mirror of
https://github.com/PDP-10/its.git
synced 2026-01-22 10:32:13 +00:00
316 lines
11 KiB
Common Lisp
Executable File
316 lines
11 KiB
Common Lisp
Executable File
;;; -*- Mode:Lisp; Fonts:MEDFNB; -*-
|
||
|
||
;;; LISPM: A library of LispM compatibility software for Maclisp
|
||
|
||
;;; Created by KMP@MC, 12:30am September 2, 1982
|
||
;;; The master copy of this file is MC:LIBDOC;LISPM >.
|
||
;;; Please do not edit this file. Contact KMP@MC with bugs/comments.
|
||
|
||
;;; The following are defined by this file:
|
||
;;;
|
||
;;; Name Description LispM Doc Reference
|
||
;;;
|
||
;;; DEFSUBST macro definition facility Manual, 4th ed, p215
|
||
;;; DOLIST iteration construct Manual, 4th ed, p42
|
||
;;; DOTIMES iteration construct Manual, 4th ed, p42
|
||
;;; DO* iteration construct (undocumented)
|
||
;;; MEXP macro expansion utility Manual, 4th ed, p226
|
||
;;; ONCE-ONLY macro building utility Manual, 4th ed, p223
|
||
;;; WITH-OPEN-FILE file i/o binding abstraction Manual, 4th ed, p365
|
||
;;; WITH-OPEN-STREAM stream i/o binding abstraction (undocumented)
|
||
|
||
(herald LISPM-COMPATIBILITY /6)
|
||
|
||
(sstatus feature LISPM-COMPATIBILITY) ; So people can do #+LISPM-COMPATIBILITY
|
||
|
||
|
||
;;; (DOLIST (item list) . body) LispM Manual, 4th ed, p 42
|
||
;;;
|
||
;;; DOLIST is a convenient abbreviation for the most common list iteration.
|
||
;;; DOLIST performs body once for each element in the list which is the
|
||
;;; value of LIST, with ITEM bound to the successive elements...
|
||
;;; You can use RETURN and GO and PROG-tags inside the body, as with DO.
|
||
;;; DOLIST forms return NIL unless returned from explicitly with RETURN....
|
||
|
||
(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 (gensym))
|
||
(item (car spec))
|
||
(list (cadr spec)))
|
||
`(do ((,l ,list (cdr ,l))
|
||
(,item))
|
||
((null ,l))
|
||
(setq ,item (car ,l))
|
||
,@body)))
|
||
|
||
|
||
;;; LispM Manual, 4th ed, p 223
|
||
;;;
|
||
;;; (ONCE-ONLY (var-list) form1 form2 ...)
|
||
;;;
|
||
;;; VAR-LIST is a list of variables. The FORMs are a lisp program that
|
||
;;; presumably uses the values of those variables. When the form resulting
|
||
;;; from the expansion of the ONCE-ONLY is evaluated, the first thing it
|
||
;;; does is to inspect the values of each of the variables in VAR-LIST;
|
||
;;; these values are assumed to be Lisp forms. For each of the variables, it
|
||
;;; binds that variable to either its current value, if the current value is
|
||
;;; a trivial form, or to a generated symbol. Next, once-only evalutes the
|
||
;;; forms in this new binding environment, and when they have been
|
||
;;; evaluated, it undoes the bindings. The result of the evaluation of the
|
||
;;; last FORM is presumed to be a Lisp form, typically the expansion of a
|
||
;;; maro. If all of the variables had been bound to trivial forms, the
|
||
;;; ONCE-ONLY just returns that result. Otherwise, ONCE-ONLY returns the
|
||
;;; result wrapped in a lambda-combination that binds the generated symbols
|
||
;;; to the result of evaluating the respective non-trivial forms.
|
||
|
||
(defmacro once-only (varlist &body forms)
|
||
(cond ((or (atom varlist)
|
||
(dolist (var varlist) (if (not (symbolp var)) (return t))))
|
||
(error "bad variable list in once-only" varlist)))
|
||
(let ((lose? (gensym))
|
||
(vars (gensym)))
|
||
`(let (,@(mapcar #'list varlist varlist)
|
||
(,lose? nil)
|
||
(,vars '()))
|
||
,@(mapcar #'(lambda (x)
|
||
`(cond ((and (symbolp ,x)
|
||
(not (get ,x '+INTERNAL-STRING-MARKER)))
|
||
(push (list ',x (gensym) ,x) ,vars))
|
||
((not (or (atom ,x)
|
||
(memq (car ,x) '(function quote))))
|
||
(setq ,lose? t)
|
||
(push (list ',x (gensym) ,x) ,vars))))
|
||
varlist)
|
||
(cond (,lose?
|
||
,@(mapcar #'(lambda (x)
|
||
`(setq ,x (or (cadr (assq ',x ,vars)) ,x)))
|
||
varlist)))
|
||
(let ((result (progn ,@forms)))
|
||
(if ,lose?
|
||
`(let ,(mapcar #'cdr (nreverse ,vars)) ;get side-effects right!
|
||
,result)
|
||
result)))))
|
||
|
||
|
||
;;; (DOTIMES (index count) . body) LispM Manual, 4th ed, p 42
|
||
;;;
|
||
;;; DOTIMES is a convenient abbreviation for the most common integer
|
||
;;; iteration. DOTIMES performs BODY the number of times given by the value
|
||
;;; of COUNT, with INDEX bound to 0, 1, etc. on successive iterations...
|
||
;;; You can use RETURN and GO and PROG-tags inside the body, as with DO.
|
||
;;; DOTIMES forms return NIL unless returned from explicitly with RETURN....
|
||
|
||
(defmacro dotimes (spec . body)
|
||
(cond ((or (atom spec)
|
||
(atom (cdr spec))
|
||
(cddr spec)
|
||
(not (symbolp (car spec))))
|
||
(error "Invalid binding spec for DOTIMES" spec)))
|
||
(let ((index (car spec))
|
||
(count (cadr spec)))
|
||
(once-only (count)
|
||
`(do ((,index 0 (1+ ,index)))
|
||
((not (< ,index ,count)))
|
||
,@body))))
|
||
|
||
|
||
;;; (DEFSUBST name bvl . body) LispM Manual, 4th ed, p 215
|
||
;;;
|
||
;;; A substitutable function is a function which is open coded by the
|
||
;;; compiler. It is like anyh other function when applied, but it can be
|
||
;;; expanded instead, and in that regard it resembles a macro....
|
||
;;;
|
||
;;; Note: Using #'name in code after a DEFSUBST of that name will result in
|
||
;;; a proceedable compiler error currently. This is a bug in the
|
||
;;; compiler which will hopefully be fixed. Typing P to the compiler
|
||
;;; will make the right thing happen.
|
||
|
||
(defmacro defsubst (name bvl . body)
|
||
(cond ((atom bvl)
|
||
(error "DEFSUBST can't hack atomic bvl." bvl)))
|
||
(dolist (var bvl)
|
||
(cond ((or (not (symbolp var))
|
||
(= (getcharn var 1) #/&))
|
||
(error "defsubst can't hack this variable spec." var))))
|
||
(let ((subst-name (symbolconc name " SUBST")))
|
||
`(progn 'compile
|
||
(defmacro ,name ,bvl
|
||
,(cond ((cdr body)
|
||
``(progn
|
||
,@(sublis (list ,@(mapcar #'(lambda (x)
|
||
`(cons ',x ,x))
|
||
bvl))
|
||
',body)))
|
||
(t
|
||
`(sublis
|
||
(list ,@(mapcar #'(lambda (X) `(cons ',x ,x)) bvl))
|
||
',(car body)))))
|
||
(eval-when (eval compile load)
|
||
(cond ((status feature complr)
|
||
(putprop ',name 't 'defcomplrmac))))
|
||
(defun ,subst-name ,bvl ,@body)
|
||
(let ((def (getl ',subst-name '(expr subr lsubr))))
|
||
(putprop ',name (cadr def) (car def)))
|
||
',name)))
|
||
|
||
|
||
;;; 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
|
||
;;; point. Please contact KMP 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 . modes) . body)"
|
||
var)))
|
||
(let ((true-options (cond ((not (cdr options)) (car options))
|
||
((not (dolist (option options)
|
||
(if (or (atom option)
|
||
(not (eq (car option) 'quote)))
|
||
(return t))))
|
||
`',(mapcar #'cadr options))
|
||
(t
|
||
`(list ,@options)))))
|
||
`(with-open-stream (,var (open ,filename ,true-options))
|
||
,@body)))
|
||
|
||
|
||
;;; 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)))
|
||
`(let ((,temp nil))
|
||
(unwind-protect (progn (without-interrupts (setq ,temp ,val))
|
||
(let ((,var ,temp))
|
||
,@body))
|
||
(if (or (filep ,temp)
|
||
(sfap ,temp))
|
||
(close ,temp))))))
|
||
|
||
|
||
;;; (MEXP) LispM Manual, 4th ed, p 226
|
||
;;;
|
||
;;; MEXP goes into a loop in which it reads forms and sequentially expands
|
||
;;; them, printing out the result of each expansion (using the pretty printer
|
||
;;; to improve readability). It terminates when it reads an atom. If you type
|
||
;;; in a form which is not a macro form, there will be no expansions. This
|
||
;;; allows you to see what your macros are expanding into without actually
|
||
;;; evaluating the result of the expansion.
|
||
|
||
(defun mexp ()
|
||
(do ((form)) (nil)
|
||
(errset
|
||
(progn
|
||
(format t "~&> ")
|
||
(setq form (read))
|
||
(cond ((atom form) (return nil)))
|
||
(cond ((symbolp (car form))
|
||
(let ((fn (car form)))
|
||
(cond ((and (not (get fn 'macro))
|
||
(not (getl fn '(expr fexpr subr lsubr fsubr))))
|
||
(let ((autoload-file (get fn 'autoload)))
|
||
(cond (autoload-file
|
||
(format t "~&;Autoloading ~A looking for ~S..."
|
||
(namestring autoload-file)
|
||
fn)
|
||
(load (get fn 'autoload))
|
||
(format t "~%"))))))
|
||
(cond ((get fn 'macro)
|
||
(do ((form (macroexpand-1 form) (macroexpand-1 form)))
|
||
(nil)
|
||
(format t "~& ==> ")
|
||
(sprin1 form)
|
||
(cond ((or (atom form)
|
||
(not (symbolp (car form)))
|
||
(not (get (car form) 'macro)))
|
||
(return nil)))))
|
||
(t
|
||
(format t "~&;~S has no macro definition." fn)))))
|
||
(t
|
||
(format t
|
||
"~&;CAR of that form is not a symbol, but I'll try it...~
|
||
~% ==> ")
|
||
(sprin1 (macroexpand form)))))
|
||
t)))
|
||
|
||
;;; (DO* bindings exitforms . body) ...undocumented...
|
||
;;;
|
||
;;; Like DO, but does sequential assignment rather than parallel assignment.
|
||
|
||
(defmacro do* (bindings exitforms &body body)
|
||
(cond ((< (length bindings) 2)
|
||
`(do ,bindings ,exitforms ,@body))
|
||
(t
|
||
`(let* ,(mapcar #'(lambda (x)
|
||
(if (atom x) x
|
||
(cons (car x) (if (cdr x) (list (cadr x))))))
|
||
bindings)
|
||
(do () ,exitforms
|
||
,@body
|
||
,@(mapcan #'(lambda (x)
|
||
(if (and (not (atom x)) (cddr x))
|
||
(ncons `(setq ,(car x) ,(caddr x)))))
|
||
bindings))))))
|
||
|
||
|
||
|
||
;;; Local Modes:;
|
||
;;; Mode:LISP;
|
||
;;; Lisp ONCE-ONLY Indent:1;
|
||
;;; End:;
|