Skip to content
Snippets Groups Projects
lisp-utilities.lisp 56.9 KiB
Newer Older
cer's avatar
cer committed
    (unless table
      (setf (gethash indicator *compile-time-property-table*)
	    (setq table (make-hash-table))))
    (values (gethash symbol table default))))

(defsetf compile-time-property #+Genera compiler:file-declare
			       #-Genera set-compile-time-property)

#-Genera
(defun set-compile-time-property (symbol indicator value)
  #+Cloe-Runtime
  (when system::*file-declaration-environment*
    (setf (clos-internals::file-declaration symbol indicator) value))
cer's avatar
cer committed
  #+Minima-Developer
  (zl:::compiler:file-declare symbol indicator value)
  #-(or Cloe-Runtime Minima-Developer)
cer's avatar
cer committed
  (let ((table (gethash indicator *compile-time-property-table*)))
    (unless table
      (setf (gethash indicator *compile-time-property-table*)
	    (setq table (make-hash-table))))
cer's avatar
cer committed
    (setf (gethash symbol table) value))
  value)
cer's avatar
cer committed

cer's avatar
cer committed
#-(or Genera (and ansi-90 (not (and Allegro (or :rs6000 (not (version>= 4 1)))))))
cer's avatar
cer committed
(defmacro define-compiler-macro (name lambda-list &body body &environment env)
  env
cer's avatar
cer committed
  #+Allegro `(excl::defcmacro ,name ,lambda-list ,@body)
  #-(or Genera Allegro) (progn name lambda-list body env nil))	;Suppress compiler warnings.
cer's avatar
cer committed

#+Genera
;;; Support (proclaim '(function ...)) and (proclaim '(ftype ...)).
;;; This is part of deleting spurious multiple-definition warnings about constructors.
;;; Of course, who knows if this will work in other lisps.
cer's avatar
cer committed
(zl:::scl:defun (:property ftype zl:::scl:proclaim) (decl compile-time)
cer's avatar
cer committed
  (declare (ignore compile-time))		;Do it at load time as well.
  (mapc #'compiler:function-defined (cdr decl)))


cer's avatar
cer committed
#-(or Genera ANSI-90)
cer's avatar
cer committed
(defmacro print-unreadable-object ((object stream &key type identity) &body body)
  `(flet ((print-unreadable-object-body () ,@body))
     (declare (dynamic-extent #'print-unreadable-object-body))
     (print-unreadable-object-1 ,object ,stream ,type ,identity
				#'print-unreadable-object-body
				',(not (null body)))))

cer's avatar
cer committed
#-(or Genera ANSI-90)
cer's avatar
cer committed
;;; EXTRA-SPACE-REQUIRED is optional because old compiled code didn't always supply it.
(defun print-unreadable-object-1 (object stream type identity continuation
					 &optional (extra-space-required t))
  (write-string "#<" stream)
  ;; wish TYPE-OF worked in PCL
  (when type (lisp:format stream "~S " (class-name (class-of object))))
  (funcall continuation)
  (when identity
    (when extra-space-required (write-char #\space stream))
    (#+PCL pcl::printing-random-thing-internal	;; I assume PCL gets this right. -- rsl
     #-PCL print-unreadable-object-identity
     object stream))
  (write-string ">" stream))

cer's avatar
cer committed
#-(or PCL Genera ANSI-90)
cer's avatar
cer committed
(defun print-unreadable-object-identity (object stream)
  #+Genera (format stream "~O" (sys:%pointer object))
cer's avatar
cer committed
  #+Allegro (format stream "@~X" (excl::pointer-to-fixnum object))
cer's avatar
cer committed
  ;; Lucid prints its addresses out in Hex.
  #+Lucid (format stream "~X" (sys:%pointer object))
cer's avatar
cer committed
  ;; Probably aren't any #+(and (not Genera) (not Allegro) (not PCL) (not ANSI-90))
cer's avatar
cer committed
  ;; implementations (actually, this is false: Lispworks).
cer's avatar
cer committed
  #-(or Genera Allegro Lucid) (declare (ignore object))
  #-(or Genera Allegro Lucid) (format stream "???"))
cer's avatar
cer committed

cer's avatar
cer committed
#-(or Genera ANSI-90 Lucid)
cer's avatar
cer committed
(defvar *print-readably* nil)

cer's avatar
cer committed
#-(or Genera Lucid ANSI-90)
cer's avatar
cer committed
(deftype real (&optional (min '*) (max '*))
  (labels ((convert (limit floatp)
	     (typecase limit
cer's avatar
cer committed
	       (number (if floatp (float limit 0f0) (rational limit)))
cer's avatar
cer committed
	       (list (map 'list #'convert limit))
	       (otherwise limit))))
    `(or (float ,(convert min t) ,(convert max t))
	 (rational ,(convert min nil) ,(convert max nil)))))

cer's avatar
cer committed
#+Genera-Release-8-1
(defun realp (x)
  (typep x 'real))

cer's avatar
cer committed
(defconstant *end-of-file-marker* :eof)
cer's avatar
cer committed
(deftype end-of-file-marker () 
cer's avatar
 
cer committed

#+Cloe-Runtime
(defmacro load-time-value (form &optional read-only-p)
  (declare (ignore read-only-p))
  form)
cer's avatar
cer committed

cer's avatar
cer committed

;;; Use a lambda-list to extract arguments from a list and bind variables.
;;; This "should" signal an error if the list doesn't match the lambda-list.
;;; In implementations that have DESTRUCTURING-BIND, the easiest thing is to use it.
;;; We're actually not using the destructuring part, just the ability to match
;;; a lambda-list to a list of arguments without making a closure and using APPLY.
;;; ANSI CL has DESTRUCTURING-BIND.  Cloe and Lucid have it.
;;; Genera has it in both SYMBOLICS-COMMON-LISP and FUTURE-COMMON-LISP,
;;; but the CLIM-LISP package doesn't use either of those.
;;; Last time I checked Franz did not have it
(defmacro bind-to-list (lambda-list list &body body)
  (cond ((not (constantp list))
cer's avatar
cer committed
	 #+Genera `(scl:destructuring-bind ,lambda-list ,list
		     ,(ignore-arglist lambda-list)
		     ,@body)
	 #+Cloe-Runtime `(cloe:destructuring-bind ,lambda-list ,list
			   ,(ignore-arglist lambda-list)
			   ,@body)
	 #+Minima `(destructuring-bind ,lambda-list ,list
		     ,(ignore-arglist lambda-list)
		     ,@body)
	 #+Lucid `(lucid-common-lisp:destructuring-bind ,lambda-list ,list
		    ,(ignore-arglist lambda-list)
		    ,@body)
cer's avatar
cer committed
 	 #+Allegro `(destructuring-bind ,lambda-list ,list
 		      ,(ignore-arglist lambda-list)
 		      ,@body)
cer's avatar
cer committed
	 ;; For the other systems, I guess we'll just give up and do it the slow way
cer's avatar
cer committed
	 #-(or Genera Cloe-Runtime Minima Lucid Allegro)
cer's avatar
cer committed
	 `(flet ((bind-to-list-body ,lambda-list
cer's avatar
cer committed
		   ,@(when (member '&rest lambda-list)
		       `((declare (dynamic-extent ,(second (member '&rest lambda-list))))))
cer's avatar
cer committed
		   ,(ignore-arglist lambda-list)
		   ,@body))
	    (declare (dynamic-extent #'bind-to-list-body))
	    (apply #'bind-to-list-body ,list)))
	(t
	 ;; This special case supposedly comes up a lot, but I think it never comes up
	 ;; This optimization plays fast and loose with order of evaluation issues
	 ;; for the default value forms in the lambda-list
	 (setq list (eval list))
	 `(symbol-macrolet
cer's avatar
cer committed
	    ,(do ((item)
		  (result nil)
		  (mode nil))
		 ((null lambda-list) (nreverse result))
	       (setq item (pop lambda-list))
	       (cond ((member item '(&optional &rest &key &aux))
		      (setq mode item))
		     ((member item lambda-list-keywords))
		     ((eq mode '&rest)
		      (push `(,item ',list) result))
		     ((eq mode '&key)
		      (multiple-value-bind (variable default supplied-p)
			  (if (atom item) (values item nil nil)
			    (values (if (atom (car item)) (car item) (cadar item))
				    (second item) (third item)))
			(do ((l list (cddr l))
			     (k (parameter-specifier-keyword item)))
			    ((null l)
			     (push `(,variable ,default) result)
			     (when supplied-p
			       (push `(,supplied-p 'nil) result)))
			  (when (eq (first l) k)
			    (push `(,variable ',(second l)) result)
			    (when supplied-p
			      (push `(,supplied-p 't) result))
			    (return)))))
		     (t
		      (multiple-value-bind (variable default supplied-p)
			  (if (atom item) (values item nil nil)
			    (values (first item) (second item) (third item)))
			(cond ((null list)
cer's avatar
cer committed
			       (push `(,variable ,default) result)
			       (when supplied-p
				 (push `(,supplied-p 'nil) result)))
cer's avatar
cer committed
			      (t
			       (push `(,variable ',(pop list)) result)
			       (when supplied-p
				 (push `(,supplied-p 't) result))))))))
cer's avatar
cer committed
	    ,@body))))

;;; Optimization to not bother with destructuring bind if none of the variables
;;; will be used
(defun lambda-list-variables-used-in-body (lambda-list body)
  ;; First collect the variables bound by lambda-list
  (let ((variables nil))
    (do* ((lambda-list lambda-list (cdr lambda-list))
	  (item (first lambda-list) (first lambda-list)))
	 ((null lambda-list))
      (cond ((member item lambda-list-keywords))
	    ((atom item)
	     (push item variables))
	    (t
	     (push (if (atom (car item)) (car item) (cadar item)) variables)
	     (when (cddr item) (push (caddr item) variables)))))
    (when variables
      #+Genera
      (lt:mapforms #'(lambda (subform kind usage state)
		       (declare (ignore usage state))
		       (when (and (member subform variables)
				  (not (member subform lt:*mapforms-bound-variables*))
				  (member kind 'lt:(set symeval)))
			 (return-from lambda-list-variables-used-in-body t)))
		   `(progn ,@body)
		   :bound-variables nil)
      #+Cloe-Runtime
      (labels ((mapper (subform context)
		 ;; It's not worth worrying about being fooled by shadowing bindings
		 ;; with the same name
		 (when (and (member subform variables)
			    (member context '(:access :assign)))
		   (return-from lambda-list-variables-used-in-body t))
		 (clos-internals::map-forms-recurse #'mapper subform context)))
	(clos-internals::map-forms-toplevel #'mapper `(progn ,@body)))
      #+(or Genera Cloe-Runtime) nil
      #-(or Genera Cloe-Runtime)
      ;; We don't know how to do this correctly in other Lisps, since there isn't any
      ;; standardized code-walker, but as a first approximation we can assume that
      ;; if the symbols appear textually they are used as variables, and if they don't,
      ;; they aren't.  Tricky use of macros could defeat this, but it should work well enough.
      ;; Of course this can be fooled by a quoted constant with the same name as a variable
      ;; into producing an unnecessary binding, but that's only an efficiency issue.
      (labels ((analyze (tree)
		 (if (atom tree)
		     (member tree variables)
		     (some #'analyze tree))))
	(analyze body)))))

;;; Get the keyword argument name from an &KEY parameter specifier
(defun parameter-specifier-keyword (spec)
  (cond ((atom spec)
cer's avatar
cer committed
	 (intern (symbol-name spec) *keyword-package*))
cer's avatar
cer committed
	((atom (car spec))
cer's avatar
cer committed
	 (intern (symbol-name (car spec)) *keyword-package*))
cer's avatar
cer committed
	(t (caar spec))))

;;; This is needed because FIND-CLASS in the compile-file environment doesn't look
;;; also in the run-time environment, at least in Symbolics CLOS, which is pretty
;;; embarrassing when we can't find the class T.
;;; In Lucid 4.0 this produces spurious wrong number of arguments warnings for the calls
;;; to FIND-CLASS.  There is no run-time error, it really does accept three arguments.
(defun find-class-that-works (name &optional (errorp t) environment)
cer's avatar
cer committed
  #+Genera (declare (inline compile-file-environment-p))
cer's avatar
cer committed
  #+ccl-2 (when (eq environment 'compile-file)
cer's avatar
cer committed
            (setq environment ccl::*fcomp-compilation-environment*))
cer's avatar
cer committed
  #+Allegro (let ((environment (compile-file-environment-p environment)))
	      (if environment
	          (or (find-class name nil environment)
		      (find-class name errorp nil))
	          (find-class name errorp)))
cer's avatar
cer committed
  #-Allegro (if (compile-file-environment-p environment)
cer's avatar
cer committed
	        (or (find-class name nil environment)
cer's avatar
cer committed
		    (find-class name errorp nil))
cer's avatar
cer committed
	        (find-class name errorp environment)))

#+Allegro
(eval-when (compile)
  (warn "~S hacked for lack of environment support in 4.1" 'find-class-that-works))
cer's avatar
cer committed


;;; F-ers

(define-modify-macro minf (&rest other-values) min)
(define-modify-macro maxf (&rest other-values) max)

(defmacro minf-or (place &rest things)
  `(if (null ,place) (setf ,place (min ,@things)) (minf ,place ,@things)))

(defmacro maxf-or (place &rest things)
  `(if (null ,place) (setf ,place (max ,@things)) (maxf ,place ,@things)))

(define-modify-macro roundf (&optional (divisor 1)) round)


;;; Simple vector support

(defun-inline copy-vector-portion (from-vector from-start to-vector to-start length)
cer's avatar
cer committed
  (declare (type fixnum from-start to-start length)
cer's avatar
cer committed
	   (type simple-vector from-vector to-vector))
  (declare (optimize (speed 3) (safety 0)))
  (cond (#+Genera (< length 8) #-Genera t
cer's avatar
cer committed
	 (let (#+(or Genera Minima) (from-vector from-vector)
	       #+(or Genera Minima) (to-vector to-vector))
	   #+(or Genera Minima) (declare (type simple-vector from-vector to-vector))
cer's avatar
cer committed
	   (repeat length
cer's avatar
cer committed
	     (setf (svref to-vector to-start) (svref from-vector from-start))
	     (incf from-start)
	     (incf to-start))))
	#+Genera
	(t
	 (si:copy-array-portion from-vector from-start (+ from-start length)
				to-vector to-start (+ to-start length)))))

;; VECTOR must be a simple vector, FILL-POINTER serves as its fill pointer.
;; The returned values are a (possibly new) vector and the new fill pointer.
;; The idiom for using this is
;; (MULTIPLE-VALUE-SETQ (VECTOR FP) (SIMPLE-VECTOR-PUSH-EXTEND ELEMENT VECTOR FP)).
(defun simple-vector-push-extend (element vector fill-pointer &optional extension)
  (declare (values vector fill-pointer))
cer's avatar
cer committed
  (declare (type fixnum fill-pointer)
	   (type simple-vector vector))
cer's avatar
cer committed
  (let ((length (array-dimension vector 0)))
cer's avatar
cer committed
    (declare (type fixnum length))
cer's avatar
cer committed
    (when (= fill-pointer length)
      ;; Grow the vector
      (let ((new-vector (make-array (+ length (max (ash length -1) (or extension 20)))
				    :element-type (array-element-type vector))))
	(copy-vector-portion vector 0 new-vector 0 length)
	(setq vector new-vector)))
    ;; Insert the new element and return the right values
    (setf (svref vector fill-pointer) element)
    (incf fill-pointer)
    (values vector fill-pointer)))

(defun simple-vector-insert-element (element index vector fill-pointer &optional extension)
  (declare (values vector fill-pointer))
cer's avatar
cer committed
  (declare (type fixnum index fill-pointer)
	   (type simple-vector vector))
cer's avatar
cer committed
  (let ((length (array-dimension vector 0)))
cer's avatar
cer committed
    (declare (type fixnum length))
cer's avatar
cer committed
    (cond ((= fill-pointer length)
	   ;; Grow the vector, leaving a hole for the new element
	   (let ((new-vector (make-array (+ length (max (ash length -1) (or extension 20)))
					 :element-type (array-element-type vector))))
	     (copy-vector-portion vector 0 new-vector 0 index) 
	     (copy-vector-portion vector index new-vector (1+ index) (- length index))
	     (setq vector new-vector)))
	  (t
	   ;; Leave a hole for the new element
cer's avatar
cer committed
	   (let (#+(or Genera Minima) (vector vector))
cer's avatar
cer committed
	     #+(or Genera Minima) (declare (type simple-vector vector))
cer's avatar
cer committed
	     (do ((i fill-pointer (1- i)))
		 ((= i index))
cer's avatar
cer committed
	       (declare (type fixnum i)
cer's avatar
cer committed
			(optimize (speed 3) (safety 0)))
	       (setf (svref vector i) (svref vector (1- i)))))))
    ;; Plug in the new element and return the right values
    (setf (svref vector index) element)
    (incf fill-pointer)
    (values vector fill-pointer)))


;;; Debugging support
(defmacro compiler-warn (format-string &rest format-args)
  `(macrolet ((warn-it ()
		(warn ,format-string ,@format-args)))
     (warn-it)))


;;; Condition support
;;; The idea here is to provide a macro that will arrange for the abort choice
;;; to be on the "Abort" debugger choice, if possible.
;;; I would just use WITH-SIMPLE-RESTART but in Genera that doesn't end up
;;; on the <Abort> key.  Note that in Allegro, this choice ends up as an ordinary 
;;; proceed option, but in Lucid it ends up on ":A".
(defmacro with-simple-abort-restart ((format-string &rest format-args) &body body)
  #{
    Genera `(scl:catch-error-restart ((sys:abort) ,format-string ,@format-args)
	      ,@body)
    otherwise `(with-simple-restart (abort ,format-string ,@format-args)
		 ,@body)
   }
  )

(defmacro with-simple-abort-restart-if (condition (format-string &rest format-args) &body body)
  (let ((name (gensymbol 'abort-restart-form)))
    `(flet ((,name () ,@body))
       (declare (dynamic-extent #',name))
       (if ,condition
	   (with-simple-abort-restart (,format-string ,@format-args) (,name))
	   ;; Still establish it as a restart, just don't handle ABORT.
	   (with-simple-restart (nil ,format-string ,@format-args)
	     (,name))))))
cer's avatar
cer committed


#||

;;; The DEFINE-CLASS-MIXTURE macro is designed to allow some flexibility
;;; in the way the programmer defines class hierarchies.  It works
;;; pretty much the same as the Flavors :MIXTURE option to DEFFLAVOR,
;;; except without one of the more mystifying features, namely the
;;; ability to condition the keywords' effects on the value of other
;;; keywords.  Here is an example of the kind of this this version
;;; handles:
;;; (define-class-mixture drawing-path
;;;   (:stretch-p stretching-drawing-path-mixin)
;;;   (:orientation
;;;     (nil horizontal-drawing-path-mixin)
;;;     (:diagonal "Diagonal drawing paths not yet implemented")
;;;     (:horizontal horizontal-drawing-path-mixin)
;;;     (:vertical vertical-drawing-path-mixin)))
(defmacro define-class-mixture (name &body specs)
  `(define-group ,name define-class-mixture
     ,@(define-class-mixture-compile-time name specs)))
#+Genera (scl:defprop define-class-mixture "Class Mixture" si:definition-type-name)

;;; Use this to define a class-mixture and a resource at the same time.
;;; This defines a mixture, and a resource of them which has a matcher
;;; and a constructor which will do what you want, namely give you
;;; objects which have the right properties flavors mixed in.
(defmacro define-class-mixture-and-resource (name (&key initializer initial-copies)
					     &body specs)
  (let ((matcher-function-name 
	  (make-symbol (lisp:format nil "~A-~A" name 'matcher)))
	(constructor-function-name
	  (make-symbol (lisp:format nil "~A-~A" name 'constructor))))
    `(define-group ,name define-class-mixture-and-resource
       (define-class-mixture ,name ,@specs)
       (defun ,matcher-function-name (object os &rest args)
	 (declare (dynamic-extent args))
	 (declare (ignore os))			;Object-storage object from resource
	 (apply #'mixture-typep object ',name args))
       (defun ,constructor-function-name (rd &rest args)
	 (declare (dynamic-extent args))
	 (declare (ignore rd))			;resource-descriptor for resource
	 (apply #'make-mixture-instance ',name args))
       (defresource ,name (&rest args)
	 :constructor ,constructor-function-name
	 :matcher ,matcher-function-name
	 :initializer ,initializer
	 :initial-copies ,initial-copies))))

;;; Create an instance of a class which has a mixture option.
(defun make-mixture-instance (mixture-name &rest args)
  (declare (dynamic-extent args))
  (apply #'make-instance
	 (apply (get mixture-name 'mixture-class-name) args)
	 args))

(defun mixture-typep (instance mixture-name &rest args)
  (declare (dynamic-extent args))
  (typep instance (apply (get mixture-name 'mixture-class-name) args)))

;;; The guts of DEFINE-CLASS-MIXTURE.  This creates a class-name
;;; function for a given mixture definition, plus all the classes you
;;; need to make it work.  The class names are heuristically chosen to
;;; be the ones the programmer would likely have chosen for the mixed
;;; flavors.  There is no attempt to fix problems this heuristic might
;;; cause, unlike Flavors.

(defun define-class-mixture-compile-time (name specs)
  (let ((keywords nil)
	(forms nil)
	(classes nil)
	(trimmed-names nil))
    (labels ((compile (form) (push form forms))
	     (define-class (class-name component-list)
	       (compile `(defclass ,class-name
				   (,@component-list ,name)
			   ())))
	     (substring (string start &optional end)
	       (setf string (string string))
	       (subseq string start (or end (length string))))
	     (trim-off-name-parts (the-class-name)
	       (let ((pair (assoc the-class-name trimmed-names)))
		 (when pair (return-from trim-off-name-parts (cdr pair))))
	       (let* ((class-name (string the-class-name))
		      (sname (string name))
		      (nl (length sname)))
		 (when (and (> (length class-name) 6)
			    (string-equal class-name "BASIC-" :end1 6))
		   (setf class-name (substring class-name 6)))
		 (when (and (> (length class-name) 6) 
			    (string-equal class-name "-MIXIN"
					  :start1 (- (length class-name) 6)))
		   (setf class-name (substring class-name 0 (- (length class-name) 6))))
		 (when (and (> (length class-name) nl)
			    (string-equal class-name sname :start1 (- (length class-name) nl)))
		   (setf class-name (substring class-name 0 (- (length class-name) nl))))
		 (push (cons the-class-name class-name) trimmed-names)
		 class-name))
	     (invent-class-name (subclasses)
	       (when (stringp (first subclasses))
		 (return-from invent-class-name `(error "Can't decode mixture ~S: ~A"
							',name ,(first subclasses))))
	       (intern
		 (with-output-to-string (out)
		   (dolist (class subclasses)
		     (princ (trim-off-name-parts class) out))
		   (princ name out))))
	     (process-specs (specs classes-so-far)
	       (when (null specs)
		 (let ((class-name (invent-class-name classes-so-far)))
		   (when (symbolp class-name)
		     (unless (member class-name classes)
		       (push class-name classes)
		       (define-class class-name classes-so-far))
		     (return-from process-specs `',class-name))
		   (return-from process-specs class-name)))
	       (let* ((first-spec (first specs))
		      (keyword (first first-spec))
		      (variable-name (intern (symbol-name keyword)))
		      (rest (rest first-spec)))
		 (pushnew variable-name keywords)
		 (assert (consp rest) ()
			 "Ill-formatted mixture specification: ~S" specs)
		 (when (and (first rest) (symbolp (first rest)))
		   (assert (null (cdr rest)) ()
			   "A component-class mixture spec must stand alone. ~S is incorrect."
			   first-spec)
		   (return-from process-specs 
		     `(if ,variable-name
			  ,(process-specs (cdr specs) (cons (first rest) classes-so-far))
			  ,(process-specs (cdr specs) classes-so-far))))
		 (assert (and rest (listp rest)) ()
			 "A specification keyword must be followed by one or more values.  ~
			  ~S is incorrect."
			 first-spec)
		 `(case ,variable-name
		    ,@(mapcar #'(lambda (subspec)
				  `((,(first subspec))
				    ,(if (second subspec)
					 (process-specs (cdr specs)
							(cons (second subspec) classes-so-far))
					 (process-specs (cdr specs) classes-so-far))))
			      rest)
		    ,@(unless (assoc 'otherwise rest)
			`((otherwise (error "~S is illegal as the ~S option to mixture ~S.~%~
					     The legal values are ~{~S~^, ~}."
					    ,variable-name ,keyword ',name
					    ',(mapcar #'first rest)))))))))
      (let ((result (process-specs specs nil)))
	(compile `(defun-property (,name mixture-class-name)
				  (&key ,@keywords &allow-other-keys)
		    ,result))))
    (nreverse forms)))

||#