;;;-*-Mode:LISP; Package:(PCL (LISP WALKER) 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation. All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox Artifical Intelligence Systems
;;; 2400 Hanover St.
;;; Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; This file contains portable versions of low-level functions and macros
;;; which are ripe for implementation specific customization. None of the
;;; code in this file *has* to be customized for a particular Common Lisp
;;; implementation. Moreover, in some implementations it may not make any
;;; sense to customize some of this code.
;;;
;;; But, experience suggests that MOST Common Lisp implementors will want
;;; to customize some of the code in this file to make PCL run better in
;;; their implementation. The code in this file has been separated and
;;; heavily commented to make that easier.
;;;
;;; Implementation-specific version of this file already exist for:
;;;
;;; Symbolics 3600 family 3600-low.lisp
;;; Lucid Lisp lucid-low.lisp
;;; Xerox 1100 family xerox-low.lisp
;;; ExCL (Franz) excl-low.lisp
;;; Kyoto Common Lisp kcl-low.lisp
;;; Vaxlisp vaxl-low.lisp
;;; CMU Lisp cmu-low.lisp
;;; H.P. Common Lisp hp-low.lisp
;;; Golden Common Lisp gold-low.lisp
;;; Ti Explorer ti-low.lisp
;;;
;;;
;;; These implementation-specific files are loaded after this file. Because
;;; none of the macros defined by this file are used in functions defined by
;;; this file the implementation-specific files can just contain the parts of
;;; this file they want to change. They don't have to copy this whole file
;;; and then change the parts they want.
;;;
;;; If you make changes or improvements to these files, or if you need some
;;; low-level part of PCL re-modularized to make it more portable to your
;;; system please send mail to CommonLoops.pa@Xerox.com.
;;;
;;; Thanks.
;;;
(in-package 'pcl)
;;
;;;;;; without-interrupts
;;
;;; OK, Common Lisp doesn't have this and for good reason. But For all of
;;; the Common Lisp's that PCL runs on today, there is a meaningful way to
;;; implement this. WHAT I MEAN IS:
;;;
;;; I want the body to be evaluated in such a way that no other code that is
;;; running PCL can be run during that evaluation. I agree that the body
;;; won't take *long* to evaluate. That is to say that I will only use
;;; without interrupts around small computations.
;;;
;;; OK?
;;;
(defmacro without-interrupts (&body body)
`(progn ,.body))
;;
;;;;;; Load Time Eval
;;
;;;
;;; #, is woefully inadequate. You can't use it inside of a macro and have
;;; the expansion of part of the macro be evaluated at load-time.
;;;
;;; load-time-eval is used to provide an interface to implementation
;;; dependent implementation of load time evaluation.
;;;
;;; A compiled call to load-time-eval:
;;; should evaluated the form at load time,
;;; but if it is being compiled-to-core evaluate it at compile time
;;; Interpreted calls to load-time-eval:
;;; should just evaluate form at run-time.
;;;
;;; The portable implementation just evaluates it every time, and PCL knows
;;; this. PCL is careful to only use load-time-eval in places where (except
;;; for performance penalty) it is OK to evaluate the form every time.
;;;
(defmacro load-time-eval (form)
`(progn ,form))
;;
;;;;;; Memory Blocks (array-like blocks of memory)
;;
;;; The portable implementation of memory-blocks is as arrays.
;;;
;;; The area argument to make-memory-block is based on the area feature of
;;; LispM's. As it is used in PCL that argument will always be an unquoted
;;; symbol. So a call to make-memory-block will look like:
;;; (make-memory-block 100 class-wrapper-area)
;;; This allows any particular implementation of make-memory-block to look at
;;; the symbol at compile time (macroexpand time) and know where the memory-
;;; block should be consed. Currently the only values ever used as the area
;;; argument are:
;;;
;;; CLASS-WRAPPER-AREA used when making a class-wrapper
;;;
;;; NOTE:
;;; It is perfectly legitimate for an implementation of make-memory-block
;;; to ignore the area argument. It only exists to try to improve paging
;;; performance in systems which do allow control over where memory is
;;; allocated.
;;;
(defmacro make-memory-block (size &optional area)
(declare (ignore area))
`(make-array ,size :initial-element nil))
(defmacro memory-block-size (block)
`(array-dimension ,block 0))
(defmacro memory-block-ref (block offset)
`(locally
(declare (optimize (speed 3) (safety 0))
(inline svref))
(svref (the simple-vector ,block) (the fixnum ,offset))))
(defsetf memory-block-ref (block offset) (new-value)
`(locally
(declare (optimize (speed 3) (safety 0)))
(setf (svref (the simple-vector ,block) (the fixnum ,offset))
,new-value)))
(eval-when (compile load eval)
(defun make-memory-block-mask (size &optional (words-per-entry 2))
(let ((offset-mask 1)
(entry-mask 1))
(loop (when (>= offset-mask size) (return))
(setq offset-mask (* offset-mask 2)))
(loop (when (>= entry-mask words-per-entry) (return))
(setq entry-mask (* entry-mask 2)))
(logxor (1- offset-mask)
(1- entry-mask))))
)
;;;
;;; clear-memory-block sets all the slots of a memory block to nil starting
;;; at start. This really shouldn't be a macro, it should be a function.
;;; It has to be a macro because otherwise its call to memory-block-ref will
;;; get compiled before people get a chance to change memory-block-ref.
;;; This argues one of:
;;; - this should be a function in another file. No, it belongs here.
;;; - Common Lisp should have defsubst. Probably
;;; - Implementors should take (proclaim '(inline xxx)) more seriously.
;;;
(defmacro clear-memory-block (block start &optional times)
(once-only (block)
`(do ((end ,(if times `(+ ,start ,times) `(length ,block)))
(index ,start (+ index 1)))
((= index end))
(setf (memory-block-ref ,block index) nil))))
;;
;;;;;; CLASS-OF
;;
;;;
;;; *class-of* is the lisp code for the definition of class-of.
;;;
;;; This version uses type-of to determine the class of an object. Because
;;; of the underspecification of type-of, this does not always produce the
;;; "most specific class of which x is an instance". But it is the best I
;;; can do portably.
;;;
;;; Specific ports of PCL should feel free to redefine *class-of* to provide
;;; a more accurate definition. At some point in any definition of class-of
;;; there should be a test to determine if the argument is a %instance, and
;;; if so the %instance-class-of macro should be used to determine the class
;;; of the instance.
;;;
;;; Whenever a new meta-class is defined, the portable code will take care of
;;; modifying the definition of %instance-class-of and recompiling class-of.
;;;
(defvar *class-of*
'(lambda (x)
(or (and (iwmc-class-p x)
(class-wrapper-class (iwmc-class-class-wrapper x)))
(and (funcallable-instance-p x)
(funcallable-instance-class x))
(and (%instancep x)
(%instance-class-of x))
(built-in-class-of x)
(error "Can't determine class of ~S" x))))
(defmacro class-of-1 (x)
(once-only (x)
`(or (and (iwmc-class-p ,x)
(class-wrapper-class (iwmc-class-class-wrapper ,x)))
(and (funcallable-instance-p ,x)
(funcallable-instance-class ,x))
(class-of ,x))))
(defvar *meta-classes* ())
(defmacro %instance-class-of (arg)
`(cond ,@(iterate ((mc in *meta-classes*))
(collect
`((eq (%instance-meta-class ,arg)
(load-time-eval (class-named ',(car mc))))
(funcall (function ,(cdr mc)) ,arg))))
(t
(error
"Internal error in %INSTANCE-CLASS-OF. The argument to~%~
%instance-class-of is a %instance, but its meta-class is~%~
not one of the meta-classes defined with define-meta-class."
(%instance-meta-class ,arg)))))
(defmacro define-meta-class (name class-of-function &rest options)
(declare (ignore options))
(check-type name symbol "a symbol which is the name of a meta-class")
(check-type class-of-function function "a function")
`(progn (define-meta-class-1 ',name ',class-of-function)
(precompile-class-of ,name ,class-of-function)))
(defun define-meta-class-1 (name class-of-function)
(or (eq name 'standard-class)
(class-named name t)
(error "In define-meta-class, there is no class named ~S.~%~
The class ~S must be defined before evaluating this~%~
define-meta-class form."))
(let ((existing (assq name *meta-classes*)))
(if existing
(setf (cdr existing) class-of-function)
(setq *meta-classes* (nconc *meta-classes*
(list (cons name class-of-function)))))))
(defvar *precompiled-meta-classes* ())
(defmacro precompile-class-of (&optional name class-of-function)
(let ((*meta-classes* *meta-classes*))
(when name (define-meta-class-1 name class-of-function))
`(progn (setq *precompiled-meta-classes* ',*meta-classes*)
(defun class-of (x) (,*class-of* x))
(recompile-class-of))))
(defun recompile-class-of (&optional forcep)
;; Check to see if the pre-compiled definition of class-of matches
;; the current value of *meta-classes*. If it does, do nothing.
;; If it doesn't or forcep is not nill, recompile class of from
;; scratch.
(when (or (not (null forcep))
(not (equal *precompiled-meta-classes* *meta-classes*))
(not (fboundp 'class-of))
(not (compiled-function-p (symbol-function 'class-of))))
(setf (symbol-function 'class-of)
#'(lambda (x)
(declare (notinline class-of))
;; Now recompile class-of so that the new definition
;; of %instance-class-of will take effect.
(compile 'class-of *class-of*)
(class-of x)))))
;;
;;;;;; TYPEP and TYPE-OF support.
;;
;;; Portable CommonLoops makes no changes to typep or type-of. In order for
;;; those functions to work with CommonLoops objects each implementation will
;;; have to fix its typep and type-of. It shouldn't be hard though, and
;;; these macros should help.
;(defmacro %instance-typep (x type)
; `(not (null (memq (class-named ,type ())
; (class-class-precedence-list (class-of ,x))))))
;
;(defmacro %instance-type-of (x)
; `(class-name (class-of ,x)))
;;
;;;;;; The primitive instances.
;;
;;;
;;; This is used by define-meta-class and friends to provide the meta-instance
;;; structure used for user-defined meta-classes.
;;;
;;; Conceptually, a %instance is an array-like datatype whose first element
;;; points to the meta-class of the %instance and whose remaining elements
;;; are used by the meta-class for whatever purpose it wants.
;;;
;;; What would like to do is use defstruct to define a new type with a
;;; variable number of slots. Unfortunately, Common Lisp itself does not
;;; let us do that. So we have to define a new type %instance, and have
;;; it point to an array which is the extra slots.
;;;
;;; Most any port of PCL should re-implement this datatype. Implementing it
;;; as a variable length type so that %instance are only one vector in memory
;;; (the "extra slots" are in-line with the meta-class) will have significant
;;; impact on the speed of many CommonLoops programs. As an example of how
;;; to do this re-implementation of %instance, please see the file 3600-low.
;;;
(defstruct (%instance (:print-function print-instance)
(:constructor %allocate-instance-1 (meta-class storage))
(:predicate %instancep))
meta-class
storage)
(defmacro %allocate-instance (meta-class size)
`(%allocate-instance-1 ,meta-class (make-array ,size)))
(defmacro %instance-ref (instance index)
`(aref (%instance-storage ,instance) ,index))
;;
;;;;;; Very Low-Level representation of instances with meta-class class.
;;
;;; As shown below, an instance with meta-class class (iwmc-class) is a three
;;; *slot* structure.
;;;
;;;
;;; /------["Class"]
;;; /-------["Class Wrapper" / <slot-and-method-cache>]
;;; /
;;; Instance--> [ / , \ , \ ]
;;; \ \
;;; \ \---[Instance Slot Storage Block]
;;; \
;;; \-------[Dynamic Slot plist]
;;;
;;; Instances with meta-class class point to their class indirectly through
;;; the class's class wrapper (each class has one class wrapper, not each
;;; instance). This is done so that all the extant instances of a class can
;;; have the class they point to changed quickly. See change-class.
;;;
;;; Static-slots are a 1-d-array-like structure.
;;; The default PCL implementation is as a memory block as described above.
;;; Particular ports are free to change this to a lower-level block of memory
;;; type structure. Once again, the accessor for static-slots storage doesn't
;;; need to do bounds checking, and static-slots structures don't need to be
;;; able to change size. This is because new slots are added using the
;;; dynamic slot mechanism, and if the class changes or the class of the
;;; instance changes a new static-slot structure is allocated (if needed).
;;
;;; Dynamic-slots are a plist-like structure.
;;; The default PCL implementation is as a plist.
;;;
;;; *** Put a real discussion here of where things should be consed.
;;; - if all the class wrappers in the world are on the same page that
;;; would be good because during method lookup we only use the wrappers
;;; not the classes and once a slot is cached, we only use the wrappers
;;; too. So a page of just wrappers would stay around all the time and
;;; you would never have to page in the classes at least in "tight" loops.
;;;
(defstruct (iwmc-class (:predicate iwmc-class-p)
(:conc-name %iwmc-class-)
(:constructor %%allocate-instance--class ())
(:print-function print-instance))
(class-wrapper nil)
(static-slots nil)
(dynamic-slots ()))
(defmacro iwmc-class-class-wrapper (x) `(%iwmc-class-class-wrapper ,x))
(defmacro iwmc-class-static-slots (x) `(%iwmc-class-static-slots ,x))
(defmacro iwmc-class-dynamic-slots (x) `(%iwmc-class-dynamic-slots ,x))
(defun print-instance (instance stream depth) ;This is a temporary definition
(declare (ignore depth)) ;used mostly for debugging the
(printing-random-thing (instance stream) ;bootstrapping code.
(format stream "instance ??")))
(defmacro %allocate-instance--class (no-of-slots)
`(let ((iwmc-class (%%allocate-instance--class)))
(%allocate-instance--class-1 ,no-of-slots iwmc-class)
iwmc-class))
(defmacro %allocate-instance--class-1 (no-of-slots instance)
(once-only (instance)
`(progn
(setf (iwmc-class-static-slots ,instance)
(%allocate-static-slot-storage--class ,no-of-slots))
(setf (iwmc-class-dynamic-slots ,instance)
(%allocate-dynamic-slot-storage--class)))))
(defmacro %convert-slotd-position-to-slot-index (slotd-position)
slotd-position)
(defmacro %allocate-static-slot-storage--class (no-of-slots)
`(make-memory-block ,no-of-slots))
(defmacro %static-slot-storage-slot-value--class (static-slot-storage
slot-index)
`(memory-block-ref ,static-slot-storage ,slot-index))
(defmacro %allocate-dynamic-slot-storage--class ()
())
(defmacro %dynamic-slot-storage-slot-value--class (dynamic-slot-storage
name
default)
`(getf ,dynamic-slot-storage ,name ,default))
(defmacro %dynamic-slot-storage-remove-slot--class (dynamic-slot-storage
name)
`(remf ,dynamic-slot-storage ,name))
(defmacro class-of--class (iwmc-class)
`(class-wrapper-class (iwmc-class-class-wrapper ,iwmc-class)))
;;
;;;;;; Class Wrappers (the Watercourse Way algorithm)
;;
;;; Well, we had this really cool scheme for keeping multiple different
;;; caches tables in the same block of memory. Unfortunately, we only
;;; cache one thing in class wrappers these days, and soon class wrappers
;;; will go away entirely so its kind of lost generality. I am leaving
;;; the old comment here cause the hack is worth remembering.
;;;
;;; * Old Comment
;;; * The key point are:
;;; *
;;; * - No value in the cache can be a key for anything else stored
;;; * in the cache.
;;; *
;;; * - When we invalidate a wrapper cache, we flush it so that when
;;; * it is next touched it will get a miss.
;;; *
;;; * A class wrapper is a block of memory whose first two slots have a
;;; * deadicated (I just can't help myself) purpose and whose remaining
;;; * slots are the shared cache table. A class wrapper looks like:
;;; *
;;; * slot 0: <pointer to class>
;;; * slot 1: T if wrapper is valid, NIL otherwise.
;;; * .
;;; * . shared cache
;;; * .
;;;
(eval-when (compile load eval)
(defconstant class-wrapper-cache-size 32
"The size of class-wrapper caches.")
(defconstant class-wrapper-leader 2
"The number of slots at the beginning of a class wrapper which have a
special purpose. These are the slots that are not part of the cache.")
(defconstant class-wrapper-cache-mask
(make-memory-block-mask class-wrapper-cache-size 2))
)
(defmacro make-class-wrapper (class)
`(let ((wrapper (make-memory-block ,(+ class-wrapper-cache-size
class-wrapper-leader)
class-wrapper-area)))
(setf (class-wrapper-class wrapper) ,class)
(setf (class-wrapper-valid-p wrapper) t)
wrapper))
(defmacro class-wrapper-class (class-wrapper)
`(memory-block-ref ,class-wrapper 0))
(defmacro class-wrapper-valid-p (class-wrapper)
`(memory-block-ref ,class-wrapper 1))
(defmacro class-wrapper-cached-key (class-wrapper offset)
`(memory-block-ref ,class-wrapper ,offset))
(defmacro class-wrapper-cached-val (class-wrapper offset)
`(memory-block-ref ,class-wrapper (+ ,offset 1)))
(defmacro class-wrapper-slot-value-offset (class-wrapper slot-name)
(declare (ignore class-wrapper))
`(+ class-wrapper-leader
(symbol-cache-no ,slot-name ,class-wrapper-cache-mask)))
(defmacro flush-class-wrapper-cache (class-wrapper)
`(clear-memory-block ,class-wrapper
,class-wrapper-leader
,class-wrapper-cache-size))
(defmacro class-wrapper-cache-cache-entry (wrapper offset key val)
(once-only (wrapper offset key val)
`(without-interrupts
(setf (class-wrapper-cached-key ,wrapper ,offset) ,key) ;store key
(setf (class-wrapper-cached-val ,wrapper ,offset) ,val))));store value
(defmacro class-wrapper-cache-cached-entry (wrapper offset key)
(once-only (wrapper offset)
`(and (eq (class-wrapper-cached-key ,wrapper ,offset) ,key)
(class-wrapper-cached-val ,wrapper ,offset))))
(defmacro invalidate-class-wrapper (wrapper)
(once-only (wrapper)
`(progn (flush-class-wrapper-cache ,wrapper)
(setf (class-wrapper-valid-p ,wrapper) nil))))
(defmacro validate-class-wrapper (iwmc-class) ;HAS to be a macro!
`(let ((wrapper (iwmc-class-class-wrapper ,iwmc-class)));So that xxx-low
(if (class-wrapper-valid-p wrapper) ;can redefine the
wrapper ;macros we use.
(progn (setf (iwmc-class-class-wrapper ,iwmc-class)
(class-wrapper (class-wrapper-class wrapper)))
(setf (class-wrapper-valid-p wrapper) t)))))
;;
;;;;;; Generating CACHE numbers
;;
;;; These macros should produce a CACHE number for their first argument
;;; masked to fit in their second argument. A useful cache number is just
;;; the symbol or object's memory address. The memory address can either
;;; be masked to fit the mask or folded down with xor to fit in the mask.
;;; See some of the other low files for examples of how to implement these
;;; macros. Except for their illustrative value, the portable versions of
;;; these macros are nearly worthless. Any port of CommonLoops really
;;; should redefine these to be faster and produce more useful numbers.
(defvar *warned-about-symbol-cache-no* nil)
(defvar *warned-about-object-cache-no* nil)
(defmacro symbol-cache-no (symbol mask)
(unless *warned-about-symbol-cache-no*
(setq *warned-about-symbol-cache-no* t)
(warn
"Compiling PCL without having defined an implementation-specific~%~
version of SYMBOL-CACHE-NO. This is likely to have a significant~%~
effect on slot-access performance.~%~
See the definition of symbol-cache-no in the file low to get an~%~
idea of how to implement symbol-cache-no."))
`(logand (sxhash ,symbol) ,mask))
(defmacro object-cache-no (object mask)
(declare (ignore object))
(unless *warned-about-object-cache-no*
(setq *warned-about-object-cache-no* t)
(warn
"Compiling PCL without having defined an implementation-specific~%~
version of OBJECT-CACHE-NO. This effectively disables method.~%~
lookup caching. See the definition of object-cache-no in the file~%~
low to get an idea of how to implement object-cache-no."))
`(logand 0 ,mask))
;;
;;;;;; FUNCTION-ARGLIST
;;
;;; Given something which is functionp, function-arglist should return the
;;; argument list for it. PCL does not count on having this available, but
;;; MAKE-SPECIALIZABLE works much better if it is available. Versions of
;;; function-arglist for each specific port of pcl should be put in the
;;; appropriate xxx-low file. This is what it should look like:
;(defun function-arglist (function)
; (<system-dependent-arglist-function> function))
(defun function-pretty-arglist (function)
(declare (ignore function))
())
(defsetf function-pretty-arglist set-function-pretty-arglist)
(defun set-function-pretty-arglist (function new-value)
(declare (ignore function))
new-value)
;;;
;;; set-function-name
;;; When given a function should give this function the name <new-name>.
;;; Note that <new-name> is sometimes a list. Some lisps get the upset
;;; in the tummy when they start thinking about functions which have
;;; lists as names. To deal with that there is set-function-name-intern
;;; which takes a list spec for a function name and turns it into a symbol
;;; if need be.
;;;
;;; When given a funcallable instance, set-function-name MUST side-effect
;;; that FIN to give it the name. When given any other kind of function
;;; set-function-name is allowed to return new function which is the 'same'
;;; except that it has the name.
;;;
;;; In all cases, set-function-name must return the new (or same) function.
;;;
(defun set-function-name (function new-name)
(declare (notinline set-function-name-1 intern-function-name))
(set-function-name-1 function
(intern-function-name new-name)
new-name))
(defun set-function-name-1 (function new-name uninterned-name)
(declare (ignore new-name uninterned)) function)
(defun intern-function-name (name)
#+Symbolics name
#-Symbolics (cond ((symbolp name) name)
((listp name)
(intern (format nil "~S" name)
(if (eq (car name) 'method)
(symbol-package (if (listp (cadr name))
(cadr (cadr name))
(cadr name)))
*package*)))))
;;
;;;;;; Templated functions
;;
;;; In CommonLoops there are many program-generated functions which
;;; differ from other, similar program-generated functions only in the
;;; values of certain in-line constants.
;;;
;;; A prototypical example is the family of discriminating functions used by
;;; classical generic functions. For all classical generic-functions which
;;; have the same number of required arguments and no &rest argument, the
;;; discriminating function is the same, except for the value of the
;;; "in-line" constants (the cache and generic-function).
;;;
;;; Naively, whenever we want one of these functions we have to produce and
;;; compile separate lambda. But this is very expensive, instead what we
;;; would like to do is copy the existing compiled code and replace the
;;; values of the inline constants with the right new values.
;;;
;;; Templated functions provide a nice interface to this abstraction of
;;; copying an existing compiled function and replacing certain constants
;;; with others. Templated functions are based on the assumption that for
;;; any given CommonLisp one of the following is true:
;;; Either:
;;; Funcalling a lexical closure is fast, and lexical variable access
;;; is as fast (or about as fast) in-line constant access. In this
;;; case we implement templated functions as lexical closures closed
;;; over the constants we want to change from one instance of the
;;; templated function to another.
;;; Or:
;;; Code can be written to take a compiled code object, copy it and
;;; replace references to certain in-line constants with references
;;; to other in-line constants.
;;;
;;; Actually, I believe that for most Lisp both of the above assumptions are
;;; true. For certain lisps the explicit copy and replace scheme *may be*
;;; more efficient but the lexical closure scheme is completely portable and
;;; is likely to be more efficient since the lexical closure it returns are
;;; likely to share compiled code objects and only have separate lexical
;;; environments.
;;;
;;; Another thing to notice about templated functions is that they provide
;;; the modularity to support special objects which a particular
;;; implementation's low-level function-calling code might know about. As
;;; an example, when a classical discriminating function is created, the
;;; code says "make a classical discriminating function with 1 required
;;; arguments". It then uses whatever comes back from the templated function
;;; code as the the discriminating function So, a particular port can easily
;;; make this return any sort of special data structure instead of one of
;;; the lexical closures the portable implementation returns.
;;;
(defvar *templated-function-types* ())
(defmacro define-function-template (name
template-parameters
instance-parameters
&body body)
`(eval-when (compile load eval)
(pushnew ',name *templated-function-types*)
;; Get rid of all the cached constructors.
(setf (get ',name 'templated-fn-constructors) ())
;; Now define the constructor constructor.
(setf (get ',name 'templated-fn-params)
(list* ',template-parameters ',instance-parameters ',body))
(setf (get ',name 'templated-fn-constructor-constructor)
,(make-templated-function-constructor-constructor
template-parameters instance-parameters body))))
(defun reset-templated-function-types ()
(dolist (type *templated-function-types*)
(setf (get type 'templated-fn-constructors) ())))
(defun get-templated-function-constructor (name &rest template-parameters)
(setq template-parameters (copy-list template-parameters)) ;Groan.
(let ((existing (assoc template-parameters
(get name 'templated-fn-constructors)
:test #'equal)))
(if existing
(progn (setf (nth 3 existing) t) ;Mark this constructor as
;having been used.
(cadr existing)) ;And return the actual
;constructor.
(let ((new-constructor
(apply (get name 'templated-fn-constructor-constructor)
template-parameters)))
(push (list template-parameters new-constructor 'made-on-the-fly t)
(get name 'templated-fn-constructors))
new-constructor))))
(defmacro pre-make-templated-function-constructor (name
&rest template-parameters)
(setq template-parameters (copy-list template-parameters)) ;Groan.
(let* ((params #-GCLisp (get name 'templated-fn-params)
#+GCLisp (copy-tree (get name 'templated-fn-params)))
(template-params (car params))
(instance-params (cadr params))
(body (cddr params))
#+Symbolics
(dummy-fn-name (gensym))
(form
(progv template-params
template-parameters
`(let ((entry
(or (assoc ',template-parameters
(get ',name 'templated-fn-constructors)
:test #'equal)
(let ((new-entry
(list ',template-parameters () () ())))
(push new-entry
(get ',name 'templated-fn-constructors))
new-entry))))
(setf (caddr entry) 'pre-made)
(setf (cadr entry)
(function (lambda ,(eval instance-params)
,(eval (cons 'progn body)))))))))
;;
;; This one may be superfluous.
;;
#+GCLisp (setq form (copy-tree form))
#+Symbolics
`(progn (defun ,dummy-fn-name () ,form)
(,dummy-fn-name))
#-Symbolics
form))
(defun make-templated-function-constructor-constructor (template-params
instance-params
body)
(let ((cc `(function
(lambda ,template-params
(compile () (list 'lambda ,instance-params ,@body))))))
#+GCLisp (copy-tree cc)
#-GCLisp cc))
(defun record-definition (type spec &rest args)
(declare (ignore type spec args))
())