;;; -*- 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:;
