diff options
Diffstat (limited to 'src/interp/macros.lisp.pamphlet')
| -rw-r--r-- | src/interp/macros.lisp.pamphlet | 791 |
1 files changed, 54 insertions, 737 deletions
diff --git a/src/interp/macros.lisp.pamphlet b/src/interp/macros.lisp.pamphlet index 5437ae2d..1cd2f731 100644 --- a/src/interp/macros.lisp.pamphlet +++ b/src/interp/macros.lisp.pamphlet @@ -140,16 +140,8 @@ ends up being [[CONTAINED |$EmptyMode| Y]]. <<*>>= <<license>> -(import-module "sys-constants") +(import-module "sys-macros") (in-package "BOOT") - -(defvar |$compilingMap| ()) -(defvar |$definingMap| nil) - -(defmacro KAR (ARG) `(ifcar ,arg)) -(defmacro KDR (ARG) `(ifcdr ,arg)) -(defmacro KADR (ARG) `(ifcar (ifcdr ,arg))) -(defmacro KADDR (ARG) `(ifcar (ifcdr (ifcdr ,arg)))) ; 5 PROGRAM STRUCTURE @@ -159,9 +151,6 @@ ends up being [[CONTAINED |$EmptyMode| Y]]. ; 5.3.2 Declaring Global Variables and Named Constants -(defmacro |function| (name) `(FUNCTION ,name)) -(defmacro |dispatchFunction| (name) `(FUNCTION ,name)) - (defun |functionp| (fn) (if (identp fn) (and (fboundp fn) (not (macro-function fn))) (functionp fn))) (defun |macrop| (fn) (and (identp fn) (macro-function fn))) @@ -172,20 +161,6 @@ ends up being [[CONTAINED |$EmptyMode| Y]]. ; 6.3 Equality Predicates -;; qeqcar should be used when you know the first arg is a pair -;; the second arg should either be a literal fixnum or a symbol -;; the car of the first arg is always of the same type as the second -;; use eql unless we are sure fixnums are represented canonically - -#-lucid -(defmacro qeqcar (x y) - (if (integerp y) `(eql (the fixnum (qcar ,x)) (the fixnum ,y)) - `(eq (qcar ,x) ,y))) - -#+lucid -(defmacro qeqcar (x y) `(eq (qcar ,x) ,y)) - - (defun COMPARE (X Y) "True if X is an atom or X and Y are lists and X and Y are equal up to X." (COND ((ATOM X) T) @@ -216,208 +191,20 @@ ends up being [[CONTAINED |$EmptyMode| Y]]. ((EQUAL U V)) ((NOT (string> (write-to-string U) (write-to-string V)))))) -(defmacro boot-equal (a b) - (cond ((ident-char-lit a) - `(or (eql ,a ,b) (eql (character ,a) ,b))) - ((ident-char-lit b) - `(or (eql ,a ,b) (eql ,a (character ,b)))) - (t `(eqqual ,a ,b)))) - -(defun ident-char-lit (x) - (and (eqcar x 'quote) (identp (cadr x)) (= (length (pname (cadr x))) 1))) - -(defmacro EQQUAL (a b) - (cond ((OR (EQUABLE a) (EQUABLE b)) `(eq ,a ,b)) - ((OR (numberp a) (numberp b)) `(eql ,a ,b)) - (t `(equal ,a ,b)))) - -(defmacro NEQUAL (a b) `(not (BOOT-EQUAL ,a ,b))) - -(defun EQUABLE (X) - (OR (NULL X) (AND (EQCAR X 'QUOTE) (symbolp (CADR X))))) - ; 7 CONTROL STRUCTURE ; 7.1 Constants and Variables ; 7.1.1 Reference -(DEFUN MKQ (X) - "Evaluates an object and returns it with QUOTE wrapped around it." - (if (NUMBERP X) X (LIST 'QUOTE X))) - ; 7.2 Generalized Variables -(defmacro IS (x y) `(dcq ,y ,x)) - -(defmacro LETT (var val &rest L) - (COND - (|$QuickLet| `(SETQ ,var ,val)) - (|$compilingMap| - ;; map tracing - `(PROGN - (SETQ ,var ,val) - (COND (|$letAssoc| - (|mapLetPrint| ,(MKQ var) - ,var - (QUOTE ,(KAR L)))) - ('T ,var)))) - ;; used for LETs in SPAD code --- see devious trick in COMP,TRAN,1 - ((ATOM var) - `(PROGN - (SETQ ,var ,val) - (IF |$letAssoc| - ,(cond ((null (cdr l)) - `(|letPrint| ,(MKQ var) ,var (QUOTE ,(KAR L)))) - ((and (eqcar (car l) 'SPADCALL) (= (length (car l)) 3)) - `(|letPrint3| ,(MKQ var) ,var ,(third (car l)) (QUOTE ,(KADR L)))) - (t `(|letPrint2| ,(MKQ var) ,(car l) (QUOTE ,(KADR L)))))) - ,var)) - ('T (ERROR "Cannot compileLET construct")))) - -(defmacro SPADLET (A B) - (if (ATOM A) `(SETQ ,A ,B) - `(OR (IS ,B ,A) (LET_ERROR ,(MK_LEFORM A) ,(MKQ B) )))) - -(defmacro RPLAC (&rest L) - (if (EQCAR (CAR L) 'ELT) - (LIST 'SETELT (CADAR L) (CADDR (CAR L)) (CADR L)) - (let ((A (CARCDREXPAND (CAR L) NIL)) (B (CADR L))) - (COND ((CDDR L) (ERROR 'RPLAC)) - ((EQCAR A 'CAR) (LIST 'RPLACA (CADR A) B)) - ((EQCAR A 'CDR) (LIST 'RPLACD (CADR A) B)) - ((ERROR 'RPLAC)))))) - -(MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'SELCODE (CADR J))) - '((CAR 2) (CDR 3) (CAAR 4) (CADR 5) (CDAR 6) (CDDR 7) - (CAAAR 8) (CAADR 9) (CADAR 10) (CADDR 11) (CDAAR 12) - (CDADR 13) (CDDAR 14) (CDDDR 15) (CAAAAR 16) (CAAADR 17) - (CAADAR 18) (CAADDR 19) (CADAAR 20) (CADADR 21) (CADDAR 22) - (CADDDR 23) (CDAAAR 24) (CDAADR 25) (CDADAR 26) (CDADDR 27) - (CDDAAR 28) (CDDADR 29) (CDDDAR 30) (CDDDDR 31))) - -(eval-when (compile eval load) -(defun CARCDREXPAND (X FG) ; FG = TRUE FOR CAR AND CDR - (let (n hx) - (COND ((ATOM X) X) - ((SETQ N (GET (RENAME (SETQ HX (CARCDREXPAND (CAR X) FG))) 'SELCODE)) - (CARCDRX1 (CARCDREXPAND (CADR X) FG) N FG)) - ((CONS HX (MAPCAR #'(LAMBDA (Y) (CARCDREXPAND Y FG)) (CDR X))))))) - -(DEFUN RENAME (U) - (let (x) - (if (AND (IDENTP U) (SETQ X (GET U 'NEWNAM))) X U))) - -(defun CARCDRX1 (X N FG) ; FG = TRUE FOR CAR AND CDR - (COND ((< N 1) (fail)) - ((EQL N 1) X) - ((let ((D (DIVIDE N 2))) - (CARCDRX1 (LIST (if (EQL (CADR D) 0) (if FG 'CAR 'CAR) (if FG 'CDR 'CDR)) X) - (CAR D) - FG)))))) - - ; 7.3 Function Invocation -(DEFUN APPLYR (L X) (if (not L) X (LIST (CAR L) (APPLYR (CDR L) X)))) - ; 7.8 Iteration ; 7.8.2 General Iteration -(defmacro REPEAT (&rest L) - (let ((U (REPEAT-TRAN L NIL))) (-REPEAT (CDR U) (CAR U)))) - -(defun REPEAT-TRAN (L LP) - (COND ((ATOM L) (ERROR "REPEAT FORMAT ERROR")) - ((MEMBER (KAR (KAR L)) - '(EXIT RESET IN ON GSTEP ISTEP STEP GENERAL UNTIL WHILE SUCHTHAT EXIT)) - (REPEAT-TRAN (CDR L) (CONS (CAR L) LP))) - ((CONS (NREVERSE LP) (MKPF L 'PROGN))))) - -(DEFUN MKPF (L OP) - (if (FLAGP OP 'NARY) (SETQ L (MKPFFLATTEN-1 L OP NIL))) - (MKPF1 L OP)) - -(DEFUN MKPFFLATTEN (X OP) - (COND ((ATOM X) X) - ((EQL (CAR X) OP) (CONS OP (MKPFFLATTEN-1 (CDR X) OP NIL))) - ((CONS (MKPFFLATTEN (CAR X) OP) (MKPFFLATTEN (CDR X) OP))))) - -(DEFUN MKPFFLATTEN-1 (L OP R) - (let (X) - (if (NULL L) - R - (MKPFFLATTEN-1 (CDR L) OP - (APPEND R (if (EQCAR (SETQ X - (MKPFFLATTEN (CAR L) OP)) OP) - (CDR X) (LIST X))))))) - -(DEFUN MKPF1 (L OP) - (let (X) (case OP (PLUS (COND ((EQL 0 (SETQ X (LENGTH - (SETQ L (S- L '(0 (ZERO))))))) 0) - ((EQL 1 X) (CAR L)) - ((CONS 'PLUS L)) )) - (TIMES (COND ((S* L '(0 (ZERO))) 0) - ((EQL 0 (SETQ X (LENGTH - (SETQ L (S- L '(1 (ONE))))))) 1) - ((EQL 1 X) (CAR L)) - ((CONS 'TIMES L)) )) - (QUOTIENT (COND ((GREATERP (LENGTH L) 2) (fail)) - ((EQL 0 (CAR L)) 0) - ((EQL (CADR L) 1) (CAR L)) - ((CONS 'QUOTIENT L)) )) - (MINUS (COND ((CDR L) (FAIL)) - ((NUMBERP (SETQ X (CAR L))) (MINUS X)) - ((EQCAR X 'MINUS) (CADR X)) - ((CONS 'MINUS L)) )) - (DIFFERENCE (COND ((GREATERP (LENGTH L) 2) (FAIL)) - ((EQUAL (CAR L) (CADR L)) '(ZERO)) - ((|member| (CAR L) '(0 (ZERO))) (MKPF (CDR L) 'MINUS)) - ((|member| (CADR L) '(0 (ZERO))) (CAR L)) - ((EQCAR (CADR L) 'MINUS) - (MKPF (LIST (CAR L) (CADADR L)) 'PLUS)) - ((CONS 'DIFFERENCE L)) )) - (EXPT (COND ((GREATERP (LENGTH L) 2) (FAIL)) - ((EQL 0 (CADR L)) 1) - ((EQL 1 (CADR L)) (CAR L)) - ((|member| (CAR L) '(0 1 (ZERO) (ONE))) (CAR L)) - ((CONS 'EXPT L)) )) - (OR (COND ((MEMBER 'T L) ''T) - ((EQL 0 (SETQ X (LENGTH (SETQ L (REMOVE NIL L))))) NIL) - ((EQL 1 X) (CAR L)) - ((CONS 'OR L)) )) - (|or| (COND ((MEMBER 'T L) 'T) - ((EQL 0 (SETQ X (LENGTH (SETQ L (REMOVE NIL L))))) NIL) - ((EQL 1 X) (CAR L)) - ((CONS 'or L)) )) - (NULL (COND ((CDR L) (FAIL)) - ((EQCAR (CAR L) 'NULL) (CADAR L)) - ((EQL (CAR L) 'T) NIL) - ((NULL (CAR L)) ''T) - ((CONS 'NULL L)) )) - (|and| (COND ((EQL 0 (SETQ X (LENGTH - (SETQ L (REMOVE T (REMOVE '|true| L)))))) T) - ((EQL 1 X) (CAR L)) - ((CONS '|and| L)) )) - (AND (COND ((EQL 0 (SETQ X (LENGTH - (SETQ L (REMOVE T (REMOVE '|true| L)))))) ''T) - ((EQL 1 X) (CAR L)) - ((CONS 'AND L)) )) - (PROGN (COND ((AND (NOT (ATOM L)) (NULL (LAST L))) - (if (CDR L) `(PROGN . ,L) (CAR L))) - ((NULL (SETQ L (REMOVE NIL L))) NIL) - ((CDR L) (CONS 'PROGN L)) - ((CAR L)))) - (SEQ (COND ((EQCAR (CAR L) 'EXIT) (CADAR L)) - ((CDR L) (CONS 'SEQ L)) - ((CAR L)))) - (LIST (if L (cons 'LIST L))) - (CONS (if (cdr L) (cons 'CONS L) (car L))) - (t (CONS OP L) )))) - -(defvar $TRACELETFLAG NIL "Also referred to in Comp.Lisp") - (defmacro |Zero| (&rest L) (declare (ignore l)) "Needed by spadCompileOrSetq" 0) @@ -426,186 +213,7 @@ ends up being [[CONTAINED |$EmptyMode| Y]]. (declare (ignore l)) "Needed by spadCompileOrSetq" 1) -(defun -REPEAT (BD SPL) - (let (u g g1 inc final xcl xv il rsl tll funPLUS funGT fun? funIdent - funPLUSform funGTform) - (DO ((X SPL (CDR X))) - ((ATOM X) - (LIST 'spadDO (NREVERSE IL) (LIST (MKPF (NREVERSE XCL) 'OR) XV) - (SEQOPT (CONS 'SEQ (NCONC (NREVERSE RSL) (LIST (LIST 'EXIT BD))))))) - (COND ((ATOM (CAR X)) (FAIL))) - (COND ((AND (EQ (CAAR X) 'STEP) - (|member| (CADDAR X) '(2 1 0 (|One|) (|Zero|))) - (|member| (CADR (CDDAR X)) '(1 (|One|)))) - (SETQ X (CONS (CONS 'ISTEP (CDAR X)) (CDR X))) )) - ; A hack to increase the likelihood of small integers - (SETQ U (CDAR X)) - (case (CAAR X) - (GENERAL (AND (CDDDR U) (PUSH (CADDDR U) XCL)) - (PUSH (LIST (CAR U) (CADR U) (CADDR U)) IL) ) - (GSTEP - (SETQ tll (CDDDDR U)) ;tll is (+fun >fun type? ident) - (SETQ funPLUSform (CAR tll)) - (SETQ funGTform (CAR (SETQ tll (QCDR tll)))) - (PUSH (LIST (SETQ funPLUS (GENSYM)) funPLUSform) IL) - (PUSH (LIST (SETQ funGT (GENSYM)) funGTform) IL) - (COND ((SETQ tll (CDR tll)) - (SETQ fun? (CAR tll)) - (SETQ funIdent (CAR (SETQ tll (QCDR tll)))))) - (IF (NOT (ATOM (SETQ inc (CADDR U)) )) - (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL)) - (SETQ final (CADDDR U)) - (COND (final - (COND ((ATOM final)) - ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL))) - ; If CADDDR U is not an atom, only compute the value once - (PUSH - (if fun? - (if (FUNCALL fun? INC) - (if (FUNCALL (EVAL funGTform) INC funIdent) - (LIST 'FUNCALL funGT (CAR U) FINAL) - (LIST 'FUNCALL funGT FINAL (CAR U))) - (LIST 'IF (LIST 'FUNCALL funGT INC funIdent) - (LIST 'FUNCALL funGT (CAR U) FINAL) - (LIST 'FUNCALL funGT FINAL (CAR U)))) - (LIST 'FUNCALL funGT (CAR U) final)) - XCL))) - (PUSH (LIST (CAR U) (CADR U) (LIST 'FUNCALL funPLUS (CAR U) INC)) IL)) - (STEP - (IF (NOT (ATOM (SETQ inc (CADDR U)) )) - (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL)) - (COND ((CDDDR U) - (COND ((ATOM (SETQ final (CADDDR U)) )) - ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL))) - ; If CADDDR U is not an atom, only compute the value once - (PUSH - (if (INTEGERP INC) - (LIST (if (MINUSP INC) '< '>) (CAR U) FINAL) - `(if (MINUSP ,INC) - (< ,(CAR U) ,FINAL) - (> ,(CAR U) ,FINAL))) - XCL))) - (PUSH (LIST (CAR U) (CADR U) (LIST '+ (CAR U) INC)) IL)) - (ISTEP - (IF (NOT (ATOM (SETQ inc (CADDR U)) )) - (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL)) - (COND ((CDDDR U) - (COND ((ATOM (SETQ final (CADDDR U)) )) - ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL))) - ; If CADDDR U is not an atom, only compute the value once - (PUSH - (if (INTEGERP INC) - (LIST (if (QSMINUSP INC) 'QSLESSP 'QSGREATERP) - (CAR U) FINAL) - `(if (QSMINUSP ,INC) - (QSLESSP ,(CAR U) ,FINAL) - (QSGREATERP ,(CAR U) ,FINAL))) - XCL))) - (PUSH (LIST (CAR U) (CADR U) - (COND ((|member| INC '(1 (|One|))) - (MKQSADD1 (CAR U))) - ((LIST 'QSPLUS (CAR U) INC)) )) - IL)) - (ON (PUSH (LIST 'ATOM (CAR U)) XCL) - (PUSH (LIST (CAR U) (CADR U) (LIST 'CDR (CAR U))) IL)) - (RESET (PUSH (LIST 'PROGN (CAR U) NIL) XCL)) - (IN - (PUSH (LIST 'OR - (LIST 'ATOM (SETQ G (GENSYM))) - (CONS 'PROGN - (CONS - (LIST 'SETQ (CAR U) (LIST 'CAR G)) - (APPEND - (COND ((AND (symbol-package (car U)) $TRACELETFLAG) - (LIST (LIST '/TRACELET-PRINT (CAR U) - (CAR U)))) - (NIL)) - (LIST NIL)))) ) XCL) - (PUSH (LIST G (CADR U) (LIST 'CDR G)) IL) - (PUSH (LIST (CAR U) NIL) IL)) - (INDOM (SETQ G (GENSYM)) - (SETQ G1 (GENSYM)) - (PUSH (LIST 'ATOM G) XCL) - (PUSH (LIST G (LIST 'INDOM-FIRST (CADR U)) - (LIST 'INDOM-NEXT G1)) IL) - (PUSH (LIST (CAR U) NIL) IL) - (PUSH (LIST G1 NIL) IL) - (PUSH (LIST 'SETQ G1 (LIST 'CDR G)) RSL) - (PUSH (LIST 'SETQ (CAR U) (LIST 'CAR G)) RSL)) - (UNTIL (SETQ G (GENSYM)) (PUSH (LIST G NIL (CAR U)) IL) (PUSH G XCL)) - (WHILE (PUSH (LIST 'NULL (CAR U)) XCL)) - (SUCHTHAT (SETQ BD (LIST 'SUCHTHATCLAUSE BD (CAR U)))) - (EXIT (SETQ XV (CAR U))) (FAIL))))) - - -(defun SEQOPT (U) - (if (AND (EQCAR U 'SEQ) (EQCAR (CADR U) 'EXIT) (EQCAR (CADADR U) 'SEQ)) - (CADADR U) - U)) - -(defmacro SUCHTHATCLAUSE (&rest L) (LIST 'COND (LIST (CADR L) (CAR L)))) - -(defvar $NEWSPAD NIL) -(defvar $BOOT NIL) - -(defmacro spadDO (&rest OL) - (PROG (VARS L VL V U INITS U-VARS U-VALS ENDTEST EXITFORMS BODYFORMS) - (if (OR $BOOT (NOT $NEWSPAD)) (return (CONS 'DO OL))) - (SETQ L (copy-list OL)) - (if (OR (ATOM L) (ATOM (CDR L))) (GO BADO)) - (setq vl (POP L)) - (COND ((IDENTP VL) - (SETQ VARS (LIST VL)) - (AND (OR (ATOM L) - (ATOM (progn (setq inits (POP L)) L)) - (ATOM (progn (setq u-vals (pop L)) L))) - (GO BADO)) - (SETQ INITS (LIST INITS) U-VARS (LIST (CAR VARS)) U-VALS (LIST U-VALS)) - (setq endtest (POP L))) - ((prog nil - (COND ((NULL VL) (GO TG5)) ((ATOM VL) (GO BADO))) - G180 (AND (NOT (PAIRP (SETQ V (CAR VL)))) (SETQ V (LIST V))) - (AND (NOT (IDENTP (CAR V))) (GO BADO)) - (PUSH (CAR V) VARS) - (PUSH (COND ((PAIRP (CDR V)) (CADR V))) INITS) - (AND (PAIRP (CDR V)) - (PAIRP (CDDR V)) - (SEQ (PUSH (CAR V) U-VARS) - (PUSH (CADDR V) U-VALS))) - (AND (PAIRP (progn (POP VL) VL)) (GO G180)) - TG5 (setq exitforms (POP L)) - (and (PAIRP EXITFORMS) - (progn (setq endtest (POP EXITFORMS)) exitforms))))) - (AND L - (COND ((CDR L) (SETQ BODYFORMS (CONS 'SEQ L))) - ((NULL (EQCAR (CAR L) 'SEQ)) (SETQ BODYFORMS (CONS 'SEQ L))) - ((SETQ BODYFORMS (CAR L))))) - (SETQ EXITFORMS `(EXIT ,(MKPF EXITFORMS 'PROGN))) - (AND ENDTEST (SETQ ENDTEST (LIST 'COND (LIST ENDTEST '(GO G191))))) - (COND ((NULL U-VARS) (GO XT) ) - ((NULL (CDR U-VARS)) - (SEQ (SETQ U-VARS (LIST 'SETQ (CAR U-VARS) (CAR U-VALS))) - (GO XT)) )) - (SETQ VL (LIST 'SETQ (CAR U-VARS) (CAR U-VALS))) - (SEQ (SETQ V (CDR U-VARS)) (SETQ U (CDR U-VALS))) - TG (SETQ VL (LIST 'SETQ (CAR V) (LIST 'PROG1 (CAR U) VL))) - (POP U) - (AND (progn (POP V) V) (GO TG)) - (SETQ U-VARS VL) - XT (RETURN (COND - ((AND $NEWSPAD (NULL $BOOT)) - (CONS 'SEQ (NCONC (DO_LET VARS INITS) - (LIST 'G190 ENDTEST BODYFORMS U-VARS '(GO G190) - 'G191 EXITFORMS)))) - ((CONS `(LAMBDA ,(NRECONC VARS NIL) - (SEQ G190 ,ENDTEST ,BODYFORMS ,U-VARS (GO G190) G191 ,EXITFORMS)) - (NRECONC INITS NIL))))) - BADO (ERROR (FORMAT NIL "BAD DO FORMAT~%~A" OL)))) - -(defun DO_LET (VARS INITS) - (if (OR (NULL VARS) (NULL INITS)) NIL - (CONS (LIST 'SPADLET (CAR VARS) (CAR INITS)) - (DO_LET (CDR VARS) (CDR INITS))))) + #-:CCL (defun NREVERSE0 (X) ; Already built-in to CCL @@ -615,96 +223,13 @@ This version is needed so that (COLLECT (IN X Y) ... (RETURN 'JUNK))=>JUNK." ; 7.8.4 Mapping -(defmacro COLLECT (&rest L) - (let ((U (REPEAT-TRAN L NIL))) - (CONS 'THETA (CONS '\, (NCONC (CAR U) (LIST (CDR U))))))) - -;; The following was changed to a macro for efficiency in CCL. To change -;; it back to a function would require recompilation of a large chunk of -;; the library. -(defmacro PRIMVEC2ARR (x) x) ;redefine to change Array rep - -(defmacro COLLECTVEC (&rest L) - `(PRIMVEC2ARR (COLLECTV ,@L))) - -(defmacro COLLECTV (&rest L) - (PROG (CONDS BODY ANS COUNTER X Y) - ;If we can work out how often we will go round - ;allocate a vector first - (SETQ CONDS NIL) - (SETQ BODY (REVERSE L)) - (SETQ ANS (GENSYM)) - (SETQ COUNTER NIL) - (SETQ X (CDR BODY)) - (SETQ BODY (CAR BODY)) -LP (COND ((NULL X) - (COND ((NULL COUNTER) - (SETQ COUNTER (GENSYM)) - (SETQ L (CONS (LIST 'ISTEP COUNTER 0 1) L)) )) - (RETURN (LIST 'PROGN - (LIST 'SPADLET ANS - (LIST 'GETREFV - (COND ((NULL CONDS) (fail)) - ((NULL (CDR CONDS)) - (CAR CONDS)) - ((CONS 'MIN CONDS)) ) )) - (CONS 'REPEAT (NCONC (CDR (REVERSE L)) - (LIST (LIST 'SETELT ANS COUNTER BODY)))) - ANS)) )) - (SETQ Y (CAR X)) - (SETQ X (CDR X)) - (COND ((MEMQ (CAR Y) '(SUCHTHAT WHILE UNTIL)) - (RETURN (LIST 'LIST2VEC (CONS 'COLLECT L)) )) - ((member (CAR Y) '(IN ON) :test #'eq) - (SETQ CONDS (CONS (LIST 'SIZE (CADDR Y)) CONDS)) - (GO LP)) - ((member (CAR Y) '(STEP ISTEP) :test #'eq) - (if (AND (EQL (CADDR Y) 0) (EQL (CADDDR Y) 1)) - (SETQ COUNTER (CADR Y)) ) - (COND ((CDDDDR Y) ; there may not be a limit - (SETQ CONDS (CONS - (COND ((EQL 1 (CADDDR Y)) - (COND ((EQL 1 (CADDR Y)) (CAR (CDDDDR Y))) - ((EQL 0 (CADDR Y)) (MKQSADD1 (CAR (CDDDDR Y)))) - ((MKQSADD1 `(- ,(CAR (CDDDDR Y)) ,(CADDR Y)))))) - ((EQL 1 (CADDR Y)) `(/ ,(CAR (CDDDDR Y)) ,(CADDR Y))) - ((EQL 0 (CADDR Y)) - `(/ ,(MKQSADD1 (CAR (CDDDDR Y))) ,(CADDR Y))) - (`(/ (- ,(MKQSADD1 (CAR (CDDDDR Y))) ,(CADDR Y)) - ,(CADDR Y)))) - CONDS)))) - (GO LP))) - (ERROR "Cannot handle macro expansion"))) - -(defun MKQSADD1 (X) - (COND ((ATOM X) `(QSADD1 ,X)) - ((AND (member (CAR X) '(-DIFFERENCE QSDIFFERENCE -) :test #'eq) - (EQL 1 (CADDR X))) - (CADR X)) - (`(QSADD1 ,X)))) -; 7.10 Dynamic Non-local Exits -(defmacro yield (L) - (let ((g (gensym))) - `(let ((,g (state))) - (if (statep ,g) (throw 'yield (list 'pair ,L) ,g))))) +; 7.10 Dynamic Non-local Exits ; 10.1 The Property List -(DEFUN FLAG (L KEY) - "Set the KEY property of every item in list L to T." - (mapc #'(lambda (item) (makeprop item KEY T)) L)) - -(FLAG '(* + AND OR PROGN) 'NARY) ; flag for MKPF - -(DEFUN REMFLAG (L KEY) - "Set the KEY property of every item in list L to NIL." - (OR (ATOM L) (SEQ (REMPROP (CAR L) KEY) (REMFLAG (CDR L) KEY)))) -(DEFUN FLAGP (X KEY) - "If X has a KEY property, then FLAGP is true." - (GET X KEY)) (defun PROPERTY (X IND N) "Returns the Nth element of X's IND property, if it exists." @@ -712,7 +237,6 @@ LP (COND ((NULL X) ; 10.3 Creating Symbols -(defmacro INTERNL (a &rest b) (if (not b) `(intern ,a) `(intern (strconc ,a . ,b)))) (defvar $GENNO 0) @@ -730,46 +254,18 @@ LP (COND ((NULL X) ; 10.7 CATCH and THROW -(defmacro SPADCATCH (&rest form) (CONS 'CATCH form)) - -(defmacro SPADTHROW (&rest form) (CONS 'THROW form)) - ; 12 NUMBERS ; 12.3 Comparisons on Numbers -(defmacro IEQUAL (&rest L) `(eql . ,L)) -(defmacro GE (&rest L) `(>= . ,L)) -(defmacro GT (&rest L) `(> . ,L)) -(defmacro LE (&rest L) `(<= . ,L)) -(defmacro LT (&rest L) `(< . ,L)) - ; 12.4 Arithmetic Operations -(defmacro SPADDIFFERENCE (&rest x) `(- . ,x)) - ; 12.5 Irrational and Transcendental Functions ; 12.5.1 Exponential and Logarithmic Functions -(define-function 'QSEXPT #'expt) - ; 12.6 Small Finite Field ops with vector trimming -;; following macros assume 0 <= x,y < z - -(defmacro qsaddmod (x y z) - `(let* ((sum (qsplus ,x ,y)) - (rsum (qsdifference sum ,z))) - (if (qsminusp rsum) sum rsum))) - -(defmacro qsdifmod (x y z) - `(let ((dif (qsdifference ,x ,y))) - (if (qsminusp dif) (qsplus dif ,z) dif))) - -(defmacro qsmultmod (x y z) - `(rem (* ,x ,y) ,z)) - (defun TRIMLZ (vec) (declare (simple-vector vec)) (let ((n (position 0 vec :from-end t :test-not #'eql))) @@ -785,11 +281,6 @@ LP (COND ((NULL X) ; 14.1 Simple Sequence Functions -(DEFUN NLIST (N FN) - "Returns a list of N items, each initialized to the value of an - invocation of FN" - (if (LT N 1) NIL (CONS (EVAL FN) (NLIST (SUB1 N) FN)))) - (define-function 'getchar #'elt) (defun GETCHARN (A M) "Return the code of the Mth character of A" @@ -808,14 +299,6 @@ LP (COND ((NULL X) (defun NSTRCONC (s1 s2) (concatenate 'string (string s1) (string s2))) -(defmacro spadREDUCE (OP AXIS BOD) (REDUCE-1 OP AXIS BOD)) - -(MAPC #'(LAMBDA (X) (MAKEPROP (CAR X) 'THETA (CDR X))) - '((PLUS 0) (+ (|Zero|)) (|lcm| (|One|)) (STRCONC "") (|strconc| "") - (MAX -999999) (MIN 999999) (TIMES 1) (* (|One|)) (CONS NIL) - (APPEND NIL) (|append| NIL) (UNION NIL) (UNIONQ NIL) (|gcd| (|Zero|)) - (|union| NIL) (NCONC NIL) (|and| |true|) (|or| |false|) (AND 'T) - (OR NIL))) (define-function '|append| #'APPEND) @@ -829,189 +312,31 @@ LP (COND ((NULL X) ((and (atom item) (not (arrayp item))) (remove item sequence)) (T (remove item sequence :test #'equalp)))) -(MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'UNMACRO (CADR J))) - '( (AND AND2) (OR OR2))) - -(defun and2 (x y) (and x y)) - -(defun or2 (x y) (or x y)) - -(MAKEPROP 'CONS 'RIGHT-ASSOCIATIVE T) - -(defun REDUCE-1 (OP AXIS BOD) - (let (u op1 tran iden) - (SEQ (SETQ OP1 (cond ((EQ OP '\,) 'CONS) - ((EQCAR OP 'QUOTE) (CADR OP)) - (OP))) - (SETQ IDEN (if (SETQ U (GET OP1 'THETA)) (CAR U) 'NO_THETA_PROPERTY)) - (SETQ TRAN (if (EQCAR BOD 'COLLECT) - (PROG (L BOD1 ITL) - (SETQ L (REVERSE (CDR BOD))) - (SETQ BOD1 (CAR L)) - (SETQ ITL (NREVERSE (CDR L))) - (RETURN (-REDUCE OP1 AXIS IDEN BOD1 ITL)) ) - (progn (SETQ U (-REDUCE-OP OP1 AXIS)) - (LIST 'REDUCE-N (MKQ (OR (GET U 'UNMACRO) U)) - (GET OP1 'RIGHT-ASSOCIATIVE) - BOD IDEN)))) - (if (EQ OP '\,) (LIST 'NREVERSE-N TRAN AXIS) TRAN)))) - -(defun -REDUCE (OP AXIS Y BODY SPL) - (PROG (X G AUX EXIT VALUE PRESET CONSCODE RESETCODE) - (SETQ G (GENSYM)) - ; create preset of accumulate - (SETQ PRESET (COND - ((EQ Y 'NO_THETA_PROPERTY) (LIST 'SPADLET G (MKQ G))) - ((LIST 'SPADLET G Y)) )) - (SETQ EXIT (COND - ((SETQ X (ASSOC 'EXIT SPL))(SETQ SPL (DELASC 'EXIT SPL)) (COND - ((MEMBER OP '(AND OR)) (LIST 'AND G (CADR X))) ((CADR X)) )) - ((EQ Y 'NO_THETA_PROPERTY) (LIST 'THETACHECK G (MKQ G)(MKQ OP))) - (G) )) - (COND ((EQ OP 'CONS) (SETQ EXIT (LIST 'NREVERSE0 EXIT)))) - ; CONSCODE= code which conses a member onto the list - (SETQ VALUE (COND ((EQ Y 'NO_THETA_PROPERTY) (GENSYM)) - (BODY))) - (SETQ CONSCODE (CONS (-REDUCE-OP OP AXIS) (COND - ((FLAGP OP 'RIGHT-ASSOCIATIVE) (LIST VALUE G)) - ((LIST G VALUE) ) ) ) ) - ; next reset code which varies if THETA property is|/is not given - (SETQ RESETCODE (LIST 'SETQ G (COND - ((EQ Y 'NO_THETA_PROPERTY) - (LIST 'COND (LIST (LIST 'EQ G (MKQ G)) VALUE) - (LIST ''T CONSCODE)) ) - (CONSCODE) ))) - ; create body - (SETQ BODY (COND ((EQ VALUE BODY) RESETCODE) - ((LIST 'PROGN (LIST 'SPADLET VALUE BODY) RESETCODE)) )) - (SETQ AUX (CONS (LIST 'EXIT EXIT) (COND - ((EQ OP 'AND) (LIST (LIST 'UNTIL (LIST 'NULL G)))) - ((EQ OP 'OR) (LIST (LIST 'UNTIL G))) - (NIL) ))) - (RETURN (COND - ((AND $NEWSPAD (NULL $BOOT)) (LIST 'PROGN PRESET - (CONS 'REPEAT (APPEND AUX (APPEND SPL (LIST BODY))) ))) - ((LIST 'PROG - (COND ((EQ RESETCODE BODY) (LIST G)) ((LIST G VALUE))) - PRESET (LIST 'RETURN - (CONS 'REPEAT (APPEND AUX (APPEND SPL (LIST BODY))))))))))) - -(defun -REDUCE-OP (OP AXIS) - (COND ((EQL AXIS 0) OP) - ((EQL AXIS 1) - (COND ((EQ OP 'CONS) 'CONS-N) - ((EQ OP 'APPEND) 'APPEND-N) - ((FAIL)))) - ((FAIL)))) - -(defun NREVERSE-N (X AXIS) - (COND ((EQL AXIS 0) (NREVERSE X)) - ((MAPCAR #'(LAMBDA (Y) (NREVERSE-N Y (SUB1 AXIS))) X)))) - -(defun CONS-N (X Y) - (COND ((NULL Y) (CONS-N X (NLIST (LENGTH X) NIL))) - ((MAPCAR #'CONS X Y)))) - -(defun APPEND-N (X Y) - (COND ((NULL X) (APPEND-N (NLIST (LENGTH Y) NIL) Y)) - ((MAPCAR #'APPEND X Y)))) - -(defun REDUCE-N (OP RIGHT L ACC) - (COND (RIGHT (PROG (U L1) - (SETQ L1 (NREVERSE L)) - (SETQ U (REDUCE-N-1 OP 'T L1 ACC)) - (NREVERSE L1) - (RETURN U) )) - ((REDUCE-N-1 OP NIL L ACC)))) - -(defun REDUCE-N-1 (OP RIGHT L ACC) - (COND ((EQ ACC 'NO_THETA_PROPERTY) - (COND ((NULL L) (THETA_ERROR OP)) - ((REDUCE-N-2 OP RIGHT (CDR L) (CAR L))) )) - ((REDUCE-N-2 OP RIGHT L ACC)))) - -(defun REDUCE-N-2 (OP RIGHT L ACC) - (COND ((NULL L) ACC) - (RIGHT (REDUCE-N-2 OP RIGHT (CDR L) (funcall (symbol-function OP) (CAR L) ACC))) - ((REDUCE-N-2 OP RIGHT (CDR L) (funcall (symbol-function OP) ACC (CAR L)))))) - -(defmacro THETA (&rest LL) - (let (U (L (copy-list LL))) - (if (EQ (KAR L) '\,) `(theta CONS . ,(CDR L)) - (progn - (if (EQCAR (CAR L) 'QUOTE) (RPLAC (CAR L) (CADAR L))) - (-REDUCE (CAR L) 0 - (if (SETQ U (GET (CAR L) 'THETA)) (CAR U) - (MOAN "NO THETA PROPERTY")) - (CAR (SETQ L (NREVERSE (CDR L)))) - (NREVERSE (CDR L))))))) - -(defmacro THETA1 (&rest LL) - (let (U (L (copy-list LL))) - (if (EQ (KAR L) '\,) - (LIST 'NREVERSE-N (CONS 'THETA1 (CONS 'CONS (CDR L))) 1) - (-REDUCE (CAR L) 1 - (if (SETQ U (GET (CAR L) 'THETA)) (CAR U) - (MOAN "NO THETA PROPERTY")) - (CAR (SETQ L (NREVERSE (CDR L)))) - (NREVERSE (CDR L)))))) -(defun THETACHECK (VAL VAR OP) (if (EQL VAL VAR) (THETA_ERROR OP) val)) -(defun THETA_ERROR (OP) - (Boot::|userError| - (LIST "Sorry, do not know the identity element for " OP))) -; 15 LISTS -; 15.1 Conses +(defun THETACHECK (VAL VAR OP) (if (EQL VAL VAR) (THETA_ERROR OP) val)) +; 15 LISTS -(defmacro |SPADfirst| (l) - (let ((tem (gensym))) - `(let ((,tem ,l)) (if ,tem (car ,tem) (first-error))))) +; 15.1 Conses -(defun first-error () (error "Cannot take first of an empty list")) ; 15.2 Lists -(defmacro ELEM (val &rest indices) - (if (null indices) val `(ELEM (nth (1- ,(car indices)) ,val) ,@(cdr indices)))) - (defun ELEMN (X N DEFAULT) (COND ((NULL X) DEFAULT) ((EQL N 1) (CAR X)) ((ELEMN (CDR X) (SUB1 N) DEFAULT)))) -(defmacro TAIL (&rest L) - (let ((x (car L)) (n (if (cdr L) (cadr L) 1))) - (COND ((EQL N 0) X) - ((EQL N 1) (LIST 'CDR X)) - ((GT N 1) (APPLYR (PARTCODET N) X)) - ((LIST 'TAILFN X N))))) - -(defun PARTCODET (N) - (COND ((OR (NULL (INTEGERP N)) (LT N 1)) (ERROR 'PARTCODET)) - ((EQL N 1) '(CDR)) - ((EQL N 2) '(CDDR)) - ((EQL N 3) '(CDDDR)) - ((EQL N 4) '(CDDDDR)) - ((APPEND (PARTCODET (PLUS N -4)) '(CDDDDR))))) - (defmacro TL (&rest L) `(tail . ,L)) -(defun TAILFN (X N) (if (LT N 1) X (TAILFN (CDR X) (SUB1 N)))) (defmacro SPADCONST (&rest L) (cons 'qrefelt L)) -(defmacro SPADCALL (&rest L) - (let ((args (butlast l)) (fn (car (last l))) (gi (gensym))) - ;; (values t) indicates a single return value - `(let ((,gi ,fn)) (the (values t) (funcall (car ,gi) ,@args (cdr ,gi)))) - )) - (DEFUN LASTELEM (X) (car (last X))) (defun LISTOFATOMS (X) @@ -1089,14 +414,6 @@ LP (COND ((NULL X) ; 15.5 Using Lists as Sets <<DEFUN CONTAINED>> -(DEFUN S+ (X Y) - (COND ((ATOM Y) X) - ((ATOM X) Y) - ((MEMBER (CAR X) Y :test #'equal) (S+ (CDR X) Y)) - ((S+ (CDR X) (CONS (CAR X) Y))))) - -(defun S* (l1 l2) (INTERSECTION l1 l2 :test #'equal)) -(defun S- (l1 l2) (set-difference l1 l2 :test #'equal)) (DEFUN PREDECESSOR (TL L) "Returns the sublist of L whose CDR is EQ to TL." @@ -1110,48 +427,62 @@ LP (COND ((NULL X) ; 15.6 Association Lists -(defun DelAsc (u v) "Returns a copy of a-list V in which any pair with key U is deleted." - (cond ((atom v) nil) - ((or (atom (car v))(not (equal u (caar v)))) - (cons (car v) (DelAsc u (cdr v)))) - ((cdr v)))) + +;; FIXME: Should not this be named `alistAllKeys'? +(DEFUN ASSOCLEFT (X) + "Returns all the keys of association list X." + (if (ATOM X) + X + (mapcar #'car x))) + +;; FIXME: Should not this be named `alistAllValues'? +(DEFUN ASSOCRIGHT (X) + "Returns all the datums of association list X." + (if (ATOM X) + X + (mapcar #'cdr x))) + (DEFUN ADDASSOC (X Y L) "Put the association list pair (X . Y) into L, erasing any previous association for X" - (COND ((ATOM L) (CONS (CONS X Y) L)) - ((EQUAL X (CAAR L)) (CONS (CONS X Y) (CDR L))) + (COND ((ATOM L) + (CONS (CONS X Y) L)) + ((EQUAL X (CAAR L)) + (CONS (CONS X Y) (CDR L))) ((CONS (CAR L) (ADDASSOC X Y (CDR L)))))) (DEFUN DELLASOS (U V) "Remove any assocation pair (U . X) from list V." (COND ((ATOM V) NIL) - ((EQUAL U (CAAR V)) (CDR V)) + ((EQUAL U (CAAR V)) + (CDR V)) ((CONS (CAR V) (DELLASOS U (CDR V)))))) + -(DEFUN ASSOCLEFT (X) - "Returns all the keys of association list X." - (if (ATOM X) X (mapcar #'car x))) - -(DEFUN ASSOCRIGHT (X) - "Returns all the datums of association list X." - (if (ATOM X) X (mapcar #'cdr x))) - +;; FIXME: Should not this be named `alistValue'? (DEFUN LASSOC (X Y) "Return the datum associated with key X in association list Y." (PROG NIL - A (COND ((ATOM Y) (RETURN NIL)) - ((EQUAL (CAAR Y) X) (RETURN (CDAR Y))) ) + A + (COND ((ATOM Y) + (RETURN NIL)) + ((EQUAL (CAAR Y) X) + (RETURN (CDAR Y))) ) (SETQ Y (CDR Y)) (GO A))) - + +;; FIXME: Should not this be named `alistKey'? (DEFUN |rassoc| (X Y) - "Return the datum associated with key X in association list Y." + "Return the key associated with datum X in association list Y." (PROG NIL - A (COND ((ATOM Y) (RETURN NIL)) - ((EQUAL (CDAR Y) X) (RETURN (CAAR Y))) ) + A + (COND ((ATOM Y) + (RETURN NIL)) + ((EQUAL (CDAR Y) X) + (RETURN (CAAR Y))) ) (SETQ Y (CDR Y)) (GO A))) - + ; (defun QLASSQ (p a-list) (let ((y (assoc p a-list :test #'eq))) (if y (cdr y)))) (defun QLASSQ (p a-list) (cdr (assq p a-list))) @@ -1392,10 +723,6 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size ; 24.2 Specialized Error-Signalling Forms and Macros -(defun MOAN (&rest x) (|sayBrightly| `(|%l| "===> " ,@X |%l|))) - -(DEFUN FAIL () (|systemError| '"Antique error (FAIL ENTERED)")) - (defun CROAK (&rest x) (|systemError| x)) ; 25 MISCELLANEOUS FEATURES @@ -1432,12 +759,6 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size (defmacro |do| (&rest args) (CONS 'PROGN args)) -(defmacro |char| (arg) - (cond ((stringp arg) (character arg)) - ((integerp arg) (code-char arg)) - ((and (consp arg) (eq (car arg) 'quote)) (character (cadr arg))) - (t `(character ,arg)))) - (defun DROPTRAILINGBLANKS (LINE) (string-right-trim " " LINE)) ; # Gives the number of elements of a list, 0 for atoms. @@ -1503,11 +824,6 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size (defun compile-defun (name body) (eval body) (compile name)) -(defmacro |Record| (&rest x) - `(|Record0| (LIST ,@(COLLECT (IN Y X) - (list 'CONS (MKQ (CADR Y)) (CADDR Y)))))) - -(defmacro |:| (tag expr) `(LIST '|:| ,(MKQ tag) ,expr)) (defun |deleteWOC| (item list) (lisp::delete item list :test #'equal)) @@ -1517,16 +833,6 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size (DEFUN |rightBindingPowerOf| (X IND &AUX (Y (GETL X IND))) (IF Y (ELEMN Y 4 105) 105)) -(defmacro make-bf (MT EP) `(CONS |$BFtag| (CONS ,MT ,EP))) - -(defun MAKE-FLOAT (int frac fraclen exp) - (if (AND $SPAD |$useBFasDefault|) - (if (= frac 0) - (MAKE-BF int exp) - (MAKE-BF (+ (* int (expt 10 fraclen)) frac) (- exp fraclen)) ) - (read-from-string - (format nil "~D.~v,'0De~D" int fraclen frac exp))) ) - ;;---- Added by WFS. (proclaim '(ftype (function (t t) t) |subWord|)) ;hack for bug in akcl-478 @@ -1722,6 +1028,17 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size (defmacro |shoeread-line| (st) `(read-line ,st nil nil)) +;; +;; -*- Record Structures -*- +;; + +(defmacro |Record| (&rest x) + `(|Record0| (LIST ,@(COLLECT (IN Y X) + (list 'CONS (MKQ (CADR Y)) (CADDR Y)))))) + +(defmacro |:| (tag expr) + `(LIST '|:| ,(MKQ tag) ,expr)) + @ \eject |