diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 8 | ||||
| -rw-r--r-- | src/interp/Makefile.in | 10 | ||||
| -rw-r--r-- | src/interp/Makefile.pamphlet | 20 | ||||
| -rw-r--r-- | src/interp/bootlex.lisp | 2 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 2 | ||||
| -rw-r--r-- | src/interp/def.lisp | 668 | ||||
| -rw-r--r-- | src/interp/g-boot.boot | 466 | ||||
| -rw-r--r-- | src/interp/g-opt.boot | 2 | ||||
| -rw-r--r-- | src/interp/i-util.boot | 17 | ||||
| -rw-r--r-- | src/interp/wi1.boot | 2 |
10 files changed, 35 insertions, 1162 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 17a676b1..a48af9e1 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,13 @@ 2010-05-16 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/i-util.boot (flattenCOND): Move from g-boot.boot. + (extractCONDClauses): Likewise. + * interp/g-boot.boot: Remove. + * interp/def.lisp: Likewise. + * interp/Makefile.pamphlet: Adjust dependencies. + +2010-05-16 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/property.lisp: Clean up. 2010-05-15 Gabriel Dos Reis <gdr@cs.tamu.edu> diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 30962fc2..c839616b 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -45,7 +45,6 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \ g-cndata.$(FASLEXT) database.$(FASLEXT) \ debug.$(FASLEXT) dq.$(FASLEXT) \ fname.$(FASLEXT) format.$(FASLEXT) \ - def.$(FASLEXT) g-boot.$(FASLEXT) \ g-error.$(FASLEXT) g-opt.$(FASLEXT) \ ggreater.$(FASLEXT) \ hypertex.$(FASLEXT) \ @@ -115,8 +114,7 @@ BROBJS= bc-matrix.$(FASLEXT) \ autoload_objects += $(BFOBJS) TRANOBJS= ${AUTO}/wi1.$(FASLEXT) ${AUTO}/wi2.$(FASLEXT) ${AUTO}/pspad1.$(FASLEXT) \ - ${AUTO}/pspad2.$(FASLEXT) ${AUTO}/mark.$(FASLEXT) ${AUTO}/nspadaux.$(FASLEXT) \ - ${AUTO}/def.$(FASLEXT) + ${AUTO}/pspad2.$(FASLEXT) ${AUTO}/mark.$(FASLEXT) ${AUTO}/nspadaux.$(FASLEXT) autoload_objects += $(TRANOBJS) @@ -348,10 +346,9 @@ mark.$(FASLEXT): macros.$(FASLEXT) parse.$(FASLEXT): metalex.$(FASLEXT) postpar.$(FASLEXT) packtran.$(FASLEXT): sys-macros.$(FASLEXT) postpar.$(FASLEXT): macros.$(FASLEXT) -bootlex.$(FASLEXT): preparse.$(FASLEXT) def.$(FASLEXT) \ +bootlex.$(FASLEXT): preparse.$(FASLEXT) macros.$(FASLEXT) \ nlib.$(FASLEXT) sys-globals.$(FASLEXT) newaux.$(FASLEXT): macros.$(FASLEXT) -def.$(FASLEXT): macros.$(FASLEXT) comp.$(FASLEXT): macros.$(FASLEXT) preparse.$(FASLEXT): fnewmeta.$(FASLEXT) fnewmeta.$(FASLEXT): parsing.$(FASLEXT) @@ -400,10 +397,9 @@ info.$(FASLEXT): g-util.$(FASLEXT) slam.$(FASLEXT): g-timer.$(FASLEXT) clammed.$(FASLEXT): g-timer.$(FASLEXT) clam.$(FASLEXT): g-timer.$(FASLEXT) -g-opt.$(FASLEXT): def.$(FASLEXT) +g-opt.$(FASLEXT): macros.$(FASLEXT) g-timer.$(FASLEXT): macros.$(FASLEXT) g-util.$(FASLEXT) msgdb.$(FASLEXT): g-util.$(FASLEXT) -g-boot.$(FASLEXT): def.$(FASLEXT) g-util.$(FASLEXT) g-error.$(FASLEXT): diagnostics.$(FASLEXT) g-util.$(FASLEXT) c-util.$(FASLEXT): g-util.$(FASLEXT) g-opt.$(FASLEXT) pathname.$(FASLEXT): nlib.$(FASLEXT) diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index b07194c3..be5cb024 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -124,7 +124,6 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \ g-cndata.$(FASLEXT) database.$(FASLEXT) \ debug.$(FASLEXT) dq.$(FASLEXT) \ fname.$(FASLEXT) format.$(FASLEXT) \ - def.$(FASLEXT) g-boot.$(FASLEXT) \ g-error.$(FASLEXT) g-opt.$(FASLEXT) \ ggreater.$(FASLEXT) \ hypertex.$(FASLEXT) \ @@ -189,16 +188,6 @@ first time they are called. Loading the files overwrites the autoload function call and re-calls the function. Any subsequent calls will run the compiled code. -Notice that the object file [[def.$(FASLEXT)]] appears on both the -[[OBJS]] and [[TRANOBJS]] lists. In normal situation, parsing -precedes translation; consequently the file [[def]] is loaded by the -parser, so that it does not need to be reloaded by the translator. -However, it may theoretically be that a translation could happen without -prior parsing (in case someone types in a parse tree for SPAD code). -Consequently, it must be ensured that [[def.]] is still loaded in that -configuration. In the long term, the autoload machinery need -rethinking. - The {\bf OCOBJS} list contains files from the old compiler. Again, ``old'' is meaningless. These files should probably be autoloaded. <<environment>>= @@ -247,8 +236,7 @@ many compiler functions by versions contain in this files. (which replace compiler functions) {\em must} be autoloaded). <<environment>>= TRANOBJS= ${AUTO}/wi1.$(FASLEXT) ${AUTO}/wi2.$(FASLEXT) ${AUTO}/pspad1.$(FASLEXT) \ - ${AUTO}/pspad2.$(FASLEXT) ${AUTO}/mark.$(FASLEXT) ${AUTO}/nspadaux.$(FASLEXT) \ - ${AUTO}/def.$(FASLEXT) + ${AUTO}/pspad2.$(FASLEXT) ${AUTO}/mark.$(FASLEXT) ${AUTO}/nspadaux.$(FASLEXT) autoload_objects += $(TRANOBJS) @@ -597,10 +585,9 @@ mark.$(FASLEXT): macros.$(FASLEXT) parse.$(FASLEXT): metalex.$(FASLEXT) postpar.$(FASLEXT) packtran.$(FASLEXT): sys-macros.$(FASLEXT) postpar.$(FASLEXT): macros.$(FASLEXT) -bootlex.$(FASLEXT): preparse.$(FASLEXT) def.$(FASLEXT) \ +bootlex.$(FASLEXT): preparse.$(FASLEXT) macros.$(FASLEXT) \ nlib.$(FASLEXT) sys-globals.$(FASLEXT) newaux.$(FASLEXT): macros.$(FASLEXT) -def.$(FASLEXT): macros.$(FASLEXT) comp.$(FASLEXT): macros.$(FASLEXT) preparse.$(FASLEXT): fnewmeta.$(FASLEXT) fnewmeta.$(FASLEXT): parsing.$(FASLEXT) @@ -649,10 +636,9 @@ info.$(FASLEXT): g-util.$(FASLEXT) slam.$(FASLEXT): g-timer.$(FASLEXT) clammed.$(FASLEXT): g-timer.$(FASLEXT) clam.$(FASLEXT): g-timer.$(FASLEXT) -g-opt.$(FASLEXT): def.$(FASLEXT) +g-opt.$(FASLEXT): macros.$(FASLEXT) g-timer.$(FASLEXT): macros.$(FASLEXT) g-util.$(FASLEXT) msgdb.$(FASLEXT): g-util.$(FASLEXT) -g-boot.$(FASLEXT): def.$(FASLEXT) g-util.$(FASLEXT) g-error.$(FASLEXT): diagnostics.$(FASLEXT) g-util.$(FASLEXT) c-util.$(FASLEXT): g-util.$(FASLEXT) g-opt.$(FASLEXT) pathname.$(FASLEXT): nlib.$(FASLEXT) diff --git a/src/interp/bootlex.lisp b/src/interp/bootlex.lisp index 811657e7..e32e375b 100644 --- a/src/interp/bootlex.lisp +++ b/src/interp/bootlex.lisp @@ -45,7 +45,7 @@ (import-module "sys-globals") (IMPORT-MODULE "preparse") -(IMPORT-MODULE "def") +(IMPORT-MODULE "macros") (IMPORT-MODULE "nlib") (in-package "BOOT") diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index f55cbd31..c59519a8 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -886,7 +886,7 @@ setqMultiple(nameList,val,m,e) == [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr for x in nameList for [y,:z] in selectorModePairs] if assignList="failed" then NIL - else [MKPROGN [x,:assignList,g],m',e] + else [mkpf([x,:assignList,g],'PROGN),m',e] setqMultipleExplicit(nameList,valList,m,e) == #nameList~=#valList => diff --git a/src/interp/def.lisp b/src/interp/def.lisp deleted file mode 100644 index d7d629b8..00000000 --- a/src/interp/def.lisp +++ /dev/null @@ -1,668 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -;; All rights reserved. -;; Copyright (C) 2007-2008, Gabriel Dos Reis. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical Algorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -; NAME: Def -; PURPOSE: Defines BOOT code - -(IMPORT-MODULE "macros") - -(in-package "BOOT") - -(REPEAT (IN X '( - (|:| |DEF-:|) - (|::| |DEF-::|) - (ELT DEF-ELT) - (SETELT DEF-SETELT) - (%LET DEF-LET) - (COLLECT DEF-COLLECT) - (LESSP DEF-LESSP) - (|<| DEF-LESSP) - (REPEAT DEF-REPEAT) -;;(|TRACE,LET| DEF-TRACE-LET) - (CATEGORY DEF-CATEGORY) - (EQUAL DEF-EQUAL) - (|is| DEF-IS) - (SEQ DEF-SEQ) - (|isnt| DEF-ISNT) - (|where| DEF-WHERE) -)) (PROGN (MAKEPROP (CAR X) '|DEF-TRAN| (CADR X)) (CADR X))) - - -;;; Common Block - -(defparameter deftran nil) -(defparameter $macroassoc nil) -(defparameter $ne nil) - -(defparameter $op nil -"$OP is globalized for construction of local function names, e.g. -foo defined inside of fum gets renamed as fum,foo.") - -(defparameter $opassoc nil -"$OPASSOC is a renaming accumulator to be used with SUBLIS.") - -(defparameter $BODY nil) - -(defun DEF (FORM SIGNATURE $BODY) - (declare (ignore SIGNATURE)) - (let* ($opassoc - ($op (first form)) - (argl (rest form)) - ($body (deftran $body)) - (argl (DEF-INSERT_LET argl)) - (arglp (DEF-STRINGTOQUOTE argl)) - ($body (|bootTransform| $body))) - (|backendCompile| (SUBLIS $OPASSOC (list (list $OP (list 'LAM arglp $body))))))) - -; We are making shallow binding cells for these functions as well - -(mapcar #'(lambda (x) (MAKEPROP (FIRST X) 'DEF-TRAN (SECOND X))) - '((\: DEF-\:) (\:\: DEF-\:\:) (ELT DEF-ELT) - (SETELT DEF-SETELT) (SPADLET DEF-LET) - (SEQ DEF-SEQ) (COLLECT DEF-COLLECT) - (REPEAT DEF-REPEAT) (TRACE-LET DEF-TRACE-LET) - (CATEGORY DEF-CATEGORY) (EQUAL DEF-EQUAL) - (|is| DEF-IS) (|isnt| DEF-ISNT) (|where| DEF-WHERE))) - -(defun DEF-EQUAL (X) - (COND ((NOT (CDR X)) (CONS 'EQUAL X)) - ((OR (MEMBER '(|One|) X) (MEMBER '(|Zero|) X) - (integerp (FIRST X)) (integerp (SECOND X))) (CONS 'EQL X)) - ; ((AND (EQCAR (FIRST X) 'QUOTE) (IDENTP (CADAR X))) (CONS 'EQ X)) - ((NOT (FIRST X)) (LIST 'NULL (SECOND X))) - ((NOT (SECOND X)) (LIST 'NULL (FIRST X))) - ; ((AND (EQCAR (SECOND X) 'QUOTE) (IDENTP (CADADR X))) (CONS 'EQ X)) - ($BOOT (CONS 'BOOT-EQUAL X)) - ((CONS 'EQUAL X)))) - -(defun DEF-LESSP (x) - (cond ((null (cdr x)) (cons '< x)) - ((eq (cadr x) 0) (list 'minusp (car x))) - ((and (smint-able (car x)) (smint-able (cadr x))) - (cons 'qslessp x)) - ('t (list '> (CADR x) (CAR x))))) - -(defun smint-able (x) - (or (smintp x) - (and (pairp x) (memq (car x) '(|One| |Zero| LENGTH \# QCSIZE QVSIZE QLENGTH))))) - -(defun DEF-PROCESS (X &aux $MACROASSOC) - (COND ((EQCAR X 'DEF) (DEF (SECOND X) (THIRD X) (FIRST (CDDDDR X)))) - ((EQCAR X 'MDEF) (B-MDEF (SECOND X) (THIRD X) (FIRST (CDDDDR X)))) - ((AND (EQCAR X 'WHERE) (EQCAR (cadr X) 'DEF)) - (let* ((u (cadr X)) (Y (cdr U))) - (DEF-PROCESS (LIST 'DEF - (car Y) - (car (setq Y (cdr Y))) - (car (setq Y (cdr Y))) - (CONS 'WHERE (cons (car (setq Y (cdr Y))) (cddr X))))))) - ((IS-CONSOLE |$OutputStream|) - (SAY " VALUE = " (EVAL (DEFTRAN X)))) - ((print-full (DEFTRAN X))))) - -(defun B-MDEF (FORM SIGNATURE $BODY) - (declare (ignore SIGNATURE)) - (let* ($OpAssoc - ($op (first form)) (argl (cdr form)) - (GARGL (MAPCAR #'(LAMBDA (X) (GENSYM)) ARGL)) - ($BODY (SUBLISLIS GARGL ARGL (|bootTransform| (DEFTRAN $BODY)))) - ($BODY (LIST 'SUBLISLIS (CONS 'LIST GARGL) (LIST 'QUOTE GARGL) - (LIST 'QUOTE $BODY)))) - (|backendCompile| (SUBLIS $OPASSOC - (LIST (LIST $OP (LIST 'MLAMBDA (CONS () GARGL) $BODY))))))) - -(defun DEF-INNER (FORM SIGNATURE $BODY) - "Same as DEF but assumes body has already been DEFTRANned" - (let ($OpAssoc ($op (first form)) (argl (rest form))) - (let* ((ARGL (DEF-INSERT_LET ARGL)) - (ARGLP (DEF-STRINGTOQUOTE ARGL))) - (|backendCompile| (SUBLIS $OPASSOC `((,$OP (LAM ,ARGLP ,$BODY)))))))) - -(defun DEF-INSERT_LET (X) - (if (ATOM X) X - (CONS (DEF-INSERT_LET1 (FIRST X)) (DEF-INSERT_LET (CDR X))))) - -(defun DEF-INSERT_LET1 (Y) - (if (EQCAR Y 'SPADLET) - (COND ((IDENTP (SECOND Y)) - (setq $BODY - (MKPROGN - (LIST (DEF-LET (THIRD Y) (SECOND Y)) $BODY))) - (setq Y (SECOND Y))) - ((IDENTP (THIRD Y)) - (setq $BODY - (MKPROGN (LIST (DEFTRAN Y) $BODY))) (setq Y (THIRD Y))) - ((ERRHUH))) - Y)) - -(defun MKPROGN (L) (MKPF L 'PROGN)) - -(defun DEF-STRINGTOQUOTE (X) - (COND ((STRINGP X) (LIST 'QUOTE (INTERN X))) - ((ATOM X) X) - ((CONS (DEF-ADDLET (FIRST X)) (DEF-STRINGTOQUOTE (CDR X)))))) - -(defun DEF-ADDLET (X) - (if (ATOM X) - (if (STRINGP X) `(QUOTE ,(intern x)) X) - (let ((g (gensym))) - (setq $body (mkprogn - (list (def-let (comp\,fluidize x) g) - $body))) - g))) - -(mapcar #'(lambda (x) (MAKEPROP (CAR X) 'RENAME (CDR X))) - '((|true| 'T) (|otherwise| 'T) (|false| NIL) - (|and| AND) (|or| OR) (|is| IS) - (|list| LIST) (|cons| CONS) (|car| CAR) (|cdr| CDR) - (|setDifference| SETDIFFERENCE) (INTERSECTION |intersection|) - (|setIntersection| |intersection|) (|setUnion| |union|) - (UNION |union|) (REMOVE |remove|) (MEMBER |member|) (ASSOC |assoc|) - (READ VMREAD) (READ-LINE |read-line|) - (|apply| APPLY) (|lastNode| LASTPAIR) (LAST |last|) - (|in| |member|) (|strconc| STRCONC) (|append| APPEND) - (|copy| COPY) (DELETE |delete|) (RASSOC |rassoc|) - (|size| SIZE) (|nconc| NCONC) - (|setPart| SETELT) (|where| WHERE) - (|first| CAR) (|rest| CDR) (|substitute| MSUBST) - (|removeDuplicates| REMDUP) (|reverse| REVERSE) (|nreverse| NREVERSE) - (|drop| DROP) (|take| TAKE) (|croak| CROAK) (|genvar| GENVAR) - (|mkpf| MKPF) (^= NEQUAL) (= EQUAL) (- SPADDIFFERENCE) - (+ PLUS) (* TIMES) (/ QUOTIENT) - (** EXPT) (|return| RETURN) (|exit| EXIT) (\| SUCHTHAT) - (^ NULL) (|not| NULL) (NOT NULL) (REDUCE spadReduce) (DO spadDo) - (|atom| ATOM) (|nil| NIL) (|null| NULL) (GET GETL) - (T T$))) - -; This two-level call allows DEF-RENAME to be locally bound to do -; nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp) - -(defun DEF-RENAME (X) (DEF-RENAME1 X)) - -(defun DEF-RENAME1 (X) - (COND ((symbolp X) (let ((y (get x 'rename))) (if y (first y) x))) - ((and (listp X) X) - (if (EQCAR X 'QUOTE) - X - (CONS (DEF-RENAME1 (FIRST X)) (DEF-RENAME1 (CDR X))))) - (X))) - -(defun DEFTRAN (X) - (let (op Y) - (COND ((STRINGP X) (DEF-STRING X)) - ((IDENTP X) (COND ((LASSOC X $MACROASSOC)) (X))) - ((ATOM X) X) - ((EQ (setq OP (FIRST X)) 'WHERE) (DEF-WHERE (CDR X))) - ((EQ OP 'REPEAT) (DEF-REPEAT (CDR X))) - ((EQ OP 'COLLECT) (DEF-COLLECT (CDR X))) - ((EQ OP 'MAKESTRING) - (COND ((STRINGP (SECOND X)) X) - ((EQCAR (SECOND X) 'QUOTE) - (LIST 'MAKESTRING (STRINGIMAGE (CADADR X)))) - ((LIST 'MAKESTRING (DEFTRAN (SECOND X)) )) )) - ((EQ OP 'QUOTE) - (if (STRINGP (setq y (SECOND X))) (LIST 'MAKESTRING y) - (if (and (identp y) (char= (elt (pname y) 0) #\.)) - `(intern ,(pname y) ,(package-name *package*)) x))) - ((EQ OP 'IS) (|defIS| (CADR X) (CADDR X))) - ((EQ OP 'SPADLET) (DEF-LET (CADR X) (caddr x))) - ((EQ OP 'DCQ) (LIST 'DCQ (SECOND X) (DEFTRAN (THIRD X)))) - ((EQ OP 'COND) (CONS 'COND (DEF-COND (CDR X)))) - ((member (FIRST X) '(|sayBrightly| SAY MOAN CROAK) :test #'eq) - (DEF-MESSAGE X)) - ((setq Y (GETL (FIRST X) 'DEF-TRAN)) - (funcall Y (MAPCAR #'DEFTRAN (CDR X)))) - ((mapcar #'DEFTRAN X))))) - -(defun DEF-SEQ (U) (SEQOPT (CONS 'SEQ U))) - -(defun DEF-MESSAGE (U) (CONS (FIRST U) (mapcar #'def-message1 (cdr u)))) - -(defun DEF-MESSAGE1 (V) - (COND ((AND (STRINGP V) (> (SIZE V) 0) (NOT (EQ (ELT V 0) '\%))) - (LIST 'MAKESTRING V)) - ((EQCAR V 'CONS) (LIST 'CONS (DEF-MESSAGE1 (SECOND V)) - (DEF-MESSAGE1 (THIRD V)))) - ((DEFTRAN V)))) - -(defun |DEF-:| (X &aux Y) - (DCQ (x y) x) - `(SPADLET ,(if (or (eq y '|fluid|) - (and (identp x) (char= #\$ (ELT (PNAME X) 0)))) - `(FLUID ,X) X) - NIL)) - -(defmacro |DEF-::| (X) - (let ((expr (first x)) (type (second x))) - (if (EQUAL TYPE '(|Triple|)) EXPR (ERRHUH)))) - -(defun DEF-COLLECT (L) (DEF-IT 'COLLECT (MAPCAR #'DEFTRAN (HACKFORIS L)))) - -(defun DEF-REPEAT (L) (DEF-IT 'REPEAT (mapcar #'DEFTRAN (HACKFORIS L)))) - -(defun HACKFORIS (L) (mapcar #'hackforis1 L)) - -(defun HACKFORIS1 (X) - (if (AND (MEMBER (KAR X) '(IN ON)) (EQCAR (SECOND X) 'IS)) - (CONS (FIRST X) (CONS (CONS 'SPADLET (CDADR X)) (CDDR X))) - X)) - -(defun DEF-select (L) - (cond ((IDENTP (FIRST L)) (DEF-select1 (FIRST L) (SECOND L))) - ((LET* ((G (GENSYM)) - (U (DEF-select1 G (SECOND L)))) - (LIST 'PROGN (LIST 'SPADLET G (FIRST L)) U))))) - -(defun DEF-select1 (X Y) - (if (EQCAR Y 'SEQ) - (CONS 'COND (DEF-select2 X (CDR Y))) - (MOAN (format nil "Unexpected CASE body: ~S" Y)))) - -(defun DEF-select2 (X Y) - (let (u v) - (COND ((NOT Y) (MOAN "Unexpected CASE clause termination")) - ((EQCAR (setq U (FIRST Y)) 'EXIT) - (LIST (LIST ''T (SECOND U)))) - ((AND (EQCAR U 'COND) (NOT (CDDR U)) - (EQCAR (SECOND (setq V (SECOND U))) 'EXIT)) - (CONS (LIST (DEF-IS (LIST X (FIRST V))) (CADADR V)) - (DEF-select2 X (CDR Y)))) - ((MOAN (format nil "Unexpected CASE clause: ~S" (FIRST Y))))))) - -(defun DEF-IT (FN L) - (setq L (reverse L)) - (let ((B (first L))) - (let ((it (DEF-IN2ON (NREVERSE (rest L))))) - (let ((itp - (apply #'APPEND - (mapcar - #'(lambda (x &aux OP Y G) - (if (AND (MEMBER (setq OP (FIRST X)) '(IN ON)) - (NOT (ATOM (SECOND X)))) - (if (EQCAR (setq Y (SECOND X)) 'SPADLET) - (if (ATOM (setq G (SECOND Y))) - (LIST `(,OP ,G - ,(DEFTRAN (THIRD X))) - `(RESET - ,(DEF-LET - (DEFTRAN - (THIRD Y)) G))) - (ERRHUH)) - (LIST - `(,OP ,(setq G (GENSYM)) - ,(DEFTRAN (THIRD X))) - `(RESET - ,(DEF-LET (DEFTRAN (SECOND X)) - G)))) - `(,X))) - IT)))) - (CONS FN (NCONC ITP (LIST B))))))) - -(defun DEF-IN2ON (IT) - (mapcar #'(lambda (x) (let (u) - (COND - ((AND (EQCAR X 'IN) (EQCAR (THIRD X) '|tails|)) - (LIST 'ON (SECOND X) (SECOND (THIRD X)))) - ((AND (EQCAR X 'IN) (EQCAR (setq U (THIRD X)) 'SEGMENT)) - (COND - ((THIRD U) (LIST 'STEP (SECOND X) (SECOND U) 1 (THIRD U))) - ((LIST 'STEP (SECOND X) (SECOND U) 1)) )) - ((AND (EQCAR X 'INBY) (EQCAR (setq U (THIRD X)) 'SEGMENT)) - (COND - ((THIRD U) (LIST 'STEP (SECOND X) (SECOND U) (|last| x) (THIRD U))) - ((LIST 'STEP (SECOND X) (SECOND U) (|last| x))) )) - (X)))) - IT)) - -(defun DEF-COND (L) - (COND ((NOT L) NIL) - ((CONS (MAPCAR #'DEFTRAN (FIRST L)) (DEF-COND (CDR L)))))) - -(defun DEF-LET (FORM RHS) - (setq FORM (if (EQCAR FORM '\:) FORM (macroexpand FORM))) - (prog (F1 F2) - (COND ((EQCAR FORM '\:) - (SPADLET F1 (DEFTRAN FORM)) - (SPADLET F2 (DEFTRAN (LIST 'SPADLET (CADR FORM) RHS))) - (COND ((AND (EQ (CAR F2) 'SPADLET) (EQUAL (CADR F2) (CADR FORM))) - (RETURN (LIST 'SPADLET (CADR F1) (CADDR F2)) )) - ('T (RETURN (LIST 'PROGN F1 F2)) )) ) - ((EQCAR FORM 'ELT) (RETURN - (DEFTRAN (LIST 'SETELT (CADR FORM) (CADDR FORM) RHS)) ))) - (RETURN - (COND (|$useDCQnotLET| (|defLETdcq| FORM (DEFTRAN RHS))) - ('T (|defLET| FORM (DEFTRAN RHS))))))) - -(defun |defLETdcq| (FORM RHS &AUX G NAME) - ;; see defLET in G-BOOT BOOT - (COND - ((IDENTP FORM) (LIST 'SPADLET FORM RHS)) - ((IDENTP RHS) - (LIST 'COND (LIST (DEFTRAN (LIST 'IS RHS FORM)) RHS) - (LIST ''T (LIST 'LET_ERROR (LIST 'MAKESTRING - (MK_LEFORM FORM)) RHS)))) - ((AND (EQ (CAR RHS) 'SPADLET) (IDENTP (SETQ NAME (CADR RHS)) )) - (SPADLET G (GENSYM)) - (LIST 'COND (LIST (SUBST RHS G (DEFTRAN (LIST 'IS G FORM))) NAME) - (LIST ''T (LIST 'LET_ERROR (LIST 'MAKESTRING - (MK_LEFORM FORM)) NAME)))) - ('T (SPADLET G (GENSYM)) - (LIST 'COND (LIST (SUBST (LIST 'SPADLET G RHS) G - (DEFTRAN (LIST 'IS G FORM))) G) - (LIST ''T (LIST 'LET_ERROR (LIST 'MAKESTRING - (MK_LEFORM FORM)) G)) ) ))) - - -(defun LET_ERROR (FORM VAL) - (|systemError| (format nil "~S is not matched by structure ~S~%" FORM VAL))) - -(defun DEF-ISNT (X) (DEFTRAN (LIST 'NULL (CONS 'IS X)))) - -(defparameter $IS-GENSYMLIST nil) - -(defparameter Initial-Gensym (list (gensym))) - -(defun DEF-IS (X) - (let (($IS-GENSYMLIST Initial-Gensym)) - (DEF-IS2 (first X) (second x)))) - -(defun IS-GENSYM () - (if (NOT (CDR $IS-GENSYMLIST)) (RPLACD $IS-GENSYMLIST (LIST (GENSYM)))) - (pop $IS-GENSYMLIST)) - -(defparameter $IS-EQLIST nil) -(defparameter $IS-SPILL_LIST nil) - -(defun DEF-IS2 (FORM STRUCT) - (let ($IS-EQLIST $IS-SPILL_LIST (FORM (DEFTRAN FORM))) - (if (EQCAR STRUCT '|%Comma|) - (MOAN "you must use square brackets around right arg. to" '%b "is" '%d)) - (let* ((X (DEF-IS-EQLIST (DEF-IS-REMDUP STRUCT))) - (CODE (if (IDENTP X) - (MKPF (SUBST FORM X $IS-EQLIST) 'AND) - (MKPF `((DCQ ,X ,FORM) . ,$IS-EQLIST) 'AND)))) - (let ((CODE (MKPF `(,CODE . ,$IS-SPILL_LIST) 'AND))) - (if $TRACELETFLAG - (let ((L (remove-if #'gensymp (listofatoms x)))) - `(PROG1 ,CODE - ,@(mapcar #'(lambda (y) `(/tracelet-print ,y ,y)) L))) - CODE))))) - -(defun DEF-STRING (X) - ;; following patches needed to fix reader bug in Lucid Common Lisp - (if (and (> (size x) 0) (or (char= (elt x 0) #\.) (char= (elt x 0) #\Page))) - `(INTERN ,X ,(package-name *PACKAGE*)) - `(QUOTE ,(DEFTRAN (INTERN X))))) - -(defun DEF-IS-EQLIST (STR) - (let (g e) - (COND ((NOT STR) (PUSH `(EQ ,(setq G (IS-GENSYM)) NIL) $IS-EQLIST) G) - ((EQ STR '\.) (IS-GENSYM)) - ((IDENTP STR) STR) - ((STRINGP STR) - (setq E (DEF-STRING STR)) - (PUSH (LIST (if (ATOM (SECOND E)) 'EQ 'EQUAL) - (setq G (IS-GENSYM)) E) - $IS-EQLIST) - G) - ((OR (NUMBERP STR) (MEMBER STR '((|Zero|) (|One|)))) - (PUSH (LIST 'EQ (setq G (IS-GENSYM)) STR) $IS-EQLIST) - G) - ((ATOM STR) (ERRHUH)) - ((EQCAR STR 'SPADLET) - (COND ((IDENTP (SECOND STR)) - (PUSH (DEF-IS2 (cadr str) (caddr STR)) $IS-SPILL_LIST) - (SECOND STR)) - ((IDENTP (THIRD STR)) - (PUSH (DEFTRAN STR) $IS-SPILL_LIST) (THIRD STR)) - ((ERRHUH)) )) - ((EQCAR STR 'QUOTE) - (PUSH (LIST (COND ((ATOM (SECOND STR)) 'EQ) - ('EQUAL)) - (setq G (IS-GENSYM)) STR) $IS-EQLIST) G) - ((EQCAR STR 'LIST) (DEF-IS-EQLIST (LIST2CONS STR))) - ((OR (EQCAR STR 'CONS) (EQCAR STR 'VCONS)) - (CONS (DEF-IS-EQLIST (SECOND STR)) (DEF-IS-EQLIST (THIRD STR)))) - ((EQCAR STR 'APPEND) - (if (NOT (IDENTP (SECOND STR))) (ERROR "CANT!")) - (PUSH (DEF-IS2 (LIST 'REVERSE (setq G (IS-GENSYM))) - (DEF-IS-REV (THIRD STR) (SECOND STR))) - $IS-EQLIST) - (COND ((EQ (SECOND STR) '\.) ''T) - ((PUSH (SUBST (SECOND STR) 'L '(OR (setq L (NREVERSE L)) T)) - - $IS-SPILL_LIST))) - G) - ((ERRHUH))))) - -(defparameter $vl nil) - -(defun def-is-remdup (x) (let ($vl) (def-is-remdup1 x))) - -(defun def-is-remdup1 (x) - (let (rhs lhs g) - (COND ((NOT X) NIL) - ((EQ X '\.) X) - ((IDENTP X) - (COND ((MEMBER X $VL) - (PUSH (LIST 'EQUAL (setq G (IS-GENSYM)) X) $IS-EQLIST) G) - ((PUSH X $VL) X))) - ((MEMBER X '((|Zero|) (|One|))) X) - ((ATOM X) X) - ((EQCAR X 'SPADLET) - (setq RHS (DEF-IS-REMDUP1 (THIRD X))) - (setq LHS (DEF-IS-REMDUP1 (SECOND X))) - (LIST 'SPADLET LHS RHS)) - ((EQCAR X '%LET) - (setq RHS (DEF-IS-REMDUP1 (THIRD X))) - (setq LHS (DEF-IS-REMDUP1 (SECOND X))) - (LIST '%LET LHS RHS)) - ((EQCAR X 'QUOTE) X) - ((AND (EQCAR X 'EQUAL) (NOT (CDDR X))) - (PUSH (LIST 'EQUAL (setq G (IS-GENSYM)) (SECOND X)) $IS-EQLIST) G) - ((MEMBER (FIRST X) '(LIST APPEND CONS VCONS)) - (CONS (COND ((EQ (FIRST X) 'VCONS) 'CONS) ( (FIRST X))) - (mapcar #'def-is-remdup1 (cdr x)))) - ((ERRHUH))))) - -(defun LIST2CONS (X) -"Produces LISP code for constructing a list, involving only CONS." - (LIST2CONS-1 (CDR X))) - -(defun LIST2CONS-1 (X) - (if (NOT X) NIL (LIST 'CONS (FIRST X) (LIST2CONS-1 (CDR X))))) - -(defun DEF-IS-REV (X A) - (let (y) - (if (EQ (FIRST X) 'CONS) - (COND ((NOT (THIRD X)) (LIST 'CONS (SECOND X) A)) - ((setq Y (DEF-IS-REV (THIRD X) NIL)) - (setf (THIRD Y) (LIST 'CONS (SECOND X) A)) - Y)) - (ERRHUH)))) - -(defparameter $DEFSTACK nil) - -(defun DEF-WHERE (args) - (let ((x (car args)) (y (cdr args)) $DEFSTACK) - (let ((u (DEF-WHERECLAUSELIST Y))) - (mapc #'(lambda (X) (DEF-INNER (FIRST X) NIL - (SUBLIS $OPASSOC (SECOND X)))) - $DEFSTACK) - (MKPROGN (NCONC U (LIST (DEFTRAN X))))))) - -(defun DEF-WHERECLAUSELIST (L) - (if (NOT (CDR L)) - (DEF-WHERECLAUSE (DEFTRAN (FIRST L))) - (REDUCE #'APPEND - (mapcar #'(lambda (u) (def-whereclause (deftran u))) L)))) - -(defun DEF-WHERECLAUSE (X) - (COND ((OR (EQCAR X 'SEQ) (EQCAR X 'PROGN)) - (reduce #'append (mapcar #'def-whereclause (cdr x)))) - ((EQCAR X 'DEF) (WHDEF (SECOND X) (FIRST (CDDDDR X))) NIL) - ((AND (EQCAR X '|exit|) (EQCAR (SECOND X) 'DEF)) - (WHDEF (CADADR X) (FIRST (CDDDDR (SECOND X)) )) NIL) - ((LIST X)))) - -(defun WHDEF (X Y) - "Returns no value -- side effect is to do a compilation or modify a global." - (prog ((XP (if (ATOM X) (LIST X) X)) Op) - (COND ((NOT (CDR XP)) - (RETURN (PUSH (CONS (FIRST XP) Y) $MACROASSOC)))) - (setq OP (INTERNL (PNAME $OP) "\," (FIRST XP))) - (SETQ $OPASSOC (PUSH (CONS (FIRST XP) OP) $OPASSOC)) - (SETQ $DEFSTACK (CONS (LIST (CONS OP (CDR XP)) Y) $DEFSTACK)) - NIL)) - - -(mapcar #'(lambda (x) (MAKEPROP (first X) 'SEL\,FUNCTION (second X))) - '((|aTree| 0) (|aMode| 1) - (|aValue| 2) (|aModeSet| 3) - (|aGeneral| 4) (|expr| CAR) - (|mode| CADR) (|env| CADDR) - (|mmDC| CAAR) (|cacheName| CADR) - (|cacheType| CADDR) (|cacheReset| CADDDR) - (|cacheCount| CADDDDR)(|mmSignature| CDAR) - (|mmTarget| CADAR) (|mmCondition| CAADR) - (|mmImplementation| CADADR) - (|streamName| CADR) (|streamDef| CADDR) - (|streamCode| CADDDR) (|opSig| CADR) - (|attributes| CADDR) (|op| CAR) - (|opcode| CADR) (|sig| CDDR) - (|source| CDR) (|target| CAR) - (|first| CAR) (|rest| CDR))) - -(defun DEF-ELT (args) - (let ((EXPR (car args)) (SEL (cadr args))) - (let (Y) - (COND ((and (symbolp sel) (setq Y (GET SEL 'SEL\,FUNCTION))) - (COND ((INTEGERP Y) (LIST 'ELT EXPR Y)) - ((LIST Y EXPR)))) - ((LIST 'ELT EXPR SEL)))))) - -(defun DEF-SETELT (args) - (let ((VAR (first args)) (SEL (second args)) (EXPR (third args))) - (let ((y (and (symbolp sel) (get sel 'sel\,function)))) - (COND (y (COND ((INTEGERP Y) (LIST 'SETELT VAR Y EXPR)) - ((LIST 'RPLAC (LIST Y VAR) EXPR)))) - ((LIST 'SETELT VAR SEL EXPR)))))) - -(defun DEF-CATEGORY (L) - (let (siglist atlist) - (mapcar #'(lambda (x) (if (EQCAR (KADR X) 'Signature) - (PUSH X SIGLIST) - (PUSH X ATLIST))) - L) - (LIST 'CATEGORY (MKQ (NREVERSE SIGLIST)) (MKQ (NREVERSE ATLIST))))) - - -(defun LIST2STRING (X) -"Converts a list to a string which looks like a printed list, -except that elements are separated by commas." - (COND ((ATOM X) (STRINGIMAGE X)) - ((STRCONC "(" (LIST2STRING (FIRST X)) (LIST2STRING1 (CDR X)) ")")))) - -(defun LIST2STRING1 (X) - (COND - ((NOT X) "") - ((STRCONC "\," (LIST2STRING (FIRST X)) (LIST2STRING1 (CDR X)))))) - -(defvar |$new2OldRenameAssoc| - '((\QUAD . \.) (\' . QUOTE) (|nil| . NIL) (|append| . APPEND) - (|union| . UNION) (|cons| . CONS))) - -(defun |new2OldLisp| (x) (|new2OldTran| (|postTransform| x))) - -(defun |new2OldTran| (x) - (PROG (G10463 a b G10465 G10466 G10467 G10469 d G10470 c) - (RETURN - (prog nil - (if (atom x) - (RETURN (let ((y (ASSOC x |$new2OldRenameAssoc|))) - (if y (cdr y) x)))) - (if (AND (dcq (g10463 a b . g10465) x) - (null G10465) - (EQ G10463 '|where|) - (dcq (g10466 . g10467) b) - (dcq ((g10469 d . g10470) . c) (reverse g10467)) - (null G10470) - (EQ G10469 '|exit|) - (EQ G10466 'SEQ) - (OR (setq c (NREVERSE c)) 'T)) - (RETURN - `(|where| ,(|new2OldTran| a) ,@(|new2OldTran| c) - ,(|new2OldTran| d)))) - (return - (case (car x) - (QUOTE x) - (DEF (|newDef2Def| x)) - (IF (|newIf2Cond| x)) - (|construct| (|newConstruct| (|new2OldTran| (cdr x)))) - (T `(,(|new2OldTran| (CAR x)) . - ,(|new2OldTran| (CDR x)))))))))) - -(defun |newDef2Def| (DEF-EXPR) - (if (not (AND (= (length def-expr) 5) (eq (car def-expr) 'DEF))) - (LET_ERROR "(DEF,form,a,b,c)" DEF-EXPR) - (let ((form (second def-expr)) - (a (third def-expr)) - (b (fourth def-expr)) - (c (fifth def-expr))) - `(DEF ,(|new2OldDefForm| form) ,(|new2OldTran| a) - ,(|new2OldTran| b) ,(|new2OldTran| c))))) - -(defun |new2OldDefForm| (x) - (cond ((ATOM x) (|new2OldTran| x)) - ((and (listp x) - (listp (car x)) - (eq (caar x) '|is|) - (= (length (car x)) 3)) - (let ((a (second (car x))) (b (third (car x))) (y (cdr x))) - (|new2OldDefForm| `((SPADLET ,a ,b) ,@y)))) - ((CONS (|new2OldTran| (CAR x)) (|new2OldDefForm| (CDR x)))))) - -(defun |newIf2Cond| (COND-EXPR) - (if (not (AND (= (length cond-expr) 4) (EQ (car cond-expr) 'IF))) - (LET_ERROR "(IF,a,b,c)" COND-EXPR)) - (let ((a (second COND-EXPR)) - (b (third COND-EXPR)) - (c (fourth COND-EXPR))) - (setq a (|new2OldTran| a) b (|new2OldTran| b) c (|new2OldTran| c)) - (cond ((EQ c '|%noBranch|) `(if ,a ,b)) - (t `(if ,a ,b ,c))))) - -(defun |newConstruct| (l) - (if (ATOM l) l - `(CONS ,(CAR l) ,(|newConstruct| (CDR l))))) diff --git a/src/interp/g-boot.boot b/src/interp/g-boot.boot deleted file mode 100644 index fe3fe608..00000000 --- a/src/interp/g-boot.boot +++ /dev/null @@ -1,466 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- Copyright (C) 2007-2010, Gabriel Dos Reis. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -import def -import g_-util -namespace BOOT - --- @(#)g-boot.boot 2.2 89/11/02 14:44:09 - ---% BOOT to LISP Translation - --- these supplement those in DEF and MACRO LISP - ---% Utilities - -$inDefLET := false -$inDefIS := false -$letGenVarCounter := 1 -$isGenVarCounter := 1 - -$LET := 'SPADLET -- LET is a standard macro in Common Lisp - -nakedEXIT? c == - atom c => NIL - [a,:d] := c - IDENTP a => - a = 'EXIT => true - a = 'QUOTE => NIL - a in '(SEQ PROG LAMBDA MLAMBDA LAM) => NIL - nakedEXIT?(d) - nakedEXIT?(a) or nakedEXIT?(d) - -mergeableCOND x == - atom(x) or x isnt ['COND,:cls] => NIL - -- to be mergeable, every result must be an EXIT and the last - -- predicate must be a pair - ok := true - while (cls and ok) repeat - [[p,:r],:cls] := cls - cons? QCDR r => ok := NIL - first(r) isnt ['EXIT,.] => ok := NIL - null(cls) and atom(p) => ok := NIL - null(cls) and (p = ''T) => ok := NIL - ok - -mergeCONDsWithEXITs l == - -- combines things like - -- (COND (foo (EXIT a))) - -- (COND (bar (EXIT b))) - -- into one COND - null l => NIL - atom l => l - atom QCDR l => l - a := QCAR l - if a is ['COND,:.] then a := flattenCOND a - am := mergeableCOND a - rest(l) is [b,:k] and am and mergeableCOND(b) => - b:= flattenCOND b - c := ['COND,:QCDR a,:QCDR b] - mergeCONDsWithEXITs [flattenCOND c,:k] - rest(l) is [b] and am => - [removeEXITFromCOND flattenCOND ['COND,:QCDR a,[''T,b]]] - [a,:mergeCONDsWithEXITs rest l] - -removeEXITFromCOND? c == - -- c is '(COND ...) - -- only can do it if every clause simply EXITs - ok := true - c := rest c - while ok and c repeat - [[p,:r],:c] := c - nakedEXIT? p => ok := NIL - [:f,r1] := r - nakedEXIT? f => ok := NIL - r1 isnt ['EXIT,r2] => ok := NIL - nakedEXIT? r2 => ok := NIL - ok - -removeEXITFromCOND c == - -- c is '(COND ...) - z := NIL - for cl in rest c repeat - atom cl => z := [cl,:z] - cond := QCAR cl - length1? cl => - cond is ["EXIT",:.] => z := [QCDR cond,:z] - z := [cl,:z] - cl' := reverse cl - lastSE := QCAR cl' - atom lastSE => z := [cl,:z] - lastSE is ["EXIT",:.] => - z := [reverse [second lastSE,:rest cl'],:z] - z := [cl,:z] - ['COND,:nreverse z] - -flattenCOND body == - -- transforms nested COND clauses to flat ones, if possible - body isnt ['COND,:.] => body - ['COND,:extractCONDClauses body] - -extractCONDClauses clauses == - -- extracts nested COND clauses into a flat structure - clauses is ['COND, [pred1,:act1],:restClauses] => - if act1 is [['PROGN,:acts]] then act1 := acts - restClauses is [[''T,restCond]] => - [[pred1,:act1],:extractCONDClauses restCond] - [[pred1,:act1],:restClauses] - [[''T,clauses]] - ---% COND and IF - -bootIF c == - -- handles IF expressions by turning them into CONDs - c is [.,p,t] => bootCOND ['COND,[p,t]] - [.,p,t,e] := c - bootCOND ['COND,[p,t],[''T,e]] - -bootCOND c == - -- handles COND expressions: c is ['COND,:.] - cls := rest c - null cls => NIL - cls is [[''T,r],:.] => r - [:icls,fcls] := cls - ncls := NIL - for cl in icls repeat - [p,:r] := cl - ncls := - r is [['PROGN,:r1]] => [[p,:r1],:ncls] - [cl,:ncls] - fcls := bootPushEXITintoCONDclause fcls - ncls := - fcls is [''T,['COND,:mcls]] => - append(reverse mcls,ncls) - fcls is [''T,['PROGN,:mcls]] => - [[''T,:mcls],:ncls] - [fcls,:ncls] - ['COND,:reverse ncls] - -bootPushEXITintoCONDclause e == - e isnt [''T,['EXIT,['COND,:cls]]] => e - ncls := NIL - for cl in cls repeat - [p,:r] := cl - ncls := - r is [['EXIT,:.]] => [cl,:ncls] - r is [r1] => [[p,['EXIT,r1]],:ncls] - [[p,['EXIT,bootTran ['PROGN,:r]]],:ncls] - [''T,['COND,:nreverse ncls]] - ---% SEQ and PROGN - --- following is a more sophisticated def than that in MACRO LISP --- it is used for boot code - -tryToRemoveSEQ e == - -- returns e if unsuccessful - e isnt ['SEQ,cl,:cls] => NIL - nakedEXIT? cl => - cl is ['COND,[p,['EXIT,r]],:ccls] => - nakedEXIT? p or nakedEXIT? r => e - null ccls => - bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,:cls]]] - bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,['COND,:ccls],:cls]]] - e - bootPROGN ['PROGN,cl,bootSEQ ['SEQ,:cls]] - -bootAbsorbSEQsAndPROGNs e == - -- assume e is a list from a SEQ or a PROGN - atom e => e - [:cls,lcl] := e - g := [:flatten(f) for f in cls] where - flatten x == - null x => NIL - IDENTP x => - MEMQ(x,$labelsForGO) => [x] - NIL - atom x => NIL - x is ['PROGN,:pcls,lpcl] => - atom lpcl => pcls - rest x - -- next usually comes about from if foo then bar := zap - x is ['COND,y,[''T,'NIL]] => [['COND,y]] - [x] - while lcl is ['EXIT,f] repeat - lcl := f - lcl is ['PROGN,:pcls] => append(g,pcls) - lcl is ['COND,[''T,:pcls]] => append(g,pcls) - lcl is ['COND,[pred,['EXIT,h]]] => - append(g,[['COND,[pred,h]]]) - append(g,[lcl]) - -bootSEQ e == - e := ['SEQ,:mergeCONDsWithEXITs bootAbsorbSEQsAndPROGNs rest e] - if e is [.,:cls,lcl] and IDENTP lcl and not MEMQ(lcl,$labelsForGO) then - e := ['SEQ,:cls,['EXIT,lcl]] - cls := QCDR e - cls is [['SEQ,:.]] => tryToRemoveSEQ QCAR cls - cls is [['EXIT,body]] => - nakedEXIT? body => bootTran ['SEQ,body] - body - not (nakedEXIT?(cls) or "or"/[MEMQ(g,$labelsForGO) for g in cls]) => - bootTran ['PROGN,:cls] - e is ['SEQ,['COND,[pred,['EXIT,r1]]],:r2] => - nakedEXIT?(pred) or nakedEXIT?(r1) or nakedEXIT?(r2) => - tryToRemoveSEQ e - bootTran ['COND,[pred,r1],[''T,:r2]] - tryToRemoveSEQ e - -bootPROGN e == - e := ['PROGN,:bootAbsorbSEQsAndPROGNs rest e] - [.,:cls] := e - null cls => NIL - cls is [body] => body - e - ---% LET - -defLetForm(lhs,rhs) == ---if functionp lhs then --- sayMSG ['"Danger: Reassigning value to LISP function:",:bright lhs] - [$LET,lhs,rhs] - -defLET1(lhs,rhs) == - IDENTP lhs => defLetForm(lhs,rhs) - lhs is ['FLUID,id] => defLetForm(lhs,rhs) - IDENTP rhs and not CONTAINED(rhs,lhs) => - rhs' := defLET2(lhs,rhs) - EQCAR(rhs',$LET) => MKPROGN [rhs',rhs] - rhs' is ["PROGN",:.] => append(rhs',[rhs]) - if IDENTP first rhs' then rhs' := [rhs',:NIL] - MKPROGN [:rhs',rhs] - rhs is [=$LET,:.] and IDENTP(name := second rhs) => - -- handle things like [a] := x := foo - l1 := defLET1(name,third rhs) - l2 := defLET1(lhs,name) - l2 is ["PROGN",:.] => MKPROGN [l1,:rest l2] - if IDENTP first l2 then l2 := [l2,:nil] - MKPROGN [l1,:l2,name] - g := INTERN strconc('"LETTMP#",STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - rhs' := [$LET,g,rhs] - let' := defLET1(lhs,g) - let' is ["PROGN",:.] => MKPROGN [rhs',:rest let'] - if IDENTP first let' then let' := [let',:NIL] - MKPROGN [rhs',:let',g] - -defLET2(lhs,rhs) == - IDENTP lhs => defLetForm(lhs,rhs) - null lhs => NIL - lhs is ['FLUID,id] => defLetForm(lhs,rhs) - lhs is [=$LET,a,b] => - a := defLET2(a,rhs) - null (b := defLET2(b,rhs)) => a - atom b => [a,b] - cons? QCAR b => [a,:b] - [a,b] - lhs is ['CONS,var1,var2] => - var1 = "." or (var1 is ["QUOTE",:.]) => - defLET2(var2,addCARorCDR('CDR,rhs)) - l1 := defLET2(var1,addCARorCDR('CAR,rhs)) - var2 in '(NIL _.) => l1 - if cons? l1 and atom first l1 then l1 := [l1,:nil] - IDENTP var2 => - [:l1,defLetForm(var2,addCARorCDR('CDR,rhs))] - l2 := defLET2(var2,addCARorCDR('CDR,rhs)) - if cons? l2 and atom first l2 then l2 := [l2,:nil] - append(l1,l2) - lhs is ['APPEND,var1,var2] => - patrev := defISReverse(var2,var1) - rev := ['REVERSE,rhs] - g := INTERN strconc('"LETTMP#",STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - l2 := defLET2(patrev,g) - if cons? l2 and atom first l2 then l2 := [l2,:nil] - var1 = "." => [[$LET,g,rev],:l2] - last l2 is [=$LET, =var1, val1] => - [[$LET,g,rev],:reverse rest reverse l2, - defLetForm(var1,['NREVERSE,val1])] - [[$LET,g,rev],:l2,defLetForm(var1,['NREVERSE,var1])] - lhs is ['EQUAL,var1] => - ['COND,[['EQUAL,var1,rhs],var1]] - -- let the IS code take over from here - isPred := - $inDefIS => defIS1(rhs,lhs) - defIS(rhs,lhs) - ['COND,[isPred,rhs]] - -defLET(lhs,rhs) == - $letGenVarCounter : local := 1 - $inDefLET : local := true - defLET1(lhs,rhs) - -addCARorCDR(acc,expr) == - atom expr => [acc,expr] - acc = 'CAR and expr is ["REVERSE",:.] => - ['last,:QCDR expr] - funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR - CDAAR CDDAR CDADR CDDDR) - p := position(QCAR expr,funs) - p = -1 => [acc,expr] - funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR - CAADDR CADAAR CADDAR CADADR CADDDR) - funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR - CDADDR CDDAAR CDDDAR CDDADR CDDDDR) - if acc = 'CAR then [funsA.p,:QCDR expr] - else [funsR.p,:QCDR expr] - - ---% IS - -defISReverse(x,a) == - -- reverses forms coming from APPENDs in patterns - -- pretty much just a translation of DEF-IS-REV - x is ['CONS,:.] => - null third x => ['CONS,second x, a] - y := defISReverse(third x, NIL) - y.rest.rest.first := ['CONS,second x,a] - y - ERRHUH() - -defIS1(lhs,rhs) == - null rhs => - ['NULL,lhs] - string? rhs => - ['EQ,lhs,['QUOTE,INTERN rhs]] - NUMBERP rhs => - ['EQUAL,lhs,rhs] - atom rhs => - ['PROGN,defLetForm(rhs,lhs),''T] - rhs is ['QUOTE,a] => - IDENTP a => ['EQ,lhs,rhs] - ['EQUAL,lhs,rhs] - rhs is [=$LET,c,d] => - l := - $inDefLET => defLET1(c,lhs) - defLET(c,lhs) - ['AND,defIS1(lhs,d),MKPROGN [l,''T]] - rhs is ['EQUAL,a] => - ['EQUAL,lhs,a] - cons? lhs => - g := INTERN strconc('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - MKPROGN [[$LET,g,lhs],defIS1(g,rhs)] - rhs is ['CONS,a,b] => - a = "." => - null b => - ['AND,['CONSP,lhs], - ['EQ,['QCDR,lhs],'NIL]] - ['AND,['CONSP,lhs], - defIS1(['QCDR,lhs],b)] - null b => - ['AND,['CONSP,lhs], - ['EQ,['QCDR,lhs],'NIL],_ - defIS1(['QCAR,lhs],a)] - b = "." => - ['AND,['CONSP,lhs],defIS1(['QCAR,lhs],a)] - a1 := defIS1(['QCAR,lhs],a) - b1 := defIS1(['QCDR,lhs],b) - a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] => - ['AND,['CONSP,lhs],MKPROGN [c,:cls]] - ['AND,['CONSP,lhs],a1,b1] - rhs is ['APPEND,a,b] => - patrev := defISReverse(b,a) - g := INTERN strconc('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - rev := ['AND,['CONSP,lhs],['PROGN,[$LET,g,['REVERSE,lhs]],''T]] - l2 := defIS1(g,patrev) - if cons? l2 and atom first l2 then l2 := [l2,:nil] - a = "." => ['AND,rev,:l2] - ['AND,rev,:l2,['PROGN,defLetForm(a,['NREVERSE,a]),''T]] - SAY '"WARNING (defIS1): possibly bad IS code being generated" - DEF_-IS [lhs,rhs] - -defIS(lhs,rhs) == - $isGenVarCounter : local := 1 - $inDefIS : local := true - defIS1(DEFTRAN lhs,rhs) - ---% OR and AND - -bootOR e == - -- flatten any contained ORs. - cls := rest e - null cls => NIL - null rest cls => first cls - ncls := [:flatten(c) for c in cls] where - flatten x == - x is ['OR,:.] => QCDR x - [x] - ['OR,:ncls] - -bootAND e == - -- flatten any contained ANDs. - cls := rest e - null cls => 'T - null rest cls => first cls - ncls := [:flatten(c) for c in cls] where - flatten x == - x is ['AND,:.] => QCDR x - [x] - ['AND,:ncls] - ---% Main Transformation Functions - -bootLabelsForGO e == - atom e => NIL - [head,:tail] := e - IDENTP head => - head = 'GO => $labelsForGO := [first tail,:$labelsForGO] - head = 'QUOTE => NIL - bootLabelsForGO tail - bootLabelsForGO head - bootLabelsForGO tail - -bootTran e == - atom e => e - [head,:tail] := e - head = 'QUOTE => e - tail := [bootTran t for t in tail] - e := [head,:tail] - IDENTP head => - head = 'IF => bootIF e - head = 'COND => bootCOND e - head = 'PROGN => bootPROGN e - head = 'SEQ => bootSEQ e - head = 'OR => bootOR e - head = 'AND => bootAND e - e - [bootTran head,:QCDR e] - -bootTransform e == ---null $BOOT => e - $labelsForGO : local := NIL - bootLabelsForGO e - bootTran e diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index 65368f84..7b85a8e6 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -32,7 +32,7 @@ -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -import def +import macros namespace BOOT --% diff --git a/src/interp/i-util.boot b/src/interp/i-util.boot index 2a571c5e..9c602844 100644 --- a/src/interp/i-util.boot +++ b/src/interp/i-util.boot @@ -155,3 +155,20 @@ validateVariableNameOrElse var == not IDENTP var => throwKeyedMsg("S2IS0016",[STRINGIMAGE var]) var in '(% %%) => throwKeyedMsg("S2IS0050",[var]) true + +--% + +flattenCOND body == + -- transforms nested COND clauses to flat ones, if possible + body isnt ['COND,:.] => body + ['COND,:extractCONDClauses body] + +extractCONDClauses clauses == + -- extracts nested COND clauses into a flat structure + clauses is ['COND, [pred1,:act1],:restClauses] => + if act1 is [['PROGN,:acts]] then act1 := acts + restClauses is [[''T,restCond]] => + [[pred1,:act1],:extractCONDClauses restCond] + [[pred1,:act1],:restClauses] + [[''T,clauses]] + diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot index c4ee9412..19a968cc 100644 --- a/src/interp/wi1.boot +++ b/src/interp/wi1.boot @@ -623,7 +623,7 @@ setqMultiple(nameList,val,m,e) == [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr for x in nameList for [y,:z] in selectorModePairs] if assignList="failed" then NIL - else [MKPROGN [x,:assignList,g],m',e] + else [mkpf([x,:assignList,g],'PROGN),m',e] setqMultipleExplicit(nameList,valList,m,e) == #nameList ~= #valList => |