;;; -*- Package: PCL -*- (in-package 'pcl) ;;; ;;; The above must be the first non-blank line in the file. ;;; (Does case matter at all?) This is handled in Allegro CL ;;; through an object function defined for FRED windows, SET-WINDOW-PACKAGE. ;;; Only the package option is recognized by FRED. To get us into the ;;; correct package when this file is loaded, we need the (IN-PACKAGE 'PCL) ;;; above... ;;; ;;;; Quadruple comments are interpreted as subheadings (CLtL p. 348) #| Beast.lisp -- CLOS and CL fun Version X01.00 Brian Foote 30 July 1989 (Okinawa, Iowa St.) Good clean fun with CLOS and Common Lisp... Version X01.01 Brian Foote 14 February 1990 (Carthage, Iowa St.) Added the home-list function. Version X01.02 Brian Foote 24 March 1990 (Carthage, Iowa St.) Added the list-subclasses function, after getting this machine limping again... Version X01.03 Brian Foote 9 March 1991 (Carthage) Added the eval-when examples at the end... |# ;;; ;;; animal -- A rather prosaic taxonomic example class hierarchy... ;;; (defclass animal () ;; Define the slots for generic beasts here... ((species :accessor species :initarg :species :initform "An Animal") (legs :accessor legs :initarg :legs :initform 0 :type fixnum) ;; Define a slot with the :class allocation-type. This is ;; similar to a Smalltalk class variable. For fun, try giving it ;; a type. (Vishnu is the second member of the three member Hindu ;; trinity...) (creator :accessor creator :initform "Brahma" :type (string 255) :allocation :class :documentation "Shiva is the destroyer...")) ;; Use the usual metaclass. STANDARD-CLASS is the default, so ;; the line below is, in effect, a no-op... (:metaclass standard-class) ;An inline (single) comment (FRED does nothing)... ;; Give no useful information here... (:documentation "I am a generic beast...")) ;;; ;;; mammal -- Animals that give milk... ;;; (defclass mammal (animal) ((breasts :accessor breasts :initform 2 :initarg :breasts)) (:documentation "I give milk...") ;; Try out the :default-initargs feature here... (:default-initargs :species "Some sort of Mammal" :legs 2)) ;;; ;;; mouse -- A rodent... ;;; (defclass mouse (mammal) ((favorite-cheese :accessor favorite-cheese :initform "Swiss" :initarg :favorite-cheese)) (:documentation "I'm a mouse...") ;;:defaut-initargs are inherited. This is the only class option ;;that is, says Keene... (:default-initargs :species "Mouse" :legs 4) ) ;;; ;;; speak -- A generic speak function... ;;; (defgeneric speak (who) ;Takes just a dummy lambda list... (:documentation "Will the animals talk back?") (:argument-precedence-order "goes here too")) (defmethod speak ((who animal)) (format t "I'm an animal: ~A~%" who)) (defmethod speak :before ((who animal)) (format t "Before specializing on animal: ~A~%" who)) (defmethod speak :after ((who animal)) (format t "After specializing on animal: ~A~%" who)) ;;; ;;; speak mouse -- primary method (This returns the value)... ;;; (defmethod speak ((who mouse)) (format t "I am but a mouse...~%") (format t "call-next-method: ") ;;This code illustrates the use of next-method-p. If call-next-method ;;is called in a context where no next most specific method is ;;applicable, CLOS will signal an array. (Contrast this with the ;;treatment of usual-xxx in Object Lisp.) The next-method-p predicate ;;can be used to avoid such mishaps. In the event that no next method ;;is defined, we call the CL error function... (if (next-method-p) (call-next-method) (error "No next method (Should never occur...), who: ~A~%" who)) ;;Return an atypical, easy to identify result... 99) ;;; ;;; Called for side effects, doesn't affect the value. In the core framework, ;;; any values of before- or after-methods are ignored, and the generic function ;;; returns the value of the primary method. If there is no applicable ;;; primary method, an error is signaled... ;;; (defmethod speak :before ((who mouse)) (format t "Before: Eek Eek...~%")) ;;; ;;; Called for side effects, doesn't affect the value... ;;; (defmethod speak :after ((who mouse)) ;;I can't directly modify the returned value, but I can cause side effects... (format t "After: Eek Eek...~%")) ;;; ;;; :around methods use call-next-method to explicitly control ;;; the sequencing of methods. The :around methods are called ;;; from most to least specific, and then the entire "core framework" ;;; is called. Before-methods, primary-methods, and after-methods comprise ;;; CLOS's core framework. The call-next-method mechanism is also ;;; used in primary methods to invoke "shadowed" methods. Before-methods ;;; are called in most-specific to least-specific (most general) order. ;;; After-methods are called in least-specific to most-specific order. ;;; The core framework is said to employ a "declarative" approach. ;;; The call-next-method scheme is thought of as an "imperative" approach. ;;; If call-next-method is invoked with no arguments, the original arguments ;;; are used... ;;; ;;; (An additional novelty: The &aux variable...) ;;; (defmethod speak :around ((who mouse) &aux result) (format t "In mouse :around method, before call-next-method...~%") (setf result (call-next-method)) (format t "In mouse :around method, after call-next-method: ~A~%" result) result) ;;; ;;; dm -- UCI Lisp Compatable "define macro" macro...... ;;; ;;; An example of a Common Lisp macro definition... ;;; (defmacro dm (&whole body) (cons 'defmacro (cdr body))) ;;; ;;; Fun with macros... ;;; #| (defmacro inc (x) `(add-1 ,x)) ;Define in terms of another macro... (defmacro add-1 (x) `(1+ ,x)) ;Add one to x... (macroexpand '(inc 1)) ;Expand until the form is not a macro... (macroexpand-1 '(inc 1)) ;Expand exactly once... (macro-function 'inc) ;Return the macro expansion function... |# ;;;; Fun with defstruct... ;;; ;;; simple-beast -- A sample CL structure... ;;; ;;; Define simple-beast-p, make-simple-beast, and simple-beast-species, etc. ;;; The make-xxx function is called a constructor function. ;;; (typep (make-simple beast) 'simple-beast) is true. ;;; A function (a "copier function") called copy-simple-beast is defined too. ;;; "Access functions" for each component are defined. ;;; The component names are also usable as keywords in make-simple-beast. ;;; For example (setq simple (make-simple beast :species "Ocelot" ;;; :stomachs :legs 4 :weight 10.0))... ;;; (defstruct simple-beast species stomachs legs weight) ;;; ;;; beast -- A sample CL structure... ;;; (defstruct beast ;; ;; Type specifiers are described in chapter 4 of CLtL, starting ;; on page 42... ;; (species "Who cares?" :type (string 255)) ;I wonder if they use this... (stomachs 1 :type fixnum) ;fixnum is the machine one... (legs 4 :type integer) ;integer has no size limit, just as in ST80... (weight 100.0 :type float)) ;;; ;;; print-one-to-ten -- Simple do example... ;;; ;;; Print the integers from 1 to 10. ;;; To time this thing: (time (print-one-to-ten()))... ;;; ;;; The code below is tricky. 1 to 9 are printed by the do, ;;; and ten is printed by Lisp, since the result of the do is i... ;;; (defun print-one-to-ten () (do ((i 1 (1+ i))) ;Loop var(s)... ((= i 10) i) ;Termination test and the result form... ;;To make this interesting, try some declarations... (declare (optimize speed)) ; = (declare (optimize (speed 3))) (declare (fixnum i)) ;This is a small integer... ;;The actual body of the loop... (print i))) ;;; ;;; return-three-values -- A sample multiple value return... ;;; (defun return-three-values () (values 1 2 3)) ;;; ;;; return-no-value -- Return no value at all... ;;; (defun return-no-value () (values)) ;;; ;;; Multiple value examples... ;;; ;;; multiple-value-setq can be thought of as a generalized setq... ;;; #| (values 1 2 3) ;Exps to mvs... (multiple-value-setq (x y) (values 7 3)) ;Takes a list of vars, and an mv exp... (multiple-value-bind (x y) 1 2) ;Last value returned... (multiple-value-list (values 7 3)) ;Turns mvs into a list... (values-list '(1 2)) ;Turns a list into mvs.. (if (values) 'true 'false) ;No value is treated the same way as nil... (if (values t nil) 'true 'false) ;Q: Which is used? A: true (multiple-value-prog1 (values 1 2) (values 3 4) 5) ;Will return 1 2... |# ;;; ;;; funcall and apply... ;;; #| (funcall '+ 2 3 4) ;Symbol, args... (apply '+ 2 3 '(4 5 6)) ;Last is a list... (funcall #'+ 2 2) (funcall (function +) 2 2) ;function is like quote... ;;; ;;; The code below replaces the macro expansion hook with ;;; a variant of funcall of our own design... ;;; (defun my-funcall (&rest) (print "In my-funcall...") (apply (car args) (cdr args)) ) (setf *macroexpand-hook* 'my-funcall) ;;; ;;; Define a tail macro, and a setf update function that allows ;;; us to treat tail calls as generalized variables... ;;; (defmacro tail (l) `(cdr ,l)) (symbol-plist 'tail) (setf (symbol-plist 'tail) nil) ;Breaks the macro! (symbol-function 'tail) (eq (symbol-function 'tail) (get 'tail 'ccl::macrop)) ;Answer is T... (macro-function 'tail) (defsetf tail (l) (new-tail) `(progn (rplacd ,l ,new-tail) ,new-tail)) ;;; ;;; Try a very simple one... ;;; (defmacro my-quote (x) `(quote ,x)) ;;; ;;; The expansion function returned by macro-function is a function ;;; of two arguments (the macro-call form and the environment) that ;;; returns the macro expansion for the call. This macro expansion ;;; is then evaluated. Therefore: It seems as if Coral's eval checks ;;; for CCL::MACROP on a symbol's property list in order to decide ;;; whether to evaluate the arguments. Recall that macro-function IS the ;;; macrop/-p predicate in Common Lisp... ;;; (funcall (get 'my-quote 'ccl::macrop) '(my-quote :dog) nil) ;NIL okay as env... (funcall (get 'my-quote 'ccl::macrop) '(fido :dog) nil) ;CAR form ignored... (setf (symbol-plist 'my-quote) nil) (symbol-plist 'tail) ;ccl::setf-method-expander # (symbol-plist 'aref) ;ccl::setf-inverse ccl::aset ;;; ;;; After the above, the below is NIL. Evidently Coral uses the CCL::MACROP ;;; property as its storage location for the macro expansion function... ;;; (fboundp 'my-quote) ;After above this is NIL... ;;; ;;; Fun with special-form-p... ;;; (setf old (symbol-plist 'unwind-protect)) (setf (symbol-plist 'unwind-protect) nil) (setf (symbol-plist 'unwind-protect) old) (symbol-plist 'unwind-protect) (special-form-p 'unwind-protect) ;It DOES use the plist-entries... (setf (get 'dog 'ccl::special-in-evaluator) 3) (setf (get 'dog 'ccl::special-in-compiler) 4) (special-form-p 'dog) ;Returns 3 once the two props above are set!!! ;;; ;;; More fun and games... ;;; (setf (symbol-plist 'dog) nil) (defun dog (x) (print x)) (setf (get 'dog 'ccl::special-in-evaluator) #'(lambda (x) (print x))) (special-form-p 'dog) (dog x) ;It gets the entire calling form, it seems, unevaluated... ;;Print settings (:upcase :downcase) are respected by print and friends, ;;not the code for internal symbol names... (symbol-name 'dog) ;Always "DOG", no matter what the print setting... |# ;;; ;;; Symbol fun... ;;; #| ;;; ;;; CL symbols have three user visible components: a property list, ;;; a package cell, and a print name. The value and function cells ;;; are not defined as such, since different implementations handle these ;;; differently... ;;; (symbol-plist 'dog) ;setf works okay here... (symbol-name 'pcl::dog) ;No setf for this guy... (symbol-package 'dog) (symbol-value 'dog) ;Faster than eval in certain cases, they say... (symbol-function 'dog) ;can be setf... (symbol-name '#:cat) ;Create an uninterned symbol with this print name... (make-symbol "NAME") *print-case* (gensym) ;Creates an uninterned symbol. Invents a print name... (gensym "PREFIX") ;Sets a prefix (gensym 123) ;Resets the counter... |# ;;; ;;; Format examples. ~A is like princ, ~S is like prin1... ;;; #| (format nil "This is a test ~A ~S ~%" "A string" "Another string") (format t "This is a test ~A ~S ~%" "A string" "Another string") (princ "This is a test") (prin1 "This is a test") (print "This is a test") ;;; ;;; The stream args for most output functions are: ;;; nil: *standard-output* ;;; t: *terminal-io* ;;; ;;; For format, these are: ;;; nil: Return the string ;;; t: *standard-output* ;;; ;;; The standard input stream is *standard-input*... ;;; (defun print (x &optional (stream nil)) (terpri stream) (write x :stream stream :escape t)) (defun princ (x &optional (stream nil)) (write x :stream stream :escape nil)) (define prin1 (x &optional (stream nil)) (write x :stream stream :escape t)) |# ;;; ;;; Some file examples... ;;; ;;; with-open-file is good because it closes the file when its scope is exited. ;;; #| (with-open-file (out "junk" :direction :output :if-exists :supersede) (format out "~A ~A" 'foo 'bar)) ;I never did like 'foo and 'bar... (with-open-file (in "junk" :direction :input) (format t "Position: ~A~%" (file-position in)) (file-length in)) ;Why is the length 7? |# ;;; ;;; dolist example. do-list is like a Smalltalk do: over a collection... ;;; #| (dolist (item '(1 2 3) 'a-result-form) (print item)) |# ;;; ;;; dotimes example. Note that it starts with ZERO... ;;; #| (dotimes (i 10 'a-result-form) (print i) ;Prints 0 to 9...) |# ;;; ;;; Read Macro examples. The readtable is a structure used by read to ;;; drive the processing of input streams. The (current) readtable is stored ;;; in the variable *readtable*. The following are pre-registered in the ;;; readtable as macro characters: " # ' ( ) , ; `. The function associated ;;; with each of these macro characters can be fetched using get-macro-character. ;;; (The list of eight characters given above corresponds to that seen in ;;; Allegro CL's default readtable...) ;;; ;;; Macro characters. This example makes ! work the same way as '...] ;;; When a macro character is seen in the input stream, ;;; (funcall ) is called. ;;; The macro character has already been consumed from the stream. Read puts the ;;; result of the funcall into the input. If a function does not return a ;;; value, read is considered to have received no input... ;;; #| (set-macro-character #\! #'(lambda (stream char) (list 'quote (read stream)))) (defun exclaim (stream char) (list 'quote (read stream))) (set-macro-character #\! #'exclaim) (get-macro-character #\!) (get-macro-character #\)) ;;; ;;; If a do has no result form, nil is returned (not the last body value)... ;;; (defun semicolon-reader (stream char) (do ((char (read-char stream) ;Init (read-char stream))) ((char= char #\Newline) (values)) ;End test is done at start... ;Body would normally go here... )) (set-macro-character #\! #'semicolon-reader) ;;; ;;; Sharp sign macros # ;;; Can be user defined. Yuasa and Hagiya give no examples. ;;; A macro beginning with # is a sharp sign macro. # begins a ;;; dispatching macro. Each can have a number of subchars. A dispatching ;;; macro is set up with (make-dispatch-macro-char char). ;;; #o123 '#(1 2 3) ;A vector #b0101 #3r12 #4r123 #B0101 #XABCD (defun disp-test (stream subchar arg) (declare (ignore subchar arg)) ;An ignore example... (list 'dollars (read stream t nil t))) ;Something about recursive-p... (set-dispatch-macro-character #\# #\$ #'disp-test) (get-dispatch-macro-character #\# #\$ *readtable*) (get-dispatch-macro-character #\# #\^ *readtable*) (defun dollars (&rest args) args) #$1 |# ;;; ;;; Trivial property list manipulations... ;;; #| (setf (get 'dog 'legs) 4) (get 'dog 'legs) (setf (getf (symbol-plist 'dog) 'legs) 5) (getf (symbol-plist 'dog) 'legs) (remprop 'dog 'legs) (symbol-plist 'dog) |# ;;; ;;; The code below is taken from the PCL file high.lisp. It shows how ;;; one can force a class to be described as an instance. The description ;;; so yielded is quite lengthy... ;;; #| (defmethod pcl-describe #-Lispm ((object object)) #+Lispm ((object object) &optional no-complaints) #+Lispm (declare (ignore no-complaints)) (describe-instance object)) (defmethod pcl-describe #-Lispm ((class standard-class)) #+Lispm ((class standard-class) &optional no-complaints) #+Lispm (declare (ignore no-complaints)) (describe-class class)) |# ;;; ;;; How to define a setf method... ;;; #| (defmethod (setf breasts) (nv (who mouse)) (print mv) (print who)) |# ;;; ;;; The code below is from an old LOW.LISP... ;;; #| ;; ;;;;;; Very Low-Level representation of instances with meta-class class. ;; ;;; ;;; <*BF*> 3/29/90 IWMC's are called STD-INSTANCEs in Rainy Day PCL... ;;; ;;; As shown below, an instance with meta-class class (iwmc-class) is a three ;;; *slot* structure. ;;; ;;; ;;; /------["Class"] ;;; /-------["Class Wrapper" / ] ;;; / ;;; 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-iwmc-class)) (class-wrapper nil) (static-slots nil)) (defmacro iwmc-class-class-wrapper (x) `(%iwmc-class-class-wrapper ,x)) (defmacro iwmc-class-static-slots (x) `(%iwmc-class-static-slots ,x)) |# ;;; ;;; The code below is from FIN.LISP... ;;; #| ;;; ;;; For Coral Lisp ;;; #+:coral (progn (defconstant ccl::$v_istruct 22) (defvar ccl::initial-fin-slots (make-list (length funcallable-instance-data))) (defconstant ccl::fin-function 1) (defconstant ccl::fin-data (+ ccl::FIN-function 1)) (defun allocate-funcallable-instance-1 () (apply #'ccl::%gvector ccl::$v_istruct 'ccl::funcallable-instance #'(lambda (&rest ignore) (declare (ignore ignore)) (called-fin-without-function)) ccl::initial-fin-slots)) (defun funcallable-instance-p (x) (and (eq (ccl::%type-of x) 'ccl::internal-structure) (eq (ccl::%uvref x 0) 'ccl::funcallable-instance))) (defun set-funcallable-instance-function (fin new-value) (unless (funcallable-instance-p fin) (error "~S is not a funcallable-instance." fin)) (unless (functionp new-value) (error "~S is not a function." new-value)) (ccl::%uvset fin ccl::FIN-function new-value)) (defmacro funcallable-instance-data-1 (fin data-name) `(ccl::%uvref ,fin (+ (funcallable-instance-data-position ,data-name) ccl::FIN-data))) (defsetf funcallable-instance-data-1 (fin data) (new-value) `(ccl::%uvset ,fin (+ (funcallable-instance-data-position ,data) ccl::FIN-data) ,new-value)) ); End of #+:coral |# ;;; ;;; An attempt to make -> an alias for funcall. ;;; It is interesting how this turns out... ;;; (defmacro -> (var &rest args) `(apply ,var (list ,@args))) (setf cat #'car) (-> cat '(1 2 3)) (macroexpand '(-> cat '(1 2 3))) ;;; ;;; This symbol ccl::funcallable-instance seems to be essential. ;;; Substitute symbols don't seem to work. There must have been ;;; some collusion between Coral and Xerox. The only difference between ;;; this version and the Xerox version is the test- in the function name... ;;; #| (defun allocate-test-funcallable-instance-1 () (apply #'ccl::%gvector ccl::$v_istruct ;A code of some sort for %gvector... 'ccl::funcallable-instance ; (%uvref xxx 0) #'(lambda (&rest ignore) (declare (ignore ignore)) (print "test-funcallable-instance called")) ; (%uvref xxx 1) ccl::initial-fin-slots)) ; (%uvref xxx 2) |# ;;; ;;; So where does 3 come from... ;;; #| (setf t1 (allocate-test-funcallable-instance-1)) (ccl::%uvref t1 0) ;The symbol (ccl::%uvref t1 1) ;The function... (ccl::%uvref t1 2) ;The slots array... (ccl::%uvref t1 3) ;This one does not fail??? (ccl::%uvref t1 4) ;This one fails... ;;; ;;; Here's the good part. We bind the funcallable instance to the ;;; FUNCTION CELL of the given atom.... ;;; (ccl::fset 't1 t1) (t1 1 2 3) |# #| Poor man's fins... (defun dog () (print "Bow wow")) (defun cat () (print "Meow")) (setf (symbol-function 'cat) (symbol-function 'dog)) (setf (symbol-function 'cat) #'(lambda () print "lambda")) (cat) |# ;;; ;;; The eval-when low-down... ;;; ;;; compile means when the compiler is running... ;;; load means when the .fasl (or what have you file) is loaded... ;;; eval means when the text file is loaded or evaluated... ;;; (eval-when (compile) (format t "compile~%")) (eval-when (load) (format t "load~%")) (eval-when (eval) (format t "eval~%"))