mirror of
https://github.com/PDP-10/its.git
synced 2026-01-18 17:16:59 +00:00
750 lines
22 KiB
Common Lisp
Executable File
750 lines
22 KiB
Common Lisp
Executable File
;;;;;;;;;;;;;;;;;;; -*- Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
;;;(macsyma-module meta macro)
|
||
|
||
;;; GJC Some time in July 1980.
|
||
;;; a very simple meta evaluator for lisp code.
|
||
;;; the main use of this is for looking at functions
|
||
;;; which are candidates for open compilation.
|
||
;;; No. Also used to implement atomic macros in order to implement
|
||
;;; lexical DEFCLOSURE. Also used in the macsyma->lisp translator
|
||
;;; to gronk environments. Also used to implement lexicaly local macros...
|
||
|
||
#-Lispm
|
||
(herald meta-evaluator)
|
||
|
||
(eval-when (eval) ;trivial utilities
|
||
(defun ldm () (load '|libmax;meta >|))
|
||
(defmacro defo (&rest form) `(def-subr-open ,@form))
|
||
(defun oexp (x) (open-subr-expander x)))
|
||
|
||
(eval-when (compile eval)
|
||
(or (fboundp 'defstruct)
|
||
(load '((liblsp)struct))))
|
||
|
||
(defstruct (meta-var conc-name #+maclisp (TYPE NAMED-HUNK) #+lispm named)
|
||
(eval-p 0)
|
||
(setq-p 0)
|
||
special-p
|
||
name
|
||
VALUE
|
||
IN-LOOP-P ;; T if found free a PROG context.
|
||
IN-FUNARG-P
|
||
CERTAIN-EVAL-P ;; T if certain to get evaluated.
|
||
;; NIL if it might not get evaluated due to
|
||
;; RETURN, GO, or THROW.
|
||
ORDER ;; the evaluation order of the first time evaluated.
|
||
)
|
||
|
||
;;; (META-EVAL <FORM> &OPTIONAL <INTERESTING-VARS> <VAR-SUBST-LIST>)
|
||
;;; returns a list of meta-var structures of the interesting variables,
|
||
;;; when the var-subst-list is given it meta-substitutes for corresponding
|
||
;;; interesting variables.
|
||
|
||
;;; this does no alpha conversion, it is a one-pass
|
||
;;; tree walker with a method for each kind of node.
|
||
;;; Furthermore, this is for lexical variables only.
|
||
|
||
(defvar *meta-var-stack* nil)
|
||
(defvar *meta-var-eval-order-index* 0)
|
||
(DEFVAR *META-SUBST-P* NIL)
|
||
;;; if non nil then meta-eval is doing substitution,
|
||
;;; otherwise, the value returned by meta-eval is a list of
|
||
;;; meta-vars.
|
||
(DEFVAR *META-FREE-VARS* NIL)
|
||
(DEFVAR *META-CHECKING-FOR-FREE-VARS-P* NIL)
|
||
(DEFVAR *META-IN-LOOP-CONTEXT-P* nil)
|
||
(DEFVAR *META-IN-FUNARG-CONTEXT-P* NIL)
|
||
(DEFVAR *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)
|
||
|
||
(defmacro bind-meta-eval-state (&rest body)
|
||
`(let ((*meta-var-stack* nil)
|
||
(*meta-var-eval-order-index* 0)
|
||
(*meta-subst-p* nil)
|
||
(*meta-free-vars* nil)
|
||
(*meta-checking-for-free-vars-p* nil)
|
||
(*meta-in-loop-context-p* nil)
|
||
(*META-IN-CERTAIN-EVAL-CONTEXT-P* T)
|
||
(*META-IN-FUNARG-CONTEXT-P* NIL))
|
||
,@body))
|
||
|
||
(defmacro special-p (x) `(get ,x 'special))
|
||
;;; this is a system-dependant macro. In maclisp it only
|
||
;;; works in the compiler.
|
||
;;; Assuming: that the special declarations of variables are
|
||
;;; inherited in the local context. If this were not true then
|
||
;;; it would save a lot of hair and confusion, but it is true.
|
||
|
||
(defun meta-symeval (sym &aux (meta (get sym 'meta-var)))
|
||
(COND ((EQ META 'BOUND) SYM)
|
||
(META
|
||
;; not interested in this variable otherwise.
|
||
(setq *meta-var-eval-order-index*
|
||
(1+ *meta-var-eval-order-index*))
|
||
(alter-meta-var meta
|
||
IN-LOOP-P *META-IN-LOOP-CONTEXT-P*
|
||
IN-FUNARG-P *META-IN-FUNARG-CONTEXT-P*
|
||
special-p (special-p sym)
|
||
eval-p (1+ (meta-var-eval-p meta))
|
||
CERTAIN-EVAL-P (OR (META-VAR-CERTAIN-EVAL-P META)
|
||
*META-IN-CERTAIN-EVAL-CONTEXT-P*)
|
||
order (or (meta-var-order meta)
|
||
*meta-var-eval-order-index*))
|
||
|
||
(META-VAR-VALUE META))
|
||
(*META-CHECKING-FOR-FREE-VARS-P*
|
||
; in this state we a looking for all free variables.
|
||
; so create a new cell for this one.
|
||
(setq *meta-var-eval-order-index* (1+ *meta-var-eval-order-index*))
|
||
(let ((cell (make-meta-var
|
||
IN-LOOP-P *meta-in-loop-context-p*
|
||
IN-FUNARG-P *META-IN-FUNARG-CONTEXT-P*
|
||
special-p (special-p sym)
|
||
name sym
|
||
eval-p 1
|
||
CERTAIN-EVAL-P *META-IN-CERTAIN-EVAL-CONTEXT-P*
|
||
order *meta-var-eval-order-index*)))
|
||
(setf (get sym 'meta-var) cell)
|
||
(push cell *meta-free-vars*)))
|
||
(T SYM)))
|
||
|
||
(defun meta-set (sym)
|
||
(or (symbolp sym)
|
||
(meta-eval-error "Attempt to set non symbol" sym))
|
||
(let ((meta (get sym 'meta-var)))
|
||
(cond ((eq meta 'bound) sym)
|
||
(meta
|
||
(setf (meta-var-setq-p meta) (1+ (meta-var-setq-p meta)))
|
||
(setf (meta-var-special-p meta) (special-p sym))
|
||
(meta-var-value meta))
|
||
(*meta-checking-for-free-vars-p*
|
||
(let ((cell (make-meta-var setq-p 1
|
||
value sym
|
||
special-p (special-p sym)
|
||
name sym)))
|
||
(setf (get sym 'Meta-var) cell)
|
||
(push cell *meta-free-vars*))
|
||
sym))))
|
||
|
||
(DEFMACRO META-BINDV (VARL &REST BODY
|
||
&AUX (VARLG (GENSYM)))
|
||
`(LET ((,VARLG ,VARL))
|
||
(META-BINDPUSH ,VARLG)
|
||
(UNWIND-PROTECT (PROGN ,@BODY)
|
||
(META-POPV ,VARLG))))
|
||
|
||
(DEFUN META-BINDPUSH (VARL)
|
||
(MAPC #'(LAMBDA (V)
|
||
(OR (SYMBOLP V)
|
||
(META-EVAL-ERROR "Attempt to bind non symbol" V))
|
||
(PUSH (GET V 'META-VAR) *META-VAR-STACK*)
|
||
(SETF (GET V 'META-VAR) 'BOUND))
|
||
VARL))
|
||
|
||
(DEFUN META-POPV (VARL)
|
||
(MAPC #'(LAMBDA (V)
|
||
(SETF (GET V 'META-VAR)
|
||
(POP *META-VAR-STACK*)))
|
||
VARL))
|
||
|
||
|
||
(DEFUN META-EVAL (FORM
|
||
&OPTIONAL
|
||
(VARS NIL VARS-p) (SUBST-LIST))
|
||
(bind-meta-eval-state
|
||
(or vars-p
|
||
(setq *META-CHECKING-FOR-FREE-VARS-P* t))
|
||
(and subst-list
|
||
(setq *meta-subst-p*
|
||
(or (= (length vars) (length subst-list))
|
||
(meta-eval-error
|
||
"In compatible var and subst-var lengths"
|
||
(list vars subst-list)))))
|
||
|
||
(META-BINDV
|
||
VARS
|
||
(UNWIND-PROTECT
|
||
(PROGN
|
||
(COND (*META-SUBST-P*
|
||
(MAPC #'(LAMBDA (VAR VAL)
|
||
(SETF (GET VAR 'META-VAR)
|
||
(MAKE-META-VAR VALUE VAL
|
||
NAME VAR)))
|
||
VARS subst-list))
|
||
(*meta-checking-for-free-vars-p*)
|
||
(T
|
||
(MAPC #'(LAMBDA (V)
|
||
(SETF (GET V 'META-VAR)
|
||
(MAKE-META-VAR name v)))
|
||
VARS)))
|
||
(LET ((RESULT (META-EVAL-SUB FORM)))
|
||
(COND (*META-SUBST-P* RESULT)
|
||
(*meta-checking-for-free-vars-p*
|
||
*meta-free-vars*)
|
||
(t
|
||
(MAPCAR #'(LAMBDA (V) (GET V 'META-VAR)) VARS)))))
|
||
(MAPC #'(LAMBDA (V)
|
||
(SETF (GET (META-VAR-NAME V) 'META-VAR) NIL))
|
||
*META-FREE-VARS*)))))
|
||
|
||
(DEFVAR *META-SPECIAL-FORMS* NIL)
|
||
;;; a self document.
|
||
|
||
;;; DEFMETA-SPECIAL and METACALL are a team.
|
||
|
||
(DEFMACRO DEFMETA-SPECIAL (NAME &REST BODY)
|
||
`(PROGN 'COMPILE
|
||
(DEFUN (,NAME META-EVAL) (*META-FORM*)
|
||
,@BODY)
|
||
(OR (MEMQ ',NAME *META-SPECIAL-FORMS*)
|
||
(PUSH ',NAME *META-SPECIAL-FORMS*))))
|
||
|
||
(DEFMACRO METACALL (&REST ARGS) `(FUNCALL ,@ARGS))
|
||
|
||
(DEFMACRO DEFMETA-PROP-SPECIAL (NAME PROP)
|
||
`(PROGN 'COMPILE
|
||
(PUTPROP ',NAME #',PROP 'META-EVAL)
|
||
(OR (MEMQ ',NAME *META-SPECIAL-FORMS*)
|
||
(PUSH ',NAME *META-SPECIAL-FORMS*))))
|
||
|
||
(DEFUN META-EVAL-ERROR (A B)
|
||
(ERROR (FORMAT NIL "~A encountered during meta evaluation." A)
|
||
B
|
||
'fail-act))
|
||
|
||
|
||
(DEFUN META-SPECIALP (OP &AUX (DISP (GET OP 'META-EVAL)))
|
||
#+Maclisp
|
||
(COND (DISP DISP)
|
||
((GET OP 'MACRO)
|
||
#'(LAMBDA (FORM)
|
||
(META-EVAL-SUB
|
||
(FUNCALL (GET (CAR FORM) 'MACRO) FORM))))
|
||
((OR (GET OP 'SUBR)
|
||
(GET OP 'LSUBR)
|
||
(GET OP 'EXPR))
|
||
#'META-EVAL-ARGS-AND-APPLY)
|
||
((GET OP 'FSUBR)
|
||
(META-EVAL-ERROR "Uknown special form" OP))
|
||
(T
|
||
#'META-EVAL-ARGS-AND-APPLY))
|
||
#+Lispm
|
||
(COND (DISP DISP)
|
||
((FBOUNDP OP)
|
||
(LET ((BINDING (FSYMEVAL OP)))
|
||
(COND ((FUNCTIONP OP)
|
||
#'META-EVAL-ARGS-AND-APPLY)
|
||
((AND (LISTP BINDING) (EQ (CAR BINDING) 'MACRO))
|
||
#'(LAMBDA (FORM)
|
||
(META-EVAL-SUB
|
||
(FUNCALL (CDR (FSYMEVAL (CAR FORM))) FORM))))
|
||
((FUNCTIONP OP T)
|
||
(META-EVAL-ERROR "Uknown special form" OP))
|
||
(T
|
||
(META-EVAL-ERROR "BUG: strange function kind?")))))
|
||
(T
|
||
#'META-EVAL-ARGS-AND-APPLY)))
|
||
|
||
(DEFUN META-EVAL-ARGS-AND-APPLY (FORM)
|
||
(PROG1 (COND (*META-SUBST-P*
|
||
(CONS (CAR FORM) (META-EVAL-ARGS (CDR FORM))))
|
||
(T (META-EVAL-ARGS (CDR FORM))))
|
||
;; here is where we need a real-live data base.
|
||
;; there are whole classes of side-effects to think about.
|
||
(AND (FUNCTION-DOES-THROW-P (CAR FORM))
|
||
(SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL))))
|
||
|
||
(DEFUN FUNCTION-DOES-THROW-P (NAME)
|
||
; well, meta-eval the function body and see!
|
||
; assume the worst about unknown functions.
|
||
; That is the correct way to do it.
|
||
; (I don't mention the assertion data-base one would need to
|
||
; resolve circularities in unknown functions.)
|
||
; for testing just assume no throwing around.
|
||
(GET NAME 'THROW-P))
|
||
|
||
(DEFUN META-EVAL-ARGS (FORM)
|
||
(COND (*META-SUBST-P*
|
||
(MAPCAR #'META-EVAL-SUB FORM))
|
||
(T (MAPC #'META-EVAL-SUB FORM))))
|
||
|
||
(DEFUN META-EVAL-SUB (FORM)
|
||
(COND ((NULL FORM) FORM)
|
||
((ATOM FORM)
|
||
(COND ((EQ T FORM) FORM)
|
||
((SYMBOLP FORM)
|
||
(META-SYMEVAL FORM))
|
||
(T FORM)))
|
||
(T
|
||
(LET ((OP (CAR FORM)))
|
||
(COND ((ATOM OP)
|
||
(COND ((SYMBOLP OP)
|
||
(METACALL (META-SPECIALP OP) FORM))
|
||
(T
|
||
(META-EVAL-ERROR
|
||
"Non symbolic atom in operator position"
|
||
OP))))
|
||
((EQ (CAR OP)'LAMBDA)
|
||
(SETQ FORM (META-EVAL-ARGS (CDR FORM)))
|
||
(SETQ OP (META-EVAL-FIXED-LAMBDA OP))
|
||
(COND (*META-SUBST-P*
|
||
(CONS OP FORM))))
|
||
(T
|
||
(META-EVAL-ERROR
|
||
"Non-lambda expression in operator position"
|
||
OP)))))))
|
||
|
||
|
||
(DEFMETA-SPECIAL QUOTE *META-FORM*)
|
||
|
||
(DEFUN META-FUNCTION-*FUNCTION (*META-FORM*)
|
||
(SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)
|
||
(LET ((*META-IN-FUNARG-CONTEXT-P* T))
|
||
(OR (= (LENGTH *META-FORM*) 2)
|
||
(META-EVAL-ERROR
|
||
"Wrong number of args" *META-FORM*))
|
||
(COND ((ATOM (CADR *META-FORM*)) *META-FORM*)
|
||
((EQ (CAR (CADR *META-FORM*)) 'LAMBDA)
|
||
(LET ((RESULT (META-EVAL-SUB (CADR *META-FORM*))))
|
||
(COND (*META-SUBST-P*
|
||
(LIST (CAR *META-FORM*) RESULT)))))
|
||
(T
|
||
(META-EVAL-ERROR
|
||
"Non-lambda expression in FUNCTION construct"
|
||
*META-FORM*)))))
|
||
|
||
(DEFMETA-PROP-SPECIAL FUNCTION META-FUNCTION-*FUNCTION)
|
||
(DEFMETA-PROP-SPECIAL *FUNCTION META-FUNCTION-*FUNCTION)
|
||
|
||
(DEFUN META-EVAL-FIXED-LAMBDA (*META-FORM*)
|
||
; (LAMBDA ARGS . BODY)
|
||
(COND ((CDR *META-FORM*)
|
||
(COND ((AND (CADR *META-FORM*) (ATOM (CADR *META-FORM*)))
|
||
(META-EVAL-ERROR
|
||
"Bad lambda list internally" (cadr *META-FORM*)))
|
||
(T
|
||
(LET ((BODY
|
||
(META-BINDV
|
||
(CADR *META-FORM*)
|
||
(META-EVAL-ARGS (CDDR *META-FORM*)))))
|
||
(COND (*META-SUBST-P*
|
||
(LIST* (CAR *META-FORM*)
|
||
(CADR *META-FORM*)
|
||
BODY)))))))
|
||
(T
|
||
(META-EVAL-ERROR
|
||
"Bad lambda expression" *META-FORM*))))
|
||
|
||
(DEFMETA-SPECIAL PROGN (META-EVAL-ARGS-AND-APPLY *META-FORM*))
|
||
|
||
(DEFMETA-SPECIAL SETQ
|
||
(DO ((ARGS (CDR *META-FORM*))
|
||
(VAR)(VAL)
|
||
(NEWBODY NIL))
|
||
((NULL ARGS)
|
||
(COND (*META-SUBST-P*
|
||
; might as well turn it into a SETF
|
||
; this is a useful thing for atomic macros.
|
||
(CONS 'SETF (NREVERSE NEWBODY)))))
|
||
(SETQ VAR (META-SET (POP ARGS)))
|
||
(AND *META-SUBST-P* (PUSH VAR NEWBODY))
|
||
(OR ARGS
|
||
(META-EVAL-ERROR "Setq with odd number of arguments"
|
||
*META-FORM*))
|
||
(SETQ VAL (META-EVAL-SUB (POP ARGS)))
|
||
(AND *META-SUBST-P* (PUSH VAL NEWBODY))
|
||
))
|
||
|
||
(DEFUN VAR-OF-LET-PAIR (LET-PAIR)
|
||
;; LET-PAIR can be FOO or (FOO) or (FOO BAR)
|
||
(COND ((ATOM LET-PAIR) LET-PAIR)
|
||
(T (CAR LET-PAIR))))
|
||
|
||
(DEFUN CODE-OF-LET-PAIR (LET-PAIR)
|
||
(COND ((ATOM LET-PAIR) NIL)
|
||
((NULL (CDR LET-PAIR)) NIL)
|
||
(T (CADR LET-PAIR))))
|
||
|
||
(DEFMETA-SPECIAL META-LET
|
||
(DO ((LET-PAIRS (CADR *META-FORM*) (CDR LET-PAIRS))
|
||
(BODY `(PROGN ,@(CDDR *META-FORM*)))
|
||
(VARS NIL (CONS (VAR-OF-LET-PAIR (CAR LET-PAIRS)) VARS))
|
||
(VALS NIL
|
||
(CONS (EVAL (CODE-OF-LET-PAIR (CAR LET-PAIRS))) VALS)))
|
||
((NULL LET-PAIRS))
|
||
(PROGV VARS
|
||
VALS
|
||
(META-EVAL-SUB BODY))))
|
||
|
||
(DEFMETA-SPECIAL PROG
|
||
|
||
(let ((*meta-in-loop-context-p* *meta-in-loop-context-p*))
|
||
; We go along evaluating the forms in the prog.
|
||
; Our state changes if we see a TAG, a GO, or a RETURN.
|
||
(COND ((CDR *META-FORM*)
|
||
(COND ((AND (CADR *META-FORM*) (ATOM (CADR *META-FORM*)))
|
||
(META-EVAL-ERROR
|
||
"Bad PROG var list" (CADR *META-FORM*)))
|
||
(T
|
||
(META-BINDV
|
||
(CADR *META-FORM*)
|
||
(COND (*META-SUBST-P*
|
||
`(PROG ,(CADR *META-FORM*)
|
||
,@(MAPCAR
|
||
#'(LAMBDA
|
||
(U)
|
||
(COND ((ATOM U)
|
||
(SETQ *META-IN-LOOP-CONTEXT-P* T)
|
||
U)
|
||
(T
|
||
(META-EVAL-SUB U))))
|
||
(CDDR *META-FORM*))))
|
||
(T
|
||
(MAPC #'(LAMBDA (U)
|
||
(COND ((ATOM U)
|
||
(SETQ *META-IN-LOOP-CONTEXT-P* T))
|
||
(T
|
||
(META-EVAL-SUB U))))
|
||
(CDDR *META-FORM*))))))
|
||
(T
|
||
(META-EVAL-ERROR "Bad PROG" *META-FORM*)))))))
|
||
|
||
(DEFMETA-SPECIAL GO
|
||
(PROG1
|
||
(COND ((CDR *META-FORM*)
|
||
(COND ((ATOM (CADR *META-FORM*)) *META-FORM*)
|
||
(T
|
||
(META-EVAL-ARGS-AND-APPLY *META-FORM*))))
|
||
(T
|
||
(META-EVAL-ERROR "Bad GO form" *META-FORM*)))
|
||
(SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)))
|
||
|
||
(DEFMETA-SPECIAL RETURN
|
||
(PROG1 (META-EVAL-ARGS-AND-APPLY *META-FORM*)
|
||
(SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)))
|
||
|
||
(COMMENT |
|
||
CATCH-BARRIER UWRITE SUBRCALL ARRAY UFILE DEFUN SETF STORE
|
||
UKILL BREAK PROG UREAD UPROBE UAPPEND CRUNIT EVAL-WHEN ERRSET
|
||
FUNCTION COND DECLARE CATCH *FUNCTION
|
||
FASLOAD PROGV DO GCTWA GO THROW POP LSUBRCALL OR STATUS SIGNP
|
||
ARRAYCALL INCLUDE CATCHALL *CATCH ERR COMMENT SSTATUS AND
|
||
QUOTE UCLOSE PUSH UNWIND-PROTECT CASEQ SETQ DEFPROP
|
||
|)
|
||
|
||
(DEFUN IDENTITY1 (X) X)
|
||
(DEFMACRO DEFMETA-SPECIAL-IDENTITY (X) `(DEFMETA-PROP-SPECIAL ,X IDENTITY1))
|
||
|
||
(DEFMETA-SPECIAL-IDENTITY UWRITE)
|
||
(DEFMETA-SPECIAL-IDENTITY UFILE)
|
||
(DEFMETA-SPECIAL-IDENTITY UKILL)
|
||
(DEFMETA-SPECIAL-IDENTITY UREAD)
|
||
(DEFMETA-SPECIAL-IDENTITY UPROBE)
|
||
(DEFMETA-SPECIAL-IDENTITY UCLOSE)
|
||
(DEFMETA-SPECIAL-IDENTITY UAPPEND)
|
||
(DEFMETA-SPECIAL-IDENTITY CRUNIT)
|
||
(DEFMETA-SPECIAL-IDENTITY FASLOAD)
|
||
(DEFMETA-SPECIAL-IDENTITY DEFPROP)
|
||
(DEFMETA-SPECIAL-IDENTITY COMMENT)
|
||
(DEFMETA-SPECIAL-IDENTITY INCLUDE)
|
||
|
||
(DEFUN META-EVAL-AND-OR-ARGS (ARGS)
|
||
(COND (*META-SUBST-P*
|
||
(LIST* (PROG1 (META-EVAL-SUB (CAR ARGS))
|
||
(SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL))
|
||
(META-EVAL-ARGS (CDR ARGS))))
|
||
(T
|
||
(META-EVAL-SUB (CAR ARGS))
|
||
(SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)
|
||
(META-EVAL-ARGS (CDR ARGS)))))
|
||
|
||
(DEFUN META-EVAL-AND-OR (*META-FORM*)
|
||
(COND (*META-SUBST-P*
|
||
(CONS (CAR *META-FORM*) (META-EVAL-AND-OR-ARGS (CDR *META-FORM*))))
|
||
(T (META-EVAL-AND-OR-ARGS (CDR *META-FORM*)))))
|
||
|
||
(DEFMETA-PROP-SPECIAL AND META-EVAL-AND-OR)
|
||
(DEFMETA-PROP-SPECIAL OR META-EVAL-AND-OR)
|
||
|
||
(DEFMETA-SPECIAL COND
|
||
(DO ((FORMS (CDR *META-FORM*) (CDR FORMS))
|
||
(CLAUSE) (NEWBODY))
|
||
((NULL FORMS)
|
||
(COND (*META-SUBST-P*
|
||
`(COND ,@(NREVERSE NEWBODY)))))
|
||
(AND (ATOM (CAR FORMS))
|
||
(META-EVAL-ERROR "Bad COND clause" (CAR FORMS)))
|
||
; will side-effect *META-IN-CERTAIN-EVAL-CONTEXT-P*
|
||
(SETQ CLAUSE (META-EVAL-AND-OR-ARGS (CAR FORMS)))
|
||
(AND *META-SUBST-P*
|
||
(PUSH CLAUSE NEWBODY))))
|
||
|
||
|
||
(DEFUN META-CALL-SERIES (*META-FORM*
|
||
&AUX
|
||
(RESULT (META-EVAL-ARGS (CDDR *META-FORM*))))
|
||
(COND (*META-SUBST-P*
|
||
(LIST* (CAR *META-FORM*)
|
||
(CADR *META-FORM*)
|
||
RESULT))))
|
||
|
||
(DEFMETA-PROP-SPECIAL SUBRCALL META-CALL-SERIES)
|
||
(DEFMETA-PROP-SPECIAL LSUBRCALL META-CALL-SERIES)
|
||
(DEFMETA-PROP-SPECIAL ARRAYCALL META-CALL-SERIES)
|
||
(DEFMETA-PROP-SPECIAL ERRSET META-EVAL-ARGS-AND-APPLY)
|
||
(DEFMETA-SPECIAL-IDENTITY ARRAY)
|
||
(DEFMETA-SPECIAL BREAK ; (BREAK <TAG> <PRED>)
|
||
(COND ((= (LENGTH *META-FORM*) 3)
|
||
(LET ((RESULT (META-EVAL-SUB (CADDR *META-FORM*))))
|
||
(COND (*META-SUBST-P*
|
||
(LIST (CAR *META-FORM*)
|
||
(CADR *META-FORM*)
|
||
RESULT)))))
|
||
(T
|
||
(META-EVAL-ERROR "Bad BREAK form" *META-FORM*))))
|
||
(DEFMETA-SPECIAL DEFUN
|
||
(META-EVAL-ERROR "DEFUN in the middle of code" *META-FORM*))
|
||
(DEFMETA-SPECIAL EVAL-WHEN
|
||
(META-EVAL-ERROR "EVAL-WHEN inside code" *META-FORM*))
|
||
|
||
(DEFMETA-SPECIAL
|
||
DECLARE
|
||
(COND (*META-SUBST-P*
|
||
(CONS 'DECLARE
|
||
(MAPCAR #'META-EVAL-ARGS-AND-APPLY
|
||
(CDR *META-FORM*))))
|
||
(t
|
||
; this part depends on meta-symeval
|
||
(mapc #'(lambda
|
||
(dform)
|
||
(cond ((atom dform))
|
||
((eq (car dform) 'special)
|
||
(mapc #'(lambda
|
||
(var)
|
||
(cond ((atom var)
|
||
(let ((meta
|
||
(get var 'meta-var)))
|
||
(cond ((eq meta 'bound))
|
||
(meta
|
||
(setf (meta-var-special-p meta)
|
||
t))
|
||
(*META-CHECKING-FOR-FREE-VARS-P*
|
||
; a local declaration for
|
||
; a global variable?
|
||
; poo-poo.
|
||
nil)
|
||
(t nil))))))
|
||
(cdr dform)))))
|
||
(cdr *meta-form*)))))
|
||
|
||
(DEFMETA-SPECIAL STORE
|
||
(OR (= (LENGTH *META-FORM*) 3)
|
||
(META-EVAL-ERROR "Wrong number of args to STORE" *META-FORM*))
|
||
(LET ((RES (META-EVAL-ARGS (CDR *META-FORM*))))
|
||
(COND (*META-SUBST-P*
|
||
(CONS 'STORE RES)))))
|
||
|
||
;;; the obsolete catch and throw. second arg is the tag. un-evaluated.
|
||
|
||
(DEFUN META-EVAL-CATCH-THROW (*META-FORM*)
|
||
(PROG1
|
||
(CASEQ (LENGTH *META-FORM*)
|
||
(2 (META-EVAL-ARGS-AND-APPLY *META-FORM*))
|
||
(3 (COND (*META-SUBST-P*
|
||
(LIST* (CAR *META-FORM*)
|
||
(META-EVAL-SUB (CADR *META-FORM*))
|
||
(CDDR *META-FORM*)))
|
||
(T (META-EVAL-SUB (CADR *META-FORM*)))))
|
||
(T
|
||
(META-EVAL-ERROR
|
||
"Wrong number of args" *META-FORM*)))
|
||
(SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)))
|
||
|
||
(DEFMETA-PROP-SPECIAL CATCH meta-eval-catch-throw)
|
||
(DEFMETA-PROP-SPECIAL THROW meta-eval-catch-throw)
|
||
|
||
|
||
(DEFMETA-PROP-SPECIAL *CATCH META-EVAL-ARGS-AND-APPLY)
|
||
(DEFMETA-PROP-SPECIAL CATCHALL META-EVAL-ARGS-AND-APPLY)
|
||
(DEFMETA-PROP-SPECIAL CATCH-BARRIER META-EVAL-ARGS-AND-APPLY)
|
||
(DEFMETA-PROP-SPECIAL UNWIND-PROTECT META-EVAL-ARGS-AND-APPLY)
|
||
|
||
(DEFMETA-SPECIAL ERR
|
||
(COND ((> (LENGTH *META-FORM*) 1)
|
||
(LET ((RES (META-EVAL-SUB (CADR *META-FORM*))))
|
||
(COND (*META-SUBST-P*
|
||
(LIST* 'ERR RES (CDDR *META-FORM*))))))
|
||
(T *META-FORM*)))
|
||
|
||
(DEFMETA-PROP-SPECIAL PROGV META-EVAL-ARGS-AND-APPLY)
|
||
|
||
#.(PROGN (SETQ DO-NULL-SLOT '%%%DO-NULL-SLOT%%%) NIL)
|
||
|
||
(DEFUN DO-INIT-FORM-META-CHECK (U)
|
||
(COND ((OR (NULL U) (ATOM U))
|
||
(META-EVAL-ERROR
|
||
"Bad DO var iterate form" U))
|
||
((CDR U)
|
||
(META-EVAL-SUB (CADR U)))
|
||
(T
|
||
'#.DO-NULL-SLOT)))
|
||
|
||
(DEFUN DO-ITER-FORM-META-CHECK (U)
|
||
(COND ((NULL (CDDR U)) '#.DO-NULL-SLOT)
|
||
(T (META-EVAL-SUB (CADDR U)))))
|
||
|
||
(DEFMETA-SPECIAL DO ; (DO (<FORML>) ...)
|
||
(let ((*meta-in-loop-context-p* *META-IN-LOOP-CONTEXT-P*))
|
||
|
||
(OR (> (LENGTH *META-FORM*) 2)
|
||
(META-EVAL-ERROR "Bad DO form" *META-FORM*))
|
||
(AND (CADR *META-FORM*)
|
||
(ATOM (CADR *META-FORM*))
|
||
(META-EVAL-ERROR "Bad DO var list" (CADR *META-FORM*)))
|
||
(LET (INIT-FORMS ITER-FORMS VARS ENDFORMS BODY)
|
||
(COND (*META-SUBST-P*
|
||
(SETQ INIT-FORMS
|
||
(MAPCAR #'DO-INIT-FORM-META-CHECK
|
||
(CADR *META-FORM*))))
|
||
(T (MAPC #'DO-INIT-FORM-META-CHECK (CADR *META-FORM*))))
|
||
(SETQ VARS (MAPCAR #'CAR (CADR *META-FORM*)))
|
||
(META-BINDV
|
||
VARS
|
||
(SETQ *META-IN-LOOP-CONTEXT-P* T)
|
||
(AND (OR (NULL (CADDR *META-FORM*))
|
||
(ATOM (CADDR *META-FORM*)))
|
||
(META-EVAL-ERROR "Bad end clause in DO"
|
||
(CADDR *META-FORM*)))
|
||
(SETQ ENDFORMS (META-EVAL-AND-OR-ARGS (CADDR *META-FORM*)))
|
||
(COND (*META-SUBST-P*
|
||
(SETQ ITER-FORMS
|
||
(MAPCAR #'DO-ITER-FORM-META-CHECK
|
||
(CADR *META-FORM*))))
|
||
(T (MAPC #'DO-ITER-FORM-META-CHECK
|
||
(CADR *META-FORM*))))
|
||
(SETQ BODY (META-EVAL-ARGS (CDDDR *META-FORM*))))
|
||
(COND (*META-SUBST-P*
|
||
`(DO ,(MAPCAR
|
||
#'(LAMBDA (VAR INIT ITER)
|
||
(COND ((EQ INIT
|
||
'#.DO-NULL-SLOT)
|
||
(LIST VAR))
|
||
((EQ ITER
|
||
'#.DO-NULL-SLOT)
|
||
(LIST VAR INIT))
|
||
(T
|
||
(LIST VAR INIT ITER))))
|
||
VARS INIT-FORMS ITER-FORMS)
|
||
,ENDFORMS
|
||
,@BODY))))))
|
||
|
||
(DEFMETA-SPECIAL-IDENTITY GCTWA)
|
||
|
||
(DEFMETA-SPECIAL SIGNP ; (SIGNP C X)
|
||
(OR (= (LENGTH *META-FORM*) 3)
|
||
(ERROR "Wrong number of args to SIGNP" *META-FORM*))
|
||
(LET ((RES (META-EVAL-SUB (CADDR *META-FORM*))))
|
||
(COND (*META-SUBST-P*
|
||
(LIST 'SIGNP (CADR *META-FORM*) RES)))))
|
||
|
||
(DEFUN META-STATUS-SSTATUS-EVAL (*META-FORM*)
|
||
(COND ((< (LENGTH *META-FORM*) 3) *META-FORM*)
|
||
(T
|
||
(CASEQ (CADR *META-FORM*)
|
||
((FEATURE NOFEATURE) *META-FORM*)
|
||
(T
|
||
(LET ((RESULT (META-EVAL-ARGS (CDDR *META-FORM*))))
|
||
(COND (*META-SUBST-P*
|
||
(LIST* (CAR *META-FORM*)
|
||
(CADR *META-FORM*)
|
||
RESULT)))))))))
|
||
|
||
|
||
(DEFMETA-PROP-SPECIAL STATUS META-STATUS-SSTATUS-EVAL)
|
||
(DEFMETA-PROP-SPECIAL SSTATUS META-STATUS-SSTATUS-EVAL)
|
||
|
||
|
||
; this next are new fsubrs. which have macro properties in the compiler.
|
||
|
||
(DEFUN CASEQ-META-EVAL (CASE)
|
||
(COND ((ATOM CASE)
|
||
(META-EVAL-ERROR "Bad CASEQ clause" CASE))
|
||
(*META-SUBST-P*
|
||
(CONS (CAR CASE) (META-EVAL-ARGS (CDR CASE))))
|
||
(T (META-EVAL-ARGS (CDR CASE)))))
|
||
|
||
(DEFMETA-SPECIAL CASEQ
|
||
(OR (CDR *META-FORM*)
|
||
(META-EVAL-ERROR "Bad CASEQ form" *META-FORM*))
|
||
(LET ((CASEQ (META-EVAL-SUB (CADR *META-FORM*))))
|
||
(SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)
|
||
(COND (*META-SUBST-P*
|
||
(LIST* 'CASEQ CASEQ
|
||
(MAPCAR #'CASEQ-META-EVAL
|
||
(CDDR *META-FORM*))))
|
||
(T
|
||
(MAPC #'CASEQ-META-EVAL
|
||
(CDDR *META-FORM*))))))
|
||
|
||
#+Maclisp
|
||
(progn 'compile
|
||
|
||
(DEFMETA-SPECIAL PUSH
|
||
(META-EVAL-SUB (+INTERNAL-PUSH-X (CDR *META-FORM*) NIL)))
|
||
(DEFMETA-SPECIAL POP
|
||
(META-EVAL-SUB (+INTERNAL-POP-X (CDR *META-FORM*) NIL)))
|
||
(DEFMETA-SPECIAL SETF
|
||
(META-EVAL-SUB (+INTERNAL-SETF-X (CDR *META-FORM*) NIL)))
|
||
|
||
(SETQ *META-EVAL-MISSING* NIL)
|
||
(MAPATOMS #'(LAMBDA (U)
|
||
(AND (GET U 'FSUBR)
|
||
(NOT (OR (GET U 'MACRO)
|
||
(GET U 'META-EVAL)))
|
||
(PUSH U *META-EVAL-MISSING*))))
|
||
)
|
||
|
||
|
||
#+Maclisp
|
||
(defmacro defopen (fname argl &rest body)
|
||
`(progn 'compile
|
||
(eval-when (compile)
|
||
(defprop ,fname (integrate-subr) source-trans)
|
||
(defprop ,fname (,(preprocess-argl argl)
|
||
,(preprocess-body body))
|
||
open-coding-info))
|
||
(defun ,fname ,argl ,@body)))
|
||
|
||
|
||
#+Maclisp
|
||
(defun preprocess-argl (argl)
|
||
(mapcar #'(lambda (x)
|
||
(if (memq x '(&rest &optional &aux))
|
||
(error "not allowed in defopen, -sorry" x)
|
||
x))
|
||
argl))
|
||
|
||
(defun preprocess-body (body)
|
||
(if (null (cdr body))
|
||
(car body)
|
||
`(Progn ,@body)))
|
||
|
||
(defun integrate-subr (form)
|
||
(values (integrate-subr-1 form) t))
|
||
|
||
(defun integrate-subr-1 (form)
|
||
(let ((info (get (car form) 'open-coding-info)))
|
||
(let ((argl (car info))
|
||
(body (cadr info)))
|
||
(if (= (length (cdr form))
|
||
(length argl))
|
||
(let ((temps (mapcar #'(lambda (ignore) (gensym)) argl)))
|
||
`((lambda ,temps
|
||
,(meta-eval body argl temps))
|
||
,@(cdr form)))
|
||
(integrate-subr-1 (error "wrong number of arguments in form" form
|
||
'wrng-no-args))))))
|
||
|