diff --git a/Makefile b/Makefile diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet diff --git a/src/interp/def.lisp.pamphlet b/src/interp/def.lisp.pamphlet index 247268c..410313c 100644 --- a/src/interp/def.lisp.pamphlet +++ b/src/interp/def.lisp.pamphlet @@ -583,7 +583,7 @@ foo defined inside of fum gets renamed as fum,foo.") (COND ((and (symbolp sel) (setq Y (GET SEL 'SEL\,FUNCTION))) (COND ((INTEGERP Y) (LIST 'ELT EXPR Y)) ((LIST Y EXPR)))) - ((LIST 'ELT EXPR SEL)))))) + ((LIST 'SAFE-ELT EXPR SEL)))))) (defun DEF-SETELT (args) (let ((VAR (first args)) (SEL (second args)) (EXPR (third args))) diff --git a/src/interp/g-boot.boot.pamphlet b/src/interp/g-boot.boot.pamphlet index 5a9c83a..45e5c6d 100644 --- a/src/interp/g-boot.boot.pamphlet +++ b/src/interp/g-boot.boot.pamphlet @@ -864,7 +864,7 @@ bootTransform e == ;;; *** |addCARorCDR| REDEFINED -(DEFUN |addCARorCDR| (|acc| |expr|) (PROG (|funs| |p| |funsA| |funsR|) (RETURN (COND ((NULL (PAIRP |expr|)) (CONS |acc| (CONS |expr| NIL))) ((AND (BOOT-EQUAL |acc| (QUOTE CAR)) (EQCAR |expr| (QUOTE REVERSE))) (CONS (QUOTE |last|) (QCDR |expr|))) ((QUOTE T) (SPADLET |funs| (QUOTE (CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR CDAAR CDDAR CDADR CDDDR))) (SPADLET |p| (|position| (QCAR |expr|) |funs|)) (COND ((BOOT-EQUAL |p| (SPADDIFFERENCE 1)) (CONS |acc| (CONS |expr| NIL))) ((QUOTE T) (SPADLET |funsA| (QUOTE (CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR CAADDR CADAAR CADDAR CADADR CADDDR))) (SPADLET |funsR| (QUOTE (CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR))) (COND ((BOOT-EQUAL |acc| (QUOTE CAR)) (CONS (ELT |funsA| |p|) (QCDR |expr|))) ((QUOTE T) (CONS (ELT |funsR| |p|) (QCDR |expr|))))))))))) +(DEFUN |addCARorCDR| (|acc| |expr|) (PROG (|funs| |p| |funsA| |funsR|) (RETURN (COND ((NULL (PAIRP |expr|)) (CONS |acc| (CONS |expr| NIL))) ((AND (BOOT-EQUAL |acc| (QUOTE CAR)) (EQCAR |expr| (QUOTE REVERSE))) (CONS (QUOTE |last|) (QCDR |expr|))) ((QUOTE T) (SPADLET |funs| (QUOTE (CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR CDAAR CDDAR CDADR CDDDR))) (SPADLET |p| (|position| (QCAR |expr|) |funs|)) (COND ((BOOT-EQUAL |p| (SPADDIFFERENCE 1)) (CONS |acc| (CONS |expr| NIL))) ((QUOTE T) (SPADLET |funsA| (QUOTE (CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR CAADDR CADAAR CADDAR CADADR CADDDR))) (SPADLET |funsR| (QUOTE (CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR))) (COND ((BOOT-EQUAL |acc| (QUOTE CAR)) (CONS (SAFE-ELT |funsA| |p|) (QCDR |expr|))) ((QUOTE T) (CONS (SAFE-ELT |funsR| |p|) (QCDR |expr|))))))))))) ; ; ;--% IS diff --git a/src/interp/g-util.boot.pamphlet b/src/interp/g-util.boot.pamphlet index 878e547..c5ee28b 100644 --- a/src/interp/g-util.boot.pamphlet +++ b/src/interp/g-util.boot.pamphlet @@ -787,7 +787,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& ;;; *** |centerString| REDEFINED -(DEFUN |centerString| (|text| |width| |fillchar|) (PROG (|wid| |f| |fill2| |fill1|) (RETURN (SEQ (PROGN (SPADLET |wid| (|entryWidth| |text|)) (COND ((>= |wid| |width|) |text|) ((QUOTE T) (SPADLET |f| (DIVIDE (SPADDIFFERENCE |width| |wid|) 2)) (SPADLET |fill1| (QUOTE ||)) (DO ((#0=#:G2567 (ELT |f| 0)) (|i| 1 (QSADD1 |i|))) ((QSGREATERP |i| #0#) NIL) (SEQ (EXIT (SPADLET |fill1| (STRCONC |fillchar| |fill1|))))) (SPADLET |fill2| |fill1|) (COND ((NEQUAL (ELT |f| 1) 0) (SPADLET |fill1| (STRCONC |fillchar| |fill1|)))) (CONS |fill1| (CONS |text| (CONS |fill2| NIL)))))))))) +(DEFUN |centerString| (|text| |width| |fillchar|) (PROG (|wid| |f| |fill2| |fill1|) (RETURN (SEQ (PROGN (SPADLET |wid| (|entryWidth| |text|)) (COND ((>= |wid| |width|) |text|) ((QUOTE T) (SPADLET |f| (DIVIDE (SPADDIFFERENCE |width| |wid|) 2)) (SPADLET |fill1| (QUOTE ||)) (DO ((#0=#:G2567 (SAFE-ELT |f| 0)) (|i| 1 (QSADD1 |i|))) ((QSGREATERP |i| #0#) NIL) (SEQ (EXIT (SPADLET |fill1| (STRCONC |fillchar| |fill1|))))) (SPADLET |fill2| |fill1|) (COND ((NEQUAL (SAFE-ELT |f| 1) 0) (SPADLET |fill1| (STRCONC |fillchar| |fill1|)))) (CONS |fill1| (CONS |text| (CONS |fill2| NIL)))))))))) ;stringPrefix?(pref,str) == ; -- sees if the first #pref letters of str are pref ; -- replaces STRINGPREFIXP @@ -1160,7 +1160,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& ;;; *** |str2Tex| REDEFINED -(DEFUN |str2Tex| (|s|) (PROG (|outf| |val|) (RETURN (PROGN (SPADLET |outf| (|str2Outform| |s|)) (SPADLET |val| (|coerceInt| (|mkObj| (|wrap| |outf|) (QUOTE (|OutputForm|))) (QUOTE (|TexFormat|)))) (SPADLET |val| (|objValUnwrap| |val|)) (CAR (ELT |val| 1)))))) +(DEFUN |str2Tex| (|s|) (PROG (|outf| |val|) (RETURN (PROGN (SPADLET |outf| (|str2Outform| |s|)) (SPADLET |val| (|coerceInt| (|mkObj| (|wrap| |outf|) (QUOTE (|OutputForm|))) (QUOTE (|TexFormat|)))) (SPADLET |val| (|objValUnwrap| |val|)) (CAR (SAFE-ELT |val| 1)))))) ;opOf x == ; atom x => x ; first x @@ -1293,7 +1293,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& ;;; *** |leftTrim| REDEFINED -(DEFUN |leftTrim| (|s|) (PROG (|k| |j|) (RETURN (SEQ (PROGN (SPADLET |k| (MAXINDEX |s|)) (COND ((MINUSP |k|) |s|) ((BOOT-EQUAL (ELT |s| 0) |$blank|) (DO ((|i| 0 (QSADD1 |i|))) ((OR (QSGREATERP |i| |k|) (NULL (BOOT-EQUAL (ELT |s| |i|) |$blank|))) NIL) (SEQ (EXIT (SPADLET |j| |i|)))) (SUBSTRING |s| (PLUS |j| 1) NIL)) ((QUOTE T) |s|))))))) +(DEFUN |leftTrim| (|s|) (PROG (|k| |j|) (RETURN (SEQ (PROGN (SPADLET |k| (MAXINDEX |s|)) (COND ((MINUSP |k|) |s|) ((BOOT-EQUAL (SAFE-ELT |s| 0) |$blank|) (DO ((|i| 0 (QSADD1 |i|))) ((OR (QSGREATERP |i| |k|) (NULL (BOOT-EQUAL (SAFE-ELT |s| |i|) |$blank|))) NIL) (SEQ (EXIT (SPADLET |j| |i|)))) (SUBSTRING |s| (PLUS |j| 1) NIL)) ((QUOTE T) |s|))))))) ;rightTrim s == -- assumed a non-empty string ; k := MAXINDEX s ; k < 0 => s @@ -1304,7 +1304,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& ;;; *** |rightTrim| REDEFINED -(DEFUN |rightTrim| (|s|) (PROG (|k| |j|) (RETURN (SEQ (PROGN (SPADLET |k| (MAXINDEX |s|)) (COND ((MINUSP |k|) |s|) ((BOOT-EQUAL (ELT |s| |k|) |$blank|) (DO ((#0=#:G3107 (SPADDIFFERENCE 1)) (|i| |k| (+ |i| #0#))) ((OR (IF (MINUSP #0#) (< |i| 0) (> |i| 0)) (NULL (BOOT-EQUAL (ELT |s| |i|) |$blank|))) NIL) (SEQ (EXIT (SPADLET |j| |i|)))) (SUBSTRING |s| 0 |j|)) ((QUOTE T) |s|))))))) +(DEFUN |rightTrim| (|s|) (PROG (|k| |j|) (RETURN (SEQ (PROGN (SPADLET |k| (MAXINDEX |s|)) (COND ((MINUSP |k|) |s|) ((BOOT-EQUAL (SAFE-ELT |s| |k|) |$blank|) (DO ((#0=#:G3107 (SPADDIFFERENCE 1)) (|i| |k| (+ |i| #0#))) ((OR (IF (MINUSP #0#) (< |i| 0) (> |i| 0)) (NULL (BOOT-EQUAL (SAFE-ELT |s| |i|) |$blank|))) NIL) (SEQ (EXIT (SPADLET |j| |i|)))) (SUBSTRING |s| 0 |j|)) ((QUOTE T) |s|))))))) ;pp x == ; PRETTYPRINT x ; x @@ -1345,13 +1345,13 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& ;;; *** |intern| REDEFINED -(DEFUN |intern| (|x|) (COND ((STRINGP |x|) (COND ((DIGITP (ELT |x| 0)) (|string2Integer| |x|)) ((QUOTE T) (INTERN |x|)))) ((QUOTE T) |x|))) +(DEFUN |intern| (|x|) (COND ((STRINGP |x|) (COND ((DIGITP (SAFE-ELT |x| 0)) (|string2Integer| |x|)) ((QUOTE T) (INTERN |x|)))) ((QUOTE T) |x|))) ;isDomain a == ; REFVECP a and #a>5 and GETDATABASE(a.0,'CONSTRUCTORKIND) = 'domain ;;; *** |isDomain| REDEFINED -(DEFUN |isDomain| (|a|) (AND (REFVECP |a|) (> (|#| |a|) 5) (BOOT-EQUAL (GETDATABASE (ELT |a| 0) (QUOTE CONSTRUCTORKIND)) (QUOTE |domain|)))) +(DEFUN |isDomain| (|a|) (AND (REFVECP |a|) (> (|#| |a|) 5) (BOOT-EQUAL (GETDATABASE (SAFE-ELT |a| 0) (QUOTE CONSTRUCTORKIND)) (QUOTE |domain|)))) ;-- variables used by browser ;$htHash := MAKE_-HASH_-TABLE() @@ -1497,7 +1497,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& ;;; *** |isDefaultPackageName| REDEFINED -(DEFUN |isDefaultPackageName| (|x|) (PROG (|s|) (RETURN (BOOT-EQUAL (ELT (SPADLET |s| (PNAME |x|)) (MAXINDEX |s|)) (|char| (QUOTE &)))))) +(DEFUN |isDefaultPackageName| (|x|) (PROG (|s|) (RETURN (BOOT-EQUAL (SAFE-ELT (SPADLET |s| (PNAME |x|)) (MAXINDEX |s|)) (|char| (QUOTE &)))))) ;;;Boot translation finished for g-util.boot @ diff --git a/src/interp/i-output.boot.pamphlet b/src/interp/i-output.boot.pamphlet diff --git a/src/interp/macros.lisp.pamphlet b/src/interp/macros.lisp.pamphlet index 44a6d3e..20ace6e 100644 --- a/src/interp/macros.lisp.pamphlet +++ b/src/interp/macros.lisp.pamphlet @@ -265,13 +265,14 @@ ends up being [[CONTAINED |$EmptyMode| Y]]. `(OR (IS ,B ,A) (LET_ERROR ,(MK_LEFORM A) ,(MKQ B) )))) (defmacro RPLAC (&rest L) - (if (EQCAR (CAR L) 'ELT) + (if (or (EQCAR (CAR L) 'ELT) + (EQCAR (CAR L) 'SAFE-ELT)) (LIST 'SETELT (CADAR L) (CADDR (CAR L)) (CADR L)) (let ((A (CARCDREXPAND (CAR L) NIL)) (B (CADR L))) - (COND ((CDDR L) (ERROR 'RPLAC)) + (COND ((CDDR L) (ERROR "RPLAC")) ((EQCAR A 'CAR) (LIST 'RPLACA (CADR A) B)) ((EQCAR A 'CDR) (LIST 'RPLACD (CADR A) B)) - ((ERROR 'RPLAC)))))) + ((ERROR "RPLAC")))))) (MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'SELCODE (CADR J))) '((CAR 2) (CDR 3) (CAAR 4) (CADR 5) (CDAR 6) (CDDR 7) diff --git a/src/interp/nlib.lisp.pamphlet b/src/interp/nlib.lisp.pamphlet index 9be8dfe..bfa29b1 100644 --- a/src/interp/nlib.lisp.pamphlet +++ b/src/interp/nlib.lisp.pamphlet @@ -371,27 +371,6 @@ but has been changed to read: (directory-namestring lfile)))))))) -#+:AKCL -(defun spad-fixed-arg (fname ) - (and (equal (symbol-package fname) (find-package "BOOT")) - (not (get fname 'compiler::spad-var-arg)) - (search ";" (symbol-name fname)) - (or (get fname 'compiler::fixed-args) - (setf (get fname 'compiler::fixed-args) t))) - nil) - -#+:AKCL -(defun compile-lib-file (fn &rest opts) - (unwind-protect - (progn - (trace (compiler::fast-link-proclaimed-type-p - :exitcond nil - :entrycond (spad-fixed-arg (car system::arglist)))) - (trace (compiler::t1defun :exitcond nil - :entrycond (spad-fixed-arg (caar system::arglist)))) - (apply #'compile-file fn opts)) - (untrace compiler::fast-link-proclaimed-type-p compiler::t1defun))) -#+:CCL (define-function 'compile-lib-file #'compile-file) ;; (RDROPITEMS filearg keys) don't delete, used in files.spad diff --git a/src/interp/parse.boot.pamphlet b/src/interp/parse.boot.pamphlet index 5d9a4be..b3a11e7 100644 --- a/src/interp/parse.boot.pamphlet +++ b/src/interp/parse.boot.pamphlet @@ -693,7 +693,7 @@ parseVCONS l == ["VECTOR",:parseTranList l] ;;; *** |parseLET| REDEFINED -(DEFUN |parseLET| (#0=#:G2389) (PROG (|x| |y| |p|) (RETURN (PROGN (SPADLET |x| (CAR #0#)) (SPADLET |y| (CADR #0#)) (SPADLET |p| (CONS (QUOTE LET) (CONS (|parseTran| |x|) (CONS (|parseTranCheckForRecord| |y| (|opOf| |x|)) NIL)))) (COND ((BOOT-EQUAL (|opOf| |x|) (QUOTE |cons|)) (CONS (QUOTE LET) (CONS (|transIs| (ELT |p| 1)) (CONS (ELT |p| 2) NIL)))) ((QUOTE T) |p|)))))) +(DEFUN |parseLET| (#0=#:G2389) (PROG (|x| |y| |p|) (RETURN (PROGN (SPADLET |x| (CAR #0#)) (SPADLET |y| (CADR #0#)) (SPADLET |p| (CONS (QUOTE LET) (CONS (|parseTran| |x|) (CONS (|parseTranCheckForRecord| |y| (|opOf| |x|)) NIL)))) (COND ((BOOT-EQUAL (|opOf| |x|) (QUOTE |cons|)) (CONS (QUOTE LET) (CONS (|transIs| (SAFE-ELT |p| 1)) (CONS (SAFE-ELT |p| 2) NIL)))) ((QUOTE T) |p|)))))) ; ;parseLETD [x,y] == ['LETD,parseTran x,parseTran parseType y] @@ -862,7 +862,7 @@ parseVCONS l == ["VECTOR",:parseTranList l] ;;; *** |specialModeTran| REDEFINED -(DEFUN |specialModeTran| (|form|) (PROG (|op| |argl| |sop| |s0| |argKey| |numArgs| |zeroOrOne| |isDmp| |LETTMP#1| |vl| |extraDomain| |s3| |isUpOrMp| |domainPart| |argPart| |n| |polyForm|) (RETURN (SEQ (COND ((AND (PAIRP |form|) (PROGN (SPADLET |op| (QCAR |form|)) (SPADLET |argl| (QCDR |form|)) (QUOTE T))) (COND ((NULL (ATOM |op|)) |form|) ((BOOT-EQUAL (SPADLET |s0| (ELT (SPADLET |sop| (PNAME |op|)) 0)) (QUOTE *)) (SPADLET |n| (|#| |sop|)) (COND ((EQL |n| 1) |form|) ((QUOTE T) (SPADLET |argKey| (ELT |sop| 1)) (SPADLET |numArgs| (SPADDIFFERENCE (|#| |argl|) (COND ((BOOT-EQUAL |argKey| (QUOTE |1|)) 1) ((QUOTE T) 0)))) (SPADLET |zeroOrOne| (OR (BOOT-EQUAL |argKey| (QUOTE |0|)) (BOOT-EQUAL |argKey| (QUOTE |1|)))) (SPADLET |isDmp| (COND ((> 10 |numArgs|) (AND (EQL |n| 6) (BOOT-EQUAL (MAKESTRING "DMP") (SUBSTRING |sop| 3 3)) |zeroOrOne|)) ((QUOTE T) (AND (EQL |n| 7) (BOOT-EQUAL (MAKESTRING "DMP") (SUBSTRING |sop| 4 3)) |zeroOrOne|)))) (COND (|isDmp| (COND ((BOOT-EQUAL |argKey| (QU! OTE |0|)) (SPADLET |extraDomain| |$EmptyMode|) (SPADLET |vl| |argl|)) ((QUOTE T) (SPADLET |LETTMP#1| (REVERSE |argl|)) (SPADLET |extraDomain| (CAR |LETTMP#1|)) (SPADLET |vl| (NREVERSE (CDR |LETTMP#1|))) |argl|)) (CONS (QUOTE |DistributedMultivariatePolynomial|) (CONS (CONS (QUOTE |construct|) |vl|) (CONS (|specialModeTran| |extraDomain|) NIL)))) ((AND (EQL |n| 4) (BOOT-EQUAL (SPADLET |s3| (ELT |sop| 3)) (QUOTE M)) |zeroOrOne|) (|specialModeTran| (PROGN (SPADLET |extraDomain| (COND ((BOOT-EQUAL |argKey| (QUOTE |0|)) (CONS |$EmptyMode| NIL)) ((QUOTE T) NIL))) (COND ((EQL (SPADLET |n| (PARSE-INTEGER (PNAME (ELT |sop| 2)))) 1) (CONS (QUOTE |SquareMatrix|) (APPEND |argl| |extraDomain|))) ((EQL |n| 2) (CONS (QUOTE |RectangularMatrix|) (APPEND |argl| |extraDomain|))) ((QUOTE T) |form|))))) ((QUOTE T) (SPADLET |isUpOrMp| (COND ((> 10 |numArgs|) (OR (AND (EQL |n| 4) (BOOT-EQUAL (SPADLET |s3| (ELT |sop| 3)) (QUOTE P)) |zeroOrOne|) (AND (EQL |n| 5) (BOOT-EQUAL (SPADLET |s3| (ELT |sop|! 3)) (QUOTE R)) (BOOT-EQUAL (ELT |sop| 4) (QUOTE F)) |zeroOrOne|))) (( QUOTE T) (OR (AND (EQL |n| 5) (BOOT-EQUAL (SPADLET |s3| (ELT |sop| 4)) (QUOTE P)) |zeroOrOne|) (AND (EQL |n| 6) (BOOT-EQUAL (SPADLET |s3| (ELT |sop| 4)) (QUOTE R)) (BOOT-EQUAL (ELT |sop| 5) (QUOTE F)) |zeroOrOne|))))) (COND (|isUpOrMp| (SPADLET |polyForm| (PROGN (SPADLET |domainPart| (COND ((BOOT-EQUAL |argKey| (QUOTE |0|)) |$EmptyMode|) ((QUOTE T) (|last| |argl|)))) (SPADLET |argPart| (COND ((BOOT-EQUAL |argKey| (QUOTE |0|)) |argl|) ((QUOTE T) (DROP (SPADDIFFERENCE 1) |argl|)))) (COND ((AND (> 10 |numArgs|) (EQL (SPADLET |n| (PARSE-INTEGER (PNAME (ELT |sop| 2)))) 1)) (CONS (QUOTE UP) (APPEND |argPart| (CONS |domainPart| NIL)))) ((QUOTE T) (CONS (QUOTE MP) (CONS (CONS (QUOTE |construct|) |argPart|) (CONS |domainPart| NIL))))))) (|specialModeTran| (COND ((BOOT-EQUAL |s3| (QUOTE R)) (CONS |$QuotientField| (CONS |polyForm| NIL))) ((QUOTE T) |polyForm|)))) ((QUOTE T) (CONS (CAR |form|) (PROG (#0=#:G2725) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G2730 (CDR |form|) (CDR #1#)) (|x| NIL! )) ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (|specialModeTran| |x|) #0#))))))))))))))) ((QUOTE T) (CONS (CAR |form|) (PROG (#2=#:G2740) (SPADLET #2# NIL) (RETURN (DO ((#3=#:G2745 (CDR |form|) (CDR #3#)) (|x| NIL)) ((OR (ATOM #3#) (PROGN (SETQ |x| (CAR #3#)) NIL)) (NREVERSE0 #2#)) (SEQ (EXIT (SETQ #2# (CONS (|specialModeTran| |x|) #2#))))))))))) ((QUOTE T) |form|)))))) +(DEFUN |specialModeTran| (|form|) (PROG (|op| |argl| |sop| |s0| |argKey| |numArgs| |zeroOrOne| |isDmp| |LETTMP#1| |vl| |extraDomain| |s3| |isUpOrMp| |domainPart| |argPart| |n| |polyForm|) (RETURN (SEQ (COND ((AND (PAIRP |form|) (PROGN (SPADLET |op| (QCAR |form|)) (SPADLET |argl| (QCDR |form|)) (QUOTE T))) (COND ((NULL (ATOM |op|)) |form|) ((BOOT-EQUAL (SPADLET |s0| (SAFE-ELT (SPADLET |sop| (PNAME |op|)) 0)) (QUOTE *)) (SPADLET |n| (|#| |sop|)) (COND ((EQL |n| 1) |form|) ((QUOTE T) (SPADLET |argKey| (SAFE-ELT |sop| 1)) (SPADLET |numArgs| (SPADDIFFERENCE (|#| |argl|) (COND ((BOOT-EQUAL |argKey| (QUOTE |1|)) 1) ((QUOTE T) 0)))) (SPADLET |zeroOrOne| (OR (BOOT-EQUAL |argKey| (QUOTE |0|)) (BOOT-EQUAL |argKey| (QUOTE |1|)))) (SPADLET |isDmp| (COND ((> 10 |numArgs|) (AND (EQL |n| 6) (BOOT-EQUAL (MAKESTRING "DMP") (SUBSTRING |sop| 3 3)) |zeroOrOne|)) ((QUOTE T) (AND (EQL |n| 7) (BOOT-EQUAL (MAKESTRING "DMP") (SUBSTRING |sop| 4 3)) |zeroOrOne|)))) (COND (|isDmp| (COND ((BOOT-EQUAL |a! rgKey| (QUOTE |0|)) (SPADLET |extraDomain| |$EmptyMode|) (SPADLET |vl| |argl|)) ((QUOTE T) (SPADLET |LETTMP#1| (REVERSE |argl|)) (SPADLET |extraDomain| (CAR |LETTMP#1|)) (SPADLET |vl| (NREVERSE (CDR |LETTMP#1|))) |argl|)) (CONS (QUOTE |DistributedMultivariatePolynomial|) (CONS (CONS (QUOTE |construct|) |vl|) (CONS (|specialModeTran| |extraDomain|) NIL)))) ((AND (EQL |n| 4) (BOOT-EQUAL (SPADLET |s3| (SAFE-ELT |sop| 3)) (QUOTE M)) |zeroOrOne|) (|specialModeTran| (PROGN (SPADLET |extraDomain| (COND ((BOOT-EQUAL |argKey| (QUOTE |0|)) (CONS |$EmptyMode| NIL)) ((QUOTE T) NIL))) (COND ((EQL (SPADLET |n| (PARSE-INTEGER (PNAME (SAFE-ELT |sop| 2)))) 1) (CONS (QUOTE |SquareMatrix|) (APPEND |argl| |extraDomain|))) ((EQL |n| 2) (CONS (QUOTE |RectangularMatrix|) (APPEND |argl| |extraDomain|))) ((QUOTE T) |form|))))) ((QUOTE T) (SPADLET |isUpOrMp| (COND ((> 10 |numArgs|) (OR (AND (EQL |n| 4) (BOOT-EQUAL (SPADLET |s3| (SAFE-ELT |sop| 3)) (QUOTE P)) |zeroOrOne|) (AND (EQL |n| 5) (BOOT-EQUAL! (SPADLET |s3| (SAFE-ELT |sop| 3)) (QUOTE R)) (BOOT-EQUAL (SAFE-ELT |s op| 4) (QUOTE F)) |zeroOrOne|))) ((QUOTE T) (OR (AND (EQL |n| 5) (BOOT-EQUAL (SPADLET |s3| (SAFE-ELT |sop| 4)) (QUOTE P)) |zeroOrOne|) (AND (EQL |n| 6) (BOOT-EQUAL (SPADLET |s3| (SAFE-ELT |sop| 4)) (QUOTE R)) (BOOT-EQUAL (SAFE-ELT |sop| 5) (QUOTE F)) |zeroOrOne|))))) (COND (|isUpOrMp| (SPADLET |polyForm| (PROGN (SPADLET |domainPart| (COND ((BOOT-EQUAL |argKey| (QUOTE |0|)) |$EmptyMode|) ((QUOTE T) (|last| |argl|)))) (SPADLET |argPart| (COND ((BOOT-EQUAL |argKey| (QUOTE |0|)) |argl|) ((QUOTE T) (DROP (SPADDIFFERENCE 1) |argl|)))) (COND ((AND (> 10 |numArgs|) (EQL (SPADLET |n| (PARSE-INTEGER (PNAME (SAFE-ELT |sop| 2)))) 1)) (CONS (QUOTE UP) (APPEND |argPart| (CONS |domainPart| NIL)))) ((QUOTE T) (CONS (QUOTE MP) (CONS (CONS (QUOTE |construct|) |argPart|) (CONS |domainPart| NIL))))))) (|specialModeTran| (COND ((BOOT-EQUAL |s3| (QUOTE R)) (CONS |$QuotientField| (CONS |polyForm| NIL))) ((QUOTE T) |polyForm|)))) ((QUOTE T) (CONS (CAR |form|) (PROG (#0=#:G2725) (SPADLET #0# NIL) (R! ETURN (DO ((#1=#:G2730 (CDR |form|) (CDR #1#)) (|x| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (|specialModeTran| |x|) #0#))))))))))))))) ((QUOTE T) (CONS (CAR |form|) (PROG (#2=#:G2740) (SPADLET #2# NIL) (RETURN (DO ((#3=#:G2745 (CDR |form|) (CDR #3#)) (|x| NIL)) ((OR (ATOM #3#) (PROGN (SETQ |x| (CAR #3#)) NIL)) (NREVERSE0 #2#)) (SEQ (EXIT (SETQ #2# (CONS (|specialModeTran| |x|) #2#))))))))))) ((QUOTE T) |form|)))))) ; ;parseHas [x,y] == ; if $InteractiveMode then diff --git a/src/interp/setvars.boot.pamphlet b/src/interp/setvars.boot.pamphlet index 864ced0..69535e8 100644 --- a/src/interp/setvars.boot.pamphlet +++ b/src/interp/setvars.boot.pamphlet @@ -2072,7 +2072,7 @@ describeSetStreamsCalculate() == sayKeyedMsg("S2IV0001",[$streamCount]) ; '"have the same effect as",:bright '"on",'"and",:bright '"off", ; '"respectively."] -(DEFUN |displaySetOptionInformation| (|arg| |setData|) (PROG (|st| |current|) (RETURN (SEQ (PROGN (SPADLET |st| (ELT |setData| 3)) (COND ((BOOT-EQUAL |st| (QUOTE TREE)) (|displaySetVariableSettings| (ELT |setData| 5) (ELT |setData| 0))) ((QUOTE T) (|centerAndHighlight| (STRCONC (MAKESTRING "The ") (|object2String| |arg|) (MAKESTRING " Option")) $LINELENGTH (|specialChar| (QUOTE |hbar|))) (|sayBrightly| (CONS (QUOTE |%l|) (APPEND (|bright| (MAKESTRING "Description:")) (CONS (ELT |setData| 1) NIL)))) (COND ((BOOT-EQUAL |st| (QUOTE FUNCTION)) (TERPRI) (COND ((|functionp| (ELT |setData| 4)) (FUNCALL (ELT |setData| 4) (QUOTE |%describe%|))) ((QUOTE T) (|sayMSG| (MAKESTRING " Function not implemented."))))) ((BOOT-EQUAL |st| (QUOTE INTEGER)) (|sayMessage| (CONS (MAKESTRING " The") (APPEND (|bright| |arg|) (CONS (MAKESTRING "option") (CONS (MAKESTRING " may be followed by an integer in the range") (APPEND (|bright| (ELT (ELT |setData| 5) 0)) (CONS (MAKESTRING "to") (CONS (QUOTE ! |%l|) (APPEND (|bright| (ELT (ELT |setData| 5) 1)) (CONS (MAKESTRING "inclusive.") (CONS (MAKESTRING " The current setting is") (|bright| (|eval| (ELT |setData| 4))))))))))))))) ((BOOT-EQUAL |st| (QUOTE STRING)) (|sayMessage| (CONS (MAKESTRING " The") (APPEND (|bright| |arg|) (CONS (MAKESTRING "option") (CONS (MAKESTRING " is followed by a string enclosed in double quote marks.") (CONS (QUOTE |%l|) (CONS (MAKESTRING " The current setting is") (|bright| (CONS (QUOTE |"|) (CONS (|eval| (ELT |setData| 4)) (CONS (QUOTE |"|) NIL)))))))))))) ((BOOT-EQUAL |st| (QUOTE LITERALS)) (PROGN (|sayMessage| (CONS (MAKESTRING " The") (APPEND (|bright| |arg|) (CONS (MAKESTRING "option") (CONS (MAKESTRING " may be followed by any one of the following:") NIL))))) (SPADLET |current| (|translateTrueFalse2YesNo| (|eval| (ELT |setData| 4)))) (DO ((#0=#:G2796 (ELT |setData| 5) (CDR #0#)) (|name| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |name| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (COND ((BOOT-EQUAL |name| |cu! rrent|) (|sayBrightly| (CONS (MAKESTRING " ->") (|bright| (|object2Str ing| |name|))))) ((QUOTE T) (|sayBrightly| (CONS (MAKESTRING " ") (CONS (|object2String| |name|) NIL)))))))) (|sayMessage| (MAKESTRING " The current setting is indicated within the list.")) (COND ((OR (BOOT-EQUAL (ELT |setData| 5) (QUOTE (|yes| |no| |on| |off|))) (BOOT-EQUAL (ELT |setData| 5) (QUOTE (|yes| |no| |on| |off| |long|)))) (|sayMessage| (APPEND (|bright| (MAKESTRING "yes")) (CONS (MAKESTRING "and") (APPEND (|bright| (MAKESTRING "no")) (CONS (MAKESTRING "have the same effect as") (APPEND (|bright| (MAKESTRING "on")) (CONS (MAKESTRING "and") (APPEND (|bright| (MAKESTRING "off")) (CONS (MAKESTRING "respectively.") NIL)))))))))) ((QUOTE T) NIL)))))))))))) +(DEFUN |displaySetOptionInformation| (|arg| |setData|) (PROG (|st| |current|) (RETURN (SEQ (PROGN (SPADLET |st| (ELT |setData| 3)) (COND ((BOOT-EQUAL |st| (QUOTE TREE)) (|displaySetVariableSettings| (ELT |setData| 5) (ELT |setData| 0))) ((QUOTE T) (|centerAndHighlight| (STRCONC (MAKESTRING "The ") (|object2String| |arg|) (MAKESTRING " Option")) $LINELENGTH (|specialChar| (QUOTE |hbar|))) (|sayBrightly| (CONS (QUOTE |%l|) (APPEND (|bright| (MAKESTRING "Description:")) (CONS (ELT |setData| 1) NIL)))) (COND ((BOOT-EQUAL |st| (QUOTE FUNCTION)) (TERPRI) (COND ((|functionp| (ELT |setData| 4)) (FUNCALL (ELT |setData| 4) (QUOTE |%describe%|))) ((QUOTE T) (|sayMSG| (MAKESTRING " Function not implemented."))))) ((BOOT-EQUAL |st| (QUOTE INTEGER)) (|sayMessage| (CONS (MAKESTRING " The") (APPEND (|bright| |arg|) (CONS (MAKESTRING "option") (CONS (MAKESTRING " may be followed by an integer in the range") (APPEND (|bright| (SAFE-ELT (ELT |setData| 5) 0)) (CONS (MAKESTRING "to") (CONS (Q! UOTE |%l|) (APPEND (|bright| (SAFE-ELT (ELT |setData| 5) 1)) (CONS (MAKESTRING "inclusive.") (CONS (MAKESTRING " The current setting is") (|bright| (|eval| (ELT |setData| 4))))))))))))))) ((BOOT-EQUAL |st| (QUOTE STRING)) (|sayMessage| (CONS (MAKESTRING " The") (APPEND (|bright| |arg|) (CONS (MAKESTRING "option") (CONS (MAKESTRING " is followed by a string enclosed in double quote marks.") (CONS (QUOTE |%l|) (CONS (MAKESTRING " The current setting is") (|bright| (CONS (QUOTE |"|) (CONS (|eval| (ELT |setData| 4)) (CONS (QUOTE |"|) NIL)))))))))))) ((BOOT-EQUAL |st| (QUOTE LITERALS)) (PROGN (|sayMessage| (CONS (MAKESTRING " The") (APPEND (|bright| |arg|) (CONS (MAKESTRING "option") (CONS (MAKESTRING " may be followed by any one of the following:") NIL))))) (SPADLET |current| (|translateTrueFalse2YesNo| (|eval| (ELT |setData| 4)))) (DO ((#0=#:G2796 (ELT |setData| 5) (CDR #0#)) (|name| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |name| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (COND ((BOOT-EQUAL ! |name| |current|) (|sayBrightly| (CONS (MAKESTRING " ->") (|bright| (| object2String| |name|))))) ((QUOTE T) (|sayBrightly| (CONS (MAKESTRING " ") (CONS (|object2String| |name|) NIL)))))))) (|sayMessage| (MAKESTRING " The current setting is indicated within the list.")) (COND ((OR (BOOT-EQUAL (ELT |setData| 5) (QUOTE (|yes| |no| |on| |off|))) (BOOT-EQUAL (ELT |setData| 5) (QUOTE (|yes| |no| |on| |off| |long|)))) (|sayMessage| (APPEND (|bright| (MAKESTRING "yes")) (CONS (MAKESTRING "and") (APPEND (|bright| (MAKESTRING "no")) (CONS (MAKESTRING "have the same effect as") (APPEND (|bright| (MAKESTRING "on")) (CONS (MAKESTRING "and") (APPEND (|bright| (MAKESTRING "off")) (CONS (MAKESTRING "respectively.") NIL)))))))))) ((QUOTE T) NIL)))))))))))) ;displaySetVariableSettings(setTree,label) == ; if label = "" then label := '")set" ; else label := STRCONC('" ",object2String label,'" ") @@ -2259,7 +2259,7 @@ describeSetStreamsCalculate() == sayKeyedMsg("S2IV0001",[$streamCount]) ; sayKeyedMsg("S2IZ0049R",[x,$interpreterFrameName]) ; clearClams() -(DEFUN |setExposeAddGroup| (|arg|) (PROG (|x|) (RETURN (SEQ (COND ((NULL |arg|) (|centerAndHighlight| (QUOTE |The group Option|) $LINELENGTH (|specialChar| (QUOTE |hbar|))) (|displayExposedGroups|) (|sayMSG| (MAKESTRING " ")) (|sayKeyedMsg| (QUOTE S2IZ0049G) (CONS (|namestring| (|pathname| (CONS "interp" (CONS "exposed" NIL)))) NIL)) (|sayMSG| (MAKESTRING " ")) (|sayAsManyPerLineAsPossible| (PROG (#0=#:G2946) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G2951 |$globalExposureGroupAlist| (CDR #1#)) (|x| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (|object2String| (CAR |x|)) #0#))))))))) ((QUOTE T) (DO ((#2=#:G2962 |arg| (CDR #2#)) (|x| NIL)) ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) NIL) (SEQ (EXIT (PROGN (COND ((PAIRP |x|) (SPADLET |x| (QCAR |x|)))) (COND ((BOOT-EQUAL |x| (QUOTE |all|)) (SETELT |$localExposureData| 0 (PROG (#3=#:G2972) (SPADLET #3# NIL) (RETURN (DO ((#4=#:G2977 |$globalExposureGroupAlist| (CDR #4#)) (|! x| NIL)) ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) (NREVERSE0 #3#)) (SEQ (EXIT (SETQ #3# (CONS (CAR |x|) #3#)))))))) (SETELT |$localExposureData| 1 NIL) (SETELT |$localExposureData| 2 NIL) (|displayExposedGroups|) (|sayMSG| (MAKESTRING " ")) (|displayExposedConstructors|) (|sayMSG| (MAKESTRING " ")) (|displayHiddenConstructors|) (|clearClams|)) ((NULL (GETALIST |$globalExposureGroupAlist| |x|)) (|sayKeyedMsg| (QUOTE S2IZ0049H) (CONS |x| NIL))) ((|member| |x| (ELT |$localExposureData| 0)) (|sayKeyedMsg| (QUOTE S2IZ0049I) (CONS |x| (CONS |$interpreterFrameName| NIL)))) ((QUOTE T) (SETELT |$localExposureData| 0 (MSORT (CONS |x| (ELT |$localExposureData| 0)))) (|sayKeyedMsg| (QUOTE S2IZ0049R) (CONS |x| (CONS |$interpreterFrameName| NIL))) (|clearClams|))))))))))))) +(DEFUN |setExposeAddGroup| (|arg|) (PROG (|x|) (RETURN (SEQ (COND ((NULL |arg|) (|centerAndHighlight| (QUOTE |The group Option|) $LINELENGTH (|specialChar| (QUOTE |hbar|))) (|displayExposedGroups|) (|sayMSG| (MAKESTRING " ")) (|sayKeyedMsg| (QUOTE S2IZ0049G) (CONS (|namestring| (|pathname| (CONS "interp" (CONS "exposed" NIL)))) NIL)) (|sayMSG| (MAKESTRING " ")) (|sayAsManyPerLineAsPossible| (PROG (#0=#:G2946) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G2951 |$globalExposureGroupAlist| (CDR #1#)) (|x| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (|object2String| (CAR |x|)) #0#))))))))) ((QUOTE T) (DO ((#2=#:G2962 |arg| (CDR #2#)) (|x| NIL)) ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) NIL) (SEQ (EXIT (PROGN (COND ((PAIRP |x|) (SPADLET |x| (QCAR |x|)))) (COND ((BOOT-EQUAL |x| (QUOTE |all|)) (SETELT |$localExposureData| 0 (PROG (#3=#:G2972) (SPADLET #3# NIL) (RETURN (DO ((#4=#:G2977 |$globalExposureGroupAlist| (CDR #4#)) (|! x| NIL)) ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) (NREVERSE0 #3#)) (SEQ (EXIT (SETQ #3# (CONS (CAR |x|) #3#)))))))) (SETELT |$localExposureData| 1 NIL) (SETELT |$localExposureData| 2 NIL) (|displayExposedGroups|) (|sayMSG| (MAKESTRING " ")) (|displayExposedConstructors|) (|sayMSG| (MAKESTRING " ")) (|displayHiddenConstructors|) (|clearClams|)) ((NULL (GETALIST |$globalExposureGroupAlist| |x|)) (|sayKeyedMsg| (QUOTE S2IZ0049H) (CONS |x| NIL))) ((|member| |x| (SAFE-ELT |$localExposureData| 0)) (|sayKeyedMsg| (QUOTE S2IZ0049I) (CONS |x| (CONS |$interpreterFrameName| NIL)))) ((QUOTE T) (SETELT |$localExposureData| 0 (MSORT (CONS |x| (SAFE-ELT |$localExposureData| 0)))) (|sayKeyedMsg| (QUOTE S2IZ0049R) (CONS |x| (CONS |$interpreterFrameName| NIL))) (|clearClams|))))))))))))) ;setExposeAddConstr arg == ; (null arg) => ; centerAndHighlight ("The constructor Option",$LINELENGTH, @@ -2281,7 +2281,7 @@ describeSetStreamsCalculate() == sayKeyedMsg("S2IV0001",[$streamCount]) ; clearClams() ; sayKeyedMsg("S2IZ0049P",[x,$interpreterFrameName]) -(DEFUN |setExposeAddConstr| (|arg|) (PROG (|x|) (RETURN (SEQ (COND ((NULL |arg|) (|centerAndHighlight| (QUOTE |The constructor Option|) $LINELENGTH (|specialChar| (QUOTE |hbar|))) (|displayExposedConstructors|)) ((QUOTE T) (DO ((#0=#:G2998 |arg| (CDR #0#)) (|x| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (PROGN (SPADLET |x| (|unabbrev| |x|)) (COND ((PAIRP |x|) (SPADLET |x| (QCAR |x|)))) (COND ((NULL (GETDATABASE |x| (QUOTE CONSTRUCTORKIND))) (|sayKeyedMsg| (QUOTE S2IZ0049J) (CONS |x| NIL))) ((|member| |x| (ELT |$localExposureData| 1)) (|sayKeyedMsg| (QUOTE S2IZ0049K) (CONS |x| (CONS |$interpreterFrameName| NIL)))) ((QUOTE T) (COND ((|member| |x| (ELT |$localExposureData| 2)) (SETELT |$localExposureData| 2 (|delete| |x| (ELT |$localExposureData| 2))))) (SETELT |$localExposureData| 1 (MSORT (CONS |x| (ELT |$localExposureData| 1)))) (|clearClams|) (|sayKeyedMsg| (QUOTE S2IZ0049P) (CONS |x| (CONS |$interpreterFrameName| NIL))))))))))))))) +(DEFUN |setExposeAddConstr| (|arg|) (PROG (|x|) (RETURN (SEQ (COND ((NULL |arg|) (|centerAndHighlight| (QUOTE |The constructor Option|) $LINELENGTH (|specialChar| (QUOTE |hbar|))) (|displayExposedConstructors|)) ((QUOTE T) (DO ((#0=#:G2998 |arg| (CDR #0#)) (|x| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (PROGN (SPADLET |x| (|unabbrev| |x|)) (COND ((PAIRP |x|) (SPADLET |x| (QCAR |x|)))) (COND ((NULL (GETDATABASE |x| (QUOTE CONSTRUCTORKIND))) (|sayKeyedMsg| (QUOTE S2IZ0049J) (CONS |x| NIL))) ((|member| |x| (SAFE-ELT |$localExposureData| 1)) (|sayKeyedMsg| (QUOTE S2IZ0049K) (CONS |x| (CONS |$interpreterFrameName| NIL)))) ((QUOTE T) (COND ((|member| |x| (SAFE-ELT |$localExposureData| 2)) (SETELT |$localExposureData| 2 (|delete| |x| (SAFE-ELT |$localExposureData| 2))))) (SETELT |$localExposureData| 1 (MSORT (CONS |x| (SAFE-ELT |$localExposureData| 1)))) (|clearClams|) (|sayKeyedMsg| (QUOTE S2IZ0049P) (CONS |x| (CONS |$interpreterFrameName| NIL)))))))! )))))))) ;setExposeDrop arg == ; (null arg) => ; centerAndHighlight ("The drop Option",$LINELENGTH,specialChar 'hbar) @@ -2323,7 +2323,7 @@ describeSetStreamsCalculate() == sayKeyedMsg("S2IV0001",[$streamCount]) ; sayKeyedMsg("S2IZ0049I",[x,$interpreterFrameName]) ; sayKeyedMsg("S2IZ0049H",[x]) -(DEFUN |setExposeDropGroup| (|arg|) (PROG (|x|) (RETURN (SEQ (COND ((NULL |arg|) (|centerAndHighlight| (QUOTE |The group Option|) $LINELENGTH (|specialChar| (QUOTE |hbar|))) (|sayKeyedMsg| (QUOTE S2IZ0049L) NIL) (|sayMSG| (MAKESTRING " ")) (|displayExposedGroups|)) ((QUOTE T) (DO ((#0=#:G3031 |arg| (CDR #0#)) (|x| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (PROGN (COND ((PAIRP |x|) (SPADLET |x| (QCAR |x|)))) (COND ((BOOT-EQUAL |x| (QUOTE |all|)) (SETELT |$localExposureData| 0 NIL) (SETELT |$localExposureData| 1 NIL) (SETELT |$localExposureData| 2 NIL) (|displayExposedGroups|) (|sayMSG| (MAKESTRING " ")) (|displayExposedConstructors|) (|sayMSG| (MAKESTRING " ")) (|displayHiddenConstructors|) (|clearClams|)) ((|member| |x| (ELT |$localExposureData| 0)) (SETELT |$localExposureData| 0 (|delete| |x| (ELT |$localExposureData| 0))) (|clearClams|) (|sayKeyedMsg| (QUOTE S2IZ0049S) (CONS |x| (CONS |$interpreterFrameName| NIL)))) ((GETALIST |$globalExposur! eGroupAlist| |x|) (|sayKeyedMsg| (QUOTE S2IZ0049I) (CONS |x| (CONS |$interpreterFrameName| NIL)))) ((QUOTE T) (|sayKeyedMsg| (QUOTE S2IZ0049H) (CONS |x| NIL)))))))))))))) +(DEFUN |setExposeDropGroup| (|arg|) (PROG (|x|) (RETURN (SEQ (COND ((NULL |arg|) (|centerAndHighlight| (QUOTE |The group Option|) $LINELENGTH (|specialChar| (QUOTE |hbar|))) (|sayKeyedMsg| (QUOTE S2IZ0049L) NIL) (|sayMSG| (MAKESTRING " ")) (|displayExposedGroups|)) ((QUOTE T) (DO ((#0=#:G3031 |arg| (CDR #0#)) (|x| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (PROGN (COND ((PAIRP |x|) (SPADLET |x| (QCAR |x|)))) (COND ((BOOT-EQUAL |x| (QUOTE |all|)) (SETELT |$localExposureData| 0 NIL) (SETELT |$localExposureData| 1 NIL) (SETELT |$localExposureData| 2 NIL) (|displayExposedGroups|) (|sayMSG| (MAKESTRING " ")) (|displayExposedConstructors|) (|sayMSG| (MAKESTRING " ")) (|displayHiddenConstructors|) (|clearClams|)) ((|member| |x| (SAFE-ELT |$localExposureData| 0)) (SETELT |$localExposureData| 0 (|delete| |x| (SAFE-ELT |$localExposureData| 0))) (|clearClams|) (|sayKeyedMsg| (QUOTE S2IZ0049S) (CONS |x| (CONS |$interpreterFrameName| NIL)))) ((GETALIST |$glo! balExposureGroupAlist| |x|) (|sayKeyedMsg| (QUOTE S2IZ0049I) (CONS |x| (CONS |$interpreterFrameName| NIL)))) ((QUOTE T) (|sayKeyedMsg| (QUOTE S2IZ0049H) (CONS |x| NIL)))))))))))))) ;setExposeDropConstr arg == ; (null arg) => ; centerAndHighlight ("The constructor Option",$LINELENGTH, @@ -2347,7 +2347,7 @@ describeSetStreamsCalculate() == sayKeyedMsg("S2IV0001",[$streamCount]) ; clearClams() ; sayKeyedMsg("S2IZ0049Q",[x,$interpreterFrameName]) -(DEFUN |setExposeDropConstr| (|arg|) (PROG (|x|) (RETURN (SEQ (COND ((NULL |arg|) (|centerAndHighlight| (QUOTE |The constructor Option|) $LINELENGTH (|specialChar| (QUOTE |hbar|))) (|sayKeyedMsg| (QUOTE S2IZ0049N) NIL) (|sayMSG| (MAKESTRING " ")) (|displayExposedConstructors|) (|sayMSG| (MAKESTRING " ")) (|displayHiddenConstructors|)) ((QUOTE T) (DO ((#0=#:G3050 |arg| (CDR #0#)) (|x| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (PROGN (SPADLET |x| (|unabbrev| |x|)) (COND ((PAIRP |x|) (SPADLET |x| (QCAR |x|)))) (COND ((NULL (GETDATABASE |x| (QUOTE CONSTRUCTORKIND))) (|sayKeyedMsg| (QUOTE S2IZ0049J) (CONS |x| NIL))) ((|member| |x| (ELT |$localExposureData| 2)) (|sayKeyedMsg| (QUOTE S2IZ0049O) (CONS |x| (CONS |$interpreterFrameName| NIL)))) ((QUOTE T) (COND ((|member| |x| (ELT |$localExposureData| 1)) (SETELT |$localExposureData| 1 (|delete| |x| (ELT |$localExposureData| 1))))) (SETELT |$localExposureData| 2 (MSORT (CONS |x| (ELT |$localExposureData|! 2)))) (|clearClams|) (|sayKeyedMsg| (QUOTE S2IZ0049Q) (CONS |x| (CONS |$interpreterFrameName| NIL))))))))))))))) +(DEFUN |setExposeDropConstr| (|arg|) (PROG (|x|) (RETURN (SEQ (COND ((NULL |arg|) (|centerAndHighlight| (QUOTE |The constructor Option|) $LINELENGTH (|specialChar| (QUOTE |hbar|))) (|sayKeyedMsg| (QUOTE S2IZ0049N) NIL) (|sayMSG| (MAKESTRING " ")) (|displayExposedConstructors|) (|sayMSG| (MAKESTRING " ")) (|displayHiddenConstructors|)) ((QUOTE T) (DO ((#0=#:G3050 |arg| (CDR #0#)) (|x| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (PROGN (SPADLET |x| (|unabbrev| |x|)) (COND ((PAIRP |x|) (SPADLET |x| (QCAR |x|)))) (COND ((NULL (GETDATABASE |x| (QUOTE CONSTRUCTORKIND))) (|sayKeyedMsg| (QUOTE S2IZ0049J) (CONS |x| NIL))) ((|member| |x| (SAFE-ELT |$localExposureData| 2)) (|sayKeyedMsg| (QUOTE S2IZ0049O) (CONS |x| (CONS |$interpreterFrameName| NIL)))) ((QUOTE T) (COND ((|member| |x| (SAFE-ELT |$localExposureData| 1)) (SETELT |$localExposureData| 1 (|delete| |x| (SAFE-ELT |$localExposureData| 1))))) (SETELT |$localExposureData| 2 (MSORT (CONS |x| (SAFE-ELT ! |$localExposureData| 2)))) (|clearClams|) (|sayKeyedMsg| (QUOTE S2IZ0049Q) (CONS |x| (CONS |$interpreterFrameName| NIL))))))))))))))) ;setFortTmpDir arg == ; arg = "%initialize%" => ; $fortranTmpDir := '"/tmp/" diff --git a/src/interp/spaderror.lisp.pamphlet b/src/interp/spaderror.lisp.pamphlet index 3db7dcd..d3e821d 100644 --- a/src/interp/spaderror.lisp.pamphlet +++ b/src/interp/spaderror.lisp.pamphlet @@ -87,7 +87,7 @@ ;; (if (NULL val) |$numericFailure| (cons 0 (car val))))) ;; the following form embeds around the akcl error handler -#+:akcl +#+:GCL (eval-when (load eval) (unembed 'system:universal-error-handler) @@ -102,7 +102,8 @@ (|systemError| (error-format error-string args))) ((and (eq |$BreakMode| '|trapNumerics|) (eq type :ERROR)) - (setq |$BreakMode| nil) (throw '|trapNumerics| |$numericFailure|)) + (setq |$BreakMode| nil) + (throw '|trapNumerics| |$numericFailure|)) ((and (eq |$BreakMode| '|trapNumerics|) (boundp '|$oldBreakMode|) (setq |$BreakMode| |$oldBreakMode|) diff --git a/src/interp/sys-pkg.lisp.pamphlet b/src/interp/sys-pkg.lisp.pamphlet index 6ac6d4f..28968b5 100644 --- a/src/interp/sys-pkg.lisp.pamphlet +++ b/src/interp/sys-pkg.lisp.pamphlet @@ -129,11 +129,11 @@ idioms from prior ports (like rdefiostream and fileactq) "RDEFIOSTREAM" "RDROPITEMS" "RE-ENABLE-INT" "RECLAIM" "RECOMPILE-DIRECTORY" "RECOMPILE-LIB-FILE-IF-NECESSARY" "REFVECP" "REMAINDER" "REMOVEQ" "REROOT" "RESETQ" "RKEYIDS" "RNUMP" "RPACKFILE" "RPLACSTR" "RPLNODE" "RPLPAIR" "RPLQ" - "RREAD" "RSETCLASS" "RSHUT" "RVECP" "RWRITE" "SEQ" "SETANDFILEQ" - "SETDIFFERENCE" "SETDIFFERENCEQ" "SETELT" "SETQP" "SETSIZE" "SFP" "SHUT" - "SINTP" "SIZE" "SMINTP" "SORTBY" "SORTGREATERP" "STACKLIFO" "STATEP" "STRCONC" - "STRGREATERP" "STRING2ID-N" "STRINGIMAGE" "STRINGLENGTH" "STRPOS" "STRPOSL" - "SUB1" "SUBLOAD" "SUBRP" "SUBSTQ" "SUBSTRING" "SUFFIX" "SYSTEM" "TAB" + "RREAD" "RSETCLASS" "RSHUT" "RVECP" "RWRITE" "SAFE-ELT" "SAFE-SETELT" "SEQ" + "SETANDFILEQ" "SETDIFFERENCE" "SETDIFFERENCEQ" "SETELT" "SETQP" "SETSIZE" "SFP" + "SHUT" "SINTP" "SIZE" "SMINTP" "SORTBY" "SORTGREATERP" "STACKLIFO" "STATEP" + "STRCONC" "STRGREATERP" "STRING2ID-N" "STRINGIMAGE" "STRINGLENGTH" "STRPOS" + "STRPOSL" "SUB1" "SUBLOAD" "SUBRP" "SUBSTQ" "SUBSTRING" "SUFFIX" "SYSTEM" "TAB" "TEMPUS-FUGIT" "TEREAD" "THROW-PROTECT" "TIMES" "TRIMSTRING" "TRUEFN" "U-CASE" "UEQUAL" "UNEMBED" "UNIONQ" "UPCASE" "USE-VMLISP-SYNTAX" "VEC-SETELT" "VEC2LIST" "VECP" "VM/" "VMPRINT" "VMREAD" "assoc" "directoryp" "idChar?" diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index fe3cf7a..5c6116d 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -589,9 +589,30 @@ Contributed by Juergen Weiss. (setq ,id ,item) (lam\,fileactq ',id (list 'setq ',id (list 'quote ,id))))) -#-:CCL +(defun safe-elt (seq n) + (declare (type sequence seq) + (type unsigned-byte n)) + (if (consp seq) + (do ((tail seq (cdr tail))) + ((zerop n) + (if (consp tail) (car tail) tail)) + (decf n)) + (elt seq n))) + +(defun safe-setelt (seq n val) + (declare (type sequence seq) + (type unsigned-byte n)) + (if (consp seq) + (if (zerop n) + (setf (car seq) val) + (let ((tail (nthcdr (1- n) seq))) + (if (consp (cdr tail)) + (setf (cadr tail) val) + (setf (cdr tail) val)))) + (setf (elt seq n) val))) + (defmacro setelt (vec ind val) - `(setf (elt ,vec ,ind) ,val)) + `(safe-setelt ,vec ,ind ,val)) (defmacro setqp (&whole form pattern exp) (declare (ignore form))