diff --git a/build/lisp.tcl b/build/lisp.tcl index c07eeeb7..de01d782 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -67,7 +67,7 @@ respond "_" "\032" type ":kill\r" respond "*" "complr\013" -respond "_" "liblsp;_libdoc;dbg rwk1\r" +respond "_" "liblsp;_libdoc;dbg ejs2\r" respond "_" "liblsp;_libdoc;comrd kmp1\r" respond "_" "\032" type ":kill\r" diff --git a/src/libdoc/dbg.rwk1 b/src/libdoc/dbg.ejs2 similarity index 99% rename from src/libdoc/dbg.rwk1 rename to src/libdoc/dbg.ejs2 index 4a598602..1a8082dc 100755 --- a/src/libdoc/dbg.rwk1 +++ b/src/libdoc/dbg.ejs2 @@ -478,7 +478,7 @@ The X command works only with SIGNAL to continue or restart from errors. (debug-frame-printer frame sprinter-p)) (defun debug-n-spaces (n) - (dotimes (\\ n debug-indent-max) + (dotimes (() (\\ n debug-indent-max)) (tyo #\SPACE error-io))) diff --git a/src/lspsrc/mlmac.92 b/src/lspsrc/mlmac.93 old mode 100755 new mode 100644 similarity index 92% rename from src/lspsrc/mlmac.92 rename to src/lspsrc/mlmac.93 index 6c456fff..3ed72c08 --- a/src/lspsrc/mlmac.92 +++ b/src/lspsrc/mlmac.93 @@ -6,7 +6,7 @@ ;;; ************************************************************************* ;; Herald is on next page, since it is defined in this file -;; (herald MLMAC /92) +;; (herald MLMAC /93) (eval-when (eval compile) (or (get 'SUBLOAD 'VERSION) @@ -94,6 +94,8 @@ +;;;; Random Macros + ;; Basically, most of these "FSUBR" macros only need to be "un-cached" ;; if they are redefined. (eval-when (eval compile) @@ -142,6 +144,7 @@ (princ '| instead.| msgfiles)) +;;;; Variable Definers ;; (DEFVAR sym value documentation) ;; SETQ-IF-UNBOUND so can initialize a var before loading the file which @@ -156,13 +159,34 @@ ,.(if valp `((SETQ-IF-UNBOUND ,var ,val))) ',var)) -(defmacro DEFCONST (var &optional (val () valp) () ) ;3rd = documentation + +;DEFPARAMETER is similar to DEFVAR, but ALWAYS initializes the variable, +; in spite of anything else. +(defmacro DEFPARAMETER (var val &optional () ) ;3rd = documentation `(PROGN 'COMPILE (EVAL-WHEN (EVAL LOAD COMPILE) (AND (STATUS FEATURE COMPLR) (SPECIAL ,var))) - ,.(if valp `((SETQ ,var ,val))) + (SETQ ,var ,val) ',var)) +;This name is being flushed to avoid confusion with DEFCONSTANT, which +; has a trivially different name so that code will continue to work. +(macro DEFCONST (form) + (cons 'DEFPARAMETER (cdr form))) + + +;This is supposed to be a "manifest constant", i.e. something the compiler +; could hardwire into your code (if the implementation so warrants). +;The code is in error if there is a variable binding in effect when the +; variable is being initialized. The code is in error (and this should +; be checked but isn't) if the variable has a global value which is +; not EQUAL to the value being assigned. +(macro DEFCONSTANT (form) + (cons 'DEFPARAMETER (cdr form))) + + + +;;;; More random macros ;; PSETQ looks like SETQ but does its work in parallel. (defmacro PSETQ (&rest rest) @@ -322,8 +346,8 @@ -;;;; MULTIPLE-VALUE-LIST, MULTIPLE-VALUE, MULTIPLE-VALUE-BIND, VALUES, -;;;; RETURN-LIST, MULTIPLE-VALUE-RETURN +;;; MULTIPLE-VALUE-LIST, MULTIPLE-VALUE, MULTIPLE-VALUE-BIND, VALUES, +;;; RETURN-LIST, MULTIPLE-VALUE-RETURN (defmacro MULTIPLE-VALUE-LIST (form) @@ -388,7 +412,3 @@ `(RETURN (VALUES-LIST ,l))) (defmacro MULTIPLE-VALUE-RETURN (form) `(RETURN ,form)) - - - - diff --git a/src/lspsrc/umlmac.35 b/src/lspsrc/umlmac.35 deleted file mode 100755 index d15cf6b4..00000000 --- a/src/lspsrc/umlmac.35 +++ /dev/null @@ -1,240 +0,0 @@ -;;; UMLMAC -*-Mode:Lisp;Package:SI;Lowercase:T-*- -;;; ************************************************************************* -;;; ***** MacLISP ******* Utility MacLisp MACros **************************** -;;; ************************************************************************* -;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ************* -;;; ************************************************************************* - -(herald UMLMAC /35) - -(include ((lisp) subload lsp)) - - -(eval-when (eval compile) - (setq defmacro-for-compiling 'T defmacro-displace-call MACROEXPANDED) - (mapc #'(lambda (x) (putprop x 'T 'SKIP-WARNING)) - '(SELECTQ STRUCT-LET STRUCT-SETF)) - (subload LOOP) -) - -;;;; MSETQ-..., for backwards compatibility -;;;; BIT-, WHEN, UNLESS, - - -(defmacro MSETQ-CALL (&rest w) `(MULTIPLE-VALUE ,.w)) -(defmacro MSETQ-RETURN (&rest w) `(VALUES ,.w)) - - -(DEFBOTHMACRO BIT-TEST (X Y) `(NOT (= (BOOLE 1 ,X ,Y) 0))) -(DEFBOTHMACRO BIT-SET (X Y) `(BOOLE 7 ,X ,Y)) -(DEFBOTHMACRO BIT-CLEAR (X Y) `(BOOLE 2 ,X ,Y)) - - -(DEFMACRO WHEN (P . C) `(COND (,P . ,C))) -(DEFMACRO UNLESS (P . C) `(COND ((NOT ,P) . ,C))) - -(def-or-autoloadable GENTEMP MACAID) -(def-or-autoloadable SYMBOLCONC MACAID) - - -;;;; SELECTQ - -(defvar SI:SELECTQ-TYPE-TESTERS '((FIXNUM . =) (BIGNUM . EQUAL)) ) - -(defvar SI:SELECTQ-PREDICATES '((FIXNUM . FIXNUMP) (BIGNUM . BIGP) )) - -;;; We could all (FLONUM . =$) to SI:SELECTQ-TYPE-TESTERS, and -;;; (FLONUM . FLONUMP) to SI:SELECTQ-PREDICATES - -(defvar SI:SELECTQ-OTHERWISE-KEYWORDS '(T OTHERWISE :OTHERWISE)) - -(defvar SI:SELECTQ-TYPEP-ALIST) - -(defvar SI:SELECTQ-VAR) - - -(defmacro SELECTQ (key-form &rest clauses &aux types-used tem newclauses) - (cond - ((or (null clauses) (memq (caar clauses) si:selectq-otherwise-keywords)) - `(PROGN ,key-form () ,@(cdar clauses))) - ('T (loop as clause = (car clauses) - as test = (car clause) - until (memq test si:selectq-otherwise-keywords) - as typed-alist = () - do (loop for key in (cond ((atom test) (list test)) (test)) - as type = (car (assq (typep key) - si:selectq-type-testers)) - unless (memq type types-used) - do (push type types-used) - unless (setq tem (assq type typed-alist)) - do (push (setq tem (ncons type)) typed-alist) - do (nconc tem (list key))) - (push (cons typed-alist (cdr clause)) newclauses) - while (setq clauses (cdr clauses))) - (let* ((si:selectq-var (cond ((atom key-form) key-form) - ('T (si:gen-local-var () "Selector")))) - (q (selectq-compile-1 newclauses types-used (cdar clauses)))) - (cond ((eq key-form si:selectq-var) q) - ('T `((LAMBDA (,si:selectq-var) ,q) ,key-form))))))) - -(defun SELECTQ-COMPILE-1 (clauses types-used otherwisep) - (and (equal otherwisep '(())) (setq otherwisep ())) - (let ((si:selectq-typep-alist ()) - (pre-test ()) - (final-form ()) - (type-vars ()) - (type-vals ()) - (type-inits ())) - (cond ((and (null (cdr types-used)) - (or (null (car types-used)) (not otherwisep))) - (or (null (car types-used)) - (setq pre-test `(,(cdr (assq (car types-used) - si:selectq-predicates)) - ,si:selectq-var)))) - ('T (loop with var = () - for type in types-used - when type - do (si:gen-local-var var type) - (push (cons type var) si:selectq-typep-alist) - (push () type-vals) - (push var type-vars) - (push `(SETQ ,var - (,(cdr (assq type si:selectq-predicates)) - ,si:selectq-var)) - type-inits)))) - (loop with nclauses = () - for xclause in clauses - do (push (cons (cond ((not si:selectq-typep-alist) - (selectq-one-hairy-predicate (caar xclause))) - ('T (selectq-hairy-predicate (car xclause)))) - (or (cdr xclause) '(()))) - nclauses) - finally (and otherwisep (nconc nclauses (list `('T ,@otherwisep)))) - (setq final-form (cons 'cond nclauses))) - (and pre-test (setq final-form `(and ,pre-test ,final-form))) - (cond ((not (null (cdr type-inits))) (push 'OR type-inits)) - ('T (setq type-inits (car type-inits)))) - `((LAMBDA ,type-vars ,type-inits ,final-form) ,@type-vals))) - - -(defun SELECTQ-HAIRY-PREDICATE (type-alist &aux untyped) - (loop with clauses = () - for entry in type-alist - do (cond ((not (null (car entry))) - (push `(,(cdr (assq (car entry) si:selectq-typep-alist)) - ,(selectq-one-hairy-predicate entry)) - clauses)) - ('T (setq untyped entry))) - finally (and untyped - (push (ncons (selectq-one-hairy-predicate untyped)) - clauses)) - (return (cond ((cdr clauses) `(COND ,.(nreverse clauses))) - ((cdar clauses) `(AND ,.(car clauses))) - ('T (caar clauses)))))) - -(defun SELECTQ-ONE-HAIRY-PREDICATE (entry) - ; Consider optimizing MEMQ. - (loop with fn = (or (cdr (assq (car entry) si:selectq-type-testers)) 'eq) - for k in (cdr entry) - collect `(,fn ,si:selectq-var ',k) into preds - finally (return (cond ((cdr preds) `(OR ,.preds)) - ('T (car preds)))))) - - -;;;; DOLIST, DOTIMES - -(defmacro DOLIST ((var form index) &rest body &aux dummy decls) - (setq decls (cond ((and body - (not (atom (car body))) - (eq (caar body) 'DECLARE)) - (prog2 () (cdar body) (pop body))))) - (cond (index (push `(FIXNUM ,INDEX) decls) - (setq index (ncons `(,INDEX 0 (1+ ,INDEX)) )))) - (and decls (setq decls (ncons `(DECLARE ,.decls)))) - (si:gen-local-var dummy) - `(DO ((,DUMMY ,FORM (CDR ,DUMMY)) (,VAR) ,.index ) - ((NULL ,DUMMY)) - ,@decls - (SETQ ,VAR (CAR ,DUMMY)) ,.BODY)) - -(eval-when (eval compile) - (setq defmacro-for-compiling 'T defmacro-displace-call 'T) -) - - -;Repeat a number of times. evaluates to the number of times, -;and is executed with bound to 0, 1, ... -;Don't generate dummy variable if is an integer. We could also do this -;if were a symbol, but the symbol may get clobbered inside the body, -;so the behavior of the macro would change. - -(defmacro DOTIMES ((var count) &rest body &aux dummy decls) - (or var (si:gen-local-var var)) - (and *RSET - (do () - ((symbolp var)) - (setq var (error '|Must be a variable -- DOTIMES| - var - 'WRNG-TYPE-ARG)))) - (setq count (macroexpand count)) - (cond ((|constant-p/|| count) - (do () - ((fixnump count)) - (setq count (error '|Must be FIXNUM -- DOTIMES| - count - 'WRNG-TYPE-ARG)))) - ('T (si:gen-local-var dummy) - (psetq dummy `((,dummy ,count)) - count dummy))) - (setq decls `(DECLARE - (FIXNUM ,var ,.(and dummy (list count))) - ,.(cond ((and body - (not (atom (car body))) - (eq (caar body) 'DECLARE)) - (prog2 () (cdar body) (pop body)))))) - `(DO ((,var 0 (1+ ,var)) ,.dummy) - ((NOT (< ,var ,count))) - ,decls - ,.body)) - - -;;;; STRUCT-LET and STRUCT-SETF - - -(eval-when (eval compile) - (setq defmacro-displace-call '|defvst-construction/||) -) - - -;;; E.g. (STRUCT-LET ( ) -;; ((var slot-name) ; or, -;; (var-named-same-as-slot) ; or, -;; var-named-same-as-slot -;; ...) -;; . body) - -(defmacro STRUCT-LET ((struct-name str-obj) bvl &rest body) - (let (var slot-name accessor) - (setq bvl (mapcar - #'(lambda (e) - (if (atom e) (setq e `(,e ,e))) - (desetq (var slot-name) e) - (or slot-name (setq slot-name var)) - (setq accessor (symbolconc struct-name '/- slot-name)) - `(,var (,accessor ,str-obj))) - bvl)) - `(LET ,bvl ,.body))) - - -;;; E.g. (STRUCT-SETF (structure-name object) (slot-name value) ...) -(defmacro STRUCT-SETF ((str-name str-obj) &rest l &aux slot-name accessor val) - `(PROGN ,. (mapcar - #'(lambda (x) - (if (atom x) (setq x `(,x ,x))) - (desetq (slot-name val) x) - (setq accessor (symbolconc str-name '/- slot-name)) - `(SETF (,accessor ,str-obj) ,val)) - l))) - - - diff --git a/src/lspsrc/umlmac.42 b/src/lspsrc/umlmac.42 new file mode 100644 index 00000000..436c60f7 --- /dev/null +++ b/src/lspsrc/umlmac.42 @@ -0,0 +1,352 @@ +;;; UMLMAC -*-Mode:Lisp;Package:SI;Lowercase:T-*- +;;; ************************************************************************* +;;; ***** MacLISP ******* Utility MacLisp MACros **************************** +;;; ************************************************************************* +;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ************* +;;; ************************************************************************* + +(herald UMLMAC /40) + + +(include ((lisp) subload lsp)) + + +(eval-when (eval compile) + (mapc #'(lambda (x) (putprop x 'T 'SKIP-WARNING)) + '(SELECTQ STRUCT-LET STRUCT-SETF)) + (subload LOOP) + ) + + +(declare (*expr si:obsolete-form-msg)) + +(def-or-autoloadable GENTEMP MACAID) +(def-or-autoloadable SYMBOLCONC MACAID) +(def-or-autoloadable si:obsolete-form-msg MLMAC) + +;;;; Random B.S. + +;;; MSETQ-..., for backwards compatibility +;;; BIT-, WHEN, UNLESS, + + +(defmacro MSETQ-CALL (&rest w) + (si:obsolete-form-msg 'msetq-call 'multiple-value) + `(MULTIPLE-VALUE ,.w)) +(defmacro MSETQ-RETURN (&rest w) + (si:obsolete-form-msg 'msetq-return 'values) + `(VALUES ,.w)) + + +;This is good. +(DEFBOTHMACRO BIT-TEST (X Y) + `(NOT (= (BOOLE 1 ,X ,Y) 0))) +;This should be dyked out. (-> LOGIOR) +(DEFBOTHMACRO BIT-SET (X Y) + `(BOOLE 7 ,X ,Y)) +;This too. (-> LOGANDC1) +(DEFBOTHMACRO BIT-CLEAR (X Y) + `(BOOLE 2 ,X ,Y)) + + +(DEFMACRO WHEN (P . C) + `(COND (,P . ,C))) +(DEFMACRO UNLESS (P . C) + `(COND ((NOT ,P) . ,C))) + +;;;; SELECTQ + +(defvar SI:SELECTQ-TYPE-TESTERS '((FIXNUM . =) (BIGNUM . EQUAL)) ) + +(defvar SI:SELECTQ-PREDICATES '((FIXNUM . FIXNUMP) (BIGNUM . BIGP) )) + +;;; We could all (FLONUM . =$) to SI:SELECTQ-TYPE-TESTERS, and +;;; (FLONUM . FLONUMP) to SI:SELECTQ-PREDICATES + +(defvar SI:SELECTQ-OTHERWISE-KEYWORDS '(T OTHERWISE :OTHERWISE)) + +(defvar SI:SELECTQ-TYPEP-ALIST) + +(defvar SI:SELECTQ-VAR) + + +(defmacro SELECTQ (key-form &rest clauses &aux types-used tem newclauses) + (cond + ((or (null clauses) (memq (caar clauses) si:selectq-otherwise-keywords)) + `(PROGN ,key-form () ,@(cdar clauses))) + ('T (loop as clause = (car clauses) + as test = (car clause) + until (memq test si:selectq-otherwise-keywords) + as typed-alist = () + do (loop for key in (cond ((atom test) (list test)) (test)) + as type = (car (assq (typep key) + si:selectq-type-testers)) + unless (memq type types-used) + do (push type types-used) + unless (setq tem (assq type typed-alist)) + do (push (setq tem (ncons type)) typed-alist) + do (nconc tem (list key))) + (push (cons typed-alist (cdr clause)) newclauses) + while (setq clauses (cdr clauses))) + (let* ((si:selectq-var (cond ((atom key-form) key-form) + ('T (si:gen-local-var () "Selector")))) + (q (selectq-compile-1 newclauses types-used (cdar clauses)))) + (cond ((eq key-form si:selectq-var) q) + ('T `((LAMBDA (,si:selectq-var) ,q) ,key-form))))))) + +(defun SELECTQ-COMPILE-1 (clauses types-used otherwisep) + (and (equal otherwisep '(())) (setq otherwisep ())) + (let ((si:selectq-typep-alist ()) + (pre-test ()) + (final-form ()) + (type-vars ()) + (type-vals ()) + (type-inits ())) + (cond ((and (null (cdr types-used)) + (or (null (car types-used)) (not otherwisep))) + (or (null (car types-used)) + (setq pre-test `(,(cdr (assq (car types-used) + si:selectq-predicates)) + ,si:selectq-var)))) + ('T (loop with var = () + for type in types-used + when type + do (si:gen-local-var var type) + (push (cons type var) si:selectq-typep-alist) + (push () type-vals) + (push var type-vars) + (push `(SETQ ,var + (,(cdr (assq type si:selectq-predicates)) + ,si:selectq-var)) + type-inits)))) + (loop with nclauses = () + for xclause in clauses + do (push (cons (cond ((not si:selectq-typep-alist) + (selectq-one-hairy-predicate (caar xclause))) + ('T (selectq-hairy-predicate (car xclause)))) + (or (cdr xclause) '(()))) + nclauses) + finally (and otherwisep (nconc nclauses (list `('T ,@otherwisep)))) + (setq final-form (cons 'cond nclauses))) + (and pre-test (setq final-form `(and ,pre-test ,final-form))) + (cond ((not (null (cdr type-inits))) (push 'OR type-inits)) + ('T (setq type-inits (car type-inits)))) + `((LAMBDA ,type-vars ,type-inits ,final-form) ,@type-vals))) + + +(defun SELECTQ-HAIRY-PREDICATE (type-alist &aux untyped) + (loop with clauses = () + for entry in type-alist + do (cond ((not (null (car entry))) + (push `(,(cdr (assq (car entry) si:selectq-typep-alist)) + ,(selectq-one-hairy-predicate entry)) + clauses)) + ('T (setq untyped entry))) + finally (and untyped + (push (ncons (selectq-one-hairy-predicate untyped)) + clauses)) + (return (cond ((cdr clauses) `(COND ,.(nreverse clauses))) + ((cdar clauses) `(AND ,.(car clauses))) + ('T (caar clauses)))))) + +(defun SELECTQ-ONE-HAIRY-PREDICATE (entry) + ; Consider optimizing MEMQ. + (loop with fn = (or (cdr (assq (car entry) si:selectq-type-testers)) 'eq) + for k in (cdr entry) + collect `(,fn ,si:selectq-var ',k) into preds + finally (return (cond ((cdr preds) `(OR ,.preds)) + ('T (car preds)))))) + + +;;;; DOLIST, DOTIMES + +;(dolist (var list) body...) +;Steps through the elements of . is a progbody; +; tags and GO and RETURN are allowed. +;In the future, there will be a third optional form in the iteration spec, +; which will be evaluated to get the return value of the form. This is +; not supported currently to catch illegal or confused uses of that syntax +; for some other purpose. +(defmacro dolist (spec . body) + (cond ((or (atom spec) + (atom (cdr spec)) + (cddr spec) + (not (symbolp (car spec)))) + (error "Invalid binding spec for DOLIST" spec))) + (let ((l (gentemp)) (item (car spec)) (list (cadr spec)) (decls nil)) + (setq decls (cond ((and body + (not (atom (car body))) + (eq (caar body) 'DECLARE)) + (prog1 (cdar body) (pop body))))) + (cond ((not (null decls)) (setq decls (ncons `(DECLARE ,.decls))))) + `(do ((,l ,list (cdr ,l)) (,item)) ((null ,l)) + ,.decls + (setq ,item (car ,l)) + ,@body))) + + +;(dotimes (var count) body...) +;Repeat a number of times. evaluates to the number of times, +; and is executed with bound to 0, 1, ... +;Don't generate dummy variable if is an integer. We could also do +; this if were a symbol, but the symbol may get clobbered inside the +; body, so the behavior of the macro would change. +;In the future, there will be a third optional form in the iteration spec, +; which will be evaluated to get the return value of the form. This is +; not supported currently to catch illegal or confused uses of that syntax +; for some other purpose. +(defmacro DOTIMES (iter-spec &rest body) + (let ((var nil) + (count nil) + (decls (cond ((and body + (not (atom (car body))) + (eq (caar body) 'DECLARE)) + (prog1 (cdar body) (pop body)))))) + (if (and (not (atom iter-spec)) + (not (atom (cdr iter-spec))) + (null (cddr iter-spec))) + (setq var (car iter-spec) count (cadr iter-spec)) + (error "Malformed iteration spec -- DOTIMES" iter-spec)) + (or var (setq var (gentemp))) + (do () ((symbolp var)) + (setq var (error '|Must be a variable -- DOTIMES| + var 'WRNG-TYPE-ARG))) + (if (and (not (atom (setq count (macroexpand count)))) + (eq (car count) 'quote) + (fixnump (cadr count))) + (setq count (cadr count))) + (let ((scrodp nil) (use-form count)) + (if (not (fixnump count)) + (setq scrodp t use-form (gentemp))) + (let ((form `(DO ((,var 0 (1+ ,var))) + ((NOT (< ,var ,use-form))) + (declare (fixnum ,var) ,@decls) + ,.body))) + (if scrodp + `((lambda (,use-form) + (declare (fixnum ,use-form)) + ,form) + ,count) + form))))) + + +;;;; with-open-file + +;;; LispM Manual, 4th ed, p 365 +;;; +;;; (WITH-OPEN-FILE ((var filename . options) . body) ...) +;;; +;;; Evaluates the BODY forms with the variable VAR bound to a stream which +;;; reads or writes the file named by the value of FILENAME. OPTIONS may be +;;; any number of keywords to be passed open. These options control whether +;;; a stream is for input from an existing file or output to a new file, +;;; whether the file is text or binary, etc. The options are the same as +;;; those which may be given to the OPEN function. +;;; +;;; When control leaves the body, either normally or abnormally (eg, via +;;; *THROW), the file is closed. +;;; +;;; NOTE: The LispM feature wherein the file is deleted if a throw is done +;;; is not currently supported and is not likely to be in the near +;;; future. In any case, code using this compatibility macro should +;;; not make assumptions about its behavior one way or the other on +;;; this point. Please contact BUG-MACLISP if you have any troubles in +;;; this regard. +;;; +;;; Because it always closes the file even when an error exit is taken, +;;; WITH-OPEN-FILE is preferred over OPEN. Opening a large number of files +;;; and forgetting to close them is anti-social on some file systems (eg, ITS) +;;; because there are only a finite number of disk channels available which +;;; must be shared among the community of logged-in users. +;;; +;;; Because the filename will be passed to OPEN, either a namestring or a +;;; namelist will work. However, code intended to run on the LispM should +;;; use only namestring format for files since that's all the LispM will +;;; accept. +;;; +;;; NOTE: If an error occurs during the OPEN, the friendly behavior of the +;;; LispM (wherein a new filename is prompted for) will not occur. +;;; Instead, the IO-LOSSAGE handler will run as for any OPEN, probably +;;; resulting in an error breakpoint. Users are encouraged to verify +;;; the existence of a file before invoking WITH-OPEN-FILE on it. + +(defmacro with-open-file ((var filename . options) &body body) + (cond ((not (symbolp var)) + (error + "bad var. Syntax is: (with-open-file (var file . options) . body)" + var))) + `(with-open-stream (,var (open ,filename ,@options)) + ,@body))) + + +;;;; with-open-stream + +;;; Not documented in LispM Manual, 4th ed +;;; +;;; (WITH-OPEN-STREAM (var exp) . body) +;;; +;;; Like WITH-OPEN-FILE but exp may be an arbitrary form to accomplish the +;;; OPEN. The result of evaluating EXP should be a file or sfa. BODY will be +;;; evaluated in a context where VAR is bound to that file or sfa. +;;; Upon return, as with WITH-OPEN-FILE, the file or sfa will be closed. +;;; +;;; Note: This is a reasonably low-level primitive. If you don't know the +;;; which you want of WITH-OPEN-FILE or WITH-OPEN-STREAM, you almost +;;; surely want WITH-OPEN-FILE. + +(defmacro with-open-stream (bindings &body body) + (cond ((or (atom bindings) + (not (symbolp (car bindings))) ;var to bind + (atom (cdr bindings)) + (not (null (cddr bindings)))) + (error "bad bindings. Syntax is: (WITH-OPEN-STREAM (var form) . body)" + bindings))) + (let (((var val) bindings) + (temp (gensym))) + `((lambda (,temp) + (unwind-protect (progn (without-interrupts (setq ,temp ,val)) + ((lambda (,var) ,@body) ,temp)) + (if (or (filep ,temp) + (sfap ,temp)) + (close ,temp)))) + nil))) + + + +;;;; STRUCT-LET and STRUCT-SETF + + +(eval-when (eval compile) + (setq defmacro-displace-call '|defvst-construction/||) +) + + +;;; E.g. (STRUCT-LET ( ) +;; ((var slot-name) ; or, +;; (var-named-same-as-slot) ; or, +;; var-named-same-as-slot +;; ...) +;; . body) + +(defmacro STRUCT-LET ((struct-name str-obj) bvl &rest body) + (let (var slot-name accessor) + (setq bvl (mapcar + #'(lambda (e) + (if (atom e) (setq e `(,e ,e))) + (desetq (var slot-name) e) + (or slot-name (setq slot-name var)) + (setq accessor (symbolconc struct-name '/- slot-name)) + `(,var (,accessor ,str-obj))) + bvl)) + `(LET ,bvl ,.body))) + + +;;; E.g. (STRUCT-SETF (structure-name object) (slot-name value) ...) +(defmacro STRUCT-SETF ((str-name str-obj) &rest l &aux slot-name accessor val) + `(PROGN ,. (mapcar + #'(lambda (x) + (if (atom x) (setq x `(,x ,x))) + (desetq (slot-name val) x) + (setq accessor (symbolconc str-name '/- slot-name)) + `(SETF (,accessor ,str-obj) ,val)) + l))) diff --git a/src/rlb/faslro.71 b/src/rlb/faslro.71 deleted file mode 100755 index 1f99b0ba..00000000 --- a/src/rlb/faslro.71 +++ /dev/null @@ -1,294 +0,0 @@ -(eval-when (eval compile) - (or (get 'when 'macro) (load '((lisp)umlmac))) - (or (get 'bitmac 'version) (load '((RLB) BITMAC))) - ) - -(declare (array* (notype faslist-opcodes 1 faslist-acs 1 faslist-bits 1)) - (*lexpr faslreadopen) - (*lexpr faslist faslist-loop) - (special faslread-type faslist-bits-size faslist/. linel)) - -(setq faslist-bits-size #o36000) ;big enough for 15 blocks! - -(prog1 'loadup - (or (fboundp 'sort) (load (get 'sort 'autoload))) - (or (fboundp 'sprinter) (load (get 'sprinter 'autoload))) - (or (fboundp 'format) (load (get 'format 'autoload))) - (or (fboundp 'faslreadopen) (get 'faslread 'version) - (load '|MC:RLB%;FASLRE FASL|)) - (lapfivify 0)) - -(defun dump (filespec) - (sstatus flush (status feature its)) ; Use (SSTATUS FLUSH T) on ITS - (sstatus toplevel '(faslist-loop)) - (princ '|GC'ing...| tyo) - (gc) ; Garbage collect - (princ '|Dumping...| tyo) - (suspend '|/î/ | filespec) ; Suspend - (defaultf `((dsk ,(status udir)) ,(status userid) fasl)) - (endpagefn tyo #'faslist--More--fun) - (setq gc-overflow #'gc-overflow-foo) - (faslist-loop (do ((l '(0 #^@ #^C #^M #^_) (cdr l)) - (jcl (status jcl) (delete (ascii (car l)) jcl))) - ((null l) jcl)))) - -(defun faslist-loop (&optional (jcl () jcl?)) - (do ((jcl jcl - (progn (terpri) - (princ '|FASList: | tyo) - (explodec (readline tyi '||))))) - (nil) - (cond (JCL - (let ((filename ()) options) - (do ((l jcl (cdr l))) - ((or (eq (car l) '/) ;Alt? - (null l)) - (setq filename (maknam (nreverse filename))) - (setq options (cons '/( - (nreverse (cons '/) - (nreverse (cdr l))))))) - (push (car l) filename)) - (if (errset (setq options (readlist options)) nil) - (progn (defaultf filename) - (if (probef filename) - (errset (*catch 'flush--More-- - (faslist filename - (or options 'all))) - t) - (format tyo '|/~ - ;File not found: /"~a/"| - (namestring (mergef filename defaultf))))) - (format tyo '| -;Syntax error. Use format /"filename{esc}flag1 flag2.../"/ -;Possible flags are ABS, CALL, REL, SPEC, QATOM, QLIST, GLBL,/ -; GETDDT, ARRAY, UNUSED, ATOMTB, ENTRY, LOC, PUTDDT, EVAL, and EOF/ -|) - )))) - (if (and jcl? jcl) (quit)) - (setq jcl? nil))) - -(defun faslist--More--fun (tty-file-obj) - (declare (special catching--More--)) - (if (not (and (boundp 'catching--More--) catching--More--)) - (+internal-tty-endpagefn tty-file-obj) - (let ((tyic (status ttycons tty-file-obj))) - (nointerrupt ()) - (format tyo '|--More--|) - (if (equal (tyipeek -1 tyic) #\space) - (progn (tyi tyic) (terpri tyo)) - (*throw 'catching--More-- tty-file-obj))))) - -(defun gc-overflow-foo (space) - (let* ((mumble (get (cons () (alloc 'T)) space)) - ((a b c) mumble) - (morelist '(() list 1024.)) - (more (get morelist space))) - (and more (alloc `(space (,a ,(+ b more) ,c)))) - 'T)) - -(defun faslist (&OPTIONAL (file () filep) (options 'all)) - (if (not filep) '(ABS REL SPEC CALL QATOM QLIST GLBL GETDDT - ARRAY UNUSED ATOMTB ENTRY LOC PUTDDT EVAL EOF) - (let (f faslread-type (base 8.)) - (*catch 'catching--More-- - (let ((catching--More-- 'T)) - (declare (special catching--More--)) - (cursorpos 'C tyo) - (unwind-protect (progn (setq f (faslreadopen file options)) - (faslist1 f)) - (faslreadclose f)))) - 'T))) - -(defun faslist1 (f) - (fillarray 'faslist-bits '(0)) - (do ((r (faslread f) (faslread f)) (prev-r) (word 0) (faslist/. 0) - (linel (cdr (status ttysize)))) - ((eq faslread-type 'eof) - (when prev-r (faslist-sprint prev-r linel)) - () ) - (setq word (faslreadnum f)) - (cond ((and prev-r (not (atom prev-r)) (eq faslread-type 'glbl)) - (let (/@ ((op ac e i rest) prev-r)) - (when (eq e '/@) (setq /@ '(/@) e i i rest)) - (unless ac (setq ac '0)) - (faslist-sprint - `(,op ,ac ,@/@ ,(cond ((and e (zerop e) (eq r 'R70)) - '(% 0 0 '())) - ((or (null e) (zerop e)) r) - ((and (eq r 'R70) (symbolp e)) - (get e 'faslist-r70)) - (`(+ ,r ,e))) - ,@(and i (ncons i))) - linel) - (setq prev-r () faslread-type 'foo))) - (prev-r (faslist-sprint prev-r linel) (setq prev-r ()))) - (caseq faslread-type - (abs (setq prev-r (faslist-insn word (rh-bits word) 'T) - faslist/. (1+ faslist/.))) - (foo ()) - (T - (faslist-sprint - (caseq faslread-type -; (abs (setq faslist/. (1+ faslist/.)) -; (faslist-insn word (rh-bits word) 'T)) - (rel (let* ((w (rh-bits word))) - (faslist-setbit w) - (setq faslist/. (1+ faslist/.)) - (faslist-insn word (faslist-gentag w) 'T))) - (call (unless (atom r) (setq r (car (last r)))) - (setq faslist/. (1+ faslist/.)) - (faslist-insn word (list 'function r) ())) - ((spec qatom array) - (unless (atom r) (setq r (car (last r)))) - (setq faslist/. (1+ faslist/.)) - (faslist-insn word (list (get faslread-type 'lapop) r) - 'T)) - (qlist (setq faslist/. (1+ faslist/.)) - (faslist-insn word `',r 'T)) - (entry (cons 'entry r)) - (eval r) - (loc (list faslread-type - (setq faslist/. (faslreadnum f)) - r)) - (T (list faslread-type (faslreadnum f) r))) - linel))))) - - -(defun faslist-insn (word rh acp) - (let* ((op* (faslist-opcodes (bit-range word |4.9-4.1|))) - (op (cond ((atom op*) op*) ((car op*))))) - `(,op - ,(let ((ac (bit-range word |3.9-3.6|))) - (cond (acp (faslist-acs ac)) (ac))) - ,@(and (bitp word #o20_22) (list '/@)) - ,@(cond ((not (eq (typep rh) 'fixnum)) (list rh)) - ((and (= rh 0) (= 0 (bit-range word |3.4-3.1|))) ()) - ((and (< rh #o20) (atom op*)) - (ncons (faslist-acs rh))) - ((and (not (atom op*)) (cdr op*)) - (ncons (fsc (rplac-lh 0 rh) #o1_22))) - ((< rh #o700000) (list rh)) - ((list (rplac-lh rh #o777777)))) - ,@(and (not (= 0 (setq word (bit-range word |3.4-3.1|)))) - (list (faslist-acs word)))))) - -(defun faslist-setbit (n) - (declare (fixnum n bitpos wordpos)) - (let ((bitpos (bit-and #.(1- 32.) n)) - (wordpos (lsh n #.(- (haulong 32.))))) - (and (< n faslist-bits-size) - (store (faslist-bits wordpos) - (bit-or (lsh 1 bitpos) (faslist-bits wordpos))) - 'T))) - -(defun faslist-testbit (n) - (declare (fixnum n bitpos wordpos)) - (let ((bitpos (bit-and #.(1- 32.) n)) - (wordpos (lsh n #.(- (haulong 32.))))) - (and (< n faslist-bits-size) - (not (zerop (bit-and (lsh 1 bitpos) (faslist-bits wordpos))))))) - - -(defun faslist-sprint (x linel) - (terpri) - (princ (cond ((not (> faslist/. 0)) '| |) - ((faslist-testbit (1- faslist/.)) - (faslist-gentag (1- faslist/.))) - ((1- faslist/.)))) - (sprint1 x (- linel 8) 0)) - - -(defun faslist-gentag (n) (format () '|G~4,48o| n)) - -(mapc #'(lambda (item op) (putprop item op 'lapop)) - '(spec qatom array qlist) - '(special quote array quote)) - -(array faslist-bits fixnum (// faslist-bits-size 32.)) - -(array faslist-acs T #o20) -#%(let ((acs '(0 A B C AR1 AR2A T TT D R F FREEAC P FLP FXP SP))) - (fillarray 'faslist-acs acs) - (dolist (ac acs i) - (or (equal ac 0) - (putprop ac `(% 0 0 ,i ,i) 'faslist-r70)))) - -(array faslist-opcodes T #o1000) -(prog1 'faslist-opcodes - (fillarray 'faslist-opcodes - '(0 LERR ACALL AJCALL LER3 %UDF PP STRT ;000 - SERINT TP IOJRST STRT7 CALL JCALL CALLF JCALLF ;010 - NCALL NJCALL NCALLF NJCALF - |024_33| |025_33| |026_33| |027_33| ;020 - |030_33| |031_33| |032_33| |033_33| - |034_33| |035_33| |036_33| |037_33| ;030 - *IOT *OPEN *OPER *CALL *USET *BREAK *STATU *ACCES ;040 - |050_33| |051_33| |052_33| |053_33| - |054_33| |055_33| |056_33| |057_33| ;050 - |060_33| |061_33| |062_33| |063_33| - |064_33| |065_33| |066_33| |067_33| ;060 - |070_33| |071_33| |072_33| |073_33| - |074_33| |075_33| |076_33| |077_33| ;070 - |100_33| |101_33| |102_33| |103_33| - |104_33| ADJSP |106_33| |107_33| ;100 - DFAD DFSB DFMP DFDV DADD DSUB DMUL DDIV ;110 - DMOVE DMOVN FIX EXTEND DMOVEM DMOVNM FIXR FLTR ;120 - UFA DFN (FSC) IBP ILDB LDB IDPB DPB ;130 - FAD FADL FADM FADB FADR (FADRI s) FADRM FADRB ;140 - FSB FSBL FSBM FSBB FSBR (FSBRI s) FSBRM FSBRB ;150 - FMP FMPL FMPM FMPB FMPR (FMPRI s) FMPRM FMPRB ;160 - FDV FDVL FDVM FDVB FDVR (FDVRI s) FDVRM FDVRB ;170 - MOVE (MOVEI) MOVEM MOVES MOVS (MOVSI) MOVSM MOVSS ;200 - MOVN (MOVNI) MOVNM MOVNS MOVM (MOVMI) MOVMM MOVMS ;210 - IMUL (IMULI) IMULM IMULB MUL (MULI) MULM MULB ;220 - IDIV (IDIVI) IDIVM IDIVB DIV (DIVI) DIVM DIVB ;230 - (ASH)(ROT)(LSH)(JFFO)(ASHC)(ROTC)(LSHC)(CIRC) ;240 - EXCH BLT AOBJP AOBJN JRST JFCL XCT |257_33| ;250 - PUSHJ PUSH POP POPJ JSR JSP JSA JRA ;260 - ADD (ADDI) ADDM ADDB SUB (SUBI) SUBM SUBB ;270 - (CAI)(CAIL)(CAIE)(CAILE)(CAIA)(CAIGE)(CAIN)(CAIG) ;300 - CAM CAML CAME CAMLE CAMA CAMGE CAMN CAMG ;310 - JUMP JUMPL JUMPE JUMPLE JUMPA JUMPGE JUMPN JUMPG ;320 - SKIP SKIPL SKIPE SKIPLE SKIPA SKIPGE SKIPN SKIPG ;330 - AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN AOJG ;340 - AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG ;350 - SOJ SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG ;360 - SOS SOSL SOSE SOSLE SOSA SOSGE SOSN SOSG ;370 - SETZ (SETZI) SETZM SETZB AND (ANDI) ANDM ANDB ;400 - ANDCA(ANDCAI)ANDCAM ANDCAB SETM(SETMI)SETMM SETMB ;410 - ANDCM(ANDCMI)ANDCMM ANDCMB SETA(SETAI)SETAM SETAB ;420 - XOR (XORI) XORM XORB IOR (IORI) IORM IORB ;430 - ANDCB (ANDCBI) ANDCBM ANDCBB EQV (EQVI) EQVM EQVB ;440 - SETCA(SETCAI)SETCAM SETCAB ORCA(ORCAI)ORCAM ORCAB ;450 - SETCM(SETCMI)SETCMM SETCMB ORCM(ORCMI)ORCMM ORCMB ;460 - ORCB (ORCBI) ORCBM ORCBB SETO (SETOI) SETOM SETOB ;470 - HLL (HLLI) HLLM HLLS HRL (HRLI) HRLM HRLS ;500 - HLLZ (HLLZI) HLLZM HLLZS HRLZ (HRLZI) HRLZM HRLZS ;510 - HLLO (HLLOI) HLLOM HLLOS HRLO (HRLOI) HRLOM HRLOS ;520 - HLLE (HLLEI) HLLEM HLLES HRLE (HRLEI) HRLEM HRLES ;530 - HRR (HRRI) HRRM HRRS HLR (HLRI) HLRM HLRS ;540 - HRRZ (HRRZI) HRRZM HRRZS HLRZ (HLRZI) HLRZM HLRZS ;550 - HRRO (HRROI) HRROM HRROS HLRO (HLROI) HLROM HLROS ;560 - HRRE (HRREI) HRREM HRRES HLRE (HLREI) HLREM HLRES ;570 - (TRN)(TLN)(TRNE)(TLNE)(TRNA)(TLNA)(TRNN)(TLNN) ;600 - TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN ;610 - (TRZ)(TLZ)(TRZE)(TLZE)(TRZA)(TLZA)(TRZN)(TLZN) ;620 - TDZ TSZ TDZE TSZE TDZA TSZA TDZN TSZN ;630 - (TRC)(TLC)(TRCE)(TLCE)(TRCA)(TLCA)(TRCN)(TLCN) ;640 - TDC TSC TDCE TSCE TDCA TSCA TDCN TSCN ;650 - (TRO)(TLO)(TROE)(TLOE)(TROA)(TLOA)(TRON)(TLON) ;660 - TDO TSO TDOE TSOE TDOA TSOA TDON TSON ;670 - nil)) - ;Fill in 700 thru 777 - (do ((8s 0 (+ 8s #o10)) (ch8s #/0 (1+ ch8s))) - ((> 8s #o70)) - (do ((1s 0 (1+ 1s)) (ch1s #/0 (1+ ch1s)) (n (+ 8s #o700) (1+ n))) - ((> 1s 7)) - (store (faslist-opcodes n) - (implode `(/7 ,ch8s ,ch1s /_ /3 /3)))))) - -;; Local Modes: -;; Mode:LISP -;; Comment Column:40 -;; Atom Word Mode:1 -;; END: diff --git a/src/rlb/faslro.72 b/src/rlb/faslro.73 similarity index 97% rename from src/rlb/faslro.72 rename to src/rlb/faslro.73 index 92ee825a..1e2099af 100644 --- a/src/rlb/faslro.72 +++ b/src/rlb/faslro.73 @@ -209,9 +209,15 @@ (array faslist-acs T #o20) #%(let ((acs '(0 A B C AR1 AR2A T TT D R F FREEAC P FLP FXP SP))) (fillarray 'faslist-acs acs) - (dolist (ac acs i) - (or (equal ac 0) - (putprop ac `(% 0 0 ,i ,i) 'faslist-r70)))) + (do ((i 0 (1+ i)) + (ac acs (cdr ac))) + ((null ac)) + (or (equal (car ac) 0) + (putprop (car ac) `(% 0 0 ,i ,i) 'faslist-r70))) +; (dolist (ac acs i) +; (or (equal ac 0) +; (putprop ac `(% 0 0 ,i ,i) 'faslist-r70))) + ) (array faslist-opcodes T #o1000) (prog1 'faslist-opcodes