mirror of
https://github.com/PDP-10/its.git
synced 2026-01-25 03:37:00 +00:00
ad5f5a0589
to new DOTIMES and DOLIST macro definitions (in the case of FASLRO, update to use DO rather than DOLIST since DOLIST no longer (as of latest UMLMAC) binds a parameter to the loop count. Resolves #1054.
415 lines
14 KiB
Common Lisp
415 lines
14 KiB
Common Lisp
;;; MLMAC -*-Mode:Lisp;Package:SI;Lowercase:T-*-
|
||
;;; *************************************************************************
|
||
;;; ***** MacLISP ******* MacLisp-only system MACros ************************
|
||
;;; *************************************************************************
|
||
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *************
|
||
;;; *************************************************************************
|
||
|
||
;; Herald is on next page, since it is defined in this file
|
||
;; (herald MLMAC /93)
|
||
|
||
(eval-when (eval compile)
|
||
(or (get 'SUBLOAD 'VERSION)
|
||
(load '((lisp) subload)))
|
||
)
|
||
|
||
|
||
(def-or-autoloadable VALUES-LIST MLSUB)
|
||
(def-or-autoloadable MULTIPLE-VALUE-LIST/| MLSUB)
|
||
(def-or-autoloadable MSETQ-CALL UMLMAC)
|
||
(def-or-autoloadable MSETQ-RETURN UMLMAC)
|
||
(def-or-autoloadable GENTEMP MACAID)
|
||
(def-or-autoloadable +INTERNAL-PERMUTIBLE-P MACAID)
|
||
|
||
|
||
;; Warning! following lines, related to a switch in location of some
|
||
;; autoloadable functions, must come before the subload of DEFMAX
|
||
;; ######## Glaaag! Remove these crocks after Nov 1981 ? -- JonL 11/12/80
|
||
(progn 'compile
|
||
(and (not (getl 'FBOUNDP '(SUBR EXPR)))
|
||
(defun FBOUNDP (x) (getl x '(SUBR FSUBR LSUBR EXPR FEXPR MACRO))))
|
||
(and (not (getl 'PAIRP '(SUBR EXPR)))
|
||
(defun PAIRP (x) (eq (typep x) 'LIST)))
|
||
)
|
||
|
||
;;Might as well - output of defmacro for HERALD will require it anyway
|
||
(subload DEFMAX)
|
||
|
||
|
||
(declare (genprefix |mmac|) )
|
||
|
||
(declare (own-symbol HERALD)
|
||
(mapex () )
|
||
(mapc '(lambda (x) (putprop x 'T 'SKIP-WARNING))
|
||
'(IF SETQ-IF-UNBOUND CATCH THROW DEFVAR DEFCONST PSETQ
|
||
WITHOUT-INTERRUPTS WITH-INTERRUPTS WITHOUT-TTY-INTERRUPTS
|
||
MULTIPLE-VALUE VALUES MULTIPLE-VALUE-BIND
|
||
MULTIPLE-VALUE-LIST MULTIPLE-VALUE-RETURN RETURN-LIST))
|
||
(muzzled T))
|
||
|
||
|
||
;;;; HERALD
|
||
|
||
(defmacro HERALD (group-name &optional (version-number '||) (ofile 'MSGFILES))
|
||
(or (symbolp group-name)
|
||
(check-type group-name #'SYMBOLP 'HERALD))
|
||
(let* ((ifile (and (filep infile)
|
||
(car (last (truename infile)))))
|
||
(v (cond ((and ifile
|
||
(fixp (car (errset (readlist (exploden ifile)) () ))))
|
||
ifile)
|
||
((symbolp version-number) version-number)
|
||
('||)))
|
||
(putpropper `(DEFPROP ,group-name ,v VERSION))
|
||
(text (symbolconc '|;Loading | group-name '| | v)) )
|
||
;; Remember, this is a maclisp-only file!
|
||
(cond ((if (get 'SHARPCONDITIONALS 'VERSION)
|
||
(featurep '(and NIL (not MacLISP)))
|
||
(status feature For-NIL))
|
||
;;This clause should be selected only when cross-compiling
|
||
;; NILAID feature set has *both* NIL and MacLISP
|
||
(setq text (get-pname text))
|
||
(setq putpropper `(PUTPROP ',group-name ',v 'VERSION)))
|
||
('T (setq text (copysymbol text () ))
|
||
(set text text)
|
||
(putprop text 'T '+INTERNAL-STRING-MARKER)
|
||
(if (status feature COMPLR)
|
||
(putprop text `(SPECIAL ,text) 'SPECIAL))
|
||
;;In older lisps, or for cross-compilation, we simply forget
|
||
;; about delaying-until-exit the putprop of version number.
|
||
(setq putpropper
|
||
`(COND ((ALPHALESSP (STATUS LISPV) '/2071) ,putpropper)
|
||
('T (PUSH #'(LAMBDA (X) (OR X ,putpropper))
|
||
FILE-EXIT-FUNCTIONS))))))
|
||
`(PROGN
|
||
(COND ((STATUS NOFEATURE NOLDMSG)
|
||
(TERPRI ,ofile)
|
||
(PRINC ,text ,ofile)))
|
||
,putpropper
|
||
',v)))
|
||
|
||
|
||
(herald MLMAC /92)
|
||
|
||
|
||
|
||
|
||
;;;; Random Macros
|
||
|
||
;; Basically, most of these "FSUBR" macros only need to be "un-cached"
|
||
;; if they are redefined.
|
||
(eval-when (eval compile)
|
||
(setq defmacro-displace-call MACROEXPANDED)
|
||
)
|
||
|
||
(defmacro IF (p c &rest a)
|
||
(cond (a `(COND (,p ,c) (T ,.a)))
|
||
(T `(AND ,p ,c))))
|
||
|
||
|
||
(defmacro SETQ-IF-UNBOUND (&rest args)
|
||
(do ((a args (cddr a))
|
||
(l () (cons `(OR (BOUNDP ',(car a)) (SETQ ,(car a) ,(cadr a))) l)))
|
||
((null a)
|
||
(cond ((null (cdr l)) (car l))
|
||
(`(PROGN ,.(nreverse l)))))))
|
||
|
||
|
||
(defmacro CATCH (&whole f comp &optional tag)
|
||
(si:catch-throw-service f comp tag '*CATCH))
|
||
|
||
(defmacro THROW (&whole f comp &optional tag)
|
||
(si:catch-throw-service f comp tag '*THROW))
|
||
|
||
(defun SI:CATCH-THROW-SERVICE (f comp tag newfun)
|
||
(si:obsolete-form-msg f newfun)
|
||
(cond ((and tag (not (symbolp tag)))
|
||
(terpri msgfiles)
|
||
(princ '|Warning! Possible syntax error -- the 'tag' part of your old | msgfiles)
|
||
(princ (car f) msgfiles)
|
||
(terpri msgfiles)
|
||
(princ '| | msgfiles)
|
||
(princ tag msgfiles)
|
||
(princ '| is not a symbol. | msgfiles)))
|
||
`(,newfun ',tag ,comp))
|
||
|
||
|
||
(defun SI:OBSOLETE-FORM-MSG (f fun)
|
||
(terpri msgfiles)
|
||
(princ '|WARNING! An obsolete form, | msgfiles)
|
||
(prin1 f msgfiles)
|
||
(terpri msgfiles)
|
||
(princ '| is being expanded - please use | msgfiles)
|
||
(princ fun msgfiles)
|
||
(princ '| instead.| msgfiles))
|
||
|
||
|
||
;;;; Variable Definers
|
||
|
||
;; (DEFVAR sym value documentation)
|
||
;; SETQ-IF-UNBOUND so can initialize a var before loading the file which
|
||
;; DEFVARs it. "documentation" is optional
|
||
;; Consider: (SETQ GRINDEF-MAGIC-PARAMETER 34.)
|
||
|
||
|
||
(defmacro DEFVAR (var &optional (val () valp) () ) ;3rd = documentation
|
||
`(PROGN 'COMPILE
|
||
(EVAL-WHEN (EVAL LOAD COMPILE)
|
||
(AND (STATUS FEATURE COMPLR) (SPECIAL ,var)))
|
||
,.(if valp `((SETQ-IF-UNBOUND ,var ,val)))
|
||
',var))
|
||
|
||
|
||
;DEFPARAMETER is similar to DEFVAR, but ALWAYS initializes the variable,
|
||
; in spite of anything else.
|
||
(defmacro DEFPARAMETER (var val &optional () ) ;3rd = documentation
|
||
`(PROGN 'COMPILE
|
||
(EVAL-WHEN (EVAL LOAD COMPILE)
|
||
(AND (STATUS FEATURE COMPLR) (SPECIAL ,var)))
|
||
(SETQ ,var ,val)
|
||
',var))
|
||
|
||
;This name is being flushed to avoid confusion with DEFCONSTANT, which
|
||
; has a trivially different name so that code will continue to work.
|
||
(macro DEFCONST (form)
|
||
(cons 'DEFPARAMETER (cdr form)))
|
||
|
||
|
||
;This is supposed to be a "manifest constant", i.e. something the compiler
|
||
; could hardwire into your code (if the implementation so warrants).
|
||
;The code is in error if there is a variable binding in effect when the
|
||
; variable is being initialized. The code is in error (and this should
|
||
; be checked but isn't) if the variable has a global value which is
|
||
; not EQUAL to the value being assigned.
|
||
(macro DEFCONSTANT (form)
|
||
(cons 'DEFPARAMETER (cdr form)))
|
||
|
||
|
||
|
||
;;;; More random macros
|
||
|
||
;; PSETQ looks like SETQ but does its work in parallel.
|
||
(defmacro PSETQ (&rest rest)
|
||
(cond ((cddr rest)
|
||
`(SETQ ,(car rest)
|
||
(PROG1 ,(cadr rest) (PSETQ . ,(cddr rest)))))
|
||
((cdr rest) `(SETQ ,.rest))
|
||
('T (error '|Odd number of args| (cons 'PSETQ rest)))))
|
||
|
||
|
||
|
||
;;; Interrupt hackers
|
||
(defmacro WITHOUT-INTERRUPTS (&body forms)
|
||
`(LET ((+INTERNAL-WITHOUT-INTERRUPTS T))
|
||
. ,forms))
|
||
|
||
(defmacro WITH-INTERRUPTS (&body forms)
|
||
`(LET ((+INTERNAL-WITHOUT-INTERRUPTS ()))
|
||
. ,forms))
|
||
|
||
(defmacro WITHOUT-TTY-INTERRUPTS (&body forms)
|
||
`(LET ((+INTERNAL-WITHOUT-INTERRUPTS 'TTY))
|
||
. ,forms))
|
||
|
||
(or (fboundp 'SELECTQ)
|
||
(equal (get 'SELECTQ 'AUTOLOAD) #%(autoload-filename UMLMAC))
|
||
(defun SELECTQ macro (x)
|
||
((lambda (n FASLOAD)
|
||
(cond ((null n))
|
||
((alphalessp n "26")
|
||
(remprop 'UMLMAC 'VERSION))
|
||
((+internal-lossage 'UMLMAC 'SELECTQ n)))
|
||
(load #%(autoload-filename UMLMAC))
|
||
(macroexpand x))
|
||
(get 'UMLMAC 'VERSION)
|
||
() )))
|
||
|
||
|
||
|
||
;;;; Multiple-value stuff
|
||
|
||
;;; Variables *:AR2 *:AR3 *:AR4 *:AR5 *:AR6 *:AR7 *:AR8 *:ARn *:ARlist
|
||
;;; are automatically specialized by the COMPLR
|
||
|
||
(eval-when (eval compile)
|
||
(setq retvec-vars '(*:AR2 *:AR3 *:AR4 *:AR5 *:AR6 *:AR7 *:AR8)
|
||
max-retvec (length retvec-vars))
|
||
)
|
||
|
||
(let ((x '#.`(*:ARlist *:ARn ,.retvec-vars)))
|
||
(if (boundp '+INTERNAL-INTERRUPT-BOUND-VARIABLES)
|
||
(or (memq '*:AR2 +INTERNAL-INTERRUPT-BOUND-VARIABLES)
|
||
(memq '*:ARlist +INTERNAL-INTERRUPT-BOUND-VARIABLES)
|
||
(setq +INTERNAL-INTERRUPT-BOUND-VARIABLES
|
||
(append x +INTERNAL-INTERRUPT-BOUND-VARIABLES)))
|
||
(setq +INTERNAL-INTERRUPT-BOUND-VARIABLES x)))
|
||
|
||
|
||
;;; *:ARn holds the number of extra-return values -- 0 at top level
|
||
;;; *:ARlist holds a list of all return values beyond the 8'th
|
||
(setq *:ARn 0 *:ARlist () )
|
||
|
||
|
||
|
||
(defun MULTIPLE-VALUE-tester/| (val)
|
||
;; Returns () if it is likely that evaluation of 'val' cannot
|
||
;; produce multiple values. T says it probably can produce them.
|
||
(cond
|
||
((atom val) () )
|
||
((eq (car val) 'VALUES) 'T)
|
||
((atom (setq val (macroexpand val))) () )
|
||
((not (atom (car val)))
|
||
(and (eq (caar val) 'LAMBDA)
|
||
(MULTIPLE-VALUE-tester/| (car (last (cddar val))))))
|
||
((not (symbolp (car val))) () )
|
||
((let ((type (sysp (car val))))
|
||
(cond
|
||
((not (memq type '(SUBR LSUBR FSUBR)))) ;;Non-system subrs might!
|
||
((eq type 'LSUBR)
|
||
(cond ((cond ((eq (car val) 'PROG2) (pop val) 'T)
|
||
((eq (car val) 'PROG1) 'T))
|
||
(and (null (cddr val))
|
||
(MULTIPLE-VALUE-tester/| (cadr val))))
|
||
((eq (car val) 'PROGN)
|
||
(MULTIPLE-VALUE-tester/| (car (last val))))
|
||
((memq (car val) '(FUNCALL APPLY EVAL LEXPR-FUNCALL SEND
|
||
SEND-AS LEXPR-SEND LEXPR-SEND-AS)))))
|
||
((eq type 'FSUBR)
|
||
(cond ((cond ((eq (car val) 'COND))
|
||
((eq (car val) 'CASEQ) (pop val) 'T))
|
||
;; COND's are permissible only if each clause is OK
|
||
(MULTIPLE-VALUE-tester-aux/|
|
||
(mapcar #'CAR (mapcar #'LAST (cdr val)))))
|
||
((eq (car val) 'OR)
|
||
(MULTIPLE-VALUE-tester-aux/| (cdr val)))
|
||
((eq (car val) 'AND)
|
||
(MULTIPLE-VALUE-tester/| (car (last val))))
|
||
((memq (car val) '(SUBRCALL LSUBRCALL))))))))))
|
||
|
||
|
||
(defun MULTIPLE-VALUE-tester-aux/| (l)
|
||
;; Check to see that each item on list l is permissible for MULTIPLE-VALUEs
|
||
(do ()
|
||
((null l) 'T)
|
||
(if (null (MULTIPLE-VALUE-tester/| (car l)))
|
||
(return () ))
|
||
(pop l)))
|
||
|
||
|
||
|
||
;;FOO! this definition must be compiled before subsequent re-definitions for
|
||
;; MULTIPLE-VALUE, so that MACROEXPAND-1*M can be properly called.
|
||
|
||
(defun MULTIPLE-VALUE-expander/|
|
||
(varlist val original &aux (nxvals 0) stql ck-no-retvals atomic-valp)
|
||
(declare (fixnum nxvals))
|
||
;;First value is normal return value -- rest are passed thru
|
||
;; the special variables *:AR2, *:AR3, ... *:AR8
|
||
;;The number of extra return values is stored in *:ARn.
|
||
;; In addition to checking everything, Returns a list of the expanded
|
||
;; 'val' form, a form to check the number of return-values, and a
|
||
;; list of pairs of things to be setq'd
|
||
(do ((ex? 'T))
|
||
((cond ((null ex?))
|
||
((not (pairp val)) (setq atomic-valp 'T) 'T)
|
||
((memq (car val) '(VALUES VALUES-LIST)))))
|
||
;;Say, there a circularity here -- omit the macroexpand for "bootstrap"
|
||
(multiple-value (val ex?) (macroexpand-1*m val)))
|
||
(cond ((null varlist) () )
|
||
;;() means no vars to be SETQ'd -- an OK case.
|
||
((or (atom varlist)
|
||
(> (setq nxvals (length (cdr varlist))) 255.)
|
||
;;Atomic "computation" can't produce "extra" multiple values
|
||
(and (> nxvals 0) atomic-valp))
|
||
(error '|Bad varlist for MULTIPLE-VALUEing macro| original))
|
||
((and (> nxvals 0)
|
||
(cond (atomic-valp 'T)
|
||
((memq (car val) '(VALUES VALUES-LIST)) () )
|
||
((not (MULTIPLE-VALUE-tester/| val)))))
|
||
;;No system function currently returns multiple values -- 2/4/81
|
||
(error "This form does not guarantee multiple return values"
|
||
original)))
|
||
(setq stql (mapcan #'(lambda (var slot) (if var (list `(,var ,slot))))
|
||
(cdr varlist)
|
||
'#.retvec-vars))
|
||
(cond ((> nxvals 0)
|
||
(setq ck-no-retvals `(AND (< *:ARn ,nxvals)
|
||
(SI:CHECK-MULTIPLICITIES ,nxvals)))
|
||
(if (> nxvals #.max-retvec)
|
||
(setq stql (nconc stql
|
||
`((,(nthcdr #.max-retvec (cdr varlist))
|
||
(PROG1 *:ARlist (SETQ *:ARlist () )))))))))
|
||
(if (not atomic-valp)
|
||
;; Shield against spurious propogation of "values" in *:ARn
|
||
(setq val `(PROG2 (SETQ *:ARn 0) ,val ,ck-no-retvals (SETQ *:ARn 0))))
|
||
(list val stql))
|
||
|
||
|
||
|
||
;;; MULTIPLE-VALUE-LIST, MULTIPLE-VALUE, MULTIPLE-VALUE-BIND, VALUES,
|
||
;;; RETURN-LIST, MULTIPLE-VALUE-RETURN
|
||
|
||
|
||
(defmacro MULTIPLE-VALUE-LIST (form)
|
||
`(PROG2 (SETQ *:ARn 0) (MULTIPLE-VALUE-LIST/| ,form)))
|
||
|
||
|
||
(defmacro MULTIPLE-VALUE (varlist val &whole original
|
||
&aux (first-var (car varlist)) (SETQer 'SETQ))
|
||
(let (((val stql)
|
||
(MULTIPLE-VALUE-expander/| varlist val original)))
|
||
;;First, see if any destructuring has to take place
|
||
(mapc #'(lambda (bind-spec)
|
||
(cond ((null bind-spec) )
|
||
((or (not (symbolp (setq bind-spec (car bind-spec))))
|
||
(memq bind-spec '(() T)))
|
||
(setq SETQer 'DESETQ))))
|
||
stql)
|
||
(if stql (setq stql `(,SETQer ,.(apply #'NCONC stql))))
|
||
(cond ((null first-var)
|
||
`(PROG1 ,val ,stql))
|
||
((symbolp first-var)
|
||
`(PROGN (SETQ ,first-var ,val)
|
||
,stql
|
||
,first-var))
|
||
((let (g)
|
||
(si:gen-local-var g)
|
||
`(LET ((,g ,val))
|
||
(DESETQ ,first-var ,g)
|
||
,stql
|
||
,g))))))
|
||
|
||
|
||
(defmacro MULTIPLE-VALUE-BIND (varsl form &body body &whole original)
|
||
;; Even though there is an explicit call macroexpand here, it should
|
||
;; only really call the macro MULTIPLE-VALUE, which probably will be
|
||
;; be redefined only when this macro is redefined too.
|
||
(let (((val letlist)
|
||
(MULTIPLE-VALUE-expander/| `(() ,.(cdr varsl)) form original)))
|
||
`(LET ((,(car varsl) ,val)
|
||
,.letlist )
|
||
,.body)))
|
||
|
||
|
||
|
||
(defmacro (VALUES defmacro-displace-call 'T) (&rest w)
|
||
(let ((nxvals (1- (length w))) (first-value (car w)) stql)
|
||
(declare (fixnum nxvals))
|
||
(if (< nxvals 1) (setq nxvals 0))
|
||
(setq stql (mapcan #'LIST '#.retvec-vars (cdr w)))
|
||
(if (> nxvals #.max-retvec)
|
||
(setq stql (nconc stql
|
||
`(*:ARlist (LIST ,.(nthcdr #.(1+ max-retvec) w))))))
|
||
(if stql (setq stql `((PSETQ ,.stql))))
|
||
`(PROG1 ,first-value
|
||
,.stql
|
||
(SETQ *:ARn ,nxvals))))
|
||
|
||
|
||
(defmacro RETURN-LIST (l)
|
||
;; Return from a PROG, spreading out the elements of the argument
|
||
;; (which should be a non-null list) into the m-v state
|
||
`(RETURN (VALUES-LIST ,l)))
|
||
|
||
(defmacro MULTIPLE-VALUE-RETURN (form) `(RETURN ,form))
|