perm filename UMACRO.LSP[SCH,LSP] blob sn#688856 filedate 1982-11-14 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 -*-LISP-*-
C00006 ENDMK
CāŠ—;
;;; -*-LISP-*-

#M(DECLARE (MACROS T))

#M(PROGN 'COMPILE
  
  (DEFMACRO MAKE-HUNK-OF-SIZE (SIZE) `(MAKHUNK ,SIZE))

  (DEFMACRO MAKE-HUNK-LIST (L) `(MAKHUNK ,L))

  (DEFMACRO MAKE-HUNK ARGS `(HUNK . ,ARGS))

  (DEFMACRO SUBR-NAME (SUBR-PTR)
    `(SUBR (MAKNUM ,SUBR-PTR)))

)



#Q(eval-when (compile eval load)
    (setq si:inhibit-fdefine-warnings t));overwrite FETCH and DISPATCH

#Q(PROGN 'COMPILE			;simulate HUNKs on LM using ARRAYs.

  (DEFMACRO MAKE-HUNK-OF-SIZE (SIZE)
    `(MAKE-ARRAY NIL 'ART-Q ,SIZE))
  
  (DEFMACRO MAKE-HUNK-LIST (Z)
    (PROG (LEN FILL TEMP)
	  (COND ((FIXP Z) (SETQ LEN Z)		
		 (SETQ FILL NIL))		
		(T (SETQ TEMP (CADR Z))		
		   (SETQ LEN (LENGTH TEMP))	
		   (SETQ FILL (APPEND (LAST TEMP) (BUTLAST TEMP)))))	
	  (RETURN
	    `(FUNCALL 'FILLARRAY (MAKE-ARRAY NIL 'ART-Q ,LEN)	
		      ',FILL))))
  
  (DEFMACRO MAKE-HUNK ARGS
    `(LET ((ANSWER-HUNK (MAKE-HUNK-OF-SIZE ',(LENGTH ARGS))))
       ,@(DO ((AL (APPEND (LAST ARGS) (BUTLAST ARGS)) (CDR AL))
	      (N 0 (+ N 1))
	      (INITS NIL))
	     ((NULL AL)
	      INITS)
	   (SETQ INITS (CONS `(ASET ,(CAR AL) ANSWER-HUNK ',N) INITS)))
       ANSWER-HUNK))
  
  (DEFMACRO CXR (N H) `(AREF ,H ,N))				
  
  (DEFMACRO RPLACX (N H X) `(ASET ,X ,H ,N))				
  
  (DEFMACRO HUNKP (H) `(ARRAYP ,H))				
  
  (DEFMACRO HUNKSIZE (H) `(ARRAY-LENGTH ,H))

  (DEFUN NOINTERRUPT (X) NIL)				;magic

  (DEFUN SPRINTER (EXP) (GRIND-TOP-LEVEL EXP))

  (DEFUN ATOMP (X) (AND (NOT (ARRAYP X)) (ATOM X)))

  (DEFUN ZAP-TO-SCHEME (FORM)
    (SETQ *SCHEME-FORMS-TO-EVAL* (APPEND *SCHEME-FORMS-TO-EVAL* (LIST FORM))))

  (DEFUN EDITOR ()
    (LET ((*SCHEME-FORMS-TO-EVAL* NIL))
      (ED)
      *SCHEME-FORMS-TO-EVAL*))
  
)

(DEFMACRO DEFUN-IMPORT (FORM BVRS . BODY)
  `(PROGN 'COMPILE
	  (SETQ *LISP-IMPORTS*
		(CONS ',FORM *LISP-IMPORTS*))
	  (DEFUN ,(IF (SYMBOLP FORM) FORM (CADR FORM)) ,BVRS
	    ,@BODY)))