BSD 4_3 development

[unix-history] / usr / lib / lisp / lmhacks.l

(setq rcs-lmhacks-
   "$Header: lmhacks.l,v 1.2 83/08/15 22:32:31 jkf Exp $")

;;  This file contains miscellaneous functions and macros that 
;;  ZetaLisp users often find useful


;;;  (c) Copyright 1982 Massachusetts Institute of Technology 

;; This is a simple multiple value scheme based on the one implemented
;; in MACLISP.  It doesn't clean up after its self properly, so if
;; you ask for multiple values, you will get them regardless of whether
;; they are returned.

(environment-maclisp (compile eval) (files struct flavorm))

(declare (macros t))

(defvar si:argn () "Number of arguments returned by last values")
(defvar si:arg2 () "Second return value")
(defvar si:arg3 () "Third return value")
(defvar si:arg4 () "Fourth return value")
(defvar si:arg5 () "Fifth return value")
(defvar si:arg6 () "Sixth return value")
(defvar si:arg7 () "Seventh return value")
(defvar si:arg8 () "Eigth return value")
(defvar si:arglist () "Additional return values after the eigth")

(defvar si:return-registers
  '(si:arg2 si:arg3 si:arg4 si:arg5 si:arg6 si:arg7 si:arg8))

(defmacro values (&rest values)
  `(prog2 (setq si:argn ,(length values))
	  ,(first values)
	  ,@(do ((vals (cdr values) (cdr vals))
		 (regs si:return-registers (cdr regs))
		 (forms))
		(nil)
	      (cond ((null vals)
		     (return (reverse forms)))
		    ((null regs)
		     (return
		      `(,@(reverse forms)
			(setq si:arglist (list ,@vals)))))
		    (t (push `(setq ,(car regs) ,(car vals))
			     forms))))))

(defun values-list (list)
  (setq si:argn (length list))
  (do ((vals (cdr list) (cdr vals))
       (regs si:return-registers (cdr regs)))
      ((null regs)
       (if (not (null vals))
	   (setq si:arglist vals))
       (car list))
    (set (car regs) (car vals))))

(defmacro multiple-value (vars form)
  `(progn
     ,@(if (not (null (car vars)))
	  `((setq ,(car vars) ,form)
	    (if (< si:argn 1) (setq ,(car vars) nil)))
	  `(,form))
     ,@(do ((vs (cdr vars) (cdr vs))
	    (regs si:return-registers (cdr regs))
	    (i 2 (1+ i))
	    (forms))
	   (nil)
	 (cond ((null vars)
		(return (reverse forms)))
	       ((null regs)
		(return
		 (do ((vs vs (cdr vs)))
		     ((null vs) (nreverse forms))
		   (and (not (null (car vs)))
			(push
			 `(setq ,(car vs)
				(prog1
				 (if (not (> ,i si:argn))
				     (car si:arglist))
				 (setq si:arglist (cdr si:arglist))))
			 forms)))))
	       ((not (null (car vs)))
		(push `(setq ,(car vs) (if (not (> ,i si:argn)) ,(car regs))
			     ,(car regs) nil)
		      forms))))))

(defmacro multiple-value-bind (vars form &rest body)
  `(let ,vars
	(multiple-value ,vars ,form)
	,@body))

(defmacro multiple-value-list (form)
  `(multiple-value-list-1 ,form))

(defun multiple-value-list-1 (si:arg1)
  (cond ((= 0 si:argn) ())
	((= 1 si:argn)
	 (list si:arg1))
	((= 2 si:argn)
	 (list si:arg1 si:arg2))
	((= 3 si:argn)
	 (list si:arg1 si:arg2 si:arg3))
	((= 4 si:argn)
	 (list si:arg1 si:arg2 si:arg3 si:arg4))
	((= 5 si:argn)
	 (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5))
	((= 6 si:argn)
	 (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6))
	((= 7 si:argn)
	 (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6
	       si:arg7))
	((= 8 si:argn)
	 (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6
	       si:arg7 si:arg8))
	((> si:argn 8)
	 (rplacd (nthcdr (- si:argn 9) si:arglist) nil)
	 (list* si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6
		si:arg7 si:arg8 si:arglist))
	(t (ferror () "Internal error, si:argn = ~D" si:argn))))
\f
(defun union (set &rest others)
  (loop for s in others
	do (loop for elt in s
		 unless (memq elt set)
		 do (push elt set))
	finally (return set)))

(defun make-list (length &rest options &aux (iv))
  (loop for (key val) on options by #'cddr
	do (selectq key
	     (:initial-value
		(setq iv val))
	     (:area)
	     (otherwise
	      (error "Illegal parameter to make-list" key))))
  (loop for i from 1 to length collect iv))
\f
;; si:printing-random-object
;; A macro for aiding in the printing of random objects.
;; This macro generates a form which: (by default) includes the virtual 
;; address in the printed representation.
;; Options are	:NO-POINTER to suppress the pointer
;;		:TYPEP princs the typep of the object first.

;; Example:
;; (DEFSELECT ((:PROPERTY HACKER :NAMED-STRUCTURE-INVOKE))
;;   (:PRINT-SELF (HACKER STREAM IGNORE IGNORE)
;;     (SI:PRINTING-RANDOM-OBJECT (HACKER STREAM :TYPEP)
;;       (PRIN1 (HACKER-NAME HACKER) STREAM))))
;; ==> #<HACKER /"MMcM/" 6172536765>

(defmacro si:printing-random-object ((object stream . options) &body body)
  (let ((%pointer t)
	(typep nil))
    (do ((l options (cdr l)))
	((null l))
      (selectq (car l)
	(:no-pointer (setq %pointer nil))
	(:typep (setq typep t))
	(:fastp (setq l (cdr l)))		; for compatibility sake
	(otherwise
	 (ferror nil "~S is an unknown keyword in si:printing-random-object"
		 (car l)))))
    `(progn
       (patom "#<" ,stream)
       ,@(and typep
	      `((patom (:typep ,object) ,stream)))
       ,@(and typep body
	      `((patom " " ,stream)))
       ,@body
       ,@(and %pointer
	      `((patom " " ,stream)
		(patom (maknum ,object) ,stream)))
       (patom ">" ,stream)
       ,object)))
\f
(defun named-structure-p (x &aux symbol)
  (cond ((or (and (hunkp x) (atom (setq symbol (cxr 0 x))))
	     (and (vectorp x)
		  (setq symbol (or (and (atom (vprop x)) (vprop x))
				   (and (dtpr (vprop x))
					(atom (car (vprop x)))
					(car (vprop x)))))))
				  
	 (if (get symbol 'defstruct-description)
	     symbol))))

(defun named-structure-symbol (x)
  (or (named-structure-p x)
      (ferror () "~S was supposed to have been a named structure."
	      x)))

(declare (localf named-structure-invoke-internal))

(defun named-structure-invoke (operation struct &rest args)
  (named-structure-invoke-internal operation struct args t))

(defun named-structure-invoke-carefully (operation struct &rest args)
  (named-structure-invoke-internal operation struct args nil))

(defun named-structure-invoke-internal (operation struct args error-p)
   (let (symbol fun)
      (setq symbol (named-structure-symbol struct))
      (if (setq fun (get symbol ':named-structure-invoke))
	 then (lexpr-funcall fun operation struct args)
	 else (and error-p
		   (ferror ()
			   "No named structure invoke function for ~S"
			   struct)))))

(defmacro defselect ((function-spec default-handler no-which-operations)
		     &rest args)
  (let ((name (intern (gensym)))
	fun-name)
    `(progn 'compile
       (defun ,(if (eq (car function-spec) ':property)
		   (cdr function-spec)
		   (ferror () "Can't interpret ~S defselect function spec"
				  function-spec))
	      (operation &rest args &aux temp)
	 (if (setq temp (gethash operation (get ',name 'select-table)))
	     (lexpr-funcall temp args)
	     ,(if default-handler
		  `(lexpr-funcall ,default-handler operation args)
		  `(ferror () "No handler for the ~S method of ~S"
			   operation ',function-spec))))
       (setf (get ',name 'select-table) (make-hash-table))
       ,@(do ((args args (cdr args))
	     (form)
	     (forms nil))
  	    ((null args) (nreverse forms))
	  (setq form (car args))
	  (cond ((atom (cdr form))
		 (setq fun-name (cdr form)))
		(t (setq fun-name
			 (intern (concat name (if (atom (car form)) (car form)
						  (caar form)))))
		   (push `(defun ,fun-name ,@(cdr form)) forms)))
	  (if (atom (car form))
	      (push `(puthash ',(car form) ',fun-name
			      (get ',name 'select-table))
		    forms)
	      (mapc #'(lambda (q)
			(push `(puthash ',q ',fun-name
					(get ',name 'select-table))
			      forms))
		    (car form))))
       ,@(and (not no-which-operations)
	      `((defun ,(setq fun-name (intern
					(concat name '-which-operations)))
		       (&rest args)
		  '(:which-operations ,@(loop for form in args
					      appending (if (atom (car form))
							    (list (car form))
							    (car form)))))
		(puthash ':which-operations ',fun-name
			 (get ',name 'select-table))))
       ',function-spec)))
\f
(defun :typep (ob &optional (type nil) &aux temp)
  (cond ((instancep ob)
	 (instance-typep ob type))
	((setq temp (named-structure-p ob))
	 (if (null type) temp
	     (if (eq type temp) t
		 (memq type (nth 11. (get temp 'defstruct-description))))))
	((hunkp ob)
	 (if (null type) 'hunk (eq type 'hunk)))
	((null type)
	 (funcall 'typep ob))
	(t (eq type (funcall 'typep ob)))))

(defun send-internal (object message &rest args)
  (declare (special .own-flavor. self))
  (lexpr-funcall (if (eq self object)
		     (or (gethash message
				  (flavor-method-hash-table .own-flavor.))
			 (flavor-default-handler .own-flavor.))
		     object)
		 message args))
\f
;; New printer

(declare (special poport prinlevel prinlength top-level-print))

(defun zprint (x &optional (stream poport))
       (zprin1 x stream)
       't)

(defun zprinc (x &optional (stream poport))
       (zprin1a x stream () (or prinlevel -1)))

(defun zprin1 (x &optional (stream poport))
       (zprin1a x stream 't (or prinlevel -1)))

(defun zprin1a (ob stream slashifyp level &aux temp)
  (cond ((null ob) (patom "()" stream))
	((setq temp (named-structure-p ob))
	 (or (named-structure-invoke-carefully ':print-self ob stream
						level slashifyp)
	     (si:printing-random-object (ob stream :typep))))
	((instancep ob)
	 (if (get-handler-for ob ':print-self)
	     (send ob ':print-self stream)
	     (si:printing-random-object (ob stream :typep))))
        ((atom ob)
	 (if slashifyp (xxprint ob stream)
	     (patom ob stream)))
	((dtpr ob) (zprint-list ob stream slashifyp (1- level)))
	((hunkp ob) (zprint-hunk ob stream slashifyp (1- level)))
	((= level 0)
	 (patom "&" stream))
	(t
	 (if slashifyp (xxprint ob stream)
	     (patom ob stream))))
  't)

(defun zprint-list (l stream slashifyp level)
       (tyo #/( stream)
       (do ((l l (cdr l))
	    (i (or prinlength -1) (1- i))
	    (first t nil))
	   ((not (dtpr l))
	    (cond ((not (null l))
		   (patom " . " stream)
		   (zprin1a l stream slashifyp level)))
	    't)
           (cond ((= i 0)
		  (patom " ..." stream)
		  (return 't)))
	   (if (not first)
	       (tyo #/  stream))
	   (zprin1a (car l) stream slashifyp level))
       (tyo #/) stream))

(defun zprint-hunk (l stream slashifyp level)
       (tyo #/{ stream)
       (do ((i 0 (1+ i))
	    (lim (hunksize l))
	    (first t nil))
	   ((= i lim)
	    't)
           (cond ((and (not (null prinlength)) (not (< i prinlength)))
		  (patom " ..." stream)
		  (return 't)))
	   (if (not first)
	       (tyo #/  stream))
	   (zprin1a (cxr i l) stream slashifyp level))
       (tyo #/} stream))

(eval-when (load eval)
   (putd 'xxprint (getd 'print))
   (putd 'xxprinc (getd 'princ)))

(defun new-printer ()
  (setq top-level-print 'zprint)
  (putd 'print (getd 'zprint))
  (putd 'prin1 (getd 'zprin1))
  't)

(defun old-printer ()
  (setq top-level-print 'xxprint)
  (putd 'print (getd 'xxprint))
  (putd 'princ (getd 'xxprinc))
  't)




(putprop 'lmhacks t 'version)