From c3ad9ffd9a23e41e562ce624d44e9f40c4d0ebf5 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 6 Feb 1990 17:27:59 +0000 Subject: [PATCH] Initial revision --- code/alieneval.lisp | 1267 +++++++++++++++++++++++ code/array.lisp | 869 ++++++++++++++++ code/c-call.lisp | 935 +++++++++++++++++ code/char.lisp | 466 +++++++++ code/clx-ext.lisp | 591 +++++++++++ code/debug-info.lisp | 191 ++++ code/debug.lisp | 441 ++++++++ code/defmacro.lisp | 413 ++++++++ code/defstruct.lisp | 561 ++++++++++ code/describe.lisp | 318 ++++++ code/error.lisp | 1237 ++++++++++++++++++++++ code/eval.lisp | 366 +++++++ code/extensions.lisp | 349 +++++++ code/fdefinition.lisp | 68 ++ code/filesys.lisp | 1278 +++++++++++++++++++++++ code/foreign.lisp | 281 +++++ code/format.lisp | 1514 +++++++++++++++++++++++++++ code/gc.lisp | 604 +++++++++++ code/globals.lisp | 56 + code/hash.lisp | 429 ++++++++ code/lispinit.lisp | 1212 ++++++++++++++++++++++ code/list.lisp | 869 ++++++++++++++++ code/load.lisp | 1022 ++++++++++++++++++ code/machdef.lisp | 106 ++ code/macros.lisp | 1532 +++++++++++++++++++++++++++ code/misc.lisp | 126 +++ code/package.lisp | 1101 ++++++++++++++++++++ code/pred.lisp | 619 +++++++++++ code/print.lisp | 1267 +++++++++++++++++++++++ code/purify.lisp | 538 ++++++++++ code/rand.lisp | 128 +++ code/reader.lisp | 1302 +++++++++++++++++++++++ code/save.lisp | 114 ++ code/search-list.lisp | 154 +++ code/seq.lisp | 2281 +++++++++++++++++++++++++++++++++++++++++ code/sharpm.lisp | 456 ++++++++ code/sort.lisp | 442 ++++++++ code/stream.lisp | 1043 +++++++++++++++++++ code/string.lisp | 608 +++++++++++ code/struct.lisp | 156 +++ code/symbol.lisp | 189 ++++ code/sysmacs.lisp | 274 +++++ code/time.lisp | 404 ++++++++ code/tty-inspect.lisp | 195 ++++ tools/worldcom.lisp | 118 +++ tools/worldload.lisp | 164 +++ 46 files changed, 28654 insertions(+) create mode 100644 code/alieneval.lisp create mode 100644 code/array.lisp create mode 100644 code/c-call.lisp create mode 100644 code/char.lisp create mode 100644 code/clx-ext.lisp create mode 100644 code/debug-info.lisp create mode 100644 code/debug.lisp create mode 100644 code/defmacro.lisp create mode 100644 code/defstruct.lisp create mode 100644 code/describe.lisp create mode 100644 code/error.lisp create mode 100644 code/eval.lisp create mode 100644 code/extensions.lisp create mode 100644 code/fdefinition.lisp create mode 100644 code/filesys.lisp create mode 100644 code/foreign.lisp create mode 100644 code/format.lisp create mode 100644 code/gc.lisp create mode 100644 code/globals.lisp create mode 100644 code/hash.lisp create mode 100644 code/lispinit.lisp create mode 100644 code/list.lisp create mode 100644 code/load.lisp create mode 100644 code/machdef.lisp create mode 100644 code/macros.lisp create mode 100644 code/misc.lisp create mode 100644 code/package.lisp create mode 100644 code/pred.lisp create mode 100644 code/print.lisp create mode 100644 code/purify.lisp create mode 100644 code/rand.lisp create mode 100644 code/reader.lisp create mode 100644 code/save.lisp create mode 100644 code/search-list.lisp create mode 100644 code/seq.lisp create mode 100644 code/sharpm.lisp create mode 100644 code/sort.lisp create mode 100644 code/stream.lisp create mode 100644 code/string.lisp create mode 100644 code/struct.lisp create mode 100644 code/symbol.lisp create mode 100644 code/sysmacs.lisp create mode 100644 code/time.lisp create mode 100644 code/tty-inspect.lisp create mode 100644 tools/worldcom.lisp create mode 100644 tools/worldload.lisp diff --git a/code/alieneval.lisp b/code/alieneval.lisp new file mode 100644 index 000000000..179bc392c --- /dev/null +++ b/code/alieneval.lisp @@ -0,0 +1,1267 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains any the part of the Alien implementation that +;;; is not part of the compiler. +;;; +(in-package 'lisp) +(in-package 'system) +(export '(*alien-eval-when* make-alien alien-type alien-size alien-address + copy-alien dispose-alien defalien alien-value + alien-bind defoperator alien-index alien-indirect + bits bytes words long-words port perq-string + boolean defenumeration enumeration + system-area-pointer pointer alien alien-access + alien-assign alien-sap define-alien-stack + with-stack-alien null-terminated-string c-procedure + unstructured)) +(in-package 'lisp) + +(defun concat-pnames* (name1 name2) + (if name1 + (make-symbol (concatenate 'simple-string (symbol-name name1) + (symbol-name name2))) + name2)) + +#-new-compiler +(eval-when (compile) + (setq lisp::*bootstrap-defmacro* :both)) + +;;; The number of bits corresponding to a change of 1 in the value of a SAP. +;;; +(defconstant alien-address-unit 8) + +;;; The address pointed to by the SAP in an alien is always a multiple of this +;;; number of bits. +;;; +(defconstant alien-alignment 16) + +(defvar *alien-eval-when* '(compile load eval) + "This is a list of the times to eval Alien compiler info.") + +(defun %print-alien-value (s stream d) + (declare (ignore d)) + (let ((offset (alien-value-offset s))) + (format stream + "#<Alien value, Address = #x~X~:[+~D/8~;~*~], Size = ~D, Type = ~S>" + (%primitive sap-int (alien-value-sap s)) (zerop offset) offset + (alien-value-size s) (alien-value-type s)))) + +(defun %print-alien-info (s stream d) + (declare (ignore s d)) + (write-string "#<Alien-Info>" stream)) + + +;;;; Interpreter stubs for SAP functions: + +#+new-compiler (progn +(defun sap-int (sap) + "Converts a System Area Pointer into an integer." + (sap-int sap)) + +(defun int-sap (int) + "Converts an integer into a System Area Pointer." + (int-sap int)) + +(defun sap-ref-8 (sap offset) + "Returns the 8-bit byte at Offset bytes from SAP." + (sap-ref-8 sap offset)) + +(defun sap-ref-16 (sap offset) + "Returns the 16-bit word at Offset words from SAP." + (sap-ref-16 sap offset)) + +(defun sap-ref-32 (sap offset) + "Returns the 32-bit dualword at Offset words from SAP." + (sap-ref-32 sap offset)) + +(defun (setf sap-ref-8) (sap offset new-value) + (setf (sap-ref-8 sap offset) new-value)) + +(defun (setf sap-ref-16) (sap offset new-value) + (setf (sap-ref-16 sap offset) new-value)) + +(defun (setf sap-ref-32) (sap offset new-value) + (setf (sap-ref-32 sap offset) new-value)) + +); #+New-Compiler + + +;;;; Miscellaneous primitives: + +;;; Alien-Assign -- Public +;;; +;;; Just blt the bytes from one to the other... +;;; +(defun alien-assign (to-alien from-alien) + "Copy the data in From-Alien into To-Alien. The two alien values + must be of the same size and type." + (declare (type alien-value to-alien from-alien)) + (unless (equal (alien-value-type to-alien) (alien-value-type from-alien)) + (error "Arguments to Alien-Assign are of different types:~%~S~%~S" + to-alien from-alien)) + (let ((size (alien-value-size to-alien)) + (src-off (alien-value-offset from-alien)) + (dst-off (alien-value-offset to-alien))) + (unless (= size (alien-value-size from-alien)) + (error "Arguments to Alien-Assign are of different sizes:~%~S~%~S" + to-alien from-alien)) + (unless (zerop (logand size 7)) + (error "Size of assigned Alien is not a byte multiple:~%~S" + from-alien)) + (unless (zerop (logand src-off 7)) + (error "Alien is not byte aligned:~%~S" from-alien)) + (unless (zerop (logand dst-off 7)) + (error "Alien is not byte aligned:~%~S" to-alien)) + (let ((dst-start (ash dst-off -3))) + (%primitive byte-blt (alien-value-sap from-alien) (ash src-off -3) + (alien-value-sap to-alien) dst-start + (+ dst-start (ash size -3)))) + to-alien)) + + +;;; Alien-Type, Alien-Size, Alien-Address, Alien-SAP -- Public +;;; +;;; Return the corresponding fields out of the Alien-Value structure. +;;; Convert the address back into rational form. +;;; +(defun alien-type (alien) + "Return the type of the Alien Value." + (check-type alien alien-value) + (alien-value-type alien)) + +(defun alien-size (alien) + "Return the size in bits of the Alien." + (check-type alien alien-value) + (alien-value-size alien)) + +(defun alien-address (alien) + "Return the address of the data for Alien." + (check-type alien alien-value) + (+ (%primitive sap-int (alien-value-sap alien)) + (/ (alien-value-offset alien) alien-address-unit))) + +(defun alien-sap (alien) + "Return the system-area-pointer which corresponds to Alien. Signal an + error if the alien's address is not word-aligned." + (check-type alien alien-value) + (unless (zerop (alien-value-offset alien)) + (error "Argument to Alien-SAP is not word-aligned:~%~S" alien)) + (alien-value-sap alien)) + + +;;;; Interface macros: + +;;; Defalien -- Public +;;; +;;; Dump the right compiler info and code to create the value at +;;; load-time. +;;; +(defmacro defalien (name type size &optional (address :static)) + "defalien Name Type Size [address] + Define a global Alien variable with the specified Name, Type, Size and + Address. If Address is not supplied allocate storage to hold it." + `(progn + (eval-when (load eval) + (defparameter ,name (make-alien ',type ,size ,address))) + (eval-when ,*alien-eval-when* + (setf (info variable alien-value ',name) + (make-ct-a-val + :type ',type + :size ,size + :offset ,(if (numberp address) + (rem (* address alien-address-unit) alien-alignment) + 0) + :sap `(alien-value-sap ,',name) + :alien ',name))))) + + +;;; Define-Alien-Stack -- Public +;;; +;;; Define some variables and a function to grow the stack. Put good +;;; stuff on the property list. +;;; +(defmacro define-alien-stack (name type size) + "Define-Stack-Alien Name Type Size + Defines a new alien stack for use with the With-Stack-Alien macro. + The aliens have the specifed Type and Size, and are static." + (let ((n-head (concat-pnames name '-alien-stack-head)) + (n-current (concat-pnames name '-alien-stack)) + (grow-fun (concat-pnames name '-grow-stack))) + `(progn + (eval-when ,*alien-eval-when* + (setf (info alien-stack info ',name) + (make-stack-info :head ',n-head :current ',n-current + :grow ',grow-fun :type ',type + :size ,size))) + (defvar ,n-head ()) + (defvar ,n-current ()) + (defun ,grow-fun () + (let ((new (list (make-alien ',type ,size :static)))) + (setq ,n-head (nconc ,n-head new) ,n-current new) + (car new)))))) + + +;;; Defoperator -- Public +;;; +;;; Make the Alien-Info for the compiler and the function for the +;;; interpreter. +;;; +(defmacro defoperator ((name result-type) args body) + (do ((arg args (cdr arg)) + (argnames ()) + (arg-types ()) + (n 0 (1+ n))) + ((null arg) + `(eval-when ,*alien-eval-when* + (setf (info function alien-operator ',name) + (make-alien-info #'(lambda ,(nreverse argnames) ,body) + ,(length args) ',arg-types ',result-type)) + (setf (info function source-transform ',name) + #'c::alien=>lisp-transform) + (defun ,name (&rest dummy-arglist) + (displace-operator-definition ',name dummy-arglist)))) + (cond + ((symbolp (car arg)) + (push (car arg) argnames)) + (t + (push (cons n (cadar arg)) arg-types) + (push (caar arg) argnames))))) + +#-new-compiler +(eval-when (compile) + (setq lisp::*bootstrap-defmacro* nil)) + + +;;;; Alien allocation: + +(eval-when (compile) + (dolist (x '(system-space-start alien-allocation-end)) + (remprop x 'lisp::%constant))) + +;;; In order to improve memory locality static alien values are allocated +;;; contiguously in a pre-validated area at the beginning of system space. We +;;; keep a free pointer to the next word we can allocate. +;;; +(defparameter system-space-start + (%primitive make-immediate-type 0 %static-alien-area) + "The address of the first statically allocated alien.") + +(defparameter alien-allocation-end + (%primitive make-immediate-type #x40000 %static-alien-area) + "The end of statically allocated aliens.") + +(defvar *current-alien-free-pointer* system-space-start + "The next word in system space for static alien allocation.") + +;;; Allocate-Static-Alien -- Internal +;;; +;;; Allocate enough storage to hold the specified number of bits +;;; and return the address. +;;; +(defun allocate-static-alien (bits) + (declare (fixnum bits)) + (let* ((alien *current-alien-free-pointer*) + (bytes (logand (ash (the fixnum (+ bits 31)) -3) (lognot 3))) + (new (%primitive sap+ *current-alien-free-pointer* bytes))) + (when (%primitive pointer> new alien-allocation-end) + (error "Not enough room to allocate a ~D bit alien." bits)) + (setq *current-alien-free-pointer* new) + alien)) + + +;;; Make-Alien -- Public +;;; +;;; Create an Alien value structure, validating memory to hold the data +;;; if necessary. We convert the rational address into a word address + +;;; bit offset. +;;; +(defun make-alien (type size &optional (address :dynamic)) + "Return an Alien value of the specified Type, whose size is Size bits. + Address is the word address of the value to create, if this is not + supplied then memory is allocated to contain the data." + (case address + (:dynamic + (setq address (do-validate 0 (ash size -3) -1))) + (:static + (setq address (allocate-static-alien size))) + (t + (if (not (integerp address)) + (setq address (%primitive sap-int address))) + (check-type address (rational 0)))) + (check-type size (integer 0)) + (if (numberp address) + (multiple-value-bind (base frac) (truncate address) + (let ((offset (* frac alien-address-unit))) + (unless (integerp frac) + (error "Address ~S does not fall on a bit position." address)) + (make-alien-value (%primitive int-sap base) offset size type))) + (make-alien-value address 0 size type))) + + +;;; Copy-Alien -- Public +;;; +;;; Validate some memory and byte-blt the contents to it. Since we just move +;;; words we preserve a nonzero bit-offset when it might be desirable to +;;; eliminate it, but that is more trouble than it is worth, since non-aligned +;;; fields are probably rarely copied. +;;; +(defun copy-alien (alien) + "Copy the storage pointed to by Alien and return a new alien value that + describes it." + (check-type alien alien-value) + (let* ((offset (alien-value-offset alien)) + (length (alien-value-size alien)) + (bytes (ash (+ length offset 15) -3)) + (new (%primitive int-sap (do-validate 0 bytes -1)))) + (%primitive byte-blt (alien-value-sap alien) (ash offset -3) + new 0 bytes) + (make-alien-value new offset length (alien-value-type alien)))) + + +;;; Dispose-Alien -- Public +;;; +;;; Invalidate the memory pointed to by unless it is a statically +;;; allocated alien. +;;; +(defun dispose-alien (alien) + "Release the storage allocated for Alien." + (check-type alien alien-value) + (let ((address (alien-value-sap alien))) + (unless (not (or (%primitive pointer< address system-space-start) + (%primitive pointer> address alien-allocation-end))) + (gr-call mach:vm_deallocate *task-self* address + (logand #x-200 (ash (+ (alien-value-size alien) #xFFF) -3)))))) + + +;;;; Operator definition primitives: + +;;; Alien-Index -- Public +;;; +;;; Check that the selected field fits within the Alien, and add it +;;; in if it does. +;;; +(defun alien-index (alien offset size) + "Return a new Alien value that is Offset bits within Alien, and is + Size bits long." + (check-type alien alien-value) + (check-type offset (integer 0)) + (check-type size (integer 0)) + (when (> (+ offset size) (alien-value-size alien)) + (error "~S is too small to extract a ~A bit field at ~A." + alien size offset)) + (multiple-value-bind (words bits) + (truncate (+ offset (alien-value-offset alien)) 8) + (make-alien-value + (%primitive int-sap (+ words (%primitive sap-int (alien-value-sap alien)))) + bits + size + nil))) + +;;; Alien-Indirect -- Public +;;; +;;; Check that Alien is word-aligned and 32 bits long. If it is, grab +;;; the value. Check that the value falls within the system area. If +;;; it does then make a new Alien-Value out of it. +;;; +(defun alien-indirect (alien size) + "Return a new Alien value that points to what the value of Alien points to + which is Size bits long." + (check-type alien alien-value) + (check-type size (integer 0)) + (unless (= (alien-value-size alien) 32) + (error "~S is not thirty-two bits long." alien)) + (unless (zerop (alien-value-offset alien)) + (error "~S is not word aligned.")) + (let* ((sap (alien-value-sap alien)) + (value (logior (ash (%primitive 16bit-system-ref sap 0) 16) + (%primitive 16bit-system-ref sap 1)))) +#| + (unless (<= system-space-start value most-positive-fixnum) + (error "The value of ~S, #x~X, does not point into system space." + alien value)) +|# + (make-alien-value (%primitive int-sap value) 0 size nil))) + + +;;; Bits, Bytes, Words, Long-Words -- Public +;;; +;;; +(macrolet ((frob (name n) + `(progn + (proclaim '(inline ,name)) + (defun ,name (n) + (declare (type (integer 0 ,(truncate most-positive-fixnum n)) + n)) + (* n ,n))))) + (frob bits 1) + (frob bytes 8) + (frob words 16) + (frob long-words 32)) + + +;;;; General case versions of compiler internal functions: + +;;; %Alien-Indirect -- Internal +;;; +;;; Alien-Indirect is transformed into this. Calls can take place at +;;; run-time when the operation can't be proven safe at compile time. +;;; +(defun %alien-indirect (size sap offset exp) + (unless (eql size 32) + (error "Argument to Alien-Indirect is ~D bits, 32:~% ~S." size exp)) + (unless (zerop (logand offset #x1F)) + (error "Offset ~D to Alien-Indirect is not long-word-aligned:~% ~S." + offset exp)) + (%primitive sap-system-ref sap (ash offset -4))) + + +;;; %Aligned-SAP -- Internal +;;; +;;; Various things transform into this when the alien is declared to be +;;; aligned. In this case, we absorb the offset into the SAP, and make the +;;; bound offset 0. +;;; +(defun %aligned-sap (sap offset form) + (unless (zerop (logand offset #xF)) + (error "Offset ~S was declared to be word aligned, but isn't:~% ~S" + offset form)) + (%primitive sap+ sap (ash offset -3))) + +#+new-compiler +;;; Naturalize-Integer -- Internal +;;; +;;; Read a possibly signed integer somewhere. For the 16 and 32 bit +;;; cases we let the transform do the work, for random fields we do it +;;; by hand. +;;; +(defun naturalize-integer (signed sap offset size form) + (multiple-value-bind (q r) (truncate offset 16) + (cond + ((> size 15) + (unless (zerop r) + (error "Offset ~D for ~D bit access is not word-aligned:~% ~S" + offset size form)) + (case size + (32 + (if signed + (%primitive signed-32bit-system-ref sap (ash q 4)) + (%primitive unsigned-32bit-system-ref sap (ash q 4)))) + (16 + (if signed + (naturalize-integer t sap (ash q 4) 16 nil) + (naturalize-integer nil sap (ash q 4) 16 nil))) + (t + (error "Access of ~D bit integers is not supported." size)))) + (t + (when (> (+ size r) 16) + (error "~D bit field at ~D offset crosses a word boundry:~% ~S" + size offset form)) + (if signed + (let ((val (ldb (byte size (- 16 size r)) + (%primitive 16bit-system-ref sap q)))) + (if (logbitp val (1- size)) + (logior val (ash -1 size)) + val)) + (ldb (byte size (- 16 size r)) + (%primitive 16bit-system-ref sap q))))))) + +#+new-compiler +;;; Deport-Integer -- Internal +;;; +;;; Like Naturalize-Integer, but writes an integer. +;;; +(defun deport-integer (signed sap offset size value form) + (declare (ignore signed)) + (multiple-value-bind (q r) (truncate offset 16) + (declare (fixnum r)) + (cond + ((> size 15) + (unless (zerop r) + (error "Offset ~D for ~D bit store is not word-aligned:~% ~S" + offset size form)) + (case size + (32 + (%primitive signed-32bit-system-set sap q value)) + (16 + (%primitive 16bit-system-set sap q value)) + (t + (error "Storing of ~D bit integers is not supported:~% ~S" + size form)))) + ((= size 8) + (setq q (ash q 1)) + (when (= r 8) + (setq q (1+ q)) + (setq r 0)) + (when (/= r 0) + (error "8 bit field at ~D offset crosses a byte boundary:~% ~S" + offset form)) + (%primitive 8bit-system-set sap q value)) + ((> size 7) + (when (> (+ size r) 16) + (error "~D bit field at ~D offset crosses a word boundry:~% ~S" + size offset form)) + (%primitive 16bit-system-set sap q + (dpb value (byte size (- 16 size r)) + (%primitive 16bit-system-ref sap q)))) + (T + (multiple-value-bind (nq nr) (truncate offset 8) + (when (> (+ size nr) 8) + (error "~D bit field at ~D offset crosses a byte boundry:~% ~S" + size offset form)) + (%primitive 8bit-system-set sap nq + (dpb value (byte size (- 8 size nr)) + (%primitive 8bit-system-ref sap nq))))))) + nil) + + +;;; Naturalize and Deport Boolean -- Internal +;;; +;;; Handle the general case of boolean access. The transforms +;;; should pick off the normal cases. +;;; +#+new-compiler +(defun naturalize-boolean (sap offset size form) + (declare (notinline naturalize-integer)) + (not (zerop (naturalize-integer nil sap offset size form)))) +;;; +#+new-compiler +(defun deport-boolean (sap offset size value form) + (declare (notinline deport-integer)) + (deport-integer nil sap offset size (if value 1 0) form) + nil) + +;;; Check<=, Check= -- Internal +;;; +;;; Interpreter stubs for functions normally open-coded. Note that the +;;; compiler will constant-fold these, possibly producing an error at compile +;;; time. +;;; +(defun check<= (x y) (check<= x y)) +(defun check= (x y) + #| + (check= x y) + |# + ;### Bootstrap hack: + (unless (and (fixnump x) (>= x 0) + (fixnump y) (>= y 0) + (= x y)) + (error "Not ~S not = to ~S at compile time." x y))) + + +;;;; Utility functions used by macros and special forms: + +;;; Check-Alien-Type -- Internal +;;; +;;; Check that Alien is of the specified Alien type, and give an +;;; error if it is not. +;;; +(defun check-alien-type (alien type) + (unless (alien-value-p alien) + (error "~S is not an Alien value." alien)) + (unless (equal (alien-value-type alien) type) + (error "Wrong Alien type ~S, should have been of type ~S." + (alien-value-type alien) type)) + alien) + + +;;; Assert-Alien-Type -- Internal +;;; +;;; Make a new Alien value having the specified type. +;;; +(defun assert-alien-type (alien type) + (unless (alien-value-p alien) + (error "~S is not an Alien value." alien)) + (make-alien-value (alien-value-sap alien) + (alien-value-offset alien) + (alien-value-size alien) + type)) + + +;;; Displace-Operator-Definition -- Internal +;;; +;;; To save space and load & compile time for defoperators, we don't +;;; actually generate the function for the operator until it is called. +;;; This results in a significant space savings at the cost of +;;; always running the operator definition interpreted when called +;;; that way. +;;; +(defun displace-operator-definition (name actual-args) + (let ((info (info function alien-operator name))) + (unless info + (error "Operator ~S has no Alien-Operator-Info property.")) + (let ((num-args (alien-info-num-args info)) + (arg-types (alien-info-arg-types info))) + (do ((i 0 (1+ i)) + (args ()) + (binds ())) + ((= i num-args) + (let* ((args (nreverse args)) + (res (coerce `(lambda ,args + (alien-bind ,(nreverse binds) + (assert-alien-type + ,(apply (alien-info-function info) args) + ',(alien-info-result-type info)))) + 'function))) + (setf (symbol-function name) res) + (apply res actual-args))) + (let ((type (assoc i arg-types)) + (sym (gensym))) + (push sym args) + (if type + (push `(,sym ,sym ,(cdr type)) binds))))))) + + +;;;; Alien access method definition: +;;; +;;; We describe how to access and store at an Alien's address in +;;; a way that permits the same code to be use both for the compiler +;;; and the interpreter. What we do is have experts that ask things +;;; about the alien value and return a piece of code to do the access. +;;; +;;; +(defvar *alien-access-table* (make-hash-table :test #'eq) + "Hashtable from lisp types to Alien access functions.") +(defvar *alien-only-access-table* (make-hash-table :test #'eq) + "Hashtable from alien types to Alien access functions.") +(defvar *alien-to-lisp-types* (make-hash-table :test #'eq) + "Hashtable we use to tell whether there is a unique lisp-type + for a given alien-type.") + +(defmacro mostcar (x) + `(if (listp ,x) (car ,x) ,x)) + + +;;; %Define-Alien-Access -- Internal +;;; +(defun %define-alien-access (lisp-type atypes fun) + (dolist (type atypes) + (let ((res (gethash type *alien-to-lisp-types*))) + (cond ((not res) + (setf (gethash type *alien-to-lisp-types*) lisp-type)) + ((eq res lisp-type)) + (t + (setf (gethash type *alien-to-lisp-types*) '%conflict%)))) + + (setf (gethash type *alien-only-access-table*) fun) + (setf (gethash lisp-type *alien-access-table*) fun))) + + +;;; Get-Alien-Access-Method -- Internal +;;; +;;; Returns the alien-access method corresponding to Alien-Type and +;;; Lisp-Type or dies trying. +;;; +(defun get-alien-access-method (alien-type lisp-type) + (let* ((alien-type (mostcar alien-type)) + (lisp-type (mostcar lisp-type)) + (unique? (gethash alien-type *alien-to-lisp-types*))) + (cond + ((not unique?) + (error "Alien type ~S does not correspond to any Lisp type." alien-type)) + ((and (null lisp-type) + (not (eq unique? '%conflict%)) + (gethash alien-type *alien-only-access-table*))) + ((not (eq unique? '%conflict%)) + (gethash unique? *alien-access-table*)) + ((not lisp-type) + (error "Lisp-Type must be specified with Alien type ~S." alien-type)) + ((gethash lisp-type *alien-access-table*)) + (t + (error "~S is not a Lisp-Type known to Alien-Access." + lisp-type))))) + + +;;; Define-Alien-Access -- Internal +;;; +(defmacro define-alien-access ((lisp-type &optional (atype lisp-type) + &rest more-types) + (alien-var kind-var value-var + &optional + (source-var (gensym) source-p)) + &body body) + "Define-Alien-Access (Lisp-Type {Alien-Type}*) (Alien-Var Kind-Var Value-Var) + {form}* + + Define a new type for Alien-Access. When Alien-Access is given the specified + Lisp-Type and the alien is one of the specified Alien-Types, then body will + be evaluated to get an expression that does the the appropriate access/store. + If no Alien-Type is supplied, then the accepted Alien type is Lisp-Type. If + the type of the Alien is a list, then we use the car as the type. + + Alien-Var + Bound to the Alien type of the Alien value to access. + + Kind-Var + Bound to :read or :write, indicating whether to read or store a value. + + Value-Var + When Kind-Var is :write, this is bound to an expression to evaluate to + obtain the value to be stored. + + Source-Var + If specified, this is bound to the original Alien-Access form + (for use in error messages.) + + In order to obtain the Alien value at which the access is to be done, the + local With-Alien macro should be used: + + With-Alien (Sap-Var) (Offset-Var {Key Value}*) (Size-Var {Key Value}*) + {Form}* + This macro is for use within the body of a Define-Alien-Access. It + analyzes and verifies assertions on the alien value to be accessed. + Sap-Var, Offset-Var and Size-Var are bound to expressions for the + system-area-pointer to the value, the offset from it in bits and + the size of the Alien in bits. + + The keyword arguments for the offset and size may be used to place + constraints on the values they may assume. If the value + is Nil, that is taken to be a null constraint. The following + keys are defined: + :unit -- A integer (default 16). + Asserts that the value is a multiple of this number, and + that the value is to be divided by this number before any + other options are processed. + :constant -- An integer (default Nil). + Asserts that the value must be exactly the supplied value. + :minimum -- An integer (default Nil). + Asserts that the value may not be less than the supplied + value. + + The value of With-Alien is the value of the last form." + + (let ((n-sap (gensym)) + (n-offset (gensym)) + (n-size (gensym))) + `(%define-alien-access + ',lisp-type '(,atype ,@more-types) + #'(lambda (,n-sap ,n-offset ,n-size ,alien-var ,kind-var ,value-var + ,source-var) + ,@(unless source-p + `((declare (ignore ,source-var)))) + + (unless (memq (mostcar ,alien-var) '(,atype ,@more-types)) + (error "Wrong Alien type ~S, should have been ~S~ + ~{~#[~; or~:;,~] ~S~}." + ,alien-var ',atype ',more-types)) + + (macrolet ((with-alien ((sap) + (offset &key + ((:unit ounit) 16)) + (size &key + ((:constant sconst) nil) + ((:minimum smin) nil) + ((:unit sunit) 16)) + &body (body decls)) + (%with-alien sap offset ounit + size sconst smin sunit + ',n-sap ',n-offset ',n-size + body decls))) + ,@body))))) + + +(eval-when (compile load eval) + +(defun %with-alien (sap offset ounit size sconst smin sunit + n-sap n-offset n-size body decls) + (let ((sunit (or sunit 1)) + (ounit (or ounit 1)) + (n-scaled-offset (gensym)) + (n-scaled-size (gensym))) + `(let ((,sap ,n-sap) + (,offset ',n-scaled-offset) + (,size ',n-scaled-size)) + ,@decls + `(let ((,',n-scaled-offset (/ ,,n-offset ,,ounit)) + (,',n-scaled-size (/ ,,n-size ,,sunit))) + ,',n-scaled-size ; Ignorable... + ,@',(when sconst + `((check= ,n-scaled-size ,sconst))) + ,@',(when smin + `((check<= ,smin ,n-scaled-size))) + ,,@body)))) + +); Eval-When (Compile Load Eval) + + +;;; Alien-Access -- Public +;;; +;;; This is only called when we can't open-code because the types aren't +;;; constant (or are erroneous.) In this case, we must look up the access +;;; method at run-time, compute the access form, then eval it. +;;; +(defun alien-access (alien &optional lisp-type) + "Converts the bits described by Alien into an object of type Lisp-Type, + or dies trying." + (declare (type alien-value alien)) + (let* ((alien-type (alien-value-type alien)) + (access (get-alien-access-method alien-type lisp-type)) + (n-sap (gensym)) + (n-offset (gensym)) + (n-size (gensym))) + (eval + `(let ((,n-sap ',(alien-value-sap alien)) + (,n-offset ',(alien-value-offset alien)) + (,n-size ',(alien-value-size alien))) + ,(funcall access n-sap n-offset n-size alien-type :read nil + 'alien-access))))) + +(defsetf alien-access %set-alien-access + "Stores the representation of the value into the alien.") + +;;; %Set-Alien-Access -- Public +;;; +;;; Like Alien-Access, only we call the expert with :write and return +;;; the new value. +;;; +(defun %set-alien-access (alien lisp-type &optional (new-value nil nvp)) + (declare (type alien-value alien)) + (let* ((lisp-type (if nvp lisp-type nil)) + (new-value (if nvp new-value lisp-type)) + (alien-type (alien-value-type alien)) + (access (get-alien-access-method alien-type lisp-type)) + (n-sap (gensym)) + (n-offset (gensym)) + (n-size (gensym)) + (n-nval (gensym))) + (eval + `(let ((,n-sap ',(alien-value-sap alien)) + (,n-offset ',(alien-value-offset alien)) + (,n-size ',(alien-value-size alien)) + (,n-nval ,new-value)) + ,(funcall access n-sap n-offset n-size alien-type :write n-nval + '(setf alien-access)))) + new-value)) + + +;;;; Miscellaneous alien access methods: + +;;; Alien-Access expert for Port -- Internal +;;; +;;; Just find the place and grab or store a 32-bit port, depending +;;; on the access kind, treating ports as 32-bit signed integers. --JRG +;;; +(define-alien-access (port) (type kind value form) + ;; + ;; We want to know if the offset is constant, and the size must be two + ;; words. + (with-alien (sap) + (offset :unit nil) + (size :constant 32 + :unit nil) + (declare (ignore size)) + (if (eq kind :read) + `(naturalize-integer t ,sap ,offset 32 ',form) + `(deport-integer t ,sap ,offset 32 ,value ',form)))) + +;;; Alien-Access expert for String-Char -- Internal +;;; +;;; Kind of easy, but we need to deal with random bit positions. What we do +;;; is call Naturalize-Integer or Deport-Integer to do the access, and just do +;;; the type conversion. +;;; +(define-alien-access (string-char) (type kind value form) + (with-alien (sap) + (offset :unit nil) + (size :unit nil :minimum 8) + (if (eq kind :read) + `(code-char (naturalize-integer nil ,sap ,offset ,size ',form)) + `(deport-integer nil ,sap ,offset ,size (char-code ,value) ',form)))) + +;;; Alien-Access experts for Unsigned-Byte, Signed-Byte -- Internal +;;; +;;; Like, just call Naturalize or Deport Integer. +;;; +(define-alien-access (unsigned-byte) (type kind value form) + (with-alien (sap) + (offset :unit nil) + (size :minimum (cadr type) + :unit nil) + (if (eq kind :read) + `(naturalize-integer nil ,sap ,offset ,size ',form) + `(deport-integer nil ,sap ,offset ,size ,value ',form)))) +;;; +(define-alien-access (signed-byte) (type kind value form) + (with-alien (sap) + (offset :unit nil) + (size :minimum (cadr type) + :unit nil) + (if (eq kind :read) + `(naturalize-integer t ,sap ,offset ,size ',form) + `(deport-integer t ,sap ,offset ,size ,value ',form)))) + +#| +I didn't write this, and it is wrong, since it assumes the size is constant. +In fact, it will never be constant at this point in the new compiler. I also +don't know that it is supposed to be used for. I suspect it is a PERQ crock. + +(define-alien-access (unstructured) (type kind value) + (with-alien (sap) + (offset :unit nil) + (size :unit nil + :minimum (cadr type)) + (if (eq kind :read) + (if (<= size 32) + `(naturalize-integer nil ,sap ,offset ,size) + (if (and (= (mod offset 32) 0) (= (mod size 32) 0)) + (do ((i 32 (+ i 32)) + (form `(naturalize-integer nil ,sap ,offset 32))) + ((>= i size) form) + (setq form + `(logior (ash ,form 32) + (naturalize-integer nil ,sap + ,(+ offset i) 32)))) + (error + "Unstructured aliens of size ~D and offset ~D not supported." + size offset))) + (if (<= size 32) + `(deport-integer nil ,sap ,offset ,size ,value) + (if (and (= (mod offset 32) 0) (= (mod size 32) 0)) + (do ((i (- size 32) (- i 32)) + (shift 0 (- shift 32)) + (form ())) + ((< i 0) (nreverse form)) + (push `(deport-integer nil ,sap ,(+ offset i) 32 + (logand (ash ,value ,shift) + #xFFFFFFFF)) + form)) + (error + "Unstructured aliens of size ~D and offset ~D not supported." + size offset))))))) + +|# + +;;; Alien-Access expert for Boolean -- Internal +;;; +;;; A boolean is a single bit, represented in Lisp as T or NIL. +;;; +(define-alien-access (boolean) (type kind value form) + (with-alien (sap) + (offset :unit 1) + (size :unit 1 :minimum 1) + (if (eq kind :read) + `(naturalize-boolean ,sap ,offset ,size ',form) + `(deport-boolean ,sap ,offset ,size ,value ',form)))) + + +;;; Alien-Access expert for short-floats +;;; +(define-alien-access (short-float) (type kind value) + (with-alien (sap) + (offset) + (size :constant 2) + (declare (ignore size)) + (if (eq kind :read) + `(%primitive int-sap + (logior (ash (%primitive unsigned-32bit-system-ref ,sap ,offset) + (- clc::short-float-shift-16)) + (ash clc::short-float-4bit-type + (- 32 clc::short-float-shift-16)))) + (let ((var (gensym))) + `(let ((,var (float ,value 1.0s0))) + (setq ,var (ash (%primitive sap-int ,var) clc::short-float-shift-16)) + (%primitive signed-32bit-system-set ,sap ,offset ,var)))))) + + +;;; Alien-Access expert for long-floats +;;; +(define-alien-access (long-float) (type kind value) + (with-alien (sap) + (offset) + (size :constant 4) + (declare (ignore size)) + (if (eq kind :read) + (let ((var (gensym))) + `(let ((,var (%primitive float-long 0))) + (%primitive 16bit-system-set ,var 2 + (%primitive 16bit-system-ref ,sap ,offset)) + (%primitive 16bit-system-set ,var 3 + (%primitive 16bit-system-ref ,sap (1+ ,offset))) + (%primitive 16bit-system-set ,var 4 + (%primitive 16bit-system-ref ,sap (+ ,offset 2))) + (%primitive 16bit-system-set ,var 5 + (%primitive 16bit-system-ref ,sap (+ ,offset 3))) + ,var)) + (let ((var (gensym))) + `(let ((,var (float ,value 1.0L0))) + (%primitive 16bit-system-set ,sap ,offset + (%primitive 16bit-system-ref ,var 2)) + (%primitive 16bit-system-set ,sap (1+ ,offset) + (%primitive 16bit-system-ref ,var 3)) + (%primitive 16bit-system-set ,sap (+ ,offset 2) + (%primitive 16bit-system-ref ,var 4)) + (%primitive 16bit-system-set ,sap (+ ,offset 3) + (%primitive 16bit-system-ref ,var 5))))))) + +;;; Alien-access expert for procedure objects. These should be used +;;; with caution. +;;; +(define-alien-access (c-procedure) (type kind value) + (with-alien (sap) + (offset) + (size :constant 2) + (declare (ignore size)) + (if (eq kind :read) + `(error "It is illegal to reference a c-procedure object.") + `(%primitive set-c-procedure-pointer ,sap ,offset ,value)))) + + +;;;; Strings accesses: + +;;; Alien-Access expert for String -- Internal +;;; +;;; Read a Perq-String into a string or write a string out into +;;; a Perq-String. +;;; +(define-alien-access (simple-string perq-string) (type kind n-value) + (with-alien (n-sap) + (n-offset :unit 8) + (size :unit 8 + :minimum (1+ (cadr type))) + (declare (ignore size)) + (if (eq kind :read) + (let ((size (gensym)) + (str (gensym))) + `(let* ((,size (%primitive 8bit-system-ref ,n-sap ,n-offset)) + (,str (make-string ,size))) + (%primitive byte-blt ,n-sap (1+ ,n-offset) ,str 0 ,size) + ,str)) + (let ((len (gensym)) + (1+off (gensym))) + `(let ((,len (length (the simple-string + ,n-value))) + (,1+off (1+ ,n-offset))) + (check<= ,len ,(cadr type)) + (%primitive 8bit-system-set ,n-sap ,n-offset ,len) + (%primitive byte-blt ,n-value 0 ,n-sap ,1+off + (+ ,1+off ,len))))))) + + +;;; Alien-Access expert for null terminated string -- Internal +;;; +;;; Read a null terminated string into a string or write a string out into +;;; a null terminated string. +;;; +(define-alien-access (simple-string null-terminated-string) (type kind n-value) + (with-alien (n-sap) + (n-offset :unit 8) + (size :unit 8 + :minimum (cadr type)) + (declare (ignore size)) + (if (eq kind :read) + (let ((size (gensym)) + (str (gensym))) + `(let* ((,size (the fixnum + (- (the fixnum + (%primitive find-character + ,n-sap ,n-offset + most-positive-fixnum 0)) + (the fixnum ,n-offset)))) + (,str (make-string ,size))) + (%primitive byte-blt ,n-sap ,n-offset ,str 0 ,size) + ,str)) + (let ((len (gensym)) + (end (gensym))) + `(let* ((,len (the fixnum (1+ (length (the simple-string + ,n-value))))) + (,end (the fixnum (+ (the fixnum ,len) ,n-offset)))) + (declare (fixnum ,len ,end)) + (check<= ,len ,(cadr type)) + (%primitive byte-blt ,n-value 0 ,n-sap ,n-offset ,end) + (%primitive 8bit-system-set ,n-sap + (the fixnum (1+ ,end)) 0)))))) + + +;;;; Pointer alien access: + +;;; Alien-Access expert for System-Area-Pointer -- Internal +;;; +;;; Get or store a pointer. In the store case this is the same +;;; as Pointer. +;;; +(define-alien-access (system-area-pointer system-area-pointer alien) + (type kind value) + (with-alien (sap) + (offset) + (size :constant 2) + (declare (ignore size)) + (if (eq kind :read) + `(%primitive sap-system-ref ,sap ,offset) + `(%primitive pointer-system-set ,sap ,offset ,value)))) + +;;; Alien-Access expert for (Alien <type> [<bits>]) -- Internal +;;; +;;; Get or store an alien value. On read, we cons up a value, getting +;;; the size of out the type. On write, we just store the SAP. +;;; +(define-alien-access (alien) (type kind value) + (with-alien (sap) + (offset) + (size :constant 2) + (declare (ignore size)) + (unless (and (consp type) (consp (cdr type))) + (error "Bad type for accessing as an Alien: ~S" type)) + (let ((atype (second type)) + (size (third type))) + (cond + ((eq kind :read) + (unless size + (error "Size not specified when reading alien type: ~S" type)) + (unless (and (integerp size) (>= size 0)) + (error "Size is not a positive integer: ~S" type)) + `(make-alien-value + (%primitive sap-system-ref ,sap ,offset) + 0 + ,size + ',atype)) + (t + `(%primitive pointer-system-set ,sap ,offset + (alien-value-sap ,value))))))) + +;;; Alien-Access expert for (Pointer xxx) -- Internal +;;; +;;; We can't read pointers, and can only store pointers to unboxed +;;; things. +;;; +(define-alien-access (pointer pointer alien) (type kind value) + (with-alien (sap) + (offset) + (size :constant 2) + (declare (ignore size)) + (when (eq kind :read) + (error "Cannot read with Pointer Alien type:~%~S" type)) + `(%primitive pointer-system-set ,sap ,offset ,value))) + + +;;;; Enumeration Alien access: + +(compiler-let ((lisp::*bootstrap-defmacro* t)) + +;;; Defenumeration -- Public +;;; +;;; Cons up the from alist, keeping track of the minimum and maximum +;;; values, then decide whether to use a vector or alist to mapping. +;;; +(defmacro defenumeration (name &rest elements) + "Defenumeration Name {{Element}+ | {(Element Value)}+} + Define an enumeration for use with Alien-Access and the Enumeration + Alien type." + (let ((min nil) + (max nil) + (from-alist ())) + (declare (list from-alist)) + (when (null elements) + (error "An anumeration must contain at least one element.")) + (if (listp (car elements)) + (dolist (el elements) + (unless (listp el) + (error "Element value is not specified: ~S." el)) + (push (cons (first el) (second el)) from-alist)) + (let ((num -1)) + (dolist (el elements) + (push (cons el (incf num)) from-alist)))) + (do ((el from-alist (cdr el))) + ((null el)) + (let ((sym (caar el)) + (val (cdar el))) + (unless (keywordp sym) + (error "Enumeration element ~S is not a keyword." sym)) + (unless (integerp val) + (error "Element value ~S is not an integer." val)) + (unless (and max (> max val)) (setq max val)) + (unless (and min (< min val)) (setq min val)) + (when (rassoc val (cdr el)) + (error "Element value ~S used more than once." val)) + (when (assq sym (cdr el)) + (error "Enumeration element ~S used more than once." sym)))) + (let* ((signed (minusp min)) + (to (intern (concatenate 'simple-string (string name) + "-TO-ENUMERATION-" (string (gensym))))) + (from (intern (concatenate 'simple-string (string name) + "-FROM-ENUMERATION-" (string (gensym))))) + (info (make-enumeration-info :signed signed + :size (if signed + (1+ (max (integer-length min) + (integer-length max))) + (integer-length max)) + :from from :to to)) + to-thing) + (cond + ;; + ;; If range is at least 20% dense, use vector mapping. Crossover + ;; point solely on basis of space would be 25%. Vector mapping + ;; is always faster, so give the benefit of the doubt. + ((< 0.2 (/ (float (length from-alist)) (float (- max min)))) + ;; + ;; If offset is small and ignorable, ignore it to save time. + (when (< 0 min 10) (setq min 0)) + (setq to-thing (make-array (1+ (- max min)))) + (dolist (el from-alist) + (setf (svref to-thing (- (cdr el) min)) (car el))) + (setf (enumeration-info-kind info) :vector) + (setf (enumeration-info-offset info) (- min))) + (t + (setf (enumeration-info-kind info) :alist) + (setq to-thing (mapcar #'(lambda (x) (cons (cdr x) (car x))) from-alist)))) + `(progn + (eval-when (compile load eval) + (proclaim '(special ,to ,from)) + (set ',to ',to-thing) + (set ',from ',from-alist)) + (eval-when ,*alien-eval-when* + (setf (info enumeration info ',name) ',info)) + ',name)))) + +); compiler-let + +;;; Enumeration-Error -- Internal +;;; +;;; Tell the luser what permissable values the enumeration has when she +;;; gives us something bogus. We even give them a chance to specify +;;; something else. +;;; +(defun enumeration-error (alist) + (loop + (cerror "Prompt for a new value." + "Enumeration value is not one of the following: ~{~<~% ~:;~S ~>~}" + (mapcar #'car alist)) + (write-string "New value: " *query-io*) + (let* ((response (read *query-io*)) + (res (cdr (assq response alist)))) + (when res (return res))))) + + +(define-alien-access (enumeration) (type kind value form) + (let* ((enum (cadr type)) + (info (or (info enumeration info enum) + (error "~S is not a defined enumeration." enum))) + (signed (enumeration-info-signed info)) + (to (enumeration-info-to info)) + (from (enumeration-info-from info))) + (with-alien (sap) + (offset :unit nil) + (size :unit nil + :minimum (enumeration-info-size info)) + (if (eq kind :read) + (ecase (enumeration-info-kind info) + (:vector + `(svref ,to + (+ ,(enumeration-info-offset info) + (naturalize-integer ,signed ,sap ,offset ,size + ',form)))) + (:alist + `(cdr (assoc (naturalize-integer ,signed ,sap ,offset ,size + ',form) + ,to)))) + `(deport-integer + ,signed ,sap ,offset ,size + (or (cdr (assq ,value ,from)) + (enumeration-error ,from)) + ',form))))) + diff --git a/code/array.lisp b/code/array.lisp new file mode 100644 index 000000000..3ee656af4 --- /dev/null +++ b/code/array.lisp @@ -0,0 +1,869 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Functions to implement arrays for Spice Lisp +;;; Written by Skef Wholey. +;;; +(in-package "LISP") + +(export '(array-rank-limit array-dimension-limit array-total-size-limit + make-array vector aref array-element-type array-rank + array-dimension array-dimensions array-in-bounds-p + array-row-major-index array-total-size svref bit sbit + bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2 + bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p + fill-pointer vector-push vector-push-extend vector-pop adjust-array + adjustable-array-p row-major-aref)) + +(defconstant array-rank-limit 65529 + "The exclusive upper bound on the rank of an array.") + +(defconstant array-dimension-limit most-positive-fixnum + "The exclusive upper bound any given dimension of an array.") + +(defconstant array-total-size-limit most-positive-fixnum + "The exclusive upper bound on the total number of elements in an array.") + + +;;; Random function used by WITH-ARRAY-DATA, which has to be defined in +;;; init.lisp. +;;; +(defun find-data-vector (array) + (do ((data array (%primitive header-ref data %array-data-slot)) + (cumulative-offset 0 + (the fixnum + (+ cumulative-offset + (the fixnum + (or (%primitive header-ref data + %array-displacement-slot) + 0)))))) + ((not (array-header-p data)) + (values data cumulative-offset)) + (declare (fixnum cumulative-offset)))) + + + +(defun make-array (dimensions &key + (element-type t) + (initial-element nil initial-element-p) + initial-contents adjustable fill-pointer + displaced-to displaced-index-offset) + "Creates an array of the specified Dimensions. See manual for details." + (unless (listp dimensions) (setq dimensions (list dimensions))) + (let ((array-rank (length (the list dimensions)))) + (declare (fixnum array-rank)) + (if (eq fill-pointer t) (setq fill-pointer (car dimensions))) + (if (and fill-pointer (> array-rank 1)) + (error "Multidimensional arrays can't have fill pointers.")) + (cond (displaced-to + ;; If the array is displaced, make a header and fill it up. + (unless (subtypep element-type (array-element-type displaced-to)) + (error "One can't displace an array of type ~S into another of ~ + type ~S." element-type (array-element-type displaced-to))) + (if (or initial-element initial-contents) + (error "The :initial-element or initial-contents option may not ~ + be specified with :displaced-to.")) + (let ((displacement (or displaced-index-offset 0)) + (array-size (array-linear-length dimensions))) + (declare (fixnum displacement array-size)) + (if (< (the fixnum (array-total-size displaced-to)) + (the fixnum (+ displacement array-size))) + (error "The :displaced-to array is too small.")) + (set-array-header (%primitive alloc-array array-rank) + displaced-to array-size + (or fill-pointer array-size) + displacement dimensions t))) + ((and (not adjustable) (= array-rank 1) (not fill-pointer)) + ;; If the array can be represented as a simple thing, do that. + (if (and initial-element-p initial-contents) + (error "The :initial-contents option may not be specified with ~ + :initial-element.")) + (data-vector-from-inits dimensions (car dimensions) array-rank + element-type initial-contents + initial-element initial-element-p)) + (t + ;; Otherwise, build a complex array. + (if (and initial-element-p initial-contents) + (error "The :initial-contents option may not be specified with ~ + :initial-element.")) + (let* ((array-size (array-linear-length dimensions)) + (array (%primitive alloc-array array-rank)) + (array-data (data-vector-from-inits + dimensions array-size array-rank element-type + initial-contents initial-element + initial-element-p))) + (set-array-header array array-data array-size + (or fill-pointer array-size) + 0 ;displacement + dimensions nil)))))) + +;;; Some people out there are still calling MAKE-VECTOR: +;;; +(setf (symbol-function 'make-vector) #'make-array) + +(defun vector (&rest objects) + "Constructs a simple-vector from the given objects." + (coerce (the list objects) 'simple-vector)) + +;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array +;;; characteristics. Dimensions is only used to pass to COPY-CONTENTS-AUX +;;; for error checking on the structure of initial-contents. +;;; +(defun data-vector-from-inits (dimensions total-size rank element-type + initial-contents initial-element + initial-element-p) + (let ((data (cond ((subtypep element-type 'string-char) + (%primitive alloc-string total-size)) + ((subtypep element-type '(unsigned-byte 32)) + (%primitive alloc-i-vector total-size + (element-type-to-access-code element-type))) + (t + (%primitive alloc-g-vector total-size initial-element))))) + (cond (initial-element-p + (unless (simple-vector-p data) + (unless (typep initial-element element-type) + (error "~S cannot be used to initialize an array of type ~S." + initial-element element-type)) + (fill (the vector data) initial-element))) + (initial-contents + (copy-contents-aux dimensions initial-contents element-type + rank 0 data))) + data)) + +;;; COPY-CONTENTS-AUX spins down into the Data vector and the Initial-Contents +;;; filling the former from the latter. +;;; +(defun copy-contents-aux (dimensions initial-contents element-type + depth index data) + (declare (fixnum depth index)) + (cond ((= depth 0) + (unless (typep initial-contents element-type) + (error "~S cannot be used to initialize an array of element-type ~S." + initial-contents element-type)) + (setf (aref data index) initial-contents) + (the fixnum (1+ index))) + ((listp initial-contents) + (unless (= (length (the list initial-contents)) (car dimensions)) + (error "This part of initial-contents, ~S, is an unappropriate ~ + length for the dimension, ~S." + initial-contents (car dimensions))) + (do ((initial-contents initial-contents (cdr initial-contents)) + (next-dimensions (cdr dimensions)) + (next-depth (the fixnum (1- depth)))) + ((null initial-contents) index) + (declare (list initial-contents)) + (setq index (copy-contents-aux + next-dimensions (car initial-contents) element-type + next-depth index data)))) + ((vectorp initial-contents) + (unless (= (length (the vector initial-contents)) (car dimensions)) + (error "This part of initial-contents, ~S, is an unappropriate ~ + length for the dimension, ~S." + initial-contents (car dimensions))) + (do ((i-index 0 (1+ i-index)) + (i-end (length (the vector initial-contents))) + (next-dimensions (cdr dimensions)) + (next-depth (the fixnum (1- depth)))) + ((= i-index i-end) index) + (declare (fixnum i-index i-end)) + (setq index (copy-contents-aux + next-dimensions (aref initial-contents index) + element-type next-depth index data)))) + (t + (error "~S is not a sequence, and cannot be used to initialize~%~ + the contents of an array." initial-contents)))) + +;;; ELEMENT-TYPE-TO-ACCESS-CODE returns the Spice Lisp I-Vector access code to +;;; be used for the data vector of an array with the given access code. +;;; +(defun element-type-to-access-code (type) + (cond ((subtypep type 'bit) 0) + ((subtypep type '(unsigned-byte 2)) 1) + ((subtypep type '(unsigned-byte 4)) 2) + ((subtypep type '(unsigned-byte 8)) 3) + ((subtypep type '(unsigned-byte 16)) 4) + ((subtypep type '(unsigned-byte 32)) 5) + (t (error "Unexpected array element type -- ~S." type)))) + + +;;; ARRAY-LINEAR-LENGTH returns the number of elements an array with the +;;; specified dimensions would have. +;;; +(defun array-linear-length (dimensions) + (do ((dimensions dimensions (cdr dimensions)) + (length 1)) + ((null dimensions) length) + (declare (fixnum length)) + (setq length (* length (the fixnum (car dimensions)))))) + +(defun aref (array &rest subscripts) + "Returns the element of the Array specified by the Subscripts." + (if (and subscripts (null (cdr subscripts))) + (aref array (car subscripts)) + (do ((subscripts (nreverse (the list subscripts)) (cdr subscripts)) + (dim-index (1- (the fixnum (%primitive header-length array))) + (1- dim-index)) + (chunk-size 1) + (result 0)) + ((= (the fixnum dim-index) %array-dim-base) + (if (atom subscripts) + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (aref data (the fixnum (+ start result)))) + (error "Too many subscripts for array reference."))) + (declare (fixnum dim-index chunk-size result)) + (let ((axis (%primitive header-ref array dim-index))) + (declare (fixnum axis)) + (cond ((atom subscripts) + (error "Too few subscripts for array reference.")) + ((not (< -1 (the fixnum (car subscripts)) axis)) + (error "Subscript ~S is out of bounds." (car subscripts))) + (t + (setq result (the fixnum + (+ result + (the fixnum + (* (the fixnum (car subscripts)) + chunk-size))))) + (setq chunk-size (* chunk-size axis)))))))) + +(defun %aset (array &rest stuff) + (if (and (cdr stuff) (null (cddr stuff))) + (setf (aref array (car stuff)) (cadr stuff)) + (let ((rstuff (nreverse (the list stuff)))) + (do ((subscripts (cdr rstuff) (cdr subscripts)) + (dim-index (1- (the fixnum (%primitive header-length array))) + (1- dim-index)) + (chunk-size 1) + (result 0)) + ((= dim-index %array-dim-base) + (if (atom subscripts) + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (setf (aref data (+ start result)) (car rstuff))) + (error "Too many subscripts for array reference."))) + (declare (fixnum dim-index chunk-size result)) + (let ((axis (%primitive header-ref array dim-index))) + (declare (fixnum axis)) + (cond ((atom subscripts) + (error "Too few subscripts for array reference.")) + ((not (< -1 (the fixnum (car subscripts)) axis)) + (error "Subscript ~S is out of bounds." + (car subscripts))) + (t + (setq result (+ result + (the fixnum (* (the fixnum (car subscripts)) + chunk-size)))) + (setq chunk-size (* chunk-size axis))))))))) + + +;;; %Apply-aset is called when (setf (apply #'aref ...) new-value) is +;;; called. + +(defun %apply-aset (new-value array &rest stuff) + (if (null (cdr stuff)) + (setf (aref array (car stuff)) new-value) + (let ((rstuff (nreverse (the list stuff)))) + (do ((subscripts rstuff (cdr subscripts)) + (dim-index (1- (the fixnum (%primitive header-length array))) + (1- dim-index)) + (chunk-size 1) + (result 0)) + ((= dim-index %array-dim-base) + (if (atom subscripts) + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (setf (aref data (+ start result)) new-value)) + (error "Too many subscripts for array reference."))) + (declare (fixnum dim-index chunk-size result)) + (let ((axis (%primitive header-ref array dim-index))) + (declare (fixnum axis)) + (cond ((atom subscripts) + (error "Too few subscripts for array reference.")) + ((not (< -1 (the fixnum (car subscripts)) axis)) + (error "Subscript ~S is out of bounds." + (car subscripts))) + (t + (setq result (+ result + (the fixnum (* (the fixnum (car subscripts)) + chunk-size)))) + (setq chunk-size (* chunk-size axis))))))))) + +(defun array-element-type (array) + "Returns the type of the elements of the array" + (cond ((bit-vector-p array) + '(mod 2)) + ((stringp array) + 'string-char) + ((simple-vector-p array) + t) + ((array-header-p array) + (with-array-data ((data array) (start) (end)) + (declare (ignore start end)) + (array-element-type data))) + ((vectorp array) + (case (%primitive get-vector-access-code array) + (0 'bit) + (1 '(unsigned-byte 2)) + (2 '(unsigned-byte 4)) + (3 '(unsigned-byte 8)) + (4 '(unsigned-byte 16)) + (5 '(unsigned-byte 32)))) + (t (error "~S is not an array." array)))) + +(defun array-rank (array) + "Returns the number of dimensions of the Array." + (if (array-header-p array) + (the fixnum (- (the fixnum (%primitive header-length array)) + %array-first-dim-slot)) + 1)) + +(defun array-dimension (array axis-number) + "Returns length of dimension Axis-Number of the Array." + (declare (fixnum axis-number)) + (if (array-header-p array) + (if (and (>= axis-number 0) + (< axis-number (the fixnum (array-rank array)))) + (%primitive header-ref array (the fixnum (+ %array-first-dim-slot axis-number))) + (error "~S is an illegal axis number." axis-number)) + (if (= axis-number 0) + (%primitive vector-length array) + (error "~S is an illegal axis number." axis-number)))) + +(defun array-dimensions (array) + "Returns a list whose elements are the dimensions of the array" + (if (array-header-p array) + (do ((index %array-first-dim-slot (1+ index)) + (end (%primitive header-length array)) + (result ())) + ((= index end) (nreverse result)) + (declare (fixnum index end)) + (push (%primitive header-ref array index) result)) + (list (%primitive vector-length array)))) + +(defun array-total-size (array) + "Returns the total number of elements in the Array." + (if (array-header-p array) + (%primitive header-ref array %array-length-slot) + (%primitive vector-length array))) + +(defun array-in-bounds-p (array &rest subscripts) + "Returns T if the Subscipts are in bounds for the Array, Nil otherwise." + (if (array-header-p array) + (do ((dim-index %array-first-dim-slot (1+ dim-index)) + (dim-index-limit (+ %array-first-dim-slot + (the fixnum (array-rank array)))) + (subs subscripts (cdr subs))) + ((= dim-index dim-index-limit) + (atom subs)) + (declare (fixnum dim-index dim-index-limit)) + (if (atom subs) + (return nil) + (if (not (< -1 + (the fixnum (car subs)) + (the fixnum (%primitive header-ref array dim-index)))) + (return nil)))) + (and (null (cdr subscripts)) + (< -1 + (the fixnum (car subscripts)) + (the fixnum (%primitive vector-length array)))))) + +(defun array-row-major-index (array &rest subscripts) + "Returns the index into the Array's data vector for the given subscripts." + (if (array-header-p array) + (do ((subscripts (nreverse (the list subscripts)) (cdr subscripts)) + (dim-index (1- (the fixnum (%primitive header-length array))) + (1- dim-index)) + (chunk-size 1) + (result 0)) + ((= dim-index %array-dim-base) + (if (atom subscripts) + result + (error "Too many subscripts for array reference."))) + (declare (fixnum dim-index chunk-size result)) + (let ((axis (%primitive header-ref array dim-index))) + (declare (fixnum axis)) + (cond ((null subscripts) + (error "Too few subscripts for array reference.")) + ((not (< -1 (the fixnum (car subscripts)) axis)) + (error "Subscript ~S is out of bounds." (car subscripts))) + (t + (setq result (+ result + (the fixnum (* (the fixnum (car subscripts)) + chunk-size)))) + (setq chunk-size (* chunk-size axis)))))) + (cond ((null subscripts) + (error "Too few subscripts for array reference.")) + ((not (< -1 + (the fixnum (car subscripts)) + (length (the simple-array array)))) + (error "Subscript ~S is out of bounds." (car subscripts))) + (t + (car subscripts))))) + + +(defun adjustable-array-p (array) + "Returns T if the given Array is adjustable, or Nil otherwise." + (array-header-p array)) + + +(defun row-major-aref (array index) + "Returns the element of array corressponding to the row-major index. This is + SETF'able." + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (aref data (+ start index)))) + +(defsetf row-major-aref %set-row-major-aref) + +(defun %set-row-major-aref (array index new-value) + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (setf (aref data (+ start index)) new-value))) + +(defun svref (simple-vector index) + "Returns the Index'th element of the given Simple-Vector." + (svref simple-vector index)) + +(defun %svset (simple-vector index new) + (setf (svref simple-vector index) new)) + +;;; The following function is used when (setf (apply #'svref ...) new +;;; is compiled. + +(defun %apply-svset (new simple-vector index) + (setf (svref simple-vector index) new)) + +(defun array-has-fill-pointer-p (array) + "Returns T if the given Array has a fill pointer, or Nil otherwise." + (and (vectorp array) (array-header-p array))) + +(defun fill-pointer (vector) + "Returns the Fill-Pointer of the given Vector." + (if (and (vectorp vector) (array-header-p vector)) + (%primitive header-ref vector %array-fill-pointer-slot) + (error "~S is not an array with a fill-pointer." vector))) + +(defun %set-fill-pointer (vector new) + (declare (fixnum new)) + (if (and (vectorp vector) (array-header-p vector)) + (if (> new (the fixnum (%primitive header-ref vector %array-length-slot))) + (error "New fill pointer, ~S, is larger than the length of the vector." + new) + (%primitive header-set vector %array-fill-pointer-slot new)) + (error "~S is not an array with a fill-pointer." vector))) + +(defun vector-push (new-el array) + "Attempts to set the element of Array designated by the fill pointer + to New-El and increment fill pointer by one. If the fill pointer is + too large, Nil is returned, otherwise the new fill pointer value is + returned." + (if (array-header-p array) + (let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot))) + (declare (fixnum fill-pointer)) + (cond ((= fill-pointer + (the fixnum (%primitive header-ref array %array-length-slot))) + nil) + (t (%primitive header-set array %array-fill-pointer-slot + (1+ fill-pointer)) + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (setf (aref data (+ fill-pointer start)) new-el)) + fill-pointer))) + (error "~S: Object has no fill pointer." array))) + +(defun vector-push-extend (new-el array &optional (extension (length array))) + "Like Vector-Push except that if the fill pointer gets too large, the + Array is extended rather than Nil being returned." + (declare (fixnum extension)) + (if (array-header-p array) + (let ((length (%primitive header-ref array %array-length-slot)) + (fill-pointer (%primitive header-ref array %array-fill-pointer-slot))) + (declare (fixnum length fill-pointer)) + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (if (= fill-pointer length) + (do* ((new-index 0 (1+ new-index)) + (new-length (let ((l (+ length extension))) + (declare (fixnum l)) + (if (zerop l) 1 l))) + (old-index start (1+ old-index)) + (new-data (make-array (if (zerop new-length) 1 new-length) + :element-type (array-element-type + array)))) + ((= new-index length) + (setq data new-data) + (setq start 0) + (set-array-header array data new-length + (1+ fill-pointer) start new-length nil)) + (declare (fixnum new-index new-length old-index)) + (setf (aref new-data new-index) (aref data old-index))) + (%primitive header-set array + %array-fill-pointer-slot (1+ fill-pointer))) + (setf (aref data (+ fill-pointer start)) new-el) + fill-pointer)) + (error "~S has no fill pointer." array))) + +(defun vector-pop (array) + "Attempts to decrease the fill-pointer by 1 and return the element + pointer to by the new fill pointer. If the new value of the fill + pointer is 0, an error occurs." + (if (array-header-p array) + (let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot))) + (declare (fixnum fill-pointer)) + (cond ((< fill-pointer 1) + (error "Fill-pointer reached 0.")) + (t + (let ((fill-pointer (1- fill-pointer))) + (declare (fixnum fill-pointer)) + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (%primitive header-set array %array-fill-pointer-slot + fill-pointer) + (aref data (+ fill-pointer start))))))) + (error "~S: Object has no fill pointer." array))) + + + +(defun get-new-fill-pointer (new-array-size fill-pointer old-fill-pointer) + (cond ((not fill-pointer) + old-fill-pointer) + ((numberp fill-pointer) + fill-pointer) + (t new-array-size))) + +(defun adjust-array (array dimensions &key + (element-type (array-element-type array)) + (initial-element nil initial-element-p) + initial-contents fill-pointer + displaced-to displaced-index-offset) + "Adjusts the Array's dimensions to the given Dimensions and stuff." + (unless (listp dimensions) (setq dimensions (list dimensions))) + (cond ((not (array-header-p array)) + (error "~S is not an adjustable array." array)) + ((/= (the fixnum (length (the list dimensions))) + (the fixnum (array-rank array))) + (error "Number of dimensions not equal to rank of array.")) + ((not (subtypep element-type (array-element-type array))) + (error "New element type, ~S, is incompatible with old." + element-type))) + (let ((array-rank (length (the list dimensions))) + (old-fill-pointer (fill-pointer array))) + (declare (fixnum array-rank)) + (when (and fill-pointer (> array-rank 1)) + (error "Multidimensional arrays can't have fill pointers.")) + (cond (initial-contents + (if (or initial-element-p displaced-to) + (error "Initial contents may not be specified with ~ + the :initial-element or :displaced-to option.")) + (let* ((array-size (array-linear-length dimensions)) + (array-data (data-vector-from-inits + dimensions array-size array-rank element-type + initial-contents initial-element + initial-element-p))) + (set-array-header array array-data array-size + (get-new-fill-pointer array-size fill-pointer + old-fill-pointer) + 0 dimensions nil))) + (displaced-to + (when initial-element ;no initial-contents supplied is already known + (error "The :initial-element option may not be specified ~ + with :displaced-to.")) + (unless (subtypep element-type (array-element-type displaced-to)) + (error "One can't displace an array of type ~S into another of ~ + type ~S." element-type (array-element-type displaced-to))) + (let ((displacement (or displaced-index-offset 0)) + (array-size (array-linear-length dimensions))) + (declare (fixnum displacement array-size)) + (if (< (the fixnum (array-total-size displaced-to)) + (the fixnum (+ displacement array-size))) + (error "The :displaced-to array is too small.")) + (set-array-header array displaced-to array-size + (get-new-fill-pointer array-size fill-pointer + old-fill-pointer) + displacement dimensions t))) + ((= array-rank 1) + (let ((old-length (%primitive header-ref array %array-length-slot)) + (new-length (car dimensions)) + new-data) + (declare (fixnum old-length new-length)) + (with-array-data ((old-data array) (old-start) + (old-end old-length)) + (cond ((or (%displacedp array) (< old-length new-length)) + (setf new-data + (data-vector-from-inits + dimensions new-length array-rank element-type + initial-contents initial-element + initial-element-p)) + (replace new-data old-data + :start2 old-start :end2 old-end)) + (t (setf new-data + (%primitive shrink-vector old-data new-length)))) + (set-array-header array new-data new-length + (get-new-fill-pointer new-length fill-pointer + old-fill-pointer) + 0 dimensions nil)))) + (t + (let ((old-length (%primitive header-ref array %array-length-slot)) + (new-length (array-linear-length dimensions))) + (declare (fixnum old-length new-length)) + (with-array-data ((old-data array) (old-start) + (old-end old-length)) + (declare (ignore old-end)) + (let ((new-data (if (or (%displacedp array) + (> new-length old-length)) + (data-vector-from-inits + dimensions new-length array-rank + element-type () initial-element + initial-element-p) + old-data))) + (zap-array-data old-data (array-dimensions array) old-start + new-data dimensions new-length element-type + initial-element initial-element-p) + (set-array-header array new-data new-length + new-length 0 dimensions nil))))))) + array) + +(defun shrink-vector (vector new-size) + "Destructively alters the Vector, changing its length to New-Size, which + must be less than or equal to its current size." + (cond ((array-header-p vector) + ;; (%primitive shrink-vector + ;; (%primitive header-ref vector %array-data-slot) + ;; new-size) + ;; (%primitive header-set vector %array-length-slot new-size) + ;; Instead of shrinking the vector, just set the fill-pointer field. + (%primitive header-set vector %array-fill-pointer-slot new-size) + vector) + (t + (%primitive shrink-vector vector new-size)))) + +(defun set-array-header (array data length fill-pointer displacement dimensions + &optional displacedp) + "Fills in array header with provided information. Returns array." + (%primitive header-set array %array-data-slot data) + (%primitive header-set array %array-length-slot length) + (%primitive header-set array %array-fill-pointer-slot fill-pointer) + (%primitive header-set array %array-displacement-slot displacement) + (if (listp dimensions) + (do ((index %array-first-dim-slot (1+ index)) + (dims dimensions (cdr dims))) + ((null dims)) + (declare (fixnum index)) + (%primitive header-set array index (car dims))) + (%primitive header-set array %array-first-dim-slot dimensions)) + (%set-array-displacedp array displacedp) + array) + + +;;; Zap-Array-Data does the grinding work for Adjust-Array. The data is zapped +;;; from the Old-Data in an arrangement specified by the Old-Dims to the +;;; New-Data in an arrangement specified by the New-Dims. Offset is a displaced +;;; offset to be added to computed indexes of Old-Data. New-Length, Element-Type, +;;; Initial-Element, and Initial-Element-P are used when Old-Data and New-Data +;;; are EQ; in this case, a temporary must be used and filled appropriately. +;;; When Old-Data and New-Data are not EQ, New-Data has already been filled with +;;; any specified initial-element. + +;;; Make a temporary to be used when old-data and new-data are EQ. +(defvar *zap-array-data-temp* (%primitive alloc-g-vector 1000 t)) + +(defun zap-array-data-temp (length element-type initial-element initial-element-p) + (declare (fixnum length)) + (if (> length (the fixnum (length *zap-array-data-temp*))) + (setf *zap-array-data-temp* (%primitive alloc-g-vector length t))) + (when initial-element-p + (unless (typep initial-element element-type) + (error "~S cannot be used to initialize an array of type ~S." + initial-element element-type)) + (fill (the simple-vector *zap-array-data-temp*) initial-element :end length)) + *zap-array-data-temp*) + +;;; Bump-Index-List helps us out: +(eval-when (compile eval) +(defmacro bump-index-list (index limits) + `(do ((subscripts ,index (cdr subscripts)) + (limits ,limits (cdr limits))) + ((null subscripts) nil) + (cond ((< (the fixnum (car subscripts)) + (the fixnum (car limits))) + (rplaca subscripts (1+ (the fixnum (car subscripts)))) + (return ,index)) + (t (rplaca subscripts 0))))) +) + +(defun zap-array-data (old-data old-dims offset new-data new-dims new-length + element-type initial-element initial-element-p) + (declare (list old-dims new-dims)) + (setq old-dims (nreverse old-dims)) + (setq new-dims (reverse new-dims)) + (if (eq old-data new-data) + (let ((temp (zap-array-data-temp new-length element-type + initial-element initial-element-p))) + (zap-array-data-aux old-data old-dims offset temp new-dims) + (dotimes (i new-length) (setf (aref new-data i) (aref temp i)))) + (zap-array-data-aux old-data old-dims offset new-data new-dims))) + + +(defun zap-array-data-aux (old-data old-dims offset new-data new-dims) + (declare (fixnum offset)) + (let ((limits (mapcar #'(lambda (x y) + (declare (fixnum x y)) + (1- (the fixnum (min x y)))) + old-dims new-dims))) + (do ((index (make-list (length old-dims) :initial-element 0) + (bump-index-list index limits))) + ((null index)) + (setf (aref new-data (row-major-index-from-dims index new-dims)) + (aref old-data + (+ (the fixnum (row-major-index-from-dims index old-dims)) + offset)))))) + + +;;; ROW-MAJOR-INDEX-FROM-DIMS figures out the row-major-order index of an +;;; array reference from a list of subscripts and a list of dimensions. +;;; This is for internal calls only, and the subscripts and dim-list variables +;;; are assumed to be reversed from what the user supplied. +;;; +(defun row-major-index-from-dims (rev-subscripts rev-dim-list) + (do ((rev-subscripts rev-subscripts (cdr rev-subscripts)) + (rev-dim-list rev-dim-list (cdr rev-dim-list)) + (chunk-size 1) + (result 0)) + ((null rev-dim-list) result) + (declare (fixnum chunk-size result)) + (setq result (+ result + (the fixnum (* (the fixnum (car rev-subscripts)) + chunk-size)))) + (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list)))))) + + +(defun bit (bit-array &rest subscripts) + "Returns the bit from the Bit-Array at the specified Subscripts." + (apply #'aref bit-array subscripts)) + +(defun %bitset (bit-array &rest stuff) + (apply #'%aset bit-array stuff)) + +(defun sbit (simple-bit-array &rest subscripts) + "Returns the bit from the Simple-Bit-Array at the specified Subscripts." + (apply #'aref simple-bit-array subscripts)) + +(defun %sbitset (bit-array &rest stuff) + (apply #'%aset bit-array stuff)) + +(defun bit-array-same-dimensions-p (array1 array2) + (and (= (the fixnum (%primitive header-length array1)) + (the fixnum (%primitive header-length array2))) + (do ((index %array-first-dim-slot (1+ index)) + (length (- (the fixnum (%primitive header-length array1)) + %array-dim-base))) + ((= index length) t) + (declare (fixnum index length)) + (if (/= (the fixnum (%primitive header-ref array1 index)) + (the fixnum (%primitive header-ref array2 index))) + (return nil))))) + +(defun bit-array-boole (array1 array2 op result-array) + (if (eq result-array t) (setq result-array array1)) + (cond ((simple-bit-vector-p array1) + (let ((length (%primitive vector-length array1))) + (declare (fixnum length)) + (unless (and (simple-bit-vector-p array2) + (= (the fixnum (%primitive vector-length array2)) length)) + (error "~S and ~S do not have the same dimensions." array1 array2)) + (if result-array + (unless (and (simple-bit-vector-p result-array) + (= (the fixnum (%primitive vector-length result-array)) + length)) + (error "~S and ~S do not have the same dimensions." + array1 result-array)) + (setq result-array (%primitive alloc-bit-vector length))) + (%primitive bit-bash array1 array2 result-array op))) + (t + (unless (bit-array-same-dimensions-p array1 array2) + (error "~S and ~S do not have the same dimensions." array1 array2)) + (if result-array + (unless (bit-array-same-dimensions-p array1 result-array) + (error "~S and ~S do not have the same dimensions." + array1 result-array)) + (setq result-array (make-array (array-dimensions array1) + :element-type '(mod 2)))) + (with-array-data ((data1 array1) (start1) (end1)) + (declare (ignore end1)) + (with-array-data ((data2 array2) (start2) (end2)) + (declare (ignore end2)) + (with-array-data ((data3 result-array) (start3) (end3)) + (declare (ignore end3)) + (let ((length (%primitive header-ref array1 %array-length-slot))) + (declare (fixnum length)) + (do ((index 0 (1+ index)) + (index1 start1 (1+ index1)) + (index2 start2 (1+ index2)) + (index3 start3 (1+ index3))) + ((= index length) result-array) + (declare (fixnum index index1 index2 index3)) + (setf (sbit data3 index3) + (boole op (sbit data1 index1) + (sbit data2 index2)))))))))) + result-array) + +(defun bit-and (bit-array1 bit-array2 &optional result-bit-array) + "Performs a bit-wise logical AND on the elements of Bit-Array1 and Bit-Array2 + putting the results in the Result-Bit-Array." + (bit-array-boole bit-array1 bit-array2 boole-and result-bit-array)) + +(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array) + "Performs a bit-wise logical IOR on the elements of Bit-Array1 and Bit-Array2 + putting the results in the Result-Bit-Array." + (bit-array-boole bit-array1 bit-array2 boole-ior result-bit-array)) + +(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array) + "Performs a bit-wise logical XOR on the elements of Bit-Array1 and Bit-Array2 + putting the results in the Result-Bit-Array." + (bit-array-boole bit-array1 bit-array2 boole-xor result-bit-array)) + +(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array) + "Performs a bit-wise logical EQV on the elements of Bit-Array1 and Bit-Array2 + putting the results in the Result-Bit-Array." + (bit-array-boole bit-array1 bit-array2 boole-eqv result-bit-array)) + +(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array) + "Performs a bit-wise logical NAND on the elements of Bit-Array1 and Bit-Array2 + putting the results in the Result-Bit-Array." + (bit-array-boole bit-array1 bit-array2 boole-nand result-bit-array)) + +(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array) + "Performs a bit-wise logical NOR on the elements of Bit-Array1 and Bit-Array2 + putting the results in the Result-Bit-Array." + (bit-array-boole bit-array1 bit-array2 boole-nor result-bit-array)) + +(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array) + "Performs a bit-wise logical ANDC1 on the elements of Bit-Array1 and Bit-Array2 + putting the results in the Result-Bit-Array." + (bit-array-boole bit-array1 bit-array2 boole-andc1 result-bit-array)) + +(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array) + "Performs a bit-wise logical ANDC2 on the elements of Bit-Array1 and Bit-Array2 + putting the results in the Result-Bit-Array." + (bit-array-boole bit-array1 bit-array2 boole-andc2 result-bit-array)) + +(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array) + "Performs a bit-wise logical ORC1 on the elements of Bit-Array1 and Bit-Array2 + putting the results in the Result-Bit-Array." + (bit-array-boole bit-array1 bit-array2 boole-orc1 result-bit-array)) + +(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array) + "Performs a bit-wise logical ORC2 on the elements of Bit-Array1 and Bit-Array2 + putting the results in the Result-Bit-Array." + (bit-array-boole bit-array1 bit-array2 boole-orc2 result-bit-array)) + +(defun bit-not (bit-array &optional result-bit-array) + "Performs a bit-wise logical NOT in the elements of the Bit-Array putting + the results into the Result-Bit-Array." + (bit-array-boole bit-array bit-array boole-nor result-bit-array)) diff --git a/code/c-call.lisp b/code/c-call.lisp new file mode 100644 index 000000000..ec27554fc --- /dev/null +++ b/code/c-call.lisp @@ -0,0 +1,935 @@ +;;; -*- Mode: Lisp; Package: EXTENSIONS; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains stuff used for calling out to C routines that are +;;; linked into the Lisp process. +;;; +;;; Written by Rob MacLachlan. +;;; +(in-package "EXTENSIONS" :use '("LISP" "SYSTEM")) +(import '(lisp::enumeration-info lisp::enumeration-info-size + lisp::enumeration-info-kind + lisp::enumeration-info-offset + lisp::enumeration-info-to + lisp::call-lisp-from-c)) +(export '(c-sizeof def-c-type def-c-record def-c-array def-c-pointer + char unsigned-char short unsigned-short + int unsigned-int long unsigned-long + void def-c-routine def-c-variable + def-c-procedure reset-foreign-pointers)) + +#-new-compiler +(eval-when (compile) + (setq lisp::*bootstrap-defmacro* t)) + +(defvar foreign-routines-defined NIL + "List of symbol/routine name pairs used to reset code pointers + for foreign routines.") + +(defvar foreign-variables-defined NIL + "List of symbol/variable name pairs used to reset pointers to + foreign variables.") + +(eval-when (compile load eval) + +;;; The C-Type structure is used to represent aspects of C data representations +;;; that aren't directly implemented by Aliens. +;;; +(defstruct c-type + ;; + ;; A form which is a printable representation of this type. + description + ;; + ;; The size in bits of objects of this type. NIL if the size is variable. + (size nil :type (or unsigned-byte null)) + ;; + ;; The bit alignment used for allocating objects of this type. + (alignment nil :type (integer 1 32))) + +(defun %print-c-type (s stream d) + (declare (ignore d)) + (format stream "#<C-Type ~S>" (c-type-description s))) + + +;;; A c-type which corresponds directly to an alien type. The Description is +;;; the alien type. +;;; +(defstruct (primitive-type + (:include c-type) + (:print-function %print-c-type))) + + +;;; The Record-Type represnts a c structure type. +;;; +(defstruct (record-type + (:include c-type) + (:print-function %print-c-type)) + ;; + ;; A list of the field descriptions for the fields in the record, in order of + ;; increasing bit offset. + (fields nil :type list)) + + +;;; The Field-Info structure describes a single field in a record. The Size +;;; recorded here may be larger than the Size in the Type, since more bits may +;;; be allocated to the field than are actually necessary to hold a value of +;;; that type. +;;; +(defstruct field-info + ;; + ;; The symbol name of this field. + (name nil :type symbol) + ;; + ;; The c-type of this field. + (type nil :type c-type) + ;; + ;; The bit offset from the start of the record that this field is located at. + (offset nil :type unsigned-byte) + ;; + ;; The number of bits in this field. + (size nil :type unsigned-byte)) + + +;;; The Array-Type represents a C array type. +;;; +(defstruct (array-type + (:include c-type) + (:print-function %print-c-type)) + ;; + ;; The c-type of the elements in the array. + (element-type nil :type c-type) + ;; + ;; The number of bits used to store each element. May be larger than the + ;; Size in the Element-Type due to padding. + (element-size nil :type unsigned-byte)) + + +;;; The Pointer-Type represents a C pointer type. +;;; +(defstruct (pointer-type + (:include c-type) + (:print-function %print-c-type)) + ;; + ;; The type of object pointed to. + (to nil :type c-type)) + + +;;; An EQ hashtable from the names of c-types to the structures describing them. +;;; +(defvar *c-type-names* (make-hash-table :test #'eq)) + +;;; Find-Alignment -- Internal +;;; +;;; Return the bit alignment for an object of the specified Size. +;;; +(proclaim '(function find-alignment (unsigned-byte) (integer 1 32))) +(defun find-alignment (size) + (cond ((> size 16) 32) + ((> size 8) 16) + ((> size 1) 8) + (t 1))) + + +;;; Align-Offset -- Internal +;;; +;;; Return Offset with enough added to bring it out to the specified +;;; Alignment. +;;; +(proclaim '(function align-offset (unsigned-byte (integer 1 32)) + unsigned-byte)) +(defun align-offset (offset alignment) + (let ((extra (rem offset alignment))) + (if (zerop extra) offset (+ offset (- alignment extra))))) + + +;;; Get-C-Type -- Internal +;;; +;;; Get the C-Type structure corresponding to the supplied Spec. If the +;;; spec is a named type, then just return the info. Otherwise, the Spec must +;;; be a primitive Alien type with an obvious size. If we can't decide the +;;; Spec, we signal an error. +;;; +(proclaim '(function get-c-type (t) c-type)) +(defun get-c-type (spec) + (cond ((gethash spec *c-type-names*)) + ((memq spec '(c-procedure short-float long-float)) + (let ((size (if (eq spec 'long-float) 64 32))) + (make-primitive-type + :description spec + :size size + :alignment (find-alignment size)))) + ((and (listp spec) (> (length spec) 1) + (symbolp (first spec))) + (case (first spec) + ((signed-byte unsigned-byte) + (let ((size (second spec))) + (make-primitive-type + :description spec + :size size + :alignment (find-alignment size)))) + (perq-string + (make-primitive-type + :description spec + :size (* (1+ (second spec)) 8) + :alignment 8)) + (null-terminated-string + (make-primitive-type + :description spec + :size (* (second spec) 8) + :alignment 8)) + (enumeration + (let* ((name (second spec)) + (info (get name 'enumeration-info))) + (unless info + (error "~S is not a defined enumeration." name)) + (let ((size (enumeration-info-size info))) + (make-primitive-type + :description spec + :size size + :alignment (find-alignment size))))) + (alien + (let ((size (third spec))) + (unless size + (error "Must specify size in Alien C-Type: ~S." spec)) + (make-primitive-type + :description spec + :size size + :alignment (find-alignment size)))) + (t + (error "~S is not a known C-Type." spec)))) + (t (error "Losing C-Type: ~S." spec)))) + + +); Eval-When (Compile Load Eval) + + +;;;; Exported type operations: + +(eval-when (compile load eval) + +;;; Symbolicate -- Internal +;;; +;;; Concatenate together the names of some strings and symbols, producing +;;; a symbol in the current package. +;;; +(proclaim '(function symbolicate (&rest (or string symbol)) symbol)) +(defun symbolicate (&rest things) + (values (intern (reduce #'(lambda (x y) + (concatenate 'string (string x) (string y))) + things)))) + +); Eval-When (Compile Load Eval) + + +;;; C-Sizeof -- Public +;;; +(proclaim '(function c-sizeof (t) unsigned-byte)) +(defun c-sizeof (spec) + "Return the size in bits of the C-Type described by Spec." + (c-type-size (get-c-type spec))) + +(pushnew 'clc::fold-transform (get 'c-sizeof 'clc::clc-transforms)) + + +;;; Def-C-Type -- Public +;;; +(defmacro def-c-type (name spec) + "Def-C-Type Name Spec + Define Name to be an abbreviation for the C-Type indicated by Spec." + `(eval-when (compile load eval) + (setf (gethash ',name *c-type-names*) ',(get-c-type spec)) + ',name)) + + +;;; Def-C-Record -- Public +;;; +(defmacro def-c-record (name &rest fields) + "Name {(Name Type)}* + Define a record C-Type. Name is the name of the type. The Fields and Types + specify the name and type of each field. An Alien operator Name-Field is + defined to select each field. The Function Make-Name creates a dynamic alien + of the appropriate size and type. Also a pointer to name type is created, so + that you can have pointers to a thing of type name in the definition of name. + The name of the pointer type is *name." + (let* ((info ()) + (pname (symbolicate "*" name)) + (pos 0) + (align 0) + (res (make-record-type + :description name + :size NIL + :alignment 1 + :fields NIL)) + (pres (make-pointer-type + :description NIL + :size 32 + :alignment 32 + :to res))) + (setf (gethash name *c-type-names*) res) + (setf (gethash pname *c-type-names*) pres) + (dolist (field fields) + (unless (= (length field) 2) + (error "Malformed field specification: ~S." field)) + (let* ((ftype (second field)) + (type (if (eq ftype pname) pname (get-c-type (second field)))) + (size (if (eq ftype pname) 32 (c-type-size type))) + (start (align-offset pos (if (eq ftype pname) 32 + (c-type-alignment type))))) + (push (make-field-info :name (first field) + :type type + :offset start + :size size) + info) + (unless size + (error "Variable size field ~A in record ~A not allowd." + (first field) name)) + (setq pos (+ start size)) + (setq align (max (find-alignment size) align)))) + + (setf (record-type-size res) pos) + (setf (record-type-alignment res) align) + (setf (record-type-fields res) (nreverse info)) + (setf (pointer-type-description pres) `(alien ,name ,pos)) + `(progn + (eval-when (compile load eval) + (setf (gethash ',name *c-type-names*) ',res) + (setf (gethash ',pname *c-type-names*) ',pres)) + (defun ,(symbolicate "MAKE-" name) () + (make-alien ',name ,(c-type-size res))) + (defoperator (,(symbolicate "INDIRECT-" pname) + ,(record-type-description res)) + ((pointer ,pname)) + `(alien-indirect (alien-value ,pointer) ,,pos)) + ,@(define-record-operators res)))) + +(eval-when (compile load eval) + +;;; Define-Record-Operators -- Internal +;;; +;;; Compute the operator definitions for accessing the fields in Record. +;;; +(proclaim '(function define-record-operators (record-type) list)) +(defun define-record-operators (record) + (let ((name (c-type-description record))) + (mapcar #'(lambda (x) + `(defoperator (,(symbolicate name "-" (field-info-name x)) + ,(c-type-description (let ((type (field-info-type x))) + (if (structurep type) type + (get-c-type type))))) + ((rec ,name)) + `(alien-index (alien-value ,rec) + ,,(field-info-offset x) + ,,(field-info-size x)))) + (record-type-fields record)))) + +); Eval-When (Compile Load Eval) + + +;;; Def-C-Array -- Public +;;; +(defmacro def-c-array (name element-type &optional size) + "Def-C-Array Name Element-Type [Size] + Define Name to be an array C-Type with the specified Element-Type. If size + is not specified, then it is a variable size array." + (let* ((eltype (get-c-type element-type)) + (elalign (c-type-alignment eltype)) + (elsize (align-offset (c-type-size eltype) elalign)) + (elts (eval size)) + (res (make-array-type :description name + :size (if elts (* elsize elts) nil) + :alignment elalign + :element-type eltype + :element-size elsize))) + `(progn + (eval-when (compile load eval) + (setf (gethash ',name *c-type-names*) ',res)) + + (defun ,(symbolicate "MAKE-" name) + ,(if elts () '(size)) + (make-alien ',name ,(if elts (* elsize elts) `(* ,elsize size)))) + + (defoperator (,(symbolicate name "-REF") + ,(c-type-description eltype)) + ((array ,name) i) + `(alien-index (alien-value ,array) (* ,,elsize ,i) ,,elsize))))) + + +;;; Def-C-Pointer -- Public +;;; +(defmacro def-c-pointer (name to) + "Def-C-Pointer Name To + Define a pointer C-Type which points to an object of type To." + (let* ((type (get-c-type to)) + (res (make-pointer-type + :description `(alien ,(c-type-description type) + ,@(when (c-type-size type) + `(,(c-type-size type)))) + :size 32 + :alignment 32 + :to type))) + `(progn + (eval-when (compile load eval) + (setf (gethash ',name *c-type-names*) ',res)) + (defoperator (,(symbolicate "INDIRECT-" name) + ,(c-type-description type)) + ((pointer ,name) + ,@(unless (c-type-size type) + '(size))) + `(alien-indirect (alien-value ,pointer) + ,,(or (c-type-size type) 'size)))))) + +;;; Some trivial builtin types... +;;; +(setf (gethash 'port *c-type-names*) + (make-primitive-type :description 'port + :size 32 + :alignment 32)) + +(setf (gethash 'string-char *c-type-names*) + (make-primitive-type :description 'string-char + :size 8 + :alignment 8)) + +(setf (gethash 'boolean *c-type-names*) + (make-primitive-type :description 'boolean + :size 1 + :alignment 1)) + +(setf (gethash 'system-area-pointer *c-type-names*) + (make-primitive-type :description 'system-area-pointer + :size 32 + :alignment 32)) + + +;;; Some more standard types: + +(def-c-type char (signed-byte 8)) +(def-c-type unsigned-char (unsigned-byte 8)) +(def-c-type short (signed-byte 16)) +(def-c-type unsigned-short (unsigned-byte 16)) +(def-c-type int (signed-byte 32)) +(def-c-type unsigned-int (unsigned-byte 32)) +(def-c-type long (signed-byte 32)) +(def-c-type unsigned-long (unsigned-byte 32)) + + + +(defstruct (routine-info + (:print-function + (lambda (s stream d) + (declare (ignore d)) + (format stream "#<Routine-Info ~S>" (routine-info-name s))))) + ;; + ;; String name of the routine and symbol name of the interface function. + (name "" :type string) + (function-name nil :type symbol) + ;; + ;; Symbol name of the variable holding the code pointer for the routine. + (code nil :type symbol) + ;; + ;; The number of words of arguments. + (arg-size 0 :type unsigned-byte) + ;; + ;; The global Alien var that we build the arguments in. This is also the + ;; type of the Alien. + (arg-alien nil :type symbol) + ;; + ;; The number of words of stack allocated for reference args. + (result-size 0 :type unsigned-byte) + ;; + ;; Similar to Arg-Alien, but we receive results in it. + (result-alien nil :type symbol) + ;; + ;; List of Arg-Info structures. + (args nil :type list) + ;; + ;; The specified return-type for the function value. Null if Void was + ;; specified. + (return-type nil :type (or c-type null))) + + +(defstruct arg-info + ;; + ;; Symbol name of the arg. + (name nil :type symbol) + ;; + ;; C-Type describing the actual argument to the routine. + (type nil :type c-type) + ;; + ;; Specified mode and options. + mode + options + ;; + ;; Names of the operators that access this arg in the Args and Results + ;; Aliens. + (operator nil :type symbol) + (result-operator nil :type symbol) + ) + + +;;; +;;; A list of top-level forms that are emitted before the Defun. This is +;;; built in reverse order. +;;; +(defvar *output-forms*) + +(defmacro def-c-routine (name (return-type &key) &rest specs) + "Def-C-Routine Name (Return-Type Option*) + {(Arg-Name Arg-Type [Mode] Arg-Option*)}* + + Define a foreign interface function for the routine with the specified string + Name. Normally the interface function is named by interning the uppercased + name in the current package. A different interface function name may be + specified by using a list (Name Function-Name) in the place of Name. + + Return-Type is the C-Type for the C function return value. Void may be used + to specify a function with no result. + + The remaining forms specifiy individual arguments that are passed to the + routine. Arg-Name is a symbol that names the argument, primarily for + documentation. Arg-Type is the C-Type of the argument. Mode specifies the + say that the argument is passed. + + :In + An :In argument is simply passed by value. The value to be passed is + obtained from argument(s) to the interface function. No values are + returned for :In arguments. This is the default mode. + + :Out + The specified argument type must be a pointer to a fixed sized object. + A pointer to a preallocated object is passed to the routine, and the + the object is accessed on return, with the value(s) being returned from + the interface function. + + :Copy + Similar to :In, except that the argument values are stored in a + preallocated object, and a pointer to the object is passed instead of + the values themselves. + + :In-Out + A combination of :Out and :Copy. A pointer to the argument is passed, + with the object being initialized from supplied argument(s) and + return value(s) being determined by accessing the object on return." + + (let ((info (make-routine-info))) + (cond ((stringp name) + (setf (routine-info-name info) name) + (setf (routine-info-function-name info) + (intern (string-upcase name)))) + ((and (listp name) (= (length name) 2) + (stringp (first name)) (symbolp (second name))) + (setf (routine-info-name info) (first name)) + (setf (routine-info-function-name info) (second name))) + (t + (error "Malformed routine name specification: ~S." name))) + + (let ((arg-info ())) + (dolist (spec specs) + (unless (and (listp spec) (>= (length spec) 2)) + (error "Bad argument spec: ~S." spec)) + (let ((arg-name (first spec)) + (arg-type (get-c-type (second spec))) + (mode (or (third spec) :in)) + (options (cdddr spec))) + (when (oddp (length options)) + (error "Odd number of options in ~S." spec)) + (unless (symbolp arg-name) + (error "Arg name is not a symbol: ~S." arg-name)) + (push (make-arg-info :name arg-name :type arg-type + :mode mode :options options) + arg-info))) + + (setf (routine-info-args info) (nreverse arg-info))) + + (unless (eq return-type 'void) + (setf (routine-info-return-type info) (get-c-type return-type))) + + (let ((*output-forms* ())) + (link-routine-entry info) + (allocate-arguments info) + (multiple-value-bind (arg-names stores value-names values binds) + (access-arguments info) + `(progn + (compiler-let ((*alien-eval-when* '(compile eval))) + ,@(nreverse *output-forms*)) + (defun ,(routine-info-function-name info) ,arg-names + ,(make-doc-string info value-names) + (alien-bind (,@(when (routine-info-arg-alien info) + `((args ,(routine-info-arg-alien info)))) + ,@(when (routine-info-result-alien info) + `((results ,(routine-info-result-alien info))))) + ,@stores + (let ((return-value + (%primitive call-foreign + ,(routine-info-code info) + ,(if (routine-info-arg-alien info) + '(alien-sap (alien-value args)) 0) + ,(truncate (+ (routine-info-arg-size info) + 31) 32)))) + return-value + (let* ,binds + (values + ,@(when (routine-info-return-type info) + `(,(coerce-from-integer (routine-info-return-type info) + 'return-value))) + ,@values)))))))))) + + +;;; Allocate-Argument, Allocate-Result -- Internal +;;; +;;; Allocate storage for an argument of the specified Type for the routine +;;; specified by Info. Name is the name of the argument. Stuff is pushed onto +;;; *Output-Forms* as needed. Allocate-Result is the same except that it +;;; allocates stuff in the result Alien. +;;; +(proclaim '(ftype (function (routine-info c-type symbol) symbol) + allocate-argument allocate-result)) +(defun allocate-argument (info type name) + (multiple-value-bind (operator size) + (allocate-field (routine-info-arg-alien info) + (routine-info-arg-size info) + type name) + (setf (routine-info-arg-size info) size) + operator)) +;;; +(defun allocate-result (info type name) + (multiple-value-bind (operator size) + (allocate-field (routine-info-result-alien info) + (routine-info-result-size info) + type name) + (setf (routine-info-result-size info) size) + operator)) + +;;; Allocate-Field -- Internal +;;; +;;; Pad Size up to the next 32 bit boundry, then create an operator that +;;; accesses a field of the specified type. We return the operator name and +;;; the new amount of stuff allocated. +;;; +(proclaim '(function allocate-field (symbol unsigned-byte c-type symbol) + (values symbol unsigned-byte))) +(defun allocate-field (alien size type name) + (let ((base (align-offset size 32)) + (opname (symbolicate alien "-" name)) + (ctsize (c-type-size type))) + (unless ctsize + (error "Cannot pass variable size argument: ~S." type)) + (if (< ctsize 32) + (incf base (- 32 ctsize))) + (push `(defoperator (,opname ,(c-type-description type)) + ((alien ,alien)) + `(alien-index (alien-value ,alien) ,,base + ,,ctsize)) + *output-forms*) + (values opname (+ ctsize base)))) + + +;;; Allocate-Arguments -- Internal +;;; +;;; Allocate operators and Aliens for the arguments and results. +;;; +(proclaim '(function allocate-arguments (routine-info) void)) +(defun allocate-arguments (info) + (let ((name (routine-info-function-name info))) + (setf (routine-info-arg-alien info) (symbolicate name "-args")) + (setf (routine-info-result-alien info) (symbolicate name "-results"))) + + (dolist (arg (routine-info-args info)) + (let ((type (arg-info-type arg)) + (name (arg-info-name arg))) + (setf (arg-info-operator arg) + (allocate-argument info type name)) + (ecase (arg-info-mode arg) + (:in) + ((:copy :in-out :out) + (unless (pointer-type-p type) + (error "~S argument ~S, has non-pointer type." + (arg-info-mode arg) name)) + (setf (arg-info-result-operator arg) + (allocate-result info (pointer-type-to type) name)) + (push `(setf (alien-access (,(arg-info-operator arg) + ,(routine-info-arg-alien info)) + 'system-area-pointer) + (alien-sap (,(arg-info-result-operator arg) + ,(routine-info-result-alien info)))) + *output-forms*))))) + + (macrolet ((foo (s n) + `(cond ((zerop (,s info)) + (setf (,n info) nil)) + (t + (setq *output-forms* + (nconc *output-forms* + `((defalien ,(,n info) ,(,n info) ,(,s info))))))))) + (foo routine-info-arg-size routine-info-arg-alien) + (foo routine-info-result-size routine-info-result-alien))) + + +;;; Access-Arguments -- Internal +;;; +;;; Return stuff to access the argument in a call to the routine specified +;;; by Info. Values: +;;; +;;; 1] A list of the input argument names. +;;; 2] A list of input arg storing forms. +;;; 3] A list of the names of the result values. +;;; 4] A list of result value forms. +;;; 5] A list of let* bindings to make around the value forms. +;;; +(proclaim '(function access-arguments (routine-info) + (values list list list list))) +(defun access-arguments (info) + (let ((arg-names ()) + (stores ()) + (value-names ()) + (values ()) + (binds ())) + (dolist (arg (routine-info-args info)) + (let ((mode (arg-info-mode arg))) + (when (eq mode :in) + (multiple-value-bind (form names) + (access-one-value + (arg-info-type arg) + :write + `(,(arg-info-operator arg) (alien-value args)) + (arg-info-name arg)) + (setq arg-names (nconc arg-names names)) + (setq stores (nconc stores (list form))))) + + (when (member mode '(:copy :in-out)) + (multiple-value-bind (form names) + (access-one-value + (pointer-type-to (arg-info-type arg)) + :write + `(,(arg-info-result-operator arg) (alien-value results)) + (arg-info-name arg)) + (setq arg-names (nconc arg-names names)) + (setq stores (nconc stores (list form))))) + + (when (member mode '(:out :in-out)) + (multiple-value-bind (forms names b) + (access-one-value + (pointer-type-to (arg-info-type arg)) + :read + `(,(arg-info-result-operator arg) (alien-value results)) + (arg-info-name arg)) + (setq value-names (nconc value-names names)) + (setq values (nconc values forms)) + (setq binds (nconc binds b)))))) + + (values arg-names stores value-names values binds))) + + +;;; Access-One-Value -- Internal +;;; +;;; Read or write an alien value that is described by a c-type. +;;; Type - The C-Type of the field to be accessed. +;;; Kind - :read or :write +;;; Alien - The Alien expression for the place to access. +;;; Name - The name of the field to access. If :Write, this variable is +;;; bound to the value to store. +;;; +;;; Returns values: +;;; 1] If :read, a list of forms which are to be the values for the arg +;;; If :write, a form which does the store. +;;; 2] A list of the names of the values produced or arguments used. In +;;; the :read case, this is really just documentation. +;;; 3] If :read, a list of let* binding forms to make around the code. +;;; +(proclaim '(function access-one-value (c-type (member :read :write) t symbol) + (values list list list))) +(defun access-one-value (type kind alien name) + (typecase type + (primitive-type + (values (if (eq kind :read) + `((alien-access ,alien)) + `(setf (alien-access ,alien) ,name)) + `(,name))) + (pointer-type + (values (if (eq kind :read) + `((alien-access ,alien 'alien)) + `(setf (alien-access ,alien 'system-area-pointer) ,name)) + `(,name))) + (t + (values (if (eq kind :read) + `((copy-alien ,alien)) + `(alien-assign ,alien ,name)) + `(,name))))) + + +;;; Coerce-From-Integer -- Internal +;;; +;;; Return a form that converts a 32bit signed integer into the kind of +;;; object specified by Type. +;;; +(proclaim '(function coerce-from-integer (c-type t) t)) +(defun coerce-from-integer (type value) + (typecase type + (primitive-type + (let ((desc (c-type-description type))) + (if (atom desc) + (case desc + (port value) + (boolean `(not (zerop ,value))) + (string-char `(code-char ,value)) + (system-area-pointer `(int-sap ,value)) + (short-float `(int-sap + (logior (ash ,value (- clc::short-float-shift-16)) + (ash clc::short-float-4bit-type + (- 32 clc::short-float-shift-16))))) + (t + (error "Don't know how to hack ~S return type." desc))) + (case (first desc) + (signed-byte value) + (unsigned-byte + (if (> (second desc) 31) + `(ldb (byte 32 0) ,value) + value)) + (enumeration + (let ((info (get (cadr desc) 'enumeration-info))) + (when (null info) + (error "~S is not a defined enumeration." desc)) + (ecase (enumeration-info-kind info) + (:vector + `(svref ,(enumeration-info-to info) + (+ ,(enumeration-info-offset info) ,value))) + (`(cdr (assoc ,value) ,(enumeration-info-to info)))))) + (t + (error "Don't know how to hack ~S return type." desc)))))) + (pointer-type + (let ((to (pointer-type-to type))) + (unless (c-type-size to) + (error "Cannot return pointer to unknown size object.")) + (let ((tds (c-type-description to))) + (if (or (eq tds 'null-terminated-string) + (and (listp tds) (eq (car (the list tds)) + 'null-terminated-string))) + `(if (eq ,value 0) NIL + (let ((av (lisp::make-alien-value (int-sap ,value) 0 + ,(c-type-size to) + ',tds))) + (alien-bind ((s av ,tds)) + (alien-access (alien-value s))))) + `(if (eq ,value 0) NIL + (lisp::make-alien-value (int-sap ,value) 0 ,(c-type-size to) + ',tds)))))) + (t + (error "Don't know how to hack ~S return type." type)))) + + +;;; Make-Doc-String -- Internal +;;; +;;; Make a doc string for the interface routine described by Info. Values +;;; is a list of the names of the by-reference return values. +;;; +(proclaim '(function make-doc-string (routine-info list) string)) +(defun make-doc-string (info values) + (let ((*print-pretty* t) + (*print-case* :downcase)) + (format nil "Interface to foreign routine ~S~:[; returns no values.~;~ + ~:*, return values:~% ~A~]" + (routine-info-name info) + (if (routine-info-return-type info) + (cons 'return-value values) + values)))) + +;;; Link-Routine-Entry -- Internal +;;; +;;; Emit stuff needed to look up a foreign routine and stash the code +;;; pointer in a variable. +;;; +(proclaim '(function link-routine-entry (routine-info) void)) +(defun link-routine-entry (info) + (let ((name (symbolicate (routine-info-function-name info) "-code")) + (item (gensym))) + (push `(defparameter ,name (get-code-pointer ,(routine-info-name info))) + *output-forms*) + (push `(let ((,item (cons ',name ',(routine-info-name info)))) + (when (not (member ,item foreign-routines-defined :test #'equal)) + (push ,item foreign-routines-defined))) + *output-forms*) + (setf (routine-info-code info) name))) + + +;;; Def-C-Variable defines a global C-Variable, so that it is available to +;;; Lisp. It accepts the name of the variable (as a string) and the type +;;; of the variable. + +(defmacro def-c-variable (name type) + "Defines a foreign variable so that it is available from Lisp. + Name should be a string with the name of the foreign variable and + type is the foreign type of the variable." + (let* ((symbol (intern (string-upcase name))) + (c-info (get-c-type type)) + (c-type (if (primitive-type-p c-info) + (c-type-description c-info) + type)) + (c-size (c-type-size c-info)) + (item (gensym))) + `(let ((,item (cons ',symbol ',name))) + (when (not (member ,item foreign-variables-defined :test #'equal)) + (push ,item foreign-variables-defined)) + (defalien ,symbol ,c-type ,c-size + (lisp::sap-int (get-data-pointer ,name)))))) + +#| +;;; Def-C-Procedure defines data structures etc. so that C can be passed +;;; a pointer to a C procedure object which when called will invoke a Lisp +;;; function. Def-C-Procedure accepts three arguments: a symbol whose +;;; value is set to an object which can be written to alien-structures +;;; that will look like a c procedure object; a number which is a constant +;;; number of arguments that the C routine will be called with; and a Lisp +;;; function (an object callable as a function) which should accept the +;;; same number of arguments and will be called when the C procedure object +;;; is invoked. + +(defmacro def-c-procedure (name nargs lfunc) + "Assigns to the value of the symbol name an object which can be + passed to a foreign function as a procedure object. Nargs is the + number of arguments the procedure should accept. Lfunc is the Lisp + function will be called when the procedure is called. Lfunc should + be callable by apply." + (let ((var (gensym))) + `(defparameter ,name + (let ((,var (%primitive alloc-static-g-vector 3))) + (setf (svref ,var 0) + (int-sap (logior (ash clc::type-assembler-code + (+ clc::type-shift-16 16)) + (get 'clc::call-lisp + 'lisp::%loaded-address)))) + (setf (svref ,var 1) ,nargs) + (setf (svref ,var 2) ,lfunc) + ,var)))) + +;;; Call-Lisp-from-C is a Lisp function that gains control when a C +;;; function calls a procedure object that is defined as above. It +;;; wraps an unwind-protect around the call to the function, so that +;;; if we throw passed it, the c-stack-information will be reset. + +(defun call-lisp-from-c (old-c-stack procedure &rest args) + (unwind-protect + (let ((rv (apply (svref procedure 2) args))) + (%primitive return-to-c old-c-stack rv)) + (%primitive reset-c-stack old-c-stack))) + +;;; Reset-foreign-pointers goes through the list of all defined foreign +;;; functions and variables and sets the pointers to their new location. + +(defun reset-foreign-pointers () + "Reset all the code and variable pointers that may have moved." + (dolist (x foreign-routines-defined) + (setf (symbol-value (car x)) (get-code-pointer (cdr x)))) + (dolist (x foreign-variables-defined) + (setf (lisp::alien-value-sap (symbol-value (car x))) + (get-data-pointer (cdr x))))) +|# + +#-new-compiler +(eval-when (compile) + (setq lisp::*bootstrap-defmacro* nil)) diff --git a/code/char.lisp b/code/char.lisp new file mode 100644 index 000000000..b1bfccabd --- /dev/null +++ b/code/char.lisp @@ -0,0 +1,466 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Character functions for Spice Lisp. Part of the standard Spice Lisp +;;; environment. +;;; +;;; This file assumes the use of ASCII codes and the specific character formats +;;; used in Spice Lisp and Vax Common Lisp. It is optimized for performance +;;; rather than for portability and elegance, and may have to be rewritten if +;;; the character representation is changed. +;;; +;;; Written by Guy Steele. +;;; Rewritten by David Dill. +;;; Hacked up for speed by Scott Fahlman. +;;; Font support flushed and type hackery rewritten by Rob MacLachlan. +;;; +(in-package 'lisp) + +(export '(char-code-limit char-font-limit char-bits-limit standard-char-p + graphic-char-p string-char-p alpha-char-p upper-case-p lower-case-p + both-case-p digit-char-p alphanumericp char= char/= char< char> + char<= char>= char-equal char-not-equal char-lessp char-greaterp + char-not-greaterp char-not-lessp character char-code char-bits + char-font code-char make-char char-upcase char-downcase + digit-char char-int int-char char-name name-char char-control-bit + char-meta-bit char-hyper-bit char-super-bit char-bit set-char-bit)) + + +;;; Compile some trivial character operations via inline expansion: +;;; +(proclaim '(inline standard-char-p + graphic-char-p string-char-p alpha-char-p upper-case-p + lower-case-p both-case-p alphanumericp char-bits + char-int)) + + +(defconstant char-code-limit 256 + "The upper exclusive bound on values produced by CHAR-CODE.") +(defconstant char-font-limit 1 + "The upper exclusive bound on values produced by CHAR-FONT.") +(defconstant char-bits-limit 256 + "The upper exclusive bound on values produced by CHAR-BITS.") + +(defconstant char-control-bit 1 + "This bit indicates a control character.") +(defconstant char-meta-bit 2 + "This bit indicates a meta character.") +(defconstant char-super-bit 4 + "This bit indicates a super character.") +(defconstant char-hyper-bit 8 + "This bit indicates a hyper character.") + + +(defparameter char-name-alist + `(("NULL" . ,(code-char 0)) + ("BELL" . ,(code-char 7)) + ("BACKSPACE" . ,(code-char 8)) ("BS" . ,(code-char 8)) + ("TAB" . ,(code-char 9)) + ("LINEFEED" . ,(code-char 10)) ("LF" . ,(code-char 10)) + ("VT" . ,(code-char 11)) + ("PAGE" . ,(code-char 12)) ("FORM" . ,(code-char 12)) + ("FORMFEED" . ,(code-char 12)) ("FF" . ,(code-char 12)) + ("RETURN" . ,(code-char 13)) ("NL" . ,(code-char 10)) + ("NEWLINE" . ,(code-char 10)) ("CR" . ,(code-char 13)) + ("ALTMODE" . ,(code-char 27)) ("ALT" . ,(code-char 27)) + ("ESCAPE" . ,(code-char 27)) ("ESC" . ,(code-char 27)) + ("SPACE" . ,(code-char 32)) ("SP" . ,(code-char 32)) + ("RUBOUT" . ,(code-char 127)) ("DELETE" . ,(code-char 127))) + "This is the alist of (character-name . character) for characters + with long names. The first name in this list for a given character + is used on typeout and is the preferred form for input.") + + +;;;; Accessor functions: + +(defun char-code (char) + "Given a character object argument, char-code returns the code attribute + of that object as a non-negative integer." + (ldb %character-code-byte (char-int char))) + +(defun char-bits (char) + "Given a character object argument, char-code returns the bits attribute + of that object as a non-negative integer." + (ldb %character-control-byte (char-int char))) + +(defun char-font (char) + "Given a character object argument, char-code returns the font attribute + of that object as 0." + (declare (ignore char)) + 0) + +(defun char-int (char) + "The argument must be a character-object. Returns the font, bits, and + code fields as a single non-negative integer. Implementation dependent. + Used mostly for hashing." + (declare (character char)) + (%primitive make-fixnum char)) + + +(defun int-char (n) + "Performs the inverse of char-int. The argument must be a non-negative + integer of the appropriate size. It is turned into a character object." + (declare (type unsigned-byte n)) + (cond ((or (not (fixnump n)) + (not (<= 0 (the fixnum n) %character-int-mask))) + nil) + ((zerop (ldb %character-control-byte (the fixnum n))) + (%primitive make-immediate-type n %string-char-type)) + (t + (%primitive make-immediate-type n %bitsy-char-type)))) + + +(defun code-char (code &optional (bits 0) (font 0)) + "All three arguments, must be non-negative integers; the last two are + optional with default values of 0 (for the bits and font attributes). + Returns a character object with the specified code, bits, and font, + or returns NIL if this is not possible." + (cond ((not (and (< -1 code char-code-limit) (zerop font))) nil) + ((zerop bits) (code-char code)) + ((< -1 bits char-bits-limit) + (%primitive make-immediate-type + (dpb bits %character-control-byte code) + %bitsy-char-type)) + (t nil))) + + +(defun character (object) + "Coerces its argument into a character object if possible. Accepts + characters, strings and symbols of length 1, and integers." + (typecase object + (character object) + (integer (int-char object)) + (string (if (= 1 (the fixnum (length (the string object)))) + (char object 0) + (error "String is not of length one: ~S" object))) + (symbol (if (= 1 (the fixnum (length (symbol-name object)))) + (schar (symbol-name object) 0) + (error "Symbol name is not of length one: ~S" object))) + (t + (error "~S cannot be coerced to a character.")))) + + +(defun make-char (char &optional (bits 0) (font 0)) + "Replaces the bits and font attributes of the specified character with + those supplied by the user as fixnums. Bits and font both default to 0." + (declare (character char)) + (and (< -1 bits char-bits-limit) + (zerop font) + (int-char (dpb bits %character-control-byte (char-code char))))) + + +(defun char-name (char) + "Given a character object, char-name returns the name for that + object (a symbol)." + (car (rassoc char char-name-alist))) + + +(defun name-char (name) + "Given an argument acceptable to string, name-char returns a character + object whose name is that symbol, if one exists. Otherwise, () is returned." + (cdr (assoc (string name) char-name-alist :test #'string-equal))) + + +(defun char-bit (char name) + "Returns T if the named bit is set in character object CHAR. Else, + returns NIL. Legal names are :CONTROL, :META, :HYPER, and :SUPER." + (logtest (case name + (:control char-control-bit) + (:meta char-meta-bit) + (:hyper char-hyper-bit) + (:super char-super-bit)) + (char-bits char))) + + +(defun set-char-bit (char name newvalue) + "Returns a character just like CHAR except that the named bit is + set or cleared, according to whether NEWVALUE is non-null or NIL. + Legal bit names are :CONTROL, :META, :HYPER, and :SUPER." + (let ((bit (case name + (:control char-control-bit) + (:meta char-meta-bit) + (:hyper char-hyper-bit) + (:super char-super-bit) + (t 0)))) + (code-char (char-code char) + (if newvalue + (logior bit (char-bits char)) + (logand (lognot bit) (char-bits char))) + (char-font char)))) + + +;;;; Predicates: + +(defun standard-char-p (char) + "The argument must be a character object. Standard-char-p returns T if the + argument is a standard character -- one of the 95 ASCII printing characters + or <return>." + (declare (character char)) + (and (typep char 'string-char) + (let ((n (char-code (the string-char char)))) + (or (< 31 n 127) + (= n 13) + (= n 10))))) + + +(defun graphic-char-p (char) + "The argument must be a character object. Graphic-char-p returns T if the + argument is a printing character (space through ~ in ASCII), otherwise + returns ()." + (declare (character char)) + (and (typep char 'string-char) + (< 31 + (char-code (the string-char char)) + 127))) + + +(defun string-char-p (char) + "The argument must be a character object. String-char-p returns T if the + argument can be stored in a string." + (declare (character char)) + (typep char 'string-char)) + + +(defun alpha-char-p (char) + "The argument must be a character object. Alpha-char-p returns T if the + argument is an alphabetic character, A-Z or a-z; otherwise ()." + (declare (character char)) + (let ((m (char-code char))) + (or (< 64 m 91) (< 96 m 123)))) + + +(defun upper-case-p (char) + "The argument must be a character object; upper-case-p returns T if the + argument is an upper-case character, () otherwise." + (declare (character char)) + (< 64 + (char-code char) + 91)) + + +(defun lower-case-p (char) + "The argument must be a character object; lower-case-p returns T if the + argument is a lower-case character, () otherwise." + (declare (character char)) + (< 96 + (char-code char) + 123)) + + +(defun both-case-p (char) + "The argument must be a character object. Both-case-p returns T if the + argument is an alphabetic character and if the character exists in + both upper and lower case. For ASCII, this is the same as Alpha-char-p." + (declare (character char)) + (let ((m (char-code char))) + (or (< 64 m 91) (< 96 m 123)))) + + +(defun digit-char-p (char &optional (radix 10.)) + "If char is a digit in the specified radix, returns the fixnum for + which that digit stands, else returns NIL. Radix defaults to 10 + (decimal)." + (declare (character char)) + (let ((m (- (char-code char) 48))) + (cond ((<= radix 10.) + ;; Special-case decimal and smaller radices. + (if (and (>= m 0) (< m radix)) m nil)) + ;; Cannot handle radix past Z. + ((> radix 36) + (error "~S too large to be an input radix." radix)) + ;; Digits 0 - 9 are used as is, since radix is larger. + ((and (>= m 0) (< m 10)) m) + ;; Check for upper case A - Z. + ((and (>= (setq m (- m 7)) 10) (< m radix)) m) + ;; Also check lower case a - z. + ((and (>= (setq m (- m 32)) 10) (< m radix)) m) + ;; Else, fail. + (t nil)))) + + +(defun alphanumericp (char) + "Given a character-object argument, alphanumericp returns T if the + argument is either numeric or alphabetic." + (declare (character char)) + (let ((m (char-code char))) + (or (< 47 m 58) (< 64 m 91) (< 96 m 123)))) + + +(defun char= (character &rest more-characters) + "Returns T if all of its arguments are the same character." + (do ((clist more-characters (cdr clist))) + ((atom clist) T) + (unless (eq (car clist) character) (return nil)))) + + +(defun char/= (character &rest more-characters) + "Returns T if no two of its arguments are the same character." + (do* ((head character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (do* ((l list (cdr l))) ;inner loop returns T + ((atom l) T) ; iff head /= rest. + (if (eq head (car l)) (return nil))) + (return nil)))) + + +(defun char< (character &rest more-characters) + "Returns T if its arguments are in strictly increasing alphabetic order." + (do* ((c character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (< (char-int c) + (char-int (car list))) + (return nil)))) + + +(defun char> (character &rest more-characters) + "Returns T if its arguments are in strictly decreasing alphabetic order." + (do* ((c character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (> (char-int c) + (char-int (car list))) + (return nil)))) + + +(defun char<= (character &rest more-characters) + "Returns T if its arguments are in strictly non-decreasing alphabetic order." + (do* ((c character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (<= (char-int c) + (char-int (car list))) + (return nil)))) + + +(defun char>= (character &rest more-characters) + "Returns T if its arguments are in strictly non-increasing alphabetic order." + (do* ((c character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (>= (char-int c) + (char-int (car list))) + (return nil)))) + + + +;;; Equal-Char-Code is used by the following functions as a version of char-int +;;; which loses font, bits, and case info. + +(defmacro equal-char-code (character) + `(let ((ch (char-code ,character))) + (if (< 96 ch 123) (- ch 32) ch))) + + + +(defun char-equal (character &rest more-characters) + "Returns T if all of its arguments are the same character. + Font, bits, and case are ignored." + (do ((clist more-characters (cdr clist))) + ((atom clist) T) + (unless (= (equal-char-code (car clist)) + (equal-char-code character)) + (return nil)))) + + +(defun char-not-equal (character &rest more-characters) + "Returns T if no two of its arguments are the same character. + Font, bits, and case are ignored." + (do* ((head character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (do* ((l list (cdr l))) + ((atom l) T) + (if (= (equal-char-code head) + (equal-char-code (car l))) + (return nil))) + (return nil)))) + + +(defun char-lessp (character &rest more-characters) + "Returns T if its arguments are in strictly increasing alphabetic order. + Font, bits, and case are ignored." + (do* ((c character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (< (equal-char-code c) + (equal-char-code (car list))) + (return nil)))) + + +(defun char-greaterp (character &rest more-characters) + "Returns T if its arguments are in strictly decreasing alphabetic order. + Font, bits, and case are ignored." + (do* ((c character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (> (equal-char-code c) + (equal-char-code (car list))) + (return nil)))) + + +(defun char-not-greaterp (character &rest more-characters) + "Returns T if its arguments are in strictly non-decreasing alphabetic order. + Font, bits, and case are ignored." + (do* ((c character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (<= (equal-char-code c) + (equal-char-code (car list))) + (return nil)))) + + +(defun char-not-lessp (character &rest more-characters) + "Returns T if its arguments are in strictly non-increasing alphabetic order. + Font, bits, and case are ignored." + (do* ((c character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (>= (equal-char-code c) + (equal-char-code (car list))) + (return nil)))) + + + + +;;;; Miscellaneous functions: + +(defun char-upcase (char) + "Returns a character with the same bits and font as the input character, + converted to upper-case if that is possible." + (declare (character char)) + (cond ((typep char 'string-char) + (char-upcase (the string-char char))) + ((lower-case-p char) + (int-char (- (char-int char) 32))) + (t + char))) + + +(defun char-downcase (char) + "Returns a character with the same bits and font as the input character, + converted to lower-case if that is possible." + (declare (character char)) + (cond ((typep char 'string-char) + (char-downcase (the string-char char))) + ((upper-case-p char) + (int-char (+ (char-int char) 32))) + (t + char))) + + +(defun digit-char (weight &optional (radix 10) (font 0)) + "All arguments must be integers. Returns a character object that + represents a digit of the given weight in the specified radix. Returns + NIL if no such character exists. The character will have the specified + font attributes." + (and (>= weight 0) (< weight radix) (< weight 36) + (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)) + 0 font))) diff --git a/code/clx-ext.lisp b/code/clx-ext.lisp new file mode 100644 index 000000000..a1a4faa26 --- /dev/null +++ b/code/clx-ext.lisp @@ -0,0 +1,591 @@ +;;; -*- Package: Extensions; Log: code.log; Mode: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains code to extend CLX in the CMU Common Lisp environment. +;;; +;;; Written by Bill Chiles and Chris Hoover. +;;; + +(in-package "EXTENSIONS") + +(export '(open-clx-display with-clx-event-handling enable-clx-event-handling + disable-clx-event-handling object-set-event-handler + default-clx-event-handler + flush-display-events carefully-add-font-paths + + serve-key-press serve-key-release serve-button-press + serve-button-release serve-motion-notify serve-enter-notify + serve-leave-notify serve-focus-in serve-focus-out + serve-exposure serve-graphics-exposure serve-no-exposure + serve-visibility-notify serve-create-notify serve-destroy-notify + serve-unmap-notify serve-map-notify serve-map-request + serve-reparent-notify serve-configure-notify serve-gravity-notify + serve-resize-request serve-configure-request serve-circulate-notify + serve-circulate-request serve-property-notify serve-selection-clear + serve-selection-request serve-selection-notify serve-colormap-notify + serve-client-message)) + + + +;;;; OPEN-CLX-DISPLAY. + +(defun open-clx-display (&optional (string (cdr (assoc :display + *environment-list* + :test #'eq)))) + "Parses a display specification including display and screen numbers. + This returns nil when there is no DISPLAY environment variable. If string + is non-nil, and any fields are missing in the specification, this signals an + error. This returns the display and screen objects." + (when string + (let* ((string (coerce string 'simple-string)) + (length (length string)) + (host-name "unix") + (display-num nil) + (screen-num nil)) + (declare (simple-string string)) + (let ((colon (position #\: string :test #'char=))) + (cond ((null colon) + (error "Missing display number in DISPLAY environment variable.")) + (t + (unless (zerop colon) (setf host-name (subseq string 0 colon))) + (let* ((start (1+ colon)) + (first-dot (position #\. string + :test #'char= :start start))) + (cond ((= start (or first-dot length)) + (error "Badly formed display number in DISPLAY ~ + environment variable.")) + ((null first-dot) + (setf display-num (parse-integer string :start start))) + (t + (setf display-num (parse-integer string :start start + :end first-dot)) + (let* ((start (1+ first-dot)) + (second-dot (position #\. string :test #'char= + :start start))) + (cond ((= start (or second-dot length)) + (error "Badly formed screen number in ~ + DISPLAY environment variable.")) + (t + (setf screen-num + (parse-integer string :start start + :end second-dot))))))))))) + (let ((display (xlib:open-display host-name :display display-num))) + (cond (screen-num + (let* ((screens (xlib:display-roots display)) + (num-screens (length screens))) + (when (>= screen-num num-screens) + (xlib:close-display display) + (error "No such screen number (~D)." screen-num)) + (values display (elt screens screen-num)))) + (t + (values display (xlib:display-default-screen display)))))))) + + +;;;; Font Path Manipulation + +(defun carefully-add-font-paths (display font-pathnames + &optional (operation :append)) + "Adds the list of font pathnames, Font-Pathnames, to the font path of + the server Display but does so carefully by checking to make sure that + the font pathnames are not already on the server's font path. If any + of the font pathnames are on the server's font path, they will remain + in their current positions. Operation may be specified as either + :prepend or :append and specifies whether to add the additional font + pathnames to the beginning or the end of the server's original font + path." + (let ((font-path (xlib:font-path display)) + (result ())) + (dolist (elt font-pathnames) + (let ((font-dir (namestring elt))) + (unless (member font-dir font-path :test #'string=) + (push font-dir result)))) + (when result + (ecase operation + (:prepend + (setf (xlib:font-path display) (revappend result font-path))) + (:append + (setf (xlib:font-path display) (append font-path (nreverse result)))))))) + + + +;;;; Enabling and disabling event handling through SYSTEM:SERVER. + +(defvar *clx-fds-to-displays* (make-hash-table :test #'eql) + "This is a hash table that maps CLX file descriptors to CLX display structures. + For every CLX file descriptor in system:*file-input-handlers*, there must + be a mapping from that file descriptor to its CLX display structure when + events are handled via SYSTEM:SERVER.") + + +(defmacro with-clx-event-handling ((display handler) &rest body) + "Evaluates body in a context where events are handled for the display + by calling handler on the display. This destroys any previously established + handler for display." + `(unwind-protect + (progn + (enable-clx-event-handling ,display ,handler) + ,@body) + (disable-clx-event-handling ,display))) + +;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in +;;; *display-event-handlers*. It also associates the display's file descriptor +;;; (connection to X11 server) with CALL-DISPLAY-EVENT-HANDLER in +;;; system:*file-input-handlers*. These are both necessary for SYSTEM:SERVER +;;; to serve CLX events. Since CALL-DISPLAY-EVENT-HANDLER is called on a +;;; file descriptor, the file descriptor is also mapped to the display in +;;; *clx-fds-to-displays*, so the user's handler can be called on the display. +;;; +(defun enable-clx-event-handling (display handler) + "After calling this, when SYSTEM:SERVER notices input on display's connection + to the X11 server, handler is called on the display. Handler is invoked in + a dynamic context with an error handler bound that will flush all events + from the display and return. By returning, it declines to handle the error, + but it will have cleared all events; thus, entering the debugger will not + result in infinite errors due to streams that wait via SYSTEM:SERVER for + input. Calling this repeatedly on the same display establishes handler as + a new handler, replacing any previous one for display." + (check-type display xlib:display) + (let ((change-handler (assoc display *display-event-handlers*))) + (if change-handler + (setf (cdr change-handler) handler) + (let ((fd (xlib::display-input-stream display))) + (push (cons fd #'call-display-event-handler) + system::*file-input-handlers*) + (setf (gethash fd *clx-fds-to-displays*) display) + (push (cons display handler) *display-event-handlers*))))) + +;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps +;;; the display to its handler. If we can't find the display, we remove the +;;; file descriptor from system:*file-input-handlers* and try to remove the +;;; display from *display-event-handlers*. This is necessary to try to keep +;;; SYSTEM:SERVER from repeatedly trying to handle the same event over and +;;; over. This is possible since many CMU Common Lisp streams loop over +;;; SYSTEM:SERVER, so when the debugger is entered, infinite errors are +;;; possible. +;;; +(defun call-display-event-handler (file-descriptor) + (let ((display (gethash file-descriptor *clx-fds-to-displays*))) + (unless display + (setf system:*file-input-handlers* + (delete file-descriptor system:*file-input-handlers* + :key #'car)) + (setf *display-event-handlers* + (remove display *display-event-handlers* + :key #'car + :test #'(lambda (ignore d) + (declare (ignore ignore)) + (= (xlib::display-input-stream d) + file-descriptor)))) + (error "File descriptor ~S not associated with any CLX display.~%~ + It has been removed from system:*file-input-handlers*." + file-descriptor)) + (let ((handler (cdr (assoc display *display-event-handlers*)))) + (unless handler + (flush-display-events display) + (error "Display ~S not associated with any event handler." display)) + (handler-bind ((error #'(lambda (condx) + (declare (ignore condx)) + (flush-display-events display)))) + (funcall handler display))))) + +(defun disable-clx-event-handling (display) + "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING." + (setf *display-event-handlers* + (remove display *display-event-handlers* :key #'car)) + (let ((fd (xlib::display-input-stream display))) + (remhash fd *clx-fds-to-displays*) + (setf system:*file-input-handlers* + (remove fd system:*file-input-handlers* :key #'car)))) + + + +;;;; Object set event handling. + +;;; This is bound by OBJECT-SET-EVENT-HANDLER, so DISPATCH-EVENT can clear +;;; events on the display before signalling any errors. This is necessary +;;; since reading on certain CMU Common Lisp streams involves SERVER, and +;;; getting an error while trying to handle an event causes repeated attempts +;;; to handle the same event. +;;; +(defvar *process-clx-event-display* nil) + +(defvar *object-set-event-handler-print* nil) + +(proclaim '(declaration values)) + +(defun object-set-event-handler (display) + "This display event handler uses object sets to map event windows cross + event types to handlers. It uses XLIB:EVENT-CASE to bind all the slots of + each event, calling the handlers on all these values in addition to the + event key and send-event-p. Describe EXT:SERVE-MUMBLE, where mumble is an + event keyword name for the exact order of arguments. :mapping-notify and + :keymap-notify events are ignored since they do not occur on any particular + window. After calling a handler, each branch returns t to discard the + event. While the handler is executing, all errors go through a handler that + flushes all the display's events and returns. This prevents infinite errors + since the debug and terminal streams loop over SYSTEM:SERVER. This function + returns t if there were some event to handle, nil otherwise. It returns + immediately if there is no event to handle." + (macrolet ((dispatch (event-key &rest args) + `(multiple-value-bind (object object-set) + (lisp::map-xwindow event-window) + (unless object + (cond ((not (typep event-window 'xlib:window)) + (xlib:discard-current-event display) + (warn "Discarding ~S event on non-window ~S." + ,event-key event-window) + (return-from object-set-event-handler nil)) + (t + (flush-display-events display) + (error "~S not a known X window.~%~ + Received event ~S." + event-window ,event-key)))) + (handler-bind ((error #'(lambda (condx) + (declare (ignore condx)) + (flush-display-events display)))) + (when *object-set-event-handler-print* + (print ,event-key) (force-output)) + (funcall (gethash ,event-key + (lisp::object-set-table object-set) + (lisp::object-set-default-handler + object-set)) + object ,event-key + ,@args)) + (setf result t)))) + (let ((*process-clx-event-display* display) + (result nil)) + (xlib:event-case (display :timeout 0) + ((:KEY-PRESS :KEY-RELEASE :BUTTON-PRESS :BUTTON-RELEASE) + (event-key event-window root child same-screen-p + x y root-x root-y state time code send-event-p) + (dispatch event-key event-window root child same-screen-p + x y root-x root-y state time code send-event-p)) + (:MOTION-NOTIFY (event-window root child same-screen-p + x y root-x root-y state time hint-p send-event-p) + (dispatch :motion-notify event-window root child same-screen-p + x y root-x root-y state time hint-p send-event-p)) + (:ENTER-NOTIFY (event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (dispatch :enter-notify event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p)) + (:LEAVE-NOTIFY (event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p) + (dispatch :leave-notify event-window root child same-screen-p + x y root-x root-y state time mode kind send-event-p)) + (:EXPOSURE (event-window x y width height count send-event-p) + (dispatch :exposure event-window x y width height count send-event-p)) + (:GRAPHICS-EXPOSURE (event-window x y width height count major minor + send-event-p) + (dispatch :graphics-exposure event-window x y width height + count major minor send-event-p)) + (:NO-EXPOSURE (event-window major minor send-event-p) + (dispatch :no-exposure event-window major minor send-event-p)) + (:FOCUS-IN (event-window mode kind send-event-p) + (dispatch :focus-in event-window mode kind send-event-p)) + (:FOCUS-OUT (event-window mode kind send-event-p) + (dispatch :focus-out event-window mode kind send-event-p)) + (:KEYMAP-NOTIFY () + (warn "Ignoring keymap notify event.") + (when *object-set-event-handler-print* + (print :keymap-notify) (force-output)) + (setf result t)) + (:VISIBILITY-NOTIFY (event-window state send-event-p) + (dispatch :visibility-notify event-window state send-event-p)) + (:CREATE-NOTIFY (event-window window x y width height border-width + override-redirect-p send-event-p) + (dispatch :create-notify event-window window x y width height + border-width override-redirect-p send-event-p)) + (:DESTROY-NOTIFY (event-window window send-event-p) + (dispatch :destroy-notify event-window window send-event-p)) + (:UNMAP-NOTIFY (event-window window configure-p send-event-p) + (dispatch :unmap-notify event-window window configure-p send-event-p)) + (:MAP-NOTIFY (event-window window override-redirect-p send-event-p) + (dispatch :map-notify event-window window override-redirect-p + send-event-p)) + (:MAP-REQUEST (event-window window send-event-p) + (dispatch :map-request event-window window send-event-p)) + (:REPARENT-NOTIFY (event-window window parent x y override-redirect-p + send-event-p) + (dispatch :reparent-notify event-window window parent x y + override-redirect-p send-event-p)) + (:CONFIGURE-NOTIFY (event-window window x y width height border-width + above-sibling override-redirect-p send-event-p) + (dispatch :configure-notify event-window window x y width height + border-width above-sibling override-redirect-p + send-event-p)) + (:GRAVITY-NOTIFY (event-window window x y send-event-p) + (dispatch :gravity-notify event-window window x y send-event-p)) + (:RESIZE-REQUEST (event-window width height send-event-p) + (dispatch :resize-request event-window width height send-event-p)) + (:CONFIGURE-REQUEST (event-window window x y width height border-width + stack-mode above-sibling value-mask send-event-p) + (dispatch :configure-request event-window window x y width height + border-width stack-mode above-sibling value-mask + send-event-p)) + (:CIRCULATE-NOTIFY (event-window window place send-event-p) + (dispatch :circulate-notify event-window window place send-event-p)) + (:CIRCULATE-REQUEST (event-window window place send-event-p) + (dispatch :circulate-request event-window window place send-event-p)) + (:PROPERTY-NOTIFY (event-window atom state time send-event-p) + (dispatch :property-notify event-window atom state time send-event-p)) + (:SELECTION-CLEAR (event-window selection time send-event-p) + (dispatch :selection-notify event-window selection time send-event-p)) + (:SELECTION-REQUEST (event-window requestor selection target property + time send-event-p) + (dispatch :selection-request event-window requestor selection target + property time send-event-p)) + (:SELECTION-NOTIFY (event-window selection target property time + send-event-p) + (dispatch :selection-notify event-window selection target property time + send-event-p)) + (:COLORMAP-NOTIFY (event-window colormap new-p installed-p send-event-p) + (dispatch :colormap-notify event-window colormap new-p installed-p + send-event-p)) + (:MAPPING-NOTIFY (request) + (warn "Ignoring mapping notify event -- ~S." request) + (when *object-set-event-handler-print* + (print :mapping-notify) (force-output)) + (setf result t)) + (:CLIENT-MESSAGE (event-window format data send-event-p) + (dispatch :client-message event-window format data send-event-p))) + result))) + +(defun default-clx-event-handler (object event-key event-window &rest ignore) + (declare (ignore ignore)) + (flush-display-events *process-clx-event-display*) + (error "No handler for event type ~S on ~S in ~S." + event-key object (lisp::map-xwindow event-window))) + +(defun flush-display-events (display) + "Dumps all the events in display's event queue including the current one + in case this is called from within XLIB:EVENT-CASE, etc." + (xlib:discard-current-event display) + (xlib:event-case (display :discard-p t :timeout 0) + (t () nil))) + + + +;;;; Key and button service. + +(defun serve-key-press (object-set fun) + "Associate a method in the object-set with :key-press events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, code, and + send-event-p." + (setf (gethash :key-press (lisp::object-set-table object-set)) fun)) + +(defun serve-key-release (object-set fun) + "Associate a method in the object-set with :key-release events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, code, and + send-event-p." + (setf (gethash :key-release (lisp::object-set-table object-set)) fun)) + +(defun serve-button-press (object-set fun) + "Associate a method in the object-set with :button-press events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, code, and + send-event-p." + (setf (gethash :button-press (lisp::object-set-table object-set)) fun)) + +(defun serve-button-release (object-set fun) + "Associate a method in the object-set with :button-release events. The + method is called on the object the event occurred, event key, event window, + root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and + send-event-p." + (setf (gethash :button-release (lisp::object-set-table object-set)) fun)) + + + +;;;; Mouse service. + +(defun serve-motion-notify (object-set fun) + "Associate a method in the object-set with :motion-notify events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, hint-p, and + send-event-p." + (setf (gethash :motion-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-enter-notify (object-set fun) + "Associate a method in the object-set with :enter-notify events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind, + and send-event-p." + (setf (gethash :enter-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-leave-notify (object-set fun) + "Associate a method in the object-set with :leave-notify events. The method + is called on the object the event occurred, event key, event window, root, + child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind, + and send-event-p." + (setf (gethash :leave-notify (lisp::object-set-table object-set)) fun)) + + + +;;;; Keyboard service. + +(defun serve-focus-in (object-set fun) + "Associate a method in the object-set with :focus-in events. The method + is called on the object the event occurred, event key, event window, mode, + kind, and send-event-p." + (setf (gethash :focus-in (lisp::object-set-table object-set)) fun)) + +(defun serve-focus-out (object-set fun) + "Associate a method in the object-set with :focus-out events. The method + is called on the object the event occurred, event key, event window, mode, + kind, and send-event-p." + (setf (gethash :focus-out (lisp::object-set-table object-set)) fun)) + + + +;;;; Exposure service. + +(defun serve-exposure (object-set fun) + "Associate a method in the object-set with :exposure events. The method + is called on the object the event occurred, event key, event window, x, y, + width, height, count, and send-event-p." + (setf (gethash :exposure (lisp::object-set-table object-set)) fun)) + +(defun serve-graphics-exposure (object-set fun) + "Associate a method in the object-set with :graphics-exposure events. The + method is called on the object the event occurred, event key, event window, + x, y, width, height, count, major, minor, and send-event-p." + (setf (gethash :graphics-exposure (lisp::object-set-table object-set)) fun)) + +(defun serve-no-exposure (object-set fun) + "Associate a method in the object-set with :no-exposure events. The method + is called on the object the event occurred, event key, event window, major, + minor, and send-event-p." + (setf (gethash :no-exposure (lisp::object-set-table object-set)) fun)) + + + +;;;; Structure service. + +(defun serve-visibility-notify (object-set fun) + "Associate a method in the object-set with :visibility-notify events. The + method is called on the object the event occurred, event key, event window, + state, and send-event-p." + (setf (gethash :visibility-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-create-notify (object-set fun) + "Associate a method in the object-set with :create-notify events. The + method is called on the object the event occurred, event key, event window, + window, x, y, width, height, border-width, override-redirect-p, and + send-event-p." + (setf (gethash :create-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-destroy-notify (object-set fun) + "Associate a method in the object-set with :destroy-notify events. The + method is called on the object the event occurred, event key, event window, + window, and send-event-p." + (setf (gethash :destroy-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-unmap-notify (object-set fun) + "Associate a method in the object-set with :unmap-notify events. The + method is called on the object the event occurred, event key, event window, + window, configure-p, and send-event-p." + (setf (gethash :unmap-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-map-notify (object-set fun) + "Associate a method in the object-set with :map-notify events. The + method is called on the object the event occurred, event key, event window, + window, override-redirect-p, and send-event-p." + (setf (gethash :map-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-map-request (object-set fun) + "Associate a method in the object-set with :map-request events. The + method is called on the object the event occurred, event key, event window, + window, and send-event-p." + (setf (gethash :map-request (lisp::object-set-table object-set)) fun)) + +(defun serve-reparent-notify (object-set fun) + "Associate a method in the object-set with :reparent-notify events. The + method is called on the object the event occurred, event key, event window, + window, parent, x, y, override-redirect-p, and send-event-p." + (setf (gethash :reparent-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-configure-notify (object-set fun) + "Associate a method in the object-set with :configure-notify events. The + method is called on the object the event occurred, event key, event window, + window, x, y, width, height, border-width, above-sibling, + override-redirect-p, and send-event-p." + (setf (gethash :configure-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-gravity-notify (object-set fun) + "Associate a method in the object-set with :gravity-notify events. The + method is called on the object the event occurred, event key, event window, + window, x, y, and send-event-p." + (setf (gethash :gravity-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-resize-request (object-set fun) + "Associate a method in the object-set with :resize-request events. The + method is called on the object the event occurred, event key, event window, + width, height, and send-event-p." + (setf (gethash :resize-request (lisp::object-set-table object-set)) fun)) + +(defun serve-configure-request (object-set fun) + "Associate a method in the object-set with :configure-request events. The + method is called on the object the event occurred, event key, event window, + window, x, y, width, height, border-width, stack-mode, above-sibling, + value-mask, and send-event-p." + (setf (gethash :configure-request (lisp::object-set-table object-set)) fun)) + +(defun serve-circulate-notify (object-set fun) + "Associate a method in the object-set with :circulate-notify events. The + method is called on the object the event occurred, event key, event window, + window, place, and send-event-p." + (setf (gethash :circulate-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-circulate-request (object-set fun) + "Associate a method in the object-set with :circulate-request events. The + method is called on the object the event occurred, event key, event window, + window, place, and send-event-p." + (setf (gethash :circulate-request (lisp::object-set-table object-set)) fun)) + + + +;;;; Misc. service. + +(defun serve-property-notify (object-set fun) + "Associate a method in the object-set with :property-notify events. The + method is called on the object the event occurred, event key, event window, + atom, state, time, and send-event-p." + (setf (gethash :property-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-selection-clear (object-set fun) + "Associate a method in the object-set with :selection-clear events. The + method is called on the object the event occurred, event key, event window, + selection, time, and send-event-p." + (setf (gethash :selection-clear (lisp::object-set-table object-set)) fun)) + +(defun serve-selection-request (object-set fun) + "Associate a method in the object-set with :selection-request events. The + method is called on the object the event occurred, event key, event window, + requestor, selection, target, property, time, and send-event-p." + (setf (gethash :selection-request (lisp::object-set-table object-set)) fun)) + +(defun serve-selection-notify (object-set fun) + "Associate a method in the object-set with :selection-notify events. The + method is called on the object the event occurred, event key, event window, + selection, target, property, time, and send-event-p." + (setf (gethash :selection-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-colormap-notify (object-set fun) + "Associate a method in the object-set with :colormap-notify events. The + method is called on the object the event occurred, event key, event window, + colormap, new-p, installed-p, and send-event-p." + (setf (gethash :colormap-notify (lisp::object-set-table object-set)) fun)) + +(defun serve-client-message (object-set fun) + "Associate a method in the object-set with :client-message events. The + method is called on the object the event occurred, event key, event window, + format, data, and send-event-p." + (setf (gethash :client-message (lisp::object-set-table object-set)) fun)) diff --git a/code/debug-info.lisp b/code/debug-info.lisp new file mode 100644 index 000000000..3b8d7f099 --- /dev/null +++ b/code/debug-info.lisp @@ -0,0 +1,191 @@ +;;; -*- Log: code.log; Package: C -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains structures used for recording debugger information. +;;; +(in-package "C") + +(defstruct location) + +(defstruct (compiled-location (:include location)) + ;; + ;; This variable's name and package, represented as strings. This allows the + ;; debugger to recover the symbol without requiring the symbol to be created + ;; at load time. Package-Name is NIL for gensyms. + (name nil :type simple-string) + (package-name nil :type (or simple-string null)) + ;; + ;; The SC and offset, save SC and save offset encoded as bit-fields. Also + ;; some sort of ID that makes the name/package unique. All locations for the + ;; same var have the same ID. A single variable will have multiple locations + ;; (in different functions) when it is closed over. + (bits0 0 :type fixnum) + (bits1 0 :type fixnum) + ;; + ;; The variable's type, represented as list-style type descriptor. + type) + + +(defmacro compiled-location-offset (str) + `(ldb (byte 17 0) (compiled-location-bits0 ,str))) + +(defmacro compiled-location-sc (str) + `(ldb (byte 5 17) (compiled-location-bits0 ,str))) + +(defmacro compiled-location-save-sc (str) + `(ldb (byte 5 22) (compiled-location-bits0 ,str))) + +(defmacro compiled-location-save-offset (str) + `(ldb (byte 17 0) (compiled-location-bits1 ,str))) + +(defmacro compiled-location-id (str) + `(ldb (byte 10 17) (compiled-location-bits1 ,str))) + + +(defstruct debug-block) + +;;; If a block has elsewhere (error) code, then there will be two debug-block +;;; structures to represent it: one for the normal code and one for the +;;; elsewhere code. +;;; +;;; ### Actually, this should probably all be represented in some packed binary +;;; form in an i-vector in the debug-function. +;;; +(defstruct (compiled-debug-block (:include debug-block)) + ;; + ;; The PC that this block starts at. + (pc nil :type index) + ;; + ;; Alternating offsets into the DEBUG-FUNCTION's source map and PC + ;; increments, represented in some variable-length encoding. + (forms nil :type (simple-array ??? (*))) + ;; + ;; A bit-vector indicating which vars are live somewhere in this block. This + ;; vector parallels the DEBUG-FUNCTION-VARIABLES, with a 1 for stored in each + ;; location that corresponds to a live variable. + (live-variables nil :type simple-bit-vector) + ;; + ;; If NIL, this block has no successor. If an INDEX, the PC of this + ;; block's successor. If a CONS, then the block's two successors are the CAR + ;; and CDR. + (successor nil :type (or null index cons))) + + +(defstruct debug-function) + +(defstruct (compiled-debug-function (:include debug-function)) + ;; + ;; The name of this function. If from a DEFUN, etc., then this is the + ;; function name, otherwise it is a descriptive string. + (name nil :type (or simple-string cons symbol)) + ;; + ;; The kind of function (same as FUNCTIONAL-KIND): + (kind nil :type (member nil :optional :external :top-level :cleanup)) + ;; + ;; A vector of the Location structures for the variables that the argument + ;; values are stored in within this function. The Locations are in the order + ;; that the arguments are actually passed in, but special marker symbols can + ;; be interspersed to indicate the orignal call syntax: + ;; + ;; DELETED + ;; There was an argument to the function in this position, but it was + ;; deleted due to lack of references. The value cannot be recovered. + ;; + ;; SUPPLIED-P + ;; The following location is the supplied-p value for the preceding + ;; keyword or optional. + ;; + ;; REST-ARG + ;; The following location holds the list of rest args. + ;; + ;; MORE-ARG + ;; The following two locations are the more arg context and count. + ;; + ;; <any other symbol> + ;; The following location is the value of the keyword argument with the + ;; specified name. + ;; + ;; This may be NIL to save space. + (arguments nil :type (or simple-vector null)) + ;; + ;; A vector of the locations of all the variables in this function, + ;; alphabetically sorted by the NAME. This may be NIL to save space. + (variables nil :type (or simple-vector null)) + ;; + ;; A vector of Locations describing the return locations, or :Standard if the + ;; function returns using the standard unknown-values convention. This may + ;; be NIL to save space. These locations only meaningful slots are OFFSET + ;; and SC. + (returns nil :type (or simple-vector (member :standard nil))) + ;; + ;; A vector of all the DEBUG-BLOCKs in this function, in the order they were + ;; emitted. The first block is the start of the function. This may be NIL + ;; to save space. + (blocks nil :type (or simple-vector null)) + ;; + ;; Register where the return PC and return CONT are kept, or NIL if they are + ;; kept on the stack in the standard location. + (return-pc nil :type (or (unsigned-byte 8) null)) + (old-cont nil :type (or (unsigned-byte 8) null))) + + +;;; ### We may ultimately want a vector of the start positions of each source +;;; form, since that would make it easier for the debugger to locate the +;;; source. +;;; +(defstruct debug-source + ;; + ;; This slot indicates where the definition came from: + ;; :File - from a file (Compile-File) + ;; :Lisp - from Lisp (Compile) + ;; :Stream - from a non-file stream (Compile-From-Stream) + (from nil :type (member :file :stream :lisp)) + ;; + ;; If :File, the file name, if :Lisp, the lambda compiled, otherwise some + ;; descriptive string. + (name nil :type (or pathname list simple-string)) + ;; + ;; The universal time that the source was written, or NIL if unavailable. + (created nil :type (or unsigned-byte null)) + ;; + ;; The universal time that the source was compiled. + (compiled nil :type unsigned-byte) + ;; + ;; The source path root number of the first form read from this source (i.e. + ;; the total number of forms converted previously in this compilation.) + (source-root 0 :type index) + ;; + ;; The file-position of the first form read from this source (if applicable). + (start-position nil :type (or index null))) + +(defstruct debug-info) + +(defstruct (compiled-debug-info (:include debug-info)) + ;; + ;; Some string describing something about the code in this component. + (name nil :type simple-string) + ;; + ;; A list of DEBUG-SOURCE structures describing where the code for this + ;; component came from, in the order that they were read. + ;; + ;; *** NOTE: the offset of this slot is wired into the fasl dumper so that it + ;; *** can backpatch the source info when compilation is complete. + (source nil :type list) + ;; + ;; A simple-vector of alternating Debug-Function structures and fixnum + ;; PCs. This is used to map PCs to functions, so that we can figure out + ;; what function we were running in. The function is valid between the PC + ;; before it (inclusive) and the PC after it (exclusive). The PCs are in + ;; sorted order, so we can binary-search. We omit the first and last PC, + ;; since their values are 0 and the length of the code vector. Null only + ;; temporarily. + (function-map nil :type (or simple-vector null)) + ;; + ;; Representation of the tree of source paths for code in this component. + (source-paths nil :type (or (simple-array (unsigned-byte 4) (*)) null))) diff --git a/code/debug.lisp b/code/debug.lisp new file mode 100644 index 000000000..1b9f1457f --- /dev/null +++ b/code/debug.lisp @@ -0,0 +1,441 @@ +;;; -*- Mode: Lisp; Package: Debug; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Spice Lisp Debugger. +;;; +;;; Written by Steve Handerson +;;; Pages 6 through 9 rewritten by Bill Chiles. +;;; +;;; ********************************************************************** +;;; +(in-package "DEBUG" :use '("LISP" "SYSTEM")) + + +(export '(internal-debug *flush-debug-errors* backtrace debug-function + show-all debug-return local show hide argument pc + function-name hide-defaults *debug-print-level* + *debug-print-length* *debug-hidden-functions*)) + + + +(in-package "LISP") +(export '(invoke-debugger *debugger-hook*)) + + +(in-package "DEBUG") + +;;; +;;; Used to communicate to debug-loop that we are at a step breakpoint. +;;; + +(define-condition step-condition (simple-condition)) + "*Print-level* is bound to this value when debug prints a function call.") +;;;; Variables, parameters, and constants. + + "*Print-length* is bound to this value when debug prints a function call.") + null, use *PRINT-LEVEL*") +(defvar *inside-debugger-p* nil + "This is T while evaluating expressions in the debugger.") + + +(defparameter *debug-print-length* 5 + "*PRINT-LENGTH* is bound to this value when debug prints a function call. If + null, use *PRINT-LENGTH*.") + +(defvar *in-the-debugger* nil + "When true, the LIST-LOCATIONS command only displays block start locations. + "The default contents of *debug-prompt*." + Otherwise, all locations are displayed.") + + "If true, list the code location type in the LIST-LOCATIONS command.") + (princ " "))) +;;; should not be listed when listing breakpoints. +;;; + "A lambda of no args that prints the debugger prompt on *debug-io*.") + +;;; Code locations of the possible breakpoints +;;; +Prompt is <stack-level>':'<frame-number>(<command-level>*']'). +Frames look like calls, C signifying a catch frame. +Expressions get evaluated in the frame's lexical environment, + setting * and friends like the top level read-eval-print loop. +Debug commands do not affect * and friends. +;;; +(defvar *breakpoints* nil) +(declaim (type list *breakpoints*)) + +;;; A list of breakpoint-info structures of the made and active step +;;; breakpoints. + PUSH rebinds things in another command level. Good for hide/show. + ABORT returns to the previous abort restart case. +;;; +(defvar *step-breakpoints* nil) +;;; +(defvar *number-of-steps* 1) + F go to numbered frame (prompts if not given). + S search for a specified function (prompts), + an optional number of times (does not prompt). + R searches up the stack, optional times. +(declaim (type integer *number-of-steps*)) +;;; +(defvar *default-breakpoint-debug-function* nil) + ? prints all kinds of groovy things. + L lists locals in current function. + P, PP displays current function call. + +Functions/macros for your enjoyment: + (DEBUG:DEBUG-RETURN expression [frame]) returns with values from an active frame. + (DEBUG:ARGUMENT n [frame]) shows the nth supplied argument. + (DEBUG:PC [frame]) shows the next pc to be executed. +;;; Returns a list of the next code-locations following the one passed. One of +;;; the *bad-code-location-types* will not be returned. +;;; +(defun next-code-locations (code-location) + (di:do-debug-block-locations (block-code-location debug-block) + (setf kind (di:breakpoint-kind (breakpoint-info-breakpoint place))) + (format t "Cannot step, in elsewhere code~%")) + (t +(proclaim '(inline pointer+ stack-ref valid-env-p cstack-pointer-valid-p)) + (di:activate-breakpoint bp) +(defun pointer+ (x y) + (%primitive sap+ x (ash y 2))) + (t ,other))))) +(defun stack-ref (s n) + (%primitive read-control-stack (pointer+ s n))) + +(defun escape-reg (f n) + (stack-ref f (+ n %escape-frame-general-register-start-slot))) + +(defun valid-env-p (env) + (and (functionp env) + (eql (%primitive get-vector-subtype env) + %function-constants-subtype))) + +(defun cstack-pointer-valid-p (x) + (and (%primitive pointer< x (%primitive current-sp)) + (not (%primitive pointer< x + (%primitive make-immediate-type 0 + %control-stack-type))))) + +(defun check-valid (x) + (unless (cstack-pointer-valid-p x) + (error "Invalid control stack pointer.")) + x) + +(defun print-code-and-stuff (env pc) + (let* ((code (%primitive header-ref env %function-code-slot)) + (code-int (%primitive make-fixnum code))) + (format t "~A, Code = #x~X, PC = ~D" + (%primitive header-ref env %function-name-slot) + (logior code-int (ash %code-type 27)) + (- (%primitive make-fixnum pc) code-int)))) + +;;; Backtrace prints a history of calls on the stack. + +(defun backtrace (&optional (frames most-positive-fixnum) + (*standard-output* *debug-io*)) + "Show a listing of the call stack going down from the current frame. Frames + is how many frames to show." + (do ((callee (%primitive current-cont) + (stack-ref callee c::old-cont-save-offset)) + (n 0 (1+ n))) + ((or (not (cstack-pointer-valid-p callee)) + (>= n frames)) + (values)) + (let* ((caller (stack-ref callee c::old-cont-save-offset)) + (pc (stack-ref callee c::return-pc-save-offset))) + (unless (cstack-pointer-valid-p caller) + (return (values))) + (let ((env (stack-ref caller c::env-save-offset))) + (cond + ((eql env 0) + (let ((env (escape-reg caller c::env-offset))) + (cond ((eql (%primitive get-type env) %trap-type) + (format t "~%<undefined> ~S" + (escape-reg caller c::call-name-offset)) + (setq callee + (check-valid + (escape-reg caller c::old-cont-offset)))) + ((valid-env-p env) + (format t "~%<escape frame> ") + (print-code-and-stuff + env + (escape-reg caller c::return-pc-offset)) + (setq callee + (check-valid + (stack-ref callee c::old-cont-save-offset)))) + (t + (error "Escaping frame ENV invalid?"))))) + ((valid-env-p env) + (terpri) + (print-code-and-stuff env pc)) + (t + (format t "~%<invalid frame>"))))))) + + (make-unprintable-object "unavailable-arg"))) +;;;; DEBUG +;;; PRINT-FRAME-CALL -- Interface +;;; +;;; This prints a representation of the function call causing frame to exist. +;;; Verbosity indicates the level of information to output; zero indicates just + which causes the standard debugger to execute.") +(defun print-frame-call (frame &key (print-length *print-length*) + (number nil)) + (let ((*print-length* (or *debug-print-length* print-length)) +(defvar *debug-abort*) + (*print-level* (or *debug-print-level* print-level))) + (when number + (format t "~&~S: " (di:frame-number frame))) + (format t "~S" frame)) + (t + (when number + (format t "~&~S: " (di:frame-number frame))) + (when (>= verbosity 2) + (let ((loc (di:frame-code-location frame))) + (*debug-abort* (find-restart 'abort)) + (handler-case + (progn + (*error-output* *debug-io*)) + +;;;; Invoke-debugger. + +(defvar *debugger-hook* nil + which causes the standard debugger to execute. The system passes the value + of this variable to the function because it binds *debugger-hook* to nil + around the invocation.") + (do ((p restarts (cdr p)) + (i 0 (1+ i))) + ((endp p)) + (format s "~& ~D: ~A~%" i (car p))))) + ;; Rebind some printer control variables. +;;; INTERNAL-DEBUG calls the debug loop. This is used in DEBUG and +;;; CONDITIONS::ERROR-ERROR. + (*print-readably* nil) +;;; SHOW-RESTARTS -- Internal. + (let ((*in-the-debugger* T) + (*read-suppress* NIL)) + (when restarts + (format s "~&Restarts:~%") + (let ((count 0) + (names-used '(nil)) + (max-name-len 0)) + (dolist (restart restarts) + +;;; NTH-ARG -- Internal. +;;; +;;; This returns the n'th arg as the user sees it from args, the result of +;;; Interface to *debug-commands*. +;;; +(defmacro def-debug-command (name &rest body) + (dolist (ele args (error "Argument specification out of range -- ~S." n)) + (lambda-list-element-dispatch ele + (defun ,fun-name () ,@body) + (push (cons ,name #',fun-name) *debug-commands*) + (di:frame-code-location *current-frame*) + (error "Unused rest-arg before n'th argument.") +(defun debug-command-p (form) + (if (symbolp form) + (cdr (assoc (symbol-name form) *debug-commands* :test #'string=)))) +(defun debug-command-p (form &optional other-commands) + ;; Return the right value. +(defun make-restart-commands (&optional (restarts *debug-restarts*)) +(def-debug-command "FRAME" (&optional +;;; +(def-debug-command "Q" + (princ "You are here.")) + ((> n current) +(def-debug-command "GO" + (setf *current-frame* + (do ((prev *current-frame* lead) + +(def-debug-command "PUSH" + (invoke-debugger *debug-condition*)) + +(def-debug-command "ABORT" + (invoke-restart *debug-abort*)) + (lead (di:frame-down *current-frame*) +(def-debug-command "RESTART" + ((null lead) + (princ "Bottom of stack encountered.") + prev) + (write-string "Restart number: ") + (t + (invoke-restart-interactively (nth num *debug-restarts*)))) +;;; + +;;; +;;; +(def-debug-command "H" + (princ debug-help-string)) + (princ "No such restart."))))) +(def-debug-command "ERROR" +;;; Information commands. +;;; + +;;; BACKTRACE-DEBUG-COMMAND binds *inside-debugger-p*, so BACKTRACE will +;;; not reparse the stack. *inside-debugger-p* is only bound to non-nil +;;; when doing evaluations in the debug loop. +;;; +(def-debug-command "BACKTRACE" + (let ((*inside-debugger-p* t)) + (backtrace (read-if-available most-positive-fixnum)))) + printing a prompting line to continue with output.") + (let* ((end -1) +(defvar *flush-debug-errors* t + "Don't recursively call DEBUG on errors while within the debugger if non-nil.") + (let ((code-loc (di:debug-function-start-location place))) +(def-debug-command "FLUSH" + (setf *flush-debug-errors* (not *flush-debug-errors*))) + + (when old-bp-info + (di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info)) + (setf *breakpoints* (remove old-bp-info *breakpoints*)) + (format t "Note: previous breakpoint removed.~%")) + (push new-bp-info *breakpoints*)) + (print-breakpoint-info (first *breakpoints*)) + (if (not (listen-skip-whitespace in)) + (princ prompt out)) + +;;; list all breakpoints set +(def-debug-command "LIST-BREAKPOINTS" () + (if (listen-skip-whitespace stream) + (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number)) + (dolist (info *breakpoints*) + + + +;;;; Debug-Loop. + +(defun debug-loop () + (let ((*debug-command-level* (1+ *debug-command-level*))) + (loop + (catch 'debug-loop-catcher + (handler-bind ((error #'(lambda (condition) + (when *flush-debug-errors* + (clear-input *debug-io*) + (princ condition) + (format t "~&Error flushed ...") + (throw 'debug-loop-catcher nil)) + (invoke-debugger condition)))) + (funcall *debug-prompt*) + (let* ((exp (read)) + (cmd-fun (debug-command-p exp)) + ;; Must bind level for restart function created for this abort. + (level *debug-command-level*)) + (with-simple-restart (abort "Return to debug level ~D." level) + (if cmd-fun + (funcall cmd-fun) + (debug-eval-print exp))))))))) + +(defun debug-eval-print (exp) + (setq +++ ++ ++ + + - - exp) + (let* ((values (multiple-value-list (eval -))) + (*standard-output* *debug-io*)) + (fresh-line) + (if values (prin1 (car values))) + (dolist (x (cdr values)) + (fresh-line) + (prin1 x)) + (setq /// // // / / values) + (setq *** ** ** * * (car values)) + ;; Make sure nobody passes back an unbound marker. + (unless (boundp '*) + (setq * nil) + (fresh-line) + (princ "Setting * to NIL -- was unbound marker.")))) + (print-breakpoint-info info))) + +(def-debug-command-alias "LB" "LIST-BREAKPOINTS") +(def-debug-command-alias "LBP" "LIST-BREAKPOINTS") + +;;; remove breakpoint n or all if none given +(def-debug-command "DELETE-BREAKPOINT" () + (let* ((index (read-if-available nil)) + (bp-info + (find index *breakpoints* :key #'breakpoint-info-breakpoint-number))) + (cond (bp-info + (di:delete-breakpoint (breakpoint-info-breakpoint bp-info)) + (setf *breakpoints* (remove bp-info *breakpoints*)) + (format t "Breakpoint ~S removed.~%" index)) + (index (format t "Breakpoint doesn't exist.")) + (t + (dolist (ele *breakpoints*) + (di:delete-breakpoint (breakpoint-info-breakpoint ele))) + (setf *breakpoints* nil) + (format t "All breakpoints deleted.~%"))))) + +(def-debug-command-alias "DBP" "DELETE-BREAKPOINT") + + +;;; +;;; Miscellaneous commands. +;;; + +(def-debug-command "FLUSH-ERRORS" () + (if (setf *flush-debug-errors* (not *flush-debug-errors*)) + (write-line "Errors now flushed.") + (write-line "Errors now create nested debug levels."))) + + +(def-debug-command "DESCRIBE" () + (let* ((curloc (di:frame-code-location *current-frame*)) + (debug-fun (di:code-location-debug-function curloc)) + (function (di:debug-function-function debug-fun))) + (if function + (describe function) + (format t "Can't figure out the function for this frame.")))) + + +;;; +;;; Editor commands. +;;; + +(def-debug-command "EDIT-SOURCE" () + (unless (typep *terminal-io* 'ed::ts-stream) + (error "The debugger's EDIT-SOURCE command only works in slave Lisps ~ + connected to a Hemlock editor.")) + (let* ((wire (ed::ts-stream-wire *terminal-io*)) + (location (maybe-block-start-location + (di:frame-code-location *current-frame*))) + (d-source (di:code-location-debug-source location)) + (name (di:debug-source-name d-source))) + (ecase (di:debug-source-from d-source) + (:file + (let* ((tlf-offset (di:code-location-top-level-form-offset location)) + (local-tlf-offset (- tlf-offset + (di:debug-source-root-number d-source))) + (char-offset (aref (or (di:debug-source-start-positions d-source) + (error "No start positions map.")) + local-tlf-offset))) + (wire:remote wire + (ed::edit-source-location (namestring name) + (di:debug-source-created d-source) + tlf-offset local-tlf-offset char-offset + (di:code-location-form-number location))) + (wire:wire-force-output wire))) + ((:lisp :stream) + (wire:remote wire + (ed::cannot-edit-source-location)) + (wire:wire-force-output wire))))) + + + +;;;; Debug loop command utilities. + +(defun read-prompting-maybe (prompt &optional (in *standard-input*) + (out *standard-output*)) + (unless (ext:listen-skip-whitespace in) + (princ prompt out) + (force-output out)) + (read in)) + +(defun read-if-available (default &optional (stream *standard-input*)) + (if (ext:listen-skip-whitespace stream) + (read stream) + default)) diff --git a/code/defmacro.lisp b/code/defmacro.lisp new file mode 100644 index 000000000..aae4551ce --- /dev/null +++ b/code/defmacro.lisp @@ -0,0 +1,413 @@ +;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains the DEFMACRO function that is part of the +;;; standard Spice Lisp environment. For the version that runs in +;;; Maclisp, see file DEFMACRO.LSP. +;;; +;;; Written by Scott Fahlman. +;;; +;;; Ugly code, since I can't create macros here and need to stay close to +;;; Maclisp, so that it will be easy to create a derivitive version to use +;;; in the cross compiler. Even without this, there's so much going on +;;; in the arglist that the code has to be hairy. +;;; +(in-package 'lisp) +(export '(defmacro deftype)) + +;;; The following specials are used for communication during argument-list +;;; parsing for a macro or macro-like form. + +(proclaim '(special %arg-count %min-args %restp %let-list + %keyword-tests *keyword-package* + %env-arg-name %env-arg-used)) + +;;; The following is an ugly way of getting an optional arg passed in to +;;; Analyze1. Bootstrapping problems in Maclisp force me to do this. + +(defvar *default-default* nil) +(defvar *key-finder* 'find-keyword) + +;;; Parse-Defmacro -- Semi-Public +;;; +;;; Provides a clean interface to ANALYZE1 +;;; +(defun parse-defmacro (arglist whole code errloc &key (path `(cdr ,whole)) + ((:environment %env-arg-name)) error-string + (doc-string-allowed t) + ((:default-default *default-default*) nil) + ((:key-finder *key-finder*) 'find-keyword)) + "For use by macros and macro-like forms that must parse some form + according to a defmacro-like argument list, ARGLIST. The first value + returned is a LET* form which binds things and then evalutes the + specified CODE. WHOLE is the variable which is bound to the entire + arglist, or NIL if &whole is illegal. ERRLOC is the name of the function + being worked on, for use in error messages. The second value is a list + of ignore declarations for the WHOLE and ENVIRONMENT vars, if appropriate. + + PATH is an access expression for getting to the object to be parsed, + which defaults to the CDR of WHOLE. + + ENVIRONMENT is the place where the macroexpansion environment + may be found. If not supplied, then no &environment arg is allowed. + + ERROR-STRING is used as the argument to error if an incorrect number of + arguments are supplied. The additional error arguments are ERRLOC and + the number of arguments supplied. If not supplied, then no argument count + error checking is done. + + DOC-STRING-ALLOWED indicates whether a doc-string should be parsed out of + the body. If one is found, it is returned as the third value. + + DEFAULT-DEFAULT is the default value for unsupplied arguments, which defaults + to NIL. + + KEY-FINDER the function used to do keyword lookup. It defaults to a function + that does the right thing. + + The fourth and fifth values are the minimum and maximum number of arguments + allowed, in case you care about that kind of thing. The fifth value is NIL + if there is no upper limit." + (multiple-value-bind (body local-decs doc) + (parse-body code nil doc-string-allowed) + + (let ((%arg-count 0) (%min-args 0) + (%restp nil) (%let-list nil) + (%keyword-tests nil) + (%env-arg-used nil)) + (analyze1 arglist path errloc whole) + + (let ((arg-test (if error-string (defmacro-arg-test whole))) + (body + `(let* ,(nreverse %let-list) + ,@ local-decs + (progn + ,@ %keyword-tests + ,@ body)))) + (values + (if arg-test + `(if ,arg-test + (error ,error-string ',errloc (length ,path)) + ,body) + body) + ;; Wrong if no error check and arglist composed entirely of &environment + ;; args, but anyone who does that deserves to lose... + `(,@(unless (or arg-test arglist) `((declare (ignore ,whole)))) + ,@(when (and %env-arg-name (not %env-arg-used)) + `((declare (ignore ,%env-arg-name))))) + doc + %min-args + (if %restp nil %arg-count)))))) + +;;; ANALYZE1 is implemented as a finite-state machine that steps +;;; through the legal parts of an arglist in order: required, optional, +;;; rest, key, and aux. The results are accumulated in a set of special +;;; variables: %let-list, %arg-count, %min-args, %restp, and %keyword-tests. +;;; +;;; ANALYZE1 is called by ANALYZE-ARGLIST to do the work for required and +;;; optional args. It calls other functions if &rest, &key, or &aux are +;;; encountered. + +(defun analyze1 (arglist path errloc whole) + (do ((args arglist (cdr args)) + (optionalp nil) + a temp) + ((atom args) + (cond ((null args) nil) + ;; Varlist is dotted, treat as &rest arg and exit. + (t (push (list args path) %let-list) + (setq %restp t)))) + (setq a (car args)) + (cond ((eq a '&whole) + (cond ((and whole (cdr args) (symbolp (cadr args))) + (push (list (cadr args) whole) %let-list) + (setq %restp t) + (setq args (cdr args))) + (t (error "Illegal or ill-formed &whole arg in ~S." errloc)))) + ((eq a '&environment) + (cond ((and %env-arg-name (cdr args) (symbolp (cadr args))) + (push `(,(cadr args) ,%env-arg-name) %let-list) + (setq %env-arg-used t) + (setq args (cdr args))) + (t (error "Illegal or ill-formed &environment arg in ~S." + errloc)))) + ((eq a '&optional) + (and optionalp + (cerror "Ignore it." + "Redundant &optional flag in varlist of ~S." errloc)) + (setq optionalp t)) + ((or (eq a '&rest) (eq a '&body)) + (return (analyze-rest (cdr args) path errloc whole))) + ((eq a '&key) + ;; Create a rest-arg, then do keyword analysis. + (setq temp (gensym)) + (setq %restp t) + (push (list temp path) %let-list) + (return (analyze-key (cdr args) temp errloc))) + ((eq a '&allow-other-keys) + (cerror "Ignore it." + "Stray &ALLOW-OTHER-KEYS in arglist of ~S." errloc)) + ((eq a '&aux) + (return (analyze-aux (cdr args) errloc))) + ((not optionalp) + (setq %min-args (1+ %min-args)) + (setq %arg-count (1+ %arg-count)) + (cond ((symbolp a) + (push `(,a (car ,path)) %let-list)) + ((atom a) + (cerror "Ignore this item." + "Non-symbol variable name in ~S." errloc)) + (t (let ((%min-args 0) (%arg-count 0) (%restp nil) + (new-whole (gensym))) + (push (list new-whole `(car ,path)) %let-list) + (analyze1 a new-whole errloc new-whole)))) + (setq path `(cdr ,path))) + ;; It's an optional arg. + (t (setq %arg-count (1+ %arg-count)) + (cond ((symbolp a) + ;; Just a symbol. Bind to car of path or default. + (push `(,a (cond (,path (car ,path)) + (t ,*default-default*))) + %let-list)) + ((atom a) + (cerror "Ignore this item." + "Non-symbol variable name in ~S." errloc)) + ((symbolp (car a)) + ;; Car of list is a symbol. Bind to car of path or + ;; to default value. + (push `(,(car a) + (cond (,path (car ,path)) + (t ,(cond ((> (length a) 1) (cadr a)) + (t *default-default*))))) + %let-list) + ;; Handle supplied-p variable, if any. + (and (> (length a) 2) + (push `(,(caddr a) (not (null ,path))) %let-list))) + ;; Then destructure arg against contents of this gensym. + (t (setq temp (gensym)) + (push `(,temp + (cond (,path (car ,path)) + (t ,(cond ((cddr a) (cadr a)) + (t *default-default*))))) + %let-list) + (let ((%min-args 0) (%arg-count 0) (%restp nil)) + (analyze1 (car a) temp errloc nil)) + ;; Handle supplied-p variable if any. + (and (> (length a) 2) + (push `(,(caddr a) (not (null ,path))) %let-list)))) + (setq path `(cdr ,path)))))) + + +;;; This deals with the portion of the arglist following any &rest flag. + +(defun analyze-rest (arglist path errloc whole) + (when (atom arglist) + (error "Bad &rest or &body arg in ~S." errloc)) + (prog ((rest-arg (car arglist)) + (more (cdr arglist))) + (cond ((symbolp rest-arg) + (push (list rest-arg path) %let-list)) + ((and (consp rest-arg) (> (length (the list rest-arg)) 1)) + (unless %env-arg-name + (error "Hairy &body not allowed when no environment available.")) + (let ((decls-var (second rest-arg)) + (doc-var (third rest-arg)) + (n-body (gensym)) (n-decls (gensym)) (n-doc (gensym))) + (setq rest-arg (first rest-arg)) + (when doc-var (push doc-var %let-list)) + (push decls-var %let-list) + (push `(,rest-arg + (multiple-value-bind (,n-body ,n-decls ,n-doc) + (parse-body ,path ,%env-arg-name + ,(not (null doc-var))) + (setq ,decls-var ,n-decls) + ,(if doc-var `(setq ,doc-var ,n-doc) n-doc) + ,n-body)) + %let-list))) + (t + (error "Bad &rest or &body arg in ~S." errloc))) + + (setq %restp t) + TRY-AGAIN + (cond ((null more) nil) + ((atom more) + (cerror "Ignore the illegal terminator." + "Dotted arglist terminator after &rest arg in ~S." errloc)) + ((eq (car more) '&key) + (analyze-key (cdr more) rest-arg errloc)) + ((eq (car more) '&aux) + (analyze-aux (cdr more) errloc)) + ((eq (car more) '&allow-other-keys) + (cerror "Ignore it." + "Stray &ALLOW-OTHER-KEYS in arglist of ~S." errloc)) + ((eq (cadr arglist) '&whole) + (cond ((and whole (cdr more) (symbolp (cadr more))) + (push (list (cadr more) whole) %let-list) + (setq more (cddr more)) + (go try-again)) + (t (error "Ill-formed or illegal &whole arg in ~S." + errloc)))) + ((eq (cadr arglist) '&environment) + (cond ((and %env-arg-name (cdr more) (symbolp (cadr more))) + (push `(,(cadr more) ,%env-arg-name) %let-list) + (setq %env-arg-used t) + (setq more (cddr more)) + (go try-again)) + (t (error "Ill-formed or illegal &environment arg in ~S." + errloc))))))) + +;;; Analyze stuff following &aux. + +(defun analyze-aux (arglist errloc) + (do ((args arglist (cdr args))) + ((null args)) + (cond ((atom args) + (cerror "Ignore the illegal terminator." + "Dotted arglist after &AUX in ~S." errloc) + (return nil)) + ((atom (car args)) + (push (list (car args) nil) %let-list)) + (t (push (list (caar args) (cadar args)) %let-list))))) + + +;;; Handle analysis of keywords, perhaps with destructuring over the keyword +;;; variable. Assumes the remainder of the calling form has already been +;;; bound to the variable passed in as RESTVAR. + +(defun analyze-key (arglist restvar errloc) + (let ((temp (gensym)) + (check-keywords t) + (keywords-seen nil)) + (push temp %let-list) + (do ((args arglist (cdr args)) + a k sp-var temp1) + ((atom args) + (cond ((null args) nil) + (t (cerror "Ignore the illegal terminator." + "Dotted arglist after &key in ~S." errloc)))) + (setq a (car args)) + (cond ((eq a '&allow-other-keys) + (setq check-keywords nil)) + ((eq a '&aux) + (return (analyze-aux (cdr args) errloc))) + ;; Just a top-level variable. Make matching keyword. + ((symbolp a) + (setq k (make-keyword a)) + (push `(,a (cond ((setq ,temp (,*key-finder* ',k ,restvar)) + (car ,temp)) + (t nil))) + %let-list) + (push k keywords-seen)) + ;; Filter out error that might choke defmacro. + ((atom a) + (cerror "Ignore this item." + "~S -- non-symbol variable name in arglist of ~S." + a errloc)) + ;; Deal with the common case: (var [init [svar]]) + ((symbolp (car a)) + (setq k (make-keyword (car a))) + ;; Deal with supplied-p variable, if any. + (cond ((and (cddr a) (symbolp (caddr a))) + (setq sp-var (caddr a)) + (push (list sp-var nil) %let-list)) + (t (setq sp-var nil))) + (push `(,(car a) + (cond ((setq ,temp (,*key-finder* ',k ,restvar)) + ,@(and sp-var `((setq ,sp-var t))) + (car ,temp)) + (t ,(cadr a)))) + %let-list) + (push k keywords-seen)) + ;; Filter out more error cases that might kill defmacro. + ((or (atom (car a)) (not (keywordp (caar a))) (atom (cdar a))) + (cerror "Ignore this item." + "~S -- ill-formed keyword arg in ~S." (car a) errloc)) + ;; Next case is ((:key var) [init [supplied-p]]). + ((symbolp (cadar a)) + (setq k (caar a)) + ;; Deal with supplied-p variable, if any. + (cond ((and (cddr a) (symbolp (caddr a))) + (setq sp-var (caddr a)) + (push (list sp-var nil) %let-list)) + (t (setq sp-var nil))) + (push `(,(cadar a) + (cond ((setq ,temp (,*key-finder* ',k ,restvar)) + ,@(and sp-var `((setq ,sp-var t))) + (car ,temp)) + (t ,(cadr a)))) + %let-list) + (push k keywords-seen)) + ;; Same case, but must destructure the "variable". + (t (setq k (caar a)) + (setq temp1 (gensym)) + (cond ((and (cddr a) (symbolp (caddr a))) + (setq sp-var (caddr a)) + (push (list sp-var nil) %let-list)) + (t (setq sp-var nil))) + (push `(,temp1 + (cond ((setq ,temp (,*key-finder* ',k ,restvar)) + ,@(and sp-var `((setq ,sp-var t))) + (car ,temp)) + (t ,(cadr a)))) + %let-list) + (push k keywords-seen) + (let ((%min-args 0) (%arg-count 0) (%restp nil)) + (analyze1 (cadar a) temp1 errloc nil))))) + (and check-keywords + (push `(keyword-test ,restvar ',keywords-seen) %keyword-tests)))) + + +;;; Functions that must be around when the macros produced by DEFMACRO are +;;; expanded. + +(defun make-keyword (s) + "Takes a non-keyword symbol S and returns the corresponding keyword." + (intern (symbol-name s) *keyword-package*)) + + +(defun find-keyword (keyword keylist) + "If keyword is present in the keylist, return a list of its argument. + Else, return NIL." + (do ((l keylist (cddr l))) + ((atom l) nil) + (cond ((atom (cdr l)) + (cerror "Stick a NIL on the end and go on." + "Unpaired item in keyword portion of macro call.") + (rplacd l (list nil)) + (return nil)) + ((eq (car l) keyword) (return (list (cadr l))))))) + + +(defun keyword-test (keylist legal) + "Check whether all keywords in a form are legal. KEYLIST is the portion + of the calling form containing keywords. LEGAL is the list of legal + keywords. If the keyword :allow-other-keyws is present in KEYLIST, + just return without complaining about anything." + (cond ((memq ':allow-other-keys keylist) nil) + (t (do ((kl keylist (cddr kl))) + ((atom kl) nil) + (cond ((memq (car kl) legal)) + (t (cerror "Ignore it." + "~S illegal or unknown keyword." (car kl)))))))) + +;;; Return a form which tests whether an illegal number of arguments +;;; have been supplied. Args is the name of the variable to which +;;; the arglist is bound. +;;; +(defun defmacro-arg-test (args) + (cond ((and (zerop %min-args) %restp) nil) + ((zerop %min-args) + `(> (length ,args) ,(1+ %arg-count))) + (%restp + `(< (length ,args) ,(1+ %min-args))) + ((= %min-args %arg-count) + `(not (= (length ,args) ,(1+ %min-args)))) + (t + `(or (> (length ,args) ,(1+ %arg-count)) + (< (length ,args) ,(1+ %min-args)))))) diff --git a/code/defstruct.lisp b/code/defstruct.lisp new file mode 100644 index 000000000..4591b9414 --- /dev/null +++ b/code/defstruct.lisp @@ -0,0 +1,561 @@ +;;; -*- Log: code.log; Package: C -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Defstruct structure definition package (Mark II). +;;; Written by Skef Wholey and Rob MacLachlan. +;;; +(in-package 'c) +(export '(lisp::defstruct) "LISP") + +;;; In Spice Lisp, the default structure representation is a simple-vector with +;;; the subtype field set to 1. The first element is used to hold the name of +;;; the structure. This piece of implementation-dependency resides in the +;;; macros defined here. + +(compiler-let ((lisp::*bootstrap-defmacro* t)) + (defmacro structurify (structure) + "Frobs a vector to turn it into a named structure. Returns the vector." + `(%primitive set-vector-subtype ,structure %g-vector-structure-subtype))) + + +;;; This version of Defstruct is implemented using Defstruct, and is free of +;;; Maclisp compatability nonsense. For bootstrapping, you're on your own. + +(defun print-defstruct-description (structure stream depth) + (declare (ignore depth)) + (format stream "#<Defstruct-Description for ~S>" (dd-name structure))) + + +;;; DSD-Name -- Internal +;;; +;;; Return the the name of a defstruct slot as a symbol. We store it +;;; as a string to avoid creating lots of worthless symbols at load time. +;;; +(defun dsd-name (dsd) + (intern (string (dsd-%name dsd)) (symbol-package (dsd-accessor dsd)))) + +(defun print-defstruct-slot-description (structure stream depth) + (declare (ignore depth)) + (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure))) + +;;; The legendary macro itself. + +;;; ### Bootstrap hack... +;;; Install this definition only into the new compiler's environment so that we +;;; don't break the bootstrap environment. +;;; +(compiler-let ((lisp::*bootstrap-defmacro* t)) + +(defmacro defstruct (name-and-options &rest slot-descriptions) + "Defstruct {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)} + Define the structure type Name. See the manual for details." + (let* ((defstruct (parse-name-and-options name-and-options)) + (name (dd-name defstruct))) + (parse-slot-descriptions defstruct slot-descriptions) + (if (eq (dd-type defstruct) 'structure) + `(progn + (%compiler-defstruct ',defstruct) + ,@(define-constructor defstruct) + ,@(define-boa-constructors defstruct) + + ;; + ;; So the print function is in the right lexical environment, and + ;; can be compiled... + (let ((new ',defstruct)) + ,@(when (consp (dd-print-function defstruct)) + `((setf (dd-print-function new) + #',(dd-print-function defstruct)))) + (%defstruct new)) + ',name) + `(progn + (eval-when (compile load eval) + (setf (info type kind ',name) nil) + (setf (info type structure-info ',name) ',defstruct)) + ,@(define-constructor defstruct) + ,@(define-boa-constructors defstruct) + ,@(define-predicate defstruct) + ,@(define-accessors defstruct) + ,@(define-copier defstruct) + ',name)))) + +); Compiler-Let + + +;;;; Parsing: + +(defun parse-name-and-options (name-and-options) + (if (atom name-and-options) + (setq name-and-options (list name-and-options))) + (do* ((options (cdr name-and-options) (cdr options)) + (name (car name-and-options)) + (print-function 'default-structure-print) + (conc-name (concat-pnames name '-)) + (constructor (concat-pnames 'make- name)) + (saw-constructor) + (boa-constructors '()) + (copier (concat-pnames 'copy- name)) + (predicate (concat-pnames name '-p)) + (include) + (saw-type) + (type 'structure) + (saw-named) + (offset 0)) + ((null options) + (make-defstruct-description + :name name + :conc-name conc-name + :constructor constructor + :boa-constructors boa-constructors + :copier copier + :predicate predicate + :include include + :print-function print-function + :type type + :lisp-type (cond ((eq type 'structure) 'simple-vector) + ((eq type 'vector) 'simple-vector) + ((eq type 'list) 'list) + ((and (listp type) (eq (car type) 'vector)) + (cons 'simple-array (cdr type))) + (t (error "~S is a bad :TYPE for Defstruct." type))) + :named (if saw-type saw-named t) + :offset offset)) + (if (atom (car options)) + (case (car options) + (:constructor (setq saw-constructor t + constructor (concat-pnames 'make- name))) + (:copier) + (:predicate) + (:named (setq saw-named t)) + (t (error "The Defstruct option ~S cannot be used with 0 arguments." + (car options)))) + (let ((option (caar options)) + (args (cdar options))) + (case option + (:conc-name (setq conc-name (car args))) + (:constructor (cond ((cdr args) + (unless saw-constructor + (setq constructor nil)) + (push args boa-constructors)) + (t + (setq saw-constructor t) + (setq constructor (car args))))) + (:copier (setq copier (car args))) + (:predicate (setq predicate (car args))) + (:include (setq include args)) + (:print-function (setq print-function (car args))) + (:type (setq saw-type t type (car args))) + (:named (error "The Defstruct option :NAMED takes no arguments.")) + (:initial-offset (setq offset (car args))) + (t (error "~S is an unknown Defstruct option." option))))))) + +;;; Parse-Slot-Descriptions parses the slot descriptions (surprise) and does +;;; any structure inclusion that needs to be done. + +(defun parse-slot-descriptions (defstruct slots) + ;; First strip off any doc string and stash it in the Defstruct. + (when (stringp (car slots)) + (setf (dd-doc defstruct) (car slots)) + (setq slots (cdr slots))) + ;; Then include stuff. We add unparsed items to the start of the Slots. + (when (dd-include defstruct) + (let* ((included-name (car (dd-include defstruct))) + (included-thing (info type structure-info included-name)) + (modified-slots (cdr (dd-include defstruct)))) + (unless included-thing + (error "Cannot find description of structure ~S to use for inclusion." + included-name)) + (setf (dd-includes defstruct) + (cons (dd-name included-thing) (dd-includes included-thing))) + (setf (dd-offset defstruct) (dd-offset included-thing)) + (do* ((islots (mapcar #'(lambda (slot) + `(,(dsd-name slot) ,(dsd-default slot) + :type ,(dsd-type slot) + :read-only ,(dsd-read-only slot))) + (dd-slots included-thing))) + (islots* islots (cdr islots*))) + ((null islots*) + (setq slots (nconc islots slots))) + (let* ((islot (car islots*)) + (modifiee (find (car islot) modified-slots + :key #'(lambda (x) (if (atom x) x (car x))) + :test #'string=))) + (when modifiee + (cond ((symbolp modifiee) + ;; If it's just a symbol, nilify the default. + (setf (cadr islot) nil)) + ((listp modifiee) + ;; If it's a list, parse new defaults and options. + (setf (cadr islot) (cadr modifiee)) + (when (cddr modifiee) + (do ((options (cddr modifiee) (cddr options))) + ((null options)) + (case (car options) + (:type + (setf (cadddr islot) (cadr options))) + (:read-only + (setf (cadr (cddddr islot)) (cadr options))) + (t + (error "Bad option in included slot spec: ~S." + (car options))))))))))))) + ;; Finally parse the slots into Slot-Description objects. + (do ((slots slots (cdr slots)) + (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0)) (1+ index)) + (descriptions '())) + ((null slots) + (setf (dd-length defstruct) index) + (setf (dd-slots defstruct) (nreverse descriptions))) + (let ((slot (car slots))) + (push + (if (atom slot) + (let ((name slot)) + (make-defstruct-slot-description + :%name (string name) + :index index + :accessor (concat-pnames (dd-conc-name defstruct) name) + :type t)) + (do ((options (cddr slot) (cddr options)) + (name (car slot)) + (default (cadr slot)) + (type t) + (read-only nil)) + ((null options) + (make-defstruct-slot-description + :%name (string name) + :index index + :accessor (concat-pnames (dd-conc-name defstruct) name) + :default default + :type type + :read-only read-only)) + (case (car options) + (:type (setq type (cadr options))) + (:read-only (setq read-only (cadr options)))))) + descriptions)))) + + + +;;;; Default structure access and copiers: +;;; +;;; In the normal case of structures that have a real type (i.e. no :Type +;;; option was specified), we want to optimize things for space as well as +;;; speed, since there can be thousands of defined slot accesors. +;;; +;;; What we do is defined the accessors and copier as closures over +;;; general-case code. Since the compiler will normally open-code accesors, +;;; the (minor) efficiency penalty is not a concern. + +;;; Typep-To-Structure -- Internal +;;; +;;; Return true if Obj is an object of the structure type specified by Info. +;;; This is called by the accessor closures, which have a handle on the type's +;;; Defstruct-Description. +;;; +(proclaim '(inline typep-to-structure)) +(defun typep-to-structure (obj info) + (declare (type defstruct-description info) (inline member)) + (and (structurep obj) + (let ((name (%primitive header-ref obj 0))) + (or (eq name (dd-name info)) + (member name (dd-included-by info) :test #'eq))))) + +#+new-compiler +;;; %Defstruct -- Internal +;;; +;;; Do miscellaneous load-time actions for the structure described by Info. +;;; Define setters, accessors, copier, predicate, documentation, instantiate +;;; definition in load-time env. This is only called for default structures. +;;; +(defun %defstruct (info) + (declare (type defstruct-description info)) + (dolist (slot (dd-slots info)) + (let ((dsd slot)) + (setf (symbol-function (dsd-accessor slot)) + #'(lambda (structure) + (declare (optimize (speed 3) (safety 0))) + (unless (typep-to-structure structure info) + (error "Structure for accessor ~S is not a ~S:~% ~S" + (dsd-accessor dsd) (dd-name info) structure)) + (%primitive header-ref structure (dsd-index dsd)))) + + (unless (dsd-read-only slot) + (setf (fdefinition `(setf ,(dsd-accessor slot))) + #'(lambda (structure new-value) + (declare (optimize (speed 3) (safety 0))) + (unless (typep-to-structure structure info) + (error "Structure for setter ~S is not a ~S:~% ~S" + `(setf ,(dsd-accessor dsd)) (dd-name info) + structure)) + (unless (typep new-value (dsd-type dsd)) + (error "New-Value for setter ~S is not a ~S:~% ~S." + `(setf ,(dsd-accessor dsd)) (dsd-type dsd) + new-value)) + (%primitive header-set structure (dsd-index dsd) + new-value)))))) + + (when (dd-predicate info) + (setf (symbol-function (dd-predicate info)) + #'(lambda (object) + (declare (optimize (speed 3) (safety 0))) + (if (typep-to-structure object info) t nil)))) + + (when (dd-copier info) + (setf (symbol-function (dd-copier info)) + #'(lambda (structure) + (declare (optimize (speed 3) (safety 0))) + (unless (typep-to-structure structure info) + (error "Structure for copier ~S is not a ~S:~% ~S" + (dd-copier info) (dd-name info) structure)) + + (let ((len (dd-length info))) + (declare (fixnum len)) + (do ((i 1 (1+ i)) + (res (%primitive alloc-g-vector len nil))) + ((= i len) + (%primitive header-set res 0 (dd-name info)) + (structurify res)) + (declare (fixnum i)) + (%primitive header-set res i + (%primitive header-ref structure i))))))) + + (when (dd-doc info) + (setf (documentation (dd-name info) 'type) (dd-doc info)))) + + +;;; Define-Accessors returns a list of function definitions for accessing and +;;; setting the slots of the a typed Defstruct. The functions are proclaimed +;;; to be inline, and the types of their arguments and results are declared as +;;; well. We count on the compiler to do clever things with Elt. + +(defun define-accessors (defstruct) + (do ((slots (dd-slots defstruct) (cdr slots)) + (stuff '()) + (type (dd-lisp-type defstruct))) + ((null slots) stuff) + (let* ((slot (car slots)) + (name (dsd-accessor slot)) + (index (dsd-index slot)) + (slot-type (dsd-type slot))) + (push + `(progn + (proclaim '(inline ,name (setf ,name))) + (defun ,name (structure) + (declare (type ,type structure)) + (the ,slot-type (elt structure ,index))) + ,@(unless (dsd-read-only slot) + `((defun (setf ,name) (structure new-value) + (declare (type ,type structure) (type ,slot-type new-value)) + (setf (elt structure ,index) new-value))))) + stuff)))) + + +;;; Define-Constructor returns a definition for the constructor function of the +;;; given Defstruct. If the structure is implemented as a vector and is named, +;;; we structurify it. If the structure is a vector of some specialized type, +;;; we can't use the Vector function. +;;; +;;; If we are defining safe accessors, we also check the types of the values to +;;; make sure that they are legal. +;;; +(defun define-constructor (defstruct) + (let ((name (dd-constructor defstruct))) + (when name + (let* ((initial-cruft + (if (dd-named defstruct) + (make-list (1+ (dd-offset defstruct)) + :initial-element `',(dd-name defstruct)) + (make-list (dd-offset defstruct)))) + (slots (dd-slots defstruct)) + (names (mapcar #'dsd-name slots)) + (args (mapcar #'(lambda (slot) + `(,(dsd-name slot) ,(dsd-default slot))) + slots))) + `((defun ,name ,(if args `(&key ,@args)) + (declare + ,@(mapcar #'(lambda (slot) + `(type ,(dsd-type slot) ,(dsd-name slot))) + slots)) + ,(case (dd-type defstruct) + (list + `(list ,@initial-cruft ,@names)) + (structure + `(truly-the ,(dd-name defstruct) + (structurify + (vector ,@initial-cruft ,@names)))) + (vector + `(vector ,@initial-cruft ,@names)) + (t + (do ((sluts slots (cdr sluts)) + (sets '()) + (temp (gensym))) + ((null sluts) + `(let ((,temp (make-array + ,(dd-length defstruct) + :element-type + ',(cadr (dd-lisp-type defstruct))))) + ,@(when (dd-named defstruct) + `(setf (aref ,temp ,(dd-offset defstruct)) + ',(dd-name defstruct))) + ,@sets + ,temp)) + (let ((slot (car sluts))) + (push `(setf (aref ,temp ,(dsd-index slot)) + ,(dsd-name slot)) + sets))))))))))) + +;;; Find-Legal-Slot -- Internal +;;; +;;; Given a defstruct description and a slot name, return the corresponding +;;; slot if it exists, or signal an error if not. +;;; +(defun find-legal-slot (defstruct name) + (or (find name (dd-slots defstruct) :key #'dsd-name :test #'string=) + (error "~S is not a defined slot name in the ~S structure." + name (dd-name defstruct)))) + +;;; Define-Boa-Constructors defines positional constructor functions. We generate +;;; code to set each variable not specified in the arglist to the default given +;;; in the Defstruct. We just slap required args in, as with rest args and aux +;;; args. Optionals are treated a little differently. Those that aren't +;;; supplied with a default in the arg list are mashed so that their default in +;;; the arglist is the corresponding default from the Defstruct. +;;; +;;; If we are defining safe accessors, we check the types of the arguments +;;; supplied. We don't bother checking the defaulted arguments since we would +;;; have to figure out how to eval the defaults only once, and it probably +;;; isn't worth the effort anyway. + +(defun define-boa-constructors (defstruct) + (do* ((boas (dd-boa-constructors defstruct) (cdr boas)) + (name (car (car boas)) (car (car boas))) + (args (copy-list (cadr (car boas))) (copy-list (cadr (car boas)))) + (slots (dd-slots defstruct) (dd-slots defstruct)) + (slots-in-arglist '() '()) + (defuns '())) + ((null boas) defuns) + ;; Find the slots in the arglist and hack the defaultless optionals. + (do ((args args (cdr args)) + (arg-kind 'required)) + ((null args)) + (let ((arg (car args))) + (if (atom arg) + (if (memq arg '(&optional &rest &aux)) + (setq arg-kind arg) + (case arg-kind + ((required &rest &aux) + (push (find-legal-slot defstruct arg) slots-in-arglist)) + (&optional + (let ((dsd (find-legal-slot defstruct arg))) + (push dsd slots-in-arglist) + (rplaca args (list arg (dsd-default dsd))))))) + (push (find-legal-slot defstruct (car arg)) slots-in-arglist)))) + + ;; Then make a list that can be used with a (list ...) or (vector ...). + (let ((initial-cruft + (if (dd-named defstruct) + (make-list (1+ (dd-offset defstruct)) + :initial-element `',(dd-name defstruct)) + (make-list (dd-offset defstruct)))) + (thing (mapcar #'(lambda (slot) + (if (memq slot slots-in-arglist) + (dsd-name slot) + (dsd-default slot))) + slots))) + (push + `(defun ,name ,args + (declare + ,@(mapcar #'(lambda (slot) + `(type ,(dsd-type slot) ,(dsd-name slot))) + slots-in-arglist)) + ,(case (dd-type defstruct) + (list + `(list ,@initial-cruft ,@thing)) + (structure + `(truly-the ,(dd-name defstruct) + (structurify (vector ,@initial-cruft ,@thing)))) + (vector + `(vector ,@initial-cruft ,@thing)) + (t + (do ((things thing (cdr things)) + (index 0 (1+ index)) + (sets '()) + (temp (gensym))) + ((null things) + `(let ((,temp (make-array + ,(dd-length defstruct) + :element-type + ',(cadr (dd-lisp-type defstruct))))) + ,@(when (dd-named defstruct) + `(setf (aref ,temp ,(dd-offset defstruct)) + ',(dd-name defstruct))) + ,@sets + ,temp)) + (push `(setf (aref ,temp index) ,(car things)) + sets))))) + defuns)))) + +;;; Define-Copier returns the definition for a copier function of a typed +;;; Defstruct if one is desired. + +(defun define-copier (defstruct) + (when (dd-copier defstruct) + `((defun ,(dd-copier defstruct) (structure) + (declare (type ,(dd-lisp-type defstruct) structure)) + (subseq structure 0 ,(dd-length defstruct)))))) + + +;;; Define-Predicate returns a definition for a predicate function if one is +;;; desired. This is only called for typed structures, since the default +;;; structure predicate is implemented as a closure. + +(defun define-predicate (defstruct) + (let ((name (dd-name defstruct)) + (pred (dd-predicate defstruct))) + (when (and pred (dd-named defstruct)) + (let ((ltype (dd-lisp-type defstruct))) + `((defun ,pred (object) + (and (typep object ',ltype) + (eq (elt (the ,ltype object) ,(dd-offset defstruct)) + ',name)))))))) + + +;;; Structure-Predicate -- Internal +;;; +;;; The typep transform in typetran calls this function when it encounters +;;; an unknown symbol type specifier. If the referred-to type is in fact a +;;; structure type that has a predicate, then we open-code the normal case of +;;; an exact match, and otherwise call the predicate. +;;; +(defun structure-predicate (object type) + (let ((def (info type structure-info type))) + (if (and def (eq (dd-type def) 'structure) (dd-predicate def)) + `(and (structurep ,object) + (or (eq (%primitive header-ref ,object 0) ',type) + (,(dd-predicate def) ,object))) + `(lisp::structure-typep ,object ',type)))) + + +;;; Random sorts of stuff. + +(defun default-structure-print (structure stream depth) + (declare (ignore depth)) + (write-string "#S(" stream) + (prin1 (svref structure 0) stream) + (do ((index 1 (1+ index)) + (length (length structure)) + (slots (dd-slots (info type structure-info (svref structure 0))) + (cdr slots))) + ((or (= index length) + (and *print-length* + (= index *print-length*))) + (if (= index length) + (write-string ")" stream) + (write-string "...)" stream))) + (write-char #\space stream) + (prin1 (dsd-name (car slots)) stream) + (write-char #\space stream) + (prin1 (svref structure index) stream))) diff --git a/code/describe.lisp b/code/describe.lisp new file mode 100644 index 000000000..5d985ce4f --- /dev/null +++ b/code/describe.lisp @@ -0,0 +1,318 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (Scott.Fahlman@cs.cmu.edu). +;;; ********************************************************************** +;;; +;;; This is the describe mechanism for Common Lisp. +;;; +;;; Written by Skef Wholey or Rob MacLachlan originally. +;;; Cleaned up, reorganized, and enhanced by Blaine Burks. +;;; +;;; This should be done better using CLOS more effectively once CMU Common +;;; Lisp is brought up to the new standard. The TYPECASE in DESCRIBE-AUX +;;; should be unnecessary. -- Bill Chiles +;;; + +(in-package "LISP") + +(export '(describe *describe-level* *describe-verbose* + *describe-implementation-details* *describe-print-level* + *describe-print-length* *describe-indentation*)) + + +;;;; DESCRIBE public switches. + +(defvar *describe-level* 2 + "Depth of recursive descriptions allowed.") + +(defvar *describe-verbose* nil + "If non-nil, descriptions may provide interpretations of information and + pointers to additional information. Normally nil.") + +(defvar *describe-implementation-details* nil + "If non-null, normally concealed implementation information won't be.") + +(defvar *describe-print-level* 2 + "*print-level* gets bound to this inside describe.") + +(defvar *describe-print-length* 5 + "*print-length gets bound to this inside describe.") + +(defvar *describe-indentation* 3 + "Number of spaces that sets off each line of a recursive description.") + +(defvar *in-describe* nil + "Used to tell whether we are doing a recursive describe.") +(defvar *current-describe-level* 0 + "Used to implement recursive description cutoff. Don't touch.") +(defvar *describe-output* nil + "An output stream used by Describe for indenting and stuff.") +(defvar *used-documentation* nil "Documentation already described.") +(defvar *described-objects* nil + "List of all objects describe within the current top-level call to describe.") +(defvar *current-describe-object* nil + "The last object passed to describe.") + +;;; DESCRIBE sets up the output stream and calls DESCRIBE-AUX, which does the +;;; hard stuff. +;;; +(defun describe (x &optional (stream *standard-output*)) + "Prints a description of the object X. + See also *describe-level*, defdescribe, *describe-verbose*, + *describe-implementation-details*, *describe-print-level*, + *describe-print-length*, and *describe-indentation*." + (unless *describe-output* + (setq *describe-output* (make-indenting-stream *standard-output*))) + (cond (*in-describe* + (unless (or (eq x nil) (eq x t)) + (let ((*current-describe-level* (1+ *current-describe-level*)) + (*current-describe-object* x)) + (indenting-further *describe-output* *describe-indentation* + (describe-aux x))))) + (t + (setf (indenting-stream-stream *describe-output*) stream) + (let ((*standard-output* *describe-output*) + (*print-level* *describe-print-level*) + (*print-length* *describe-print-length*) + (*used-documentation* ()) + (*described-objects* ()) + (*in-describe* t) + (*current-describe-object* x)) + (describe-aux x)) + (values)))) + +;;; DESCRIBE-AUX does different things for each type. The order of the +;;; TYPECASE branches matters with respect to: +;;; - symbols and functions until the new standard makes them disjoint. +;;; - packages and structure since packages are structures. +;;; We punt a given call if the current level is greater than *describe-level*, +;;; or if we detect an object into which we have already descended. +;;; +(defun describe-aux (x) + (when (or (not (integerp *describe-level*)) + (minusp *describe-level*)) + (error "*describe-level* should be a nonnegative integer - ~A." + *describe-level*)) + (when (or (>= *current-describe-level* *describe-level*) + (member x *described-objects*)) + (return-from describe-aux x)) + (push x *described-objects*) + (typecase x + (symbol (describe-symbol x)) + (function (describe-function x)) + (package (describe-package x)) + (hash-table (describe-hash-table x)) + (structure (describe-structure x)) + (array (describe-array x)) + (fixnum (describe-fixnum x)) + (t (default-describe x))) + x) + + + +;;;; Implementation properties. + +;;; This supresses random garbage that users probably don't want to see. +;;; +(defparameter *implementation-properties* + '(%loaded-address + ;; + ;; Documentation properties: + %var-documentation %fun-documentation %struct-documentation + %type-documentation %setf-documentation %documentation)) + + +;;;; DESCRIBE methods. + +;;; DESC-DOC prints the specified kind of documentation about the given Symbol. +;;; +(defun desc-doc (symbol name string) + (let ((doc (documentation symbol name))) + (when (and doc (not (member doc *used-documentation*))) + (push doc *used-documentation*) + (format t "~&~A~& ~A" string doc)))) + + +(defun default-describe (x) + (format t "~&~S is a ~S." x (type-of x))) + +(defun describe-symbol (x) + (let ((package (symbol-package x))) + (if package + (multiple-value-bind (symbol status) + (find-symbol (symbol-name x) package) + (declare (ignore symbol)) + (format t "~&~A is an ~A symbol in the ~A package." x + (string-downcase (symbol-name status)) + (package-name (symbol-package x)))) + (format t "~&~A is an uninterned symbol." x))) + ;; + ;; Describe the value cell. + (when (boundp x) + (let ((value (symbol-value x)) + (constantp (constantp x))) + (cond ((get x 'globally-special) + (if constantp + (format t "~&It is a constant; its value is ~S." value) + (format t "~&It is a special variable; ~ + its current binding is ~S." + value))) + (t + (fresh-line) + (write-string "Its value is ") + (print-for-describe value nil))) + (desc-doc x 'variable + (format nil "~:[Variable~;Constant~] Documentation:" + constantp)) + (describe value))) + ;; + ;; Describe the function cell. + (cond ((macro-function x) + (let ((fun (macro-function x))) + (format t "~&Its macroexpansion function is ~A." fun) + (describe-function fun) + (desc-doc x 'function "Macro Documentation:"))) + ((fboundp x) + (describe-function (symbol-function x)))) + ;; + ;; Print other documentation. + (desc-doc x 'structure "Documentation on the structure:") + (desc-doc x 'type "Documentation on the type:") + (desc-doc x 'setf "Documentation on the SETF form:") + (dolist (assoc (get x '%documentation)) + (unless (member (cdr assoc) *used-documentation*) + (format t "~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc)))) + ;; + ;; Print out properties, possibly ignoring implementation details. + (do ((plist (symbol-plist X) (cddr plist)) + (properties-to-ignore (if *describe-implementation-details* + nil + *implementation-properties*))) + ((null plist) ()) + (unless (member (car plist) properties-to-ignore) + (format t "~&Its ~S property is ~S." (car plist) (cadr plist)) + (describe (cadr plist))))) + +(defun describe-structure (x) + (format t "~&~S is a structure of type ~A." x (svref x 0)) + (dolist (slot (cddr (inspect::describe-parts x))) + (format t "~%~A: ~S." (car slot) (cdr slot)))) + +(defun describe-array (x) + (let ((rank (array-rank x))) + (cond ((> rank 1) + (format t "~&~S is " x) + (write-string (if (%displacedp x) "a displaced" "an")) + (format t " array of rank ~A." rank) + (format t "~%Its dimensions are ~S." (array-dimensions x))) + (t + (format t "~&~S is a ~:[~;displaced ~]vector of length ~D." x + (%displacedp x) (length x)) + (if (array-has-fill-pointer-p x) + (format t "~&It has a fill pointer, currently ~d" + (fill-pointer x)) + (format t "~&It has no fill pointer.")))) + (format t "~&Its element type is ~S." (array-element-type x)))) + +(defmacro describe-function-arg-list (object test output) + `(progn + (print-for-describe ,object) + (if ,test + (write-string " is called with zero arguments.") + (indenting-further *standard-output* 2 + (format t " can be called with these arguments:~%") + ,output)))) + +(defun describe-function (x) + (case (%primitive get-vector-subtype x) + (#.%function-entry-subtype + (describe-function-compiled x)) + (#.%function-closure-subtype + (describe-function-lex-closure x)) + (t + (format t "~&It is an unknown type of function.")))) + +(defun describe-function-compiled (x) + (let ((args (%primitive header-ref x %function-entry-arglist-slot))) + (describe-function-arg-list + *current-describe-object* (string= args "()") (write-string args))) + (let ((*print-level* nil) + (*print-length* nil) + (type (%primitive header-ref x %function-entry-type-slot))) + (format t "~&Its argument types are:~% ~S" (second type)) + (format t "~&Its result type is:~% ~S" (third type))) + + (let ((name (%primitive header-ref x %function-name-slot))) + (when (symbolp name) + (desc-doc 'function name "Function Documention:"))) + + (let ((info (%primitive header-ref + (%primitive header-ref x + %function-entry-constants-slot) + %function-constants-debug-info-slot))) + (when info + (let ((sources (c::compiled-debug-info-source info))) + (format t "~&On ~A it was compiled from:" + (format-universal-time nil + (c::debug-source-compiled + (first sources)))) + (dolist (source sources) + (let ((name (c::debug-source-name source))) + (ecase (c::debug-source-from source) + (:file + (format t "~&~A " (namestring name)) + (ext:format-universal-time t (c::debug-source-created source))) + (:stream (format t "~&~S" name)) + (:lisp (format t "~&~S" name))))))))) + +(defun describe-function-lex-closure (x) + (print-for-describe x) + (format t " is a lexical closure.~%") + (format t "~&Its lexical environment is:") + (indenting-further *standard-output* 8 + (do ((i %function-closure-variables-offset (1+ i))) + ((= i (%primitive header-length x))) + (format t "~&~D: ~S" + (- i %function-closure-variables-offset) + (%primitive header-ref x i)))) + (describe-function-compiled (%primitive header-ref x %function-name-slot))) + + +(defun print-for-describe (x &optional (freshp t)) + (when freshp (fresh-line)) + (cond ((symbolp x) + (write-string (symbol-name x))) + (t + (princ x)))) + +(defun describe-fixnum (x) + (cond ((not (or *describe-verbose* (zerop *current-describe-level*)))) + ((primep x) + (format t "~&It is a prime number.")) + (t + (format t "~&It is a composite number.")))) + +(defun describe-hash-table (x) + (format t "~&~S is an ~a hash table." x (hash-table-kind x)) + (format t "~&Its size is ~d buckets." (hash-table-size x)) + (format t "~&Its rehash-size is ~d." (hash-table-rehash-size x)) + (format t "~&Its rehash-threshold is ~d." + (hash-table-rehash-threshold x)) + (format t "~&It currently holds ~d entries." + (hash-table-number-entries x))) + +(defun describe-package (x) + (describe-structure x) + (let* ((internal (package-internal-symbols x)) + (internal-count (- (package-hashtable-size internal) + (package-hashtable-free internal))) + (external (package-external-symbols x)) + (external-count (- (package-hashtable-size external) + (package-hashtable-free external)))) + (format t "~&~d symbols total: ~d internal and ~d external." + (+ internal-count external-count) internal-count external-count))) + diff --git a/code/error.lisp b/code/error.lisp new file mode 100644 index 000000000..34cd1ffc9 --- /dev/null +++ b/code/error.lisp @@ -0,0 +1,1237 @@ +;;; -*- Package: conditions; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This is a condition system for CMU Common Lisp. +;;; It was originally taken from some prototyping code written by KMP@Symbolics +;;; and massaged for our uses. +;;; + +(in-package "CONDITIONS") + +#-new-compiler +(eval-when (compile) + (setq lisp::*bootstrap-defmacro* t)) + +(in-package "LISP") +(export '(break error warn cerror + ;; + ;; The following are found in Macros.Lisp: + check-type assert etypecase ctypecase ecase ccase + ;; + ;; These are all the new things to export from "LISP" now that this + ;; proposal has been accepted. + *break-on-signals* *debugger-hook* signal handler-case handler-bind + ignore-errors define-condition make-condition with-simple-restart + restart-case restart-bind restart-name restart-name find-restart + compute-restarts invoke-restart invoke-restart-interactively abort + continue muffle-warning store-value use-value invoke-debugger restart + condition warning serious-condition simple-condition simple-warning + simple-error simple-condition-format-string + simple-condition-format-arguments storage-condition stack-overflow + storage-exhausted type-error type-error-datum + type-error-expected-type simple-type-error program-error + control-error stream-error stream-error-stream end-of-file file-error + file-error-pathname cell-error unbound-variable undefined-function + arithmetic-error arithmetic-error-operation arithmetic-error-operands + package-error package-error-package division-by-zero + floating-point-overflow floating-point-underflow)) + + +(in-package "CONDITIONS") + +;;;; Keyword utilities. + +(eval-when (eval compile load) + +(defun parse-keyword-pairs (list keys) + (do ((l list (cddr l)) + (k '() (list* (cadr l) (car l) k))) + ((or (null l) (not (member (car l) keys))) + (values (nreverse k) l)))) + +(defmacro with-keyword-pairs ((names expression &optional keywords-var) + &body forms) + (let ((temp (member '&rest names))) + (unless (= (length temp) 2) + (error "&rest keyword is ~:[missing~;misplaced~]." temp)) + (let ((key-vars (ldiff names temp)) + (key-var (or keywords-var (gensym))) + (rest-var (cadr temp))) + (let ((keywords (mapcar #'(lambda (x) + (intern (string x) ext:*keyword-package*)) + key-vars))) + `(multiple-value-bind (,key-var ,rest-var) + (parse-keyword-pairs ,expression ',keywords) + (let ,(mapcar #'(lambda (var keyword) + `(,var (getf ,key-var ,keyword))) + key-vars keywords) + ,@forms)))))) + +) ;eval-when + + + +;;;; Restarts. + +(defvar *restart-clusters* '()) + +(defun compute-restarts () + "Return a list of all the currently active restarts ordered from most + recently established to less recently established." + (copy-list (apply #'append *restart-clusters*))) + +(defun restart-print (restart stream depth) + (declare (ignore depth)) + (if *print-escape* + (format stream "#<~S.~X>" + (type-of restart) (system:%primitive lisp::make-fixnum restart)) + (restart-report restart stream))) + +(defstruct (restart (:print-function restart-print)) + name + function + report-function + interactive-function) + +(setf (documentation 'restart-name 'function) + "Returns the name of the given restart object.") + +(defun restart-report (restart stream) + (funcall (or (restart-report-function restart) + (let ((name (restart-name restart))) + #'(lambda (stream) + (if name (format stream "~S" name) + (format stream "~S" restart))))) + stream)) + +(defmacro restart-bind (bindings &body forms) + "Executes forms in a dynamic context where the given restart bindings are + in effect. Users probably want to use RESTART-CASE. When clauses contain + the same restart name, FIND-RESTART will find the first such clause." + `(let ((*restart-clusters* + (cons (list + ,@(mapcar #'(lambda (binding) + (unless (or (car binding) + (member :report-function + binding :test #'eq)) + (warn "Unnamed restart does not have a ~ + report function -- ~S" + binding)) + `(make-restart + :name ',(car binding) + :function ,(cadr binding) + ,@(cddr binding))) + bindings)) + *restart-clusters*))) + ,@forms)) + +(defun find-restart (name) + "Returns the first restart named name. If name is a restart, it is returned + if it is currently active. If no such restart is found, nil is returned. + It is an error to supply nil as a name." + (dolist (restart-cluster *restart-clusters*) + (dolist (restart restart-cluster) + (when (or (eq restart name) (eq (restart-name restart) name)) + (return-from find-restart restart))))) + + +(defun invoke-restart (restart &rest values) + "Calls the function associated with the given restart, passing any given + arguments. If the argument restart is not a restart or a currently active + non-nil restart name, then a control-error is signalled." + (let ((real-restart (find-restart restart))) + (unless real-restart + (error 'control-error + :format-string "Restart ~S is not active." + :format-arguments (list restart))) + (apply (restart-function real-restart) values))) + +(defun invoke-restart-interactively (restart) + "Calls the function associated with the given restart, prompting for any + necessary arguments. If the argument restart is not a restart or a + currently active non-nil restart name, then a control-error is signalled." + (let ((real-restart (find-restart restart))) + (unless real-restart + (error 'control-error + :format-string "Restart ~S is not active." + :format-arguments (list restart))) + (apply (restart-function real-restart) + (let ((interactive-function + (restart-interactive-function real-restart))) + (if interactive-function + (funcall interactive-function) + '()))))) + + +(defmacro restart-case (expression &body clauses) + "(RESTART-CASE form + {(case-name arg-list {keyword value}* body)}*) + The form is evaluated in a dynamic context where the clauses have special + meanings as points to which control may be transferred (see INVOKE-RESTART). + When clauses contain the same case-name, FIND-RESTART will find the first + such clause." + (flet ((transform-keywords (&key report interactive) + (let ((result '())) + (when report + (setq result (list* (if (stringp report) + `#'(lambda (stream) + (write-string ,report stream)) + `#',report) + :report-function + result))) + (when interactive + (setq result (list* `#',interactive + :interactive-function + result))) + (nreverse result)))) + (let ((temp-var (gensym)) + (outer-tag (gensym)) + (inner-tag (gensym)) + (tag-var (gensym)) + (data + (mapcar #'(lambda (clause) + (with-keyword-pairs ((report interactive &rest forms) + (cddr clause)) + (list (car clause) ;name=0 + (gensym) ;tag=1 + (transform-keywords :report report ;keywords=2 + :interactive interactive) + (cadr clause) ;bvl=3 + forms))) ;body=4 + clauses))) + `(let ((,outer-tag (cons nil nil)) + (,inner-tag (cons nil nil)) + ,temp-var ,tag-var) + (catch ,outer-tag + (catch ,inner-tag + (throw ,outer-tag + (restart-bind + ,(mapcar #'(lambda (datum) + (let ((name (nth 0 datum)) + (tag (nth 1 datum)) + (keys (nth 2 datum))) + `(,name #'(lambda (&rest temp) + (setf ,temp-var temp) + (setf ,tag-var ',tag) + (throw ,inner-tag nil)) + ,@keys))) + data) + ,expression))) + (case ,tag-var + ,@(mapcar #'(lambda (datum) + (let ((tag (nth 1 datum)) + (bvl (nth 3 datum)) + (body (nth 4 datum))) + `(,tag + (apply #'(lambda ,bvl ,@body) ,temp-var)))) + data))))))) +#| +This macro doesn't work in our system due to lossage in closing over tags. +The previous version is uglier, but it sets up unique run-time tags. + +(defmacro restart-case (expression &body clauses) + "(RESTART-CASE form + {(case-name arg-list {keyword value}* body)}*) + The form is evaluated in a dynamic context where the clauses have special + meanings as points to which control may be transferred (see INVOKE-RESTART). + When clauses contain the same case-name, FIND-RESTART will find the first + such clause." + (flet ((transform-keywords (&key report interactive) + (let ((result '())) + (when report + (setq result (list* (if (stringp report) + `#'(lambda (stream) + (write-string ,report stream)) + `#',report) + :report-function + result))) + (when interactive + (setq result (list* `#',interactive + :interactive-function + result))) + (nreverse result)))) + (let ((block-tag (gensym)) + (temp-var (gensym)) + (data + (mapcar #'(lambda (clause) + (with-keyword-pairs ((report interactive &rest forms) + (cddr clause)) + (list (car clause) ;name=0 + (gensym) ;tag=1 + (transform-keywords :report report ;keywords=2 + :interactive interactive) + (cadr clause) ;bvl=3 + forms))) ;body=4 + clauses))) + `(block ,block-tag + (let ((,temp-var nil)) + (tagbody + (restart-bind + ,(mapcar #'(lambda (datum) + (let ((name (nth 0 datum)) + (tag (nth 1 datum)) + (keys (nth 2 datum))) + `(,name #'(lambda (&rest temp) + (setq ,temp-var temp) + (go ,tag)) + ,@keys))) + data) + (return-from ,block-tag ,expression)) + ,@(mapcan #'(lambda (datum) + (let ((tag (nth 1 datum)) + (bvl (nth 3 datum)) + (body (nth 4 datum))) + (list tag + `(return-from ,block-tag + (apply #'(lambda ,bvl ,@body) + ,temp-var))))) + data))))))) +|# + +(defmacro with-simple-restart ((restart-name format-string + &rest format-arguments) + &body forms) + "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments) + body) + If restart-name is not invoked, then all values returned by forms are + returned. If control is transferred to this restart, it immediately + returns the values nil and t." + `(restart-case (progn ,@forms) + (,restart-name () + :report (lambda (stream) + (format stream ,format-string ,@format-arguments)) + (values nil t)))) + + + +;;;; Conditions. + +(defstruct (condition (:constructor |constructor for condition|) + (:predicate nil) + (:print-function condition-print)) + ) + +(defun condition-print (condition stream depth) + (declare (ignore depth)) + (if *print-escape* + (format stream "#<~S.~X>" + (type-of condition) + (system:%primitive lisp::make-fixnum condition)) + (condition-report condition stream))) + + +(eval-when (eval compile load) + +(defmacro parent-type (condition-type) `(get ,condition-type 'parent-type)) +(defmacro slots (condition-type) `(get ,condition-type 'slots)) +(defmacro conc-name (condition-type) `(get ,condition-type 'conc-name)) +(defmacro report-function (condition-type) + `(get ,condition-type 'report-function)) +(defmacro make-function (condition-type) `(get ,condition-type 'make-function)) + +) ;eval-when + +(defun condition-report (condition stream) + (do ((type (type-of condition) (parent-type type))) + ((not type) + (format stream "The condition ~A occurred." (type-of condition))) + (let ((reporter (report-function type))) + (when reporter + (funcall reporter condition stream) + (return nil))))) + +(setf (make-function 'condition) '|constructor for condition|) + +(defun make-condition (type &rest slot-initializations) + "Makes a condition of type type using slot-initializations as initial values + for the slots." + (let ((fn (make-function type))) + (cond ((not fn) (error 'simple-type-error + :datum type + :expected-type '(satisfies make-function) + :format-string "Not a condition type: ~S" + :format-arguments (list type))) + (t (apply fn slot-initializations))))) + + +;;; Some utilities used at macro expansion time. +;;; +(eval-when (eval compile load) + +(defmacro resolve-function (function expression resolver) + `(cond ((and ,function ,expression) + (cerror "Use only the :~A information." + "Only one of :~A and :~A is allowed." + ',function ',expression)) + (,expression (setq ,function ,resolver)))) + +(defun parse-new-and-used-slots (slots parent-type) + (let ((new '()) (used '())) + (dolist (slot slots) + (if (slot-used-p (car slot) parent-type) + (push slot used) + (push slot new))) + (values new used))) + +(defun slot-used-p (slot-name type) + (cond ((eq type 'condition) nil) + ((not type) (error "The type ~S does not inherit from condition." type)) + ((assoc slot-name (slots type))) + (t (slot-used-p slot-name (parent-type type))))) + +) ;eval-when + +(defmacro define-condition (name (parent-type) slot-specs &rest options) + "(DEFINE-CONDITION name (parent-type) + ( {slot-name | (slot-name) | (slot-name default-value)}*) + options)" + (let ((constructor (let ((*package* (find-package "CONDITIONS"))) + ;; Bind for the INTERN and the FORMAT. + (intern (format nil "Constructor for ~S" name))))) + (let ((slots (mapcar #'(lambda (slot-spec) + (if (atom slot-spec) (list slot-spec) slot-spec)) + slot-specs))) + (multiple-value-bind (new-slots used-slots) + (parse-new-and-used-slots slots parent-type) + (let ((conc-name-p nil) + (conc-name nil) + (report-function nil) + (documentation nil)) + (do ((o options (cdr o))) + ((null o)) + (let ((option (car o))) + (case (car option) ;should be ecase + (:conc-name + (setq conc-name-p t) + (setq conc-name (cadr option))) + (:report + (setq report-function + (if (stringp (cadr option)) + `(lambda (stream) + (write-string ,(cadr option) stream)) + (cadr option)))) + (:documentation (setq documentation (cadr option))) + (otherwise + (cerror "Ignore this DEFINE-CONDITION option." + "Invalid DEFINE-CONDITION option: ~S" option))))) + (unless conc-name-p + (setq conc-name + (intern (concatenate 'simple-string (symbol-name name) + "-") + *package*))) + ;; The following three forms are compile-time side-effects. For now, + ;; they affect the global environment, but with modified abstractions + ;; for parent-type, slots, and conc-name, the compiler could easily + ;; make them local. + (setf (parent-type name) parent-type) + (setf (slots name) slots) + (setf (conc-name name) conc-name) + ;; finally, the expansion ... + `(progn + (defstruct (,name + (:constructor ,constructor) + (:predicate nil) + (:copier nil) + (:print-function condition-print) + (:include ,parent-type ,@used-slots) + (:conc-name ,conc-name)) + ,@new-slots) + (setf (documentation ',name 'type) ',documentation) + (setf (parent-type ',name) ',parent-type) + (setf (slots ',name) ',slots) + (setf (conc-name ',name) ',conc-name) + (setf (report-function ',name) + ,(if report-function `#',report-function)) + (setf (make-function ',name) ',constructor) + ',name)))))) + + + +;;;; HANDLER-BIND and SIGNAL. + +(defvar *handler-clusters* nil) + +(defmacro handler-bind (bindings &body forms) + "(HANDLER-BIND ( {(type handler)}* ) body) + Executes body in a dynamic context where the given handler bindings are + in effect. Each handler must take the condition being signalled as an + argument. The bindings are searched first to last in the event of a + signalled condition." + (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings) + (error "Ill-formed handler bindings.")) + `(let ((*handler-clusters* + (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x))) + bindings)) + *handler-clusters*))) + ,@forms)) + +(defvar *break-on-signals* nil + "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will + enter the debugger prior to signalling that condition.") + +(defun signal (datum &rest arguments) + "Invokes the signal facility on a condition formed from datum and arguments. + If the condition is not handled, nil is returned. If + (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before + any signalling is done." + (let ((condition (coerce-to-condition datum arguments + 'simple-condition 'signal)) + (*handler-clusters* *handler-clusters*)) + (when (typep condition *break-on-signals*) + (break "~A~%Break entered because of *break-on-signals*." + condition)) + (loop + (unless *handler-clusters* (return)) + (let ((cluster (pop *handler-clusters*))) + (dolist (handler cluster) + (when (typep condition (car handler)) + (funcall (cdr handler) condition))))) + nil)) + +;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and +;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single +;;; argument that's directly usable by all the other routines. +;;; +(defun coerce-to-condition (datum arguments default-type function-name) + (cond ((typep datum 'condition) + (if arguments + (cerror "Ignore the additional arguments." + 'simple-type-error + :datum arguments + :expected-type 'null + :format-string "You may not supply additional arguments ~ + when giving ~S to ~S." + :format-arguments (list datum function-name))) + datum) + ((symbolp datum) ;Roughly, (subtypep datum 'condition). + (apply #'make-condition datum arguments)) + ((stringp datum) + (make-condition default-type + :format-string datum + :format-arguments arguments)) + (t + (error 'simple-type-error + :datum datum + :expected-type '(or symbol string) + :format-string "Bad argument to ~S: ~S" + :format-arguments (list function-name datum))))) + + + +;;;; INFINITE-ERROR-PROTECT. + +(defvar *error-system-initialized*) +(defvar *max-error-depth* 10 "The maximum number of nested errors allowed.") +(defvar *current-error-depth* 0 "The current number of nested errors.") + +;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of +;;; hyperspace. +;;; +(defmacro infinite-error-protect (form) + `(if (and (boundp '*error-system-initialized*) (numberp *current-error-depth*)) + (let ((*current-error-depth* (1+ *current-error-depth*))) + (if (> *current-error-depth* *max-error-depth*) + (error-error "Help! " *current-error-depth* " nested errors.") + ,form)) + (system:%primitive lisp::halt))) + +;;; These are used in ERROR-ERROR. +;;; +(defvar %error-error-depth% 0) +(defvar *error-throw-up-count* 0) + +(proclaim '(special lisp::*real-terminal-io*)) + +;;; ERROR-ERROR can be called when the error system is in trouble and needs +;;; to punt fast. Prints a message without using format. If we get into +;;; this recursively, then halt. +;;; +(defun error-error (&rest messages) + (let ((%error-error-depth% (1+ %error-error-depth%))) + (when (> *error-throw-up-count* 50) + (system:%primitive lisp::halt) + (throw 'lisp::top-level-catcher nil)) + (case %error-error-depth% + (1) + (2 + (setq *terminal-io* lisp::*real-terminal-io*)) + (3 + (incf *error-throw-up-count*) + (throw 'lisp::top-level-catcher nil)) + (t + (system:%primitive lisp::halt) + (throw 'lisp::top-level-catcher nil))) + + (dolist (item messages) (princ item *terminal-io*)) + (debug:internal-debug))) + + + +;;;; Fetching errorful function name. + +#+new-compiler +;;; FIND-NAME returns the name of a function if it is a subr or named-lambda. +;;; If the function is a regular lambda, the whole list is returned, and if +;;; the function can't be recognized, () is returned. +(defun find-name (function) + (declare (ignore function)) + 'hunoz) + +;;; GET-CALLER returns a form that returns the function which called the +;;; currently active function. +(defmacro get-caller () + 'nil) + + +;;;; ERROR, CERROR, BREAK, WARN. + +(define-condition serious-condition (condition) ()) + +(define-condition error (serious-condition) + ((function-name nil))) + +#+new-compiler +(defun error (datum &rest arguments) + "Invokes the signal facility on a condition formed from datum and arguments. + If the condition is not handled, the debugger is invoked." + (infinite-error-protect + (let ((condition (coerce-to-condition datum arguments 'simple-error 'error))) + (unless (error-function-name condition) + (setf (error-function-name condition) (find-name (get-caller)))) + (signal condition) + (invoke-debugger condition)))) + +#+new-compiler +;;; CERROR must take care to no use arguments when datum is already a condition +;;; object. Furthermore, we must set ERROR-FUNCTION-NAME here instead of +;;; letting ERROR do it, so we get the correct function name. +;;; +(defun cerror (continue-string datum &rest arguments) + (with-simple-restart + (continue "~A" (apply #'format nil continue-string arguments)) + (let ((condition (if (typep datum 'condition) + datum + (coerce-to-condition datum arguments + 'simple-error 'error)))) + (unless (error-function-name condition) + (setf (error-function-name condition) (find-name (get-caller)))) + (error condition))) + nil) + +#+new-compiler +(defun break (&optional (format-string "Break") &rest format-arguments) + "Prints a message and invokes the debugger without allowing any possibility + of condition handling occurring." + (with-simple-restart (continue "Return from BREAK.") + (invoke-debugger + (make-condition 'simple-condition + :format-string format-string + :format-arguments format-arguments))) + nil) + +(define-condition warning (condition) ()) + +(defvar *break-on-warnings* () + "If non-NIL, then WARN will enter a break loop before returning.") + +#+new-compiler +(defun warn (datum &rest arguments) + "Warns about a situation by signalling a condition formed by datum and + arguments. Before signalling, if *break-on-warnings* is set, then BREAK + is called. While the condition is being signaled, a muffle-warning restart + exists that causes WARN to immediately return nil." + (let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn))) + (check-type condition warning "a warning condition") + (if *break-on-warnings* + (break "~A~%Break entered because of *break-on-warnings*." + condition)) + (restart-case (signal condition) + (muffle-warning () + :report "Skip warning." + (return-from warn nil))) + (format *error-output* "~&Warning:~%~A~%" condition) + nil)) + + + +;;;; Condition definitions. + +;;; Serious-condition and error are defined on the previous page, so ERROR and +;;; CERROR can SETF a slot in the error condition object. +;;; + + +(defun simple-condition-printer (condition stream) + (apply #'format stream (simple-condition-format-string condition) + (simple-condition-format-arguments condition))) + +;;; The simple-condition type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING +;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the +;;; simple-condition, simple-warning, simple-type-error, and simple-error types. +;;; This seems to create some kind of bogus multiple inheritance that the user +;;; sees. +;;; +(define-condition simple-condition (condition) + (format-string + (format-arguments '())) + (:conc-name internal-simple-condition-) + (:report simple-condition-printer)) + +;;; The simple-warning type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING +;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the +;;; simple-condition, simple-warning, simple-type-error, and simple-error types. +;;; This seems to create some kind of bogus multiple inheritance that the user +;;; sees. +;;; +(define-condition simple-warning (warning) + (format-string + (format-arguments '())) + (:conc-name internal-simple-warning-) + (:report simple-condition-printer)) + + +(defun print-simple-error (condition stream) + (format stream "~&Error in function ~S.~%~?" + (internal-simple-error-function-name condition) + (internal-simple-error-format-string condition) + (internal-simple-error-format-arguments condition))) + +;;; The simple-error type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING +;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the +;;; simple-condition, simple-warning, simple-type-error, and simple-error types. +;;; This seems to create some kind of bogus multiple inheritance that the user +;;; sees. +;;; +(define-condition simple-error (error) + (format-string + (format-arguments '())) + (:conc-name internal-simple-error-) + (:report print-simple-error)) + + +(define-condition storage-condition (serious-condition) ()) + +(define-condition stack-overflow (storage-condition) ()) +(define-condition storage-exhausted (storage-condition) ()) + +(define-condition type-error (error) + (datum + expected-type)) + +;;; The simple-type-error type has a conc-name, so +;;; SIMPLE-CONDITION-FORMAT-STRING and SIMPLE-CONDITION-FORMAT-ARGUMENTS could +;;; be written to handle the simple-condition, simple-warning, +;;; simple-type-error, and simple-error types. This seems to create some kind +;;; of bogus multiple inheritance that the user sees. +;;; +(define-condition simple-type-error (type-error) + (format-string + (format-arguments '())) + (:conc-name internal-simple-type-error-) + (:report simple-condition-printer)) + +(define-condition case-failure (type-error) + (name + possibilities) + (:report + (lambda (condition stream) + (format stream "~S fell through ~S expression.~%Wanted one of ~:S." + (type-error-datum condition) + (case-failure-name condition) + (case-failure-possibilities condition))))) + + +;;; SIMPLE-CONDITION-FORMAT-STRING and SIMPLE-CONDITION-FORMAT-ARGUMENTS. +;;; These exist for the obvious types to seemingly give the impression of +;;; multiple inheritance. That is, the last three types inherit from warning, +;;; type-error, and error while inheriting from simple-condition also. +;;; +(defun simple-condition-format-string (condition) + (etypecase condition + (simple-condition (internal-simple-condition-format-string condition)) + (simple-warning (internal-simple-warning-format-string condition)) + (simple-type-error (internal-simple-type-error-format-string condition)) + (simple-error (internal-simple-error-format-string condition)))) +;;; +(defun simple-condition-format-arguments (condition) + (etypecase condition + (simple-condition (internal-simple-condition-format-arguments condition)) + (simple-warning (internal-simple-warning-format-arguments condition)) + (simple-type-error (internal-simple-type-error-format-arguments condition)) + (simple-error (internal-simple-error-format-arguments condition)))) + + +(define-condition program-error (error) ()) + + +(defun print-control-error (condition stream) + (apply #'format + stream "~&Error in function ~S.~%~?" + (control-error-function-name condition) + (control-error-format-string condition) + (control-error-format-arguments condition))) + +(define-condition control-error (error) + (format-string + (format-arguments nil)) + (:report print-control-error)) + + +(define-condition stream-error (error) (stream)) + +(define-condition end-of-file (stream-error) ()) + +(define-condition file-error (error) (pathname)) + +(define-condition package-error (error) (pathname)) + +(define-condition cell-error (error) (name)) + +(define-condition unbound-variable (cell-error) () + (:report (lambda (condition stream) + (format stream "The variable ~S is unbound." + (cell-error-name condition))))) + +(define-condition undefined-function (cell-error) () + (:report (lambda (condition stream) + (format stream "The function ~S is undefined." + (cell-error-name condition))))) + +(define-condition arithmetic-error (error) (operation operands)) + +(define-condition division-by-zero (arithmetic-error) ()) +(define-condition floating-point-overflow (arithmetic-error) ()) +(define-condition floating-point-underflow (arithmetic-error) ()) + + + +;;;; HANDLER-CASE and IGNORE-ERRORS. + +(defmacro handler-case (form &rest cases) + "(HANDLER-CASE form + { (type ([var]) body) }* ) + Executes form in a context with handlers established for the condition + types. A peculiar property allows type to be :no-error. If such a clause + occurs, and form returns normally, all its values are passed to this clause + as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one + var specification." + (let ((no-error-clause (assoc ':no-error cases))) + (if no-error-clause + (let ((normal-return (make-symbol "normal-return")) + (error-return (make-symbol "error-return"))) + `(block ,error-return + (multiple-value-call #'(lambda ,@(cdr no-error-clause)) + (block ,normal-return + (return-from ,error-return + (handler-case (return-from ,normal-return ,form) + ,@(remove no-error-clause cases))))))) + (let ((var (gensym)) + (outer-tag (gensym)) + (inner-tag (gensym)) + (tag-var (gensym)) + (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case)) + cases))) + `(let ((,outer-tag (cons nil nil)) + (,inner-tag (cons nil nil)) + ,var ,tag-var) + ,var ;ignoreable + (catch ,outer-tag + (catch ,inner-tag + (throw ,outer-tag + (handler-bind + ,(mapcar #'(lambda (annotated-case) + `(,(cadr annotated-case) + #'(lambda (temp) + ,(if (caddr annotated-case) + `(setq ,var temp) + '(declare (ignore temp))) + (setf ,tag-var + ',(car annotated-case)) + (throw ,inner-tag nil)))) + annotated-cases) + ,form))) + (case ,tag-var + ,@(mapcar #'(lambda (annotated-case) + (let ((body (cdddr annotated-case)) + (varp (caddr annotated-case))) + `(,(car annotated-case) + ,@(if varp + `((let ((,(car varp) ,var)) + ,@body)) + body)))) + annotated-cases)))))))) +#| +This macro doesn't work in our system due to lossage in closing over tags. +The previous version sets up unique run-time tags. + +(defmacro handler-case (form &rest cases) + "(HANDLER-CASE form + { (type ([var]) body) }* ) + Executes form in a context with handlers established for the condition + types. A peculiar property allows type to be :no-error. If such a clause + occurs, and form returns normally, all its values are passed to this clause + as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one + var specification." + (let ((no-error-clause (assoc ':no-error cases))) + (if no-error-clause + (let ((normal-return (make-symbol "normal-return")) + (error-return (make-symbol "error-return"))) + `(block ,error-return + (multiple-value-call #'(lambda ,@(cdr no-error-clause)) + (block ,normal-return + (return-from ,error-return + (handler-case (return-from ,normal-return ,form) + ,@(remove no-error-clause cases))))))) + (let ((tag (gensym)) + (var (gensym)) + (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case)) + cases))) + `(block ,tag + (let ((,var nil)) + ,var ;ignorable + (tagbody + (handler-bind + ,(mapcar #'(lambda (annotated-case) + (list (cadr annotated-case) + `#'(lambda (temp) + ,(if (caddr annotated-case) + `(setq ,var temp) + '(declare (ignore temp))) + (go ,(car annotated-case))))) + annotated-cases) + (return-from ,tag ,form)) + ,@(mapcan + #'(lambda (annotated-case) + (list (car annotated-case) + (let ((body (cdddr annotated-case))) + `(return-from + ,tag + ,(cond ((caddr annotated-case) + `(let ((,(caaddr annotated-case) + ,var)) + ,@body)) + ((not (cdr body)) + (car body)) + (t + `(progn ,@body))))))) + annotated-cases)))))))) +|# + +(defmacro ignore-errors (&rest forms) + "Executes forms after establishing a handler for all error conditions that + returns from this form nil and the condition signalled." + `(handler-case (progn ,@forms) + (error (condition) (values nil condition)))) + + + +;;;; Restart definitions. + +(define-condition abort-failure (control-error) () + (:report + "Found an \"abort\" restart that failed to transfer control dynamically.")) + +;;; ABORT signals an error in case there was a restart named abort that did +;;; not tranfer control dynamically. This could happen with RESTART-BIND. +;;; +(defun abort () + "Transfers control to a restart named abort, signalling a control-error if + none exists." + (invoke-restart 'abort) + (error 'abort-failure)) + + +(defun muffle-warning () + "Transfers control to a restart named muffle-warning, signalling a + control-error if none exists." + (invoke-restart 'muffle-warning)) + + +;;; DEFINE-NIL-RETURNING-RESTART finds the restart before invoking it to keep +;;; INVOKE-RESTART from signalling a control-error condition. +;;; +(defmacro define-nil-returning-restart (name args doc) + `(defun ,name ,args + ,doc + (if (find-restart ',name) (invoke-restart ',name ,@args)))) + +(define-nil-returning-restart continue () + "Transfer control to a restart named continue, returning nil if none exists.") + +(define-nil-returning-restart store-value (value) + "Transfer control and value to a restart named store-value, returning nil if + none exists.") + +(define-nil-returning-restart use-value (value) + "Transfer control and value to a restart named use-value, returning nil if + none exists.") + + + + +;;;; Internal Error Codes. + +;;; *Internal-error-table* contains a vector, by error code, of functions. +;;; This is used in %SP-INTERNAL-ERROR, and initialized MAKE-ERROR-TABLE. +;;; +(defvar *internal-error-table*) + +#+new-compiler +;;; %SP-INTERNAL-ERROR is called by the microcode when an internal error +;;; occurrs. It is simply a dispatch routine which looks up a specialized +;;; function to call in the special variable, *internal-error-table*. +;;; +;;; ERR-CODE -- a fixnum which identifies the specific error. +;;; PC -- the relative offset of the NEXT macro instruction to be +;;; executed in the code vector of the errorful function. +;;; ARG3 & ARG4 -- arbitrary meaning determined by ERR-CODE. +;;; +(defun lisp::%sp-internal-error (err-code arg3 arg4) + (infinite-error-protect + (funcall (svref *internal-error-table* err-code) + (find-name (get-caller)) + 0 + arg3 + arg4))) + +;;; DEF-INTERNAL-ERROR defines a form which can be put into the system init +;;; file (spinit, or vaxinit) to define the errors which the microcode may +;;; signal. The form looks like +;;; +;;; (def-internal-error err-code condition flag control-string &rest args) +;;; ERR-CODE -- the internal code for this error. less than or equal to +;;; max-internal-error which is declared in the init file. +;;; CONDITION -- the name of the error to signal +;;; FLAG -- one of CORRECTABLE, FATAL or SYSTEM-ERROR. (not evaluated) +;;; if CORRECTABLE, %sp-internal-error may return correction values +;;; if SYSTEM-ERROR, the CONDITION arg is ignored. +;;; CONTROL-STRING -- the error message as a format control string. +;;; ARGS -- The args to the control string. The 3rd & 4th args to +;;; %sp-internal-error are available as the variables ARG3 & ARG4. +;;; +;;; NOTE: system-error is never supplied, and condition is never used. Maybe +;;; it will be when we signal appropriate conditions for certain +;;; situations. +;;; + +;example +; (def-internal-error 6 :unbound-symbol correctable +; "Unbound symbol: ~s." arg3) + + +(defmacro def-internal-error (number condition flag control-string &rest args) + (declare (ignore condition)) + `(setf (svref *internal-error-table* ,number) + #'(lambda (callers-name PC arg3 arg4) + (declare (ignore ,@(unless (eq flag 'system-error) '(PC)) + ,@(unless (member 'arg3 args) '(arg3)) + ,@(unless (member 'arg4 args) '(arg4)))) + ,(case flag + ((fatal) `(error 'simple-error + :function-name callers-name + :format-string ,control-string + :format-arguments (list ,@args))) + ((correctable) `(cerror 'simple-error + :function-name callers-name + :format-string ,control-string + :format-arguments (list ,@args))))))) + + +(defconstant max-internal-error 100 + "The largest internal error number for Spice Lisp.") + +(proclaim '(special allocation-space)) + + +(defun make-error-table () + (setq *internal-error-table* + (make-array (1+ max-internal-error) + :initial-element + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (break "Undefined Error.")))) + + (def-internal-error 1 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'List) + (def-internal-error 2 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'Symbol) + (def-internal-error 3 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'Number) + (def-internal-error 4 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'Integer) + (def-internal-error 5 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'Ratio) + (def-internal-error 6 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'Complex) + (def-internal-error 7 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'Vector-like) + (def-internal-error 8 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'simple-vector) + (def-internal-error 9 :invalid-function fatal + "Invalid function: ~s." arg3) + (def-internal-error 10 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been a function or an array." arg3) + (def-internal-error 11 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'U-vector-like) + (def-internal-error 12 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." + arg3 'simple-bit-vector) + (def-internal-error 13 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 + 'simple-string) + (def-internal-error 14 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'character) + (def-internal-error 15 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." + arg3 'Control-Stack-Pointer) + (def-internal-error 16 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." + arg3 'Binding-Stack-Pointer) + (def-internal-error 17 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'Array) + (def-internal-error 18 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." + arg3 'Positive-Fixnum) + (def-internal-error 19 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'SAP-pointer) + (def-internal-error 20 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of tyep ~s." arg3 'system-pointer) + (def-internal-error 21 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'float) + (def-internal-error 22 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'rational) + (def-internal-error 23 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been a non-complex number." arg3) + + (def-internal-error 25 :unbound-variable fatal + "Unbound variable: ~s." arg3) + (def-internal-error 26 :undefined-function fatal + "Undefined function: ~s." arg3) + (def-internal-error 27 :error fatal + "Attempt to alter NIL.") + (def-internal-error 28 :error fatal + "Attempt to alter NIL.") + (def-internal-error 29 :error fatal + "Circularity detected in chain of symbols from definition cell of symbol ~S." + arg3) + + ;;Special because handlers won't work while allocation-space is wrong. + (setf (svref *internal-error-table* 24) + #'(lambda (callers-name ignore0 ignore1 ignore2) + (declare (ignore ignore0 ignore1 ignore2)) + (let ((bazfaz allocation-space)) + (setq allocation-space 0) + (error 'simple-error + :function-name callers-name + :format-string "Illegal allocation-space value: ~S." + :format-arguments (list bazfaz))))) + + (def-internal-error 30 :error fatal + "Illegal u-vector access type: ~s." arg3) + (def-internal-error 31 :error fatal + "Illegal vector length: ~s." arg3) + (def-internal-error 32 :error fatal + "Vector index, ~s, out of bounds." arg3) + (def-internal-error 33 :error fatal + "Illegal index: ~s." arg3) + (def-internal-error 34 :error fatal + "Illegal shrink value: ~s." arg3) + (def-internal-error 35 :error fatal + "Shrink value, ~s, is greater than current length of ~s." arg3 arg4) + (def-internal-error 36 :error fatal + "Illegal data vector, ~S, in an array." arg3) + (def-internal-error 37 :error fatal + "Too few arguments passed to two or three dimension array access miscop.") + (def-internal-error 38 :error fatal + "Too many arguments passed to two or three dimension array access miscop.") + (def-internal-error 39 :error fatal + "Illegal to allocate vector of size: ~s." arg3) + + (def-internal-error 40 :error fatal + "Illegal byte pointer: (byte ~s ~s)." arg3 arg4) + (def-internal-error 41 :error fatal + "Illegal position, ~s, in byte spec." arg3) + (def-internal-error 42 :error fatal + "Illegal size, ~s, in byte spec." arg3) + (def-internal-error 43 :error fatal + "Illegal shift count: ~s." arg3) + (def-internal-error 44 :error fatal + "Illegal boole operation: ~s." arg3) + + (def-internal-error 50 :error fatal "Wrong number of arguments: ~D." arg3) + + (def-internal-error 55 :error fatal + "~s is not <= to ~s (Alien index out of bounds.)" arg3 arg4) + + (def-internal-error 60 :error fatal + "Attempt to divide ~s by ~s." arg3 arg4) + (def-internal-error 61 :unseen-throw-tag fatal + "No catcher for throw tag ~s." arg3) + (def-internal-error 62 :error fatal + "Something using ~S and ~S lead to a short-float underflow." arg3 arg4) + (def-internal-error 63 :error fatal + "Something using ~S and ~S lead to a short-float overflow." arg3 arg4) +#| + (def-internal-error 64 :error fatal + "Something using ~S and ~S lead to a single-float underflow." arg3 arg4) + (def-internal-error 65 :error fatal + "Something using ~S and ~S lead to a single-float overflow." arg3 arg4) +|# + (def-internal-error 66 :error fatal + "Something using ~S and ~S lead to a long-float underflow." arg3 arg4) + (def-internal-error 67 :error fatal + "Something using ~S and ~S lead to a long-float overflow." arg3 arg4) + (def-internal-error 68 :error fatal + "Something using ~S caused a short-float underflow." arg3) + (def-internal-error 69 :error fatal + "Something using ~S caused a short-float overflow." arg3) + (def-internal-error 70 :error fatal + "Something using ~S caused a long-float underflow." arg3) + (def-internal-error 71 :error fatal + "Something using ~S caused a long-float overflow." arg3) + (def-internal-error 72 :error fatal + "~S is not a legal argument to log, it should be non-zero." arg3) + (def-internal-error 73 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'string-char) + (def-internal-error 74 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'short-float) + (def-internal-error 75 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'long-float) + (def-internal-error 76 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'fixnum) + (def-internal-error 77 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 'cons) + (def-internal-error 78 :error fatal + "Invalid exit.") + (def-internal-error 79 :error fatal + "Odd number of arguments in keyword part of argument list.") + (def-internal-error 80 :error fatal + "~S is not a known keyword argument specifier." arg3) + (def-internal-error 81 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 arg4) + (def-internal-error 82 :wrong-type-argument fatal + "Wrong type argument, ~s, should have been of type ~s." arg3 + '(or function symbol)) + (def-internal-error 83 :error fatal + "~S is not = to ~S (Alien index out of bounds.)" arg3 arg4) + + ) + + + +;;; ERROR-INIT is called at init time to initialize the error system. +;;; It initializes the internal error table, and sets a variable. +;;; +(defun error-init () + (make-error-table) + (setq *error-system-initialized* t)) + +#-new-compiler +(eval-when (compile) + (setq lisp::*bootstrap-defmacro* nil)) diff --git a/code/eval.lisp b/code/eval.lisp new file mode 100644 index 000000000..07da893c9 --- /dev/null +++ b/code/eval.lisp @@ -0,0 +1,366 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; +(in-package "LISP") +(export '(eval *evalhook* + *applyhook* evalhook applyhook constantp quote proclaim + eval-when progn prog1 prog2 let let* + do do* dotimes dolist progv and or cond if the + macro-function special-form-p *macroexpand-hook* + macroexpand-1 macroexpand block return-from + return function setq psetq apply funcall + compiler-let progv flet labels macrolet + mapcar maplist mapc mapl mapcan mapcon + tagbody prog prog* go + values multiple-values-limit + values-list multiple-value-list multiple-value-call + multiple-value-prog1 multiple-value-bind multiple-value-setq + catch unwind-protect throw defun + lambda-list-keywords call-arguments-limit lambda-parameters-limit + function-lambda-expression + ;; + ;; Declaration symbols referenced in the cold load. + declare special + ;; + ;; Magical markers... + lambda &optional &rest &key &aux &body &whole + &allow-other-keys &environment)) + +(export '(eval::interpreted-function-p + eval::interpreted-function-lambda-expression) + "EVAL") +(import '(eval::*eval-stack-top*)) + +(in-package 'system) +(export '(parse-body find-if-in-closure)) + +(in-package "LISP") + + +(defconstant lambda-list-keywords + '(&optional &rest &key &aux &body &whole &allow-other-keys &environment) + "Keywords that you can put in a lambda-list, supposing you should want + to do such a thing.") + +(defconstant call-arguments-limit most-positive-fixnum + "The exclusive upper bound on the number of arguments which may be passed + to a function, including rest args.") + +(defconstant lambda-parameters-limit most-positive-fixnum + "The exclusive upper bound on the number of parameters which may be specifed + in a given lambda list. This is actually the limit on required and optional + parameters. With &key and &aux you can get more.") + +(defconstant multiple-values-limit most-positive-fixnum + "The exclusive upper bound on the number of multiple-values that you can + have.") + + + +;;;; EVAL and friends. + +;;; +;;; This flag is used by EVAL-WHEN to keep track of when code has already been +;;; evaluated so that it can avoid multiple evaluation of nested EVAL-WHEN +;;; (COMPILE)s. +(defvar *already-evaled-this* nil) + +;;; +;;; This needs to be initialized in the cold load, since the top-level catcher +;;; will always restore the initial value. +(defvar *eval-stack-top* 0) + +;;; EVAL -- Public +;;; +;;; Pick off a few easy cases, and call INTERNAL-EVAL for the rest. If +;;; *ALREADY-EVALED-THIS* is true, then we bind it to NIL before doing a call +;;; so that the effect is confined to the lexical scope of the EVAL-WHEN. +;;; +(defun eval (exp) + "Evaluates its single arg in a null lexical environment, returns the + result or results." + (let ((exp (macroexpand exp))) + (typecase exp + (symbol (symbol-value exp)) + (list + (let ((name (first exp)) + (args (1- (length exp)))) + (case name + (function + (unless (= args 1) + (error "Wrong number of args to FUNCTION:~% ~S." exp)) + (let ((name (second exp))) + (if (or (atom name) + (and (consp name) + (eq (car name) 'setf))) + (fdefinition name) + (eval:make-interpreted-function name)))) + (quote + (unless (= args 1) + (error "Wrong number of args to QUOTE:~% ~S." exp)) + (second exp)) + (setq + (unless (evenp args) + (error "Odd number of args to SETQ:~% ~S." exp)) + (unless (zerop args) + (do ((name (cdr exp) (cddr name))) + ((null name) + (do ((args (cdr exp) (cddr args))) + ((null (cddr args)) + (set (first args) (eval (second args)))) + (set (first args) (eval (second args))))) + (unless (eq (info variable kind (first name)) :special) + (return (eval:internal-eval exp)))))) + ((progn) + (when (> args 0) + (dolist (x (butlast (rest exp)) (eval (car (last exp)))) + (eval x)))) + (t + (if (and (symbolp name) + (eq (info function kind name) :function)) + (collect ((args)) + (dolist (arg (rest exp)) + (args (eval arg))) + (if *already-evaled-this* + (let ((*already-evaled-this* nil)) + (apply (symbol-function name) (args))) + (apply (symbol-function name) (args)))) + (eval:internal-eval exp)))))) + (t + exp)))) + + +;;; INTERPRETED-FUNCTION-P -- Interface +;;; +;;; This is defined here so that the printer &c can call it before the full +;;; interpreter is loaded. +;;; +(defun eval:interpreted-function-p (x) + (and (functionp x) + (= (%primitive get-vector-subtype x) %function-closure-subtype) + (fboundp 'eval::leaf-value) + (let ((const (%primitive header-ref + (%primitive header-ref x %function-name-slot) + %function-entry-constants-slot))) + (or (eq (%primitive header-ref #'eval::leaf-value + %function-entry-constants-slot) + const) + (eq (%primitive header-ref #'eval:make-interpreted-function + %function-entry-constants-slot) + const))))) + + +;;; FUNCTION-LAMBDA-EXPRESSION -- Public +;;; +;;; If interpreted, use the interpreter interface. Otherwise, see if it was +;;; compiled with COMPILE. If that fails, check for an inline expansion. +;;; +(defun function-lambda-expression (fun) + "Given a function, return three values: + 1] A lambda expression that could be used to define the function, or NIL if + the definition isn't available. + 2] NIL if the function was definitely defined in a null lexical environment, + and T otherwise. + 3] Some object that \"names\" the function. Although this is allowed to be + any object, CMU CL always returns a valid function name or a string." + (declare (type function fun)) + (if (eval:interpreted-function-p fun) + (eval:interpreted-function-lambda-expression fun) + (case (%primitive get-vector-subtype fun) + (#.%function-closure-subtype + (function-lambda-expression + (%primitive header-ref fun %function-name-slot))) + ((#.%function-entry-subtype #.%function-closure-entry-subtype) + (let ((name (%primitive header-ref fun %function-name-slot)) + (info (%primitive header-ref + (%primitive header-ref fun + %function-entry-constants-slot) + %function-constants-debug-info-slot))) + (if info + (let ((source (first (c::compiled-debug-info-source info)))) + (cond ((eq (c::debug-source-from source) :lisp) + (values (c::debug-source-name source) + nil name)) + ((stringp name) + (values nil t name)) + (t + (let ((exp (info function inline-expansion name))) + (if exp + (values exp nil name) + (values nil t name)))))) + (values nil t name))))))) + + +;;; FIND-IF-IN-CLOSURE -- Interface +;;; +;;; Like FIND-IF, only we do it on a compiled closure's environment. +;;; +(defun find-if-in-closure (test fun) + (do ((i %function-closure-variables-offset (1+ i)) + (len (%primitive header-length fun))) + ((= i len) nil) + (let ((elt (%primitive header-ref fun i))) + (when (funcall test elt) + (return elt))))) + +(defvar *evalhook* nil + "Used to substitute another function for EVAL, for use by STEP, etc. + If *EVALHOOK* is not NIL, its value must be a function of the two + arguments, the form to evaluate and the environment to evaluate in. + This function does the evaluation instead of EVAL.") + +(defvar *applyhook* nil + "Used to substitute another function for the implicit APPLY normally done + within EVAL. If *APPLYHOOK* is not NIL, its value must be a function + which takes as arguments the function to be applied, the list of arguments + it is to be applied to, and the lexical environment. This function does + the application instead of EVAL.") + +#| +(defun evalhook (form evalhookfn applyhookfn &optional env) + "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound + to applyhookfn. Ignores these hooks once, for the top-level evaluation + of Form." + ###) +|# + +#| +(defun applyhook (function args evalhookfn applyhookfn &optional env) + "Applies Function to Args, with *Evalhook* bound to Evalhookfn and with + *Applyhook* bound to Applyhookfn. Ignores the hook function once, for the + top-level application of Function to Args." + ###) +|# + + +;;;; Syntactic environment access: + +(defun special-form-p (symbol) + "If the symbol globally names a special form, returns the definition in a + mysterious internal format (a FEXPR), else returns NIL." + (declare (symbol symbol)) + (eq (info function kind symbol) :special-form)) + +(defvar *macroexpand-hook* 'funcall + "The value of this variable must be a function that can take three + arguments, a macro expander function, the macro form to be expanded, + and the lexical environment to expand in. The function should + return the expanded form. This function is called by MACROEXPAND-1 + whenever a runtime expansion is needed. Initially this is set to + FUNCALL.") + + +;;; Macroexpand-1 -- Public +;;; +;;; The Env arg may actually be the compiler *fenv* alist. +;;; +(defun macroexpand-1 (form &optional env) + "If form is a macro, expands it once. Returns two values, the + expanded form and a T-or-NIL flag indicating whether the form was, + in fact, a macro. Env is the lexical environment to expand in, + which defaults to the null environment." + (let ((fenv #|(if (listp env) env + (lexical-environment-fenv env))|# + env)) + (if (and (consp form) (symbolp (car form))) + (let ((local-def (cdr (assoc (car form) fenv)))) + (if local-def + (if (and (consp local-def) (eq (car local-def) 'MACRO)) + (values (funcall *macroexpand-hook* (cdr local-def) + form fenv) + t) + (values form nil)) + (let ((global-def (macro-function (car form)))) + (if global-def + (values (funcall *macroexpand-hook* global-def form fenv) + t) + (values form nil))))) + (values form nil)))) + + +(defun macroexpand (form &optional env) + "If Form is a macro call, then the form is expanded until the result is not + a macro. Returns as multiple values, the form after any expansion has + been done and T if expansion was done, or NIL otherwise. Env is the + lexical environment to expand in, which defaults to the null environment." + (prog (flag) + (multiple-value-setq (form flag) (macroexpand-1 form env)) + (unless flag (return (values form nil))) + loop + (multiple-value-setq (form flag) (macroexpand-1 form env)) + (if flag (go loop) (return (values form t))))) + + +(defun macro-function (symbol) + "If the symbol globally names a macro, returns the expansion function, + else returns NIL." + (declare (symbol symbol)) + (if (eq (info function kind symbol) :macro) + (info function macro-function symbol) + nil)) + + +(defun (setf macro-function) (symbol function) + (declare (symbol symbol) (type function function)) + + (when (eq (info function kind symbol) :special-form) + (error "~S names a special form." symbol)) + + (setf (info function kind symbol) :macro) + (setf (info function macro-function symbol) function) + (fmakunbound symbol) + function) + + +(defun constantp (object) + "True of any Lisp object that has a constant value: types that eval to + themselves, keywords, constants, and list whose car is QUOTE." + (typecase object + (number t) + (character t) + (array t) + (symbol + (eq (info variable kind object) :constant)) + (list (eq (car object) 'quote)))) + + +;;; Function invocation: + +(defun apply (function arg &rest args) + "Applies FUNCTION to a list of arguments produced by evaluating ARGS in + the manner of LIST*. That is, a list is made of the values of all but the + last argument, appended to the value of the last argument, which must be a + list." + (cond ((atom args) + (apply function arg)) + ((atom (cdr args)) + (apply function (cons arg (car args)))) + (t (do* ((a1 args a2) + (a2 (cdr args) (cdr a2))) + ((atom (cdr a2)) + (rplacd a1 (car a2)) + (apply function (cons arg args))))))) + + +(defun funcall (function &rest arguments) + "Calls Function with the given Arguments." + (apply function arguments)) + + + +;;; Multiple-Value forms: + +(defun values (&rest values) + "Returns all of its arguments, in order, as values." + (values-list values)) + +(defun values-list (list) + "Returns all of the elements of List, in order, as values." + (values-list list)) diff --git a/code/extensions.lisp b/code/extensions.lisp new file mode 100644 index 000000000..8e7ea31c0 --- /dev/null +++ b/code/extensions.lisp @@ -0,0 +1,349 @@ +;;; -*- Log: code.log; Package: Extensions -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Spice Lisp extensions to the language. +;;; +;;; Letf written by Steven Handerson. +;;; +;;; ********************************************************************** +(in-package "EXTENSIONS") + +(export '(letf* letf dovector deletef indenting-further + read-char-no-edit listen-skip-whitespace concat-pnames + iterate once-only collect do-anonymous undefined-value)) + +(import 'lisp::whitespace-char-p) + + +;;; Undefined-Value -- Public +;;; +;;; This is here until we figure out what to do with it. +;;; +(proclaim '(inline undefined-value)) +(defun undefined-value () + '%undefined%) + + +(defun skip-whitespace (&optional (stream *standard-input*)) + (loop (let ((char (read-char stream))) + (if (not (lisp::whitespacep char)) + (return (unread-char char stream)))))) + + +(defun listen-skip-whitespace (&optional (stream *standard-input*)) + "See listen. Any whitespace in the input stream will be flushed." + (do ((char (read-char-no-hang stream nil nil nil) + (read-char-no-hang stream nil nil nil))) + ((null char) nil) + (cond ((not (whitespace-char-p char)) + (unread-char char stream) + (return T))))) + +;;; These macros waste time as opposed to space. + +(defmacro letf* (bindings &body body &environment env) + "Does what one might expect, saving the old values and setting the generalized + variables to the new values in sequence. Unwind-protects and get-setf-method + are used to preserve the semantics one might expect in analogy to let*, + and the once-only evaluation of subforms." + (labels ((do-bindings + (bindings) + (cond ((null bindings) body) + (t (multiple-value-bind (dummies vals newval setter getter) + (lisp::foo-get-setf-method (caar bindings) env) + (let ((save (gensym))) + `((let* (,@(mapcar #'list dummies vals) + (,(car newval) ,(cadar bindings)) + (,save ,getter)) + (unwind-protect + (progn ,setter + ,@(do-bindings (cdr bindings))) + (setq ,(car newval) ,save) + ,setter))))))))) + (car (do-bindings bindings)))) + + +(defmacro letf (bindings &body body &environment env) + "Like letf*, but evaluates all the implicit subforms and new values of all + the implied setfs before altering any values. However, the store forms + (see get-setf-method) must still be evaluated in sequence. Uses unwind- + protects to protect the environment." + (let (temps) + (labels + ((do-bindings + (bindings) + (cond ((null bindings) body) + (t (let ((binding (car bindings))) + (multiple-value-bind (dummies vals newval setter getter) + (lisp::foo-get-setf-method (car binding) env) + (let ((save (gensym))) + (mapcar #'(lambda (a b) (push (list a b) temps)) + dummies vals) + (push (list save getter) temps) + (push (list (car newval) (cadr binding)) temps) + `((unwind-protect + (progn ,setter + ,@(do-bindings (cdr bindings))) + (setq ,(car newval) ,save) + ,setter))))))))) + (let ((form (car (do-bindings bindings)))) + `(let* ,(nreverse temps) + ,form))))) + + +(define-setf-method logbitp (index int &environment env) + (multiple-value-bind (temps vals stores store-form access-form) + (lisp::foo-get-setf-method int env) + (let ((ind (gensym)) + (store (gensym)) + (stemp (first stores))) + (values `(,ind ,@temps) + `(,index + ,@vals) + (list store) + `(let ((,stemp + (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form))) + ,store-form + ,store) + `(logbitp ,ind ,access-form))))) + + +;;; Indenting-Further is a user-level macro which may be used to locally increment +;;; the indentation of a stream. + +(defmacro indenting-further (stream more &rest body) + "Causes the output of the indenting Stream to indent More spaces. More is + evaluated twice." + `(unwind-protect + (progn + (incf (lisp::indenting-stream-indentation ,stream) ,more) + ,@body) + (decf (lisp::indenting-stream-indentation ,stream) ,more))) + + +;;; Deletef + +(defmacro deletef (elt list &rest keys &environment env) + (multiple-value-bind (dummies vals newval setter getter) + (lisp::foo-get-setf-method list env) + (let ((eltsym (gensym)) + (listsym (gensym))) + `(let* ((,eltsym ,elt) + ,@(mapcar #'list dummies vals) + (,listsym ,getter) + (,(car newval) (delete ,eltsym ,listsym ,@keys))) + ,setter)))) + + +(defmacro dovector ((elt vector) &rest forms) + "Just like dolist, but with one-dimensional arrays." + (let ((index (gensym)) + (length (gensym)) + (vec (gensym))) + `(let ((,vec ,vector)) + (do ((,index 0 (1+ ,index)) + (,length (length ,vec))) + ((>= ,index ,length) nil) + (let ((,elt (aref ,vec ,index))) + ,@forms))))) + + +(eval-when (compile load eval) + (defun concat-pnames (name1 name2) + (if name1 + (intern (concatenate 'simple-string (symbol-name name1) + (symbol-name name2))) + name2))) + + +;;; Iterate -- Public +;;; +;;; The ultimate iteration macro... +;;; +(defmacro iterate (name binds &body body) + "Iterate Name ({(Var Initial-Value)}*) Declaration* Form* + This is syntactic sugar for Labels. It creates a local function Name with + the specified Vars as its arguments and the Declarations and Forms as its + body. This function is then called with the Initial-Values, and the result + of the call is return from the macro." + (dolist (x binds) + (unless (and (listp x) + (= (length x) 2)) + (error "Malformed iterate variable spec: ~S." x))) + + `(labels ((,name ,(mapcar #'first binds) ,@body)) + (,name ,@(mapcar #'second binds)))) + + +;;;; The Collect macro: + +;;; Collect-Normal-Expander -- Internal +;;; +;;; This function does the real work of macroexpansion for normal collection +;;; macros. N-Value is the name of the variable which holds the current +;;; value. Fun is the function which does collection. Forms is the list of +;;; forms whose values we are supposed to collect. +;;; +(defun collect-normal-expander (n-value fun forms) + `(progn + ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms) + ,n-value)) + +;;; Collect-List-Expander -- Internal +;;; +;;; This function deals with the list collection case. N-Tail is the pointer +;;; to the current tail of the list, which is NIL if the list is empty. +;;; +(defun collect-list-expander (n-value n-tail forms) + (let ((n-res (gensym))) + `(progn + ,@(mapcar #'(lambda (form) + `(let ((,n-res (cons ,form nil))) + (cond (,n-tail + (setf (cdr ,n-tail) ,n-res) + (setq ,n-tail ,n-res)) + (t + (setq ,n-tail ,n-res ,n-value ,n-res))))) + forms) + ,n-value))) + + +;;; Collect -- Public +;;; +;;; The ultimate collection macro... +;;; +(defmacro collect (collections &body body) + "Collect ({(Name [Initial-Value] [Function])}*) {Form}* + Collect some values somehow. Each of the collections specifies a bunch of + things which collected during the evaluation of the body of the form. The + name of the collection is used to define a local macro, a la MACROLET. + Within the body, this macro will evaluate each of its arguments and collect + the result, returning the current value after the collection is done. The + body is evaluated as a PROGN; to get the final values when you are done, just + call the collection macro with no arguments. + + Initial-Value is the value that the collection starts out with, which + defaults to NIL. Function is the function which does the collection. It is + a function which will accept two arguments: the value to be collected and the + current collection. The result of the function is made the new value for the + collection. As a totally magical special-case, the Function may be Collect, + which tells us to build a list in forward order; this is the default. If an + Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the + end. Note that Function may be anything that can appear in the functional + position, including macros and lambdas." + + (let ((macros ()) + (binds ())) + (dolist (spec collections) + (unless (<= 1 (length spec) 3) + (error "Malformed collection specifier: ~S." spec)) + (let ((n-value (gensym)) + (name (first spec)) + (default (second spec)) + (kind (or (third spec) 'collect))) + (push `(,n-value ,default) binds) + (if (eq kind 'collect) + (let ((n-tail (gensym))) + (if default + (push `(,n-tail (last ,n-value)) binds) + (push n-tail binds)) + (push `(,name (&rest args) + (collect-list-expander ',n-value ',n-tail args)) + macros)) + (push `(,name (&rest args) + (collect-normal-expander ',n-value ',kind args)) + macros)))) + `(macrolet ,macros (let* ,(nreverse binds) ,@body)))) + + +;;;; The Once-Only macro: + +;;; Once-Only -- Interface +;;; +;;; Once-Only is a utility useful in writing source transforms and macros. +;;; It provides an easy way to wrap a let around some code to ensure that some +;;; forms are only evaluated once. +;;; +(defmacro once-only (specs &body body) + "Once-Only ({(Var Value-Expression)}*) Form* + Create Let which evaluates each Value-Expression, binding a temporary + variable to the result, and wrapping the Let around the result of the + evaluation of Body. Within the body, each Var is bound to the corresponding + temporary variable. If the Value-Expression is a constant, then we just pass + it through." + (let ((n-binds (gensym)) + (n-temp (gensym))) + (collect ((names) + (temp-binds)) + (dolist (spec specs) + (when (/= (length spec) 2) + (error "Malformed Once-Only binding spec: ~S." spec)) + (let ((name (first spec)) + (exp (second spec))) + (names `(,name ,exp)) + (temp-binds + `(let ((,n-temp (gensym))) + (,n-binds `(,,n-temp ,,name)) + (setq ,name ,n-temp))))) + `(let ,(names) + (collect ((,n-binds)) + ,@(temp-binds) + (list 'let (,n-binds) (progn ,@body))))))) + + +;;;; DO-ANONYMOUS: + +;;; ### Bootstrap hack... Renamed to avoid clobbering function in bootstrap +;;; environment. +;;; +(defun lisp::do-do-body (varlist endlist code decl bind step name block) + (let* ((inits ()) + (steps ()) + (l1 (gensym)) + (l2 (gensym))) + ;; Check for illegal old-style do. + (when (or (not (listp varlist)) (atom endlist)) + (error "Ill-formed ~S -- possibly illegal old style DO?" name)) + ;; Parse the varlist to get inits and steps. + (dolist (v varlist) + (cond ((symbolp v) (push v inits)) + ((listp v) + (unless (symbolp (first v)) + (error "~S step variable is not a symbol: ~S" name (first v))) + (case (length v) + (1 (push (first v) inits)) + (2 (push v inits)) + (3 (push (list (first v) (second v)) inits) + (setq steps (list* (third v) (first v) steps))) + (t (error "~S is an illegal form for a ~S varlist." v name)))) + (t (error "~S is an illegal form for a ~S varlist." v name)))) + ;; And finally construct the new form. + `(block ,BLOCK + (,bind ,(nreverse inits) + ,@decl + (tagbody + (go ,L2) + ,L1 + ,@code + (,step ,@(nreverse steps)) + ,L2 + (unless ,(car endlist) (go ,L1)) + (return-from ,BLOCK (progn ,@(cdr endlist)))))))) + + +(defmacro do-anonymous (varlist endlist &body (body decls)) + "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* + Like DO, but has no implicit NIL block. Each Var is initialized in parallel + to the value of the specified Init form. On subsequent iterations, the Vars + are assigned the value of the Step form (if any) in paralell. The Test is + evaluated before each evaluation of the body Forms. When the Test is true, + the the Exit-Forms are evaluated as a PROGN, with the result being the value + of the DO." + (lisp::do-do-body varlist endlist body decls 'let 'psetq + 'do-anonymous (gensym))) diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp new file mode 100644 index 000000000..f7c0634af --- /dev/null +++ b/code/fdefinition.lisp @@ -0,0 +1,68 @@ +;;; -*- Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Functions that hack on the global function namespace (primarily +;;; concerned with SETF functions here.) +;;; +;;; Written by Rob MacLachlan +;;; +(in-package 'lisp) +(export '(fdefinition fboundp fmakunbound)) + +(defvar *setf-functions* (make-hash-table :test #'equal)) + +(eval-when (compile eval) + +;;; With-Function-Name -- Internal +;;; +(defmacro with-function-name (name symbol-form setf-form) + `(typecase ,name + (symbol ,symbol-form) + (cons + (unless (and (eq (car ,name) 'setf) + (consp (cdr ,name)) + (symbolp (cadr ,name))) + (error "Malformed function name: ~S." ,name)) + ,setf-form) + (t + (error "Malformed function name: ~S." ,name)))) + +); Eval-When (Compile Eval) + +(defun fdefinition (name) + "Return Name's global function definition." + (with-function-name name + (careful-symbol-function name) + (or (gethash (cadr name) *setf-functions*) + (error "Undefined function: ~S." name)))) + +(defsetf fdefinition %set-fdefinition) + +(defun %set-fdefinition (name new-value) + "Set Name's global function definition." + (declare (type function new-value)) + (with-function-name name + (set-symbol-function-carefully name new-value) + (setf (gethash (cadr name) *setf-functions*) new-value))) + +#+new-compiler +(defun fboundp (name) + "Return true if Name has a global function definition." + (with-function-name name + (functionp (%primitive fast-symbol-function name)) + (functionp (gethash (cadr name) *setf-functions*)))) + +#+new-compiler +(defun fmakunbound (name) + "Make Name have no global function definition." + (with-function-name name + (%primitive set-symbol-function name + (%primitive make-immediate-type 0 %trap-type)) + (remhash (cadr name) *setf-functions*)) + t) diff --git a/code/filesys.lisp b/code/filesys.lisp new file mode 100644 index 000000000..c317b9613 --- /dev/null +++ b/code/filesys.lisp @@ -0,0 +1,1278 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; ### Some day fix to accept :wild in any pathname component. +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Ugly pathname functions for Spice Lisp. +;;; these functions are part of the standard Spice Lisp environment. +;;; +;;; Written by Jim Large and Rob MacLachlan +;;; +;;; ********************************************************************** +(in-package 'lisp) +(export '(pathname pathnamep *default-pathname-defaults* truename + parse-namestring merge-pathnames make-pathname + pathname-host pathname-device pathname-directory + pathname-name pathname-type pathname-version + namestring file-namestring directory-namestring + host-namestring enough-namestring user-homedir-pathname + probe-file rename-file delete-file file-write-date + file-author directory)) + +(use-package "EXTENSIONS") + +(in-package "EXTENSIONS") +(export '(print-directory complete-file ambiguous-files default-directory + file-writable)) +(in-package 'lisp) + + +;;; Pathname structure + + +;;; *Default-Pathname-defaults* has all values unspecified except for the +;;; host. All pathnames must have a host. +(defvar *default-pathname-defaults* () + "Set to the default pathname-defaults pathname (Got that?)") + +(defun filesys-init () + (setq *default-pathname-defaults* + (%make-pathname "Mach" nil nil nil nil nil))) + + +;;; The pathname type is defined with a defstruct. +;;; This declaration implicitly defines the common lisp function Pathnamep +(defstruct (pathname + (:conc-name %pathname-) + (:print-function %print-pathname) + (:constructor + %make-pathname (host device directory name type version)) + (:predicate pathnamep)) + "Pathname is the structure of the file pathname. It consists of a + host, a device, a directory, a name, and a type." + (host nil :type (or simple-string null)) + (device nil :type (or simple-string (member nil :absolute))) + (directory nil :type (or simple-vector null)) + (name nil :type (or simple-string null)) + (type nil :type (or simple-string null)) + (version nil :type (or integer (member nil :newest)))) + +(defun %print-pathname (s stream d) + (declare (ignore d)) + (format stream "#.(pathname ~S)" (namestring s))) + +(defun make-pathname (&key defaults (host nil hostp) (device nil devicep) + (directory nil directoryp) (name nil namep) + (type nil typep) (version nil versionp)) + "Create a pathname from :host, :device, :directory, :name, :type and :version. + If any field is ommitted, it is obtained from :defaults as though by + merge-pathnames." + (if defaults + (let ((defaults (pathname defaults))) + (unless hostp + (setq host (%pathname-host defaults))) + (unless devicep + (setq device (%pathname-device defaults))) + (unless directoryp + (setq directory (%pathname-directory defaults))) + (unless namep + (setq name (%pathname-name defaults))) + (unless typep + (setq type (%pathname-type defaults))) + (unless versionp + (setq version (%pathname-version defaults)))) + (unless hostp + (setq host (%pathname-host *default-pathname-defaults*)))) + + (when (stringp directory) + (setq directory (%pathname-directory (parse-namestring directory)))) + (%make-pathname + (if (stringp host) (coerce host 'simple-string) host) + (if (stringp device) (coerce device 'simple-string) device) + directory + (if (stringp name) (coerce name 'simple-string) name) + (if (stringp type) (coerce type 'simple-string) type) + version)) + + +;;; These can not be done by the accessors because the pathname arg may be +;;; a string or a symbol or etc. + +(defun pathname-host (pathname) + "Returns the host slot of pathname. Pathname may be a string, symbol, + or stream." + (%pathname-host (if (pathnamep pathname) pathname (pathname pathname)))) + +(defun pathname-device (pathname) + "Returns the device slot of pathname. Pathname may be a string, symbol, + or stream." + (%pathname-device (if (pathnamep pathname) pathname (pathname pathname)))) + +(defun pathname-directory (pathname) + "Returns the directory slot of pathname. Pathname may be a string, + symbol, or stream." + (%pathname-directory (if (pathnamep pathname) pathname (pathname pathname)))) + +(defun pathname-name (pathname) + "Returns the name slot of pathname. Pathname may be a string, + symbol, or stream." + (%pathname-name (if (pathnamep pathname) pathname (pathname pathname)))) + +(defun pathname-type (pathname) + "Returns the type slot of pathname. Pathname may be a string, + symbol, or stream." + (%pathname-type (if (pathnamep pathname) pathname (pathname pathname)))) + +(defun pathname-version (pathname) + "Returns the version slot of pathname. Pathname may be a string, + symbol, or stream." + (%pathname-version (if (pathnamep pathname) pathname (pathname pathname)))) + + + +;;;; FSM Compiler + +(eval-when (compile eval) +;;; These macros are used in the code emitted by deflex. They refer +;;; to local vars in the defined function. + +(defmacro fsm-scan () + '(progn + (incf pointer) + (setq current-char (if (>= pointer end) + :end + (char string pointer))))) + +;;; fsm-emit expands into a form which pushes FLAG onto *deflex-tokens* and +;;; then pushes a string containing the ACCUMULATED characters +(defmacro fsm-emit (flag) + `(progn + (vector-push-extend ,flag *deflex-tokens*) + (vector-push-extend (subseq buffer 0 buffer-index) *deflex-tokens*) + (setq buffer-index 0))) + +;;; fsm-dotfix expands into a form which replaces the last EMITTED flag with +;;; FLAG, and the last EMITTED token with its self + "." + the ACCUMULATED +;;; characters. +(defmacro fsm-dotfix (flag) + `(let ((prev-token (vector-pop *deflex-tokens*))) + (setf (aref *deflex-tokens* (1- (fill-pointer *deflex-tokens*))) ,flag) + (vector-push (concatenate 'simple-string + prev-token + "." + (subseq buffer 0 buffer-index)) + *deflex-tokens*) + (setq buffer-index 0))) + + +(defun deflex-arc (arc) + (do ((set (nth 0 arc)) + (new-state (nth 2 arc)) + (actions (nth 3 arc) (if (member (car actions) '(EMIT DOTFIX)) + (cddr actions) + (cdr actions))) + (action-forms + () + (cons (case (car actions) + (ACCUMULATE '(progn + (setf (schar buffer buffer-index) current-char) + (incf buffer-index))) + (SCAN '(fsm-scan)) + (EMIT `(fsm-emit ,(nth 1 actions))) + (DOTFIX `(fsm-dotfix ,(nth 1 actions))) + (t (error "Illegal action ~s" (car actions)))) + action-forms))) + ((null actions) + `(when ,(cond ((eq set ':end) `(eq current-char ,set)) + ((eq set T) T) + (t + `(and (not (eq current-char :end)) + ,(if (characterp set) + `(char= current-char ,set) + `(find current-char + (the simple-string ,set)))))) + ,@(nreverse action-forms) + (go ,new-state))))) + + +(defun deflex-state (state) + (do ((state-name (car state)) + (arc-list (cdr state) (cdr arc-list)) + (form-list () (cons (deflex-arc (car arc-list)) form-list))) + ((null arc-list) + `(,state-name + ,@(nreverse form-list) + (go JAM))))) + +(defmacro deflex (name &rest states) + (do ((states states (cdr states)) + (body-forms () (append body-forms (deflex-state (car states))))) + ((null states) + `(defun ,(concat-pnames 'lex- name) + (string &optional (start 0) (end (length string))) + (declare (simple-string string) + (fixnum start end)) + (setf (fill-pointer *deflex-tokens*) 0) + (prog ((current-char (if (> end start) + (char string start) :end)) + (pointer start) + (buffer *deflex-buffer*) + (buffer-index 0)) + (declare (simple-string buffer)) + ,@body-forms + + WIN (return (values T pointer)) + JAM (return (values NIL pointer))))))) + +); eval-when (compile eval) + + +(defvar *deflex-buffer* (make-string 100)) +(defvar *deflex-tokens* (make-array 20 :adjustable t :fill-pointer 0)) + + + +;;;; FSM for lexing pathnames. + +(defconstant ses-name-char + "#@$-+*%0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz~") + +(defconstant fs-whitespace ;whitespace in filenames + " +") + +;;; Lex-ses-file-spec separates a sesame file name into its components +;;; +;;; STRING -- the string containing the file spec. +;;; &optional +;;; START -- the first character to look at (defaults to 0) +;;; END -- 1+ the last character to look at (defaluts to (length STRING)) +;;; +;;; Returns multiple values. +;;; 1st -- () for failure or a list of tokens. +;;; 2nd -- the index of the character that stopped the parse +;;; +;;; Tokens are represented by a keyword and a string in *deflex-tokens*. +;;; The first token is of type :logical-name (string is log name) or :absolute. +;;; Subsequent tokens are of type :directory-name, :file-name, :extension, or +;;; the string being a pathname component. +;;; +(deflex ses-file-spec + ;;S1 waits for the first non whitespace character + (S1 (fs-whitespace --> S1 (SCAN)) + (#\- --> JAM) ;- illegal as start of file name + (#\/ --> S3 (EMIT :absolute SCAN));/ starts an absolute pathname + (#\\ --> S2a (ACCUMULATE SCAN)) ;\ quotes char in name or logname + (#\. --> S5 (EMIT :file-name SCAN)) ;. maybe ends file name + (ses-name-char --> S2 (ACCUMULATE SCAN)) ;first char in a name or logname + (:end --> WIN) ; Null filename is legal. + ) + + ;;S2 accumulates chars in a file name, logical name, or directory name. + (S2 (#\: --> S3 (EMIT :logical-name SCAN)) ;: ends log-name, starts next name + (#\/ --> S3 (EMIT :directory-name SCAN));/ ends directory name,starts next + (#\\ --> S2a (ACCUMULATE SCAN)) ;\ quotes char in name + (#\. --> S5 (EMIT :file-name SCAN)) ;. maybe ends file name + (:end --> WIN (EMIT :file-name)) + (ses-name-char --> S2 (ACCUMULATE SCAN)) + (fs-whitespace --> S9 (EMIT :file-name SCAN)) + (T --> JAM (EMIT :file-name)) + ) + + ;;S2a waits for any char following a \ found in S2 + (S2a (:END --> JAM) + (T --> S2 (ACCUMULATE SCAN))) + + ;;S3 accumulates chars in a file name or directory name + (S3 (#\/ --> JAM) + (T --> S3b)) + (S3b (#\/ --> S3 (EMIT :directory-name SCAN));/ ends directory name,starts next + (#\. --> S4 (EMIT :file-name SCAN)) ;. maybe ends file name + (#\\ --> S3a (ACCUMULATE SCAN)) ;\ quotes char in name + (:end --> WIN (EMIT :file-name)) + (ses-name-char --> S3b (ACCUMULATE SCAN)) + (fs-whitespace --> S9 (EMIT :file-name SCAN)) + (T --> JAM (EMIT :file-name)) + ) + + ;;S3a waits for any char following a \ found in S3 + (S3a (:end --> JAM) + (T --> S3b (ACCUMULATE SCAN))) + + ;;S4 waits for chars in a name following a dot. If it encounters the end of + ;; the pathname, then the chars are the extension. Otherwise, the chars are + ;; really part of the last token, so we mash them back on with dotfix. + (S4 (#\/ --> S3 (DOTFIX :directory-name SCAN)) + (#\\ --> S4a (ACCUMULATE SCAN)) + (#\. --> S4 (DOTFIX :file-name SCAN)) + (:end --> WIN (EMIT :extension)) + (fs-whitespace --> S9 (EMIT :extension SCAN)) + (ses-name-char --> S4 (ACCUMULATE SCAN)) + (T --> JAM (EMIT :extension)) + ) + + ;;S4a waits for any char following a \ found in S4 + (S4a (:end --> JAM) + (T --> S4 (ACCUMULATE SCAN))) + + ;;S5 is the same as S4 but name may also be logical name + (S5 (#\/ --> S3 (DOTFIX :directory-name SCAN)) + (#\: --> S3 (DOTFIX :logical-name SCAN)) + (#\\ --> S5a (ACCUMULATE SCAN)) + (#\. --> S5 (DOTFIX :file-name SCAN)) + (:end --> WIN (EMIT :extension)) + (fs-whitespace --> S9 (EMIT :extension SCAN)) + (ses-name-char --> S5 (ACCUMULATE SCAN)) + (T --> JAM (EMIT :extension)) + ) + + ;;S5a waits for any char following a \ found in S5 + (S5a (:end --> JAM) + (T --> S5 (ACCUMULATE SCAN))) + + ;;S9 eats trailing whitespace. + (S9 (fs-whitespace --> S9 (SCAN)) + (:end --> WIN) + (t --> JAM)) + ) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; ses-tokens->pathname converts the contents of *deflex-tokens* into a pathname +;;; +(defun ses-tokens->pathname () + (do ((end (fill-pointer *deflex-tokens*)) + (result (make-pathname)) + (dirlist ()) + (token-val ()) + (ix 0 (+ ix 2)) + (default t)) + ((>= ix end) + (setf (%pathname-directory result) + (cond (dirlist + (when default (setf (%pathname-device result) "Default")) + (coerce (the list (nreverse dirlist)) 'simple-vector)) + (default nil) + (t '#()))) + result) + (declare (list dirlist) + (fixnum ix end)) + (setq token-val (aref *deflex-tokens* (1+ ix))) + (case (aref *deflex-tokens* ix) + (:ABSOLUTE + (setf (%pathname-device result) :ABSOLUTE) + (setq default nil)) + (:LOGICAL-NAME + (setf (%pathname-device result) token-val) + (setq default nil)) + (:DIRECTORY-NAME (push token-val dirlist)) + (:FILE-NAME + (unless (zerop (length (the simple-string token-val))) + (setf (%pathname-name result) token-val))) + (:EXTENSION (setf (%pathname-type result) token-val))))) + + + +;;;; PARSE-NAMESTRING and PATHNAME. + +(defun parse-namestring (thing &optional host + (defaults *default-pathname-defaults*) + &key (start 0) end (junk-allowed nil)) + "Parses a string representation of a pathname into a pathname." + (declare (ignore host defaults)) + (let* ((thing (typecase thing + (string (coerce thing 'simple-string)) + (pathname (return-from parse-namestring (values thing start))) + (stream (file-name thing)) + (symbol (symbol-name thing)) + (t (error "This thing is a bad thing for parse-namestring: ~S" + thing)))) + (end (or end (length thing)))) + (declare (simple-string thing)) + (multiple-value-bind (won next-field) + (lex-ses-file-spec thing start end) + (unless (or won junk-allowed) + (error "There's junk in this thing that you gave to parse-namestring:~%~ + ~4T\"~A\"~%~0,1,V,'.@A" thing (+ next-field 5) #\^)) + (values (ses-tokens->pathname) next-field)))) + +(defun pathname (thing) + "Turns thing into a pathname. Thing may be a string, symbol, stream, or + pathname." + (values (parse-namestring thing))) + + + +;;; Merge-Pathnames -- Public +;;; +;;; Returns a new pathname whose fields are the same as the fields in PATHNAME +;;; except that () fields are filled in from defaults. Type and Version field +;;; are only done if name field has to be done (see manual for explanation). +;;; +(defun merge-pathnames (pathname &optional + (defaults *default-pathname-defaults*) + default-version) + "Fills in unspecified slots of Pathname from Defaults (defaults to + *default-pathname-defaults*). If the version remains unspecified, + gets it from Default-Version." + ;; + ;; finish hairy argument defaulting + (setq pathname (pathname pathname)) + (setq defaults (pathname defaults)) + ;; + ;; make a new pathname + (let ((name (%pathname-name pathname)) + (device (%pathname-device pathname))) + (%make-pathname + (or (%pathname-host pathname) (%pathname-host defaults)) + (or device (%pathname-device defaults)) + (or (%pathname-directory pathname) (%pathname-directory defaults)) + (or name (%pathname-name defaults)) + (or (%pathname-type pathname) (%pathname-type defaults)) + (or (%pathname-version pathname) + (if name + default-version + (or (%pathname-version defaults) default-version)))))) + + +;;;; NAMESTRING and other stringification stuff. + +;;; %Dirstring -- Internal +;;; +;;; %Dirstring converts a vector of the form #("foo" "bar" ... "baz") into a +;;; string of the form "foo/bar/ ... /baz/" + +(defun %dirstring (dirlist) + (declare (simple-vector dirlist)) + (let* ((numdirs (length dirlist)) + (length numdirs)) + (declare (fixnum numdirs length)) + (dotimes (i numdirs) + (incf length (the fixnum (length (svref dirlist i))))) + (do ((result (make-string length)) + (index 0 (1+ index)) + (position 0)) + ((= index numdirs) result) + (declare (simple-string result)) + (let* ((string (svref dirlist index)) + (len (length string)) + (end (+ position len))) + (declare (simple-string string) + (fixnum len end)) + (replace result string :start1 position :end1 end :end2 len) + (setf (schar result end) #\/) + (setq position (+ end 1)))))) + +(defun quick-integer-to-string (n) + (cond ((zerop n) "0") + ((eql n 1) "1") + ((minusp n) + (concatenate 'simple-string "-" + (the simple-string (quick-integer-to-string (- n))))) + (t + (do* ((len (1+ (truncate (integer-length n) 3))) + (res (make-string len)) + (i (1- len) (1- i)) + (q n) + (r 0)) + ((zerop q) + (incf i) + (replace res res :start2 i :end2 len) + (%primitive shrink-vector res (- len i))) + (declare (simple-string res) + (fixnum len i r)) + (multiple-value-setq (q r) (truncate q 10)) + (setf (schar res i) (schar "0123456789" r)))))) + +(defun %device-string (device) + (cond ((eq device :absolute) "/") + (device + (if (string-equal device "Default") + "" + (concatenate 'simple-string (the simple-string device) ":"))) + (T ""))) + +(defun namestring (pathname) + "Returns the full form of PATHNAME as a string." + (setq pathname (pathname pathname)) + (let* ((directory (%pathname-directory pathname)) + (name (%pathname-name pathname)) + (type (%pathname-type pathname)) + (result (%device-string (%pathname-device pathname)))) + (declare (simple-string result)) + (when directory + (setq result (concatenate 'simple-string result + (the simple-string (%dirstring directory))))) + (when name + (setq result (concatenate 'simple-string result + (the simple-string name)))) + (when type + (setq result (concatenate 'simple-string result "." + (the simple-string type)))) + result)) + +(defun %ses-get-useful-name (pathname) + "NAMESTRING of pathname ignoring the device slot." + (setq pathname (pathname pathname)) + (let* ((directory (%pathname-directory pathname)) + (name (%pathname-name pathname)) + (type (%pathname-type pathname)) + (result "")) + (declare (simple-string result)) + (when directory + (setq result (concatenate 'simple-string result + (the simple-string (%dirstring directory))))) + (when name + (setq result (concatenate 'simple-string result + (the simple-string name)))) + (when type + (setq result (concatenate 'simple-string result "." + (the simple-string type)))) + result)) + +;;; This function is somewhat bummed to make the Hemlock directory command +;;; is fast. +;;; +(defun file-namestring (pathname) + "Returns the name, type, and version of PATHNAME as a string." + (unless (pathnamep pathname) (setq pathname (pathname pathname))) + (let* ((name (%pathname-name pathname)) + (type (%pathname-type pathname)) + (result (or name ""))) + (declare (simple-string result)) + (if type + (concatenate 'simple-string result "." type) + result))) + +(defun directory-namestring (pathname) + "Returns the device & directory parts of PATHNAME as a string." + (setq pathname (pathname pathname)) + (let* ((directory (%pathname-directory pathname)) + (result (%device-string (%pathname-device pathname)))) + (declare (simple-string result)) + (when directory + (setq result (concatenate 'simple-string result + (the simple-string (%dirstring directory))))) + result)) + +(defun host-namestring (pathname) + "Returns the host part of PATHNAME as a string." + (setq pathname (pathname pathname)) + (%pathname-host pathname)) + + + +;;;; ENOUGH-NAMESTRING + +(defun enough-namestring (pathname &optional + (defaults *default-pathname-defaults*)) + "Returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS." + (setq pathname (pathname pathname)) + (setq defaults (pathname defaults)) + (let* ((device (%pathname-device pathname)) + (directory (%pathname-directory pathname)) + (name (%pathname-name pathname)) + (type (%pathname-type pathname)) + (result "") + (need-name nil)) + (declare (simple-string result)) + (when (and device (string-not-equal device (%pathname-device defaults))) + (setq result (%device-string device))) + (when (and directory + (not (equalp directory (%pathname-directory defaults)))) + (setq result (concatenate 'simple-string result + (the simple-string (%dirstring directory))))) + (when (and name (string-not-equal name (%pathname-name defaults))) + (setq result (concatenate 'simple-string result + (the simple-string name)) + need-name t)) + (when (and type (or need-name + (string-not-equal type (%pathname-type defaults)))) + (setq result (concatenate 'simple-string result "." + (the simple-string type)))) + result)) + + + +;;;; TRUENAME and other stuff probing stuff. + +;;; Truename -- Public +;;; +;;; Another silly file function trivially different from another function. +;;; +(defun truename (pathname) + "Return the pathname for the actual file described by the pathname + An error is signalled if no such file exists." + (let ((result (probe-file pathname))) + (unless result + (error "The file ~S does not exist." (namestring pathname))) + result)) + +;;; Do-Search-List -- Internal +;;; +;;; Bind var in turn to each element of search list with the specifed +;;; name. +;;; +(defmacro do-search-list ((var name &optional exit-form) . body) + "Do-Search-List (Var Name [Exit-Form]) {Form}*" + `(dolist (,var (resolve-search-list ,name nil) ,exit-form) + (declare (simple-string ,var)) + ,@body)) + + +;;; Sub-Probe-File -- Internal +;;; +;;; Does the work of Probe-File, returning an additional value which +;;; indicates whether the name is really a file. +;;; +(defun sub-probe-file (pathname) + (setq pathname (pathname pathname)) + (flet ((pathnamify (ns etype) + (declare (simple-string ns)) + (case etype + (:entry_remote + (values (parse-namestring (concatenate 'simple-string ns "/")) + :entry_directory)) + (t + (values (parse-namestring ns) etype))))) + (let ((log-name (or (%pathname-device pathname) "default"))) + (if (eq log-name :absolute) + (let ((namestring (namestring pathname))) + (multiple-value-bind (name etype) + (mach:unix-subtestname namestring) + (if (null name) NIL + (pathnamify name etype)))) + (if (null (%pathname-device pathname)) + (multiple-value-bind (name etype) + (mach:unix-subtestname + (%ses-get-useful-name pathname)) + (if (null name) NIL (pathnamify name etype))) + (let ((namestring (%ses-get-useful-name pathname))) + (do-search-list (entry log-name) + (let ((str (concatenate 'simple-string entry namestring))) + (declare (simple-string str)) + (multiple-value-bind (name etype) + (mach:unix-subtestname str) + (when name + (return (pathnamify name etype)))))))))))) + + +;;; Probe-File -- Public +;;; +;;; Just call Sub-Probe-File and return nil when it isn't a file. +;;; +(defun probe-file (pathname) + "Return a pathname which is the truename of the file if it exists, NIL + otherwise. Returns NIL for directories and other non-file entries." + (multiple-value-bind (pn f) + (sub-probe-file pathname) + (if (eq f :entry_file) pn))) + + + +;;; Predict-Name -- Internal +;;; +;;; Predict-Name is a function used by Open to get an absolute pathname +;;; for a file being opened. Returns the truename of the file and +;;; whether it really exists or not. +;;; +(defun predict-name (file-name for-input) + (let* ((pathname (pathname file-name)) + (device (%pathname-device pathname)) + (truename (probe-file pathname))) + (cond ((eq device :absolute) + (if truename + (values (namestring truename) t) + ;; Try again in case file-name is a directory. + (predict-name-with-subtest (namestring pathname)))) + ((and for-input truename) + (values (namestring truename) t)) + (t + (let ((expansion (resolve-search-list (or device "default") t))) + (let ((name (concatenate 'simple-string (car expansion) + (%ses-get-useful-name pathname)))) + (declare (simple-string name)) + (predict-name-with-subtest name))))))) + +(defun predict-name-with-subtest (name) + (let ((gr (mach:unix-subtestname name))) + (if gr + (values gr t) + (values (mach::simplify-file-name name) nil)))) + + + +;;; Rename-File -- Public +;;; +;;; If File is a File-Stream, then rename the associated file if it exists, +;;; otherwise just change the name in the stream. If not a file stream, then +;;; just rename the file. +;;; +(defun rename-file (file new-name) + "Rename File to have the specified New-Name. If file is a stream open to a + file, then the associated file is renamed. If the file does not yet exist + then the file is created with the New-Name when the stream is closed." + (if (streamp file) + (let* ((name (file-name file)) + (pn (parse-namestring name)) + (npn (merge-pathnames new-name pn)) + (new (predict-name npn nil))) + (when (mach:quick-subtestname name) + (multiple-value-bind (res err) (mach:Unix-rename name new) + (if (null res) (error "Failed to rename ~A to ~A, unix error: ~A." + name new (mach:get-unix-error-msg err))))) + (file-name file new) + (values npn pn (parse-namestring new))) + (let* ((pn (or (sub-probe-file file) + (error "File to rename does not exist: ~S" file))) + (npn (merge-pathnames new-name pn)) + (new (predict-name npn nil))) + (multiple-value-bind (res err) (mach:unix-rename (namestring pn) new) + (if res (values npn pn (parse-namestring new)) + (error "Failed to rename ~A to ~A, unix error: ~A." + (namestring pn) new (mach:get-unix-error-msg err))))))) + +;;; Delete-File -- Public +;;; +;;; Delete the file, Man. +;;; +(defun delete-file (file) + "Delete the specified file." + (let ((tn (sub-probe-file file))) + (when (streamp file) + (close file :abort t)) + (if tn + (let ((ns (namestring tn))) + (multiple-value-bind (res err) (mach:unix-unlink ns) + (if (null res) + (error "Failed to delete ~A, unix error: ~A." + ns (mach:get-unix-error-msg err))))) + (unless (streamp file) + (error "File to be deleted does not exist: ~S" file)))) + t) + +;;; User-Homedir-Pathname -- Public +;;; +;;; If the user wants a meaningful homedir, she has to define Home:. +;;; Someday, login may do this for us. Since we must always return something, +;;; we just return Default: if it isn't defined. +;;; +(defun user-homedir-pathname (&optional host) + "Returns the home directory of the logged in user as a pathname. + This is obtained from the logical name \"home:\". If this is not defined, + then we return \"default:\"" + (declare (ignore host)) + (let ((home (cdr (assoc :home *environment-list* :test #'eq)))) + (if home + (pathname (if (string-equal home "/") "/" + (concatenate 'simple-string home "/"))) + (let ((expansion (if (search-list "home:") + (resolve-search-list "home" t)))) + (if expansion + (car expansion) + (make-pathname :device "default")))))) + +;;; File-Write-Date -- Public +;;; +(defun file-write-date (file) + "Return file's creation date, or NIL if it doesn't exist." + (let ((tn (sub-probe-file file))) + (when tn + (multiple-value-bind (res dev ino mode nlink uid gid + rdev size atime mtime) + (mach:unix-stat (namestring tn)) + (declare (ignore dev ino mode nlink uid gid rdev size atime)) + (if (null res) 0 + (+ unix-to-universal-time mtime)))))) + +;;; File-Author -- Public +;;; +(defun file-author (file) + "Returns the file author as a string, or nil if the author cannot be + determined. Signals an error if file doesn't exist." + (let ((filename (truename file))) + (multiple-value-bind (winp dev ino mode nlink uid) + (mach:unix-stat (namestring filename)) + (declare (ignore dev ino mode nlink)) + (if winp (lookup-login-name uid))))) + + + +;;;; DIRECTORY. + +;;; DO-DIRECTORY searches a directory, binding the vars to the name and entry +;;; type. Pattern and All are used in MACH:UNIX-SEARCH-DIRECTORY. +;;; +(defmacro do-directory ((name-var etype-var pattern &optional (all t) result) + . body) + "Do-Directory (Name Entry-Type Pattern [All] [Result]) {Form}*. + If All is non-nil (the default), then Unix dot files to be processed. + Unix dot and dot-dot are never processed." + (let ((file (gensym)) + (res (gensym)) + (type (gensym)) + (p (gensym))) + `(dolist (,file (mach:unix-search-directory ,pattern ,all) + ,result) + (declare (simple-string ,file)) + (let* ((,p (position #\/ ,file :from-end t)) + (,name-var + (if ,p + (subseq ,file (the fixnum (1+ (the fixnum ,p)))) + ,file))) + (declare (simple-string ,name-var)) + (unless (or (string= "." ,name-var) (string= ".." ,name-var)) + (let ((,etype-var (multiple-value-bind (,res ,type) + (mach:quick-subtestname ,file) + (declare (ignore ,res)) + ,type))) + ,@body)))))) + +(defun directory (pathname &key (all t)) + "Returns a list of pathnames, one for each file that matches the given + pathname. Supplying :all as nil causes this to ignore Unix dot files. This + never includes Unix dot and dot-dot in the result." + (setq pathname (pathname pathname)) + (multiple-value-bind (dir pattern) (find-directory pathname) + (let ((res ())) + (do-directory (name etype pattern all) + (if (eq etype :entry_file) + (let ((last-dot (position #\. name :from-end t))) + (push + (%make-pathname + "Mach" :absolute dir + (if last-dot (subseq name 0 last-dot) name) + (if last-dot (subseq name (1+ last-dot))) + nil) + res)) + (push + (%make-pathname + "Mach" :absolute + (concatenate 'simple-vector dir (vector name)) + nil nil nil) + res))) + (nreverse res)))) + +;;; FIND-DIRECTORY returns an absolute directory vector for pathname as a +;;; first argument and an absolute namestring. The namestring includes a +;;; trailing asterisk, wildcard, when the given pathname is immediately +;;; probe-able as a directory. +;;; +(defun find-directory (pathname) + (multiple-value-bind (pn type) + (sub-probe-file pathname) + (if pn + (let ((ns (namestring pn))) + (declare (simple-string ns)) + (case type + (:entry_directory + (when (char/= (schar ns (the fixnum (1- (length ns)))) #\/) + (setq ns (concatenate 'simple-string ns "/"))) + (values (%pathname-directory (pathname ns)) + (concatenate 'simple-string ns "*"))) + (t (values (%pathname-directory pn) ns)))) + (multiple-value-bind (pn type) + (sub-probe-file + (make-pathname + :directory (%pathname-directory pathname) + :device (%pathname-device pathname))) + (unless pn + (error "Directory does not exist: ~S" pathname)) + (let ((ns (namestring pn))) + (case type + (:entry_directory + (values + (%pathname-directory pn) + (concatenate 'simple-string ns (file-namestring pathname)))) + (t + (error "~S is not a directory." pathname)))))))) + + + +;;;; Printing directories and determining file owner names. + +;;; PRINT-DIRECTORY is exported from the EXTENSIONS package. +;;; +(defun print-directory (pathname &optional stream &key all verbose return-list) + "Like Directory, but prints a terse, multi-coloumn directory listing + instead of returning a list of pathnames. When :all is supplied and + non-nil, then Unix dot files are included too (as ls -a). When :vervose + is supplied and non-nil, then a long listing of miscellaneous + information is output one file per line." + (setf pathname (pathname pathname)) + (let ((*standard-output* (out-synonym-of stream))) + (if verbose + (print-directory-verbose pathname all return-list) + (print-directory-formatted pathname all return-list)))) + +(defun print-directory-verbose (pathname all return-list) + (multiple-value-bind (dir pattern) (find-directory pathname) + (declare (ignore dir)) + (format t "Directory of ~A :~%" pattern) + (let ((dir-name (directory-namestring pattern)) + (result ())) + (do-directory (name etype pattern all (nreverse result)) + (let ((slash-name (if (eq etype :entry_file) + name + (concatenate 'simple-string name "/")))) + (declare (simple-string slash-name)) + (when return-list + (push (pathname (concatenate 'simple-string dir-name slash-name)) + result)) + (multiple-value-bind + (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime) + (mach:unix-stat (concatenate 'simple-string dir-name name)) + (declare (ignore ino gid rdev atime) + (fixnum uid mode)) + (cond (reslt + ;; + ;; Print characters for file modes. + (macrolet ((frob (bit name &optional sbit sname negate) + `(if ,(if negate + `(not (logbitp ,bit mode)) + `(logbitp ,bit mode)) + ,(if sbit + `(if (logbitp ,sbit mode) + (write-char ,sname) + (write-char ,name)) + `(write-char ,name)) + (write-char #\-)))) + (frob 15 #\d nil nil t) + (frob 8 #\r) + (frob 7 #\w) + (frob 6 #\x 11 #\s) + (frob 5 #\r) + (frob 4 #\w) + (frob 3 #\x 10 #\s) + (frob 2 #\r) + (frob 1 #\w) + (frob 0 #\x)) + ;; + ;; Print the rest. + (multiple-value-bind (sec min hour date month year) + (get-decoded-time) + (declare (ignore sec min hour date month)) + (format t "~2D ~8A ~8D ~12A ~A~%" + nlink + (or (lookup-login-name uid) uid) + size + (decode-universal-time-for-files mtime year) + slash-name))) + (t (format t "Couldn't stat ~A -- ~A.~%" + slash-name + (mach:get-unix-error-msg dev-or-err)))))))))) + +(defun decode-universal-time-for-files (time current-year) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time (+ time unix-to-universal-time)) + (declare (ignore sec)) + (format nil "~A ~2,' D ~:[ ~D~;~*~2,'0D:~2,'0D~]" + (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" + "Sep" "Oct" "Nov" "Dec") + (1- month)) + day (= current-year year) year hour min))) + +(defun print-directory-formatted (pathname all return-list) + (let ((width (or (line-length *standard-output*) 80)) + (names ()) + (cnt 0) + (max-len 0) + (result ())) + (declare (list names) (fixnum max-len cnt)) + ;; + ;; Get the data. + (multiple-value-bind (dir pattern) (find-directory pathname) + (declare (ignore dir)) + (do-directory (name etype pattern all) + (let* ((slash-name (if (eql etype :entry_file) + name + (concatenate 'simple-string name "/"))) + (len (length slash-name))) + (declare (simple-string slash-name) + (fixnum len)) + (when return-list + (push (pathname (concatenate 'simple-string + (directory-namestring pattern) + slash-name)) + result)) + + (if (> len max-len) (setq max-len len)) + (incf cnt) + (push slash-name names))) + (setq names (nreverse names)) + ;; + ;; Do the output. + (let* ((col-width (1+ max-len)) + (cols (max (truncate width col-width) 1)) + (lines (ceiling cnt cols))) + (declare (fixnum cols lines)) + (format t "Directory of ~A :~%" pattern) + (dotimes (i lines) + (declare (fixnum i)) + (dotimes (j cols) + (declare (fixnum j)) + (let ((name (nth (+ i (the fixnum (* j lines))) names))) + (when name + (write-string name) + (unless (eql j (1- cols)) + (tab-over + (- col-width (length (the simple-string name)))))))) + (terpri)))) + (when return-list (nreverse result)))) + + + +;;;; Translating uid's and gid's. + +(defvar *uid-hash-table* (make-hash-table) + "Hash table for keeping track of uid's and login names.") + +;;; LOOKUP-LOGIN-NAME translates a user id into a login name. Previous +;;; lookups are cached in a hash table since groveling the passwd(s) files +;;; is somewhat expensive. The table may hold nil for id's that cannot +;;; be looked up since this means the files are searched in their entirety +;;; each time this id is translated. +;;; +(defun lookup-login-name (uid) + (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*) + (if foundp + login-name + (setf (gethash uid *uid-hash-table*) + (get-group-or-user-name :user uid))))) + +(defvar *gid-hash-table* (make-hash-table) + "Hash table for keeping track of gid's and group names.") + +;;; LOOKUP-GROUP-NAME translates a group id into a group name. Previous +;;; lookups are cached in a hash table since groveling the group(s) files +;;; is somewhat expensive. The table may hold nil for id's that cannot +;;; be looked up since this means the files are searched in their entirety +;;; each time this id is translated. +;;; +(defun lookup-group-name (gid) + (multiple-value-bind (group-name foundp) (gethash gid *gid-hash-table*) + (if foundp + group-name + (setf (gethash gid *gid-hash-table*) + (get-group-or-user-name :group gid))))) + + +;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group") since it is +;;; a much smaller file, contains all the local id's, and most uses probably +;;; involve id's on machines one would login into. Then if necessary, we look +;;; in "/etc/passwds" ("/etc/groups") which is really long and has to be +;;; fetched over the net. +;;; +(defun get-group-or-user-name (group-or-user id) + "Returns the simple-string user or group name of the user whose uid or gid + is id, or NIL if no such user or group exists. Group-or-user is either + :group or :user." + (let ((id-string (let ((*print-base* 10)) (prin1-to-string id)))) + (declare (simple-string id-string)) + (multiple-value-bind (file1 file2) + (ecase group-or-user + (:group (values "/etc/group" "/etc/groups")) + (:user (values "/etc/passwd" "/etc/passwd"))) + (or (get-group-or-user-name-aux id-string file1) + (get-group-or-user-name-aux id-string file2))))) + +(defun get-group-or-user-name-aux (id-string passwd-file) + (with-open-file (stream passwd-file) + (loop + (let ((entry (read-line stream nil))) + (unless entry (return nil)) + (let ((name-end (position #\: (the simple-string entry) + :test #'char=))) + (when name-end + (let ((id-start (position #\: (the simple-string entry) + :start (1+ name-end) :test #'char=))) + (when id-start + (incf id-start) + (let ((id-end (position #\: (the simple-string entry) + :start id-start :test #'char=))) + (when (and id-end + (string= id-string entry + :start2 id-start :end2 id-end)) + (return (subseq entry 0 name-end)))))))))))) + + + +;;; Complete-One-File -- Internal +;;; +;;; Return as values a string and the greatest common prefix of all +;;; the files corresponding to pattern. +;;; +(defun complete-one-file (pattern default-type ignore-types) + (let ((first nil) + (length nil)) + (do-directory (name etype pattern nil) + (declare (ignore etype)) + (let* ((last-dot (position #\. name :from-end t)) + (type (if last-dot (subseq name (1+ last-dot))))) + (cond ((and (not (string= type default-type)) + (member type ignore-types :test #'string=))) + (first + (let ((msm (string-not-equal name first :end2 length))) + (when (and msm (< msm length)) + (setq length msm)))) + (t + (setq first name) + (setq length (length name)))))) + (values first length))) + + +;;; Complete-File -- Public +;;; +;;; If the pathname is absolute, just call Complete-One-File on and test +;;; whether the result is a file. If a relative pathname, do it on each +;;; directory, accumulating the result. +;;; +(defun complete-file (pathname &key defaults ignore-types) + "Attempt to complete Pathname as the name of a file. If the resulting + completion is unique, return T as the second value. If there is no + possible completion, return both values NIL." + (setq pathname (pathname pathname)) + (setq defaults (if defaults (pathname defaults) *default-pathname-defaults*)) + (flet ((pathnamify (res len ambiguous pathname) + (values + (make-pathname :device (%pathname-device pathname) + :directory (%pathname-directory pathname) + :defaults (parse-namestring (subseq res 0 len))) + (not ambiguous)))) + (let ((dev (or (%pathname-device pathname) "default")) + (default-type (%pathname-type defaults))) + (if (eq dev :absolute) + (multiple-value-bind + (res len) + (complete-one-file (concatenate 'simple-string + (namestring pathname) + "*") + default-type ignore-types) + (declare (fixnum len)) + (if res + (pathnamify res len + (/= (the fixnum (length res)) len) + pathname) + (values nil nil))) + (let ((namestring (%ses-get-useful-name pathname)) + (dirs (if (and (%pathname-directory defaults) + (string-equal dev "default")) + (list (directory-namestring defaults)) + ())) + (max most-positive-fixnum) + (max-str nil) + (ambiguous nil)) + (declare (simple-string namestring)) + (do-search-list (entry dev) + (pushnew entry dirs :test #'string-equal)) + (dolist (entry dirs) + (let ((str (concatenate 'simple-string entry namestring "*"))) + (declare (simple-string str)) + (multiple-value-bind + (res len) + (complete-one-file str default-type ignore-types) + (when res + (unless ambiguous + (setq ambiguous (or max-str (/= (length res) len)))) + (if max-str + (setq max (or (string-not-equal res max-str :end1 len + :end2 max) + max)) + (setq max len max-str res)))))) + (if max-str + (pathnamify max-str max ambiguous pathname) + (values nil nil))))))) + +;;; File-writable -- exported from extensions. +;;; +;;; Determines whether the single argument (which should be a pathname) +;;; can be written by the the current task. + +(defun file-writable (name) + "File-writable accepts a pathname and returns T if the current + process can write it, and NIL otherwise." + (multiple-value-bind (tn exists) (predict-name name nil) + (if exists + (values (mach:unix-access tn mach:w_ok)) + (values (mach:unix-access (directory-namestring tn) + (logior mach:w_ok mach:x_ok)))))) + + +;;; Pathname-Order -- Internal +;;; +;;; Predicate to order pathnames by. Goes by name. +;;; +(defun pathname-order (x y) + (let ((xn (%pathname-name x)) + (yn (%pathname-name y))) + (if (and xn yn) + (let ((res (string-lessp xn yn))) + (cond ((not res) nil) + ((= res (length (the simple-string xn))) t) + ((= res (length (the simple-string yn))) nil) + (t t))) + xn))) + +;;; Ambiguous-Files -- Public +;;; +;;; If the pathname is absolute, just do a directory. If it is relative, +;;; do a directory on each directory in the search-list and merge the results. +;;; +(defun ambiguous-files (pathname &optional defaults) + "Return a list of all files which are possible completions of Pathname. + We look in the directory specified by Defaults as well as looking down + the search list." + (setq pathname (pathname pathname) + defaults (if defaults (pathname defaults) *default-pathname-defaults*)) + (let ((dev (or (%pathname-device pathname) "default"))) + (if (eq dev :absolute) + (directory (concatenate 'simple-string (namestring pathname) "*")) + (let ((namestring (%ses-get-useful-name pathname)) + (dirs (if (and (%pathname-directory defaults) + (string-equal dev "default")) + (list (directory-namestring defaults)) + ())) + (res ())) + (declare (simple-string namestring)) + (do-search-list (entry dev) (pushnew entry dirs :test #'string-equal)) + (dolist (entry dirs) + (let ((str (concatenate 'simple-string entry namestring "*"))) + (declare (simple-string str)) + (setq res (merge 'list res (directory str) + #'pathname-order)))) + res)))) + +;;; Default-Directory -- Public +;;; +;;; This fills in a hole in Common Lisp. We return the first thing we +;;; find by doing a ResolveSearchList on Default. +;;; +(defun default-directory () + "Returns the pathname for the default directory. This is the place where + a file will be written if no directory is specified. This may be changed + with setf." + (multiple-value-bind (gr dir-or-error) + (mach:unix-current-directory) + (if gr + dir-or-error + (error (mach:get-unix-error-msg dir-or-error))))) + +;;; +;;; Maybe this shouldn't go here... +(defsetf default-directory %set-default-directory) + +;;; %Set-Default-Directory -- Internal +;;; +;;; The setf method for Default-Directory. We actually set the environment +;;; variable Current which is by convention the head of the search list. +;;; +(defun %set-default-directory (new-val) + (multiple-value-bind (gr error) + (mach:unix-chdir (predict-name new-val nil)) + (if gr + (car (setf (search-list "default:") + (cdr (multiple-value-list (mach:unix-current-directory))))) + (error (mach:get-unix-error-msg error))))) diff --git a/code/foreign.lisp b/code/foreign.lisp new file mode 100644 index 000000000..da62b5a32 --- /dev/null +++ b/code/foreign.lisp @@ -0,0 +1,281 @@ +;;; -*- Log: code.log; Package: Extensions -*- + +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** + +;;; Functions for dealing with foreign function calls in Common Lisp. + +;;; Written by David B. McDonald, January 1987. + +;;; ******************************************************************* +(in-package "EXTENSIONS" :nicknames '("EXT") :use '("LISP" "SYSTEM")) + +(export '(load-foreign get-code-pointer get-data-pointer)) + +(defconstant Unix-OMagic #x107) +(defconstant Unix-NMagic #x108) +(defconstant Unix-ZMagic #x10b) + +(defconstant Unix-header-size 32) +(defconstant Symbol-Table-Entry-Size 12) + +(defconstant n_undf #x0) +(defconstant n_abs #x2) +(defconstant n_text #x4) +(defconstant n_data #x6) +(defconstant n_bss #x8) +(defconstant n_comm #x12) +(defconstant n_fn #x1f) +(defconstant n_ext #x1) + +(defvar file-count 0 + "Number of foreign function files loaded into the current Lisp.") + +(defvar temporary-foreign-files NIL + "List of dotted pairs containing location and size of object code + loaded so that foreign functions can be called.") + +(proclaim '(fixnum file-count)) + +(defstruct unix-ste + (type 0 :type fixnum) + (location 0)) + + +(defvar foreign-symbols (make-hash-table :size 1000 :test #'equal)) + +(defmacro read-cword (sap offset) + `(let ((rsap ,sap) + (roff ,offset)) + (declare (fixnum roff)) + (setq roff (the fixnum (ash roff 1))) + (logior (ash (%primitive 16bit-system-ref rsap roff) 16) + (%primitive 16bit-system-ref rsap (the fixnum (1+ roff)))))) + +(defun read-miscop-free-pointer () + (let ((aa lisp::alloctable-address) + (in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift))) + (declare (fixnum in)) + (logand (+ (logior (%primitive 16bit-system-ref aa (the fixnum (1+ in))) + (ash (%primitive 16bit-system-ref aa in) 16)) 3) + (lognot 3)))) + +(defun write-miscop-free-pointer (value) + (let ((aa lisp::alloctable-address) + (in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift)) + (vl (logand value #xFFFF)) + (vh (logand (ash value -16) #xFFFF))) + (declare (fixnum in)) + (%primitive 16bit-system-set aa (the fixnum (1+ in)) vl) + (%primitive 16bit-system-set aa in vh))) + +;;; Load-foreign accepts a file or a list of files to be loaded into the +;;; currently running Lisp core. These files should be standard object +;;; files created by you favourite compiler (e.g., cc). It accepts two +;;; optional parameters: libraries is a list of libraries to search +;;; for unresolved references (default is the standard C library), and +;;; env which is a list of Unix environment strings (default is what +;;; lisp started with). Load-foreign runs ld creating an object file +;;; that has been linked so that it can be loaded into a predetermined +;;; location in memory. + +(defun load-foreign (files &optional + (libraries '("-lc")) + (linker "/usr/cs/bin/ld") + (base-file "/usr/misc/.lisp/bin/lisp") + (env lisp::original-lisp-environment)) + "Load-foreign loads a list of C object files into a running Lisp. The + files argument should be a single file or a list of files. The files + may be specified as namestrings or as pathnames. The libraries + argument should be a list of library files as would be specified to + ld. They will be searched in the order given. The default is just + \"-lc\", i.e., the C library. The linker argument is used to specifier + the Unix linker to use to link the object files (the default is + /usr/cs/bin/ld). The base-file argument is used to specify a file to + use as the starting place for defined symbols. The default is the C + start up code for Lisp. The env argument is the Unix environment + variable definitions for the invocation of the linker. The default is + the environment passed to Lisp." + (if (null (listp files)) (setq files (list files))) + (format t "[Loading foreign files ~A ...~%" files) + (let ((tfl (if files (format nil "/tmp/L~d.~d" + (mach:unix-getuid) + (the fixnum (+ (the fixnum (mach:unix-getpid)) + file-count))) + base-file)) + (ofl (get-last-loaded-file file-count base-file)) + (addr (read-miscop-free-pointer))) + (when files + (setq file-count (the fixnum (1+ file-count))) + (format t " [Running ld ...") + (force-output t) + (let ((nfiles ())) + (dolist (f files) + (let* ((pn (merge-pathnames f *default-pathname-defaults*)) + (tn (probe-file pn))) + (push (if tn (namestring tn) f) nfiles))) + (setf files (nreverse nfiles))) + (run-program linker `("-N" "-A" ,ofl "-T" + ,(format nil "~X" (+ addr unix-header-size)) + "-o" ,tfl ,@files ,@libraries) + :env env :wait t :output t :error t) + (push tfl temporary-foreign-files) + (format t " done.]~%")) + (multiple-value-bind (res dev ino mode nlnk uid gid rdev len) + (mach:unix-stat tfl) + (declare (ignore ino mode nlnk uid gid rdev)) + (when (null res) + (error "Could not stat intermediate file ~a, unix error: ~A." + tfl (mach:get-unix-error-msg dev))) + (format t " [Reading Unix object file ...") + (force-output t) + (multiple-value-bind (fd err) (mach:unix-open tfl mach:o_rdonly 0) + (when (null fd) + (error "Failed to open intermediate file ~A, unix error: ~A." + (mach:get-unix-error-msg err))) + (multiple-value-bind (bytes err2) + (mach:unix-read fd (int-sap addr) + len) + (when (or (null bytes) (not (eq bytes len))) + (if (null bytes) + (error "Read of intermediate file ~A failed, unix error: ~A" + tfl (mach:get-unix-error-msg err2)) + (error "Read of intermediate file ~A only read ~d of ~d bytes." + tfl bytes len)))) + (mach:unix-close fd))) + (format t " done.]~%") + (let ((fsize (logand (+ (load-object-file tfl addr files) 4) (lognot 3)))) + (when files (write-miscop-free-pointer (+ addr fsize))))) + (format t "done.]~%")) + +;;; Get-last-loaded-file attempts to find the file that was last loaded into +;;; Lisp. If one is found, load-foreign uses it as the bases for the initial +;;; symbol table. Otherwise, it uses the lisp startup code. + +(defun get-last-loaded-file (fc base-file) + (declare (fixnum fc)) + (do ((i (the fixnum (1- fc)) (1- i))) + ((< i 0) base-file) + (declare (fixnum i)) + (let ((tfl (format nil "/tmp/L~d.~d" (mach:unix-getuid) + (the fixnum (+ (the fixnum (mach:unix-getpid)) i))))) + (if (probe-file tfl) (return tfl))))) + +;;; Load-object-file, actually loads the object file created by ld. +;;; It makes sure that it is a legal object file. + +(defun load-object-file (file addr flag) + (format t " [Loading symbol table information ...") + (force-output t) + (let* ((sap (int-sap addr)) + (magic (read-cword sap 0)) + (text-size (read-cword sap 1)) + (idata-size (read-cword sap 2)) + (udata-size (read-cword sap 3)) + (symtab-size (read-cword sap 4)) + (epoint (read-cword sap 5)) + (treloc-size (read-cword sap 6)) + (dreloc-size (read-cword sap 7)) + (load-size (+ text-size idata-size udata-size unix-header-size)) + (symstart (+ text-size idata-size (if flag unix-header-size 2048))) + (strstart (+ symstart (the fixnum symtab-size)))) + (declare (fixnum magic text-size idata-size udata-size + symtab-size symstart strstart treloc-size + dreloc-size) + (ignore epoint)) + (unless (or (null flag) + (and (= magic unix-OMagic) (= treloc-size 0) (= dreloc-size 0))) + (error "File ~A is not a legal Unix object file." file)) + (read-symbol-table (the fixnum (+ (the fixnum sap) symstart)) + symtab-size (the fixnum (+ (the fixnum sap) strstart))) + (setq load-size (logand (the fixnum (+ load-size 8192)) (lognot 8191))) + (do ((ind (truncate (+ text-size idata-size unix-header-size) 2) + (1+ ind)) + (end (truncate udata-size 2))) + ((>= ind end)) + (%primitive 16bit-system-set sap ind 0)) + (format t " done.]~%") + load-size)) + +;;; Read-symbol-table reads the symbol table out of the object, making +;;; external symbols available to Lisp, so that they can be used to +;;; link to the C routines. + +(defun read-symbol-table (symstart symtab-size strstart) + (let ((end (the fixnum (+ (the fixnum symstart) (the fixnum symtab-size))))) + (do* ((se symstart (the fixnum (+ (the fixnum se) symbol-table-entry-size))) + (si (logior (ash (%primitive 16bit-system-ref se 0) 16) + (%primitive 16bit-system-ref se 1)) + (logior (ash (%primitive 16bit-system-ref se 0) 16) + (%primitive 16bit-system-ref se 1))) + (st (%primitive 8bit-system-ref se 4) + (%primitive 8bit-system-ref se 4)) + (sv (logior (ash (%primitive 16bit-system-ref se 4) 16) + (%primitive 16bit-system-ref se 5)) + (logior (ash (%primitive 16bit-system-ref se 4) 16) + (%primitive 16bit-system-ref se 5)))) + ((>= (the fixnum se) (the fixnum end))) + (declare (fixnum st)) + (when (or (= st (logior n_text n_ext)) + (= st (logior n_data n_ext)) + (= st (logior n_bss n_ext))) + (let* ((strend (%primitive find-character strstart si (+ si 512) 0))) + (when (null strend) + (error "Symbol table string didn't terminate.")) + (let ((strlen (the fixnum (- (the fixnum strend) (the fixnum si)))) + (offset 0) + (code NIL) + (str NIL)) + (declare (fixnum strlen offset)) + (when (eq (%primitive 8bit-system-ref strstart si) (char-code #\_)) + (setq offset (the fixnum (1+ offset))) + (when (eq (%primitive 8bit-system-ref strstart + (the fixnum (1+ (the fixnum si)))) + (char-code #\.)) + (setq code T) + (setq offset (the fixnum (1+ offset))))) + (setq str (make-string (the fixnum (- strlen offset)))) + (%primitive byte-blt strstart + (the fixnum (+ (the fixnum si) offset)) str 0 strlen) + (if (let ((x (ash sv (- (+ clc::type-shift-16 16))))) + (not (<= clc::first-pointer-type x clc::last-pointer-type))) + (let ((ste (gethash str foreign-symbols)) + (loc (int-sap sv))) + (cond ((null ste) + (setf (gethash str foreign-symbols) + (make-unix-ste :type (if code + (logior n_text + n_ext) st) + :location (if code nil loc)))) + (code + (setf (unix-ste-type ste) (logior n_text n_ext))) + (T + (setf (unix-ste-location ste) loc))))))))))) + +;;; Get-code-pointer accepts a simple string which should be the name +;;; of a C routine that has already been loaded into the Lisp core image. +;;; This name should use the correct capitalization of the C name without +;;; the default underscore. +(defun get-code-pointer (name) + (let ((ste (gethash name foreign-symbols))) + (when (null ste) + (error "There is no foreign function named ~A loaded." name)) + (when (not (eq (unix-ste-type ste) (logior n_text n_ext))) + (error "~A is a foreign external variable, not a foreign function." name)) + (unix-ste-location ste))) + + +;;; Get-data-pointer is similar to get-code-pointer, except it returns the +;;; address of a foreign global variable. + +(defun get-data-pointer (name) + (let ((ste (gethash name foreign-symbols))) + (when (null ste) + (error "There is no foreign variable named ~A loaded." name)) + (when (eq (unix-ste-type ste) (logior n_text n_ext)) + (error "~A is a foreign function, not a foreign variable." name)) + (unix-ste-location ste))) diff --git a/code/format.lisp b/code/format.lisp new file mode 100644 index 000000000..975514f0f --- /dev/null +++ b/code/format.lisp @@ -0,0 +1,1514 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Functions to implement FORMAT for Spice Lisp. +;;; +;;; Original by David Adam. +;;; Re-write by Bill Maddox. +;;; Currently not maintained. +;;; +;;; FORMAT is part of the standard Spice Lisp environment. +;;; +;;; ********************************************************************** + +(in-package 'lisp) +(export 'format) + +;;; Special variables local to FORMAT + +(defvar *format-control-string* "" + "The current FORMAT control string") + +(defvar *format-index* 0 + "The current index into *format-control-string*") + +(defvar *format-length* 0 + "The length of the current FORMAT control string") + +(defvar *format-arguments* () + "Arguments to the current call of FORMAT") + +(defvar *format-original-arguments* () + "Saved arglist from top-level FORMAT call for ~* and ~@*") + +(defvar *format-stream-stack* () + "A stack of string streams for collecting FORMAT output") + +(defvar *format-dispatch-table* () + "Dispatch table for FORMAT commands") + + +;;; Specials imported from PRINT and STREAM + +(proclaim '(special *print-base* *standard-output* *terminal-io*)) + +;;; Specials imported from ERRORFUNS + +(proclaim '(special *error-output*)) + + + +;;; ERRORS + +;;; Since errors may occur while an indirect control string is being +;;; processed, i.e. by ~? or ~{~:}, some sort of backtrace is necessary +;;; in order to indicate the location in the control string where the +;;; error was detected. To this end, errors detected by format are +;;; signalled by throwing a list of the form ((control-string args)) +;;; to the tag FORMAT-ERROR. This throw will be caught at each level +;;; of indirection, and the list of error messages re-thrown with an +;;; additional message indicating that indirection was present CONSed +;;; onto it. Ultimately, the last throw will be caught by the top level +;;; FORMAT function, which will then signal an error to the Lisp error +;;; system in such a way that all the errror messages will be displayed +;;; in reverse order. + +(defun format-error (complaint &rest args) + (throw 'format-error + (list (list "~1{~:}~%~S~%~V@T^" complaint args + *format-control-string* (1+ *format-index*))))) + + + +;;; MACROS + +;;; This macro establishes the correct environment for processing +;;; an indirect control string. CONTROL-STRING is the string to +;;; process, and FORMS are the forms to do the processing. They +;;; invariably will involve a call to SUB-FORMAT. CONTROL-STRING +;;; is guaranteed to be evaluated exactly once. + +(defmacro format-with-control-string (control-string &body forms) + `(let ((string (if (simple-string-p ,control-string) + ,control-string + (coerce ,control-string 'simple-string)))) + (declare (simple-string string)) + (let ((error (catch 'format-error + (let ((*format-control-string* string) + (*format-length* (length string)) + (*format-index* 0)) + (declare (simple-string *format-control-string*) + (fixnum *format-length* *format-index*)) + ,@forms + nil)))) + (when error + (throw 'format-error + (cons (list "While processing indirect control string~%~S~%~V@T^" + *format-control-string* + (1+ *format-index*)) + error)))))) + + +;;; This macro rebinds collects output to the standard output stream +;;; in a string. For efficiency, we avoid consing a new stream on +;;; every call. A stack of string streams is maintained in order to +;;; guarantee re-entrancy. + +(defmacro format-stringify-output (&body forms) + `(let ((*standard-output* + (if *format-stream-stack* + (pop *format-stream-stack*) + (make-string-output-stream)))) + (unwind-protect + (progn ,@forms + (prog1 + (get-output-stream-string *standard-output*) + (push *standard-output* *format-stream-stack*))) + (get-output-stream-string *standard-output*)))) + + + +;;; Pops an argument from the current argument list. This is either the +;;; list of arguments given to the top-level call to FORMAT, or the argument +;;; list for the current iteration in a ~{~} construct. An error is signalled +;;; if the argument list is empty. + +(defmacro pop-format-arg () + '(if *format-arguments* + (pop *format-arguments*) + (format-error "Missing argument"))) + + +;;; This macro decomposes the argument list returned by PARSE-FORMAT-OPERATION. +;;; PARMVAR is the list of parameters. PARMDEFS is a list of lists of the form +;;; (<var> <default>). The FORMS are evaluated in an environment where each +;;; <var> is bound to either the value of the parameter supplied in the +;;; parameter list, or to its <default> value if the parameter was omitted or +;;; explicitly defaulted. + +(defmacro with-format-parameters (parmvar parmdefs &body forms) + (do ((parmdefs parmdefs (cdr parmdefs)) + (bindings () (cons `(,(caar parmdefs) (or (if ,parmvar (pop ,parmvar)) + ,(cadar parmdefs))) + bindings))) + ((null parmdefs) + `(let ,(nreverse bindings) + (when ,parmvar + (format-error "Too many parameters")) + ,@forms)))) + + + +;;; CONTROL STRING PARSING + +;;; The current control string is kept in *format-control-string*. +;;; The variable *format-index* is the position of the last character +;;; processed, indexing from zero. The variable *format-length* is the +;;; length of the control string, which is one greater than the maximum +;;; value of *format-index*. + + +;;; Gets the next character from the current control string. It is an +;;; error if there is none. Leave *format-index* pointing to the +;;; character returned. + +(defmacro nextchar () + '(if (< (the fixnum (incf (the fixnum *format-index*))) + (the fixnum *format-length*)) + (schar *format-control-string* *format-index*) + (format-error "Syntax error"))) + + +;;; Returns the current character, i.e. the one pointed to by *format-index*. + +(defmacro format-peek () + '(schar *format-control-string* *format-index*)) + + +;;; Returns the index of the first occurrence of the specified character +;;; between indices START (inclusive) and END (exclusive) in the control +;;; string. + + +(defmacro format-find-char (char start end) + `(position ,char (the simple-string *format-control-string*) + :start ,start :end ,end :test #'char=)) + + +;;; Attempts to parse a parameter, starting at the current index. +;;; Returns the value of the parameter, or NIL if none is found. +;;; On exit, *format-index* points to the first character which is +;;; not a part of the recognized parameter. + +(defun format-get-parameter () + (case (format-peek) + (#\# (nextchar) (length (the list *format-arguments*))) + ((#\V #\v) (prog1 (pop-format-arg) (nextchar))) + (#\' (prog1 (nextchar) (nextchar))) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (do* ((number (digit-char-p (format-peek)) + (+ (* 10 number) (digit-char-p (format-peek))))) + ((not (digit-char-p (nextchar))) number))) + (#\- + (nextchar) + (case (format-peek) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (do* ((number (digit-char-p (format-peek)) + (+ (* 10 number) (digit-char-p (format-peek))))) + ((not (digit-char-p (nextchar))) (- number)))) + (t (decf (the fixnum *format-index*)) ; put back to out of place "-" + nil))) + (#\+ + (nextchar) + (case (format-peek) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (do* ((number (digit-char-p (format-peek)) + (+ (* 10 number) (digit-char-p (format-peek))))) + ((not (digit-char-p (nextchar))) number))) + (t (decf (the fixnum *format-index*)) ; put back to out of place "-" + nil))) + (t nil))) + + +;;; Parses a format directive, including flags and parameters. On entry, +;;; *format-index* should point to the "~" preceding the command. On +;;; exit, *format-index* points to the command character itself. +;;; Returns the list of parameters, the ":" flag, the "@" flag, and the +;;; command character as multiple values. Explicitly defaulted parameters +;;; appear in the list of parameters as NIL. Omitted parameters are simply +;;; not included in the list at all. + +(defun parse-format-operation () + (let ((ch (nextchar))) + (values (if (or (digit-char-p ch) + (member ch '(#\, #\# #\V #\v #\' #\+ #\-) :test #'char=)) + (do ((parms (list (format-get-parameter)) + (cons (format-get-parameter) parms))) + ((char/= (format-peek) #\,) (nreverse parms)) + (declare (list parms)) + (nextchar)) + '()) + (if (char= (format-peek) #\:) (nextchar) nil) + (if (char= (format-peek) #\@) (nextchar) nil) + (format-peek)))) + + + +;;; Starting at the current value of *format-index*, finds the first +;;; occurrence of one of the specified directives. Embedded constructs, +;;; i.e. those inside ~(~), ~[~], ~{~}, or ~<~>, are ignored. And error is +;;; signalled if no satisfactory command is found. Otherwise, the +;;; following are returned as multiple values: +;;; +;;; The value of *format-index* at the start of the search +;;; The index of the "~" character preceding the command +;;; The parameter list of the command +;;; The ":" flag +;;; The "@" flag +;;; The command character +;;; +;;; Implementation note: The present implementation is not particulary +;;; careful with storage allocation. It would be a good idea to have +;;; a separate function for skipping embedded constructs which did not +;;; bother to cons parameter lists and then throw them away. +;;; +;;; We go to some trouble here to use POSITION for most of the searching. +;;; +;;; Another note: *FORMAT-ARGUMENTS* is let bound here so that we can +;;; guarantee that that list is not changed by FORMAT-FIND-COMMAND. +;;; This is necessary since PARSE-FORMAT-OPERATION (called below) calls +;;; FORMAT-GET-PARAMETER. If the parameter is #\V or #\v then +;;; FORMAT-GET-PARAMETER will pop *FORMAT-ARGUMENTS*. This causes the +;;; argument to be lost when we actually go to do the real formatting. +;;; +(defun format-find-command (command-list) + (let ((start *format-index*) + (*format-arguments* *format-arguments*)) + (do ((place start *format-index*) + (tilde (format-find-char #\~ start *format-length*) + (format-find-char #\~ place *format-length*))) + ((not tilde) + (format-error "Expecting one of ~S" command-list)) + (setq *format-index* tilde) + (multiple-value-bind (parms colon atsign command) + (parse-format-operation) + (when (member command command-list :test #'char=) + (return (values start tilde parms colon atsign command))) + (case command + (#\{ (nextchar)(format-find-command '(#\}))) + (#\< (nextchar)(format-find-command '(#\>))) + (#\( (nextchar)(format-find-command '(#\)))) + (#\[ (nextchar)(format-find-command '(#\]))) + ((#\} #\> #\) #\]) + (format-error "No matching bracket"))))))) + + + +;;; This is the FORMAT top-level function. + +(defun format (destination control-string &rest format-arguments) + "Provides various facilities for formatting output. + CONTROL-STRING contains a string to be output, possibly with embedded + directives, which are flagged with the escape character \"~\". Directives + generally expand into additional text to be output, usually consuming one + or more of the FORMAT-ARGUMENTS in the process. A few useful directives + are: + ~A or ~nA Prints one argument as if by PRINC + ~S or ~nS Prints one argument as if by PRIN1 + ~D or ~nD Prints one argument as a decimal integer + ~% Does a TERPRI + ~& Does a FRESH-LINE + + where n is the width of the field in which the object is printed. + + DESTINATION controls where the result will go. If DESTINATION is T, then + the output is sent to the standard output stream. If it is NIL, then the + output is returned in a string as the value of the call. Otherwise, + DESTINATION must be a stream to which the output will be sent. + + Example: (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\" + + FORMAT has many additional capabilities not described here. Consult the + manual for details." + + (let ((*format-original-arguments* format-arguments) ;for abs. and rel. goto + (*format-arguments* format-arguments) + (*print-radix* nil) + (*format-control-string* + (if (simple-string-p control-string) + control-string + (coerce control-string 'simple-string)))) + (declare (simple-string *format-control-string*)) + (cond + ((not destination) + (format-stringify-output + (let ((errorp (catch 'format-error + (catch 'format-escape + (catch 'format-colon-escape + (sub-format 0 (length *format-control-string*)))) + nil))) + (when errorp + (error "~%~:{~@?~%~}" (nreverse errorp)))))) + ((and (stringp destination) (array-has-fill-pointer-p destination)) + (with-output-to-string (*standard-output* destination) + (let ((errorp (catch 'format-error + (catch 'format-escape + (catch 'format-colon-escape + (sub-format 0 (length *format-control-string*)))) + nil))) + (when errorp + (error "~%~:{~@?~%~}" (nreverse errorp))) + nil))) + (t + (let ((*standard-output* + (if (or (eq destination 't) + (and (synonym-stream-p destination) + (eq (synonym-stream-symbol destination) + '*standard-output*))) + *standard-output* + destination))) + (let ((errorp (catch 'format-error + (catch 'format-escape + (catch 'format-colon-escape + (sub-format 0 (length *format-control-string*)))) + nil))) + (when errorp + (error "~%~:{~@?~%~}" (nreverse errorp)))) + nil))))) + +;;; This function does the real work of format. The segment of the control +;;; string between indiced START (inclusive) and END (exclusive) is processed +;;; as follows: Text not part of a directive is output without further +;;; processing. Directives are parsed along with their parameters and flags, +;;; and the appropriate handlers invoked with the arguments COLON, ATSIGN, and +;;; PARMS. +;;; +;;; Implementation Note: FORMAT-FIND-CHAR uses the POSITION sequence operation +;;; for speed. This is potentially faster than character-at-a-time searching. + +(defun sub-format (start end) + (declare (fixnum start end)) + (let ((*format-index* start) + (*format-length* end)) + (declare (fixnum *format-index* *format-length*)) + (do* ((place start *format-index*) + (tilde (format-find-char #\~ start end) + (format-find-char #\~ place end))) + ((not tilde) + (write-string *format-control-string* *standard-output* + :start place :end end)) + (declare (fixnum place) (type (or fixnum null) tilde)) + (when (> tilde place) + (write-string *format-control-string* *standard-output* + :start place :end tilde)) + (setq *format-index* tilde) + (multiple-value-bind + (parms colon atsign command) + (parse-format-operation) + (let ((cmdfun (svref *format-dispatch-table* (char-code command)))) + (if cmdfun + (funcall cmdfun colon atsign parms) + (format-error "Illegal FORMAT command ~~~S" command)))) + (unless (< (the fixnum (incf (the fixnum *format-index*))) end) + (return))))) + + + +;;; Conditional case conversion ~( ... ~) + +(defun format-capitalization (colon atsign parms) + (when parms + (format-error "No parameters allowed to ~~(")) + (nextchar) + (multiple-value-bind + (prev tilde end-parms end-colon end-atsign) + (format-find-command '(#\))) + (when (or end-parms end-colon end-atsign) + (format-error "Flags or parameters not allowed")) + (let ((string (format-stringify-output (sub-format prev tilde)))) + (declare (string string)) + (write-string + (cond ((and atsign colon) + (nstring-upcase string)) + (colon + (nstring-capitalize string)) + (atsign + (let ((strlen (length string))) + (declare (fixnum strlen)) + ;; Capitalize the first word only + (nstring-downcase string) + (do ((i 0 (1+ i))) + ((or (<= strlen i) (alpha-char-p (char string i))) + (setf (char string i) (char-upcase (char string i))) + string) + (declare (fixnum i))))) + (t (nstring-downcase string))))))) + + + +;;; Up and Out (Escape) ~^ + +(defun format-escape (colon atsign parms) + (when atsign + (format-error "FORMAT command ~~~:[~;:~]@^ is undefined" colon)) + (when (if (first parms) + (if (second parms) + (if (third parms) + (typecase (second parms) + (integer + (<= (first parms) (second parms) (third parms))) + (character + (char< (first parms) (second parms) (third parms))) + (t nil)) + (equal (first parms) (second parms))) + (zerop (first parms))) + (not *format-arguments*)) + (throw (if colon 'format-colon-escape 'format-escape) nil))) + + +;;; Conditional expression ~[ ... ] + + +;;; ~[ + +(defun format-untagged-condition () + (let ((test (pop-format-arg))) + (unless (integerp test) + (format-error "Argument to ~~[ must be integer - ~S" test)) + (do ((count 0 (1+ count))) + ((= count test) + (multiple-value-bind + (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\])) + (declare (ignore colon)) + (when atsign + (format-error "Atsign flag not allowed")) + (when parms + (format-error "No parameters allowed")) + (sub-format prev tilde) + (unless (char= cmd #\]) + (format-find-command '(#\]))))) + (multiple-value-bind + (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\])) + (declare (ignore prev tilde)) + (when atsign + (format-error "Atsign flag not allowed")) + (when parms + (format-error "Parameters not allowed")) + (when (char= cmd #\]) (return)) + (when colon + (nextchar) + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\])) + (declare (ignore parms colon atsign)) + (sub-format prev tilde) + (unless (char= cmd #\]) + (format-find-command '(#\])))) + (return)) + (nextchar))))) + + +;;; ~@[ + +(defun format-funny-condition () + (multiple-value-bind + (prev tilde parms colon atsign) + (format-find-command '(#\])) + (when (or colon atsign parms) + (format-error "Flags or arguments not allowed")) + (if *format-arguments* + (if (car *format-arguments*) + (sub-format prev tilde) + (pop *format-arguments*)) + (format-error "Missing argument")))) + + +;;; ~:[ + +(defun format-boolean-condition () + (multiple-value-bind + (prev tilde parms colon atsign) + (format-find-command '(#\;)) + (when (or parms colon atsign) + (format-error "Flags or parameters not allowed")) + (nextchar) + (if (pop-format-arg) + (multiple-value-bind + (prev tilde parms colon atsign) + (format-find-command '(#\])) + (when (or colon atsign parms) + (format-error "Flags or parameters not allowed")) + (sub-format prev tilde)) + (progn + (sub-format prev tilde) + (format-find-command '(#\])))))) + + +(defun format-condition (colon atsign parms) + (when parms + (push (pop parms) *format-arguments*) + (unless (null parms) + (format-error "Too many parameters to ~["))) + (nextchar) + (cond (colon + (when atsign + (format-error "~~:@[ undefined")) + (format-boolean-condition)) + (atsign + (format-funny-condition)) + (t (format-untagged-condition)))) + + +;;; Iteration ~{ ... ~} + +(defun format-iteration (colon atsign parms) + (with-format-parameters parms ((max-iter -1)) + (nextchar) + (multiple-value-bind + (prev tilde end-parms end-colon end-atsign) + (format-find-command '(#\})) + (when (or end-atsign end-parms) + (format-error "Illegal terminator for ~~{")) + (if (= prev tilde) + ;; Use an argument as the control string if ~{~} is empty + (let ((string (pop-format-arg))) + (unless (stringp string) + (format-error "Control string is not a string")) + (format-with-control-string string + (format-do-iteration 0 *format-length* + max-iter colon atsign end-colon))) + (format-do-iteration prev tilde max-iter colon atsign end-colon))))) + + +;;; The two catch tags FORMAT-ESCAPE and FORMAT-COLON-ESCAPE are needed here +;;; to correctly implement ~^ and ~:^. The former aborts only the current +;;; iteration, but the latter aborts the entire iteration process. + +(defun format-do-iteration (start end max-iter colon atsign at-least-once-p) + (catch 'format-colon-escape + (catch 'format-escape + (if atsign + (do* ((count 0 (1+ count))) + ((or (= count max-iter) + (and (null *format-arguments*) + (if (= count 0) (not at-least-once-p) t)))) + (catch 'format-escape + (if colon + (let* ((*format-original-arguments* (pop-format-arg)) + (*format-arguments* *format-original-arguments*)) + (unless (listp *format-arguments*) + (format-error "Argument must be a list")) + (sub-format start end)) + (sub-format start end)))) + (let* ((*format-original-arguments* (pop-format-arg)) + (*format-arguments* *format-original-arguments*)) + (unless (listp *format-arguments*) + (format-error "Argument must be a list")) + (do* ((count 0 (1+ count))) + ((or (= count max-iter) + (and (null *format-arguments*) + (if (= count 0) (not at-least-once-p) t)))) + (catch 'format-escape + (if colon + (let* ((*format-original-arguments* (pop-format-arg)) + (*format-arguments* *format-original-arguments*)) + (unless (listp *format-arguments*) + (format-error "Argument must be a list of lists")) + (sub-format start end)) + (sub-format start end))))))))) + + + +;;; Justification ~< ... ~> + +;;; Parses a list of clauses delimited by ~; and terminated by ~>. +;;; Recursively invoke SUB-FORMAT to process them, and return a list +;;; of the results, the length of this list, and the total number of +;;; characters in the strings composing the list. + +(defun format-get-trailing-segments () + (nextchar) + (multiple-value-bind + (prev tilde colon atsign parms cmd) + (format-find-command '(#\; #\>)) + (when colon + (format-error "~~:; allowed only after first segment in ~~<")) + (when (or atsign parms) + (format-error "Flags and parameters not allowed")) + (let ((str (catch 'format-escape + (format-stringify-output (sub-format prev tilde))))) + (declare (string str)) + (if str + (if (char= cmd #\;) + (multiple-value-bind + (segments numsegs numchars) + (format-get-trailing-segments) + (values (cons str segments) + (1+ numsegs) (+ numchars (length str)))) + (values (list str) 1 (length str))) + (values () 0 0))))) + + +;;; Gets the first segment, which is treated specially. Call +;;; FORMAT-GET-TRAILING-SEGMENTS to get the rest. + +(defun format-get-segments () + (multiple-value-bind + (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\>)) + (when atsign + (format-error "Atsign flag not allowed")) + (let ((first-seg (format-stringify-output (sub-format prev tilde)))) + (if (char= cmd #\;) + (multiple-value-bind + (segments numsegs numchars) + (format-get-trailing-segments) + (if colon + (values first-seg parms segments numsegs numchars) + (values nil nil (cons first-seg segments) (1+ numsegs) + (+ (length first-seg) numchars)))) + (values nil nil (list first-seg) 1 (length first-seg)))))) + + + + +;;; Given the total number of SPACES needed for padding, and the number +;;; of padding segments needed (PADDINGS), returns a list of such segments. +;;; We try to allocate the spaces equally to each segment. When this is +;;; not possible, allocate any left over spaces to the first segment. + +(defun make-pad-segs (spaces padding-segs) + (do* ((extra-space () (and (plusp extra-spaces) + extra-inc + (zerop (rem segs extra-inc)))) + (result () (cons (cond ((= segs 1) (+ min-space extra-spaces)) + (extra-space (1+ min-space)) + (t min-space)) + result)) + (min-space (truncate spaces padding-segs)) + (extra-spaces (- spaces (* padding-segs min-space)) + (if extra-space + (1- extra-spaces) extra-spaces)) + (extra-inc (if (plusp extra-spaces) + (truncate spaces extra-spaces))) + (segs padding-segs (1- segs))) + ((zerop segs) result))) + + +;;; Determine the actual width to be used for a field requiring WIDTH +;;; characters according to the following rule: If WIDTH is less than or +;;; equal to MINCOL, use WIDTH as the actual width. Otherwise, round up +;;; to MINCOL + k * COLINC for the smallest possible positive integer k. + +(defun format-round-columns (width mincol colinc) + (if (> width mincol) + (multiple-value-bind + (quotient remainder) + (floor (- width mincol) colinc) + (+ mincol (* quotient colinc) (if (zerop remainder) 0 colinc))) + mincol)) + + + +(defun format-justification (colon atsign parms) + (with-format-parameters parms + ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (unless (and (integerp mincol) (not (minusp mincol))) + (format-error "Mincol must be a non-negative integer - ~S" mincol)) + (unless (and (integerp colinc) (plusp colinc)) + (format-error "Colinc must be a positive integer - ~S" colinc)) + (unless (and (integerp minpad) (not (minusp minpad))) + (format-error "Minpad must be a non-negative integer - ~S" minpad)) + (unless (characterp padchar) + (format-error "Padchar must be a character - ~S" padchar)) + (nextchar) + (multiple-value-bind + (special-arg special-parms segments numsegs numchars) + (format-get-segments) + (let* ((padsegs (+ (if (or colon (= numsegs 1)) 1 0) + (1- numsegs) + (if (and atsign (or (/= numsegs 1) colon)) + 1 0))) + (width (format-round-columns (+ numchars (* minpad padsegs)) + mincol colinc)) + (spaces (append (if (or colon (= numsegs 1)) () '(0)) + (make-pad-segs (- width numchars) padsegs) + (if (and atsign (or (/= numsegs 1) colon)) + () '(0))))) + (when special-arg + (with-format-parameters special-parms ((spare 0) + (linel (or (line-length) 72))) + (let ((pos (or (charpos *standard-output*) 0))) + (when (> (+ pos width spare) linel) + (write-string special-arg))))) + (cond ((and atsign (= numsegs 1) (not colon)) + (write-string (car segments)) + (dotimes (i (car spaces)) (write-char padchar))) + (t + (do ((segs segments (cdr segs)) + (spcs spaces (cdr spcs))) + ((null segs) (dotimes (i (car spcs)) (write-char padchar))) + (dotimes (i (car spcs)) (write-char padchar)) + (write-string (car segs))))))))) + +;;; Newline ~& + +(defun format-terpri (colon atsign parms) + (when (or colon atsign) + (format-error "Flags not allowed")) + (with-format-parameters parms ((repeat-count 1)) + (dotimes (i repeat-count) (terpri)))) + + +;;; Fresh-line ~% + +(defun format-freshline (colon atsign parms) + (when (or colon atsign) + (format-error "Flags not allowed")) + (with-format-parameters parms ((repeat-count 1)) + (fresh-line) + (dotimes (i (1- repeat-count)) (terpri)))) + + +;;; Page ~| + +(defun format-page (colon atsign parms) + (when (or colon atsign) + (format-error "Flags not allowed")) + (with-format-parameters parms ((repeat-count 1)) + (dotimes (i repeat-count) (write-char #\form)))) + + +;;; Print a tilde ~~ + +(defun format-tilde (colon atsign parms) + (when (or colon atsign) + (format-error "Flags not allowed")) + (with-format-parameters parms ((repeat-count 1)) + (dotimes (i repeat-count) (write-char #\~)))) + + +;;; Continue control string on next line ~<newline> + +(defun format-eat-whitespace () + (nextchar) + (setq *format-index* + (1- (the fixnum + (position-if-not #'(lambda (ch) (or (whitespace-char-p ch) + (char= ch #\linefeed))) + (the simple-string *format-control-string*) + :start *format-index*))))) + + +(defun format-newline (colon atsign parms) + (when parms + (format-error "Parameters not allowed")) + (cond (colon + (when atsign (format-error "~:@<newline> is undefined"))) + (atsign (terpri)(format-eat-whitespace)) + (t (format-eat-whitespace)))) + + +;;; Pluralize word ~P + +(defun format-plural (colon atsign parms) + (when parms + (format-error "Parameters not allowed")) + (when colon + ;; Back up one argument first + (let ((cdrs (- (length (the list *format-original-arguments*)) + (length (the list *format-arguments*)) + 1))) + (if (minusp cdrs) + (format-error "No previous argument") + (setq *format-arguments* + (nthcdr cdrs *format-original-arguments*))))) + (if (eql (pop-format-arg) 1) + (write-string (if atsign "y" "")) + (write-string (if atsign "ies" "s")))) + + + +;;; Skip arguments (relative goto) ~* + +(defun format-skip-arguments (colon atsign parms) + (with-format-parameters parms ((count 1)) + (cond (atsign + (when (or (minusp count) + (> count (length *format-original-arguments*))) + (format-error "Illegal to go to non-existant argument")) + (setq *format-arguments* + (nthcdr count *format-original-arguments*))) + (colon + (let ((cdrs (- (length (the list *format-original-arguments*)) + (length (the list *format-arguments*)) + count))) + (if (minusp cdrs) + (format-error "Skip to nonexistant argument") + (setq *format-arguments* + (nthcdr cdrs *format-original-arguments*))))) + (t + (if (> count (length *format-arguments*)) + (format-error "Skip to nonexistant argument") + (setq *format-arguments* (nthcdr count *format-arguments*))))))) + + + +;;; Indirection ~? + +(defun format-indirection (colon atsign parms) + (if (or colon parms) (format-error "Colon flag or parameters not allowed")) + (let ((string (pop-format-arg))) + (unless (stringp string) + (format-error "Indirected control string is not a string")) + (format-with-control-string string + (if atsign + (sub-format 0 *format-length*) + (let* ((*format-original-arguments* (pop-format-arg)) + (*format-arguments* *format-original-arguments*)) + (unless (listp *format-arguments*) + (format-error "Argument must be a list")) + (sub-format 0 *format-length*)))))) + + + +;;; Tabulation ~T + +(defun format-tab (colon atsign parms) + (with-format-parameters parms ((colnum 1) (colinc 1)) + (when colon + (format-error "Tab-to in pixel units not supported")) + (let* ((pos (charpos *standard-output*)) + (len (cond (pos (let ((col (if atsign (+ pos colnum) colnum))) + (if (> pos col) + (- colinc (rem (- pos col) colinc)) + (- col pos)))) + (atsign colnum) + (t 2)))) + (declare (fixnum len)) + (do ((i len (- i 40))) + ((<= i 40) (write-string " " + *standard-output* :start 0 :end i)) + (declare (fixnum i)) + (write-string " " + *standard-output* + :start 0 + :end 40))))) + +;;; Ascii ~A + +(defun format-princ (colon atsign parms) + (let ((arg (pop-format-arg))) + (if (null parms) + (if arg (princ arg) (write-string (if colon "()" "NIL"))) + (with-format-parameters parms + ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (format-write-field (if arg + (princ-to-string arg) + (if colon "()" "NIL")) + mincol colinc minpad padchar atsign))))) + + + +;;; S-expression ~S + +(defun format-prin1 (colon atsign parms) + (let ((arg (pop-format-arg))) + (if (null parms) + (if arg (prin1 arg) (write-string (if colon "()" "NIL"))) + (with-format-parameters parms + ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (format-write-field (if arg + (prin1-to-string arg) + (if colon "()" "NIL")) + mincol colinc minpad padchar atsign))))) + + + +;;; Character ~C + +(defun format-print-character (colon atsign parms) + (with-format-parameters parms () + (let ((char (pop-format-arg))) + (unless (characterp char) + (format-error "Argument must be a character")) + (cond ((and atsign (not colon)) (prin1 char)) + (t (format-print-named-character char colon)))))) + + +(defun format-print-named-character (char longp) + (when (char-bit char :control) + (write-string (if longp "Control-" "C-"))) + (when (char-bit char :meta) + (write-string (if longp "Meta-" "M-"))) + (when (char-bit char :super) + (write-string (if longp "Super-" "S-"))) + (when (char-bit char :hyper) + (write-string (if longp "Hyper-" "H-"))) + (let* ((ch (code-char (char-code char))) ;strip funny bits + (name (char-name ch))) + (cond (name (write-string (string-capitalize name))) + ;; Print control characters as "^"<char> + ((<= 0 (the fixnum (char-code char)) 31) + (write-char #\^) + (write-char (code-char (+ 64 (the fixnum (char-code char)))))) + (t (write-char ch))))) + + + + +;;; NUMERIC PRINTING + + +;;; Insert commas after every third digit, scanning from right to left. + +(defun format-add-commas (string commachar) + (do* ((length (length (the string string))) + (new-length (+ length + (the fixnum (floor (the fixnum (1- length)) 3)))) + (new-string (make-string new-length :initial-element commachar) + (replace (the string new-string) + (the string string) + :start1 (max 0 (- new-pos 3)) + :end1 new-pos + :start2 (max 0 (- pos 3)) + :end2 pos)) + (pos length (- pos 3)) + (new-pos new-length (- new-pos 4))) + ((not (plusp pos)) new-string) + (declare (fixnum length new-length pos new-pos)))) + + +;;; Output a string in a field at MINCOL wide, padding with PADCHAR. +;;; Pads on the left if PADLEFT is true, else on the right. If the +;;; length of the string plus the minimum permissible padding, MINPAD, +;;; is greater than MINCOL, the actual field size is rounded up to +;;; MINCOL + k * COLINC for the smallest possible positive integer k. + +(defun format-write-field (string mincol colinc minpad padchar padleft) + (unless (and (integerp mincol) (not (minusp mincol))) + (format-error "Mincol must be a non-negative integer - ~S" mincol)) + (unless (and (integerp colinc) (plusp colinc)) + (format-error "Colinc must be a positive integer - ~S" colinc)) + (unless (and (integerp minpad) (not (minusp minpad))) + (format-error "Minpad must be a non-negative integer - ~S" minpad)) + (unless (characterp padchar) + (format-error "Padchar must be a character - ~S" padchar)) + (let* ((strlen (length (the string string))) + (width (format-round-columns (+ strlen minpad) mincol colinc))) + (cond (padleft + (dotimes (i (- width strlen)) (write-char padchar)) + (write-string string)) + (t + (write-string string) + (dotimes (i (- width strlen)) (write-char padchar)))))) + + +;;; This functions does most of the work for the numeric printing +;;; directives. The parameters are interpreted as defined for ~D. + +(defun format-print-number (number radix print-commas-p print-sign-p parms) + (with-format-parameters parms + ((mincol 0) (padchar #\space) (commachar #\,)) + (let* ((*print-base* radix) + (text (princ-to-string number))) + (if (integerp number) + (format-write-field + (if (and (plusp number) print-sign-p) + (if print-commas-p + (concatenate 'string "+" (format-add-commas text commachar)) + (concatenate 'string "+" text)) + (if print-commas-p + (format-add-commas text commachar) + text)) + mincol 1 0 padchar t) ;colinc = 1, minpad = 0, padleft = t + (write-string text))))) + + +;;; Print a cardinal number in English + + +;;; The following are initialized in FORMAT-INIT to get around cold-loader +;;; lossage. + +(defvar cardinal-ones () "Table of cardinal ones-place digits in English") + +(defvar cardinal-tens () "Table of cardinal tens-place digits in English") + +(defvar cardinal-teens () "Table of cardinal 'teens' digits in English") + + +(defun format-print-small-cardinal (n) + (multiple-value-bind + (hundreds rem) (truncate n 100) + (when (plusp hundreds) + (write-string (svref cardinal-ones hundreds)) + (write-string " hundred") + (when (plusp rem) (write-char #\space))) ; ; ; RAD + (when (plusp rem) + (multiple-value-bind (tens ones) + (truncate rem 10) + (cond ((< 1 tens) + (write-string (svref cardinal-tens tens)) + (when (plusp ones) + (write-char #\-) + (write-string (svref cardinal-ones ones)))) + ((= tens 1) + (write-string (svref cardinal-teens ones))) + ((plusp ones) + (write-string (svref cardinal-ones ones)))))))) + + +(defvar cardinal-periods () "Table of cardinal 'illions' in English") + + +(defun format-print-cardinal (n) + (cond ((minusp n) + (write-string "negative ") + (format-print-cardinal-aux (- n) 0 n)) + ((zerop n) + (write-string "zero")) + (t (format-print-cardinal-aux n 0 n)))) + +(defun format-print-cardinal-aux (n period err) + (multiple-value-bind (beyond here) (truncate n 1000) + (unless (<= period 10) + (format-error "Number too large to print in English: ~:D" err)) + (unless (zerop beyond) + (format-print-cardinal-aux beyond (1+ period) err)) + (unless (zerop here) + (unless (zerop beyond) (write-char #\space)) + (format-print-small-cardinal here) + (write-string (svref cardinal-periods period))))) + + +;;; Print an ordinal number in English + + +(defvar ordinal-ones () "Table of ordinal ones-place digits in English") + +(defvar ordinal-tens () "Table of ordinal tens-place digits in English") + + +(defun format-print-ordinal (n) + (when (minusp n) + (write-string "negative ")) + (let ((number (abs n))) + (multiple-value-bind + (top bot) (truncate number 100) + (unless (zerop top) (format-print-cardinal (- number bot))) + (when (and (plusp top) (plusp bot)) (write-char #\space)) + (multiple-value-bind + (tens ones) (truncate bot 10) + (cond ((= bot 12) (write-string "twelfth")) + ((= tens 1) + (write-string (svref cardinal-teens ones));;;RAD + (write-string "th")) + ((and (zerop tens) (plusp ones)) + (write-string (svref ordinal-ones ones))) + ((and (zerop ones)(plusp tens)) + (write-string (svref ordinal-tens tens))) + ((plusp bot) + (write-string (svref cardinal-tens tens)) + (write-char #\-) + (write-string (svref ordinal-ones ones))) + ((plusp number) (write-string "th")) + (t (write-string "zeroeth"))))))) + + +;;; Print Roman numerals + +(defun format-print-old-roman (n) + (unless (< 0 n 5000) + (format-error "Number too large to print in old Roman numerals: ~:D" n)) + (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) + (val-list '(500 100 50 10 5 1) (cdr val-list)) + (cur-char #\M (car char-list)) + (cur-val 1000 (car val-list)) + (start n (do ((i start (progn (write-char cur-char) (- i cur-val)))) + ((< i cur-val) i)))) + ((zerop start)))) + + +(defun format-print-roman (n) + (unless (< 0 n 4000) + (format-error "Number too large to print in Roman numerals: ~:D" n)) + (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) + (val-list '(500 100 50 10 5 1) (cdr val-list)) + (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars)) + (sub-val '(100 10 10 1 1 0) (cdr sub-val)) + (cur-char #\M (car char-list)) + (cur-val 1000 (car val-list)) + (cur-sub-char #\C (car sub-chars)) + (cur-sub-val 100 (car sub-val)) + (start n (do ((i start (progn (write-char cur-char) (- i cur-val)))) + ((< i cur-val) + (cond ((<= (- cur-val cur-sub-val) i) + (write-char cur-sub-char) + (write-char cur-char) + (- i (- cur-val cur-sub-val))) + (t i)))))) + ((zerop start)))) + + + +;;; Decimal ~D + +(defun format-print-decimal (colon atsign parms) + (format-print-number (pop-format-arg) 10 colon atsign parms)) + + +;;; Binary ~B + +(defun format-print-binary (colon atsign parms) + (format-print-number (pop-format-arg) 2 colon atsign parms)) + + +;;; Octal ~O + +(defun format-print-octal (colon atsign parms) + (format-print-number (pop-format-arg) 8 colon atsign parms)) + + +;;; Hexadecimal ~X + +(defun format-print-hexadecimal (colon atsign parms) + (format-print-number (pop-format-arg) 16 colon atsign parms)) + + +;;; Radix ~R + +(defun format-print-radix (colon atsign parms) + (let ((number (pop-format-arg))) + (if parms + (format-print-number number (pop parms) colon atsign parms) + (if atsign + (if colon + (format-print-old-roman number) + (format-print-roman number)) + (if colon + (format-print-ordinal number) + (format-print-cardinal number)))))) + + +;;; FLOATING-POINT NUMBERS + + +;;; Fixed-format floating point ~F + +(defun format-fixed (colon atsign parms) + (when colon + (format-error "Colon flag not allowed")) + (with-format-parameters parms + ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) + ;;Note that the scale factor k defaults to nil. This is interpreted as + ;;zero by flonum-to-string, but more efficiently. + (let ((number (pop-format-arg))) + (if (floatp number) + (format-fixed-aux number w d k ovf pad atsign) + (if (rationalp number) + (format-fixed-aux + (coerce number 'short-float) w d k ovf pad atsign) + (let ((*print-base* 10)) + (format-write-field + (princ-to-string number) w 1 0 #\space t))))))) + + +(defun format-fixed-aux (number w d k ovf pad atsign) + (if (not (or w d)) + (prin1 number) + (let ((spaceleft w)) + (when (and w (or atsign (minusp number))) (decf spaceleft)) + (multiple-value-bind + (str len lpoint tpoint) + (flonum-to-string (abs number) spaceleft d k) + ;;if caller specifically requested no fraction digits, suppress the + ;;optional trailing zero + (when (and d (zerop d)) (setq tpoint nil)) + (when w + (decf spaceleft len) + ;;optional leading zero + (when lpoint + (if (or (> spaceleft 0) tpoint) ;force at least one digit + (decf spaceleft) + (setq lpoint nil))) + ;;optional trailing zero + (when tpoint + (if (> spaceleft 0) + (decf spaceleft) + (setq tpoint nil)))) + (cond ((and w (< spaceleft 0) ovf) + ;;field width overflow + (dotimes (i w) (write-char ovf))) + (t (when w (dotimes (i spaceleft) (write-char pad))) + (if (minusp number) + (write-char #\-) + (if atsign (write-char #\+))) + (when lpoint (write-char #\0)) + (write-string str) + (when tpoint (write-char #\0)))))))) + + +;;; Exponential-format floating point ~E + + +(defun format-exponential (colon atsign parms) + (when colon + (format-error "Colon flag not allowed")) + (with-format-parameters parms + ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil)) + (let ((number (pop-format-arg))) + (if (floatp number) + (format-exp-aux number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-exp-aux + (coerce number 'short-float) w d e k ovf pad marker atsign) + (let ((*print-base* 10)) + (format-write-field + (princ-to-string number) w 1 0 #\space t))))))) + + +(defun format-exponent-marker (number) + (if (typep number *read-default-float-format*) + #\E + (typecase number + (short-float #\S) +; (single-float #\F) + (double-float #\D) + (long-float #\L)))) + + +;;;Here we prevent the scale factor from shifting all significance out of +;;;a number to the right. We allow insignificant zeroes to be shifted in +;;;to the left right, athough it is an error to specify k and d such that this +;;;occurs. Perhaps we should detect both these condtions and flag them as +;;;errors. As for now, we let the user get away with it, and merely guarantee +;;;that at least one significant digit will appear. + +(defun format-exp-aux (number w d e k ovf pad marker atsign) + (if (not (or w d)) + (prin1 number) + (multiple-value-bind (num expt) + (scale-exponent (abs number)) + (let* ((expt (- expt k)) + (estr (princ-to-string (abs expt))) + (elen (if e (max (length estr) e) (length estr))) + (fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) + (fmin (if (minusp k) (- 1 k) nil)) + (spaceleft (if w (- w 2 elen) nil))) + (when (or atsign (minusp number)) (decf spaceleft)) + (if (and w e ovf (> elen e)) + ;;exponent overflow + (dotimes (i w) (write-char ovf)) + (multiple-value-bind (fstr flen lpoint ) ;(tpoint) + (flonum-to-string num spaceleft fdig k fmin) + (when w + (decf spaceleft flen) + ;; (when tpoint (decf spaceleft)) ; deleted as per Rutgers' fix + (when lpoint + (if (> spaceleft 0) + (decf spaceleft) + (setq lpoint nil)))) + (cond ((and w (< spaceleft 0) ovf) + ;;significand overflow + (dotimes (i w) (write-char ovf))) + (t (when w + (dotimes (i spaceleft) (write-char pad))) + (if (minusp number) + (write-char #\-) + (if atsign (write-char #\+))) + (when lpoint (write-char #\0)) + (write-string fstr) + ;; (when tpoint (write-char #\0)) ; as per Rutgers' fix + (write-char (if marker + marker + (format-exponent-marker number))) + (write-char (if (minusp expt) #\- #\+)) + (when e + ;;zero-fill before exponent if necessary + (dotimes (i (- e (length estr))) (write-char #\0))) + (write-string estr))))))))) + + + +;;; General Floating Point - ~G + +(defun format-general-float (colon atsign parms) + (when colon + (format-error "Colon flag not allowed")) + (with-format-parameters parms + ((w nil) (d nil) (e nil) (k nil) (ovf #\*) (pad #\space) (marker nil)) + (let ((number (pop-format-arg))) + ;;The Excelsior edition does not say what to do if + ;;the argument is not a float. Here, we adopt the + ;;conventions used by ~F and ~E. + (if (floatp number) + (format-general-aux number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-general-aux + (coerce number 'short-float) w d e k ovf pad marker atsign) + (let ((*print-base* 10)) + (format-write-field + (princ-to-string number) w 1 0 #\space t))))))) + + +(defun format-general-aux (number w d e k ovf pad marker atsign) + (multiple-value-bind (ignore n) + (scale-exponent (abs number)) + (declare (ignore ignore)) + ;;Default d if omitted. The procedure is taken directly + ;;from the definition given in the manual, and is not + ;;very efficient, since we generate the digits twice. + ;;Future maintainers are encouraged to improve on this. + (unless d + (multiple-value-bind (str len) + (flonum-to-string (abs number)) + (declare (ignore str)) + (let ((q (if (= len 1) 1 (1- len)))) + (setq d (max q (min n 7)))))) + (let* ((ee (if e (+ e 2) 4)) + (ww (if w (- w ee) nil)) + (dd (- d n))) + (cond ((<= 0 dd d) + (format-fixed-aux number ww dd nil ovf pad atsign) + (dotimes (i ee) (write-char #\space))) + (t (format-exp-aux + number w d e (or k 1) ovf pad marker atsign)))))) + + +;;; Dollars floating-point format ~$ + +(defun format-dollars (colon atsign parms) + (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space)) + (let ((number (pop-format-arg))) + (if (rationalp number) (setq number (coerce number 'short-float))) + (if (floatp number) + (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) + (signlen (length signstr))) + (multiple-value-bind (str strlen ig2 ig3 pointplace) + (flonum-to-string number nil d nil) + (declare (ignore ig2 ig3)) + (when colon (write-string signstr)) + (dotimes (i (- w signlen (- n pointplace) strlen)) + (write-char pad)) + (unless colon (write-string signstr)) + (dotimes (i (- n pointplace)) (write-char #\0)) + (write-string str))) + (let ((*print-base* 10)) + (format-write-field (princ-to-string number) w 1 0 #\space t)))))) + + +;;; The following crock simulates some Common Lisp functions in the +;;; cross-compiler's MACLISP environment for the benefit of the hairy +;;; dispatch-table initialization macro. The internal representation +;;; of character objects in the compiler is known to this code. + +#| +(eval-when (compile-maclisp) + + (setq char-code-limit 256) + + (defun char-downcase (char) + (let ((ch (cadr char))) + (if (lessp 64 ch 91) (list '**character** (+ ch 32)) char))) + + (defun char-upcase (char) + (let ((ch (cadr char))) + (if (lessp 96 ch 123) (list '**character** (- ch 32)) char))) + + (defun char= (a b) + (= (cadr a) (cadr b))) + + (defun char< (a b) + (< (cadr a) (cadr b))) + + (defun char-code (char) + (cadr char)) + + (defun code-char (code) + (list '**character** code))) +|# + +;;; INITIALIZATION + + +;;; Hairy dispatch-table initialization macro. Takes a list of two-element +;;; lists (<character> <function-object>) and returns a vector char-code-limit +;;; elements in length, where the Ith element is the function associated with +;;; the character with char-code I. If the character is case-convertible, it +;;; must be given in only one case; however, an entry in the vector will be +;;; made for both. + + +(defmacro make-dispatch-vector (&body entries) + (let ((entries (mapcan #'(lambda (x) + (let ((lower (char-downcase (car x))) + (upper (char-upcase (car x)))) + (if (char= lower upper) + (list x) + (list (cons upper (cdr x)) + (cons lower (cdr x)))))) + entries))) + (do ((entries (sort entries #'(lambda (x y) (char< (car x) (car y))))) + (charidx 0 (1+ charidx)) + (comtab () (cons (if entries + (if (= (char-code (caar entries)) charidx) + (cadr (pop entries)) + nil) + nil) + comtab))) + ((= charidx char-code-limit) + (if entries + (error "Garbage in dispatch vector - ~S" entries)) + `(vector ,@(nreverse comtab)))))) + + + +;;; These initializations properly belong in the DEFVARs for these objects. +;;; At present, they must be done after loading due to a limitation in the +;;; cold loader. + +(defun format-init () + (setq cardinal-ones + '#(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) + (setq cardinal-tens + '#(nil nil "twenty" "thirty" "forty" + "fifty" "sixty" "seventy" "eighty" "ninety")) + (setq cardinal-teens + '#("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD + "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) + (setq cardinal-periods + '#("" " thousand" " million" " billion" " trillion" " quadrillion" + " quintillion" " sextillion" " septillion" " octillion" " nonillion" + " decillion")) + (setq ordinal-ones + '#(nil "first" "second" "third" "fourth" + "fifth" "sixth" "seventh" "eighth" "ninth")) + (setq ordinal-tens + '#(nil "tenth" "twentieth" "thirtieth" "fortieth" + "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) + (setq *format-dispatch-table* + (make-dispatch-vector + (#\B #'format-print-binary) + (#\O #'format-print-octal) + (#\D #'format-print-decimal) + (#\X #'format-print-hexadecimal) + (#\R #'format-print-radix) + (#\F #'format-fixed) + (#\E #'format-exponential) + (#\G #'format-general-float) + (#\A #'format-princ) + (#\C #'format-print-character) + (#\P #'format-plural) + (#\S #'format-prin1) + (#\T #'format-tab) + (#\% #'format-terpri) + (#\& #'format-freshline) + (#\* #'format-skip-arguments) + (#\| #'format-page) + (#\~ #'format-tilde) + (#\$ #'format-dollars) + (#\? #'format-indirection) + (#\^ #'format-escape) + (#\[ #'format-condition) + (#\{ #'format-iteration) + (#\< #'format-justification) + (#\( #'format-capitalization) + (#\newline #'format-newline)))) diff --git a/code/gc.lisp b/code/gc.lisp new file mode 100644 index 000000000..bae155f5c --- /dev/null +++ b/code/gc.lisp @@ -0,0 +1,604 @@ +;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*- +;;; +;;; Replacement for the GC brain damage in misc.lisp +;;; +;;; Written by Christopher Hoover. +;;; + +(in-package "EXTENSIONS") +(export '(*before-gc-hooks* *after-gc-hooks* gc *ask-about-gc* + *bytes-consed-between-gcs* + *gc-verbose* *gc-notify-before* *gc-notify-after* + *gc-inhibit-hook* + get-bytes-consed)) + +(in-package "LISP") + + +;;;; Room. + +(defvar alloctable-address (int-sap %fixnum-alloctable-address) + "A system area pointer that addresses the the alloctable.") + +(defun alloc-ref (index) + (logior (%primitive 16bit-system-ref alloctable-address (1+ index)) + (ash (logand %type-space-mask + (%primitive 16bit-system-ref alloctable-address index)) + 16))) + +(defun space-usage (type) + (let ((base (ash type %alloc-ref-type-shift))) + (values (alloc-ref base) + (alloc-ref (+ base 8)) + (alloc-ref (+ base 12))))) + +(defconstant type-space-names + '#("Bignum" "Ratio" "Complex" "Short-Float" "Short-Float" "Long-Float" + "String" "Bit-Vector" "Integer-Vector" "Code-Vector" "General-Vector" + "Array" "Function" "Symbol" "List")) + +(defun room-header () + (fresh-line) + (princ " Type | Dynamic | Static | Read-Only | Total") + (terpri) + (princ "-------------------|-----------|-----------|-----------|-----------") + (terpri)) + +(defun room-summary (dynamic static read-only) + (princ "-------------------|-----------|-----------|-----------|-----------") + (format t "~% Totals: |~10:D |~10:D |~10:D =~10:D~%" + dynamic static read-only (+ static dynamic read-only))) + +(defun describe-one-type (type dynamic static read-only) + (declare (fixnum type dynamic static read-only)) + (format t "~18A |~10:D |~10:D |~10:D |~10:D~%" + (elt (the simple-vector type-space-names) + (the fixnum (- type (the fixnum %first-pointer-type)))) + dynamic static read-only (the fixnum (+ static dynamic read-only)))) + +(defun room (&optional (x t) (object nil argp)) + "Displays information about storage allocation. + If X is true then information is displayed broken down by types. + If Object is supplied then just display information for objects of + that type." + (when x + (let ((type (%primitive get-type object))) + (when (or (> type %last-pointer-type) + (< type %first-pointer-type)) + (error "Objects of type ~S have no allocated storage." + (type-of object))) + (room-header) + (cond + (argp + (multiple-value-bind (dyn stat ro) + (space-usage type) + (describe-one-type type dyn stat ro))) + (t + (let ((cum-dyn 0) + (cum-stat 0) + (cum-ro 0)) + (do ((type %first-pointer-type (1+ type))) + ((= type (1+ %last-pointer-type))) + (if (not (or (eq type %short-+-float-type) + (eq type %short---float-type))) + (multiple-value-bind (dyn stat ro) + (space-usage type) + (describe-one-type type dyn stat ro) + (incf cum-dyn dyn) (incf cum-stat stat) (incf cum-ro ro)))) + (room-summary cum-dyn cum-stat cum-ro))))))) + + +;;;; DYNAMIC-USAGE + +;;; +;;; DYNAMIC-USAGE -- Interface +;;; +;;; Return the number of bytes of dynamic storage allocated. +;;; +(defun dynamic-usage () + "Returns the number of bytes of dynamic storage currently allocated." + (system:%primitive dynamic-space-in-use)) + + +;;; GET-BYTES-CONSED + +;;; +;;; Internal State +;;; +(defvar *last-bytes-in-use* nil) +(defvar *total-bytes-consed* 0) + +;;; +;;; GET-BYTES-CONSED -- Exported +;;; +(defun get-bytes-consed () + "Returns the number of bytes consed since the first time this function + was called. The first time it is called, it returns zero." + (cond ((null *last-bytes-in-use*) + (setq *last-bytes-in-use* (dynamic-usage)) + (setq *total-bytes-consed* 0)) + (t + (let ((bytes (dynamic-usage))) + (incf *total-bytes-consed* (- bytes *last-bytes-in-use*)) + (setq *last-bytes-in-use* bytes)))) + *total-bytes-consed*) + + +;;;; Variables and Constants + +;;; +;;; DEFAULT-BYTES-CONSED-BETWEEN-GCS +;;; +;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*. +;;; This should not be set by the user. +;;; +(defconstant default-bytes-consed-between-gcs 2000000) + +;;; +;;; *BYTES-CONSED-BETWEEN-GCS* +;;; +;;; This variable is the user-settable variable that specifices the +;;; minimum amount of dynamic space which must be consed before a GC +;;; will be triggered. +;;; +(defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs + "This number specifies the minimum number of bytes of dynamic space + that must be consed before the next gc will occur.") + +;;; +;;; *GC-TRIGGER* +;;; +;;; Internal trigger. When the dynamic usage increases beyond this +;;; amount, the system notes that a garbage collection needs to occur by +;;; setting *NEED-TO-COLLECT-GARBAGE* to T. +;;; +(defvar *gc-trigger* default-bytes-consed-between-gcs) + + + +;;; +;;; The following specials are used to control when garbage collection +;;; occurs. +;;; + +;;; +;;; *GC-INHIBIT* +;;; +;;; When Y, inhibits garbage collection. +;;; +(defvar *gc-inhibit* nil) + +;;; +;;; *ALREADY-MAYBE-GCING* +;;; +;;; This flag is used to prevent recursive entry into the garbage +;;; collector. +;;; +(defvar *already-maybe-gcing* nil) + +;;; +;;; *NEED-TO-COLLECT-GARBAGE* +;;; +;;; When T, indicates that the dynamic usage has exceeded the value +;;; *GC-TRIGGER*. +;;; +(defvar *need-to-collect-garbage* nil) + + +;;;; GC Hooks + +;;; +;;; *BEFORE-GC-HOOKS* +;;; *AFTER-GC-HOOKS* +;;; +;;; These variables are a list of functions which are run before and +;;; after garbage collection occurs. +;;; +(defvar *before-gc-hooks* nil + "A list of functions that are called before garbage collection occurs. + The functions should take no arguments.") +;;; +(defvar *after-gc-hooks* nil + "A list of functions that are called after garbage collection occurs. + The functions should take no arguments.") + +;;; +;;; *GC-INHIBIT-HOOK* +;;; +;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC +;;; was explicitly forced by calling EXT:GC). If the hook function +;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and +;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T. +;;; Presumably someone will call GC-ON later to collect the garbage. +;;; +(defvar *gc-inhibit-hook* nil + "Should be bound to a function or NIL. If it is a function, this + function should take one argument, the current amount of dynamic + usage. The function should return NIL if garbage collection should + continue and non-NIL if it should be inhibited. Use with caution.") + + + +(defun default-gc-notify-before (bytes-in-use) + (system:beep *standard-output*) + (format t "~&[GC threshold exceeded with ~:D bytes in use. ~ + Commencing GC.]~%" bytes-in-use) + (finish-output)) +;;; +(defparameter *gc-notify-before* #'default-gc-notify-before + "This function is invoked before GC'ing with the number of bytes in use. It + notifies the user that the system is going into GC.") + +(defun default-gc-notify-after (bytes-retained bytes-freed new-trigger) + (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%" + bytes-retained bytes-freed) + (format t "[GC will next occur when at least ~:D bytes are in use.]~%" + new-trigger) + (system:beep *standard-output*) + (finish-output)) +;;; +(defparameter *gc-notify-after* #'default-gc-notify-after + "This function is invoked after GC'ing with the number of bytes freed. It + notifies the user that the system is going into GC.") + + +;;;; Stack grovelling: + +;;; VECTOR-ALLOC-END -- Internal +;;; +;;; Return a pointer to past the end of the memory allocated for a +;;; vector-like object. +;;; +(defun vector-alloc-end (vec) + (%primitive pointer+ + vec + (* (%primitive vector-word-length vec) %word-size))) + + +(defvar *gc-debug* nil) + +;;; PRINT-RAW-ADDR -- Interface +;;; +;;; Print the full address of an arbitary object. +;;; +(defun print-raw-addr (x &optional (stream *standard-output*)) + (let ((fix (%primitive make-fixnum x))) + (format stream "~4,'0X~4,'0X " + (logior (ash (%primitive get-type x) 11) + (ash (%primitive get-space x) 9) + (ash fix -16)) + (logand fix #xFFFF)))) + + +;;; GC-GROVEL-STACK -- Internal +;;; +;;; Locate all raw pointers on stack stack, and clobber them with something +;;; that won't cause GC to gag. We return a list of lists of the form: +;;; (object offset stack-location*), +;;; +;;; where Object is some valid vector-like object pointer and Offset is an +;;; offset to be added to Object. The result of this addition should be stored +;;; into each Stack-Location after GC completes. We clobber the stack +;;; locations with Offset for no particular reason (might aid debugging.) +;;; +;;; There are three major steps in the algorithm: +;;; +;;; 1] Find all the distinct vector-like pointers on the stack, building a +;;; list of all the locations that each pointer is stored in. We do this +;;; using two hash-tables: the one for code pointers is separate, since +;;; they must be special-cased. +;;; +;;; Note that we do our scan downward from the current CONT, and thus don't +;;; scan our own frame. We don't want to modify the frame for the running +;;; function, as this is apt to cause problems. It isn't necessary to +;;; grovel the current frame because we return before GC happens. +;;; +;;; 2] Sort all of the vector-like pointers (other than code vectors), and +;;; scan through this list finding raw pointers based on the assumption +;;; that we will always see the true pointer to the vector header before +;;; any raw pointers into that vector. This exploits our GC invariant that +;;; when an indexing temp is in use, the true object pointer must be live +;;; on the stack or in a register. [By now, any register indexing temp +;;; will have been saved on the stack.] +;;; +;;; During this scan, we also note any true vector pointers that point to a +;;; function object. +;;; +;;; Whenever we locate a raw vector pointer, we create a fixup for the +;;; locations holding that pointer and then clobber the locations. +;;; +;;; 3] Iterate over all code pointers, clobbering the locations and +;;; making fixups for those pointers that point inside some function object +;;; that appears on the stack. This exploits our GC invariant that a +;;; *valid* code pointer only appears on the stack when some containing +;;; function object also appears on the stack. Note that *invalid* code +;;; pointers may appear in the stack garbage unaccompanied by any function +;;; object. Such isolated code pointers are set to 0. (Code pointers in +;;; the heap must always point to the code vector header, and are always +;;; considered valid.) +;;; +;;; This different invariant for code pointers allows us to throw around +;;; raw code pointers without clearing them when they are no longer needed. +;;; +(defun gc-grovel-stack () + (let ((vec-table (make-hash-table :test #'eq)) + (code-table (make-hash-table :test #'eq)) + (base (%primitive make-immediate-type 0 %control-stack-type)) + (fixups ())) + ;; + ;; Find all vector-like objects on the stack, putting code vectors in a + ;; separate table. (step 1) + (do ((sp (%primitive pointer+ (%primitive current-cont) + (- %stack-increment)) + (%primitive pointer+ sp (- %stack-increment)))) + ((%primitive pointer< sp base)) + (let* ((el (%primitive read-control-stack sp)) + (el-type (%primitive get-type el))) + + (when (and *gc-debug* (simple-vector-p el)) + (let ((hdr (%primitive read-control-stack el))) + (unless (and (fixnump hdr) (> hdr 0) + (<= (length el) #xFFFF) + (<= (%primitive get-vector-subtype el) + 3)) + (format t "Suspicious G-vector ") + (print-raw-addr el) + (format t "at ") + (print-raw-addr sp) + (terpri)))) + + (when (and (< (%primitive get-space el) %static-space) + (<= %string-type el-type %function-type)) + (push sp (gethash el + (if (eq el-type %code-type) + code-table + vec-table)))))) + + (let ((vecs ()) + (functions ())) + (maphash #'(lambda (k v) + (declare (ignore v)) + (push k vecs)) + vec-table) + + (setq vecs + (sort vecs + #'(lambda (x y) + (%primitive pointer< x y)))) + + ;; + ;; Iterate over non-code vector-like pointers in order (step 2.) + (loop + (unless vecs (return)) + (let* ((base (pop vecs)) + (end (vector-alloc-end base))) + + (when (and (= (%primitive get-type base) %function-type) + (<= %function-entry-subtype + (%primitive get-vector-subtype base) + %function-constants-subtype)) + (push base functions)) + + (loop + (unless vecs (return)) + (let ((next (first vecs))) + (unless (%primitive pointer< next end) (return)) + (pop vecs) + + (let ((offset (%primitive pointer- next base)) + (sps (gethash next vec-table))) + (dolist (sp sps) + (%primitive write-control-stack sp offset)) + (push (list* base offset sps) fixups)))))) + + ;; + ;; Iterate over all code pointers (step 3.) + (maphash #'(lambda (code-ptr sps) + (dolist (fun functions + (dolist (sp sps) + (%primitive write-control-stack sp 0))) + (let* ((base (%primitive header-ref fun + %function-code-slot)) + (end (vector-alloc-end base))) + (when (and (not (%primitive pointer< code-ptr base)) + (%primitive pointer< code-ptr end)) + (let ((offset (%primitive pointer- code-ptr base))) + (dolist (sp sps) + (%primitive write-control-stack sp offset)) + (push (list* base offset sps) fixups)) + (return))))) + code-table) + + (when *gc-debug* + (dolist (f fixups) + (terpri) + (print-raw-addr (first f)) + (format t "~X " (second f)) + (dolist (sp (cddr f)) + (print-raw-addr sp))) + (terpri)) + + fixups))) + + +;;; GC-FIXUP-STACK -- Internal +;;; +;;; Given a list of GC fixups as returned by GC-GROVEL-STACK, fix up all the +;;; raw pointers on the stack. +;;; +(defun gc-fixup-stack (fixups) + (dolist (fixup fixups) + (let ((new (%primitive pointer+ (first fixup) (second fixup)))) + (dolist (sp (cddr fixup)) + (%primitive write-control-stack sp new))))) + + +;;;; Internal GC + +;;; %GC -- Internal +;;; +;;; %GC is the real garbage collector. What we do: +;;; -- Call GC-GROVEL-STACK to locate any raw pointers on the stack. +;;; -- Invoke the COLLECT-GARBAGE miscop, adding the amount of garbage +;;; collected to *total-bytes-consed*. +;;; -- Invalidate & revalidate the old spaces to free up their memory. +;;; -- Call GC-FIXUP-STACK to restore raw pointers on the stack. +;;; +;;; *** Warning: the stack *including the current frame* is in a somewhat +;;; altered state until after GC-FIXUP-STACK is called. Don't change a single +;;; character from the start of this function until after call to +;;; GC-FIXUP-STACK unless you really know what you are doing. +;;; +;;; It is important that we not do anything that creates raw pointers between +;;; the time we call GC-GROVEL-STACK and the time we invoke COLLECT-GARBAGE. +;;; In particular, this means no function calls. All raw pointers on the stack +;;; have been trashed, so we cannot use any raw pointers until they have been +;;; regenerated. In particular, we cannot return from this function, since the +;;; return PC is a raw pointer. +;;; +;;; We also can't expect the value of any variables allocated between the +;;; grovel and fixup to persist after the fixup, since the value that variable +;;; held at grovel time may have been a pointer that needed to be fixed. +;;; +(defun %gc () + (let* ((oldspace-base (ash (%primitive newspace-bit) 25)) + (old-bytes (system:%primitive dynamic-space-in-use)) + (result nil) + (fixups (gc-grovel-stack))) + (%primitive clear-registers) + (setq result (%primitive collect-garbage)) + (let ((new-bytes (system:%primitive dynamic-space-in-use))) + (when *last-bytes-in-use* + (incf *total-bytes-consed* (- old-bytes *last-bytes-in-use*)) + (setq *last-bytes-in-use* new-bytes))) + (gc-fixup-stack fixups) + (do* ((i %first-pointer-type (1+ i)) + (this-space (logior oldspace-base (ash i 27)) + (logior oldspace-base (ash i 27))) + (losing-gr nil)) + ((= i (1+ %last-pointer-type)) + (when losing-gr + (system:gr-error "While reclaiming VM" losing-gr))) + (let ((gr (mach:vm_deallocate *task-self* this-space + (- #x2000000 8192)))) + (unless (eql gr mach:kern-success) (setq losing-gr gr))) + (let ((gr (mach:vm_allocate *task-self* this-space + (- #x2000000 8192) nil))) + (unless (eql gr mach:kern-success) (setq losing-gr gr)))) + result)) + +;;; +;;; *INTERNAL-GC* +;;; +;;; This variables contains the function that does the real GC. This is +;;; for low-level GC experimentation. Do not touch it if you do not +;;; know what you are doing. +;;; +(defvar *internal-gc* #'%gc) + + +;;;; SUB-GC + +;;; +;;; CAREFULLY-FUNCALL -- Internal +;;; +;;; Used to carefully invoke hooks. +;;; +(defmacro carefully-funcall (function &rest args) + `(handler-case (funcall ,function ,@args) + (error (cond) + (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond) + nil))) + +;;; +;;; SUB-GC -- Internal +;;; +;;; SUB-GC decides when and if to do a garbage collection. The +;;; VERBOSE-P flag controls whether or not the notify functions are +;;; called. The FORCE-P flags controls if a GC should occur even if the +;;; dynamic usage is not greater than *GC-TRIGGER*. +;;; +(defun sub-gc (verbose-p force-p) + (unless *already-maybe-gcing* + (let* ((*already-maybe-gcing* t) + (pre-gc-dyn-usage (dynamic-usage))) + (unless (integerp *bytes-consed-between-gcs*) + (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~ + integer. Reseting it to 2000000" *bytes-consed-between-gcs*) + (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs)) + (when (> *bytes-consed-between-gcs* *gc-trigger*) + (setf *gc-trigger* *bytes-consed-between-gcs*)) + (when (> pre-gc-dyn-usage *gc-trigger*) + (setf *need-to-collect-garbage* t)) + (when (or force-p + (and *need-to-collect-garbage* (not *gc-inhibit*))) + (setf *gc-inhibit* t) ; Set *GC-INHIBIT* to T before calling the hook + (when (and (not force-p) + *gc-inhibit-hook* + (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage)) + (return-from sub-gc nil)) + (setf *gc-inhibit* nil) ; Reset *GC-INHIBIT* + (multiple-value-bind + (winp old-mask) + (mach:unix-sigsetmask lockout-interrupts) + (unwind-protect + (progn + (unless winp (warn "Could not set sigmask!")) + (let ((*standard-output* *terminal-io*)) + (when verbose-p + (carefully-funcall *gc-notify-before* pre-gc-dyn-usage)) + (dolist (hook *before-gc-hooks*) + (carefully-funcall hook)) + (funcall *internal-gc*) + (let* ((post-gc-dyn-usage (dynamic-usage)) + (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage))) + (setf *need-to-collect-garbage* nil) + (setf *gc-trigger* + (+ post-gc-dyn-usage *bytes-consed-between-gcs*)) + (dolist (hook *after-gc-hooks*) + (carefully-funcall hook)) + (when verbose-p + (carefully-funcall *gc-notify-after* + post-gc-dyn-usage bytes-freed + *gc-trigger*))))) + (when winp + (unless (values (mach:unix-sigsetmask old-mask)) + (warn "Could not restore sigmask!")))))))) + nil) + +;;; +;;; MAYBE-GC -- Internal +;;; +;;; This routine is called by the allocation miscops to decide if a GC +;;; should occur. The argument, object, is the newly allocated object +;;; which must be returned to the caller. +;;; +(defun maybe-gc (object) + (sub-gc t nil) + object) + +;;; +;;; GC -- Exported +;;; +;;; This is the user advertised garbage collection function. +;;; +(defun gc (&optional (verbose-p t)) + "Initiates a garbage collection. The optional argument, VERBOSE-P, + controls wether or not GC statistics are printed." + (sub-gc verbose-p t) + nil) + + +;;;; Auxiliary Functions + +(defun gc-on () + "Enables the garbage collector." + (setq *gc-inhibit* nil) + (when *need-to-collect-garbage* + (sub-gc t nil)) + nil) + +(defun gc-off () + "Disables the garbage collector." + (setq *gc-inhibit* t) + nil) diff --git a/code/globals.lisp b/code/globals.lisp new file mode 100644 index 000000000..696759b87 --- /dev/null +++ b/code/globals.lisp @@ -0,0 +1,56 @@ +;;; -*- Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains special proclamations for variables that are +;;; referenced in the code sources before they are defined. There is also a +;;; function proclamation to make some common functions be known, avoiding +;;; large amounts of work in recording the calls that are done before the +;;; definition. +;;; +;;; Written by Rob MacLachlan +;;; +(in-package 'lisp) + +(proclaim '(special *keyword-package* *lisp-package* *package* *query-io* + *terminal-io* *error-output* *trace-output* *debug-io* + *standard-input* *standard-output* *file-input-handlers* + *hemlock-version* *evalhook* *applyhook* + *task-self* *command-line-switches* + *command-switch-demons* ext::temporary-foreign-files + *display-event-handlers* original-lisp-environment + *environment-list* + *read-default-float-format* *read-suppress* *readtable* + *print-base* *print-radix* *print-length* *print-level* + *print-pretty* *print-escape* *print-case* *print-circle* + *print-gensym* *print-array* + defmacro-error-string defsetf-error-string + std-lisp-readtable + hi::*in-the-editor* debug::*in-the-debugger* + mach::*free-trap-arg-blocks* conditions::*handler-clusters* + conditions::*restart-clusters* + alloctable-address ext::*c-type-names* *gc-inhibit* + *need-to-collect-garbage* + defmacro-error-string deftype-error-string + defsetf-error-string %sp-interrupts-inhibited + *software-interrupt-vector* *load-verbose* + *load-print-stuff* *in-compilation-unit* + *aborted-compilation-units* + + ;; hack to get these args to with-trap-arg-block to work in + ;; the bootstrapping env, since the var must be known to be + ;; special, in addition to being known to be an alien var. + mach::timeval mach::timezone mach::int1 mach::int2 + mach::int3 mach::tchars mach::ltchars)) + + +(proclaim '(ftype (function (&rest t) *) + c::%%defun c::%%defmacro c::%%defconstant c::%defstruct + c::%%compiler-defstruct c::get-info-value c::set-info-value + find-keyword keyword-test assert-error assert-prompt + check-type-error case-body-error)) diff --git a/code/hash.lisp b/code/hash.lisp new file mode 100644 index 000000000..7ecea07d1 --- /dev/null +++ b/code/hash.lisp @@ -0,0 +1,429 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Hashing and hash table functions for Spice Lisp. +;;; Written by Skef Wholey. +;;; +(in-package 'lisp) +(export '(hash-table hash-table-p make-hash-table + gethash remhash maphash clrhash + hash-table-count sxhash)) + +;;; What a hash-table is: + +(defstruct (hash-table (:constructor make-hash-table-structure) + (:conc-name hash-table-) + (:print-function %print-hash-table)) + "Structure used to implement hash tables." + (kind 'eq) + (size 65 :type fixnum) + (rehash-size 101) ; might be a float + (rehash-threshold 57 :type fixnum) + (number-entries 0 :type fixnum) + (table () :type simple-vector)) + +;;; A hash-table-table is a vector of association lists. When an +;;; entry is made in a hash table, a pair of (key . value) is consed onto +;;; the element in the vector arrived at by hashing. + +;;; How to print one: + +(defun %print-hash-table (structure stream depth) + (declare (ignore depth)) + (format stream "#<~A Hash Table {~X}>" + (symbol-name (hash-table-kind structure)) + (system:%primitive lisp::make-fixnum structure))) + + + +;;; Hashing functions for the three kinds of hash tables: + +(eval-when (compile) + +(defmacro eq-hash (object) + "Gives us a hashing of an object such that (eq a b) implies + (= (eq-hash a) (eq-hash b))" + `(%primitive make-fixnum ,object)) + +(defmacro eql-hash (object) + "Gives us a hashing of an object such that (eql a b) implies + (= (eql-hash a) (eql-hash b))" + `(if (numberp ,object) + (logand (truncate ,object) most-positive-fixnum) + (%primitive make-fixnum ,object))) + +(defmacro equal-hash (object) + "Gives us a hashing of an object such that (equal a b) implies + (= (equal-hash a) (equal-hash b))" + `(sxhash ,object)) + +) + +;;; Rehashing functions: + +(defun almost-primify (num) + (declare (fixnum num)) + "Almost-Primify returns an almost prime number greater than or equal + to NUM." + (if (= (rem num 2) 0) + (setq num (+ 1 num))) + (if (= (rem num 3) 0) + (setq num (+ 2 num))) + (if (= (rem num 7) 0) + (setq num (+ 4 num))) + num) + +(eval-when (compile) + +(defmacro grow-size (table) + "Returns a fixnum for the next size of a growing hash-table." + `(let ((rehash-size (hash-table-rehash-size ,table))) + (if (floatp rehash-size) + (ceiling (* rehash-size (hash-table-size ,table))) + (+ rehash-size (hash-table-size ,table))))) + +(defmacro grow-rehash-threshold (table new-length) + "Returns the next rehash threshold for the table." + table + `,new-length +; `(ceiling (* (hash-table-rehash-threshold ,table) +; (/ ,new-length (hash-table-size ,table)))) + ) + +(defmacro hash-set (vector key value length hashing-function) + "Used for rehashing. Enters the value for the key into the vector + by hashing. Never grows the vector. Assumes the key is not yet + entered." + `(let ((index (rem (the fixnum (funcall ,hashing-function ,key)) + (the fixnum ,length)))) + (declare (fixnum index)) + (setf (aref (the simple-vector ,vector) index) + (cons (cons ,key ,value) + (aref (the simple-vector ,vector) index))))) + +) + +(defun rehash (structure hash-vector new-length) + (declare (simple-vector hash-vector)) + (declare (fixnum new-length)) + "Rehashes a hash table and replaces the TABLE entry in the structure if + someone hasn't done so already. New vector is of NEW-LENGTH." + (do ((new-vector (make-array new-length)) + (i 0 (1+ i)) + (size (hash-table-size structure)) + (hashing-function (case (hash-table-kind structure) + (eq #'(lambda (x) (eq-hash x))) + (eql #'(lambda (x) (eql-hash x))) + (equal #'(lambda (x) (equal-hash x)))))) + ((= i size) + (cond ((eq hash-vector (hash-table-table structure)) + (cond ((> new-length size) + (setf (hash-table-table structure) new-vector) + (setf (hash-table-rehash-threshold structure) + (grow-rehash-threshold structure new-length)) + (setf (hash-table-size structure) new-length)) + (t + (setf (hash-table-table structure) new-vector))) + (if (not (eq (hash-table-kind structure) 'equal)) + (%primitive set-vector-subtype new-vector + (+ 2 (%primitive newspace-bit))))))) + (declare (fixnum i size)) + (do ((bucket (aref hash-vector i) (cdr bucket))) + ((null bucket)) + (hash-set new-vector (caar bucket) (cdar bucket) new-length + hashing-function)) + (setf (aref hash-vector i) nil))) + +;;; Macros for Gethash, %Puthash, and Remhash: + +(eval-when (compile) + +;;; Hashop dispatches on the kind of hash table we've got, rehashes if +;;; necessary, and binds Vector to the hash vector, Index to the index +;;; into that vector that the Key points to, and Size to the size of the +;;; hash vector. Since Equal hash tables only need to be maybe rehashed +;;; sometimes, one can tell it if it's one of those times with the +;;; Equal-Needs-To-Rehash-P argument. + +(defmacro hashop (equal-needs-to-rehash-p eq-body eql-body equal-body) + `(let* ((vector (hash-table-table hash-table)) + (size (length vector))) + (declare (simple-vector vector) (fixnum size) + (inline assoc)) + (case (hash-table-kind hash-table) + (equal + ,@(if equal-needs-to-rehash-p `((equal-rehash-if-needed))) + (let ((index (rem (the fixnum (equal-hash key)) size))) + (declare (fixnum index)) + ,equal-body)) + (eq + (without-gcing + (eq-rehash-if-needed) + (let ((index (rem (the fixnum (eq-hash key)) size))) + (declare (fixnum index)) + ,eq-body))) + (eql + (without-gcing + (eq-rehash-if-needed) + (let ((index (rem (the fixnum (eql-hash key)) size))) + (declare (fixnum index)) + ,eql-body)))))) + +(defmacro eq-rehash-if-needed () + `(let ((subtype (%primitive get-vector-subtype vector))) + (declare (fixnum subtype)) + (cond ((or (= subtype 4) + (/= subtype (+ 2 (%primitive newspace-bit)))) + (rehash hash-table vector size) + (setq vector (hash-table-table hash-table))) + ((> (hash-table-number-entries hash-table) + (hash-table-rehash-threshold hash-table)) + (rehash hash-table vector (grow-size hash-table)) + (setq vector (hash-table-table hash-table)) + (setq size (length vector)))))) + +(defmacro equal-rehash-if-needed () + `(cond ((> (hash-table-number-entries hash-table) + (hash-table-rehash-threshold hash-table)) + (rehash hash-table vector (grow-size hash-table)) + (setq vector (hash-table-table hash-table)) + (setq size (length vector))))) + +(defmacro rehash-if-needed () + `(let ((subtype (%primitive get-vector-subtype vector)) + (size (length vector))) + (declare (fixnum subtype size)) + (cond ((and (not (eq (hash-table-kind hash-table) 'equal)) + (or (= subtype 4) + (/= subtype (the fixnum (+ 2 (the fixnum (%primitive newspace-bit))))))) + (rehash hash-table vector size) + (setq vector (hash-table-table hash-table)) + (setq size (length vector))) + ((> (hash-table-number-entries hash-table) + (hash-table-rehash-threshold hash-table)) + (rehash hash-table vector (grow-size hash-table)) + (setq vector (hash-table-table hash-table)) + (setq size (length vector)))))) + +) + +;;; Making hash tables: + +(defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101) + rehash-threshold) + "Creates and returns a hash table. See manual for details." + (declare (fixnum size)) + (cond ((eq test #'eq) (setq test 'eq)) + ((eq test #'eql) (setq test 'eql)) + ((eq test #'equal) (setq test 'equal))) + (if (not (memq test '(eq eql equal))) + (error "~S is an illegal :Test for hash tables." test)) + (setq size (if (<= size 37) 37 (almost-primify size))) + (cond ((null rehash-threshold) + (setq rehash-threshold size)) + ((floatp rehash-threshold) + (setq rehash-threshold (ceiling (* rehash-threshold size))))) + (make-hash-table-structure :size size + :rehash-size rehash-size + :rehash-threshold rehash-threshold + :table + (if (eq test 'equal) + (make-array size) + (%primitive set-vector-subtype + (make-array size) + (the fixnum (+ 2 (the fixnum (%primitive newspace-bit)))))) + :kind test))) + +;;; Manipulating hash tables: + +(defun gethash (key hash-table &optional default) + "Finds the entry in Hash-Table whose key is Key and returns the associated + value and T as multiple values, or returns Default and Nil if there is no + such entry." + (macrolet ((lookup (test) + `(let ((cons (assoc key (aref vector index) :test #',test))) + (declare (list cons)) + (if cons + (values (cdr cons) t) + (values default nil))))) + (hashop nil + (lookup eq) + (lookup eql) + (lookup equal)))) + +(defun %puthash (key hash-table value) + "Create an entry in HASH-TABLE associating KEY with VALUE; if there already + is an entry for KEY, replace it. Returns VALUE." + (macrolet ((store (test) + `(let ((cons (assoc key (aref vector index) :test #',test))) + (declare (list cons)) + (cond (cons (setf (cdr cons) value)) + (t + (push (cons key value) (aref vector index)) + (incf (hash-table-number-entries hash-table)) + value))))) + (hashop t + (store eq) + (store eql) + (store equal)))) + +(defun remhash (key hash-table) + "Remove any entry for KEY in HASH-TABLE. Returns T if such an entry + existed; () otherwise." + (hashop nil + (let ((bucket (aref vector index))) ; EQ case + (cond ((and bucket (eq (caar bucket) key)) + (pop (aref vector index)) + (decf (hash-table-number-entries hash-table)) + t) + (t + (do ((last bucket bucket) + (bucket (cdr bucket) (cdr bucket))) + ((null bucket) ()) + (when (eq (caar bucket) key) + (rplacd last (cdr bucket)) + (decf (hash-table-number-entries hash-table)) + (return t)))))) + (let ((bucket (aref vector index))) ; EQL case + (cond ((and bucket (eql (caar bucket) key)) + (pop (aref vector index)) + (decf (hash-table-number-entries hash-table)) + t) + (t + (do ((last bucket bucket) + (bucket (cdr bucket) (cdr bucket))) + ((null bucket) ()) + (when (eql (caar bucket) key) + (rplacd last (cdr bucket)) + (decf (hash-table-number-entries hash-table)) + (return t)))))) + (let ((bucket (aref vector index))) ; EQUAL case + (cond ((and bucket (equal (caar bucket) key)) + (pop (aref vector index)) + (decf (hash-table-number-entries hash-table)) + t) + (t + (do ((last bucket bucket) + (bucket (cdr bucket) (cdr bucket))) + ((null bucket) ()) + (when (equal (caar bucket) key) + (rplacd last (cdr bucket)) + (decf (hash-table-number-entries hash-table)) + (return t)))))))) + +(defun maphash (map-function hash-table) + "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value + of the entry; returns T." + (let ((vector (hash-table-table hash-table))) + (declare (simple-vector vector)) + (rehash-if-needed) + (do ((i 0 (1+ i)) + (size (hash-table-size hash-table))) + ((= i size)) + (declare (fixnum i size)) + (do ((bucket (aref vector i) (cdr bucket))) + ((null bucket)) + + (funcall map-function (caar bucket) (cdar bucket)))))) + +(defun clrhash (hash-table) + "Removes all entries of HASH-TABLE and returns the hash table itself." + (let ((vector (hash-table-table hash-table))) + (declare (simple-vector vector)) + (setf (hash-table-number-entries hash-table) 0) + (do ((i 0 (1+ i)) + (size (hash-table-size hash-table))) + ((= i size) hash-table) + (declare (fixnum i size)) + (setf (aref vector i) nil)))) + +(defun hash-table-count (hash-table) + "Returns the number of entries in the given Hash-Table." + (hash-table-number-entries hash-table)) + +;;; Primitive Hash Function + +;;; The maximum length and depth to which we hash lists. +(defconstant sxhash-max-len 7) +(defconstant sxhash-max-depth 3) + +(eval-when (compile eval) + +;;; We could use a rotate function here, but that isn't in ucode, so +;;; instead we Xor the number with a lsh'ed version of itself... +;;; +(defmacro sxmash (x num) + (let ((n-x (gensym))) + `(let ((,n-x ,x)) + (declare (fixnum ,n-x)) + (abs (logxor (the fixnum (%primitive lsh ,n-x ,num)) ,n-x))))) + +(defmacro sxhash-simple-string (sequence) + `(%primitive sxhash-simple-string ,sequence)) + +(defmacro sxhash-string (sequence) + (let ((data (gensym)) + (start (gensym)) + (end (gensym))) + `(with-array-data ((,data ,sequence) + (,start) + (,end (%primitive header-ref ,sequence + %array-fill-pointer-slot))) + (if (zerop ,start) + (%primitive sxhash-simple-substring ,data ,end) + (sxhash-simple-string (coerce (the string ,sequence) + 'simple-string)))))) + +(defmacro sxhash-list (sequence depth) + `(if (= ,depth sxhash-max-depth) + 0 + (do ((sequence ,sequence (cdr (the list sequence))) + (index 0 (1+ index)) + (hash 2)) + ((or (atom sequence) (= index sxhash-max-len)) hash) + (declare (fixnum hash index)) + (setq hash + (sxmash + (logxor + hash + (internal-sxhash (car sequence) (1+ ,depth))) + 7))))) + +); eval-when (compile eval) + + +;;; This multi-level type dispatch is faster, since typecase doesn't +;;; turn into a real dispatch. +;;; +(defun sxhash (s-expr) + "Computes a hash code for S-EXPR and returns it as an integer." + (internal-sxhash s-expr 0)) + +(defun internal-sxhash (s-expr depth) + (typecase s-expr + (array + (typecase s-expr + (simple-string (sxhash-simple-string s-expr)) + (string (sxhash-string s-expr)) + (t (array-rank s-expr)))) + (symbol (sxhash-simple-string (symbol-name s-expr))) + (list (sxhash-list s-expr depth)) + (number + (etypecase s-expr + (integer (ldb (byte 23 0) s-expr)) + (float (multiple-value-bind (significand exponent) + (integer-decode-float s-expr) + (logxor (the fixnum (ldb (byte 23 0) significand)) + (the fixnum (ldb (byte 23 0) exponent))))) + (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0) + (internal-sxhash (denominator s-expr) 0)))) + (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0) + (internal-sxhash (imagpart s-expr) 0)))))) + (compiled-function (%primitive header-length s-expr)) + (t (%primitive make-fixnum s-expr)))) diff --git a/code/lispinit.lisp b/code/lispinit.lisp new file mode 100644 index 000000000..a531eb996 --- /dev/null +++ b/code/lispinit.lisp @@ -0,0 +1,1212 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Initialization and low-level interrupt support for the Spice Lisp system. +;;; Written by Skef Wholey and Rob MacLachlan. +;;; +(in-package "LISP" :use '("SYSTEM" "DEBUG")) + +(in-package "XLIB") + +(in-package "LISP") + +(export '(most-positive-fixnum most-negative-fixnum sleep + ++ +++ ** *** // ///)) + + +(in-package "SYSTEM") +(export '(add-port-death-handler remove-port-death-handler sap-int + int-sap sap-ref-8 sap-ref-16 sap-ref-32 without-gcing + *in-the-compiler* compiler-version *pornography-of-death* + *port-receive-rights-handlers* *port-ownership-rights-handlers* + without-interrupts with-reply-port map-port add-port-object + remove-port-object make-object-set object-set-operation + server-message *xwindow-table* map-xwindow add-xwindow-object + remove-xwindow-object server-event coerce-to-key-event + coerce-to-motion-event coerce-to-expose-event + coerece-to-exposecopy-event coerce-to-focuschange-event server + *nameserverport* *usertypescript* *userwindow* *typescriptport* + *task-self* *task-data* *task-notify* *file-input-handlers* + with-interrupts with-enabled-interrupts enable-interrupt + ignore-interrupt default-interrupt serve-all)) + +(in-package "EXTENSIONS") +(export '(quit *prompt* print-herald save-lisp gc-on gc-off + *before-save-initializations* *after-save-initializations* + *editor-lisp-p* *clx-server-displays* *display-event-handlers*)) + +(in-package "LISP") + +;;; These go here so that we can refer to them in top-level forms. + +(defvar *before-save-initializations* () + "This is a list of functions which are called before creating a saved core + image. These functions are executed in the child process which has no ports, + so they cannot do anything that tries to talk to the outside world.") + +(defvar *after-save-initializations* () + "This is a list of functions which are called when a saved core image starts + up. The system itself should be initialized at this point, but applications + might not be.") + +;;; Make the error system enable interrupts. + +(defconstant most-positive-fixnum 134217727 + "The fixnum closest in value to positive infinity.") + +(defconstant most-negative-fixnum -134217728 + "The fixnum closest in value to negative infinity.") + + +(defvar *prompt* "* " "The string with which Lisp prompts you.") + + +;;; Random information: + +(defvar compiler-version "???") +(defvar *lisp-implementation-version* "2.7(?)") + +(defvar *in-the-compiler* () + "Bound to T while running code inside the compiler. Macros may test this to + see where they are being expanded.") + +(defparameter %fasl-code-format 6) + + +;;;; Global ports: + +(defvar *task-self* 1 + "Port that refers to the current task.") + +(defvar *task-data* 2 + "Port used to receive data for the current task.") + +(defvar *nameserverport* () + "Port to the name server.") + + +;;; GC stuff. + +(defvar *gc-inhibit* nil) ; Inhibits GC's. + +(defvar *already-maybe-gcing* nil) ; Inhibits recursive GC's. + +(defvar *need-to-collect-garbage* nil + "*Need-to-collect-garbage* is set to T when GC is disabled, but the system + needs to do a GC. When GC is enabled again, the GC is done then.") + + +;;; Software interrupt stuff. + +(defvar *in-server* NIL + "*In-server* is set to T when the SIGMSG interrupt has been enabled + in Server.") + +(defvar server-unique-object (cons 1 2)) + +(defconstant lockout-interrupts (logior (mach:sigmask mach:sigint) + (mach:sigmask mach:sigquit) + (mach:sigmask mach:sigfpe) + (mach:sigmask mach:sigsys) + (mach:sigmask mach:sigpipe) + (mach:sigmask mach:sigalrm) + (mach:sigmask mach:sigurg) + (mach:sigmask mach:sigstop) + (mach:sigmask mach:sigtstp) + (mach:sigmask mach:sigcont) + (mach:sigmask mach:sigchld) + (mach:sigmask mach:sigttin) + (mach:sigmask mach:sigttou) + (mach:sigmask mach:sigio) + (mach:sigmask mach:sigxcpu) + (mach:sigmask mach:sigxfsz) + (mach:sigmask mach:sigvtalrm) + (mach:sigmask mach:sigprof) + (mach:sigmask mach:sigwinch) + (mach:sigmask mach:sigmsg) + (mach:sigmask mach:sigemsg))) + +(defconstant interrupt-stack-size 4096 + "Size of stack for Unix interrupts.") + +(defvar software-interrupt-stack NIL + "Address of the stack used by Mach to send signals to Lisp.") + +(defvar %sp-interrupts-inhibited nil + "True if emergency message interrupts should be inhibited, false otherwise.") + +(defvar *software-interrupt-vector* + (make-array mach::maximum-interrupts) + "A vector that associates Lisp functions with Unix interrupts.") + +(defun enable-interrupt (interrupt function &optional character) + "Enable one Unix interrupt and associate a Lisp function with it. + Interrupt should be the number of the interrupt to enable. Function + should be a funcallable object that will be called with three + arguments: the signal code, a subcode, and the context of the + interrupt. The optional character should be an ascii character or + an integer that causes the interrupt from the keyboard. This argument + is only used for SIGINT, SIGQUIT, and SIGTSTP interrupts and is ignored + for any others. Returns the old function associated with the interrupt + and the character that generates it if the interrupt is one of SIGINT, + SIGQUIT, SIGTSTP and character was specified." + (unless (< 0 interrupt mach::maximum-interrupts) + (error "Interrupt number ~D is not between 1 and ~D." + mach::maximum-interrupts)) + (let ((old-fun (svref *software-interrupt-vector* interrupt)) + (old-char ())) + (when (and character + (or (eq interrupt mach:sigint) + (eq interrupt mach:sigquit) + (eq interrupt mach:sigtstp))) + (when (characterp character) + (setq character (char-code character))) + (when (mach:unix-isatty 0) + (if (or (eq interrupt mach:sigint) + (eq interrupt mach:sigquit)) + (mach:with-trap-arg-block mach:tchars tc + (multiple-value-bind + (val err) + (mach:unix-ioctl 0 mach:TIOCGETC + (alien-value-sap mach:tchars)) + (if (null val) + (error "Failed to get tchars information, unix error ~S." + (mach:get-unix-error-msg err)))) + (cond ((eq interrupt mach:sigint) + (setq old-char + (alien-access (mach::tchars-intrc (alien-value tc)))) + (setf (alien-access (mach::tchars-intrc (alien-value tc))) + character)) + (T + (setq old-char + (alien-access (mach::tchars-quitc (alien-value tc)))) + (setf (alien-access (mach::tchars-quitc (alien-value tc))) + character))) + (multiple-value-bind + (val err) + (mach:unix-ioctl 0 mach:tiocsetc + (alien-value-sap mach:tchars)) + (if (null val) + (error "Failed to set tchars information, unix error ~S." + (mach:get-unix-error-msg err))))) + (mach:with-trap-arg-block mach:ltchars tc + (multiple-value-bind + (val err) + (mach:unix-ioctl 0 mach:TIOCGLTC + (alien-value-sap mach:ltchars)) + (if (null val) + (error "Failed to get ltchars information, unix error ~S." + (mach:get-unix-error-msg err)))) + (setq old-char + (alien-access (mach::ltchars-suspc (alien-value tc)))) + (setf (alien-access (mach::ltchars-suspc (alien-value tc))) + character) + (multiple-value-bind + (val err) + (mach:unix-ioctl 0 mach:TIOCSLTC + (alien-value-sap mach:ltchars)) + (if (null val) + (error "Failed to set ltchars information, unix error ~S." + (mach:get-unix-error-msg err)))))))) + (setf (svref *software-interrupt-vector* interrupt) function) + (if (null function) + (mach:unix-sigvec interrupt mach:sig_dfl 0 0) + (let ((diha (+ (ash clc::romp-data-base 16) + clc::software-interrupt-offset))) + (mach:unix-sigvec interrupt diha lockout-interrupts 1))) + (if old-char + (values old-fun old-char) + old-fun))) + +(defun ignore-interrupt (interrupt) + "The Unix interrupt handling mechanism is set up so that interrupt is + ignored." + (unless (< 0 interrupt mach::maximum-interrupts) + (error "Interrupt number ~D is not between 1 and 31.")) + (let ((old-fun (svref *software-interrupt-vector* interrupt))) + (mach:unix-sigvec interrupt mach:sig_ign 0 0) + (setf (svref *software-interrupt-vector* interrupt) NIL) + old-fun)) + +(defun default-interrupt (interrupt) + "The Unix interrupt handling mechanism is set up to do the default action + under mach. Lisp will not get control of the interrupt." + (unless (< 0 interrupt mach::maximum-interrupts) + (error "Interrupt number ~D is not between 1 and 31.")) + (let ((old-fun (svref *software-interrupt-vector* interrupt))) + (mach:unix-sigvec interrupt mach:sig_dfl 0 0) + (setf (svref *software-interrupt-vector* interrupt) NIL) + old-fun)) + + +;;; %SP-Software-Interrupt-Handler is called by the miscops when a Unix +;;; signal arrives. The three arguments correspond to the information +;;; passed to a normal Unix signal handler, i.e.: +;;; signal -- the Unix signal number. +;;; code -- a code for those signals which can be caused by more +;;; than one kind of event. This code specifies the sub-event. +;;; scp -- a pointer to the context of the signal. + +;;; Because of the way %sp-software-interrupt-handler returns, it doesn't +;;; unwind the binding stack properly. The only variable affected by this +;;; is software-interrupt-stack, so it must be handled specially. + +(defun %sp-software-interrupt-handler (signal code scp stack) + (declare (optimize (speed 3) (safety 0))) + (if (and %sp-interrupts-inhibited + (not (memq signal '(#.mach:sigill #.mach:sigbus #.mach:sigsegv)))) + (progn + (let ((iin %sp-interrupts-inhibited)) + (setq %sp-interrupts-inhibited + (nconc (if (consp iin) iin) + (list `(,signal ,code ,scp)))) + (mach:unix-sigsetmask 0))) + (let* ((old-stack software-interrupt-stack) + (new-stack ()) + (%sp-interrupts-inhibited T)) + (unwind-protect + (progn + (when *in-server* + (mach:unix-sigvec mach:sigmsg mach::sig_dfl 0 0)) + (multiple-value-bind (gr addr) + (mach:vm_allocate *task-self* 0 + interrupt-stack-size t) + (gr-error 'mach:vm_allocate gr '%sp-software-interrupt-handler) + (setq software-interrupt-stack + (int-sap (+ addr interrupt-stack-size)))) + (setq new-stack software-interrupt-stack) + (mach:unix-sigstack new-stack 0) + (mach:unix-sigsetmask 0) + (funcall (svref *software-interrupt-vector* signal) + signal code scp) + (mach:unix-sigsetmask lockout-interrupts)) + (mach:vm_deallocate *task-self* + (- (sap-int new-stack) + interrupt-stack-size) + interrupt-stack-size) + (setq software-interrupt-stack old-stack) + (mach:unix-sigstack old-stack 0) + (when *in-server* + (let ((diha (+ (ash clc::romp-data-base 16) + clc::software-interrupt-offset))) + (mach:unix-sigvec mach:sigmsg diha lockout-interrupts 1))) + (mach:unix-sigsetmask 0)))) + (%primitive break-return stack)) + + +(defun ih-sigint (signal code scp) + (declare (ignore signal code scp)) + (without-hemlock + (with-interrupts + (break "Software Interrupt" t)))) + +(defun ih-sigquit (signal code scp) + (declare (ignore signal code scp)) + (throw 'top-level-catcher nil)) + +(defun ih-sigtstp (signal code scp) + (declare (ignore signal code scp)) + (without-hemlock +; (reset-keyboard 0) + (mach:unix-kill (mach:unix-getpid) mach:sigstop))) + +(defun ih-sigill (signal code scp) + (declare (ignore signal code)) + (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext) + 'mach:sigcontext) + mach:sigcontext T)) + (error "Illegal instruction encountered at IAR ~X." + (alien-access (mach::sigcontext-iar (alien-value context)))))) + +(defun ih-sigbus (signal code scp) + (declare (ignore signal code)) + (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext) + 'mach:sigcontext) + mach:sigcontext T)) + (with-interrupts + (error "Bus error encountered at IAR ~X." + (alien-access (mach::sigcontext-iar (alien-value context))))))) + +(defun ih-sigsegv (signal code scp) + (declare (ignore signal code)) + (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext) + 'mach:sigcontext) + mach:sigcontext T)) + (with-interrupts + (error "Segment violation encountered at IAR ~X." + (alien-access (mach::sigcontext-iar (alien-value context))))))) + +(defun ih-sigfpe (signal code scp) + (declare (ignore signal code)) + (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext) + 'mach:sigcontext) + mach:sigcontext T)) + (with-interrupts + (error "Floating point exception encountered at IAR ~X." + (alien-access (mach::sigcontext-iar (alien-value context))))))) + +;;; When we're in server then throw back to server. If we're not +;;; in server then just ignore the sigmsg interrupt. We can't handle +;;; it and we should never get it anyway. But of course we do -- it's +;;; dealing with interrupts and there funny at best. +(defun ih-sigmsg (signal code scp) + (declare (ignore signal code scp)) + (mach:unix-sigsetmask (mach:sigmask mach:sigmsg)) + (default-interrupt mach:sigmsg) + (when *in-server* + (setq *in-server* nil) + (throw 'server-catch server-unique-object))) + +(defun ih-sigemsg (signal code scp) + (declare (ignore signal code scp)) + (service-emergency-message-interrupt)) + +(defun init-mach-signals () + (declare (optimize (speed 3) (safety 0))) + (multiple-value-bind (gr addr) + (mach:vm_allocate *task-self* 0 interrupt-stack-size t) + (gr-error 'mach:vm_allocate gr 'enable-interrupt) + (setq software-interrupt-stack + (int-sap (+ addr interrupt-stack-size)))) + (let ((iha (get 'clc::interrupt-handler '%loaded-address)) + (diha (+ (ash clc::romp-data-base 16) clc::software-interrupt-offset))) + (%primitive pointer-system-set diha 0 iha)) + (mach:unix-sigstack software-interrupt-stack 0) + (enable-interrupt mach:sigint #'ih-sigint) + (enable-interrupt mach:sigquit #'ih-sigquit) + (enable-interrupt mach:sigtstp #'ih-sigtstp) + (enable-interrupt mach:sigill #'ih-sigill) + (enable-interrupt mach:sigbus #'ih-sigbus) + (enable-interrupt mach:sigsegv #'ih-sigsegv) + (enable-interrupt mach:sigemsg #'ih-sigemsg) + (enable-interrupt mach:sigfpe #'ih-sigfpe) +; (reset-keyboard 0) + ) + + +;;;; Reply port allocation. +;;; +;;; We maintain a global stack of reply ports which is shared among +;;; all matchmaker interfaces, and could be used by other people as well. +;;; +;;; The stack is represented by a vector, and a pointer to the first +;;; free port. The stack grows upward. There is always at least one +;;; NIL entry in the stack after the last allocated port. +;;; +(defvar *reply-port-stack* (make-array 16)) ; Vector of reply ports. +(defvar *reply-port-pointer* 0) ; Index of first free port. +(defvar *reply-port-depth* 0) ; Dynamic depth in With-Reply-Port forms. + +;;; We use this as the reply port when allocating or deallocating reply +;;; ports to get around potentially nasty interactions. Interrupts +;;; are always off when we are doing this, so we don't have to have +;;; more than one of these, or worry about unwinding. +(defvar *allocate-reply-port* (mach:mach-task_data)) + +;;; Reset-Reply-Port-Stack -- Internal +;;; +;;; This is a before-save initialization which Nil's out the reply +;;; port stack and sets *allocate-reply-port* back to DataPort so that +;;; things initialize right at OS-Init time. +;;; +(defun reset-reply-port-stack () + (setq *reply-port-pointer* 0 *reply-port-depth* 0) + (fill (the simple-vector *reply-port-stack*) nil) + (setq *allocate-reply-port* (mach:mach-task_data))) +(pushnew 'reset-reply-port-stack *before-save-initializations*) + +;;; Allocate-New-Reply-Ports -- Internal +;;; +;;; If we run out of reply ports, we allocate another one, possibly +;;; growing the stack. +;;; +(defun allocate-new-reply-ports () + (let* ((stack *reply-port-stack*) + (pointer *reply-port-pointer*) + (len (length stack))) + (declare (simple-vector stack) (fixnum len)) + (when (eql pointer (1- len)) + (let ((new (make-array (* len 2)))) + (replace new stack :end1 len :end2 len) + (setq stack new *reply-port-stack* new))) + (setf (svref stack pointer) *allocate-reply-port*) + (let ((port (gr-call* mach:port_allocate (mach:mach-task_self)))) + (gr-call mach:port_disable (mach:mach-task_self) port) + ;; + ;; Nil out the allocate reply port so it isn't used for mundane purposes. + (setf (svref stack pointer) nil) + (setf (svref stack (1- pointer)) port) + port))) + +;;; Reallocate-Reply-Ports -- Internal +;;; +;;; This function is called when With-Reply-Port finds the stack pointer +;;; to be other than what it expected when it finishes. Reallocates all +;;; of the ports on the stack from Start to *reply-port-pointer*. We +;;; stick the *allocate-reply-port* out at *reply-port-pointer*, and +;;; bind *reply-port-depth*, so that the allocation functions are happy. +;;; +(defun reallocate-reply-ports (start) + (let* ((pointer *reply-port-pointer*) + (*reply-port-depth* pointer) + (stack *reply-port-stack*) + (save-port (svref stack pointer))) + (when (> start pointer) + (error "More ports in use than allocated???")) + (setf (svref stack pointer) *allocate-reply-port*) + (do ((i start (1+ i))) + ((= i pointer) + (setf (svref stack pointer) save-port)) + (let ((port (svref stack i))) + (gr-call mach:port_deallocate *task-self* port) + (setf (svref stack i) + (gr-call* mach:port_allocate *task-self*)))))) + + +;;;; Server stuff: +;;; +;;; There is a fair amount of stuff to support Matchmaker RPC servers +;;; and asynchonous message service. RPC message service needs to be +;;; centralized since a server must receive on all ports, and there is +;;; no way for a particular server to know about all other servers +;;; in the same lisp. +;;; +;;; The idea is that you receive the message, and then dispatch off +;;; of the port received on and the message ID received. Ports correspond +;;; to objects that the server manages. Message ID's correspond to the +;;; operations on the objects. Objects are grouped into object sets, which +;;; are sets of objects having the same operations defined. +;;; +;;; The same mechanism is used for handling asynchronous messages. +;;; + +;;; The current implementation uses standard eq[l] hashtables for both +;;; levels of dispatching. Special purpose data structures would be more +;;; efficient, but the ~1ms overhead will probably be lost in the noise. + +;;; +;;; Hashtable from ports to objects. Each entry is a cons (object . set). +;;; +(defvar *port-table* (make-hash-table :test #'eql)) + +;;; Hashtable from windows to objects. Each entry is a cons (object . set). +;;; +(defvar *xwindow-table* (make-hash-table :test #'eql)) + + +(defstruct (object-set + (:constructor make-object-set + (name &optional + (default-handler #'default-default-handler))) + (:print-function + (lambda (s stream d) + (declare (ignore d)) + (format stream "#<Object Set ~S>" (object-set-name s))))) + name ; Name, for descriptive purposes. + (table (make-hash-table :test #'eq)) ; Message-ID or xevent-type --> handler fun. + default-handler) + +(setf (documentation 'make-object-set 'function) + "Make an object set for use by a RPC/xevent server. Name is for + descriptive purposes only.") + + +;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and +;;; object set mapped to by a xwindow or port in *xwindow-table* or +;;; *port-table*. +;;; +(macrolet ((defmapper (name table) + `(defun ,(intern (concatenate 'simple-string + "MAP-" (symbol-name name))) + (,name) + ,(format nil "Return as multiple values the object and ~ + object-set mapped to by ~A." + (string-downcase (symbol-name name))) + (let ((temp (gethash ,name ,table))) + (if temp + (values (car temp) (cdr temp)) + (values nil nil)))))) + (defmapper port *port-table*) + (defmapper xwindow *xwindow-table*)) + + +;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair +;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*. +;;; +(macrolet ((def-add-object (name table) + `(defun ,(intern (concatenate 'simple-string + "ADD-" (symbol-name name) + "-OBJECT")) + (,name object object-set) + ,(format nil "Add a new ~A/object/object-set association." + (string-downcase (symbol-name name))) + (check-type object-set object-set) + (setf (gethash ,name ,table) (cons object object-set)) + object))) + (def-add-object port *port-table*) + (def-add-object xwindow *xwindow-table*)) + + +;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and +;;; its associated object/object-set pair from *port-table* or *xwindow-table*. +;;; +(macrolet ((def-remove-object (name table) + `(defun ,(intern (concatenate 'simple-string + "REMOVE-" (symbol-name name) + "-OBJECT")) + (,name) + ,(format nil + "Remove ~A and its associated object/object-set pair." + (string-downcase (symbol-name name))) + (remhash ,name ,table)))) + (def-remove-object port *port-table*) + (def-remove-object xwindow *xwindow-table*)) + + +;;; Object-Set-Operation -- Public +;;; +;;; Look up the handler function for a given message ID. +;;; +(defun object-set-operation (object-set message-id) + "Return the handler function in Object-Set for the operation specified by + Message-ID, if none, NIL is returned. The handler function is passed + the object. The received message is in server-Message." + (check-type object-set object-set) + (check-type message-id fixnum) + (values (gethash message-id (object-set-table object-set)))) + +;;; %Set-Object-Set-Operation -- Internal +;;; +;;; The setf inverse for Object-Set-Operation. +;;; +(defun %set-object-set-operation (object-set message-id new-value) + (check-type object-set object-set) + (check-type message-id fixnum) + (setf (gethash message-id (object-set-table object-set)) new-value)) +;;; +(defsetf object-set-operation %set-object-set-operation + "Sets the handler function for an object set operation.") + +;;;; Server function: +;;; +;;; SERVER makes use of a defined alien, server-event, that lives at address 0. +;;; This is a bogus alien used just as a dynamic variable that is declared +;;; appropriately for the compiler. This alien variable is bound to stuff in +;;; an alien stack by the same name, server-event, which contains elements much +;;; bigger than necessary to accommodate whatever will come back in the future +;;; from waiting across ports, sockets, file descriptors, etc. The defined +;;; alien operators allow easy access to server-event as different types of +;;; event by declaring the necessary type for the compiler when the operator +;;; is used. + + +;;; Currently the server message is 4k bytes, thus serving larger requests +;;; is impossible. If anyone is bothered by this, the size can be increased. +;;; X events are only 24 bytes. +;;; + +(defconstant server-message-size 4096) +(defalien server-message server-message (bytes server-message-size) 0) + +(define-alien-stack server-message server-message (bytes server-message-size)) + +(defrecord server-message + (msg mach:msg #.(record-size 'mach:msg))) + +(defvar *file-input-handlers* () + "Is an association list of file descriptors and functions to call when + input is available on the particular file descriptor.") + +(defvar *clx-server-displays* () + "Is a list of CLX displays that may have some activity on them.") + +(defvar *display-event-handlers* nil + "This is an alist mapping displays to user functions to be called when + SYSTEM:SERVER notices input on a display connection. Do not modify this + directly; use EXT:ENABLE-CLX-EVENT-HANDLING. A given display should be + represented here only once.") + + +;;; Default-Default-Handler -- Internal +;;; +;;; If no such operation defined, signal an error. +;;; +(defun default-default-handler (object) + (alien-bind ((msg (server-message-msg server-message))) + (error "No operation for ID ~D on ~S in ~S." + (alien-access (mach:msg-id (alien-value msg))) object + (car (gethash (alien-access (mach:msg-localport (alien-value msg))) + *port-table*))))) + + +;;; Server -- Public +;;; +(defun server (&optional (timeout 0 todef)) + "Receive on all ports and Xevents and dispatch to the appropriate handler + function. If timeout is specified, server will wait the specified time + and then return, otherwise it will wait until something happens. Server + returns T if something happened and NIL otherwise." + (cond ((dolist (d/h ext::*display-event-handlers* nil) + (let ((d (car d/h))) + (when (xlib::event-listen d) + (handler-bind ((error #'(lambda (condx) + (declare (ignore condx)) + (flush-display-events d)))) + (funcall (cdr d/h) d)) + (return t)))) + T) + (T + (let* ((to (if todef (round (* timeout 1000000)))) + (fd-mask 0) + (omask 0) + (value (catch 'server-catch + (unwind-protect + (progn + (setq omask (mach:unix-sigsetmask + (mach:sigmask mach:sigmsg))) + (unless (grab-message-loop) + (let ((*in-server* T)) + (enable-interrupt mach:sigmsg #'ih-sigmsg) + (multiple-value-bind + (to1 to2) + (if todef (truncate to 1000000)) + (multiple-value-bind + (nfd fdm) + (get-fd-info) + (mach:unix-sigsetmask 0) + (multiple-value-bind + (nfnd rfdm) + (mach:unix-select nfd fdm 0 0 + to1 to2) + (mach:unix-sigsetmask + (mach:sigmask mach:sigmsg)) + (default-interrupt mach:sigmsg) + (setq fd-mask rfdm) + nfnd)))))) + (default-interrupt mach:sigmsg) + (mach:unix-sigsetmask omask))))) + (cond ((or (null value) (and todef (eq value 0))) NIL) + ((eq value server-unique-object) + (grab-message-loop) + T) + ((file-descriptor-ready fd-mask) T)))))) + +;;; Get-fd-info turns the association list in *file-input-handlers* +;;; into information that unix-select can be called with. +(defun Get-fd-info () + (do* ((fdl *file-input-handlers* (cdr fdl)) ; + (FD (caar fdl) (caar fdl)) + (mfd 0) + (fdm 0)) + ((null fdl) + (values (1+ mfd) fdm)) + (setq mfd (max mfd fd)) + (setq fdm (logior fdm (ash 1 fd))))) + +;;; File-descriptor-ready is called when server determines that a file +;;; descriptor has input ready on one ore more of them. It calls the +;;; appropriate handler with the file-descriptor as its argument. +;;; It checks for an xevent first, so they are handled as quickly as +;;; possible. +(defun file-descriptor-ready (rfdm) + (do ((fd 0 (1+ fd)) + (ms rfdm (ash ms -1))) + ((eq ms 0)) + (when (/= (the fixnum (logand ms 1)) 0) + (let ((info (assoc fd *file-input-handlers* :test #'eq))) + (when info + (funcall (cdr info) fd))))) + T) + +;;; Grab-message-loop calls the appropiate handler for an IPC message. +(defun grab-message-loop () + (do* ((gr (server-grab-message) (server-grab-message)) + (flag (/= gr mach:rcv-timed-out) + (if (/= gr mach:rcv-timed-out) t flag))) + ((= gr mach:rcv-timed-out) flag))) + +(defun server-grab-message () + (with-stack-alien (sm server-message) + (alien-bind ((msg (server-message-msg (alien-value sm)))) + (setf (alien-access (mach:msg-msgsize (alien-value msg))) + server-message-size) + (setf (alien-access (mach:msg-localport (alien-value msg))) + mach::port-enabled) + (let ((gr (mach:msg-receive (alien-value sm) mach::rcv-timeout 0))) + (when (eql gr mach:rcv-timed-out) + (return-from server-grab-message gr)) + (unless (eql gr mach:rcv-success) + (gr-error 'mach:msg-receive gr)) + (let* ((server-message (alien-value sm)) + (port (alien-access (mach:msg-localport (alien-value msg)))) + (id (alien-access (mach:msg-id (alien-value msg)))) + (x (gethash port *port-table*)) + (set (cdr x))) + (unless x + (error "~D is not known to server (operation: ~D)." port id)) + (let ((gr (funcall (gethash id (object-set-table set) + (object-set-default-handler set)) + (car x)))) + (unless (eql gr mach:kern-success) + (gr-error 'server gr))))))) + mach:kern-success) + +(defun serve-all (&optional (timeout 0)) + "Serve-all calls server with the specified timeout. If server does + something (returns T) it loops over server with timeout 0 until all + events have been served. Serve-all returns T if server did something + and other NIL." + (do ((res NIL) + (sval (server timeout) (server 0))) + ((null sval) res) + (setq res T))) + + +;;;; Emergency Message Handling: +;;; +;;; We use the same mechanism for asynchronous messages as is used for +;;; normal server messages. The only tricky part is that we don't want +;;; some random server function being called when we really want to +;;; receive an emergency message, so we can't receive on all ports. +;;; Instead, we use MessagesWaiting to find the ports with emergency +;;; messages. + +(defalien waiting-ports nil (long-words 128)) + +;;; Service-Emergency-Message-Interrupt -- Internal +;;; +;;; This is a lot like the server function, but we only receive on +;;; ports with one emergency message. We only receive one message because +;;; the handler function might have caused any other messages to be received. +;;; When we re-enable interrupts, if any emergency messages are left, we +;;; should be interrupted again. +;;; +(defun service-emergency-message-interrupt () + (grab-message-loop)) + +;;; +;;; This object set is used for DataPort, which is the port various magical +;;; message from the kernel are received on... +(defvar *kernel-messages* (make-object-set "Kernel Messages")) + +(compiler-let ((*alien-eval-when* '(compile eval))) +(defrecord port-death-msg + (msg mach:msg #.(record-size 'mach:msg)) + (ex-port-tt pad (long-words 1)) + (ex-port (signed-byte 32) (long-words 1))) + +(defoperator (server-message-port-death-msg port-death-msg) + ((msg server-message)) + `(alien-index (alien-value ,msg) 0 (record-size 'port-death-msg))) +); Compiler-Let + + +;;; *Port-Death-Handlers* is an EQ hash table of lists of functions that are +;;; called upon port death. If a port dies that is not in the table, we print +;;; out a message on *Trace-Output* describing its death. If +;;; *Pornography-Of-Death* is true, we don't even print that message. + +(defvar *port-death-handlers* (make-hash-table :test #'eql) + "Don't use this --- use Add-Port-Death-Handler instead.") + +;;; Add-Port-Death-Handler, Remove-Port-Death-Handler -- Public +;;; +(defun add-port-death-handler (port function) + "Make Function a handler for port death on Port. When the port dies, + Function is called with the port and an argument. See also + Remove-Port-Death-Handler." + (pushnew function (gethash port *port-death-handlers*)) + nil) +;;; +(defun remove-port-death-handler (port function) + "Undoes the effect of Add-Port-Death-Handler." + (setf (gethash port *port-death-handlers*) + (delete function (gethash port *port-death-handlers*))) + nil) + +(setf (object-set-operation *kernel-messages* mach:notify-port-deleted) + #'(lambda (obj) + (declare (ignore obj)) + (let* ((ex-port (alien-access + (port-death-msg-ex-port + (server-message-port-death-msg server-message)))) + (handlers (gethash ex-port *port-death-handlers*))) + (remhash ex-port *port-table*) + (remhash ex-port *port-death-handlers*) + (if (null handlers) + (handle-unclaimed-port-death ex-port) + (dolist (fun handlers) (funcall fun ex-port)))) + mach:kern-success)) + +(defvar *pornography-of-death* t + "If true, nothing is said about port deaths.") + +(defun handle-unclaimed-port-death (port) + (unless *pornography-of-death* + (format *trace-output* "~&[Port ~S just bit the dust.]~%" port))) + +;;; Port receive and ownership rights messages are handled simlarly, but +;;; by default we deallocate the port to make sure it's really dead. This +;;; gets around problems with ports being exhausted because some servers +;;; don't really nuke the port when the deallocate the object. +;;; + +(defvar *port-receive-rights-handlers* (make-hash-table :test #'eql) + "This is a hashtable from ports to functions. The function is called with + the port as its argument when a port receive rights message for that port + is received from the kernel.") + +(defvar *port-ownership-rights-handlers* (make-hash-table :test #'eql) + "This is a hashtable from ports to functions. The function is called with + the port as its argument when a port ownership rights message for that port + is received from the kernel.") + +(setf (object-set-operation *kernel-messages* mach:notify-receive-rights) + #'(lambda (obj) + (declare (ignore obj)) + (let ((ex-port (alien-access + (port-death-msg-ex-port + (server-message-port-death-msg server-message))))) + (funcall (gethash ex-port *port-receive-rights-handlers* + #'handle-unclaimed-port-rights) + ex-port)) + mach:kern-success)) + +(setf (object-set-operation *kernel-messages* mach:notify-ownership-rights) + #'(lambda (obj) + (declare (ignore obj)) + (let ((ex-port (alien-access + (port-death-msg-ex-port + (server-message-port-death-msg server-message))))) + (funcall (gethash ex-port *port-ownership-rights-handlers* + #'handle-unclaimed-port-rights) + ex-port)) + mach:kern-success)) + +(defun handle-unclaimed-port-rights (port) + (unless *pornography-of-death* + (format *trace-output* "~&[Rights received for port ~D, deallocating it.]~%" + port)) + (mach:port_deallocate *task-self* port) + (remhash port *port-receive-rights-handlers*) + (remhash port *port-ownership-rights-handlers*) + (remhash port *port-table*)) + +(add-port-object *task-data* nil *kernel-messages*) + +;;; Clear-Port-Tables -- Internal +;;; +;;; A before-save initialization which clears all of the port hashtables. +;;; +(defun clear-port-tables () + (clrhash *port-table*) + (clrhash *port-death-handlers*) + (clrhash *port-receive-rights-handlers*) + (clrhash *port-ownership-rights-handlers*)) + +(pushnew 'clear-port-tables *before-save-initializations*) + + +;;; %Initial-Function is called when a cold system starts up. First we zoom +;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen +;;; at "load time." Then we initialize the various subsystems and call the +;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until +;;; someone (most likely the Quit function) throws to the tag +;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms +;;; in Unwind-Protects will get executed. + +(proclaim '(special *lisp-initialization-functions*)) + +(eval-when (compile) + (defmacro print-and-call (name) + `(progn + (%primitive print ',name) + (,name)))) + +(defun %initial-function () + "Gives the world a shove and hopes it spins." + (setq *already-maybe-gcing* t) + (setf *gc-inhibit* nil) + (setf *need-to-collect-garbage* nil) + (%primitive print "In initial-function, and running.") + + ;; Many top-level forms call INFO, (SETF INFO). + (print-and-call c::globaldb-init) + + ;; Some of the random top-level forms call Make-Array, which calls Subtypep... + (print-and-call subtypep-init) + + (setq *lisp-initialization-functions* + (nreverse *lisp-initialization-functions*)) + (%primitive print "Calling top-level forms.") + (dolist (fun *lisp-initialization-functions*) + (funcall fun)) + (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed. + + (print-and-call os-init) + (print-and-call filesys-init) + (print-and-call conditions::error-init) + + (print-and-call reader-init) + (print-and-call backq-init) + (print-and-call sharp-init) + ;; After the various reader subsystems have done their thing to the standard + ;; readtable, copy it to *readtable*. + (setq *readtable* (copy-readtable std-lisp-readtable)) + + (print-and-call stream-init) + (print-and-call random-init) + (print-and-call format-init) + (print-and-call package-init) + (print-and-call pprint-init) + + (setq *already-maybe-gcing* nil) + (terpri) + (princ "CMU Common Lisp kernel core image ") + (princ (lisp-implementation-version)) + (princ ".") + (terpri) + (princ "[You are in the LISP package.]") + (terpri) + (catch '%end-of-the-world + (loop + (%top-level) + (write-line "You're certainly a clever child."))) + (mach:unix-exit 0)) + + +;;;; Initialization functions: + +;;; Reinit is called to reinitialize the world when a saved core image +;;; is resumed. +(defvar *task-notify* NIL) + +(defun reinit () + (without-interrupts + (setq *already-maybe-gcing* t) + (os-init) + (stream-reinit) + (setq *already-maybe-gcing* nil)) + (setq *task-notify* (mach:mach-task_notify)) + (mach:port_enable (mach:mach-task_self) *task-notify*) + (add-port-object *task-notify* nil *kernel-messages*) + (init-mach-signals)) + + +;;; OS-Init initializes our operating-system interface. It sets the values +;;; of the global port variables to what they should be and calls the functions +;;; that set up the argument blocks for the server interfaces. + +(defun os-init () + (setq *task-self* (mach:mach-task_self)) + (setq *task-data* (mach:mach-task_data))) + + +;;; Setup-path-search-list returns a list of the directories that are +;;; in the unix path environment variable. This is so that run-program +;;; can be smarter about where to find a program to run. +(defun setup-path-search-list () + (let ((path (cdr (assoc :path ext::*environment-list*)))) + (when path + (do* ((i 0 (1+ p)) + (p (position #\: path :start i) + (position #\: path :start i)) + (pl ())) + ((null p) + (let ((s (subseq path i))) + (if (string= s "") + (push "default:" pl) + (push (concatenate 'simple-string s "/") pl))) + (nreverse pl)) + (let ((s (subseq path i p))) + (if (string= s "") + (push "default:" pl) + (push (concatenate 'simple-string s "/") pl))))))) + + +;;;; Miscellaneous external functions: + +(defun print-herald () + (write-string "CMU Common Lisp ") + (write-line (lisp-implementation-version)) + (write-string "Hemlock ") (write-string *hemlock-version*) + (write-string ", Compiler ") (write-line compiler-version) + (write-line "Send bug reports and questions to Gripe.") + (values)) + +(defvar *editor-lisp-p* nil + "This is true if and only if the lisp was started with the -edit switch.") + +(defun save-lisp (core-file-name &key + (purify t) + (root-structures ()) + (init-function + #'(lambda () + (throw 'top-level-catcher nil))) + (load-init-file t) + (print-herald t) + (process-command-line t)) + "Saves a Spice Lisp core image in the file of the specified name. The + following keywords are defined: + + :purify + If true, do a purifying GC which moves all dynamically allocated + objects into static space so that they stay pure. This takes somewhat + longer than the normal GC which is otherwise done, but GC's will done + less often and take less time in the resulting core file. + + :root-structures + This should be a list of the main entry points in any newly loaded + systems. This need not be supplied, but locality will be better if it + is. This is meaningless if :purify is Nil. + + :init-function + This is a function which is called when the created core file is + resumed. The default function simply aborts to the top level + read-eval-print loop. If the function returns it will be the value + of Save-Lisp. + + :load-init-file + If true, then look for an init.lisp or init.fasl file when the core + file is resumed. + + :print-herald + If true, print out the lisp system herald when starting." + + (if purify + (purify :root-structures root-structures) + (gc)) + (unless (save core-file-name) + (setf (search-list "default:") (list (default-directory))) + (setf (search-list "path:") (setup-path-search-list)) + (when process-command-line (ext::process-command-strings)) + (setf *editor-lisp-p* nil) + (macrolet ((find-switch (name) + `(find ,name *command-line-switches* + :key #'cmd-switch-name + :test #'(lambda (x y) + (declare (simple-string x y)) + (string-equal x y))))) + (when (and process-command-line (find-switch "edit")) + (setf *editor-lisp-p* t)) + (when (and load-init-file + (not (and process-command-line (find-switch "noinit")))) + (let* ((cl-switch (find-switch "init")) + (name (or (and cl-switch + (or (cmd-switch-value cl-switch) + (car (cmd-switch-words cl-switch)) + "init")) + "init"))) + (load (merge-pathnames name (user-homedir-pathname)) + :if-does-not-exist nil)))) + (when print-herald + (print-herald)) + (when process-command-line + (ext::invoke-switch-demons *command-line-switches* + *command-switch-demons*)) + (funcall init-function))) + + +;;; Quit gets us out, one way or another. + +(defun quit (&optional recklessly-p) + "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is + non-Nil." +; (reset-keyboard 0) + (dolist (x (if (boundp 'extensions::temporary-foreign-files) + extensions::temporary-foreign-files)) + (mach:unix-unlink x)) + (if recklessly-p + (mach:unix-exit 0) + (throw '%end-of-the-world nil))) + + + +(defalien sleep-msg mach:msg (record-size 'mach:msg)) +(setf (alien-access (mach:msg-simplemsg sleep-msg)) T) +(setf (alien-access (mach:msg-msgtype sleep-msg)) 0) +(setf (alien-access (mach:msg-msgsize sleep-msg)) + (/ (record-size 'mach:msg) 8)) + +;;; Currently there is a bug in the Mach timeout code that if the timeout +;;; period is too short the receive never returns. + +(defun sleep (n) + "This function causes execution to be suspended for N seconds. N may + be any non-negative, non-complex number." + (with-reply-port (sleep-port) + (let ((m (round (* 1000 n)))) + (cond ((minusp m) + (error "Argument to Sleep, ~S, is a negative number." n)) + ((zerop m)) + (t + (setf (alien-access (mach:msg-localport sleep-msg)) sleep-port) + (let ((gr (mach:msg-receive sleep-msg mach:rcv-timeout m))) + (unless (eql gr mach:rcv-timed-out) + (gr-error 'mach:receive gr))))))) + nil) + + +;;;; TOP-LEVEL loop. + +(defvar / nil + "Holds a list of all the values returned by the most recent top-level EVAL.") +(defvar // nil "Gets the previous value of / when a new value is computed.") +(defvar /// nil "Gets the previous value of // when a new value is computed.") +(defvar * nil "Holds the value of the most recent top-level EVAL.") +(defvar ** nil "Gets the previous value of * when a new value is computed.") +(defvar *** nil "Gets the previous value of ** when a new value is computed.") +(defvar + nil "Holds the value of the most recent top-level READ.") +(defvar ++ nil "Gets the previous value of + when a new value is read.") +(defvar +++ nil "Gets the previous value of ++ when a new value is read.") +(defvar - nil "Holds the form curently being evaluated.") +(defvar *prompt* nil "The top-level prompt string.") +(defvar %temp% nil "Random temporary, clobbered by top level loop.") +(defvar *in-top-level-catcher* nil + "True if we are within the Top-Level-Catcher. This is used by interrupt + handlers to see whether it is o.k. to throw.") + +(defun %top-level () + "Top-level READ-EVAL-PRINT loop. Do not call this." + (let ((this-eval nil) (* nil) (** nil) (*** nil) + (- nil) (+ nil) (++ nil) (+++ nil) + (/// nil) (// nil) (/ nil) (%temp% nil)) + (loop + (with-simple-restart (abort "Return to Top-Level.") + (catch 'top-level-catcher + ;; + ;; Prevent the user from irrevocably wedging the hooks. + (setq *evalhook* nil) + (setq *applyhook* nil) + (let ((*in-top-level-catcher* t)) + (loop + (fresh-line) + (princ *prompt*) + (setq +++ ++ ++ + + - - (read)) + (setq this-eval (multiple-value-list (eval -))) + (dolist (x this-eval) + (fresh-line) + (prin1 x)) + (setq /// // // / / this-eval) + (setq %temp% (car this-eval)) + ;; + ;; Make sure nobody passes back an unbound marker. + (unless (boundp '%temp%) + (setq %temp% nil) + (cerror "Go on, but set * to NIL." + "Eval returned an unbound marker.")) + (setq *** ** ** * * %temp%)))))))) + + +;;; %Halt -- Interface +;;; +;;; A convenient way to get into the assembly level debugger. +;;; +(defun %halt () + (%primitive halt)) diff --git a/code/list.lisp b/code/list.lisp new file mode 100644 index 000000000..d182b726f --- /dev/null +++ b/code/list.lisp @@ -0,0 +1,869 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Functions to implement lists for Spice Lisp. +;;; Written by Joe Ginder and Carl Ebeling. +;;; Rewritten and currently maintained by Skef Wholey. +;;; +;;; Nsublis, things at the beginning broken. +;;; +;;; The list functions are part of the standard Spice Lisp environment. +;;; +;;; ********************************************************************** +;;; +(in-package 'lisp) + +(export '(car cdr caar + cadr cdar cddr caaar caadr cadar caddr cdaar cdadr + cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr + caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr + cdddar cddddr cons tree-equal endp list-length nth first + second third fourth fifth sixth seventh eighth + ninth tenth rest nthcdr last list list* make-list + append copy-list copy-alist copy-tree revappend nconc + nreconc butlast nbutlast ldiff rplaca rplacd subst + subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis + member member-if member-if-not tailp adjoin union + nunion intersection nintersection set-difference + nset-difference set-exclusive-or nset-exclusive-or subsetp + acons pairlis + assoc assoc-if assoc-if-not + rassoc rassoc-if rassoc-if-not)) + +(proclaim '(maybe-inline + tree-equal list-length nth %setnth nthcdr last make-list append + copy-list copy-alist copy-tree revappend nconc nreconc butlast + nbutlast ldiff member member-if member-if-not tailp adjoin union + nunion intersection nintersection set-difference nset-difference + set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc + assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if + subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis)) + + +(in-package "EXTENSIONS") +(export '(assq memq delq)) +;; Assq & memq are just interpreter stubs. +(proclaim '(maybe-inline delq)) +(in-package 'lisp) + + +;;; These functions perform basic list operations: + +(defun car (list) "Returns the 1st object in a list." (car list)) +(defun cdr (list) "Returns all but the first object." (cdr list)) +(defun cadr (list) "Returns the 2nd object in a list." (cadr list)) +(defun cdar (list) "Returns the cdr of the 1st sublist." (cdar list)) +(defun caar (list) "Returns the car of the 1st sublist." (caar list)) +(defun cddr (list) "Returns all but the 1st two objects of a list." (cddr list)) +(defun caddr (list) "Returns the 1st object in the cddr of a list." (caddr list)) +(defun caadr (list) "Returns the 1st object in the cadr of a list." (caadr list)) +(defun caaar (list) "Returns the 1st object in the caar of a list." (caaar list)) +(defun cdaar (list) "Returns the cdr of the caar of a list." (cdaar list)) +(defun cddar (list) "Returns the cdr of the cdar of a list." (cddar list)) +(defun cdddr (list) "Returns the cdr of the cddr of a list." (cdddr list)) +(defun cadar (list) "Returns the car of the cdar of a list." (cadar list)) +(defun cdadr (list) "Returns the cdr of the cadr of a list." (cdadr list)) +(defun caaaar (list) "Returns the car of the caaar of a list." (caaaar list)) +(defun caaadr (list) "Returns the car of the caadr of a list." (caaadr list)) +(defun caaddr (list) "Returns the car of the caddr of a list." (caaddr list)) +(defun cadddr (list) "Returns the car of the cdddr of a list." (cadddr list)) +(defun cddddr (list) "Returns the cdr of the cdddr of a list." (cddddr list)) +(defun cdaaar (list) "Returns the cdr of the caaar of a list." (cdaaar list)) +(defun cddaar (list) "Returns the cdr of the cdaar of a list." (cddaar list)) +(defun cdddar (list) "Returns the cdr of the cddar of a list." (cdddar list)) +(defun caadar (list) "Returns the car of the cadar of a list." (caadar list)) +(defun cadaar (list) "Returns the car of the cdaar of a list." (cadaar list)) +(defun cadadr (list) "Returns the car of the cdadr of a list." (cadadr list)) +(defun caddar (list) "Returns the car of the cddar of a list." (caddar list)) +(defun cdaadr (list) "Returns the cdr of the caadr of a list." (cdaadr list)) +(defun cdadar (list) "Returns the cdr of the cadar of a list." (cdadar list)) +(defun cdaddr (list) "Returns the cdr of the caddr of a list." (cdaddr list)) +(defun cddadr (list) "Returns the cdr of the cdadr of a list." (cddadr list)) +(defun cons (se1 se2) "Returns a list with se1 as the car and se2 as the cdr." + (cons se1 se2)) + + +(proclaim '(maybe-inline tree-equal-test tree-equal-test-not)) + +(defun tree-equal-test-not (x y test-not) + (cond ((not (funcall test-not x y)) t) + ((consp x) + (and (consp y) + (tree-equal-test-not (car x) (car y) test-not) + (tree-equal-test-not (cdr x) (cdr y) test-not))) + (t ()))) + +(defun tree-equal-test (x y test) + (cond ((funcall test x y) t) + ((consp x) + (and (consp y) + (tree-equal-test (car x) (car y) test) + (tree-equal-test (cdr x) (cdr y) test))) + (t ()))) + +(defun tree-equal (x y &key (test #'eql) test-not) + "Returns T if X and Y are isomorphic trees with identical leaves." + (if test-not + (tree-equal-test-not x y test-not) + (tree-equal-test x y test))) + + +(defun endp (object) + "The recommended way to test for the end of a list. True if Object is nil, + false if Object is a cons, and an error for any other types of arguments." + (endp object)) + +(defun list-length (list) + "Returns the length of the given List, or Nil if the List is circular." + (do ((n 0 (+ n 2)) + (y list (cddr y)) + (z list (cdr z))) + (()) + (when (endp y) (return n)) + (when (endp (cdr y)) (return (+ n 1))) + (when (and (eq y z) (> n 0)) (return nil)))) + +(defun nth (n list) + "Returns the nth object in a list where the car is the zero-th element." + (car (%primitive nthcdr n list))) + +(defun first (list) + "Returns the 1st object in a list or NIL if the list is empty." + (car list)) +(defun second (list) + "Returns the 2nd object in a list or NIL if there is no 2nd object." + (cadr list)) +(defun third (list) + "Returns the 3rd object in a list or NIL if there is no 3rd object." + (caddr list)) +(defun fourth (list) + "Returns the 4th object in a list or NIL if there is no 4th object." + (cadddr list)) +(defun fifth (list) + "Returns the 5th object in a list or NIL if there is no 5th object." + (car (cddddr list))) +(defun sixth (list) + "Returns the 6th object in a list or NIL if there is no 6th object." + (cadr (cddddr list))) +(defun seventh (list) + "Returns the 7th object in a list or NIL if there is no 7th object." + (caddr (cddddr list))) +(defun eighth (list) + "Returns the 8th object in a list or NIL if there is no 8th object." + (cadddr (cddddr list))) +(defun ninth (list) + "Returns the 9th object in a list or NIL if there is no 9th object." + (car (cddddr (cddddr list)))) +(defun tenth (list) + "Returns the 10th object in a list or NIL if there is no 10th object." + (cadr (cddddr (cddddr list)))) +(defun rest (list) + "Means the same as the cdr of a list." + (cdr list)) + +(defun nthcdr (n list) + "Performs the cdr function n times on a list." + (%primitive nthcdr n list)) + +(defun last (list) + "Returns the last cons (not the last element!) of a list." + (%primitive last list)) + +(defun list (&rest args) + "Returns constructs and returns a list of its arguments." + args) + +;;; List* is done the same as list, except that the last cons is made a +;;; dotted pair + +(defun list* (arg &rest others) + "Returns a list of the arguments with last cons a dotted pair" + (cond ((atom others) arg) + ((atom (cdr others)) (cons arg (car others))) + (t (do ((x others (cdr x))) + ((null (cddr x)) (rplacd x (cadr x)))) + (cons arg others)))) + +(defun make-list (size &key initial-element) + (declare (fixnum size)) + "Constructs a list with size elements each set to value" + (if (< size 0) (error "~S is an illegal size for MAKE-LIST." size) + (do ((count size (1- count)) + (result '() (cons initial-element result))) + ((zerop count) result) + (declare (fixnum count))))) + +;;; The outer loop finds the first non-null list and the result is started. +;;; The remaining lists in the arguments are tacked to the end of the result +;;; using splice which cdr's down the end of the new list + +(defun append (&rest lists) + "Construct a new list by concatenating the list arguments" + (do ((top lists (cdr top))) ;;Cdr to first non-null list. + ((atom top) '()) + (cond ((null (car top))) ; Nil -> Keep looping + ((not (consp (car top))) ; Non cons + (if (cdr top) + (error "~S is not a list." (car top)) + (return (car top)))) + (t ; Start appending + (return + (if (atom (cdr top)) + (car top) ;;Special case. + (let* ((result (cons (caar top) '())) + (splice result)) + (do ((x (cdar top) (cdr x))) ;;Copy first list + ((atom x)) + (setq splice + (cdr (rplacd splice (cons (car x) ()) ))) ) + (do ((y (cdr top) (cdr y))) ;;Copy rest of lists. + ((atom (cdr y)) + (setq splice (rplacd splice (car y))) + result) + (if (listp (car y)) + (do ((x (car y) (cdr x))) ;;Inner copy loop. + ((atom x)) + (setq + splice + (cdr (rplacd splice (cons (car x) ()))))) + (error "~S is not a list." (car y))))))))))) + + +;;; List Copying Functions + + +;;; The list is copied correctly even if the list is not terminated by () +;;; The new list is built by cdr'ing splice which is always at the tail +;;; of the new list + +(defun copy-list (list) + "Returns a new list EQUAL but not EQ to list" + (if (atom list) + (if list + (error "~S is not a list." list)) + (let ((result (cons (car list) '()) )) + (do ((x (cdr list) (cdr x)) + (splice result + (cdr (rplacd splice (cons (car x) '() ))) )) + ((atom x) (unless (null x) + (rplacd splice x)) + result))))) + +(defun copy-alist (alist) + "Returns a new association list equal to alist, constructed in space" + (if (atom alist) + (if alist + (error "~S is not a list." alist)) + (let ((result + (cons (if (atom (car alist)) + (car alist) + (cons (caar alist) (cdar alist)) ) + '() ))) + (do ((x (cdr alist) (cdr x)) + (splice result + (cdr (rplacd splice + (cons + (if (atom (car x)) + (car x) + (cons (caar x) (cdar x))) + '() ))) )) +;;; Non-null terminated alist done here. + ((atom x) (unless (null x) + (rplacd splice x)) + result))))) + +(defun copy-tree (object) + "Copy-Tree recursively copys trees of conses." + (cond ((not (consp object)) object) + (T (cons (copy-tree (car object)) (copy-tree (cdr object)))) )) + +;;; More Commonly-used List Functions + +(defun revappend (x y) + "Returns (append (reverse x) y)" + (do ((top x (cdr top)) + (result y (cons (car top) result))) + ((endp top) result))) + +;;; NCONC finds the first non-null list, so it can make splice point +;;; to a cons. After finding the first cons element, it holds it in +;;; a result variable while running down successive elements tacking +;;; them together. While tacking lists together, if we encounter a +;;; null list, we set the previous list's last cdr to nil just in case +;;; it wasn't already nil, and it could have been dotted while the null +;;; list was the last argument to NCONC. The manipulation of splice (that +;;; is starting it out on a first cons, setting LAST of splice, and +;;; setting splice to ele) inherently handles (nconc x x), and it avoids +;;; running down the last argument to NCONC which allows the last argument +;;; to be circular. +;;; +(defun nconc (&rest lists) + "Concatenates the lists given as arguments (by changing them)" + (do ((top lists (cdr top))) + ((null top) nil) + (typecase (car top) + (cons + (let* ((result (car top)) + (splice result)) + (dolist (ele (cdr top)) + (typecase ele + (cons (rplacd (last splice) ele) + (setf splice ele)) + (null (rplacd (last splice) nil)) + (t (error "Argument is not a list -- ~S." ele)))) + (return result))) + (null) + (t (error "Argument is not a list -- ~S." (car top)))))) + +(defun nreconc (x y) + "Returns (nconc (nreverse x) y)" + (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st))) + (2nd x 1st) ;2nd follows first down the list. + (3rd y 2nd)) ;3rd follows 2nd down the list. + ((atom 2nd) 3rd) + (rplacd 2nd 3rd))) + +(defun butlast (list &optional (n 1)) + "Returns a new list the same as List without the N last elements." + (unless (integerp n) + (error "Wrong type argument, ~S, should have been of type INTEGER.")) + (if (< n 0) (setq n 0)) + (let ((length (1- (length (the list list))))) + (declare (fixnum length)) + (if (< length n) + () + (do* ((top (cdr list) (cdr top)) + (result (list (car list))) + (splice result) + (count length (1- count))) + ((= count n) result) + (setq splice (cdr (rplacd splice (list (car top))))))))) + +(defun nbutlast (list &optional (n 1)) + "Modifies List to remove the last N elements." + (unless (integerp n) + (error "Wrong type argument, ~S, should have been of type INTEGER.")) + (if (< n 0) (setq n 0)) + (let ((length (1- (length (the list list))))) + (declare (fixnum length)) + (if (< length n) () + (do ((1st (cdr list) (cdr 1st)) + (2nd list 1st) + (count length (1- count))) + ((= count n) + (rplacd 2nd ()) + list))))) + +(defun ldiff (list sublist) + "Returns a new list, whose elements are those of List that appear before + Sublist. If Sublist is not a tail of List, a copy of List is returned." + (do* ((list list (cdr list)) + (result (list ())) + (splice result)) + ((or (null list) (eq list sublist)) (cdr result)) + (setq splice (cdr (rplacd splice (list (car list))))))) + +;;; Functions to alter list structure + +(defun rplaca (x y) + "Changes the car of x to y and returns the new x." + (rplaca x y)) + +(defun rplacd (x y) + "Changes the cdr of x to y and returns the new x." + (rplacd x y)) + +;;; The following are for use by SETF. + +(defun %rplaca (x val) (rplaca x val) val) + +(defun %rplacd (x val) (rplacd x val) val) + +(defun %setnth (n list newval) + (declare (fixnum n)) + "Sets the Nth element of List (zero based) to Newval." + (if (< n 0) + (error "~S is an illegal N for SETF of NTH." n) + (do ((count n (1- count))) + ((zerop count) (rplaca list newval) newval) + (declare (fixnum count)) + (if (endp (cdr list)) + (error "~S is too large an index for SETF of NTH." n) + (setq list (cdr list)))))) + +;;;; Macros for (&key (key #'identity) (test #'eql testp) (test-not nil notp)). +;;; Use these with the following keyword args: +;;; +(defmacro with-set-keys (funcall) + `(cond ((and testp notp) (error "Test and test-not both supplied.")) + (notp ,(append funcall '(:key key :test-not test-not))) + (t ,(append funcall '(:key key :test test))))) + +(defmacro satisfies-the-test (item elt) + `(cond (testp + (funcall test ,item (funcall key ,elt))) + (notp + (not (funcall test-not ,item (funcall key ,elt)))) + (t (funcall test ,item (funcall key ,elt))))) + + +;;; Substitution of expressions + + + +(defun subst (new old tree &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Substitutes new for subtrees matching old." + (labels ((s (subtree) + (cond ((satisfies-the-test old subtree) new) + ((atom subtree) subtree) + (t (let ((car (s (car subtree))) + (cdr (s (cdr subtree)))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + (s tree))) + +(defun subst-if (new test tree &key (key #'identity)) + "Substitutes new for subtrees for which test is true." + (labels ((s (subtree) + (cond ((funcall test (funcall key subtree)) new) + ((atom subtree) subtree) + (t (let ((car (s (car subtree))) + (cdr (s (cdr subtree)))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + (s tree))) + +(defun subst-if-not (new test tree &key (key #'identity)) + "Substitutes new for subtrees for which test is false." + (labels ((s (subtree) + (cond ((not (funcall test (funcall key subtree))) new) + ((atom subtree) subtree) + (t (let ((car (s (car subtree))) + (cdr (s (cdr subtree)))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + (s tree))) + +(defun nsubst (new old tree &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Substitutes new for subtrees matching old." + (labels ((s (subtree) + (cond ((satisfies-the-test old subtree) new) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (Cdr subtree))) + ((atom subtree) + (if (satisfies-the-test old subtree) + (setf (cdr last) new))) + (if (satisfies-the-test old subtree) + (return (setf (cdr last) new)) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree))) + +(defun nsubst-if (new test tree &key (key #'identity)) + "Substitutes new for subtrees of tree for which test is true." + (labels ((s (subtree) + (cond ((funcall test (funcall key subtree)) new) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (Cdr subtree))) + ((atom subtree) + (if (funcall test (funcall key subtree)) + (setf (cdr last) new))) + (if (funcall test (funcall key subtree)) + (return (setf (cdr last) new)) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree))) + +(defun nsubst-if-not (new test tree &key (key #'identity)) + "Substitutes new for subtrees of tree for which test is false." + (labels ((s (subtree) + (cond ((not (funcall test (funcall key subtree))) new) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (Cdr subtree))) + ((atom subtree) + (if (not (funcall test (funcall key subtree))) + (setf (cdr last) new))) + (if (not (funcall test (funcall key subtree))) + (return (setf (cdr last) new)) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree))) + + + + +(defun sublis (alist tree &key (key #'identity) + (test #'eql) (test-not nil notp)) + "Substitutes from alist into tree nondestructively." + (labels ((s (subtree) + (let ((assoc + (if notp + (assoc (funcall key subtree) alist :test-not test-not) + (assoc (funcall key subtree) alist :test test)))) + (cond (assoc (cdr assoc)) + ((atom subtree) subtree) + (t (let ((car (s (car subtree))) + (cdr (s (cdr subtree)))) + (if (and (eq car (car subtreE)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr)))))))) + (s tree))) + +;;; In run-time env, since can be referenced in line expansions. +(defmacro nsublis-macro () + '(if notp + (assoc (funcall key subtree) alist :test-not test-not) + (assoc (funcall key subtree) alist :test test))) + +(defun nsublis (alist tree &key (key #'identity) + (test #'eql) (test-not nil notp)) + "Substitutes new for subtrees matching old." + (let (temp) + (labels ((s (subtree) + (cond ((Setq temp (nsublis-macro)) + (cdr temp)) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (Cdr subtree))) + ((atom subtree) + (if (setq temp (nsublis-macro)) + (setf (cdr last) (cdr temp)))) + (if (setq temp (nsublis-macro)) + (return (setf (Cdr last) (Cdr temp))) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree)))) + + +;;; Functions for using lists as sets + +(defun member (item list &key (key #'identity) (test #'eql testp) + (test-not nil notp)) + "Returns tail of list beginning with first element satisfying EQLity, + :test, or :test-not with a given item." + (do ((list list (cdr list))) + ((null list) nil) + (let ((car (car list))) + (if (satisfies-the-test item car) + (return list))))) + +(defun member-if (test list &key (key #'identity)) + "Returns tail of list beginning with first element satisfying test(element)" + (unless (listp list) + (error "~S is not a list." list)) + (do ((list list (Cdr list))) + ((endp list) nil) + (if (funcall test (funcall key (car list))) + (return list)))) + +(defun member-if-not (test list &key (key #'identity)) + "Returns tail of list beginning with first element not satisfying test(el)" + (unless (listp list) + (error "~S is not a list." list)) + (do ((list list (cdr list))) + ((endp list) ()) + (if (not (funcall test (funcall key (car list)))) + (return list))))) + +(defun tailp (sublist list) + "Returns T if sublist is one of the cons'es in list" + (do ((x list (cdr x))) + ((endp x) '()) + (if (eq x sublist) (return T)))) + +(defun adjoin (item list &key (key #'identity) (test #'eql) (test-not nil notp)) + "Add item to list unless it is already a member" + (if (if notp (member (funcall key item) list :test-not test-not :key key) + (member (funcall key item) list :test test :key key)) + list + (cons item list))) + +(defun union (list1 list2 &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Returns the union of list1 and list2." + (if (and testp notp) + (error "Test and test-not both supplied.")) + (let ((res list1)) + (dolist (elt list2) + (if (not (with-set-keys (member (funcall key elt) list1))) + (push elt res))) + res)) + +;;; Destination and source are setf-able and many-evaluable. +;;; Sets the source to the cdr, and "conses" the 1st elt of source to destination. +(defmacro steve-splice (source destination) + `(let ((temp ,source)) + (setf ,source (Cdr ,source) + (cdr temp) ,destination + ,destination temp))) + +(Defun nunion (list1 list2 &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Destructively returns the union list1 and list2." + (if (and testp notp) + (error "Test and test-not both supplied.")) + (let ((res list1)) + (do () ((endp list2)) + (if (not (with-set-keys (member (funcall key (car list2)) list1))) + (steve-splice list2 res) + (Setq list2 (cdr list2)))) + res)) + + + + +(defun intersection (list1 list2 &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Returns the intersection of list1 and list2." + (if (and testp notp) + (error "Test and test-not both supplied.")) + (let ((res nil)) + (dolist (elt list1) + (if (with-set-keys (member (funcall key elt) list2)) + (push elt res))) + res)) + +(Defun nintersection (list1 list2 &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Destructively returns the intersection of list1 and list2." + (if (and testp notp) + (error "Test and test-not both supplied.")) + (let ((res nil)) + (do () ((endp list1)) + (if (with-set-keys (member (funcall key (car list1)) list2)) + (steve-splice list1 res) + (setq list1 (Cdr list1)))) + res)) + +(Defun set-difference (list1 list2 &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Returns the elements of list1 which are not in list2." + (if (and testp notp) + (error "Test and test-not both supplied.")) + (if (null list2) + list1 + (let ((res nil)) + (dolist (elt list1) + (if (not (with-set-keys (member (funcall key elt) list2))) + (push elt res))) + res))) + + +(Defun nset-difference (list1 list2 &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Destructively returns the elements of list1 which are not in list2." + (if (and testp notp) + (error "Test and test-not both supplied.")) + (let ((res nil)) + (do () ((endp list1)) + (if (not (with-set-keys (member (funcall key (car list1)) list2))) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + + +(defun set-exclusive-or (list1 list2 &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Returns new list of elements appearing exactly once in list1 and list2." + (let ((result nil)) + (dolist (elt list1) + (unless (with-set-keys (member (funcall key elt) list2)) + (setq result (cons elt result)))) + (dolist (elt list2) + (unless (with-set-keys (member (funcall key elt) list1)) + (setq result (cons elt result)))) + result)) + + +;;; The outer loop examines list1 while the inner loop examines list2. If an +;;; element is found in list2 "equal" to the element in list1, both are +;;; spliced out. When the end of list1 is reached, what is left of list2 is +;;; tacked onto what is left of list1. The splicing operation ensures that +;;; the correct operation is performed depending on whether splice is at the +;;; top of the list or not + +(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) + (key #'identity)) + "Destructively return a list with elements which appear but once in list1 + and list2." + (do ((x list1 (cdr x)) + (splicex ())) + ((endp x) + (if (null splicex) + (setq list1 list2) + (rplacd splicex list2)) + list1) + (do ((y list2 (cdr y)) + (splicey ())) + ((endp y) (setq splicex x)) + (cond ((if notp + (not (funcall test-not (funcall key (car x)) + (funcall key (Car y)))) + (funcall test (funcall key (car x)) (funcall key (Car y)))) + (if (null splicex) + (setq list1 (cdr x)) + (rplacd splicex (cdr x))) + (if (null splicey) + (setq list2 (cdr y)) + (rplacd splicey (cdr y))) + (return ())) ; assume lists are really sets + (t (setq splicey y))))))) + +(defun subsetp (list1 list2 &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Returns T if every element in list1 is also in list2." + (dolist (elt list1) + (unless (with-set-keys (member (funcall key elt) list2)) + (return-from subsetp nil))) + T) + + +;;; Functions that operate on association lists + +(defun acons (key datum alist) + "Construct a new alist by adding the pair (key . datum) to alist" + (cons (cons key datum) alist)) + +(defun pairlis (keys data &optional (alist '())) + "Construct an association list from keys and data (adding to alist)" + (do ((x keys (cdr x)) + (y data (cdr y))) + ((and (endp x) (endp y)) alist) + (if (or (endp x) (endp y)) + (error "The lists of keys and data are of unequal length.")) + (setq alist (acons (car x) (car y) alist)))) + + +;;; In run-time environment, since these guys can be inline expanded. +(defmacro assoc-guts (test-guy) + `(do ((alist alist (cdr alist))) + ((endp alist)) + (if (car alist) + (if ,test-guy (return (car alist)))))) + + +(defun assoc (item alist &key (key #'identity) test test-not) + "Returns the cons in alist whose car is equal (by a given test or EQL) to + the Item." + (cond (test (assoc-guts (funcall test item (funcall key (caar alist))))) + (test-not (assoc-guts (not (funcall test-not item (funcall key (caar alist)))))) + (t (assoc-guts (eql item (funcall key (caar alist))))))) + +(defun assoc-if (predicate alist) + "Returns the first cons in alist whose car satisfies the Predicate." + (assoc-guts (funcall predicate (caar alist)))) + +(defun assoc-if-not (predicate alist) + "Returns the first cons in alist whose car does not satisfy the Predicate." + (assoc-guts (not (funcall predicate (caar alist))))) + + +(defun rassoc (item alist &key (key #'identity) test test-not) + (declare (list alist)) + "Returns the cons in alist whose cdr is equal (by a given test or EQL) to + the Item." + (cond (test (assoc-guts (funcall test item (funcall key (cdar alist))))) + (test-not (assoc-guts (not (funcall test-not item (funcall key (cdar alist)))))) + (t (assoc-guts (eql item (funcall key (cdar alist))))))) + +(defun rassoc-if (predicate alist) + "Returns the cons in alist whose cdr satisfies the Predicate." + (assoc-guts (funcall predicate (cdar alist)))) + +(defun rassoc-if-not (predicate alist) + "Returns the first cons in alist whose cdr does not satisfy the Predicate." + (assoc-guts (not (funcall predicate (cdar alist))))) + +(defun map1 (function original-arglists accumulate take-car) + "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon. + It Maps function over the arglists in the appropriate way. It is done when any + of the arglists runs out. Until then, it CDRs down the arglists calling the + function and accumulating results as desired." + + (let* ((arglists (copy-list original-arglists)) + (ret-list (list nil)) + (temp ret-list)) + (do ((res nil) + (args '() '())) + ((dolist (x arglists nil) (if (null x) (return t))) + (if accumulate + (cdr ret-list) + (car original-arglists))) + (do ((l arglists (cdr l))) + ((null l)) + (push (if take-car (caar l) (car l)) args) + (setf (car l) (cdar l))) + (setq res (apply function (nreverse args))) + (case accumulate + (:nconc (setq temp (last (nconc temp res)))) + (:list (rplacd temp (list res)) + (setq temp (cdr temp))))))) + + +(defun mapc (function list &rest more-lists) + "Applies fn to successive elements of lists, returns its second argument." + (map1 function (cons list more-lists) nil t)) + +(defun mapcar (function list &rest more-lists) + "Applies fn to successive elements of list, returns list of results." + (map1 function (cons list more-lists) :list t)) + +(defun mapcan (function list &rest more-lists) + "Applies fn to successive elements of list, returns NCONC of results." + (map1 function (cons list more-lists) :nconc t)) + +(defun mapl (function list &rest more-lists) + "Applies fn to successive CDRs of list, returns ()." + (map1 function (cons list more-lists) nil nil)) + +(defun maplist (function list &rest more-lists) + "Applies fn to successive CDRs of list, returns list of results." + (map1 function (cons list more-lists) :list nil)) + +(defun mapcon (function list &rest more-lists) + "Applies fn to successive CDRs of lists, returns NCONC of results." + (map1 function (cons list more-lists) :nconc nil)) + + +;;; Functions for compatibility sake: + +(defun memq (item list) + "Returns tail of list beginning with first element eq to item" + (memq item list)) + +(defun assq (item alist) + "Return the first pair of alist where item EQ the key of pair" + (assq item alist)) + +(defun delq (item list &optional (n 0 np)) + (declare (fixnum n)) + "Returns list with all (up to n) elements with all elements EQ to ITEM + deleted" + (do ((x list (cdr x)) + (splice '())) + ((or (endp x) + (and np (zerop n))) list) + (cond ((eq item (car x)) + (setq n (1- n)) + (if (null splice) + (setq list (cdr x)) + (rplacd splice (cdr x)))) + (T (setq splice x))))) ; move splice along to include element diff --git a/code/load.lisp b/code/load.lisp new file mode 100644 index 000000000..2144e68dd --- /dev/null +++ b/code/load.lisp @@ -0,0 +1,1022 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Loader for Spice Lisp. +;;; Written by Skef Wholey and Rob MacLachlan. +;;; +(in-package "LISP") +(export '(load *load-verbose*)) + +(in-package "SYSTEM") +(export 'resolve-loaded-assembler-references) + +(in-package "EXTENSIONS") +(export '*load-if-source-newer*) + +(in-package "LISP") + + +;;;; Random state variables: + +(defvar *load-verbose* () + "The default for the :Verbose argument to Load.") +(defvar *load-print-stuff* () + "True if we're gonna mumble about what we're loading.") +(defvar *fasl-file* () "The fasl file we're reading from.") +(defvar *current-code-format* "The code format that we think we are loading.") + +(defvar *in-cold-load* nil) ; True if we are in the cold loader. + +(defvar *load-if-source-newer* :load-object + "The value of *load-if-source-newer* determines what happens when the + source file is newer than the object file. The possible values are: + :load-object - load object file (default), :load-source - load the source + file, :compile - compile the source and then load the object file, or + :query - ask the user if he wants to load the source or object file.") + +(proclaim '(special cold-fop-functions)) + +;;;; The Fop-Table: +;;; +;;; The table is implemented as a simple-vector indexed by the table +;;; offset. We may need to have several, since load can be called recursively. + +(defvar *free-fop-tables* (list (make-array 1000)) + "List of free fop tables for the fasloader.") + +(defvar *current-fop-table* () + "The current fop table.") + +(defvar *current-fop-table-size* () + "The length of the current fop table.") + +(defvar *current-fop-table-index* () + "Index in the fop-table of the next entry to be used.") + +(defun grow-fop-table () + (let* ((new-size (* *current-fop-table-size* 2)) + (new-table (make-array new-size))) + (declare (fixnum new-size) (simple-vector new-table)) + (replace new-table (the simple-vector *current-fop-table*)) + (setq *current-fop-table* new-table) + (setq *current-fop-table-size* new-size))) + +(defmacro push-table (thing) + (let ((n-index (gensym))) + `(let ((,n-index *current-fop-table-index*)) + (declare (fixnum ,n-index)) + (when (= ,n-index (the fixnum *current-fop-table-size*)) + (grow-fop-table)) + (setq *current-fop-table-index* (1+ ,n-index)) + (setf (svref *current-fop-table* ,n-index) ,thing)))) + +;;;; The Fop-Stack: +;;; +;;; The is also in a simple-vector, but it grows down, since it is somewhat +;;; cheaper to test for overflow that way. +;;; +(defvar *fop-stack* (make-array 100) + "The fop stack (we only need one!).") + +(defvar *fop-stack-pointer* 100 + "The index of the most recently pushed item on the fop-stack.") + +(defvar *fop-stack-pointer-on-entry* () + "The current index into the fop stack when we last recursively entered LOAD.") + + +(defun grow-fop-stack () + (let* ((size (length (the simple-vector *fop-stack*))) + (new-size (* size 2)) + (new-stack (make-array new-size))) + (declare (fixnum size new-size) (simple-vector new-stack)) + (replace new-stack (the simple-vector *fop-stack*) :start1 size) + (incf *fop-stack-pointer-on-entry* size) + (setq *fop-stack-pointer* size) + (setq *fop-stack* new-stack))) + +;;; With-Fop-Stack -- Internal +;;; +;;; Cache information about the fop-stack in local variables. Define +;;; a local macro to pop from the stack. Push the result of evaluation if +;;; specified. +;;; +(defmacro with-fop-stack (pushp &body forms) + (let ((n-stack (gensym)) + (n-index (gensym)) + (n-res (gensym))) + `(let ((,n-stack *fop-stack*) + (,n-index *fop-stack-pointer*)) + (declare (simple-vector ,n-stack) (fixnum ,n-index)) + (macrolet ((pop-stack () + `(prog1 + (svref ,',n-stack ,',n-index) + (setq ,',n-index (1+ ,',n-index)))) + (call-with-popped-things (fun n) + (let ((n-start (gensym))) + `(let ((,n-start (+ ,',n-index ,n))) + (setq ,',n-index ,n-start) + (,fun ,@(make-list n :initial-element + `(svref ,',n-stack + (decf ,n-start)))))))) + ,(if pushp + `(let ((,n-res (progn ,@forms))) + (when (zerop ,n-index) + (grow-fop-stack) + (setq ,n-index *fop-stack-pointer* + ,n-stack *fop-stack*)) + (decf ,n-index) + (setq *fop-stack-pointer* ,n-index) + (setf (svref ,n-stack ,n-index) ,n-res)) + `(prog1 + (progn ,@forms) + (setq *fop-stack-pointer* ,n-index))))))) + +;;; FOP database: + +(defvar fop-codes (make-array 256) + "Vector indexed by a FaslOP that yields the FOP's name.") + +(defvar fop-functions + (make-array 256 :initial-element #'(lambda () (error "Losing FOP!"))) + "Vector indexed by a FaslOP that yields a function of 0 arguments which + will perform the operation.") + + +;;; Define-FOP -- Internal +;;; +;;; Defines Name as a fasl operation, with op-code op. If pushp is :nope, +;;; the the body neither pushes or pops the fop stack. If it is nil, then +;;; the body may pop, but the result is ignored. If it is true, the the result +;;; is pushed on the stack. +;;; +(defmacro define-fop ((name op &optional (pushp t)) &rest forms) + `(progn + (defun ,name () + ,(if (eq pushp :nope) + `(progn ,@forms) + `(with-fop-stack ,pushp ,@forms))) + (setf (svref fop-codes ,op) ',name) + (setf (get ',name 'fop-code) ,op) + (setf (svref fop-functions ,op) #',name))) + +;;; Clone-Fop -- Internal +;;; +;;; Defines a pair of fops which are identical except in that one reads +;;; a four byte argument and the other reads a one byte argument. The +;;; argument can be accessed by using the Clone-Arg macro. +;;; +(defmacro clone-fop ((name op &optional (pushp t)) + (small-name small-op) &rest forms) + `(progn + (macrolet ((clone-arg () '(read-arg 4))) + (define-fop (,name ,op ,pushp) ,@forms)) + (macrolet ((clone-arg () '(read-arg 1))) + (define-fop (,small-name ,small-op ,pushp) ,@forms)))) + +;;;; Utilities for reading from the fasl file. + +(proclaim '(inline read-byte)) + +;;; Fast-Read-U-Integer -- Internal +;;; +;;; Expands into code to read an N-byte unsigned integer using +;;; fast-read-byte. +;;; +(defmacro fast-read-u-integer (n) + (do ((res '(fast-read-byte) + `(logior (fast-read-byte) + (ash ,res 8))) + (cnt 1 (1+ cnt))) + ((>= cnt n) res))) + +;;; Fast-Read-Variable-U-Integer -- Internal +;;; +;;; Like Fast-Read-U-Integer, but the size may be determined at run time. +;;; +(defmacro fast-read-variable-u-integer (n) + (let ((n-pos (gensym)) + (n-res (gensym)) + (n-cnt (gensym))) + `(do ((,n-pos 8 (+ ,n-pos 8)) + (,n-cnt (1- ,n) (1- ,n-cnt)) + (,n-res + (fast-read-byte) + (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res))) + ((zerop ,n-cnt) ,n-res)))) + +;;; Fast-Read-S-Integer -- Internal +;;; +;;; Read a signed integer. +;;; +(defmacro fast-read-s-integer (n) + (let ((n-last (gensym))) + (do ((res `(let ((,n-last (fast-read-byte))) + (if (zerop (logand ,n-last #x80)) + ,n-last + (logior ,n-last #x-100))) + `(logior (fast-read-byte) + (ash ,res 8))) + (cnt 1 (1+ cnt))) + ((>= cnt n) res)))) + +;;; Read-Arg -- Internal +;;; +;;; Read an N-byte unsigned integer from the *fasl-file* +;;; +(defmacro read-arg (n) + (if (= n 1) + `(read-byte *fasl-file*) + `(prepare-for-fast-read-byte *fasl-file* + (prog1 + (fast-read-u-integer ,n) + (done-with-fast-read-byte))))) + +;;; Fasload: + +(defun fasload (stream) + (when *load-verbose* + (format t "~&; Loading stuff from ~S.~%" stream)) + (let* ((*fasl-file* stream) + (*current-fop-table* (pop *free-fop-tables*)) + (*current-fop-table-size* ()) + (*current-fop-table-index* 0) + (*fop-stack-pointer-on-entry* *fop-stack-pointer*)) + (if (null *current-fop-table*) + (setq *current-fop-table* (make-array 1000))) + (setq *current-fop-table-size* + (length (the simple-vector *current-fop-table*))) + (unwind-protect + (do ((loaded-group (load-group stream) (load-group stream))) + ((not loaded-group))) + (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*) + ;; + ;; Nil out the table, so we don't hold onto garbage. + (let ((tab *current-fop-table*)) + (dotimes (i *current-fop-table-index*) + (declare (fixnum i)) + (setf (svref tab i) nil)) + (push tab *free-fop-tables*)) + ;; + ;; Ditto for the stack... + (dotimes (i *fop-stack-pointer-on-entry*) + (declare (fixnum i)) + (setf (svref *fop-stack* i) nil)))) + t) + +#| + +(defvar *fop-counts* (make-array 256 :initial-element 0)) +(defvar *fop-times* (make-array 256 :initial-element 0)) +(defvar *print-fops* nil) + +(defun clear-counts () + (fill (the simple-vector *fop-counts*) 0) + (fill (the simple-vector *fop-times*) 0) + t) + +(defun analyze-counts () + (let ((counts ()) + (total-count 0) + (times ()) + (total-time 0)) + (macrolet ((breakdown (lvar tvar vec) + `(progn + (dotimes (i 255) + (declare (fixnum i)) + (let ((n (svref ,vec i))) + (push (cons (svref fop-codes i) n) ,lvar) + (incf ,tvar n))) + (setq ,lvar (subseq (sort ,lvar #'(lambda (x y) + (> (cdr x) (cdr y)))) + 0 10))))) + + (breakdown counts total-count *fop-counts*) + (breakdown times total-time *fop-times*) + (format t "Total fop count is ~D~%" total-count) + (dolist (c counts) + (format t "~30S: ~4D~%" (car c) (cdr c))) + (format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0)) + (dolist (m times) + (format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0)))))) +|# + +;;; Load-Group -- Internal +;;; +;;; Load-Group returns t if it successfully loads a group from the file, +;;; or () if EOF was encountered while trying to read from the file. +;;; Dispatch to the right function for each fop. Special-case fop-byte-push +;;; since it is real common. +;;; +(defun load-group (file) + (when (check-header file) + (catch 'group-end + (let ((*current-code-format* 'uninitialized-code-format)) + (loop + (let ((byte (read-byte file))) + (if (eql byte 3) + (let ((index *fop-stack-pointer*)) + (when (zerop index) + (grow-fop-stack) + (setq index *fop-stack-pointer*)) + (decf index) + (setq *fop-stack-pointer* index) + (setf (svref *fop-stack* index) + (svref *current-fop-table* (read-byte file)))) + (funcall (svref fop-functions byte))))))))) + +;;; Check-Header returns t if t succesfully read a header from the file, +;;; or () if EOF was hit before anything was read. An error is signaled +;;; if garbage is encountered. + +(defun check-header (file) + (let ((byte (read-byte file NIL '*eof*))) + (cond ((eq byte '*eof*) ()) + ((eq byte (char-int #\F)) + (do ((byte (read-byte file) (read-byte file)) + (count 1 (1+ count))) + ((= byte 255) t) + (declare (fixnum byte)) + (if (and (< count 9) + (not (eql byte (char-int (schar "FASL FILE" count))))) + (error "Bad FASL file format.")))) + (t (error "Bad FASL file format."))))) + + +;;; Load-S-Integer loads a signed integer Length bytes long from the File. + +(defun load-s-integer (length) + (declare (fixnum length)) + (do* ((index length (1- index)) + (byte 0 (read-byte *fasl-file*)) + (result 0 (+ result (ash byte bits))) + (bits 0 (+ bits 8))) + ((= index 0) + (if (logbitp 7 byte) ; look at sign bit + (- result (ash 1 bits)) + result)) + (declare (fixnum index byte bits)))) + +;;; Sloload: + +;;; Something not EQ to anything read from a file: + +(defconstant load-eof-value '(())) + +;;; Sloload loads a text file into the given Load-Package. + +(defun sloload (stream) + (when *load-verbose* + (format t "~&; Loading stuff from ~S.~%" stream)) + (do ((sexpr (read stream nil load-eof-value) + (read stream nil load-eof-value))) + ((eq sexpr load-eof-value)) + (if *load-print-stuff* + (format t "~&; ~S~%" (eval sexpr)) + (eval sexpr)))))) + +;;; Load: + +(defun load (filename &key ((:verbose *load-verbose*) *load-verbose*) + ((:print *load-print-stuff*) *load-print-stuff*) + (if-does-not-exist :error)) + "Loads the file named by Filename into the Lisp environment. See manual + for details." + (let ((*package* *package*)) + (if (streamp filename) + (if (equal (stream-element-type filename) '(unsigned-byte 8)) + (fasload filename) + (sloload filename)) + (let* ((pn (merge-pathnames (pathname filename) + *default-pathname-defaults*)) + (tn (probe-file pn))) + (cond + (tn + (if (string-equal (pathname-type tn) "nfasl") + (with-open-file (file tn + :direction :input + :element-type '(unsigned-byte 8)) + (fasload file)) + (with-open-file (file tn :direction :input) + (sloload file))) + t) + ((pathname-type pn) + (let ((stream (open pn :direction :input + :if-does-not-exist if-does-not-exist))) + (when stream + (sloload stream) + (close stream) + t))) + (t + (let* ((srcn (make-pathname :type "lisp" :defaults pn)) + (src (probe-file srcn)) + (objn (make-pathname :type "nfasl" :defaults pn)) + (obj (probe-file objn))) + (cond + (obj + (cond ((and src (> (file-write-date src) + (file-write-date obj))) + (case *load-if-source-newer* + (:load-object + (warn "Loading object file ~A, which is~% ~ + older than the presumed source, ~A." + (namestring obj) + (namestring src)) + (load obj)) + (:load-source + (warn "Loading source file ~A, which is~% ~ + newer than the presumed object file, ~A." + (namestring src) + (namestring obj)) + (load src)) + (:compile + (compile-file (namestring src)) + (load obj)) + (:query + (if (y-or-n-p "Load source file ~A which is newer~% ~ + than presumed object file ~A? " + (namestring src) + (namestring obj)) + (load src) + (load obj))) + (T (error "*Load-if-source-newer* contains ~A which is not one of:~% ~ + :load-object, :load-source, :compile, or :query." + *load-if-source-newer*)))) + (T (load obj)))) + (t + (load srcn :if-does-not-exist if-does-not-exist)))))))))) + + +;;;; Actual FOP definitions: + +(define-fop (fop-nop 0 :nope)) +(define-fop (fop-pop 1 nil) (push-table (pop-stack))) +(define-fop (fop-pop-for-effect 65 nil) (pop-stack)) +(define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4))) +(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1))) + +(define-fop (fop-empty-list 4) ()) +(define-fop (fop-truth 5) t) +(define-fop (fop-misc-trap 66) + (%primitive make-immediate-type 0 lisp::%trap-type)) + +(define-fop (fop-character 68) + (int-char (read-arg 3))) +(define-fop (fop-short-character 69) + (code-char (read-arg 1))) + +(define-fop (fop-structure 79) + (%primitive set-vector-subtype (pop-stack) 1)) + +(define-fop (fop-end-group 64 :nope) (throw 'group-end t)) +(define-fop (fop-end-header 255) + (error "Fop-End-Header was executed???")) + +(define-fop (fop-normal-load 81 :nope)) +(define-fop (fop-maybe-cold-load 82 :nope) + (when *in-cold-load* + (setq fop-functions cold-fop-functions))) + +(define-fop (fop-static-heap 60 :nope)) +(define-fop (fop-dynamic-heap 61 :nope)) +(define-fop (fop-read-only-heap 67 :nope)) + +(define-fop (fop-verify-table-size 62 :nope) + (if (/= *current-fop-table-index* (read-arg 4)) + (error "Fasl table of improper size. Bug!"))) +(define-fop (fop-verify-empty-stack 63 :nope) + (if (/= *fop-stack-pointer* *fop-stack-pointer-on-entry*) + (error "Fasl stack not empty. Bug!"))) + +;;;; Loading symbols: + +(defvar *load-symbol-buffer* (make-string 100)) +(defvar *load-symbol-buffer-size* 100) + +(macrolet ((frob (name code name-size package) + (let ((n-package (gensym)) + (n-size (gensym)) + (n-buffer (gensym))) + `(define-fop (,name ,code) + (prepare-for-fast-read-byte *fasl-file* + (let ((,n-package ,package) + (,n-size (fast-read-u-integer ,name-size))) + (when (> ,n-size *load-symbol-buffer-size*) + (setq *load-symbol-buffer* + (make-string (setq *load-symbol-buffer-size* + (* ,n-size 2))))) + (done-with-fast-read-byte) + (let ((,n-buffer *load-symbol-buffer*)) + (read-n-bytes *fasl-file* ,n-buffer 0 ,n-size) + (push-table (intern* ,n-buffer ,n-size ,n-package))))))))) + (frob fop-symbol-save 6 4 *package*) + (frob fop-small-symbol-save 7 1 *package*) + (frob fop-lisp-symbol-save 75 4 *lisp-package*) + (frob fop-lisp-small-symbol-save 76 1 *lisp-package*) + (frob fop-keyword-symbol-save 77 4 *keyword-package*) + (frob fop-keyword-small-symbol-save 78 1 *keyword-package*) + + (frob fop-symbol-in-package-save 8 4 + (svref *current-fop-table* (fast-read-u-integer 4))) + (frob fop-small-symbol-in-package-save 9 1 + (svref *current-fop-table* (fast-read-u-integer 4))) + (frob fop-symbol-in-byte-package-save 10 4 + (svref *current-fop-table* (fast-read-u-integer 1))) + (frob fop-small-symbol-in-byte-package-save 11 1 + (svref *current-fop-table* (fast-read-u-integer 1)))) + +(clone-fop (fop-uninterned-symbol-save 12) + (fop-uninterned-small-symbol-save 13) + (let* ((arg (clone-arg)) + (res (make-string arg))) + (read-n-bytes *fasl-file* res 0 arg) + (push-table (make-symbol res)))) + +(define-fop (fop-package 14) + (let ((name (pop-stack))) + (or (find-package name) + (error "The package ~S does not exist." name)))) + +;;;; Loading numbers: + +(clone-fop (fop-integer 33) + (fop-small-integer 34) + (load-s-integer (clone-arg))) + +(define-fop (fop-word-integer 35) + (prepare-for-fast-read-byte *fasl-file* + (prog1 + (fast-read-s-integer 4) + (done-with-fast-read-byte)))) +(define-fop (fop-byte-integer 36) + (prepare-for-fast-read-byte *fasl-file* + (prog1 + (fast-read-s-integer 1) + (done-with-fast-read-byte)))) + +(define-fop (fop-ratio 70) + (let ((den (pop-stack))) + (%primitive make-ratio (pop-stack) den))) + +(define-fop (fop-complex 71) + (let ((im (pop-stack))) + (%primitive make-complex (pop-stack) im))) + +(define-fop (fop-float 45) + (let* ((n (read-arg 1)) + (exponent (load-s-integer (ceiling n 8))) + (m (read-arg 1)) + (mantissa (load-s-integer (ceiling m 8))) + (number (cond ((or (> n 9) (> m 32)) + (coerce mantissa 'long-float)) + ((> m 21) + (coerce mantissa 'single-float)) + (T (coerce mantissa 'short-float))))) + (multiple-value-bind (f ex s) (decode-float number) + (declare (ignore ex)) + (* s (scale-float f exponent))))) + +;;;; Loading lists: + +(define-fop (fop-list 15) + (do ((res () (cons (pop-stack) res)) + (n (read-arg 1) (1- n))) + ((zerop n) res))) + +(define-fop (fop-list* 16) + (do ((res (pop-stack) (cons (pop-stack) res)) + (n (read-arg 1) (1- n))) + ((zerop n) res))) + +(macrolet ((frob (name op fun n) + `(define-fop (,name ,op) + (call-with-popped-things ,fun ,n)))) + + (frob fop-list-1 17 list 1) + (frob fop-list-2 18 list 2) + (frob fop-list-3 19 list 3) + (frob fop-list-4 20 list 4) + (frob fop-list-5 21 list 5) + (frob fop-list-6 22 list 6) + (frob fop-list-7 23 list 7) + (frob fop-list-8 24 list 8) + + (frob fop-list*-1 25 list* 2) + (frob fop-list*-2 26 list* 3) + (frob fop-list*-3 27 list* 4) + (frob fop-list*-4 28 list* 5) + (frob fop-list*-5 29 list* 6) + (frob fop-list*-6 30 list* 7) + (frob fop-list*-7 31 list* 8) + (frob fop-list*-8 32 list* 9)) + + +;;;; Loading arrays: +;;; + +(clone-fop (fop-string 37) + (fop-small-string 38) + (let* ((arg (clone-arg)) + (res (make-string arg))) + (read-n-bytes *fasl-file* res 0 arg) + res)) + +(clone-fop (fop-vector 39) + (fop-small-vector 40) + (let* ((size (clone-arg)) + (res (make-array size))) + (declare (fixnum size)) + (do ((n (1- size) (1- n))) + ((minusp n)) + (setf (svref res n) (pop-stack))) + res)) + +(clone-fop (fop-uniform-vector 41) + (fop-small-uniform-vector 42) + (make-array (clone-arg) :initial-element (pop-stack))) + +(define-fop (fop-array 83) + (let* ((rank (read-arg 4)) + (vec (pop-stack)) + (size (+ rank %array-first-dim-slot)) + (length (length vec)) + (res (%primitive alloc-array rank))) + (declare (simple-array vec)) + (set-array-header res vec length length 0 + (do ((i (1- size) (1- i)) + (dimensions () (cons (pop-stack) dimensions))) + ((< i %array-first-dim-slot) dimensions)) + nil) + res)) + + +;;; Fop-Int-Vector -- Internal +;;; +;;; Load an I-Vector using the Guy Steele memorial faslop. If there +;;; is no space at the end of a group, then we can read it using +;;; Read-N-Bytes. All vectors dumped by our compiler should be loadable +;;; in this way. If the other cases don't work, we may never know... +;;; +(define-fop (fop-int-vector 43) + (prepare-for-fast-read-byte *fasl-file* + (let* ((n (fast-read-u-integer 4)) + (size (fast-read-byte)) + (count (fast-read-byte)) + (res (make-array n :element-type `(unsigned-byte ,size)))) + (multiple-value-bind (ints-per-entry extra) + (truncate (* count 8) size) + (cond ((and (zerop extra) (<= size 16)) + (done-with-fast-read-byte) + (read-n-bytes *fasl-file* res 0 + (* count (ceiling n ints-per-entry)))) + ((= ints-per-entry 1) + (dotimes (i n) + (setf (aref res i) (fast-read-variable-u-integer count))) + (done-with-fast-read-byte)) + (t + (let ((i 0)) + (loop + (when (= i n) (return)) + (let ((byte (fast-read-byte))) + (dotimes (j ints-per-entry) + (setf (aref res i) (ldb (byte size (* size j)) byte)) + (incf i) + (when (= i n) (return)))))) + (done-with-fast-read-byte)))) + res))) + +(define-fop (fop-uniform-int-vector 44) + (prepare-for-fast-read-byte *fasl-file* + (let* ((n (fast-read-u-integer 4)) + (size (fast-read-byte)) + (value (fast-read-variable-u-integer (ceiling size 8)))) + (done-with-fast-read-byte) + (make-array n :element-type `(unsigned-byte ,size) + :initial-element value)))) + +(define-fop (fop-alter 52 nil) + (let ((index (read-arg 1)) + (newval (pop-stack)) + (object (pop-stack))) + (declare (fixnum index)) + (typecase object + (list (case index + (0 (rplaca object newval)) + (1 (rplacd object newval)) + (t (error "~S: Bad index for FaslOP Alter. Bug!")))) + (symbol (case index + (0 (set object newval)) + (1 (setf (symbol-function object) newval)) + (2 (setf (symbol-plist object) newval)) + (t (error "~S: Bad index for FaslOP Alter. Bug!")))) + (array (setf (aref object index) newval)) + (t (error "~S: Bad object for FaslOP Alter. Bug!"))))) + +(define-fop (fop-eval 53) + (let ((result (eval (pop-stack)))) + (when *load-print-stuff* + (format t "~&; ~S~%" result)) + result)) + +(define-fop (fop-eval-for-effect 54 nil) + (let ((result (eval (pop-stack)))) + (when *load-print-stuff* + (format t "~&; ~S~%" result)))) + +(define-fop (fop-funcall 55) + (let ((arg (read-arg 1))) + (if (zerop arg) + (funcall (pop-stack)) + (do ((args () (cons (pop-stack) args)) + (n arg (1- n))) + ((zerop n) (apply (pop-stack) args)))))) + +(define-fop (fop-funcall-for-effect 56 nil) + (let ((arg (read-arg 1))) + (if (zerop arg) + (funcall (pop-stack)) + (do ((args () (cons (pop-stack) args)) + (n arg (1- n))) + ((zerop n) (apply (pop-stack) args)))))) + +;;;; Fixing up circularities. +(define-fop (fop-rplaca 200 nil) + (let ((obj (svref *current-fop-table* (read-arg 4))) + (idx (read-arg 4)) + (val (pop-stack))) + (setf (car (nthcdr idx obj)) val))) + + +(define-fop (fop-rplacd 201 nil) + (let ((obj (svref *current-fop-table* (read-arg 4))) + (idx (read-arg 4)) + (val (pop-stack))) + (setf (cdr (nthcdr idx obj)) val))) + +(define-fop (fop-svset 202 nil) + (let* ((obi (read-arg 4)) + (obj (svref *current-fop-table* obi)) + (idx (read-arg 4)) + (val (pop-stack))) + (setf (svref obj idx) val))) + +(define-fop (fop-nthcdr 203 t) + (nthcdr (read-arg 4) (pop-stack))) + +;;;; Loading functions: + +(define-fop (fop-code-format 57 :nope) + (setq *current-code-format* (read-arg 1))) + + +;;; Load-Code loads a code object. NItems objects are popped off the stack for +;;; the boxed storage section, then Size bytes of code are read in. This must +;;; be done WITHOUT-GCING, since GC only recognizes code object references that +;;; appear in a function object. If a GC happened before we stored the code +;;; object, the code would disappear. +;;; +(defmacro load-code (nitems size) + `(without-gcing + (let ((box-num ,nitems) + (code-length ,size)) + (declare (fixnum box-num code-length)) + (let ((function (%primitive alloc-function box-num))) + (%primitive set-vector-subtype function %function-constants-subtype) + (do ((index (1- box-num) (1- index))) + ((minusp index)) + (declare (fixnum index)) + (%primitive header-set function index (pop-stack))) + (let ((code (%primitive alloc-code code-length))) + (read-n-bytes *fasl-file* code 0 code-length) + (%primitive header-set function %function-code-slot code)) + (when *load-print-stuff* + (format t "~&; ~S~%" function)) + function)))) + +(define-fop (fop-code 58) + (if (eql *current-code-format* %fasl-code-format) + (load-code (read-arg 4) (read-arg 4)) + (error "~A has an incompatible fasl file format.~@ + You must recompile the source code." + *fasl-file*))) + + +(define-fop (fop-small-code 59) + (if (eql *current-code-format* %fasl-code-format) + (load-code (read-arg 1) (read-arg 2)) + (error "~A has an incompatible fasl file format.~@ + You must recompile the source code." + *fasl-file*))) + + +;;; Now a NOOP except in cold load... +(define-fop (fop-fset 74 nil) + (pop-stack) + (pop-stack)) + + +;;; Modify a slot in a Constants object. +;;; +(clone-fop (fop-alter-code 140 nil) (fop-byte-alter-code 141) + (let ((value (pop-stack)) + (code (pop-stack)) + (index (clone-arg))) + (%primitive header-set code index value))) + + +;;; Kind of like Load-Code, except that we set the Code and Constants +;;; slots from the Constants object that is our first stack argument. The +;;; subtype is set to the second stack argument. +;;; +(define-fop (fop-function-entry 142) + (let* ((box-num (read-arg 1)) + (function (%primitive alloc-function box-num))) + ;; + ;; Pop boxed things, storing them in the allocated entry object. + (do ((index (1- box-num) (1- index))) + ((minusp index)) + (%primitive header-set function index (pop-stack))) + ;; + ;; Set the subtype of the entry object. + (%primitive set-vector-subtype function (pop-stack)) + ;; + ;; Set code and constants slots in the entry. + (let* ((constants (pop-stack)) + (code (%primitive header-ref constants %function-code-slot))) + (%primitive header-set function %function-code-slot code) + (%primitive header-set function %function-entry-constants-slot + constants)) + + function)) + + + +(define-fop (fop-user-miscop-fixup 134) + (let* ((miscop-name (pop-stack)) + (function-object (pop-stack)) + (code (%primitive header-ref function-object %function-code-slot)) + (offset (read-arg 4)) + (loaded-addr (get miscop-name '%loaded-address))) + (unless loaded-addr + (error "Miscop ~A is undefined." miscop-name)) + + (let ((hi-addr (logior (ash clc::type-assembler-code + clc::type-shift-16) + (logand (ash loaded-addr -16) #xFFFF)))) + (setf (aref code (+ offset 1)) (logand hi-addr #xFF)) + (setf (aref code (+ offset 2)) + (logand (ash loaded-addr -8) #xFF)) + (setf (aref code (+ offset 3)) + (logand loaded-addr #xFF))) + + function-object)) + + +;;;; Loading assembler routines: +;;; + +;;; Allocate-Assembler-Code -- Internal +;;; +;;; Allocate some stuff out of assembler code space. +;;; +(defun allocate-assembler-code (bytes) + (let* ((idx (ash %assembler-code-type %alloc-ref-type-shift)) + (free (alloc-ref idx)) + (new (+ free bytes))) + (prog1 + (%primitive make-immediate-type free %assembler-code-type) + (%primitive 16bit-system-set alloctable-address idx (ash new -16)) + (%primitive 16bit-system-set alloctable-address (1+ idx) + (logand new #xFFFF))))) + +(define-fop (fop-assembler-routine 130) + (let* ((code-length (read-arg 4)) + (buffer (make-array code-length :element-type '(unsigned-byte 8))) + (code (allocate-assembler-code code-length))) + (declare (fixnum code-length)) + (read-n-bytes *fasl-file* buffer 0 code-length) + (%primitive byte-blt buffer 0 code 0 code-length) + code)) + +;;; A list of the miscop definitions which have been loaded but not +;;; resolved. Each element is a cons (name . code-ptr). +;;; +(defvar *miscop-definitions* ()) + + +;;; Recall that the format of a reference is (How Label Location), +;;; where How is one of JI, BI, BA, or L, Label is the label's name, and +;;; Location is the location of the reference. These things are stored on +;;; the list *external-references* as (Name . References), where Name is +;;; the name of the referencing routine, and References is a list of references +;;; in the above format. +;;; +(defvar *external-references* ()) +(defvar *user-defined-miscops* ()) + +(define-fop (fop-fixup-miscop-routine 131 nil) + (let* ((external-references (pop-stack)) + (external-labels (pop-stack)) + (name (pop-stack)) + (code (pop-stack)) + (start (%primitive make-immediate-type code %+-fixnum-type))) + (dolist (lab external-labels) + (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start))) + (push (cons name external-references) *external-references*) + (push (cons name code) *miscop-definitions*))) + +(define-fop (fop-fixup-user-miscop-routine 133 nil) + (let* ((external-references (pop-stack)) + (external-labels (pop-stack)) + (name (pop-stack)) + (code (pop-stack)) + (start (%primitive make-immediate-type code %+-fixnum-type))) + (dolist (lab external-labels) + (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start))) + (push (cons name external-references) *external-references*) + (pushnew name *user-defined-miscops*) + (setf (get name 'user-miscop) t))) + +(define-fop (fop-fixup-assembler-routine 132 nil) + (let* ((external-references (pop-stack)) + (external-labels (pop-stack)) + (name (pop-stack)) + (code (pop-stack)) + (start (%primitive make-immediate-type code %+-fixnum-type))) + (dolist (lab external-labels) + (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start))) + (push (cons name external-references) *external-references*))) + +;;; Resolving all the assembler routines' references. + +;;; Patch-Instruction -- Internal +;;; +;;; Used to patch an assembler code object. Hi-var and lo-var are +;;; bound to the values of the high and low halfwords in the instruction. +;;; The values may by changed by setting the variables. +;;; +(defmacro patch-instruction ((hi-var lo-var code offset) &body body) + `(let ((,hi-var (%primitive 16bit-system-ref ,code ,offset)) + (,lo-var (%primitive 16bit-system-ref ,code (1+ ,offset)))) + (multiple-value-prog1 + (progn ,@body) + (%primitive 16bit-system-set ,code ,offset ,hi-var) + (%primitive 16bit-system-set ,code (1+ ,offset) ,lo-var)))) + +;;; Resolve-Loaded-Assembler-References -- Public +;;; +;;; Fix up the recorded external references and define the miscops. +;;; +(defun resolve-loaded-assembler-references () + "This function resolves external label references in loaded assembler + routines. It should be called after assembler files have been loaded. + Miscop definitions do not take effect until this function is called." + (dolist (reflist *external-references*) + (let* ((code-byte-offset (get (car reflist) '%loaded-address)) + (code-halfword-offset (ash code-byte-offset -1)) + (address (%primitive make-immediate-type code-byte-offset + %assembler-code-type))) + (dolist (refs (cdr reflist)) + (let ((how (car refs)) + (label (get (cadr refs) '%loaded-address)) + (location (caddr refs))) + (unless label + (error "~A references ~A, which has not been defined.~%" + (car reflist) (cadr refs))) + (let ((offset (- (- (ash label -1) code-halfword-offset) location))) + (ecase how + (clc::ji + (unless (<= #x-80 offset #x7F) + (error "Offset #X~X out of JI range for ~A to reference ~A.~%" + offset (car reflist) (cadr refs))) + (patch-instruction (hi lo address location) + (setf (ldb (byte 8 0) hi) offset))) + (clc::bi + (unless (<= #x-80000 offset #x7FFFF) + (error "Offset #X~X out of BI range for ~A to reference ~A.~%" + offset (car reflist) (cadr refs))) + (patch-instruction (hi lo address location) + (setf (ldb (byte 4 0) hi) (ash offset -16)) + (setq lo (logand offset #xFFFF)))) + (clc::ba (error "I can't resolve a BA reference yet.~%")) + (clc::l (error "I can't resolve an L reference yet.~%")))))))) + (setq *external-references* ()) + + (dolist (mo *miscop-definitions*) + (let* ((name (intern (symbol-name (car mo)) (find-package "COMPILER"))) + (index (get name 'clc::transfer-vector-index))) + (if index + (%primitive write-control-stack + (%primitive make-immediate-type (ash index 2) + %assembler-code-type) + (cdr mo)) + (pushnew name *user-defined-miscops*)))) + (setq *miscop-definitions* ())) + +(proclaim '(notinline read-byte)) diff --git a/code/machdef.lisp b/code/machdef.lisp new file mode 100644 index 000000000..0dce05382 --- /dev/null +++ b/code/machdef.lisp @@ -0,0 +1,106 @@ +;;; -*- Log: code.log; Package: Mach -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Record definitions needed for the interface to Mach. +;;; +(in-package 'mach) +(export '(msg-simplemsg msg-msgsize msg-msgtype msg-localport msg-remoteport + msg-id sigmask with-trap-arg-block)) + +(defrecord Msg + (Reserved1 (unsigned-byte 8) 8) + (Reserved2 (unsigned-byte 8) 8) + (Reserved3 (unsigned-byte 8) 8) + (Reserved4 (unsigned-byte 7) 7) + (SimpleMsg boolean 1) + (MsgSize (signed-byte 32) 32) + (MsgType (signed-byte 32) 32) + (LocalPort port 32) + (RemotePort port 32) + (ID (signed-byte 32) 32)) + +(defrecord timeval + (seconds (unsigned-byte 32) (long-words 1)) + (useconds (signed-byte 32) (long-words 1))) + +(defalien timeval timeval (record-size 'timeval)) + +(defrecord timezone + (minuteswest (signed-byte 32) (long-words 1)) + (dsttime (signed-byte 32) (long-words 1))) + +(defalien timezone timezone (record-size 'timezone)) + +(eval-when (compile load eval) +(defrecord int1 + (int (signed-byte 32) (long-words 1))) + +(defalien int1 int1 (record-size 'int1)) + +(defrecord int2 + (int (signed-byte 32) (long-words 1))) + +(defalien int2 int2 (record-size 'int2)) + +(defrecord int3 + (int (signed-byte 32) (long-words 1))) + +(defalien int3 int3 (record-size 'int3)) + +(defrecord sigcontext + (onstack (unsigned-byte 32) (long-words 1)) + (mask (unsigned-byte 32) (long-words 1)) + (sctx-fpa (unsgined-byte 32) (long-words 1)) + (sp (unsigned-byte 32) (long-words 1)) + (fp (unsigned-byte 32) (long-words 1)) + (ap (unsigned-byte 32) (long-words 1)) + (iar (unsigned-byte 32) (long-words 1)) + (icscs (unsigned-byte 32) (long-words 1))) +(defalien sigcontext sigcontext (record-size 'sigcontext)) + + +(defrecord tchars + (intrc (signed-byte 8) (bytes 1)) + (quitc (signed-byte 8) (bytes 1)) + (startc (signed-byte 8) (bytes 1)) + (stopc (signed-byte 8) (bytes 1)) + (eofc (signed-byte 8) (bytes 1)) + (brkc (signed-byte 8) (bytes 1))) +(defalien tchars tchars (record-size 'tchars)) + +(defrecord ltchars + (suspc (signed-byte 8) (bytes 1)) + (dsuspc (signed-byte 8) (bytes 1)) + (rprntc (signed-byte 8) (bytes 1)) + (flushc (signed-byte 8) (bytes 1)) + (werasc (signed-byte 8) (bytes 1)) + (lnextc (signed-byte 8) (bytes 1))) +(defalien ltchars ltchars (record-size 'ltchars)) + +); eval-when (compile load eval) + + +#-new-compiler +(eval-when (compile) + (setq lisp::*bootstrap-defmacro* t)) + +(defmacro sigmask (signal) + "Returns a mask given a signal." + `(ash 1 (1- ,signal))) + + +(defmacro with-trap-arg-block (arg-var alien-var &body forms) + `(progn (unless *free-trap-arg-blocks* (alloc-trap-arg-block)) + (let ((*free-trap-arg-blocks* (cdr *free-trap-arg-blocks*)) + (,arg-var (car *free-trap-arg-blocks*))) + (alien-bind ((,alien-var ,arg-var ,arg-var T)) + ,@forms)))) +#-new-compiler +(eval-when (compile) + (setq lisp::*bootstrap-defmacro* nil)) diff --git a/code/macros.lisp b/code/macros.lisp new file mode 100644 index 000000000..efe5ed697 --- /dev/null +++ b/code/macros.lisp @@ -0,0 +1,1532 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains the macros that are part of the standard +;;; Spice Lisp environment. +;;; +;;; Written by Scott Fahlman and Rob MacLachlan. +;;; Modified by Bill Chiles to adhere to +;;; +(in-package 'lisp) +(export '(defvar defparameter defconstant when unless loop setf + defsetf define-setf-method psetf shiftf rotatef push pushnew pop + incf decf remf case typecase with-open-file + with-open-stream with-input-from-string with-output-to-string + locally etypecase ctypecase ecase ccase + get-setf-method get-setf-method-multiple-value + define-modify-macro + otherwise)) ; Sacred to CASE and related macros. + +(in-package "EXTENSIONS") +(export '(do-anonymous collect iterate)) + +(in-package "LISP") + + +;;; Parse-Body -- Public +;;; +;;; Parse out declarations and doc strings, *not* expanding macros. +;;; Eventually the environment arg should be flushed, since macros can't expand +;;; into declarations anymore. +;;; +(defun parse-body (body environment &optional (doc-string-allowed t)) + "This function is to parse the declarations and doc-string out of the body of + a defun-like form. Body is the list of stuff which is to be parsed. + Environment is ignored. If Doc-String-Allowed is true, then a doc string + will be parsed out of the body and returned. If it is false then a string + will terminate the search for declarations. Three values are returned: the + tail of Body after the declarations and doc strings, a list of declare forms, + and the doc-string, or NIL if none." + (declare (ignore environment)) + (let ((decls ()) + (doc nil)) + (do ((tail body (cdr tail))) + ((endp tail) + (values tail (nreverse decls) doc)) + (let ((form (car tail))) + (cond ((and (stringp form) (cdr tail)) + (if doc-string-allowed + (setq doc form) + (return (values tail (nreverse decls) doc)))) + ((not (and (consp form) (symbolp (car form)))) + (return (values tail (nreverse decls) doc))) + ((eq (car form) 'declare) + (push form decls)) + (t + (return (values tail (nreverse decls) doc)))))))) + + +;;;; DEFMACRO: + +#-new-compiler +(proclaim '(special *in-compilation-unit*)) + +(defparameter defmacro-error-string "Macro ~S cannot be called with ~S args.") + +;;; Defmacro -- Public +;;; +;;; Parse the definition and make an expander function. The actual +;;; definition is done by %defmacro which we expand into. +;;; +(defmacro defmacro (name lambda-list &body body) + (let ((whole (gensym)) (environment (gensym))) + (multiple-value-bind + (body local-decs doc) + (parse-defmacro lambda-list whole body name + :environment environment + :error-string 'defmacro-error-string) + (let ((def `(lambda (,whole ,environment) + ,@local-decs + (block ,name + ,body)))) + ;; + ;; ### Bootstrap hack... + ;; When in old compiler, call %%defmacro with #'(lambda ...) so that + ;; the function gets compiled. When in old interpreter (neither in old + ;; or new compiler), just setf the macro-function so that we can have + ;; interpreted macros. + (cond #-new-compiler + (system:*in-the-compiler* + `(c::%%defmacro ',name #',def ,doc)) + #-new-compiler + ((not *in-compilation-unit*) + `(setf (symbol-function ',name) + (cons 'macro #',def))) + (t + `(c::%defmacro ',name + #+new-compiler #',def + #-new-compiler ',def + ',lambda-list ,doc))))))) + + +(eval-when (compile load eval) + +;;; %Defmacro, %%Defmacro -- Internal +;;; +;;; Defmacro expands into %Defmacro which is a function that is treated +;;; magically the compiler. After the compiler has gotten the information it +;;; wants out of macro definition, it compiles a call to %%Defmacro which +;;; happens at load time. We have a %Defmacro function which just calls +;;; %%Defmacro in order to keep the interpreter happy. +;;; +;;; Eventually %%Defmacro should deal with clearing old compiler information +;;; for the functional value. +;;; +(defun c::%defmacro (name definition lambda-list doc) + #+new-compiler + ;; ### bootstrap hack... + ;; This WHEN only necessary to make cross-compiling of this file work. + ;; Necessary because the EVAL-WHEN COMPILE goes into the bootstrap + ;; environment, but is read with the NEW-COMPILER feature. + (when (fboundp 'eval:interpreted-function-p) + (assert (eval:interpreted-function-p definition)) + (setf (eval:interpreted-function-name definition) name) + (setf (eval:interpreted-function-arglist definition) lambda-list)) + (c::%%defmacro name definition doc)) +;;; +(defun c::%%defmacro (name definition doc) + (clear-info function where-from name) + (setf (info function macro-function name) definition) + (setf (info function kind name) :macro) + (setf (documentation name 'function) doc) + name) + +); Eval-When + +;;; ### Bootstrap hack... +;;; +;;; Redefine the top-level defmacro handler to do nothing special when +;;; *bootstrap-defmacro* is true so that our defmacro gets called. +;;; +#-new-compiler +(eval-when (compile load eval) + (defvar *old-pdm* #'clc::process-defmacro) + (defvar *bootstrap-defmacro* nil) + (defun clc::process-defmacro (form) + (ecase *bootstrap-defmacro* + ((t) + (clc::process-random (macroexpand form) nil)) + ((nil) + (funcall *old-pdm* form)) + (:both + (clc::process-random (macroexpand form) nil) + (funcall *old-pdm* form)))))) + +;;; ### Bootstrap hack... +;;; At load time, get defmacro from the old place and store it in the new +;;; place. +#-new-compiler +(c::%%defmacro 'defmacro (macro-function 'defmacro) nil) + + +;;; ### Bootstrap hack... +;;; Install macro definitions in this file only into the new compiler's +;;; environment. +(eval-when (compile) + (setq *bootstrap-defmacro* t)) + + +;;; DEFTYPE is a lot like DEFMACRO. + +(defparameter deftype-error-string "Type ~S cannot be used with ~S args.") + +(defmacro deftype (name arglist &body body) + "Syntax like DEFMACRO, but defines a new type." + (unless (symbolp name) + (error "~S -- Type name not a symbol." name)) + + (let ((whole (gensym))) + (multiple-value-bind (body local-decs doc) + (parse-defmacro arglist whole body name + :default-default ''* + :error-string 'deftype-error-string + ) + `(eval-when (compile load eval) + (setf (get ',name 'deftype-expander) + #'(lambda (,whole) ,@local-decs (block ,name ,body))) + ,@(when doc + `((setf (documentation ',name 'type) ,doc))) + ',name)))) + +;;; And so is DEFINE-SETF-METHOD. + +(defparameter defsetf-error-string "Setf expander for ~S cannot be called with ~S args.") + +(compiler-let ((*bootstrap-defmacro* :both)) + +(defmacro define-setf-method (access-fn lambda-list &body body) + "Syntax like DEFMACRO, but creates a Setf-Method generator. The body + must be a form that returns the five magical values." + (unless (symbolp access-fn) + (error "~S -- Access-function name not a symbol in DEFINE-SETF-METHOD." + access-fn)) + + (let ((whole (gensym)) (environment (gensym))) + (multiple-value-bind (body local-decs doc) + (parse-defmacro lambda-list whole body access-fn + :environment environment + :error-string 'defsetf-error-string) + `(eval-when (load compile eval) + (setf (info setf inverse ',access-fn) nil) + (setf (info setf expander ',access-fn) + #'(lambda (,whole ,environment) + ,@local-decs + (block ,access-fn ,body))) + ,@(when doc + `((setf (documentation ',access-fn 'setf) ,doc))) + ',access-fn)))) + +); compiler-let + + +;;;; Defun, Defvar, Defparameter, Defconstant: + +;;; Defun -- Public +;;; +;;; Very similar to Defmacro, but simpler. We don't have to parse the +;;; lambda-list. +;;; +(defmacro defun (name lambda-list &body (body decls doc) &whole source) + (let ((def `(lambda ,lambda-list + ,@decls + (block ,(if (and (consp name) (eq (car name) 'setf)) + (cadr name) + name) + ,@body)))) + `(c::%defun ',name #',def ,doc ',source))) + + +;;; %Defun, %%Defun -- Internal +;;; +;;; Similar to %Defmacro, ... +;;; +(defun c::%%defun (name def doc &optional inline-expansion) + (setf (fdefinition name) def) + (when doc + (if (and (consp name) (eq (first name) 'setf)) + (setf (documentation (second name) 'setf) doc) + (setf (documentation name 'function) doc))) + + (unless (eq (info function kind name) :function) + (setf (info function kind name) :function)) + + (when (info function accessor-for name) + (setf (info function accessor-for name) nil)) + + (when (or inline-expansion + (info function inline-expansion name)) + (setf (info function inline-expansion name) inline-expansion)) + name) +;;; +(defun c::%defun (name def doc source) + (declare (ignore source)) + (c::%%defun name def doc)) + + +;;; DEFCONSTANT -- Public +;;; +(defmacro defconstant (var val &optional doc) + "For defining global constants at top level. The DEFCONSTANT says that the + value is constant and may be compiled into code. If the variable already has + a value, and this is not equal to the init, an error is signalled. The third + argument is an optional documentation string for the variable." + `(c::%defconstant ',var ,val ',doc)) + +;;; %Defconstant, %%Defconstant -- Internal +;;; +;;; Like the other %mumbles except that we currently actually do something +;;; interesting at load time, namely checking if the constant is being +;;; redefined. +;;; +(defun c::%defconstant (name value doc) + (c::%%defconstant name value doc)) +;;; +(defun c::%%defconstant (name value doc) + (when doc + (setf (documentation name 'variable) doc)) + (when (boundp name) + (unless (equalp (symbol-value name) value) + (cerror "Go ahead and change the value." + "Constant ~S being redefined." name))) + (setf (symbol-value name) value) + (setf (info variable kind name) :constant) + (clear-info variable constant-value name) + name) + + +(defmacro defvar (var &optional (val nil valp) (doc nil docp)) + "For defining global variables at top level. Declares the variable + SPECIAL and, optionally, initializes it. If the variable already has a + value, the old value is not clobbered. The third argument is an optional + documentation string for the variable." + `(progn + (proclaim '(special ,var)) + ,@(when valp + `((unless (boundp ',var) + (setq ,var ,val)))) + ,@(when docp + `((setf (documentation ',var 'variable) ',doc))) + ',var)) + +(defmacro defparameter (var val &optional (doc nil docp)) + "Defines a parameter that is not normally changed by the program, + but that may be changed without causing an error. Declares the + variable special and sets its value to VAL. The third argument is + an optional documentation string for the parameter." + `(progn + (proclaim '(special ,var)) + (setq ,var ,val) + ,@(when docp + `((setf (documentation ',var 'variable) ',doc))) + ',var)) + + +;;;; ASSORTED CONTROL STRUCTURES + + +(defmacro when (test &body forms) + "First arg is a predicate. If it is non-null, the rest of the forms are + evaluated as a PROGN." + `(cond (,test nil ,@forms))) + +(defmacro unless (test &rest forms) + "First arg is a predicate. If it is null, the rest of the forms are + evaluated as a PROGN." + `(cond ((not ,test) nil ,@forms))) + + +(defmacro return (&optional (value nil)) + `(return-from nil ,value)) + +(defmacro prog (varlist &body (body decls)) + `(block nil + (let ,varlist + ,@decls + (tagbody ,@body)))) + +(defmacro prog* (varlist &body (body decls)) + `(block nil + (let* ,varlist + ,@decls + (tagbody ,@body)))) + + +;;; Prog1, Prog2 -- Public +;;; +;;; These just turn into a Let. +;;; +(defmacro prog1 (result &rest body) + (let ((n-result (gensym))) + `(let ((,n-result ,result)) + ,@body + ,n-result))) +;;; +(defmacro prog2 (form1 result &rest body) + `(prog1 (progn ,form1 ,result) ,@body)) + + +;;; And, Or -- Public +;;; +;;; AND and OR are defined in terms of IF. +;;; +(defmacro and (&rest forms) + (cond ((endp forms) t) + ((endp (rest forms)) (first forms)) + (t + `(if ,(first forms) + (and ,@(rest forms)) + nil)))) +;;; +(defmacro or (&rest forms) + (cond ((endp forms) nil) + ((endp (rest forms)) (first forms)) + (t + (let ((n-result (gensym))) + `(let ((,n-result ,(first forms))) + (if ,n-result + ,n-result + (or ,@(rest forms)))))))) + + +;;; Cond -- Public +;;; +;;; COND also turns into IF. +;;; +(defmacro cond (&rest clauses) + (if (endp clauses) + nil + (let ((clause (first clauses))) + (when (atom clause) + (error "Cond clause is not a list: ~S." clause)) + (let ((test (first clause)) + (forms (rest clause))) + (if (endp forms) + (let ((n-result (gensym))) + `(let ((,n-result ,test)) + (if ,n-result + ,n-result + (cond ,@(rest clauses))))) + `(if ,test + (progn ,@forms) + (cond ,@(rest clauses)))))))) + + +;;;; Multiple value macros: + +;;; Multiple-Value-XXX -- Public +;;; +;;; All the multiple-value receiving forms are defined in terms of +;;; Multiple-Value-Call. +;;; +(defmacro multiple-value-setq (varlist value-form) + (unless (and (listp varlist) (every #'symbolp varlist)) + (error "Varlist is not a list of symbols: ~S." varlist)) + (let ((temps (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) varlist))) + `(multiple-value-bind ,temps ,value-form + ,@(mapcar #'(lambda (var temp) + `(setq ,var ,temp)) + varlist temps) + ,(car temps)))) +;;; +(defmacro multiple-value-bind (varlist value-form &body body) + (unless (and (listp varlist) (every #'symbolp varlist)) + (error "Varlist is not a list of symbols: ~S." varlist)) + (if (= (length varlist) 1) + `(let ((,(car varlist) ,value-form)) + ,@body) + (let ((ignore (gensym))) + `(multiple-value-call #'(lambda (&optional ,@varlist &rest ,ignore) + (declare (ignore ,ignore)) + ,@body) + ,value-form)))) +;;; +(defmacro multiple-value-list (value-form) + `(multiple-value-call #'list ,value-form)) + + +;;;; SETF and friends. + +;;; Note: The expansions for SETF and friends sometimes create needless +;;; LET-bindings of argument values. The compiler will remove most of +;;; these spurious bindings, so SETF doesn't worry too much about creating +;;; them. + +;;; The inverse for a generalized-variable reference function is stored in +;;; one of two ways: +;;; +;;; A SETF-INVERSE property corresponds to the short form of DEFSETF. It is +;;; the name of a function takes the same args as the reference form, plus a +;;; new-value arg at the end. +;;; +;;; A SETF-METHOD-EXPANDER property is created by the long form of DEFSETF or +;;; by DEFINE-SETF-METHOD. It is a function that is called on the reference +;;; form and that produces five values: a list of temporary variables, a list +;;; of value forms, a list of the single store-value form, a storing function, +;;; and an accessing function. + +(eval-when (compile load eval) + +;;; ### bootstrap hack... +;;; Rename get-setf-method so that we don't blow away setf in the bootstrap +;;; lisp. All references in this file are to the renamed function, and should +;;; eventually be renamed back. +;;; +#+new-compiler +(defun get-setf-method (form &optional environment) + (foo-get-setf-method form environment)) +;;; +(defun foo-get-setf-method (form &optional environment) + "Returns five values needed by the SETF machinery: a list of temporary + variables, a list of values with which to fill them, the temporary for the + new value in a list, the setting function, and the accessing function." + (let (temp) + (cond ((symbolp form) + (let ((new-var (gensym))) + (values nil nil (list new-var) `(setq ,form ,new-var) form))) + ((atom form) + (error "~S illegal atomic form for GET-SETF-METHOD." form)) + ;; + ;; ### Bootstrap hack... + ;; Ignore any DEFSETF info for structure accessors. + ((info function accessor-for (car form)) + (get-setf-method-inverse form `(funcall #'(setf ,(car form))))) + ((setq temp (info setf inverse (car form))) + (get-setf-method-inverse form `(,temp))) + ((setq temp (info setf expander (car form))) + (funcall temp form environment)) + (t + (multiple-value-bind (res win) + (macroexpand-1 form environment) + (if win + (foo-get-setf-method res environment) + (get-setf-method-inverse + form + `(funcall #'(setf ,(car form)))))))))) + +(defun get-setf-method-inverse (form inverse) + (let ((new-var (gensym)) + (vars nil) + (vals nil)) + (dolist (x (cdr form)) + (push (gensym) vars) + (push x vals)) + (setq vals (nreverse vals)) + (values vars vals (list new-var) + `(,@inverse ,@vars ,new-var) + `(,(car form) ,@vars)))) + + +(defun get-setf-method-multiple-value (form &optional environment) + "Like Get-Setf-Method, but may return multiple new-value variables." + (get-setf-method form environment)) + +(defun defsetter (fn rest env) + (let* ((arglist (car rest)) + (new-var (car (cadr rest))) + (%arg-count 0) + (%min-args 0) + (%restp nil) + (%let-list nil) + (%keyword-tests nil)) + (declare (special %arg-count %min-args %restp %let-list %keyword-tests)) + (multiple-value-bind (body local-decs doc) + (parse-body (cddr rest) env) + ;; Analyze the defmacro argument list. + (analyze1 arglist '(cdr %access-arglist) fn '%access-arglist) + ;; Now build the body of the transform. + (values + `(lambda (%access-arglist ,new-var) + ,@(when (null arglist) + '((declare (ignore %access-arglist)))) + (let* ,(nreverse %let-list) + ,@ local-decs + ,@ %keyword-tests + ,@ body)) + doc)))) + +) ; End of Eval-When. + + +(compiler-let ((*bootstrap-defmacro* :both)) + +(defmacro defsetf (access-fn &rest rest &environment env) + "Associates a SETF update function or macro with the specified access + function or macro. The format is complex. See the manual for + details." + (cond ((not (listp (car rest))) + `(eval-when (load compile eval) + (setf (info setf inverse ',access-fn) ',(car rest)) + ;; + ;; ### Bootstrap hack... + ;; In bootstrap env, also install inverse in old place so that we + ;; can still compile defstructs. + #-new-compiler + (setf (get ',access-fn 'setf-inverse) ',(car rest)) + (setf (info setf expander ',access-fn) nil) + ,@(if (and (car rest) (stringp (cadr rest))) + `((eval-when (load eval) + (%put ',access-fn '%setf-documentation ,(cadr rest))))) + ',access-fn)) + ((and (listp (car rest)) (cdr rest) (listp (cadr rest))) + (if (not (= (length (cadr rest)) 1)) + (cerror "Ignore the extra items in the list." + "Only one new-value variable allowed in DEFSETF.")) + (multiple-value-bind (setting-form-generator doc) + (defsetter access-fn rest env) + `(eval-when (load compile eval) + (setf (info setf inverse ',access-fn) nil) + (setf (info setf expander ',access-fn) + #'(lambda (access-form environment) + (declare (ignore environment)) + (do* ((args (cdr access-form) (cdr args)) + (dummies nil (cons (gensym) dummies)) + (newval-var (gensym)) + (new-access-form nil)) + ((atom args) + (setq new-access-form + (cons (car access-form) dummies)) + (values + dummies + (cdr access-form) + (list newval-var) + (funcall (function ,setting-form-generator) + new-access-form newval-var) + new-access-form))))) + ,@(if doc + `((eval-when (load eval) + (%put ',access-fn '%setf-documentation ',doc))) + `((eval-when (load eval) ;SKH 4/17/84 + (remprop ',access-fn '%setf-documentation)))) + ',access-fn))) + (t (error "Ill-formed DEFSETF for ~S." access-fn)))) + +); Compiler-Let + +(defmacro setf (&rest args &environment env) + "Takes pairs of arguments like SETQ. The first is a place and the second + is the value that is supposed to go into that place. Returns the last + value. The place argument may be any of the access forms for which SETF + knows a corresponding setting form." + (let ((temp (length args))) + (cond ((= temp 2) + (cond ((atom (car args)) + `(setq ,(car args) ,(cadr args))) + ((info function accessor-for (caar args)) + `(funcall #'(setf ,(caar args)) ,@(cdar args) ,(cadr args))) + ((setq temp (info setf inverse (caar args))) + `(,temp ,@(cdar args) ,(cadr args))) + (t (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method (car args) env) + (declare (ignore getter)) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil)) + ((null d) + (setq let-list + (nreverse (cons (list (car newval) + (cadr args)) + let-list))) + `(let* ,let-list ,setter)) + (setq let-list + (cons (list (car d) (car v)) let-list))))))) + ((oddp temp) + (error "Odd number of args to SETF.")) + (t (do ((a args (cddr a)) (l nil)) + ((null a) `(progn ,@(nreverse l))) + (setq l (cons (list 'setf (car a) (cadr a)) l))))))) + + +(defmacro psetf (&rest args &environment env) + "This is to SETF as PSETQ is to SETQ. Args are alternating place + expressions and values to go into those places. All of the subforms and + values are determined, left to right, and only then are the locations + updated. Returns NIL." + (do ((a args (cddr a)) + (let-list nil) + (setf-list nil)) + ((atom a) + `(let* ,(nreverse let-list) ,@(nreverse setf-list) nil)) + (if (atom (cdr a)) + (error "Odd number of args to PSETF.")) + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method (car a) env) + (declare (ignore getter)) + (do* ((d dummies (cdr d)) + (v vals (cdr v))) + ((null d)) + (push (list (car d) (car v)) let-list)) + (push (list (car newval) (cadr a)) let-list) + (push setter setf-list)))) + + + +(defmacro shiftf (&rest args &environment env) + "One or more SETF-style place expressions, followed by a single + value expression. Evaluates all of the expressions in turn, then + assigns the value of each expression to the place on its left, + returning the value of the leftmost." + (if (< (length args) 2) + (error "Too few argument forms to a SHIFTF.")) + (let ((leftmost (gensym))) + (do ((a args (cdr a)) + (let-list nil) + (setf-list nil) + (next-var leftmost)) + ((atom (cdr a)) + (push (list next-var (car a)) let-list) + `(let* ,(nreverse let-list) ,@(nreverse setf-list) ,leftmost)) + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method (car a) env) + (do* ((d dummies (cdr d)) + (v vals (cdr v))) + ((null d)) + (push (list (car d) (car v)) let-list)) + (push (list next-var getter) let-list) + (push setter setf-list) + (setq next-var (car newval)))))) + + +(defmacro rotatef (&rest args &environment env) + "Takes any number of SETF-style place expressions. Evaluates all of the + expressions in turn, then assigns to each place the value of the form to + its right. The rightmost form gets the value of the leftmost. Returns NIL." + (cond ((null args) nil) + ((null (cdr args)) `(progn ,(car args) nil)) + (t (do ((a args (cdr a)) + (let-list nil) + (setf-list nil) + (next-var nil) + (fix-me nil)) + ((atom a) + (rplaca fix-me next-var) + `(let* ,(nreverse let-list) ,@(nreverse setf-list) nil)) + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method (car a) env) + (do ((d dummies (cdr d)) + (v vals (cdr v))) + ((null d)) + (push (list (car d) (car v)) let-list)) + (push (list next-var getter) let-list) + ;; We don't know the newval variable for the last form yet, + ;; so fake it for the first getter and fix it at the end. + (unless fix-me (setq fix-me (car let-list))) + (push setter setf-list) + (setq next-var (car newval))))))) + + +(compiler-let ((*bootstrap-defmacro* :both)) + +(defmacro define-modify-macro (name lambda-list function &optional doc-string) + "Creates a new read-modify-write macro like PUSH or INCF." + (let ((other-args nil) + (rest-arg nil) + (env (gensym)) + (reference (gensym))) + + ;; Parse out the variable names and rest arg from the lambda list. + (do ((ll lambda-list (cdr ll)) + (arg nil)) + ((null ll)) + (setq arg (car ll)) + (cond ((eq arg '&optional)) + ((eq arg '&rest) + (if (symbolp (cadr ll)) + (setq rest-arg (cadr ll)) + (error "Non-symbol &rest arg in definition of ~S." name)) + (if (null (cddr ll)) + (return nil) + (error "Illegal stuff after &rest arg in Define-Modify-Macro."))) + ((memq arg '(&key &allow-other-keys &aux)) + (error "~S not allowed in Define-Modify-Macro lambda list." arg)) + ((symbolp arg) + (push arg other-args)) + ((and (listp arg) (symbolp (car arg))) + (push (car arg) other-args)) + (t (error "Illegal stuff in lambda list of Define-Modify-Macro.")))) + (setq other-args (nreverse other-args)) + `(defmacro ,name (,reference ,@lambda-list &environment ,env) + ,doc-string + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method ,reference ,env) + (do ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil (cons (list (car d) (car v)) let-list))) + ((null d) + (push + (list (car newval) + ,(if rest-arg + `(list* ',function getter ,@other-args ,rest-arg) + `(list ',function getter ,@other-args))) + let-list) + `(let* ,(nreverse let-list) + ,setter))))))) + +); Compiler-Let + + +(defmacro push (obj place &environment env) + "Takes an object and a location holding a list. Conses the object onto + the list, returning the modified list." + (if (symbolp place) + `(setq ,place (cons ,obj ,place)) + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method place env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil)) + ((null d) + (push (list (car newval) `(cons ,obj ,getter)) + let-list) + `(let* ,(nreverse let-list) + ,setter)) + (push (list (car d) (car v)) let-list))))) + + +(defmacro pushnew (obj place &rest keys &environment env) + "Takes an object and a location holding a list. If the object is already + in the list, does nothing. Else, conses the object onto the list. Returns + NIL. If there is a :TEST keyword, this is used for the comparison." + (if (symbolp place) + `(setq ,place (adjoin ,obj ,place ,@keys)) + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method place env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil)) + ((null d) + (push (list (car newval) `(adjoin ,obj ,getter ,@keys)) + let-list) + `(let* ,(nreverse let-list) + ,setter)) + (push (list (car d) (car v)) let-list))))) + + +(defmacro pop (place &environment env) + "The argument is a location holding a list. Pops one item off the front + of the list and returns it." + (if (symbolp place) + `(prog1 (car ,place) (setq ,place (cdr ,place))) + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method place env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil)) + ((null d) + (push (list (car newval) getter) let-list) + `(let* ,(nreverse let-list) + (prog1 (car ,(car newval)) + (setq ,(car newval) (cdr ,(car newval))) + ,setter))) + (push (list (car d) (car v)) let-list))))) + + +(define-modify-macro incf (&optional (delta 1)) + + "The first argument is some location holding a number. This number is + incremented by the second argument, DELTA, which defaults to 1.") + + +(define-modify-macro decf (&optional (delta 1)) - + "The first argument is some location holding a number. This number is + decremented by the second argument, DELTA, which defaults to 1.") +#| +(defmacro putf (place indicator value &environment env) + "Place may be any place expression acceptable to SETF, and is expected + to hold a property list or (). This list is destructively altered so + that (GETF place indicator) will find the specified newvalue. Returns + the new value." + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method place env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil) + (ind-temp (gensym)) + (val-temp (gensym))) + ((null d) + (push (list (car newval) getter) let-list) + (push (list ind-temp indicator) let-list) + (push (list val-temp value) let-list) + `(let* ,(nreverse let-list) + (setq ,(car newval) + (%primitive putf ,(car newval) ,ind-temp ,val-temp)) + ,setter + ,val-temp)) + (push (list (car d) (car v)) let-list)))) +|# + + +(defmacro remf (place indicator &environment env) + "Place may be any place expression acceptable to SETF, and is expected + to hold a property list or (). This list is destructively altered to + remove the property specified by the indicator. Returns T if such a + property was present, NIL if not." + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method place env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil) + (ind-temp (gensym)) + (local1 (gensym)) + (local2 (gensym))) + ((null d) + (push (list (car newval) getter) let-list) + (push (list ind-temp indicator) let-list) + `(let* ,(nreverse let-list) + (do ((,local1 ,(car newval) (cddr ,local1)) + (,local2 nil ,local1)) + ((atom ,local1) nil) + (cond ((atom (cdr ,local1)) + (error "Odd-length property list in REMF.")) + ((eq (car ,local1) ,ind-temp) + (cond (,local2 + (rplacd (cdr ,local2) (cddr ,local1)) + (return t)) + (t (setq ,(car newval) (cddr ,(car newval))) + ,setter + (return t)))))))) + (push (list (car d) (car v)) let-list)))) + + +;;; The built-in DEFSETFs. + +(defsetf car %rplaca) +(defsetf cdr %rplacd) +(defsetf caar (x) (v) `(%rplaca (car ,x) ,v)) +(defsetf cadr (x) (v) `(%rplaca (cdr ,x) ,v)) +(defsetf cdar (x) (v) `(%rplacd (car ,x) ,v)) +(defsetf cddr (x) (v) `(%rplacd (cdr ,x) ,v)) +(defsetf caaar (x) (v) `(%rplaca (caar ,x) ,v)) +(defsetf cadar (x) (v) `(%rplaca (cdar ,x) ,v)) +(defsetf cdaar (x) (v) `(%rplacd (caar ,x) ,v)) +(defsetf cddar (x) (v) `(%rplacd (cdar ,x) ,v)) +(defsetf caadr (x) (v) `(%rplaca (cadr ,x) ,v)) +(defsetf caddr (x) (v) `(%rplaca (cddr ,x) ,v)) +(defsetf cdadr (x) (v) `(%rplacd (cadr ,x) ,v)) +(defsetf cdddr (x) (v) `(%rplacd (cddr ,x) ,v)) +(defsetf caaaar (x) (v) `(%rplaca (caaar ,x) ,v)) +(defsetf cadaar (x) (v) `(%rplaca (cdaar ,x) ,v)) +(defsetf cdaaar (x) (v) `(%rplacd (caaar ,x) ,v)) +(defsetf cddaar (x) (v) `(%rplacd (cdaar ,x) ,v)) +(defsetf caadar (x) (v) `(%rplaca (cadar ,x) ,v)) +(defsetf caddar (x) (v) `(%rplaca (cddar ,x) ,v)) +(defsetf cdadar (x) (v) `(%rplacd (cadar ,x) ,v)) +(defsetf cdddar (x) (v) `(%rplacd (cddar ,x) ,v)) +(defsetf caaadr (x) (v) `(%rplaca (caadr ,x) ,v)) +(defsetf cadadr (x) (v) `(%rplaca (cdadr ,x) ,v)) +(defsetf cdaadr (x) (v) `(%rplacd (caadr ,x) ,v)) +(defsetf cddadr (x) (v) `(%rplacd (cdadr ,x) ,v)) +(defsetf caaddr (x) (v) `(%rplaca (caddr ,x) ,v)) +(defsetf cadddr (x) (v) `(%rplaca (cdddr ,x) ,v)) +(defsetf cdaddr (x) (v) `(%rplacd (caddr ,x) ,v)) +(defsetf cddddr (x) (v) `(%rplacd (cdddr ,x) ,v)) + +(defsetf first %rplaca) +(defsetf second (x) (v) `(%rplaca (cdr ,x) ,v)) +(defsetf third (x) (v) `(%rplaca (cddr ,x) ,v)) +(defsetf fourth (x) (v) `(%rplaca (cdddr ,x) ,v)) +(defsetf fifth (x) (v) `(%rplaca (cddddr ,x) ,v)) +(defsetf sixth (x) (v) `(%rplaca (cdr (cddddr ,x)) ,v)) +(defsetf seventh (x) (v) `(%rplaca (cddr (cddddr ,x)) ,v)) +(defsetf eighth (x) (v) `(%rplaca (cdddr (cddddr ,x)) ,v)) +(defsetf ninth (x) (v) `(%rplaca (cddddr (cddddr ,x)) ,v)) +(defsetf tenth (x) (v) `(%rplaca (cdr (cddddr (cddddr ,x))) ,v)) +(defsetf rest %rplacd) + +(defsetf elt %setelt) +(defsetf aref %aset) +(defsetf svref %svset) +(defsetf char %charset) +(defsetf bit %bitset) +(defsetf schar %scharset) +(defsetf sbit %sbitset) +(defsetf symbol-value set) +(defsetf symbol-function %sp-set-definition) +(defsetf symbol-plist %sp-set-plist) +(defsetf documentation %set-documentation) +(defsetf nth %setnth) +(defsetf fill-pointer %set-fill-pointer) +(defsetf search-list %set-search-list) + + +(define-setf-method getf (place prop &optional default &environment env) + (multiple-value-bind (temps values stores set get) + (foo-get-setf-method place env) + (let ((newval (gensym)) + (ptemp (gensym)) + (def-temp (gensym))) + (values `(,@temps ,(car stores) ,ptemp ,@(if default `(,def-temp))) + `(,@values ,get ,prop ,@(if default `(,default))) + `(,newval) + `(progn (setq ,(car stores) + (%primitive putf ,(car stores) ,ptemp ,newval)) + ,set + ,newval) + `(getf ,(car stores) ,ptemp ,@(if default `(,def-temp))))))) + +(define-setf-method get (symbol prop &optional default) + "Get turns into %put. Don't put in the default unless it really is supplied and + non-nil, so that we can transform into the get instruction whenever possible." + (let ((symbol-temp (gensym)) + (prop-temp (gensym)) + (def-temp (gensym)) + (newval (gensym))) + (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp))) + `(,symbol ,prop ,@(if default `(,default))) + (list newval) + `(%put ,symbol-temp ,prop-temp ,newval) + `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp)))))) + +(define-setf-method gethash (key hashtable &optional default) + (let ((key-temp (gensym)) + (hashtable-temp (gensym)) + (default-temp (gensym)) + (new-value-temp (gensym))) + (values + `(,key-temp ,hashtable-temp ,@(if default `(,default-temp))) + `(,key ,hashtable ,@(if default `(,default))) + `(,new-value-temp) + `(%puthash ,key-temp ,hashtable-temp ,new-value-temp) + `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp)))))) + +(defsetf subseq (sequence start &optional (end nil)) (v) + `(progn (replace ,sequence ,v :start1 ,start :end1 ,end) + ,v)) + + +;;; Evil hack invented by the gnomes of Vassar Street. The function +;;; arg must be constant. Get a setf method for this function, pretending +;;; that the final (list) arg to apply is just a normal arg. If the +;;; setting and access forms produced in this way reference this arg at +;;; the end, then just splice the APPLY back onto the front and the right +;;; thing happens. + +(define-setf-method apply (function &rest args &environment env) + (if (and (listp function) + (= (list-length function) 2) + (eq (first function) 'function) + (symbolp (second function))) + (setq function (second function)) + (error + "Setf of Apply is only defined for function args of form #'symbol.")) + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method (cons function args) env) + ;; Special case aref and svref. + (cond ((or (eq function 'aref) (eq function 'svref)) + (let ((nargs (subseq setter 0 (1- (length setter)))) + (fcn (if (eq function 'aref) 'lisp::%apply-aset 'lisp::%apply-svset))) + (values dummies vals newval + `(apply (function ,fcn) ,(car newval) ,@(cdr nargs)) + `(apply (function ,function) ,@(cdr getter))))) + ;; Make sure the place is one that we can handle. + (T (unless (and (eq (car (last args)) (car (last vals))) + (eq (car (last getter)) (car (last dummies))) + (eq (car (last setter)) (car (last dummies)))) + (error "Apply of ~S not understood as a location for Setf." + function)) + (values dummies vals newval + `(apply (function ,(car setter)) ,@(cdr setter)) + `(apply (function ,(car getter)) ,@(cdr getter))))))) + + +(define-setf-method ldb (bytespec place &environment env) + "The first argument is a byte specifier. The second is any place form + acceptable to SETF. Replaces the specified byte of the number in this + place with bits from the low-order end of the new value." + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method place env) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values (cons btemp dummies) + (cons bytespec vals) + (list gnuval) + `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter))) + ,setter + ,gnuval) + `(ldb ,btemp ,getter))))) + + +(define-setf-method mask-field (bytespec place &environment env) + "The first argument is a byte specifier. The second is any place form + acceptable to SETF. Replaces the specified byte of the number in this place + with bits from the corresponding position in the new value." + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method place env) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values (cons btemp dummies) + (cons bytespec vals) + (list gnuval) + `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))) + ,setter + ,gnuval) + `(mask-field ,btemp ,getter))))) + + +(define-setf-method char-bit (place bit-name &environment env) + "The first argument is any place form acceptable to SETF. Replaces the + specified bit of the character in this place with the new value." + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method place env) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values `(,@dummies ,btemp) + `(,@vals ,bit-name) + (list gnuval) + `(let ((,(car newval) + (set-char-bit ,getter ,btemp ,gnuval))) + ,setter + ,gnuval) + `(char-bit ,getter ,btemp))))) + + +(define-setf-method the (type place &environment env) + (multiple-value-bind (dummies vals newval setter getter) + (foo-get-setf-method place env) + (values dummies + vals + newval + (subst `(the ,type ,(car newval)) (car newval) setter) + `(the ,type ,getter)))) + + + +;;;; CASE, TYPECASE, & Friends. + +(eval-when (compile load eval) + +;;; CASE-BODY returns code for all the standard "case" macros. Name is the +;;; macro name, and keyform is the thing to case on. Multi-p indicates whether +;;; a branch may fire off a list of keys; otherwise, a key that is a list is +;;; interpreted in some way as a single key. When multi-p, test is applied to +;;; the value of keyform and each key for a given branch; otherwise, test is +;;; applied to the value of keyform and the entire first element, instead of +;;; each part, of the case branch. When errorp, no t or otherwise branch is +;;; permitted, and an ERROR form is generated. When proceedp, it is an error +;;; to omit errorp, and the ERROR form generated is executed within a +;;; RESTART-CASE allowing keyform to be set and retested. +;;; +(defun case-body (name keyform cases multi-p test errorp proceedp) + (let ((keyform-value (gensym)) + (clauses ()) + (keys ())) + (dolist (case cases) + (cond ((atom case) + (error "~S -- Bad clause in ~S." case name)) + ((memq (car case) '(t otherwise)) + (if errorp + (error "No default clause allowed in ~S: ~S" name case) + (push `(t nil ,@(rest case)) clauses))) + ((and multi-p (listp (first case))) + (setf keys (append (first case) keys)) + (push `((or ,@(mapcar #'(lambda (key) + `(,test ,keyform-value ',key)) + (first case))) + nil ,@(rest case)) + clauses)) + (t + (push (first case) keys) + (push `((,test ,keyform-value + ',(first case)) nil ,@(rest case)) clauses)))) + (case-body-aux name keyform keyform-value clauses keys errorp proceedp + `(,(if multi-p 'member 'or) ,@keys)))) + +;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the +;;; cases. Note: it is not necessary that the resulting code signal +;;; case-failure conditions, but that's what KMP's prototype code did. We call +;;; CASE-BODY-ERROR, because of how closures are compiled. RESTART-CASE has +;;; forms with closures that the compiler causes to be generated at the top of +;;; any function using the case macros, regardless of whether they are needed. +;;; +(defun case-body-aux (name keyform keyform-value clauses keys + errorp proceedp expected-type) + (if proceedp + (let ((block (gensym)) + (again (gensym))) + `(let ((,keyform-value ,keyform)) + (block ,block + (tagbody + ,again + (return-from + ,block + (cond ,@(nreverse clauses) + (t + (setf ,keyform-value + (setf ,keyform + (case-body-error + ',name ',keyform ,keyform-value + ',expected-type ',keys))) + (go ,again)))))))) + `(let ((,keyform-value ,keyform)) + (cond + ,@(nreverse clauses) + ,@(if errorp + `((t (error 'conditions::case-failure + :name ',name + :datum ,keyform-value + :expected-type ',expected-type + :possibilities ',keys)))))))) + +); eval-when + +(defun case-body-error (name keyform keyform-value expected-type keys) + (restart-case + (error 'conditions::case-failure + :name name + :datum keyform-value + :expected-type expected-type + :possibilities keys) + (store-value (value) + :report (lambda (stream) + (format stream "Supply a new value for ~S." keyform)) + :interactive read-evaluated-form + value))) + + + +(defmacro case (keyform &body cases) + "CASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If a singleton key is T then the clause is a default clause." + (case-body 'case keyform cases t 'eql nil nil)) + +(defmacro ccase (keyform &body cases) + "CCASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If none of the keys matches then a correctable error is + signalled." + (case-body 'ccase keyform cases t 'eql t t)) + +(defmacro ecase (keyform &body cases) + "ECASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If none of the keys matches then an error is signalled." + (case-body 'ecase keyform cases t 'eql t nil)) + +(defmacro typecase (keyform &body cases) + "TYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true." + (case-body 'typecase keyform cases nil 'typep nil nil)) + +(defmacro ctypecase (keyform &body cases) + "CTYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true. If no form is satisfied then a correctable error is signalled." + (case-body 'ctypecase keyform cases nil 'typep t t)) + +(defmacro etypecase (keyform &body cases) + "ETYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true. If no form is satisfied then an error is signalled." + (case-body 'etypecase keyform cases nil 'typep t nil)) + + +;;;; ASSERT and CHECK-TYPE. + +;;; ASSERT is written this way, to call ASSERT-ERROR, because of how closures +;;; are compiled. RESTART-CASE has forms with closures that the compiler +;;; causes to be generated at the top of any function using ASSERT, regardless +;;; of whether they are needed. +;;; +(defmacro assert (test-form &optional places datum &rest arguments) + "Signals an error if the value of test-form is nil. Continuing from this + error using the CONTINUE restart will allow the user to alter the value of + some locations known to SETF, starting over with test-form. Returns nil." + `(loop + (when ,test-form (return nil)) + (assert-error ',test-form ',places ,datum ,@arguments) + ,@(mapcar #'(lambda (place) + `(setf ,place (assert-prompt ',place ,place))) + places))) + +(defun assert-error (test-form places datum &rest arguments) + (restart-case (if datum + (apply #'error datum arguments) + (simple-assertion-failure test-form)) + (continue () + :report (lambda (stream) (assert-report places stream)) + nil))) + +(defun simple-assertion-failure (assertion) + (error 'simple-type-error + :datum assertion + :expected-type nil ;this needs some work in next revision. -kmp + :format-string "The assertion ~S failed." + :format-arguments (list assertion))) + +(defun assert-report (names stream) + (format stream "Retry assertion") + (if names + (format stream " with new value~P for ~{~S~^, ~}." + (length names) names) + (format stream "."))) + +(defun assert-prompt (name value) + (cond ((y-or-n-p "The old value of ~S is ~S.~ + ~%Do you want to supply a new value? " + name value) + (format *query-io* "~&Type a form to be evaluated:~%") + (flet ((read-it () (eval (read *query-io*)))) + (if (symbolp name) ;help user debug lexical variables + (progv (list name) (list value) (read-it)) + (read-it)))) + (t value))) + + +;;; CHECK-TYPE is written this way, to call CHECK-TYPE-ERROR, because of how +;;; closures are compiled. RESTART-CASE has forms with closures that the +;;; compiler causes to be generated at the top of any function using +;;; CHECK-TYPE, regardless of whether they are needed. Because it would be +;;; nice if this were cheap to use, and some things can't afford this excessive +;;; consing (e.g., READ-CHAR), we bend backwards a little. +;;; + +(defmacro check-type (place type &optional type-string) + "Signals an error of type type-error if the contents of place are not of the + specified type. If an error is signaled, this can only return if + STORE-VALUE is invoked. It will store into place and start over." + (let ((place-value (gensym))) + `(loop + (let ((,place-value ,place)) + (when (typep ,place-value ',type) (return nil)) + (setf ,place + (check-type-error ',place ,place-value ',type ,type-string)))))) + +(defun check-type-error (place place-value type type-string) + (restart-case (if type-string + (error 'simple-type-error + :datum place :expected-type type + :format-string + "The value of ~S is ~S, which is not ~A." + :format-arguments + (list place place-value type-string)) + (error 'simple-type-error + :datum place :expected-type type + :format-string + "The value of ~S is ~S, which is not of type ~S." + :format-arguments + (list place place-value type))) + (store-value (value) + :report (lambda (stream) + (format stream "Supply a new value of ~S." + place)) + :interactive read-evaluated-form + value))) + +;;; READ-EVALUATED-FORM is used as the interactive method for restart cases +;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros +;;; and by CHECK-TYPE. +;;; +(defun read-evaluated-form () + (format *query-io* "~&Type a form to be evaluated:~%") + (list (eval (read *query-io*)))) + + +;;;; With-XXX + +(defmacro with-open-file ((var &rest open-args) &body (forms decls)) + "Bindspec is of the form (Stream File-Name . Options). The file whose name + is File-Name is opened using the Options and bound to the variable Stream. + The Forms are executed, and when they terminate, normally or otherwise, + the file is closed." + (let ((abortp (gensym))) + `(let ((,var (open ,@open-args)) + (,abortp t)) + ,@decls + (unwind-protect + (multiple-value-prog1 + (progn ,@forms) + (setq ,abortp nil)) + (when ,var + (close ,var :abort ,abortp)))))) + + +(defmacro with-open-stream ((var stream) &body (forms decls)) + "The form stream should evaluate to a stream. VAR is bound + to the stream and the forms are evaluated as an implicit + progn. The stream is closed upon exit." + (let ((abortp (gensym))) + `(let ((,var ,stream) + (,abortp t)) + ,@decls + (unwind-protect + (multiple-value-prog1 + (progn ,@forms) + (setq ,abortp nil)) + (when ,var + (close ,var :abort ,abortp)))))) + + +(defmacro with-input-from-string ((var string &key index start end) &body (forms decls)) + "Binds the Var to an input stream that returns characters from String and + executes the body. See manual for details." + `(let ((,var + ,(if end + `(make-string-input-stream ,string ,(or start 0) ,end) + `(make-string-input-stream ,string ,(or start 0))))) + ,@decls + (unwind-protect + (progn ,@forms) + (close ,var) + ,@(if index `((setf ,index (string-input-stream-current ,var))))))) + + +(defmacro with-output-to-string ((var &optional string) &body (forms decls)) + "Binds the Var to a string output stream that puts characters into String + and executes the body. See manual for details." + (if string + `(let ((,var (make-fill-pointer-output-stream ,string))) + ,@decls + (unwind-protect + (progn ,@forms) + (close ,var))) + `(let ((,var (make-string-output-stream))) + ,@decls + (unwind-protect + (progn ,@forms) + (close ,var)) + (get-output-stream-string ,var)))) + + +;;;; Iteration macros: + +(defmacro loop (&rest body) + "Executes the body repeatedly until the form is exited by a Throw or + Return. The body is surrounded by an implicit block with name NIL." + (let ((tag (gensym))) + `(block nil (tagbody ,tag ,@body (go ,tag))))) + + +(defmacro dotimes ((var count &optional (result nil)) &body body) + (cond ((numberp count) + `(do ((,var 0 (1+ ,var))) + ((>= ,var ,count) ,result) + ,@body)) + (t (let ((v1 (gensym))) + `(do ((,var 0 (1+ ,var)) (,v1 ,count)) + ((>= ,var ,v1) ,result) + ,@body))))) + + +;;; We repeatedly bind the var instead of setting it so that we never give the +;;; var a random value such as NIL (which might conflict with a declaration). +;;; ### Might not be legal... +;;; +(defmacro dolist ((var list &optional (result nil)) &body body) + (let ((n-list (gensym))) + `(do ((,n-list ,list (cdr ,n-list))) + ((endp ,n-list) + (let ((,var nil)) + (declare (ignorable ,var)) + ,result)) + (let ((,var (car ,n-list))) + ,@body)))) + + +(defmacro do (varlist endlist &body (body decls)) + "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* + Iteration construct. Each Var is initialized in parallel to the value of the + specified Init form. On subsequent iterations, the Vars are assigned the + value of the Step form (if any) in paralell. The Test is evaluated before + each evaluation of the body Forms. When the Test is true, the the Exit-Forms + are evaluated as a PROGN, with the result being the value of the DO. A block + named NIL is established around the entire expansion, allowing RETURN to be + used as an laternate exit mechanism." + + (do-do-body varlist endlist body decls 'let 'psetq 'do nil)) + + +(defmacro do* (varlist endlist &body (body decls)) + "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* + Iteration construct. Each Var is initialized sequentially (like LET*) to the + value of the specified Init form. On subsequent iterations, the Vars are + sequentially assigned the value of the Step form (if any). The Test is + evaluated before each evaluation of the body Forms. When the Test is true, + the the Exit-Forms are evaluated as a PROGN, with the result being the value + of the DO. A block named NIL is established around the entire expansion, + allowing RETURN to be used as an laternate exit mechanism." + (do-do-body varlist endlist body decls 'let* 'setq 'do* nil)) + + +;;;; Miscellaneous macros: + +(defmacro locally (&rest forms) + "A form providing a container for locally-scoped variables." + `(let () ,@forms)) + +(defmacro psetq (&rest pairs) + (do ((lets nil) + (setqs nil) + (pairs pairs (cddr pairs))) + ((atom (cdr pairs)) + `(let ,(nreverse lets) (setq ,@(nreverse setqs)))) + (let ((gen (gensym))) + (push `(,gen ,(cadr pairs)) lets) + (push (car pairs) setqs) + (push gen setqs)))) + +;;; ### Bootstrap hack... +;;; Restore defmacro processing to normal. +;;; +(eval-when (compile) + (setq *bootstrap-defmacro* nil)) + + +;;;; With-Compilation-Unit: + +;;; True if we are within a With-Compilation-Unit form, which normally causes +;;; nested uses to be NOOPS. +;;; +(defvar *in-compilation-unit* nil) + +;;; Count of the number of compilation units dynamically enclosed by the +;;; current active WITH-COMPILATION-UNIT that were unwound out of. +;;; +(defvar *aborted-compilation-units*) + +(compiler-let ((*bootstrap-defmacro* :both)) + +;;; With-Compilation-Unit -- Public +;;; +;;; +(defmacro with-compilation-unit (options &body body) + (let ((force nil) + (n-fun (gensym)) + (n-abort-p (gensym))) + (when (oddp (length options)) + (error "Odd number of key/value pairs: ~S." options)) + (do ((opt options (cddr opt))) + ((null opt)) + (case (first opt) + (:force + (setq force (second opt))) + (t + (warn "Ignoring unknown option: ~S." (first opt))))) + + `(flet ((,n-fun () ,@body)) + (if (or ,force (not *in-compilation-unit*)) + (let ((c::*unknown-functions* nil) + (c::*compiler-error-count* 0) + (c::*compiler-warning-count* 0) + (c::*compiler-note-count* 0) + (*in-compilation-unit* t) + (*aborted-compilation-units* 0) + (,n-abort-p t)) + (unwind-protect + (multiple-value-prog1 + (,n-fun) + (setq ,n-abort-p nil)) + (c::print-summary ,n-abort-p *aborted-compilation-units*))) + (let ((,n-abort-p t)) + (unwind-protect + (multiple-value-prog1 + (,n-fun) + (setq ,n-abort-p nil)) + (when ,n-abort-p + (incf *aborted-compilation-units*)))))))) +); Compiler-Let diff --git a/code/misc.lisp b/code/misc.lisp new file mode 100644 index 000000000..ffa274ec2 --- /dev/null +++ b/code/misc.lisp @@ -0,0 +1,126 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Assorted miscellaneous functions for Spice Lisp. +;;; +;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan. +;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too. +;;; +(in-package "LISP") +(export '(documentation *features* common variable room + lisp-implementation-type lisp-implementation-version machine-type + machine-version machine-instance software-type software-version + short-site-name long-site-name dribble)) + + +(defun documentation (symbol doc-type) + "Returns the documentation string of Doc-Type for the Symbol, or NIL if + none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE, + and SETF." + (case doc-type + (variable (get symbol '%var-documentation)) + (function (get symbol '%fun-documentation)) + (structure (get symbol '%struct-documentation)) + (type (get symbol '%type-documentation)) + (setf (get symbol '%setf-documentation)) + (t (cdr (assoc doc-type (get symbol '%documentation)))))) + +(defun %set-documentation (symbol doc-type string) + (case doc-type + (variable (%put symbol '%var-documentation string)) + (function (%put symbol '%fun-documentation string)) + (structure (%put symbol '%struct-documentation string)) + (type (%put symbol '%type-documentation string)) + (setf (%put symbol '%setf-documentation string)) + (t (let ((pair (assoc doc-type (get symbol '%documentation)))) + (if pair (%rplacd pair string) + (push (cons doc-type string) (get symbol '%documentation)))))) + string) + +(defvar *features* '(:common :cmu :mach :ibm-rt-pc :clos :new-compiler) + "Holds a list of symbols that describe features provided by the + implementation.") + +(defun featurep (x) + "If X is an atom, see if it is present in *FEATURES*. Also + handle arbitrary combinations of atoms using NOT, AND, OR." + (cond ((atom x) (memq x *features*)) + ((eq (car x) ':not) (not (featurep (cadr x)))) + ((eq (car x) ':and) + (every #'featurep (cdr x))) + ((eq (car x) ':or) + (some #'featurep (cdr x))) + (t nil))) + + + +;;; Other Environment Inquiries. + +(defun lisp-implementation-type () + "Returns a string describing the implementation type." + "CMU Common Lisp") + +(defun lisp-implementation-version () + "Returns a string describing the implementation version." + *lisp-implementation-version*) + +(defun machine-type () + "Returns a string describing the type of the local machine." + "IBM RT PC") + +(defun machine-version () + "Returns a string describing the version of the local machine." + (let ((version (system:%primitive 16bit-system-ref + (int-sap + (+ (ash clc::romp-data-base 16) + clc::floating-point-hardware-available)) + 1))) + (if (or (not (= (logand version clc::float-mc68881) 0)) + (not (= (logand version clc::float-afpa) 0))) + "IBM RT PC/APC" + "IBM RT PC"))) + +(defun machine-instance () + "Returns a string giving the name of the local machine." + (mach::unix-gethostname)) + +(defun software-type () + "Returns a string describing the supporting software." + "MACH/4.3BSD") + +(defun software-version () + "Returns a string describing version of the supporting software." + NIL) + +(defun short-site-name () + "Returns a string with the abbreviated site name." + "CMU-CSD") + +(defun long-site-name () + "Returns a string with the long form of the site name." + "Carnegie-Mellon University Computer Science Department") + + + +;;;; Dribble stuff: + +(defun dribble (&optional pathname &key (if-exists :append)) + "With a file name as an argument, dribble opens the file and + sends a record of the output to that file. Without an + argument, it closes the open dribble file." + (if pathname + (with-open-file (f pathname :direction :output :if-exists if-exists + :if-does-not-exist :create) + (catch 'dribble-punt + (let ((*terminal-io* + (make-two-way-stream + (make-echo-stream *terminal-io* f) + (make-broadcast-stream *terminal-io* f)))) + (%top-level)))) + (throw 'dribble-punt nil))) diff --git a/code/package.lisp b/code/package.lisp new file mode 100644 index 000000000..d175370ca --- /dev/null +++ b/code/package.lisp @@ -0,0 +1,1101 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Package stuff and stuff like that. +;;; +;;; Re-Written by Rob MacLachlan. Earlier version written by +;;; Lee Schumacher. Apropos & iteration macros courtesy of Skef Wholey. +;;; +(in-package 'lisp) +(export '(package packagep *package* make-package in-package find-package + package-name package-nicknames rename-package + package-use-list package-used-by-list package-shadowing-symbols + list-all-packages intern find-symbol unintern export + unexport import shadowing-import shadow use-package + unuse-package find-all-symbols do-symbols + do-external-symbols do-all-symbols apropos apropos-list)) + + +(in-package "EXTENSIONS") +(export '(*keyword-package* *lisp-package*)) +(in-package 'lisp) + + +(defstruct (package + (:constructor internal-make-package) + (:predicate packagep) + (:print-function + (lambda (s stream d) + (declare (ignore d) (stream stream)) + (multiple-value-bind (iu it) (internal-symbol-count s) + (multiple-value-bind (eu et) (external-symbol-count s) + (format stream + "#<The ~A package, ~D/~D internal, ~D/~D external>" + (package-name s) iu it eu et)))))) + "Standard structure for the description of a package. Consists of + a list of all hash tables, the name of the package, the nicknames of + the package, the use-list for the package, the used-by- list, hash- + tables for the internal and external symbols, and a list of the + shadowing symbols." + (tables (list nil)) ; A list of all the hashtables for inherited symbols. + name ; The string name of the package. + nicknames ; List of nickname strings. + (use-list ()) ; List of packages we use. + (used-by-list ()) ; List of packages that use this package. + internal-symbols ; Hashtable of internal symbols. + external-symbols ; Hashtable of external symbols. + (shadowing-symbols ())) ; List of shadowing symbols. + +(defvar *package* () "The current package.") + +;;; An equal hashtable from package names to packages. +;;; +(defvar *package-names* (make-hash-table :test #'equal)) + + +;;; Lots of people want the keyword package and Lisp package without a lot +;;; of fuss, so we give them their own variables. +;;; +(defvar *lisp-package*) +(defvar *keyword-package*) + + +;;; This magical variable is T during initialization so Use-Package's of packages +;;; that don't yet exist quietly win. Such packages are thrown onto the list +;;; *Deferred-Use-Packages* so that this can be fixed up later. + +(defvar *in-package-init* nil) +(defvar *deferred-use-packages* nil) + +;;; Find-Package -- Public +;;; +;;; +(defun find-package (name) + "Find the package having the specified name." + (values (gethash (string name) *package-names*))) + +;;; Package-Listify -- Internal +;;; +;;; Return a list of packages given a package-or-string-or-symbol or +;;; list thereof, or die trying. +;;; +(defun package-listify (thing) + (let ((res ())) + (dolist (thing (if (listp thing) thing (list thing)) res) + (push (package-or-lose thing) res)))) + +;;; Package-Or-Lose -- Internal +;;; +;;; Take a package-or-string-or-symbol and return a package. +;;; +(defun package-or-lose (thing) + (if (packagep thing) + thing + (let ((thing (string thing))) + (cond ((gethash thing *package-names*)) + (t + (cerror "Make this package." + "~S is not the name of a package." thing) + (make-package thing)))))) + +;;;; Package-Hashtables +;;; +;;; Packages are implemented using a special kind of hashtable. It is +;;; an open hashtable with a parallel 8-bit I-vector of hash-codes. The +;;; primary purpose of the hash for each entry is to reduce paging by +;;; allowing collisions and misses to be detected without paging in the +;;; symbol and pname for an entry. If the hash for an entry doesn't +;;; match that for the symbol that we are looking for, then we can +;;; go on without touching the symbol, pname, or even hastable vector. +;;; It turns out that, contrary to my expectations, paging is a very +;;; important consideration the design of the package representation. +;;; Using a similar scheme without the entry hash, the fasloader was +;;; spending more than half its time paging in INTERN. +;;; The hash code also indicates the status of an entry. If it zero, +;;; the the entry is unused. If it is one, then it is deleted. +;;; Double-hashing is used for collision resolution. + +(defstruct (package-hashtable + (:constructor internal-make-package-hashtable ()) + (:copier nil) + (:print-function + (lambda (table stream d) + (declare (ignore d)) + (format stream + "#<Package-Hashtable: Size = ~D, Free = ~D, Deleted = ~D>" + (package-hashtable-size table) + (package-hashtable-free table) + (package-hashtable-deleted table))))) + table ; The g-vector of symbols. + hash ; The i-vector of pname hash values. + size ; The maximum number of entries allowed. + free ; The entries that can be made before we have to rehash. + deleted) ; The number of deleted entries. + + +;;; The maximum density we allow in a package hashtable. +;;; +(defparameter package-rehash-threshold 3/4) + +;;; Entry-Hash -- Internal +;;; +;;; Compute a number from the sxhash of the pname and the length which +;;; must be between 2 and 255. +;;; +(defmacro entry-hash (length sxhash) + `(the fixnum (+ (the fixnum (rem (the fixnum (logxor ,length + ,sxhash + (the fixnum (ash ,sxhash -8)) + (the fixnum (ash ,sxhash -16)) + (the fixnum (ash ,sxhash -19)))) + 254)) + 2))) + +;;; Make-Package-Hashtable -- Internal +;;; +;;; Make a package hashtable having a prime number of entries at least +;;; as great as (/ size package-rehash-threshold). If Res is supplied, +;;; then it is destructively modified to produce the result. This is +;;; useful when changing the size, since there are many pointers to +;;; the hashtable. +;;; +(defun make-package-hashtable (size &optional + (res (internal-make-package-hashtable))) + (do ((n (logior (truncate size package-rehash-threshold) 1) + (+ n 2))) + ((primep n) + (setf (package-hashtable-table res) + (make-array n)) + (setf (package-hashtable-hash res) + (make-array n :element-type '(unsigned-byte 8) :initial-element 0)) + (let ((size (truncate (* n package-rehash-threshold)))) + (setf (package-hashtable-size res) size) + (setf (package-hashtable-free res) size)) + (setf (package-hashtable-deleted res) 0) + res) + (declare (fixnum n)))) + + +;;; Internal-Symbol-Count, External-Symbols-Count -- Internal +;;; +;;; Return internal and external symbols. Used by Genesis and stuff. +;;; +(flet ((stuff (table) + (let ((size (the fixnum (- (the fixnum (package-hashtable-size table)) + (the fixnum (package-hashtable-deleted table)))))) + (declare (fixnum size)) + (values (the fixnum (- size (the fixnum (package-hashtable-free table)))) size)))) + + (defun internal-symbol-count (package) + (stuff (package-internal-symbols package))) + + (defun external-symbol-count (package) + (stuff (package-external-symbols package)))) + + +;;; Add-Symbol -- Internal +;;; +;;; Add a symbol to a package hashtable. The symbol is assumed +;;; not to be present. +;;; +(defun add-symbol (table symbol) + (let* ((vec (package-hashtable-table table)) + (hash (package-hashtable-hash table)) + (len (length vec)) + (sxhash (%primitive sxhash-simple-string (symbol-name symbol))) + (h2 (the fixnum (1+ (the fixnum (rem sxhash + (the fixnum (- len 2)))))))) + (declare (simple-vector vec) + (type (simple-array (unsigned-byte 8)) hash) + (fixnum len sxhash h2)) + (cond ((zerop (the fixnum (package-hashtable-free table))) + (make-package-hashtable (the fixnum + (* (the fixnum + (package-hashtable-size table)) + 2)) + table) + (add-symbol table symbol) + (dotimes (i len) + (declare (fixnum i)) + (when (> (the fixnum (aref hash i)) 1) + (add-symbol table (svref vec i))))) + (t + (do ((i (rem sxhash len) (rem (+ i h2) len))) + ((< (the fixnum (aref hash i)) 2) + (if (zerop (the fixnum (aref hash i))) + (decf (the fixnum (package-hashtable-free table))) + (decf (the fixnum (package-hashtable-deleted table)))) + (setf (svref vec i) symbol) + (setf (aref hash i) + (entry-hash (length (the simple-string (symbol-name symbol))) + sxhash))) + (declare (fixnum i))))))) + +;;; With-Symbol -- Internal +;;; +;;; Find where the symbol named String is stored in Table. Index-Var +;;; is bound to the index, or NIL if it is not present. Symbol-Var +;;; is bound to the symbol. Length and Hash are the length and sxhash +;;; of String. Entry-Hash is the entry-hash of the string and length. +;;; +(defmacro with-symbol ((index-var symbol-var table string length sxhash + entry-hash) + &body forms) + (let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym)) + (name (gensym)) (name-len (gensym)) (ehash (gensym))) + `(let* ((,vec (package-hashtable-table ,table)) + (,hash (package-hashtable-hash ,table)) + (,len (length ,vec)) + (,h2 (1+ (the fixnum (rem (the fixnum ,sxhash) + (the fixnum (- ,len 2))))))) + (declare (type (simple-array (unsigned-byte 8)) ,hash) + (simple-vector ,vec) + (fixnum ,len ,h2)) + (prog ((,index-var (rem (the fixnum ,sxhash) ,len)) + ,symbol-var ,ehash) + (declare (type (or fixnum null) ,index-var)) + LOOP + (setq ,ehash (aref ,hash ,index-var)) + (cond ((eql ,ehash ,entry-hash) + (setq ,symbol-var (svref ,vec ,index-var)) + (let* ((,name (symbol-name ,symbol-var)) + (,name-len (length ,name))) + (declare (simple-string ,name) + (fixnum ,name-len)) + (when (and (= ,name-len ,length) + (string= ,string ,name :end1 ,length + :end2 ,name-len)) + (go DOIT)))) + ((zerop ,ehash) + (setq ,index-var nil) + (go DOIT))) + (setq ,index-var (rem (+ ,index-var ,h2) ,len)) + (go LOOP) + DOIT + (return (progn ,@forms)))))) + +;;; Nuke-Symbol -- Internal +;;; +;;; Delete the entry for String in Table. The entry must exist. +;;; +(defun nuke-symbol (table string) + (declare (simple-string string)) + (let* ((length (length string)) + (hash (%primitive sxhash-simple-string string)) + (ehash (entry-hash length hash))) + (declare (fixnum length hash)) + (with-symbol (index symbol table string length hash ehash) + (setf (aref (package-hashtable-hash table) index) 1) + (setf (aref (package-hashtable-table table) index) nil) + (incf (package-hashtable-deleted table))))) + +;;;; Iteration macros. + +;;; Instead of using slow, silly successor functions, we make the iteration +;;; guys be big PROG's. Yea! + +(eval-when (compile load eval) + +(defun make-do-symbols-vars () + `(,(gensym) ; index + ,(gensym) ; hash + ,(gensym) ; hash-vector + ,(gensym))) ; terminus + +(defun make-do-symbols-code (vars var hash-table exit-form forms) + (let ((index (first vars)) + (hash-vector (second vars)) + (hash (third vars)) + (terminus (fourth vars)) + (TOP (gensym))) + `((setq ,index 0) + (setq ,hash-vector (package-hashtable-table ,hash-table)) + (setq ,hash (package-hashtable-hash ,hash-table)) + (setq ,terminus (length (the simple-vector ,hash-vector))) + ,TOP + (if (= (the fixnum ,index) (the fixnum ,terminus)) + ,exit-form) + (when (> (the fixnum (aref (the (simple-array (unsigned-byte 8)) ,hash) + ,index)) + 1) + (setq ,var (svref ,hash-vector ,index)) + ,@forms) + (incf ,index) + (go ,TOP)))) + +); eval-when (compile load eval) + +(defmacro do-symbols ((var &optional (package '*package*) result-form) + &body (code decls)) + "Do-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* + Executes the Forms at least once for each symbol accessible in the given + Package with Var bound to the current symbol." + (let* ((DONE-INTERNAL (gensym)) + (DONE-EXTERNAL (gensym)) + (NEXT-INHERIT (gensym)) + (vars (make-do-symbols-vars)) + (n-package (gensym)) + (shadowed (gensym)) + (inherits (gensym)) + (this-inherit (gensym))) + `(prog* ((,n-package (package-or-lose ,package)) + (,shadowed (package-shadowing-symbols ,n-package)) + (,inherits (package-use-list ,n-package)) + ,var ,@vars ,this-inherit) + ,@decls + ,@(make-do-symbols-code + vars var `(package-internal-symbols ,n-package) + `(go ,DONE-INTERNAL) + code) + ,DONE-INTERNAL + + ,@(make-do-symbols-code + vars var `(package-external-symbols ,n-package) + `(go ,DONE-EXTERNAL) + code) + ,DONE-EXTERNAL + + ,NEXT-INHERIT + (when (null ,inherits) + (setq ,var nil) + (return ,result-form)) + + (setq ,this-inherit (package-external-symbols (car ,inherits))) + ,@(make-do-symbols-code + vars var this-inherit + `(progn + (setq ,inherits (cdr ,inherits)) + (go ,NEXT-INHERIT)) + `((when (or (not ,shadowed) + (eq (find-symbol (symbol-name ,var) ,n-package) ,var)) + ,@code)))))) + +(defmacro do-external-symbols ((var &optional (package '*package*) result-form) + &body (code decls)) + "Do-External-Symbols (Var [Package [Result-Form]]) + {Declaration}* {Tag | Statement}* + Executes the Forms once for each external symbol in the given Package with + Var bound to the current symbol." + (let ((vars (make-do-symbols-vars)) + (n-package (gensym))) + `(prog ((,n-package (package-or-lose ,package)) + ,var ,@vars) + ,@decls + ,@(make-do-symbols-code + vars var `(package-external-symbols ,n-package) + `(return (progn (setq ,var nil) ,result-form)) + code)))) + +(defmacro do-all-symbols ((var &optional result-form) + &body (code decls)) + "Do-All-Symbols (Var [Result-Form]) {Declaration}* {Tag | Statement}* + Executes the Forms once for each symbol in each package with Var bound + to the current symbol." + (let* ((PACKAGE-LOOP (gensym)) + (TAG (gensym)) + (package-list (gensym)) + (vars (make-do-symbols-vars)) + (internal-code (make-do-symbols-code + vars var `(package-internal-symbols (car ,package-list)) + `(go ,TAG) + code)) + (external-code (make-do-symbols-code + vars var `(package-external-symbols (car ,package-list)) + `(progn (setq ,package-list (cdr ,package-list)) + (go ,PACKAGE-LOOP)) + code))) + `(prog (,package-list ,var ,@vars) + ,@decls + (setq ,package-list (list-all-packages)) + ,PACKAGE-LOOP + (when (null ,package-list) + (setq ,var nil) + (return ,result-form)) + ,@internal-code + ,TAG + ,@external-code))) + +;;; Enter-New-Nicknames -- Internal +;;; +;;; Enter any new Nicknames for Package into *package-names*. +;;; If there is a conflict then give the user a chance to do +;;; something about it. +;;; +(defun enter-new-nicknames (package nicknames) + (check-type nicknames list) + (dolist (n nicknames) + (let* ((n (string n)) + (found (gethash n *package-names*))) + (cond ((not found) + (setf (gethash n *package-names*) package) + (push n (package-nicknames package))) + ((eq found package)) + ((string= (package-name found) n) + (cerror "Ignore this nickname." + "~S is a package name, so it cannot be a nickname for ~S." + n (package-name package))) + (t + (cerror "Redefine this nickname." + "~S is already a nickname for ~S." + n (package-name found)) + (setf (gethash n *package-names*) package) + (push n (package-nicknames package))))))) + + +;;; Make-Package -- Public +;;; +;;; Check for package name conflicts in name and nicknames, then +;;; make the package. Do a use-package for each thing in the use list +;;; so that checking for conflicting exports among used packages is done. +;;; +(defun make-package (name &key (use '("LISP")) nicknames + (internal-symbols 10) (external-symbols 10)) + "Makes a new package having the specified Name and Nicknames. The + package will inherit all external symbols from each package in + the use list. :Internal-Symbols and :External-Symbols are + estimates for the number of internal and external symbols which + will ultimately be present in the package." + (when (find-package name) + (error "A package named ~S already exists" name)) + (let* ((name (string name)) + (package (internal-make-package + :name name + :internal-symbols (make-package-hashtable internal-symbols) + :external-symbols (make-package-hashtable external-symbols)))) + (if *in-package-init* + (push (list use package) *deferred-use-packages*) + (use-package use package)) + (enter-new-nicknames package nicknames) + (setf (gethash name *package-names*) package))) + +;;; In-Package -- Public +;;; +;;; Like Make-Package, only different. +;;; +(defun in-package (name &rest keys &key nicknames use) + "Sets *package* to package with given name, creating the package if + it does not exist. If the package already exists then it is modified + to agree with the :Use and :Nicknames arguments. Any new nicknames + are added without removing any old ones not specified. If any package + in the :Use list is not currently used, then it is added to the use + list." + (let ((package (find-package name))) + (cond + (package + (if *in-package-init* + (push (list use package) *deferred-use-packages*) + (use-package use package)) + (enter-new-nicknames package nicknames) + (setq *package* package)) + (t + (setq *package* (apply #'make-package name keys)))))) + +;;; Rename-Package -- Public +;;; +;;; Change the name if we can, blast any old nicknames and then +;;; add in any new ones. +;;; +(defun rename-package (package name &optional (nicknames ())) + "Changes the name and nicknames for a package." + (check-type package package) + (let* ((package (package-or-lose package)) + (name (string name)) + (found (find-package name))) + (unless (or (not found) (eq found package)) + (error "A package named ~S already exists." name)) + (remhash (package-name package) *package-names*) + (setf (package-name package) name) + (setf (gethash name *package-names*) package) + (dolist (n (package-nicknames package)) + (remhash n *package-names*)) + (setf (package-nicknames package) ()) + (enter-new-nicknames package nicknames) + package)) + +;;; List-All-Packages -- Public +;;; +;;; +(defun list-all-packages () + "Returns a list of all existing packages." + (let ((res ())) + (maphash #'(lambda (k v) + (declare (ignore k)) + (pushnew v res)) + *package-names*) + res)) + +;;; Intern -- Public +;;; +;;; Simple-stringify the name and call intern*. +;;; +(defun intern (name &optional package) + "Returns a symbol having the specified name, creating it if necessary." + (let ((name (if (simple-string-p name) name (coerce name 'simple-string)))) + (declare (simple-string name)) + (intern* name (length name) + (if package (package-or-lose package) *package*)))) + +;;; Find-Symbol -- Public +;;; +;;; Ditto. +;;; +(defun find-symbol (name &optional package) + "Returns the symbol named String in Package. If such a symbol is found + then the second value is :internal, :external or :inherited to indicate + how the symbol is accessible. If no symbol is found then both values + are NIL." + (let ((name (if (simple-string-p name) name (coerce name 'simple-string)))) + (declare (simple-string name)) + (find-symbol* name (length name) + (if package (package-or-lose package) *package*)))) + +;;; Intern* -- Internal +;;; +;;; If the symbol doesn't exist then create it, special-casing +;;; the keyword package. +;;; +(defun intern* (name length package) + (declare (simple-string name)) + (multiple-value-bind (symbol where) (find-symbol* name length package) + (if where + (values symbol where) + (let ((symbol (%primitive alloc-symbol (subseq name 0 length)))) + (%primitive set-package symbol package) + (cond ((eq package *keyword-package*) + (add-symbol (package-external-symbols package) symbol) + (set symbol symbol)) + (t + (add-symbol (package-internal-symbols package) symbol))) + (values symbol nil))))) + +;;; Find-Symbol* -- Internal +;;; +;;; Check internal and external symbols, then scan down the list +;;; of hashtables for inherited symbols. When an inherited symbol +;;; is found pull that table to the beginning of the list. +;;; +(defun find-symbol* (string length package) + (declare (simple-string string) + (fixnum length)) + (let* ((hash (%primitive sxhash-simple-substring string length)) + (ehash (entry-hash length hash))) + (declare (fixnum hash ehash)) + (with-symbol (found symbol (package-internal-symbols package) + string length hash ehash) + (when found + (return-from find-symbol* (values symbol :internal)))) + (with-symbol (found symbol (package-external-symbols package) + string length hash ehash) + (when found + (return-from find-symbol* (values symbol :external)))) + (let ((head (package-tables package))) + (do ((prev head table) + (table (cdr head) (cdr table))) + ((null table) (values nil nil)) + (with-symbol (found symbol (car table) string length hash ehash) + (when found + (unless (eq prev head) + (shiftf (cdr prev) (cdr table) (cdr head) table)) + (return-from find-symbol* (values symbol :inherited)))))))) + +;;; Find-External-Symbol -- Internal +;;; +;;; Similar to Find-Symbol, but only looks for an external symbol. +;;; This is used for fast name-conflict checking in this file and symbol +;;; printing in the printer. +;;; +(defun find-external-symbol (string package) + (declare (simple-string string)) + (let* ((length (length string)) + (hash (%primitive sxhash-simple-string string)) + (ehash (entry-hash length hash))) + (declare (fixnum length hash)) + (with-symbol (found symbol (package-external-symbols package) + string length hash ehash) + (values symbol found)))) + +;;; Unintern -- Public +;;; +;;; If we are uninterning a shadowing symbol, then a name conflict can +;;; result, otherwise just nuke the symbol. +;;; +(defun unintern (symbol &optional (package *package*)) + "Makes Symbol no longer present in Package. If Symbol was present + then T is returned, otherwise NIL. If Package is Symbol's home + package, then it is made uninterned." + (let* ((package (package-or-lose package)) + (name (symbol-name symbol)) + (shadowing-symbols (package-shadowing-symbols package))) + (declare (list shadowing-symbols) (simple-string name)) + ;; + ;; If a name conflict is revealed, give use a chance to shadowing-import + ;; one of the accessible symbols. + (when (member symbol shadowing-symbols) + (let ((cset ())) + (dolist (p (package-use-list package)) + (multiple-value-bind (s w) (find-external-symbol name p) + (when w (pushnew s cset)))) + (when (cdr cset) + (loop + (cerror + "prompt for a symbol to shadowing-import." + "Uninterning symbol ~S causes name conflict among these symbols:~%~S" + symbol cset) + (write-string "Symbol to shadowing-import: " *query-io*) + (let ((sym (read *query-io*))) + (cond + ((not (symbolp sym)) + (format *query-io* "~S is not a symbol.")) + ((not (member sym cset)) + (format *query-io* "~S is not one of the conflicting symbols.")) + (t + (shadowing-import sym package) + (return-from unintern t))))))) + (setf (package-shadowing-symbols package) + (delete symbol shadowing-symbols))) + + (multiple-value-bind (s w) (find-symbol name package) + (declare (ignore s)) + (cond ((or (eq w :internal) (eq w :external)) + (nuke-symbol (if (eq w :internal) + (package-internal-symbols package) + (package-external-symbols package)) + name) + (if (eq (symbol-package symbol) package) + (%primitive set-package symbol nil)) + t) + (t nil))))) + +;;; Symbol-Listify -- Internal +;;; +;;; Take a symbol-or-list-of-symbols and return a list, checking types. +;;; +(defun symbol-listify (thing) + (cond ((listp thing) + (dolist (s thing) + (unless (symbolp s) (error "~S is not a symbol." s))) + thing) + ((symbolp thing) (list thing)) + (t + (error "~S is neither a symbol nor a list of symbols." thing)))) + +;;; Moby-Unintern -- Internal +;;; +;;; Like Unintern, but if symbol is inherited chases down the +;;; package it is inherited from and uninterns it there. Used +;;; for name-conflict resolution. Shadowing symbols are not +;;; uninterned since they do not cause conflicts. +;;; +(defun moby-unintern (symbol package) + (unless (member symbol (package-shadowing-symbols package)) + (or (unintern symbol package) + (let ((name (symbol-name symbol))) + (multiple-value-bind (s w) (find-symbol name package) + (declare (ignore s)) + (when (eq w :inherited) + (dolist (q (package-use-list package)) + (multiple-value-bind (u x) (find-external-symbol name q) + (declare (ignore u)) + (when x + (unintern symbol q) + (return t)))))))))) + +;;; Export -- Public +;;; +;;; Do more stuff. +;;; +(defun export (symbols &optional (package *package*)) + "Exports Symbols from Package, checking that no name conflicts result." + (let ((package (package-or-lose package)) + (syms ())) + ;; + ;; Punt any symbols that are already external. + (dolist (sym (symbol-listify symbols)) + (multiple-value-bind (s w) + (find-external-symbol (symbol-name sym) package) + (declare (ignore s)) + (unless (or w (member sym syms)) (push sym syms)))) + ;; + ;; Find symbols and packages with conflicts. + (let ((used-by (package-used-by-list package)) + (cpackages ()) + (cset ())) + (dolist (sym syms) + (let ((name (symbol-name sym))) + (dolist (p used-by) + (multiple-value-bind (s w) (find-symbol name p) + (when (and w (not (eq s sym)) + (not (member s (package-shadowing-symbols p)))) + (pushnew sym cset) + (pushnew p cpackages)))))) + (when cset + (restart-case + (error "Exporting these symbols from the ~A package:~%~S~%~ + results in name conflicts with these packages:~%~{~A ~}" + (package-name package) cset (mapcar #'package-name cpackages)) + (unintern-conflicting-symbols () + :report "Unintern conflicting symbols." + (dolist (p cpackages) + (dolist (sym cset) + (moby-unintern sym p)))) + (skip-exporting-these-symbols () + :report "Skip exporting conflicting symbols." + (setq syms (nset-difference syms cset)))))) + ;; + ;; Check that all symbols are accessible. If not, ask to import them. + (let ((missing ()) + (imports ())) + (dolist (sym syms) + (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) + (cond ((not (and w (eq s sym))) (push sym missing)) + ((eq w :inherited) (push sym imports))))) + (when missing + (cerror "Import these symbols into the ~A package." + "These symbols are not accessible in the ~A package:~%~S" + (package-name package) missing) + (import missing package)) + (import imports package)) + ;; + ;; And now, three pages later, we export the suckers. + (let ((internal (package-internal-symbols package)) + (external (package-external-symbols package))) + (dolist (sym syms) + (nuke-symbol internal (symbol-name sym)) + (add-symbol external sym))) + t)) + +;;; Unexport -- Public +;;; +;;; Check that all symbols are accessible, then move from external to +;;; internal. +;;; +(defun unexport (symbols &optional (package *package*)) + "Makes Symbols no longer exported from Package." + (let ((package (package-or-lose package)) + (syms ())) + (dolist (sym (symbol-listify symbols)) + (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) + (cond ((or (not w) (not (eq s sym))) + (error "~S is not accessible in the ~A package." + sym (package-name package))) + ((eq w :external) (pushnew sym syms))))) + + (let ((internal (package-internal-symbols package)) + (external (package-external-symbols package))) + (dolist (sym syms) + (add-symbol internal sym) + (nuke-symbol external (symbol-name sym)))) + t)) + +;;; Import -- Public +;;; +;;; Check for name conflic caused by the import and let the user +;;; shadowing-import if there is. +;;; +(defun import (symbols &optional (package *package*)) + "Make Symbols accessible as internal symbols in Package. If a symbol + is already accessible then it has no effect. If a name conflict + would result from the importation, then a correctable error is signalled." + (let ((package (package-or-lose package)) + (symbols (symbol-listify symbols)) + (syms ()) + (cset ())) + (dolist (sym symbols) + (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) + (cond ((not w) + (let ((found (member sym syms :test #'string=))) + (if found + (when (not (eq (car found) sym)) + (push sym cset)) + (push sym syms)))) + ((not (eq s sym)) (push sym cset)) + ((eq w :inherited) (push sym syms))))) + (when cset + (cerror + "Import these symbols with Shadowing-Import." + "Importing these symbols into the ~A package causes a name conflict:~%~S" + (package-name package) cset)) + ;; + ;; Add the new symbols to the internal hashtable. + (let ((internal (package-internal-symbols package))) + (dolist (sym syms) + (add-symbol internal sym))) + ;; + ;; If any of the symbols are uninterned, make them be owned by Package. + (dolist (sym symbols) + (unless (symbol-package sym) (%primitive set-package sym package))) + (shadowing-import cset package))) + +;;; Shadowing-Import -- Public +;;; +;;; If a conflicting symbol is present, unintern it, otherwise just +;;; stick the symbol in. +;;; +(defun shadowing-import (symbols &optional (package *package*)) + "Import Symbols into package, disregarding any name conflict. If + a symbol of the same name is present, then it is uninterned. + The symbols are added to the Package-Shadowing-Symbols." + (let* ((package (package-or-lose package)) + (internal (package-internal-symbols package))) + (dolist (sym (symbol-listify symbols)) + (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) + (unless (and w (not (eq w :inherited)) (eq s sym)) + (when (or (eq w :internal) (eq w :external)) + ;; + ;; If it was shadowed, we don't want Unintern to flame out... + (setf (package-shadowing-symbols package) + (delete s (the list (package-shadowing-symbols package)))) + (unintern s package)) + (add-symbol internal sym)) + (pushnew sym (package-shadowing-symbols package))))) + t) + + +;;; Shadow -- Public +;;; +;;; +(defun shadow (symbols &optional (package *package*)) + "Make an internal symbol in Package with the same name as each of the + specified symbols, adding the new symbols to the Package-Shadowing-Symbols. + If a symbol with the given name is already present in Package, then + the existing symbol is placed in the shadowing symbols list if it is + not already present." + (let* ((package (package-or-lose package)) + (internal (package-internal-symbols package))) + (dolist (sym (symbol-listify symbols)) + (let ((name (symbol-name sym))) + (multiple-value-bind (s w) (find-symbol name package) + (when (or (not w) (eq w :inherited)) + (setq s (%primitive alloc-symbol name)) + (%primitive set-package s package) + (add-symbol internal s)) + (pushnew s (package-shadowing-symbols package)))))) + t) + +;;; Use-Package -- Public +;;; +;;; Do stuff to use a package, with all kinds of fun name-conflict +;;; checking. +;;; +(defun use-package (packages-to-use &optional (package *package*)) + "Add all the Package-To-Use to the use list for Package so that + the external symbols of the used packages are accessible as internal + symbols in Package." + (let ((packages (package-listify packages-to-use)) + (package (package-or-lose package))) + ;; + ;; Loop over each package, use'ing one at a time... + (dolist (pkg packages) + (unless (member pkg (package-use-list package)) + (let ((cset ()) + (shadowing-symbols (package-shadowing-symbols package)) + (use-list (package-use-list package))) + ;; + ;; If the number of symbols already accessible is less than the + ;; number to be inherited then it is faster to run the test the + ;; other way. This is particularly valuable in the case of + ;; a new package use'ing Lisp. + (cond + ((< (+ (internal-symbol-count package) + (external-symbol-count package) + (let ((res 0)) + (dolist (p use-list res) + (incf res (external-symbol-count p))))) + (external-symbol-count pkg)) + (do-symbols (sym package) + (multiple-value-bind (s w) + (find-external-symbol (symbol-name sym) pkg) + (when (and w (not (eq s sym)) + (not (member sym shadowing-symbols))) + (push sym cset)))) + (dolist (p use-list) + (do-external-symbols (sym p) + (multiple-value-bind (s w) + (find-external-symbol (symbol-name sym) + pkg) + (when (and w (not (eq s sym)) + (not (member (find-symbol (symbol-name sym) + package) + shadowing-symbols))) + (push sym cset)))))) + (t + (do-external-symbols (sym pkg) + (multiple-value-bind (s w) + (find-symbol (symbol-name sym) package) + (when (and w (not (eq s sym)) + (not (member s shadowing-symbols))) + (push s cset)))))) + + (when cset + (cerror + "unintern the conflicting symbols in the ~2*~A package." + "Use'ing package ~A results in name conflicts for these symbols:~%~S" + (package-name pkg) cset (package-name package)) + (dolist (s cset) (moby-unintern s package)))) + + (push pkg (package-use-list package)) + (push (package-external-symbols pkg) (cdr (package-tables package))) + (push package (package-used-by-list pkg))))) + t) + +;;; Unuse-Package -- Public +;;; +;;; +(defun unuse-package (packages-to-unuse &optional (package *package*)) + "Remove Packages-To-Unuse from the use list for Package." + (let ((package (package-or-lose package))) + (dolist (p (package-listify packages-to-unuse)) + (setf (package-use-list package) + (delete p (the list (package-use-list package)))) + (setf (package-tables package) + (delete (package-external-symbols p) + (the list (package-tables package)))) + (setf (package-used-by-list p) + (delete package (the list (package-used-by-list p))))) + t)) + +;;; Find-All-Symbols -- Public +;;; +;;; +(defun find-all-symbols (string-or-symbol) + "Return a list of all symbols in the system having the specified name." + (let ((string (string string-or-symbol)) + (res ())) + (maphash #'(lambda (k v) + (declare (ignore k)) + (multiple-value-bind (s w) (find-symbol string v) + (when w (pushnew s res)))) + *package-names*) + res)) + + +;;; Apropos and Apropos-List. + +(defun briefly-describe-symbol (symbol) + (fresh-line) + (prin1 symbol) + (when (boundp symbol) + (write-string ", value: ") + (prin1 (symbol-value symbol))) + (if (fboundp symbol) + (write-string " (defined)"))) + +(defun apropos-search (symbol string) + (declare (simple-string string)) + (do* ((index 0 (1+ index)) + (name (symbol-name symbol)) + (length (length string)) + (terminus (- (length name) length))) + ((> index terminus) + nil) + (declare (simple-string name) + (fixnum index terminus length)) + (if (do ((jndex 0 (1+ jndex)) + (kndex index (1+ kndex))) + ((= jndex length) + t) + (declare (fixnum jndex kndex)) + (let ((char (schar name kndex))) + (unless (char= (schar string jndex) (char-upcase char)) + (return nil)))) + (return t)))) + +(defun apropos (string &optional package external-only) + "Briefly describe all symbols which contain the specified String. + If Package is supplied then only describe symbols present in + that package. If External-Only is true then only describe + external symbols in the specified package." + (let ((string (string-upcase string))) + (declare (simple-string string)) + (if (null package) + (do-all-symbols (symbol) + (if (apropos-search symbol string) + (briefly-describe-symbol symbol))) + (let ((package (package-or-lose package))) + (if external-only + (do-external-symbols (symbol package) + (if (apropos-search symbol string) + (briefly-describe-symbol symbol))) + (do-symbols (symbol package) + (if (apropos-search symbol string) + (briefly-describe-symbol symbol)))))) + (values))) + +(defun apropos-list (string &optional package external-only) + "Identical to Apropos, except that it returns a list of the symbols + found instead of describing them." + (let ((string (string-upcase string)) + (list '())) + (declare (simple-string string)) + (if (null package) + (do-all-symbols (symbol) + (if (apropos-search symbol string) + (push symbol list))) + (let ((package (package-or-lose package))) + (if external-only + (do-external-symbols (symbol package) + (if (apropos-search symbol string) + (push symbol list))) + (do-symbols (symbol package) + (if (apropos-search symbol string) + (push symbol list)))))) + list)) + +;;; Initialization. + +;;; The cold loader (Genesis) makes the data structure in *initial-symbols*. +;;; We grovel over it, making the specified packages and interning the +;;; symbols. For a description of the format of *initial-symbols* see +;;; the Genesis source. + +(defvar *initial-symbols*) + +(defun package-init () + (let ((*in-package-init* t)) + (dolist (spec *initial-symbols*) + (let* ((pkg (apply #'make-package (first spec))) + (internal (package-internal-symbols pkg)) + (external (package-external-symbols pkg))) + ;; + ;; Put internal symbols in the internal hashtable and set package. + (dolist (symbol (second spec)) + (add-symbol internal symbol) + (%primitive set-package symbol pkg)) + ;; + ;; External symbols same, only go in external table. + (dolist (symbol (third spec)) + (add-symbol external symbol) + (%primitive set-package symbol pkg)) + ;; + ;; Don't set package for Imported symbols. + (dolist (symbol (fourth spec)) + (add-symbol internal symbol)) + (dolist (symbol (fifth spec)) + (add-symbol external symbol)) + ;; + ;; Put shadowing symbols in the shadowing symbols list. + (setf (package-shadowing-symbols pkg) (sixth spec)))) + + (makunbound '*initial-symbols*) ; So it gets GC'ed. + + ;; Make some other packages that should be around in the cold load: + (in-package "SYSTEM") + (in-package "USER") + (in-package "DEBUG") + + ;; Now do the *deferred-use-packages*: + (dolist (args *deferred-use-packages*) + (apply #'use-package args)) + (makunbound '*deferred-use-packages*) + + (setq *lisp-package* (find-package "LISP")) + (setq *keyword-package* (find-package "KEYWORD")) + + ;; For the kernel core image wizards, set the package to *Lisp-Package*. + (setq *package* *lisp-package*))) diff --git a/code/pred.lisp b/code/pred.lisp new file mode 100644 index 000000000..a137b2624 --- /dev/null +++ b/code/pred.lisp @@ -0,0 +1,619 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Predicate functions for Spice Lisp. +;;; The type predicates are implementation-specific. A different version +;;; of this file will be required for implementations with different +;;; data representations. +;;; +;;; Written and currently maintained by Scott Fahlman. +;;; Based on an earlier version by Joe Ginder. +;;; +(in-package 'lisp) +(export '(typep null symbolp atom consp listp numberp integerp rationalp + floatp complexp characterp stringp bit-vector-p vectorp + simple-vector-p simple-string-p simple-bit-vector-p arrayp + functionp compiled-function-p commonp eq eql equal equalp not + type-of + ;; Names of types... + array atom bignum bit bit-vector character common + compiled-function complex cons double-float + fixnum float function integer keyword list long-float nil + null number ratio rational sequence short-float signed-byte + simple-array simple-bit-vector simple-string simple-vector + single-float standard-char string string-char symbol t + unsigned-byte vector structure satisfies)) + +(in-package "EXTENSIONS") +(export '(structurep fixnump bignump bitp ratiop)) +(in-package "LISP") + + +;;; Data type predicates. + +;;; Translation from type keywords to specific predicates. Assumes that +;;; the following are named structures and need no special type hackery: +;;; PATHNAME, STREAM, READTABLE, PACKAGE, HASHTABLE, RANDOM-STATE. + +(defconstant type-pred-alist + '((keyword . keywordp) + (common . commonp) + (null . null) + (cons . consp) + (list . listp) + (symbol . symbolp) + (array . arrayp) + (vector . vectorp) + (bit-vector . bit-vector-p) + (string . stringp) + (sequence . sequencep) + (simple-array . simple-array-p) + (simple-vector . simple-vector-p) + (simple-string . simple-string-p) + (simple-bit-vector . simple-bit-vector-p) + (function . functionp) + (compiled-function . compiled-function-p) + (character . characterp) + (number . numberp) + (rational . rationalp) + (float . floatp) + (string-char . %string-char-p) + (integer . integerp) + (ratio . ratiop) + (short-float . short-float-p) + (standard-char . %standard-char-p) + (fixnum . fixnump) + (complex . complexp) +; (single-float . single-float-p) + (single-float . short-float-p) + (bignum . bignump) + (double-float . double-float-p) + (bit . bitp) + (long-float . long-float-p) + (structure . structurep) + (atom . atom))) + + +;;;; TYPE-OF and auxiliary functions. + +(defun type-of (object) + "Returns the type of OBJECT as a type-specifier. + Since objects may be of more than one type, the choice is somewhat + arbitrary and may be implementation-dependent." + (if (null object) 'symbol + (case (%primitive get-type object) + (#.%+-fixnum-type 'fixnum) + (#.%bignum-type 'bignum) + (#.%ratio-type 'ratio) + ((#.%short-+-float-type #.%short---float-type) 'short-float) + (#.%long-float-type 'long-float) + (#.%complex-type 'complex) + (#.%string-type `(simple-string ,(%primitive vector-length object))) + (#.%bit-vector-type + `(simple-bit-vector ,(%primitive vector-length object))) + (#.%integer-vector-type (type-of-i-vector object)) + (#.%general-vector-type (type-of-g-vector object)) + (#.%array-type (type-of-array object)) + (#.%function-type 'function) + (#.%symbol-type 'symbol) + (#.%list-type 'cons) + (#.%string-char-type 'string-char) + (#.%bitsy-char-type 'character) + (#.%--fixnum-type 'fixnum) + (t 'random)))) + +;;; %String-Char-P is called by typep when the type specification +;;; is string-char. The CL string-char-p does not do the right thing. +(defun %string-char-p (x) + (and (characterp x) + (< (the fixnum (char-int x)) char-code-limit))) + +;;; Create the list-style description of a G-vector. + +(defun type-of-g-vector (object) + (cond ((structurep object) (svref object 0)) + (t `(simple-vector ,(%primitive vector-length object))))) + +;;; I-Vector-Element-Type -- Internal +;;; +;;; Return a type specifier for the element type of an I-Vector. +;;; +(defun i-vector-element-type (object) + (let ((ac (%primitive get-vector-access-code object))) + (if (< 0 ac 6) + (svref '#((mod 2) (mod 4) (mod 16) (mod 256) (mod 65536) + (mod 4294967296)) + ac) + (error "Invalid I-Vector access code: ~S" ac)))) + +;;; Create the list-style description of an I-vector. + +(defun type-of-i-vector (object) + `(simple-array ,(i-vector-element-type object) + ,(%primitive vector-length object))) + + +;;; Create the list-style description of an array. + +(defun type-of-array (object) + (with-array-data ((data-vector object) (start) (end)) + (declare (ignore start end)) + (let ((rank (- (the fixnum (%primitive header-length object)) + %array-first-dim-slot)) + (length (%primitive header-ref object %array-length-slot))) + (declare (fixnum rank length)) + (if (= rank 1) + (typecase data-vector + (simple-bit-vector `(bit-vector ,length)) + (simple-string `(string ,length)) + (simple-vector `(vector t ,length)) + (t `(vector ,(i-vector-element-type data-vector) ,length))) + `(array + ,(typecase data-vector + (simple-bit-vector '(mod 2)) + (simple-string 'string-char) + (simple-vector 't) + (t (i-vector-element-type data-vector))) + ,(array-dimensions object)))))) + +;;;; TYPEP and auxiliary functions. + +(defun %typep (object type) + (let ((type (type-expand type)) + temp) + (cond ((symbolp type) + (cond ((or (eq type t) (eq type '*)) t) + ((eq type 'nil) nil) + ((setq temp (assq type type-pred-alist)) + (funcall (cdr temp) object)) + (t (structure-typep object type)))) + ((listp type) + ;; This handles list-style type specifiers. + (case (car type) + (vector (and (vectorp object) + (vector-eltype object (cadr type)) + (test-length object (caddr type)))) + (simple-vector (and (simple-vector-p object) + (test-length object (cadr type)))) + (string (and (stringp object) + (test-length object (cadr type)))) + (simple-string (and (simple-string-p object) + (test-length object (cadr type)))) + (bit-vector (and (bit-vector-p object) + (test-length object (cadr type)))) + (simple-bit-vector (and (simple-bit-vector-p object) + (test-length object (cadr type)))) + (array (array-typep object type)) + (simple-array (and (not (array-header-p object)) + (array-typep object type))) + (satisfies (funcall (cadr type) object)) + (member (member object (cdr type))) + (not (not (typep object (cadr type)))) + (or (dolist (x (cdr type) nil) + (if (typep object x) (return t)))) + (and (dolist (x (cdr type) t) + (if (not (typep object x)) (return nil)))) + (integer (and (integerp object) (test-limits object type))) + (rational (and (rationalp object) (test-limits object type))) + (float (and (floatp object) (test-limits object type))) + (short-float (and (short-float-p object) + (test-limits object type))) + (single-float (and (single-float-p object) + (test-limits object type))) + (double-float (and (double-float-p object) + (test-limits object type))) + (long-float (and (long-float-p object) + (test-limits object type))) + (mod (and (integerp object) + (>= object 0) + (< object (cadr type)))) + (signed-byte + (and (integerp object) + (let ((n (cadr type))) + (or (not n) (eq n '*) + (> n (integer-length object)))))) + (unsigned-byte + (and (integerp object) + (not (minusp object)) + (let ((n (cadr type))) + (or (not n) (eq n '*) + (>= n (integer-length object)))))) + (complex (and (numberp object) + (or (not (cdr type)) + (typep (realpart object) (cadr type))))) + (t (error "~S -- Illegal type specifier to TYPEP." type)))) + (t (error "~S -- Illegal type specifier to TYPEP." type))))) + +(defun typep (obj type) + "Returns T if OBJECT is of the specified TYPE, otherwise NIL." + (declare (notinline %typep)) + (%typep obj type)) + + +;;; Type-Expand -- Internal +;;; +;;; Similar to Macroexpand, but expands deftypes. We don't bother returning +;;; a second value. +;;; +(defun type-expand (form) + (let ((def (cond ((symbolp form) + (get form 'deftype-expander)) + ((and (consp form) (symbolp (car form))) + (get (car form) 'deftype-expander)) + (t nil)))) + (if def + (type-expand (funcall def (if (consp form) form (list form)))) + form))) + + +;;; Given that the object is a vector of some sort, and that we've already +;;; verified that it matches CAR of TYPE, see if the rest of the type +;;; specifier wins. Mild hack: Eltype Nil means either type not supplied +;;; or was Nil. Any vector can hold objects of type Nil, since there aren't +;;; any, so (vector nil) is the same as (vector *). +;;; +(defun vector-eltype (object eltype) + (let ((data (if (array-header-p object) + (with-array-data ((data object) (start) (end)) + (declare (ignore start end)) + data) + object)) + (eltype (type-expand eltype))) + (case eltype + ((t) (simple-vector-p data)) + (string-char (simple-string-p data)) + (bit (simple-bit-vector-p data)) + ((* nil) t) + (t + (subtypep eltype + (cond ((simple-vector-p data) t) + ((simple-string-p data) 'string-char) + ((simple-bit-vector-p data) 'bit) + (t + (i-vector-element-type data)))))))) + + +;;; Test sequence for specified length. + +(defun test-length (object length) + (or (null length) + (eq length '*) + (= length (length object)))) + + +;;; See if object satisfies the specifier for an array. + +(defun array-typep (object type) + (and (arrayp object) + (vector-eltype object (cadr type)) + (if (cddr type) + (let ((dims (third type))) + (cond ((eq dims '*) t) + ((numberp dims) + (and (vectorp object) + (= (the fixnum (length (the vector object))) + (the fixnum dims)))) + (t + (dotimes (i (array-rank object) (null dims)) + (when (null dims) (return nil)) + (let ((dim (pop dims))) + (unless (or (eq dim '*) + (= dim (array-dimension object i))) + (return nil))))))) + t))) + + +;;; Test whether a number falls within the specified limits. + +(defun test-limits (object type) + (let ((low (cadr type)) + (high (caddr type))) + (and (cond ((null low) t) + ((eq low '*) t) + ((numberp low) (>= object low)) + ((and (consp low) (numberp (car low))) + (> object (car low))) + (t nil)) + (cond ((null high) t) + ((eq high '*) t) + ((numberp high) (<= object high)) + ((and (consp high) (numberp (car high))) + (< object (car high))) + (t nil))))) + + +;;; Structure-Typep -- Internal +;;; +;;; This is called by Typep if the type-specifier is a symbol and is not one of +;;; the built-in Lisp types. If it's a structure, see if it's that type, or if +;;; it includes that type. +;;; +(defun structure-typep (object type) + (declare (optimize speed)) + (let ((type (type-expand type))) + (if (symbolp type) + (case (info type kind type) + ((:primitive :structure) + (and (structurep object) + (let ((obj-name (%primitive header-ref object 0))) + (or (eq obj-name type) + (let ((def (info type structure-info obj-name))) + (not (null (memq type (c::dd-includes def))))))))) + (t + (error "~S is an unknown type specifier." type))) + (error "~S is an unknown type specifier." type)))) + + +;;;; Assorted mumble-P type predicates. + +(defun commonp (object) + "Returns T if object is a legal Common-Lisp type, NIL if object is any + sort of implementation-dependent or internal type." + (or (structurep object) + (let ((type-spec (type-of object))) + (if (listp type-spec) (setq type-spec (car type-spec))) + (when (memq type-spec + '(character fixnum short-float single-float double-float + long-float vector string simple-vector + simple-string bignum ratio complex + compiled-function array symbol cons)) + T)))) + +(defun bit-vector-p (object) + "Returns T if the object is a bit vector, else returns NIL." + (bit-vector-p object)) + +;;; The following definitions are trivial because the compiler open-codes +;;; all of these. + +(defun null (object) + "Returns T if the object is NIL, else returns NIL." + (null object)) + +(defun not (object) + "Returns T if the object is NIL, else returns NIL." + (null object)) + +(defun symbolp (object) + "Returns T if the object is a symbol, else returns NIL." + (symbolp object)) + +(defun atom (object) + "Returns T if the object is not a cons, else returns NIL. + Note that (ATOM NIL) => T." + (atom object)) + +(defun consp (object) + "Returns T if the object is a cons cell, else returns NIL. + Note that (CONSP NIL) => NIL." + (consp object)) + +(defun listp (object) + "Returns T if the object is a cons cell or NIL, else returns NIL." + (listp object)) + +(defun numberp (object) + "Returns T if the object is any kind of number." + (numberp object)) + +(defun integerp (object) + "Returns T if the object is an integer (fixnum or bignum), else + returns NIL." + (integerp object)) + +(defun rationalp (object) + "Returns T if the object is an integer or a ratio, else returns NIL." + (rationalp object)) + +(defun floatp (object) + "Returns T if the object is a floating-point number, else returns NIL." + (floatp object)) + +(defun complexp (object) + "Returns T if the object is a complex number, else returns NIL." + (complexp object)) + +(defun %standard-char-p (x) + (and (characterp x) (standard-char-p x))) + +(defun characterp (object) + "Returns T if the object is a character, else returns NIL." + (characterp object)) + +(defun stringp (object) + "Returns T if the object is a string, else returns NIL." + (stringp object)) + +(defun simple-string-p (object) + "Returns T if the object is a simple string, else returns NIL." + (simple-string-p object)) + +(defun vectorp (object) + "Returns T if the object is any kind of vector, else returns NIL." + (vectorp object)) + +(defun simple-array-p (object) + "Returns T if the object is a simple array, else returns NIL." + (and (arrayp object) (not (array-header-p object)))) + +(defun simple-vector-p (object) + "Returns T if the object is a simple vector, else returns NIL." + (simple-vector-p object)) + +(defun simple-bit-vector-p (object) + "Returns T if the object is a simple bit vector, else returns NIL." + (simple-bit-vector-p object)) + +(defun arrayp (object) + "Returns T if the argument is any kind of array, else returns NIL." + (arrayp object)) + +(defun functionp (object) + "Returns T if the object is a function, suitable for use by FUNCALL + or APPLY, else returns NIL." + (functionp object)) + +(defun compiled-function-p (object) + "Returns T if the object is a compiled function object, else returns NIL." + (compiled-function-p object)) + +;;; ### Dummy definition until we figure out what to really do... +(defun clos::funcallable-instance-p (object) + (declare (ignore object)) + nil) + +(defun sequencep (object) + "Returns T if object is a sequence, NIL otherwise." + (typep object 'sequence)) + + +;;; The following are not defined at user level, but are necessary for +;;; internal use by TYPEP. + +(defun structurep (object) + (structurep object)) + +(defun fixnump (object) + (fixnump object)) + +(defun bignump (object) + (bignump object)) + +(defun bitp (object) + (typep object 'bit)) + +(defun short-float-p (object) + (typep object 'short-float)) + +(defun single-float-p (object) + (typep object 'single-float)) + +(defun double-float-p (object) + (typep object 'double-float)) + +(defun long-float-p (object) + (typep object 'long-float)) + +(defun ratiop (object) + (ratiop object)) + +;;; Some silly internal things for tenser array hacking: + +(defun array-header-p (object) + (array-header-p object)) + +;;;; Equality Predicates. + +(defun eq (x y) + "Returns T if X and Y are the same object, else returns NIL." + (eq x y)) + +(defun eql (x y) + "Returns T if X and Y are EQ, or if they are numbers of the same + type and precisely equal value, or if they are characters and + are CHAR=, else returns NIL." + (eql x y)) + +(defun equal (x y) + "Returns T if X and Y are EQL or if they are structured components + whose elements are EQUAL. Strings and bit-vectors are EQUAL if they + are the same length and have indentical components. Other arrays must be + EQ to be EQUAL." + (cond ((eql x y) t) + ((consp x) + (and (consp y) + (equal (car x) (car y)) + (equal (cdr x) (cdr y)))) + ((stringp x) + (and (stringp y) (string= x y))) + ((pathnamep x) + (and (pathnamep y) + (do* ((i 1 (1+ i)) + (len (length x))) + ((>= i len) t) + (declare (fixnum i len)) + (let ((x-el (svref x i)) + (y-el (svref y i))) + (if (and (simple-vector-p x-el) + (simple-vector-p y-el)) + (let ((lx (length x-el)) + (ly (length y-el))) + (declare (fixnum lx ly)) + (if (/= lx ly) (return nil)) + (do ((i 0 (1+ i))) + ((>= i lx)) + (declare (fixnum i)) + (if (not (equal (svref x-el i) (svref y-el i))) + (return-from equal nil)))) + (unless (or (eql x-el y-el) + (equal x-el y-el)) + (return nil))))))) + ((bit-vector-p x) + (and (bit-vector-p y) + (= (the fixnum (length x)) + (the fixnum (length y))) + (do ((i 0 (1+ i)) + (length (length x))) + ((= i length) t) + (declare (fixnum i)) + (or (= (the fixnum (bit x i)) + (the fixnum (bit y i))) + (return nil))))) + (t nil))) + + +(defun equalp (x y) + "Just like EQUAL, but more liberal in several respects. + Numbers may be of different types, as long as the values are identical + after coercion. Characters may differ in alphabetic case. Vectors and + arrays must have identical dimensions and EQUALP elements, but may differ + in their type restriction." + (cond ((eql x y) t) + ((characterp x) (char-equal x y)) + ((numberp x) (and (numberp y) (= x y))) + ((consp x) + (and (consp y) + (equalp (car x) (car y)) + (equalp (cdr x) (cdr y)))) + ((vectorp x) + (let ((length (length x))) + (declare (fixnum length)) + (and (vectorp y) + (= length (the fixnum (length y))) + (dotimes (i length t) + (let ((x-el (aref x i)) + (y-el (aref y i))) + (unless (or (eql x-el y-el) + (equalp x-el y-el)) + (return nil))))))) + ((arrayp x) + (let ((rank (array-rank x)) + (len (%primitive header-ref x %array-length-slot))) + (declare (fixnum rank len)) + (and (arrayp y) + (= (the fixnum (array-rank y)) rank) + (dotimes (i rank t) + (unless (= (the fixnum (array-dimension x i)) + (the fixnum (array-dimension y i))) + (return nil))) + (with-array-data ((x-vec x) (x-start) (end)) + (declare (ignore end)) + (with-array-data ((y-vec y) (y-start) (end)) + (declare (ignore end)) + (do ((i x-start (1+ i)) + (j y-start (1+ j)) + (count len (1- count))) + ((zerop count) t) + (declare (fixnum i j count)) + (let ((x-el (aref x-vec i)) + (y-el (aref y-vec j))) + (unless (or (eql x-el y-el) + (equalp x-el y-el)) + (return nil))))))))) + (t nil))) diff --git a/code/print.lisp b/code/print.lisp new file mode 100644 index 000000000..6dd29226d --- /dev/null +++ b/code/print.lisp @@ -0,0 +1,1267 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Spice Lisp printer. +;;; Written by Neal Feinberg, Spice Lisp Group. +;;; Currently maintained by Skef Wholey. +;;; +(in-package 'lisp) +(export '(*print-escape* *print-pretty* *print-circle* *print-base* *print-radix* + *print-case* *print-level* *print-length* *print-array* *print-gensym* + write prin1 print princ write-to-string prin1-to-string + princ-to-string)) + +(defvar *print-escape* T + "Flag which indicates that slashification is on. See the manual") +(defvar *print-pretty* T + "Flag which indicates that pretty printing is to be used") +(defvar *print-base* 10. + "The output base for integers and rationals.") +(defvar *print-radix* () + "This flag requests to verify base when printing rationals.") +(defvar *print-level* () + "How many levels deep to print. Unlimited if null.") +(defvar *print-length* () + "How many elements to print on each level. Unlimited if null.") +(defvar *print-circle* () + "Whether to worry about circular list structures. See the manual.") +(defvar *print-case* ':upcase + "What kind of case the printer should use by default") +(defvar previous-case () + "What the previous case selection the printer was set to.") +(defvar *print-array* T + "Whether the array should print it's guts out") +(defvar *print-gensym* T + "If true, symbols with no home package are printed with a #: prefix. + If false, no prefix is printed.") + + +;; This variable contains the current definition of one of three symbol +;; printers. This variable is set by the various print function (PRINT, +;; PRINC, and PRIN1). + +(defvar internal-symbol-output-function ()) + +(defvar print-string-stream (make-string-output-stream) + "Holds the string stream for the x-TO-STRING functions.") + +(defvar *in-stringify-object* () + "T if in the middle of stringify-object.") + +;; Imported from reader +(proclaim '(special *read-default-float-format*)) + +;; From the package system +(proclaim '(special *package* *keyword-package*)) + +;; This macro returns code which maps over a string, binding VARIABLE to each +;; successive character in the string INIT-FORM, and executing BODY with +;; the variable so bound. This function used to be part of Common Lisp, but +;; is no more. It lives on in the printer, though. + +(defmacro dostring (varform &rest body) + ;; Varform looks like (variable init-form terminate-form) + (let ((variable (car varform)) + (init-form (cadr varform)) + (terminate-form (caddr varform))) + `(do ((,variable) + (index 0 (1+ index)) + (terminate-index (length (the string ,init-form)))) + ((= index terminate-index) + ,terminate-form) + (declare (fixnum index terminate-index)) + (setq ,variable (char ,init-form index)) + ,@body))) + + +(proclaim '(inline setup-printer-state)) + +;; This function sets the internal global symbol +;; "internal-symbol-output-function" to the right function depending on +;; the value of *print-case*. See the manual for details. The print buffer +;; stream is also reset. + +(defun setup-printer-state () + (unless (eq *print-case* previous-case) + (setq previous-case *print-case*) + (setq internal-symbol-output-function + (case *print-case* + (:upcase #'output-uppercase-symbol) + (:downcase #'output-lowercase-symbol) + (:capitalize #'output-capitalize-symbol) + (T (let ((bad-case *print-case*)) + (setq *print-case* :upcase) + (Error "Invalid *print-case* value: ~s" bad-case)))))))) + +;;; Toplevel print functions + +(defun write (object &key + ((:stream stream) *standard-output*) + ((:escape *print-escape*) *print-escape*) + ((:radix *print-radix*) *print-radix*) + ((:base *print-base*) *print-base*) + ((:circle *print-circle*) *print-circle*) + ((:pretty *print-pretty*) *print-pretty*) + ((:level *print-level*) *print-level*) + ((:length *print-length*) *print-length*) + ((:case *print-case*) *print-case*) + ((:array *print-array*) *print-array*) + ((:gensym *print-gensym*) *print-gensym*)) + "Outputs OBJECT to the specified stream, defaulting to *standard-output*" + (setup-printer-state) + (let ((*standard-output* (if (or (eq stream 't) + (and (synonym-stream-p stream) + (eq (synonym-stream-symbol stream) + '*standard-output*))) + *standard-output* + stream))) + (if *print-pretty* + (output-pretty-object object) + (output-object object))) + object) + +(defun prin1 (object &optional stream) + "Outputs a mostly READable printed representation of OBJECT on the specified + stream." + (let ((*standard-output* (if (or (null stream) + (eq stream 't) + (and (synonym-stream-p stream) + (eq (synonym-stream-symbol stream) + '*standard-output*))) + *standard-output* + stream))) + (setup-printer-state) + (let ((*print-escape* T)) + (if *print-pretty* + (output-pretty-object object) + (output-object object))) + object)) + +(defun princ (object &optional stream) + "Outputs an asthetic but not READable printed representation of OBJECT on the + specified stream." + (let ((*standard-output* (if (or (null stream) + (eq stream 't) + (and (synonym-stream-p stream) + (eq (synonym-stream-symbol stream) + '*standard-output*))) + *standard-output* + stream))) + (setup-printer-state) + (let ((*print-escape* NIL)) + (if *print-pretty* + (output-pretty-object object) + (output-object object))) + object)) + +(defun print (object &optional stream) + "Outputs a terpri, the mostly READable printed represenation of OBJECT, and + space to the stream." + (let ((*standard-output* (if (or (null stream) + (eq stream 't) + (and (synonym-stream-p stream) + (eq (synonym-stream-symbol stream) + '*standard-output*))) + *standard-output* + stream))) + (terpri) + (prin1 object) + (write-char #\space) + object)) + + +;; STRINGIFY-OBJECT is an internal printer function produces the printed +;; representation of an object as a string. It is called by various x-TO-STRING +;; functions below. + +(defun stringify-object (object &optional (*print-escape* ())) + (let ((*standard-output* (if *in-stringify-object* + (make-string-output-stream) + print-string-stream)) + (*in-stringify-object* T)) + (setup-printer-state) + (if *print-pretty* + (output-pretty-object object) + (output-object object 0)) + (get-output-stream-string *standard-output*))) + +;;; Top-level x-TO-STRING functions. These functions all take an object +;;; and return that object's printed representation as a string. + +(defun write-to-string (object &key + ((:escape *print-escape*) *print-escape*) + ((:radix *print-radix*) *print-radix*) + ((:base *print-base*) *print-base*) + ((:circle *print-circle*) *print-circle*) + ((:pretty *print-pretty*) *print-pretty*) + ((:level *print-level*) *print-level*) + ((:length *print-length*) *print-length*) + ((:case *print-case*) *print-case*) + ((:array *print-array*) *print-array*) + ((:gensym *print-gensym*) *print-gensym*)) + "Returns the printed representation of OBJECT as a string." + (stringify-object object *print-escape*)) + +(defun prin1-to-string (object) + "Returns the printed representation of OBJECT as a string with + slashification on." + (stringify-object object t)) + +(defun princ-to-string (object) + "Returns the printed representation of OBJECT as a string with + slashification off." + (stringify-object object nil)) + + +;;; Central print functions. + +;;; OUTPUT-OBJECT takes an object and outputs its printed representation to +;;; *STANDARD-OUTPUT*, which is typically bound the the internal print stream. +;;; This function is called recursively by the sub-functions which know how +;;; to print structures which can contain other lisp objects. + +(defun output-object (object &optional (currlevel 0)) + "Outputs a string which is the printed representation of the given object." + ;; First check and make sure we aren't too deep + (declare (fixnum currlevel)) + (if (and (not (null *print-level*)) + (not (= *print-level* 0)) + (>= currlevel (the fixnum *print-level*))) + (write-char #\#) + (typecase object + (symbol + (if *print-escape* + (output-symbol object) + (case *print-case* + (:upcase (write-string (symbol-name object))) + (:downcase + (let ((name (symbol-name object))) + (declare (simple-string name)) + (dotimes (i (length name)) + (write-char (char-downcase (char name i)))))) + (:capitalize + (write-string (string-capitalize (symbol-name object))))))) + ;; If a list, go through element by element, being careful + ;; about not running over the printlength + (list + (if (clos::funcallable-instance-p object) + (clos::print-object object *standard-output* (1+ currlevel)) + (output-list object (1+ currlevel)))) + (string + (if *print-escape* + (quote-string object) + (write-string object))) + (integer + (output-integer object)) + (float + (output-float object)) + (ratio + (output-ratio object)) + (complex + (output-complex object)) + (structure + (output-structure object currlevel)) + (character + (output-character object)) + (vector + (output-vector object)) + (array + (output-array object (1+ currlevel))) + (t (output-random object)))) + 'T) + + +;;; Symbol Printing Subfunctions + +(defun output-symbol (object) + (let ((package (symbol-package object)) + (name (symbol-name object))) + (cond + ;; If the symbol's home package is the current one, then a + ;; prefix is never necessary. + ((eq package *package*)) + ;; If the symbol is in the keyword package, output a colon. + ((eq package *keyword-package*) + (write-char #\:)) + ;; Uninterned symbols print with a leading #:. + ((null package) + (when *print-gensym* (write-string "#:"))) + (t + (let ((found (car (memq package (package-use-list *package*))))) + (multiple-value-bind (symbol externalp) + (find-external-symbol name package) + ;; + ;; If the symbol's home package is in our use list and is an external + ;; symbol there, then it needs no qualification. + (unless (and found externalp (eq symbol object)) + (multiple-value-bind (symbol accessible) + (find-symbol name *package*) + ;; + ;; If we can find the symbol by looking it up, it + ;; need not be qualified. This can happen if the symbol + ;; has been inherited from a package other than its home + ;; package. + (unless (and accessible (eq symbol object)) + (funcall internal-symbol-output-function (package-name package)) + (if externalp + (write-char #\:) + (write-string "::"))))))))) + (funcall internal-symbol-output-function name))) + +;;;; Escaping symbols: +;;; +;;; When we print symbols we have to figure out if they need to +;;; be printed with escape characters. This isn't a whole lot easier +;;; than reading symbols in the first place. +;;; + +;;; For each character, the value of the corresponding element is a fixnum +;;; with bits set corresponding to attributes that the character has. +;;; This is also used by the character printer. +;;; +(defvar character-attributes + (make-array char-code-limit :element-type '(unsigned-byte 8) + :initial-element 0)) + +(eval-when (compile load eval) + +;;; Constants which are a bit-mask for each interesting character attribute. +;;; +(defconstant number-attribute #b10) ; A numeric digit. +(defconstant letter-attribute #b100) ; A upper-case letter. +(defconstant sign-attribute #b1000) ; +- +(defconstant extension-attribute #b10000) ; ^_ +(defconstant dot-attribute #b100000) ; . +(defconstant slash-attribute #b1000000) ; / +(defconstant other-attribute #b1) ; Anything else legal. +(defconstant funny-attribute #b10000000) ; Anything illegal. + +(defconstant attribute-names + '((number . number-attribute) (letter . letter-attribute) + (sign . sign-attribute) (extension . extension-attribute) + (dot . dot-attribute) (slash . slash-attribute) + (other . other-attribute) (funny . funny-attribute))) + +); Eval-When (compile load eval) + +(flet ((set-bit (char bit) + (let ((code (char-code char))) + (setf (aref character-attributes code) + (logior bit (aref character-attributes code)))))) + + (dolist (char '(#\! #\@ #\$ #\% #\& #\* #\= #\~ #\[ #\] #\{ #\} + #\? #\< #\>)) + (set-bit char other-attribute)) + + (dotimes (i 10) + (set-bit (digit-char i) number-attribute)) + + (do ((code (char-code #\A) (1+ code)) + (end (char-code #\Z))) + ((> code end)) + (declare (fixnum code end)) + (set-bit (code-char code) letter-attribute)) + + (set-bit #\- sign-attribute) + (set-bit #\+ sign-attribute) + (set-bit #\^ extension-attribute) + (set-bit #\_ extension-attribute) + (set-bit #\. dot-attribute) + (set-bit #\/ slash-attribute) + + ;; Make anything not explicitly allowed funny... + (dotimes (i char-code-limit) + (when (zerop (aref character-attributes i)) + (setf (aref character-attributes i) funny-attribute)))) + +;;; For each character, the value of the corresponding element is the lowest +;;; base in which that character is a digit. +;;; +(defvar digit-bases + (make-array char-code-limit :element-type '(mod 37) :initial-element 36)) + +(dotimes (i 36) + (let ((char (digit-char i 36))) + (setf (aref digit-bases (char-code char)) i))) + + +;;; Symbol-Quotep -- Internal +;;; +;;; A FSM-like thingie that determines whether a symbol is a potential +;;; number or has evil characters in it. +;;; +(defun symbol-quotep (name) + (declare (simple-string name)) + (macrolet ((advance (tag &optional (at-end t)) + `(progn + (when (= index len) + ,(if at-end '(go TEST-SIGN) '(return nil))) + (setq current (schar name index) + code (char-code current) + bits (aref attributes code)) + (incf index) + (go ,tag))) + (test (&rest attributes) + `(not (zerop + (the fixnum + (logand + (logior ,@(mapcar + #'(lambda (x) + (or (cdr (assoc x attribute-names)) + (error "Blast!"))) + attributes)) + bits))))) + (digitp () + `(< (the fixnum (aref bases code)) base))) + + (prog ((len (length name)) + (attributes character-attributes) + (bases digit-bases) + (base *print-base*) + (index 0) + (bits 0) + (code 0) + current) + (declare (fixnum len base index bits code)) + (advance START t) + + TEST-SIGN ; At end, see if it is a sign... + (return (not (test sign))) + + OTHER ; Not potential number, see if funny chars... + (return (not (null (%primitive find-character-with-attribute + name (1- index) len + attributes funny-attribute)))) + START + (when (digitp) + (if (test letter) + (advance LAST-DIGIT-ALPHA) + (advance DIGIT))) + (when (test letter number other slash) (advance OTHER nil)) + (when (char= current #\.) (advance DOT-FOUND)) + (when (test sign extension) (advance START-STUFF nil)) + (return t) + + DOT-FOUND ; Leading dots... + (when (test letter) (advance START-DOT-MARKER nil)) + (when (digitp) (advance DOT-DIGIT)) + (when (test number other) (advance OTHER nil)) + (when (test extension slash sign) (advance START-DOT-STUFF nil)) + (when (char= current #\.) (advance DOT-FOUND)) + (return t) + + START-STUFF ; Leading stuff before any dot or digit. + (when (digitp) + (if (test letter) + (advance LAST-DIGIT-ALPHA) + (advance DIGIT))) + (when (test number other) (advance OTHER nil)) + (when (test letter) (advance START-MARKER nil)) + (when (char= current #\.) (advance START-DOT-STUFF nil)) + (when (test sign extension slash) (advance START-STUFF nil)) + (return t) + + START-MARKER ; Number marker in leading stuff... + (when (test letter) (advance OTHER nil)) + (go START-STUFF) + + START-DOT-STUFF ; Leading stuff containing dot w/o digit... + (when (test letter) (advance START-DOT-STUFF nil)) + (when (digitp) (advance DOT-DIGIT)) + (when (test sign extension dot slash) (advance START-DOT-STUFF nil)) + (when (test number other) (advance OTHER nil)) + (return t) + + START-DOT-MARKER ; Number marker in leading stuff w/ dot.. + ;; Leading stuff containing dot w/o digit followed by letter... + (when (test letter) (advance OTHER nil)) + (go START-DOT-STUFF) + + DOT-DIGIT ; In a thing with dots... + (when (test letter) (advance DOT-MARKER)) + (when (digitp) (advance DOT-DIGIT)) + (when (test number other) (advance OTHER nil)) + (when (test sign extension dot slash) (advance DOT-DIGIT)) + (return t) + + DOT-MARKER ; Number maker in number with dot... + (when (test letter) (advance OTHER nil)) + (go DOT-DIGIT) + + LAST-DIGIT-ALPHA ; Previous char is a letter digit... + (when (or (digitp) (test sign slash)) + (advance ALPHA-DIGIT)) + (when (test letter number other dot) (advance OTHER nil)) + (return t) + + ALPHA-DIGIT ; Seen a digit which is a letter... + (when (or (digitp) (test sign slash)) + (if (test letter) + (advance LAST-DIGIT-ALPHA) + (advance ALPHA-DIGIT))) + (when (test letter) (advance ALPHA-MARKER)) + (when (test number other dot) (advance OTHER nil)) + (return t) + + ALPHA-MARKER ; Number marker in number with alpha digit... + (when (test letter) (advance OTHER nil)) + (go ALPHA-DIGIT) + + DIGIT ; Seen only real numeric digits... + (when (digitp) + (if (test letter) + (advance ALPHA-DIGIT) + (advance DIGIT))) + (when (test number other) (advance OTHER nil)) + (when (test letter) (advance MARKER)) + (when (test extension slash sign) (advance DIGIT)) + (when (char= current #\.) (advance DOT-DIGIT)) + (return t) + + MARKER ; Number marker in a numeric number... + (when (test letter) (advance OTHER nil)) + (go DIGIT)))) + +;;; +;;; This function takes the pname of a symbol and adds slashes and/or +;;; vertical bars to it to make it readable again. +;;; Special quoting characters are currently vertical bar and slash who's +;;; role in life are to specially quote symbols. Funny symbol characters +;;; are those who need special slashification when they are to be printed +;;; so they can be read in again. These currently include such characters +;;; as hash signs, colons of various sorts, etc. +;;; Now there are three different version: UPPERCASE, lowercase and Captialize. +;;; Check out the manual under the entry for *print-case* for details. + +(eval-when (compile eval) +(defmacro symbol-quote-char-p (char) + `(or (char= ,char #\\) (char= ,char #\|))) +); eval-when (compile eval) + +(defun output-uppercase-symbol (pname) + (declare (simple-string pname)) + (cond ((symbol-quotep pname) + (write-char #\|) + (dostring (char pname) + ;;If it needs slashing, do it. + (if (symbol-quote-char-p char) + (write-char #\\)) + (write-char char)) + (write-char #\|)) + (t + (write-string pname)))) + +;; See documentation for output-symbol-uppercase (above). + +(defun output-lowercase-symbol (pname) + (declare (simple-string pname)) + (cond ((symbol-quotep pname) + (write-char #\|) + (dostring (char pname) + (if (symbol-quote-char-p char) + (write-char #\\)) + (write-char char)) + (write-char #\|)) + (t + (dostring (char pname) + (write-char (char-downcase char)))))) + + +(defun output-capitalize-symbol (pname) + (declare (simple-string pname)) + (cond + ((symbol-quotep pname) + (write-char #\|) + (dostring (char pname) + (if (symbol-quote-char-p char) + (write-char #\\)) + (write-char char)) + (write-char #\|)) + (t + (do ((index 0 (1+ index)) + (pname-length (length (the string pname))) + (prev-not-alpha t)) + ((= index pname-length)) + (declare (fixnum index pname-length)) + (let ((char (char pname index))) + (write-char (if prev-not-alpha char (char-downcase char))) + (setq prev-not-alpha (not (alpha-char-p char)))))))) + +;;; Recursive Datatype Printing Subfunctions + + +(defun output-list (list &optional (currlevel 0)) + "Outputs the printed representation of a list." + (write-char #\() #|)|# + (do ((list list (cdr list)) + (currlength 0 (1+ currlength))) + ((or (null list) + (and (not (null *print-length*)) + (>= currlength (the fixnum *print-length*)))) + (if (not (null list)) (write-string " ...")) + (write-char #|(|# #\))) + (declare (fixnum currlength)) + ;;If we are not printing the first object, we should space first. + (if (> currlength 0) (write-char #\space)) + ;;Print whatever the car of the list is, at this level. + (output-object (car list) currlevel) + (cond ((not (or (consp (cdr list)) + (null (cdr list)))) + (write-string " . ") + (output-object (cdr list) currlevel) + (write-char #|(|# #\)) + (return ()))))) + +(defun output-vector (vector &optional (currlevel 0)) + "Outputs the printed representation of a 1-D array." + (declare (fixnum currlevel)) + (cond ((not *print-array*) + (output-terse-array vector currlevel)) + (T + (if (bit-vector-p vector) + (write-string "#*") + (write-string "#(" #|)|# )) + (do ((currlength 0 (1+ currlength)) + (vlength (length (the vector vector))) + (not-bit-vector-p (not (bit-vector-p vector)))) + ((or (and (not (null *print-length*)) + (>= currlength (the fixnum *print-length*))) + (= currlength vlength)) + (if (not (= currlength vlength)) (write-string " ...")) + (if not-bit-vector-p + (write-char #|(|# #\)))) + (declare (fixnum currlength vlength)) + ;;Put a space before every element except the first + ;; and not in bit vectors. + (if (and (> currlength 0) + not-bit-vector-p) + (write-char #\space)) + ;;Output an element of the vector + (output-object (aref vector currlength) currlevel))))) + +(defun output-array (array &optional (currlevel 0)) + "Outputs the printed representation of any array in either the #< or #A form." + (let ((rank (array-rank array))) + (cond ((not *print-array*) + (output-terse-array array rank)) + (T + (output-array-guts array rank currlevel))))) + +;; Master function for outputing the #A form of an array + +(defun output-array-guts (array rank currlevel) + (write-char #\#) + (let ((*print-base* 10)) + (output-integer rank)) + (write-char #\A) + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (sub-output-array-guts data (array-dimensions array) currlevel start))) + +;; Some Ideas stolen from Skef Wholey. +;; Helping function for above. +(defun sub-output-array-guts (array dimensions currlevel index) + (declare (fixnum currlevel index)) + (cond ((null dimensions) + (output-object (aref array index) currlevel) + (1+ index)) + ((and (not (null *print-level*)) + (>= currlevel (the fixnum *print-level*))) + (write-char #\#) index) + (T + (write-char #\() + (do ((index index) + (times 0 (1+ times)) + (limit (pop dimensions))) + ((or (= times limit) + (and (not (null *print-length*)) + (= times *print-length*))) + (if (not (= times limit)) + (write-string " ...)") + (write-char #\))) + index) + (declare (fixnum index times limit)) + (if (not (zerop times)) (write-char #\space)) + (setq index + (sub-output-array-guts array dimensions (1+ currlevel) index)) + )))) + +;; Used to output the #< form of any array. + +(defun output-terse-array (array rank) + (write-string "#<") + (cond ((vectorp array) + (if (bit-vector-p array) + (write-string "Bit-vector") + (write-string "Vector"))) + (T + (write-string "Array, rank ") + (output-integer rank))) + (finish-random array)) + + +;;; Structure Printing. These days we can always pass the buck to the Defstruct +;;; code. + +(defun output-structure (structure currlevel) + (let ((info (info type structure-info (svref structure 0)))) + (if info + (funcall (c::dd-print-function info) structure *standard-output* + currlevel) + (write-string "#<Bizarre illegal thing that looks like a structure>")))) + +;; Helping functions for printing strings. + +(defmacro funny-string-char-p (char) + "Determines whether or not the character needs quoting in a string." + ;; Should maybe look at readtable, not quite ready for such feat so + ;; use hack. + `(or (char= ,char #\\) + (char= ,char #\"))) + +;;; +;;; This function takes a string and slashifies it sufficiently so +;;; that if so that it may be read in again. +;;; Strategy: Put slash before all and only those characters which are +;;; either double-quote or backslash. +;;; + +(defun quote-string (string) + "Quotes a string so that if printed, it could be read back in again." + (write-char #\") + (dostring (char string) + (if (funny-string-char-p char) (write-char #\\)) + (write-char char)) + (write-char #\")) + + + +(defun whitespace-char-p (char) + "Determines whether or not the character is considered whitespace." + (or (char= char #\space) + (char= char #\tab) + (char= char #\return) + (char= char #\linefeed))) + +;;; Numerical Printer Functions. + +;; Helping function for above that actually outputs the individual digits. + +(defun output-integer (integer) + "This function outputs the printed representation of any integer" + (cond ((not (and (fixnump *print-base*) (> (the fixnum *print-base*) 1))) + (let ((obase *print-base*)) + (setq *print-base* 10.) + (error "~A is not a reasonable value for *Print-Base*." obase))) + ;; Otherwise print the base + (T (cond ((and (not (= *print-base* 10.)) + *print-radix*) + ;; First print leading base information, if any. + (write-char #\#) + (write-char (case *print-base* + (2. #\b) + (8. #\o) + (16. #\x) + (T (let ((fixbase *print-base*) + (*print-base* 10.) + (*print-radix* ())) + (sub-output-integer fixbase)) + #\r))))) + ;; Then output a minus sign if the number is negative, then output + ;; the absolute value of the number. + (cond ((bignump integer) (print-bignum integer)) + ((< integer 0) + (write-char #\-) + (sub-output-integer (- integer))) + (T (sub-output-integer integer))) + ;; Print any trailing base information, if any. + (if (and (= *print-base* 10.) *print-radix*) (write-char #\.))))) + + +(defun sub-output-integer (integer) + (let ((quotient ()) + (remainder ())) + ;; Recurse until you have all the digits pushed on the stack. + (if (not (zerop (multiple-value-setq (quotient remainder) + (truncate integer *print-base*)))) + (sub-output-integer quotient)) + ;; Then as each recursive call unwinds, turn the digit (in remainder) + ;; into a character and output the character. + (write-char (int-char (if (and (> remainder 9.) + (> *print-base* 10.)) + (+ (char-int #\A) (- remainder 10.)) + (+ (char-int #\0) remainder)))))) + + +;;; Outputs the printed representation of a ratio. + +(defun output-ratio (ratio) + (output-integer (numerator ratio)) + (write-char #\/) + (output-integer (denominator ratio))) + + +;;; Outputs the printed representation of a complex number. + +(defun output-complex (complex) + (write-string "#C(" #|)|#) + (output-object (realpart complex)) + (write-char #\space) + (output-object (imagpart complex)) + (write-char #|(|# #\))) + +;;; Bignum printing +;;; +;;; Written by Steven Handerson +;;; (based on Skef's idea) +;;; + +;;; Bignum-fixnum-divide-inplace wants the divisor to be of integer-length +;;; 19 or less. + +;;; 1- the ideal power of the base for a divisor. +(defparameter *fixnum-power--1* + '#(NIL NIL 17 10 8 7 6 5 5 4 4 4 4 4 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2 + 2)) + +;;; The base raised to the ideal power. +(defparameter *base-power* + '#(NIL NIL 262144 177147 262144 390625 279936 117649 262144 59049 100000 161051 + 248832 371293 38416 50625 65536 83521 104976 130321 160000 194481 234256 + 279841 331776 390625 456976 19683 21952 24389 27000 29791 32768 35937 + 39304 42875)) + +(defun print-bignum (big) + (bignum-print-aux (cond ((minusp big) (write-char #\-) (- big)) + (t (copy-xnum big)))) + big) + +(defun bignum-print-aux (big) + (multiple-value-bind (newbig fix) + (bignum-fixnum-divide-inplace + big (aref *base-power* *print-base*)) + (if (fixnump newbig) (sub-output-integer newbig) + (bignum-print-aux newbig)) + (do ((zeros (aref *fixnum-power--1* *print-base*) (1- zeros)) + (base-power *print-base* (* base-power *print-base*))) + ((> base-power fix) + (dotimes (i zeros) (write-char #\0)) + (sub-output-integer fix))))) + + + +;;;; Floating Point printing +;;; +;;; Written by Bill Maddox +;;; +;;; +;;; +;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of +;;; the work for all printing of floating point numbers in the printer and in +;;; FORMAT. It converts a floating point number to a string in a free or +;;; fixed format with no exponent. The interpretation of the arguments is as +;;; follows: +;;; +;;; X - The floating point number to convert, which must not be +;;; negative. +;;; WIDTH - The preferred field width, used to determine the number +;;; of fraction digits to produce if the FDIGITS parameter +;;; is unspecified or NIL. If the non-fraction digits and the +;;; decimal point alone exceed this width, no fraction digits +;;; will be produced unless a non-NIL value of FDIGITS has been +;;; specified. Field overflow is not considerd an error at this +;;; level. +;;; FDIGITS - The number of fractional digits to produce. Insignificant +;;; trailing zeroes may be introduced as needed. May be +;;; unspecified or NIL, in which case as many digits as possible +;;; are generated, subject to the constraint that there are no +;;; trailing zeroes. +;;; SCALE - If this parameter is specified or non-NIL, then the number +;;; printed is (* x (expt 10 scale)). This scaling is exact, +;;; and cannot lose precision. +;;; FMIN - This parameter, if specified or non-NIL, is the minimum +;;; number of fraction digits which will be produced, regardless +;;; of the value of WIDTH or FDIGITS. This feature is used by +;;; the ~E format directive to prevent complete loss of +;;; significance in the printed value due to a bogus choice of +;;; scale factor. +;;; +;;; Most of the optional arguments are for the benefit for FORMAT and are not +;;; used by the printer. +;;; +;;; Returns: +;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT) +;;; where the results have the following interpretation: +;;; +;;; DIGIT-STRING - The decimal representation of X, with decimal point. +;;; DIGIT-LENGTH - The length of the string DIGIT-STRING. +;;; LEADING-POINT - True if the first character of DIGIT-STRING is the +;;; decimal point. +;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the +;;; decimal point. +;;; POINT-POS - The position of the digit preceding the decimal +;;; point. Zero indicates point before first digit. +;;; +;;; WARNING: For efficiency, there is a single string object *digit-string* +;;; which is modified destructively and returned as the value of +;;; FLONUM-TO-STRING. Thus the returned value is not valid across multiple +;;; calls. +;;; +;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy. +;;; Specifically, the decimal number printed is the closest possible +;;; approximation to the true value of the binary number to be printed from +;;; among all decimal representations with the same number of digits. In +;;; free-format output, i.e. with the number of digits unconstrained, it is +;;; guaranteed that all the information is preserved, so that a properly- +;;; rounding reader can reconstruct the original binary number, bit-for-bit, +;;; from its printed decimal representation. Furthermore, only as many digits +;;; as necessary to satisfy this condition will be printed. +;;; +;;; +;;; FLOAT-STRING actually generates the digits for positive numbers. The +;;; algorithm is essentially that of algorithm Dragon4 in "How to Print +;;; Floating-Point Numbers Accurately" by Steele and White. The current +;;; (draft) version of this paper may be found in [CMUC]<steele>tradix.press. +;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING +;;; THE PAPER! + + +(defvar *digits* "0123456789") + +(defvar *digit-string* + (make-array 50 :element-type 'string-char :fill-pointer 0 :adjustable t)) + +(defun flonum-to-string (x &optional width fdigits scale fmin) + (cond ((zerop x) + ;;zero is a special case which float-string cannot handle + (if fdigits + (let ((s (make-string (1+ fdigits) :initial-element #\0))) + (setf (schar s 0) #\.) + (values s (length s) t (zerop fdigits) 0)) + (values "." 1 t t 0))) + (t + (setf (fill-pointer *digit-string*) 0) + (multiple-value-bind (sig exp) + (integer-decode-float x) + (if (typep x 'short-float) + ;;20 and 53 are the number of bits of information in the + ;;significand, less sign, of a short float and a long float + ;;respectively. + (float-string sig exp 20 width fdigits scale fmin) + (float-string sig exp 53 width fdigits scale fmin)))))) + + +(defun float-string (fraction exponent precision width fdigits scale fmin) + (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0) + (digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high) + ;;Represent fraction as r/s, error bounds as m+/s and m-/s. + ;;Rational arithmetic avoids loss of precision in subsequent calculations. + (cond ((> exponent 0) + (setq r (ash fraction exponent)) + (setq m- (ash 1 exponent)) + (setq m+ m-)) + ((< exponent 0) + (setq s (ash 1 (- exponent))))) + ;;adjust the error bounds m+ and m- for unequal gaps + (when (= fraction (ash 1 precision)) + (setq m+ (ash m+ 1)) + (setq r (ash r 1)) + (setq s (ash s 1))) + ;;scale value by requested amount, and update error bounds + (when scale + (if (minusp scale) + (let ((scale-factor (expt 10 (- scale)))) + (setq s (* s scale-factor))) + (let ((scale-factor (expt 10 scale))) + (setq r (* r scale-factor)) + (setq m+ (* m+ scale-factor)) + (setq m- (* m- scale-factor))))) + ;;scale r and s and compute initial k, the base 10 logarithm of r + (do () + ((>= r (ceiling s 10))) + (decf k) + (setq r (* r 10)) + (setq m- (* m- 10)) + (setq m+ (* m+ 10))) + (do ()(nil) + (do () + ((< (+ (ash r 1) m+) (ash s 1))) + (setq s (* s 10)) + (incf k)) + ;;determine number of fraction digits to generate + (cond (fdigits + ;;use specified number of fraction digits + (setq cutoff (- fdigits)) + ;;don't allow less than fmin fraction digits + (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))) + (width + ;;use as many fraction digits as width will permit + ;;but force at least fmin digits even if width will be exceeded + (if (< k 0) + (setq cutoff (- 1 width)) + (setq cutoff (1+ (- k width)))) + (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))))) + ;;If we decided to cut off digit generation before precision has + ;;been exhausted, rounding the last digit may cause a carry propagation. + ;;We can prevent this, preserving left-to-right digit generation, with + ;;a few magical adjustments to m- and m+. Of course, correct rounding + ;;is also preserved. + (when (or fdigits width) + (let ((a (- cutoff k)) + (y s)) + (if (>= a 0) + (dotimes (i a) (setq y (* y 10))) + (dotimes (i (- a)) (setq y (ceiling y 10)))) + (setq m- (max y m-)) + (setq m+ (max y m+)) + (when (= m+ y) (setq roundup t)))) + (when (< (+ (ash r 1) m+) (ash s 1)) (return))) + + ;;zero-fill before fraction if no integer part + (when (< k 0) + (setq decpnt digits) + (vector-push-extend #\. *digit-string*) + (dotimes (i (- k)) + (incf digits) (vector-push-extend #\0 *digit-string*))) + ;;generate the significant digits + (do ()(nil) + (decf k) + (when (= k -1) + (vector-push-extend #\. *digit-string*) + (setq decpnt digits)) + (multiple-value-setq (u r) (truncate (* r 10) s)) + (setq m- (* m- 10)) + (setq m+ (* m+ 10)) + (setq low (< (ash r 1) m-)) + (if roundup + (setq high (>= (ash r 1) (- (ash s 1) m+))) + (setq high (> (ash r 1) (- (ash s 1) m+)))) + ;;stop when either precision is exhausted or we have printed as many + ;;fraction digits as permitted + (when (or low high (and cutoff (<= k cutoff))) (return)) + (vector-push-extend (char *digits* u) *digit-string*) + (incf digits)) + ;;if cutoff occured before first digit, then no digits generated at all + (when (or (not cutoff) (>= k cutoff)) + ;;last digit may need rounding + (vector-push-extend (char *digits* + (cond ((and low (not high)) u) + ((and high (not low)) (1+ u)) + (t (if (<= (ash r 1) s) u (1+ u))))) + *digit-string*) + (incf digits)) + ;;zero-fill after integer part if no fraction + (when (>= k 0) + (dotimes (i k) (incf digits) (vector-push-extend #\0 *digit-string*)) + (vector-push-extend #\. *digit-string*) + (setq decpnt digits)) + ;;add trailing zeroes to pad fraction if fdigits specified + (when fdigits + (dotimes (i (- fdigits (- digits decpnt))) + (incf digits) + (vector-push-extend #\0 *digit-string*))) + ;;all done + (values *digit-string* (1+ digits) (= decpnt 0) (= decpnt digits) decpnt))) + + + +;;; Given a non-negative floating point number, SCALE-EXPONENT returns a +;;; new floating point number Z in the range (0.1, 1.0] and and exponent +;;; E such that Z * 10^E is (approximately) equal to the original number. +;;; There may be some loss of precision due the floating point representation. + + +(defconstant short-log10-of-2 0.30103s0) + +(defun scale-exponent (x) + (if (typep x 'short-float) + (scale-expt-aux x 0.0s0 1.0s0 1.0s1 1.0s-1 short-log10-of-2) + (scale-expt-aux x 0.0l0 1.0l0 %long-float-ten + %long-float-one-tenth long-log10-of-2))) + + +(defun scale-expt-aux (x zero one ten one-tenth log10-of-2) + (multiple-value-bind (sig exponent) + (decode-float x) + (declare (ignore sig)) + (if (= x zero) + (values zero 1) + (let* ((ex (round (* exponent log10-of-2))) + (x (if (minusp ex) ;For the end ranges. + (* x ten (expt ten (- -1 ex))) + (/ x ten (expt ten (1- ex)))))) + (do ((d ten (* d ten)) + (y x (/ x d)) + (ex ex (1+ ex))) + ((< y one) + (do ((m ten (* m ten)) + (z y (* z m)) + (ex ex (1- ex))) + ((>= z one-tenth) (values z ex))))))))) + + +;;; Entry point for the float printer as called by PRINT, PRIN1, PRINC, +;;; etc. The argument is printed free-format, in either exponential or +;;; non-exponential notation, depending on its magnitude. +;;; +;;; NOTE: When a number is to be printed in exponential format, it is scaled +;;; in floating point. Since precision may be lost in this process, the +;;; guaranteed accuracy properties of FLONUM-TO-STRING are lost. The +;;; difficulty is that FLONUM-TO-STRING performs extensive computations with +;;; integers of similar magnitude to that of the number being printed. For +;;; large exponents, the bignums really get out of hand. When we switch to +;;; IEEE format for long floats, this will significantly restrict the magnitude +;;; of the largest allowable float. This combined with microcoded bignum +;;; arithmetic might make it attractive to handle exponential notation with +;;; the same accuracy as non-exponential notation, using the method described +;;; in the Steele and White paper. + +(defun output-float (x) + (if (typep x 'short-float) + (output-float-aux x 1.0s-3 1.0s7) + (output-float-aux x %long-float1l-3 %long-float1l7))) + + +(defun output-float-aux (x e-min e-max) + (cond ((zerop x) + (write-string "0.0") + (if (and (not (typep x *read-default-float-format*)) + (not (and (eq *read-default-float-format* 'single-float) + (typep x 'short-float)))) + (write-string (if (typep x 'short-float) "s0" "L0")))) + (t (when (minusp x) + (write-char #\-) + (setq x (- x))) + (if (and (>= x e-min) (< x e-max)) + ;;free format + (multiple-value-bind (str len lpoint tpoint) + (flonum-to-string x) + (declare (ignore len)) + (when lpoint (write-char #\0)) + (write-string str) + (when tpoint (write-char #\0)) + (if (and (not (typep x *read-default-float-format*)) + (not (and (eq *read-default-float-format* 'single-float) + (typep x 'short-float)))) + (write-string (if (typep x 'short-float) "s0" "L0")))) + ;;exponential format + (multiple-value-bind (f ex) + (scale-exponent x) + (multiple-value-bind (str len lpoint tpoint) + (flonum-to-string f nil nil 1) + (declare (ignore len)) + (when lpoint (write-char #\0)) + (write-string str) + (when tpoint (write-char #\0)) + (write-char (if (typep x *read-default-float-format*) + #\E + (if (typep x 'short-float) #\S #\L))) + ;;must subtract 1 from exponent here, due to + ;;the scale factor of 1 in call to FLONUM-TO-STRING + (unless (minusp (1- ex)) (write-char #\+)) + (output-integer (1- ex)))))))) + + + +;; FUNNY-CHARACTER-CHAR-P returns a predicate which determines whether a +;; character must be slashified when being output. + +(defmacro funny-character-char-p (char) + `(and (not (zerop (char-bits ,char))) + (not (zerop (logand (aref character-attributes (char-code ,char)) + funny-attribute))))) + +;;; Output-Character -- Internal +;;; +;;; If *print-escape* is false, just do a write-char, otherwise output +;;; any bits and then the character or name, escaping if necessary. In +;;; either case, we blast the bits or font before writing the character +;;; itself to the stream. +;;; +(defun output-character (char) + (let ((base (make-char char))) + (if *print-escape* + (let ((name (char-name base))) + (write-string "#\\") + (macrolet ((frob (key string) + `(when (char-bit char ,key) + (write-string ,string)))) + (frob :control "CONTROL-") + (frob :meta "META-") + (frob :super "SUPER-") + (frob :hyper "HYPER-")) + (cond (name (write-string name)) + (t + (when (funny-character-char-p char) + (write-char #\\)) + (write-char base)))) + (write-char base)))) + + + +;;; Random and Misc. Print Subfunctions + + +;;; OUTPUT-FUNCTION-OBJECT outputs the main part of the printed +;;; representation of function objects. It is called from OUTPUT-RANDOM +;;; below. + +(defun output-function-object (subr) + (let ((name (%primitive header-ref subr %function-name-slot))) + (case (%primitive get-vector-subtype subr) + (#.%function-entry-subtype + (if (stringp name) + (format t "Internal Function ~S" name) + (format t "Function ~S" name))) + (#.%function-closure-subtype + (if (eval:interpreted-function-p subr) + (multiple-value-bind + (ig1 ig2 name) + (eval:interpreted-function-lambda-expression subr) + (declare (ignore ig1 ig2)) + (format t "Interpreted Function ~S" name)) + (format t "Closure ~S" + (%primitive header-ref name %function-name-slot)))) + (#.%function-closure-entry-subtype + (format t "Closure Entry ~S" name)) + (#.%function-constants-subtype + (format t "Function Constants ~S" name)) + (#.%function-value-cell-subtype + (assert (= %function-value-cell-value-slot %function-name-slot)) + (format t "Indirect Value Cell ~S" name)) +#| + (#.%function-funcallable-instance-subtype + (format t "Funcallable Instance ~S" name)) +|# + (t (error "Unknown function subtype."))))) + + +;;; FINISH-RANDOM is a helping function for OUTPUT-RANDOM below. +;;; It outputs the numerical value of the low 28 bits of +;;; RANDOM-OBJECT, enclosed in braces, followed by the closing +;;; angle-bracket (">") random objects have at the end. This +;;; is used to distringuish random objects of the same type. + +(defun finish-random (random-object) + (write-string " {") + (let ((*print-base* 16)) + (output-integer (%primitive make-fixnum random-object))) + (write-string "}>")) + +;;; Functions Objects and other implmentation specific objects +;;; are output here. + +(defun output-random (object) + (write-string "#<") + (if (compiled-function-p object) + (output-function-object object) + (let ((type (%primitive get-type object))) + (write-string "Pointer into Hell, level ") + (sub-output-integer type))) + (finish-random object)) diff --git a/code/purify.lisp b/code/purify.lisp new file mode 100644 index 000000000..24f322e43 --- /dev/null +++ b/code/purify.lisp @@ -0,0 +1,538 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Storage purifier for Spice Lisp. +;;; Written by Rob MacLachlan and Skef Wholey. +;;; +;;; The function Purify, defined herein, puts as much of the Lisp system as +;;; possible into Read-Only and Static spaces so that subsequent garbage +;;; collections are quicker. This is done by frobbing the free-pointers for +;;; spaces so that new objects are put in static or read-only space as +;;; appropiate, then doing a GC. +;;; +;;; We also transport all of the dynamic symbols in Lisp code so we +;;; can do clever things that improve locality in the resulting Lisp. +;;; Some constant conses and g-vectors are also transported in macrocode +;;; so that we can put them in read-only space. +;;; +(in-package 'lisp) + +(defun purify (&key root-structures) + (declare (special lisp-environment-list)) + (setq lisp-environment-list NIL) + (write-string "[Doing purification: ") + (force-output) + (setq *already-maybe-gcing* t) + ;; + ;; Move symbols to static space, constants to read-only space. + #| But don't until it works... + (localify root-structures) + |# + ;; + ;; Move everything else to either static or read-only space, depending + ;; on type. + (let ((fixups (gc-grovel-stack))) + (%primitive clear-registers) + (%primitive purify) + (gc-fixup-stack fixups)) + + (setq *already-maybe-gcing* nil) + (setq *need-to-collect-garbage* nil) + (write-line "done]") + nil) + +;;;; Localify + +(eval-when (compile eval) +;;; Peek, Poke -- Internal +;;; +;;; Read or write the cell at a location without doing any type-checking or +;;; anything silly like that. +;;; +(defmacro peek (x) + `(%primitive read-control-stack ,x)) +(defmacro poke (x val) + `(%primitive write-control-stack ,x ,val)) + +;;; Symbol-Bits -- Internal +;;; +;;; There is a whole 32 bits at the end of every symbol, which until +;;; now, was unused. We will use the low 16 to annotate some stuff about +;;; how symbols are referenced. +;;; +(defmacro symbol-bits (sym) + `(get ,sym 'purify-symbol-bits 0)) + +(defsetf symbol-bits (sym) (val) + `(let ((space (%primitive get-allocation-space))) + (%primitive set-allocation-space %dynamic-space) + (prog1 (setf (get ,sym 'purify-symbol-bits) ,val) + (%primitive set-allocation-space space)))) + +(defconstant marked-bit #b001) +(defconstant worthwhile-bit #b010) +(defconstant referenced-bit #b100) + +;;; Do-Allocated-Symbols -- Internal +;;; +;;; Iterate over all the symbols allocated in some space. +;;; +(defmacro do-allocated-symbols ((symbol space) &body forms) + `(let* ((old-alloc-space (%primitive get-allocation-space))) + (%primitive set-allocation-space %dynamic-space) + (let* ((index (+ (ash %symbol-type %alloc-ref-type-shift) + (ash ,space %alloc-ref-space-shift))) + (alloc-table (int-sap %fixnum-alloctable-address)) + (end (+ (logior (%primitive 16bit-system-ref alloc-table (1+ index)) + (ash (logand %type-space-mask + (%primitive 16bit-system-ref alloc-table index)) + 16)) + (ash ,space %space-shift)))) + (declare (fixnum end)) + (do ((base (ash ,space %space-shift) (+ base %symbol-length))) + ((= base end)) + (declare (fixnum base)) + (let ((,symbol (%primitive make-immediate-type base %symbol-type))) + (%primitive set-allocation-space old-alloc-space) + ,@forms + (%primitive set-allocation-space %dynamic-space)))) + (%primitive set-allocation-space old-alloc-space))) + +;;; Inlinep -- Internal +;;; +;;; Return true if symbol appears to be the name of a function likely +;;; to be coded inline. +;;; +(defmacro inlinep (sym) + `(or (info function source-transform ,sym) + (and (boundp 'c::*function-info*) + (let ((info (gethash ,sym c::*function-info*))) + (and info + (or (c::function-info-templates info) + (c::function-info-ir2-convert info))))))) + + +;;; Next-Symbol, Next-Cons -- Internal +;;; +;;; Return the object allocated after the supplied one. +;;; +(defmacro next-symbol (sym) + `(%primitive make-immediate-type (+ (%primitive make-fixnum ,sym) %symbol-length) + %symbol-type)) +(defmacro next-cons (cons) + `(%primitive make-immediate-type (+ (%primitive make-fixnum ,cons) %cons-length) + %list-type)) + +;;; Purep -- Internal +;;; +;;; True if Obj is either not dynamic or has already been transported. +;;; +(defmacro purep (obj) + `(or (>= (%primitive get-space ,obj) %static-space) + (let ((type (%primitive get-type ,obj))) + (declare (fixnum type)) + (or (< type %first-pointer-type) + (> type %last-pointer-type) + (= (%primitive get-type (peek ,obj)) %gc-forward-type))))) + +;;; Free-Pointer-Location -- Internal +;;; +;;; Return the SAP which points to the location of the free-pointer +;;; for the specifed type and space in the alloc table. +;;; +(defmacro free-pointer-location (type space) + `(+ %fixnum-alloctable-address + (%primitive lsh ,type (1+ %alloc-ref-type-shift)) + (%primitive lsh ,space (1+ %alloc-ref-space-shift)))) + +;;; Transport-Symbol -- Internal +;;; +;;; If Sym is impure, copy it into static space and put a GC forward in the +;;; old symbol. Return True only if we actually did something. +;;; +(defmacro transport-symbol (sym) + `(unless (purep ,sym) + (let ((new-sym (%primitive alloc-symbol (symbol-name ,sym)))) + (when (boundp ,sym) + (setf (symbol-value new-sym) (symbol-value ,sym))) + (when (fboundp ,sym) + (setf (symbol-function new-sym) (symbol-function ,sym))) + (setf (symbol-plist new-sym) (symbol-plist ,sym)) + (%primitive set-package new-sym (symbol-package ,sym)) + (poke ,sym (%primitive make-immediate-type new-sym %gc-forward-type)) + t))) + +;;; Copy-G-Vector -- Internal +;;; +;;; Copy a G-Vector into the current allocation space, and forward +;;; the old object. Return the new object. If an EQ hashtable, +;;; change the subtype, otherwise preserve it. +;;; +(defmacro copy-g-vector (object) + `(let* ((len (length ,object)) + (new (%primitive alloc-g-vector len nil)) + (st (%primitive get-vector-subtype ,object))) + (dotimes (i len) + (setf (svref new i) (svref ,object i))) + (%primitive set-vector-subtype new + (case st + ((2 3) 4) + (t st))) + (poke ,object (%primitive make-immediate-type new %gc-forward-type)) + new)) + + +;;; Scavenge-Symbols -- Internal +;;; +;;; Scan through static symbol space doing a Transport-Function on +;;; the definition of every Fbound symbol between the free pointer +;;; and our clean pointer. The free pointer can move during the process +;;; due to symbols being transported. +;;; +(defmacro scavenge-symbols () + `(do ((free-ptr (peek free-ptr-loc) (peek free-ptr-loc))) + ((eq clean-ptr free-ptr)) + (when (fboundp clean-ptr) + (transport-function (symbol-function clean-ptr))) + (setq clean-ptr (next-symbol clean-ptr)))) +); eval-when (compile eval) + +;;; Mark-Function -- Internal +;;; +;;; Set the referenced bit in any symbol constants, and call +;;; Mark-If-Worthwhile on any which are not marked. +;;; +(defun mark-function (fun) + (let ((len (%primitive header-length fun))) + (do ((i %function-constants-offset (1+ i))) + ((= i len)) + (let ((el (%primitive header-ref fun i))) + (when (symbolp el) + (let ((bits (symbol-bits el))) + (setf (symbol-bits el) (logior referenced-bit bits)) + (when (zerop (logand marked-bit bits)) + (mark-if-worthwhile el)))))))) + + +;;; Mark-If-Worthwhile -- Internal +;;; +;;; Mark the symbol if it is not already marked. If it is appears to +;;; be a symbol likely to be used at runtime, we set the worthwhile +;;; bit as well. +;;; +(defun mark-if-worthwhile (sym) + (when (zerop (logand (symbol-bits sym) marked-bit)) + ;; + ;; Mark it so we know we have been here... + (setf (symbol-bits sym) (logior marked-bit (symbol-bits sym))) + ;; + ;; If fbound and not an open-coded function, walk the function. + (when (and (fboundp sym) (not (inlinep sym))) + (setf (symbol-bits sym) + (logior worthwhile-bit (symbol-bits sym))) + (mark-function (symbol-function sym))) + ;; + ;; If bound and not a inline constant, or neither bound nor fbound, + ;; but has a plist, mark as worthwhile. + (when (if (boundp sym) + (not (and (constantp sym) + (let ((val (symbol-value sym))) + (or (characterp val) (numberp val) (eq sym val))))) + (and (not (fboundp sym)) + (not (null (cddr (symbol-plist sym)))))) + (setf (symbol-bits sym) + (logior worthwhile-bit (symbol-bits sym)))))) + + +;;; Transport-And-Scavenge -- Internal +;;; +;;; Transport a symbol and then scavenge to completion. +;;; +(defun transport-and-scavenge (symbol) + (let* ((free-ptr-loc (free-pointer-location %symbol-type %static-space)) + (clean-ptr (peek free-ptr-loc))) + (transport-symbol symbol) + (scavenge-symbols))) + + +;;; Transport-Function -- Internal +;;; +;;; Grovel the constants of a function object, transporting things +;;; that look useful. If a symbol has the worthwhile bit set, we move it. We +;;; transport conses and g-vectors here so that they can go into read-only +;;; space. If a constant is a compiled function, we recurse on it. +;;; +(defun transport-function (fun) + (unless (purep fun) + (let ((def (ecase (%primitive get-vector-subtype fun) + (#.%function-entry-subtype + (%primitive header-ref fun %function-entry-constants-slot)) + (#.%function-closure-subtype + (%primitive header-ref + (%primitive header-ref fun %function-name-slot) + %function-entry-constants-slot)) + (#.%function-funcallable-instance-subtype + nil)))) + (when def + (do ((i %function-constants-constants-offset (1+ i)) + (length (%primitive header-length def))) + ((= i length)) + (let ((const (%primitive header-ref def i))) + (typecase const + (symbol + (unless (zerop (logand worthwhile-bit (symbol-bits const))) + (transport-symbol const))) + (cons + (transport-cons const)) + (compiled-function + (transport-function const)) + (simple-vector + (transport-g-vector const))))))))) + + +;;; Transport-Cons -- Internal +;;; +;;; Transport a cons and any list structure attached to it into read-only +;;; space and scavenge to completion. +;;; +(defun transport-cons (cons) + (unless (purep cons) + (%primitive set-allocation-space %read-only-space) + (let* ((free-ptr-loc (free-pointer-location %list-type %read-only-space)) + (clean-ptr (peek free-ptr-loc))) + (loop + (loop + (let ((new (cons (car cons) (cdr cons)))) + (poke cons (%primitive make-immediate-type new %gc-forward-type)) + (setq cons (cdr cons)) + (when (or (atom cons) (purep cons)) (return nil)))) + (let ((free-ptr (peek free-ptr-loc))) + (loop + (when (eq clean-ptr free-ptr) + (%primitive set-allocation-space %static-space) + (return-from transport-cons nil)) + (setq cons (car clean-ptr)) + (setq clean-ptr (next-cons clean-ptr)) + (unless (or (atom cons) (purep cons)) (return nil)))))))) + +;;; Transport-G-Vector -- Internal +;;; +;;; Transport a G-Vector into static space. We only bother with +;;; the top level, and leave the rest to GC. +;;; +(defun transport-g-vector (vec &optional read-only) + (unless (purep vec) + (when read-only + (%primitive set-allocation-space %read-only-space)) + (copy-g-vector vec) + (when read-only + (%primitive set-allocation-space %static-space)))) + +;;; Transport-Root -- Internal +;;; +;;; Descend into lists, simple-vectors and compiled functions, transporting +;;; any useful symbols we run into, and scavenging to completion after each. We +;;; transport simple-vectors now so that we don't lose on circular or highly +;;; shared structures. +;;; +(defun transport-root (object) + (unless (purep object) + (typecase object + (symbol + (unless (zerop (logand worthwhile-bit (symbol-bits object))) + (transport-and-scavenge object))) + (simple-vector + (let ((new (copy-g-vector object))) + (dotimes (i (length new)) + (transport-root (svref new i))))) + (cons + (transport-root (car object)) + (transport-root (cdr object))) + (compiled-function + (transport-function object))))) + +;;; Localify -- Internal +;;; +;;; This function goes GC-Like stuff at lisp level to try to increase +;;; the locality in a purified core image. The basic idea is to do a +;;; breadth-first walk of the function objects, moving interesting symbols +;;; into static space. +;;; +(defun localify (root-structures) + (%primitive set-allocation-space %static-space) + ;; + ;; Mark interesting symbols, and those referenced by their definitions. + (do-allocated-symbols (sym %dynamic-space) + (setf (symbol-bits sym) 0)) + (do-allocated-symbols (sym %dynamic-space) + (mark-if-worthwhile sym)) + ;; + ;; Move interesting symbols referenced by the root structures. + (dolist (x root-structures) + (transport-root x)) + ;; + ;; Treat interesting unreferenced symbols as roots... + (do-allocated-symbols (sym %dynamic-space) + (unless (purep sym) + (let ((bits (symbol-bits sym))) + (when (and (zerop (logand referenced-bit bits)) + (not (zerop (logand worthwhile-bit bits)))) + (transport-and-scavenge sym))))) + ;; + ;; Treat referenced symbols as roots... + (do-allocated-symbols (sym %dynamic-space) + (unless (or (purep sym) + (zerop (logand referenced-bit (symbol-bits sym)))) + (transport-and-scavenge sym))) + ;; + ;; Do anything else that wants to be done... + (do-allocated-symbols (sym %dynamic-space) + ;; + ;; Move some selected property values into read-only space. + (macrolet ((movec (prop) + `(let ((val (get sym ',prop))) + (when val (transport-cons val)))) + (movev (prop) + `(let ((val (get sym ',prop))) + (when val (transport-g-vector val t))))) + (movec inline-expansion) + (movec clc::clc-transforms) + (movec clc::clc-args) + (movev %structure-definition) + (movev alien-variable) + (movev alien-stack-info) + (movev alien-operator-info) + (movev enumeration-info)) + ;; + ;; Move some types of variable value... + (when (boundp sym) + (let ((val (symbol-value sym))) + (cond ((purep val)) + ((get sym '%constant) + (typecase val + (cons (transport-cons val)) + (simple-vector (transport-g-vector val t)))) + ((and (structurep val) + (memq (svref val 0) '(clc::%instruction alien-value))) + (transport-g-vector val t))))) + ;; + ;; Move any interned symbol that's left... + (unless (or (purep sym) (not (symbol-package sym))) + (transport-and-scavenge sym))) + + ;; + ;; Reset the bits... + (remprop nil 'purify-symbol-bits) + + (do-allocated-symbols (sym %static-space) + (remprop sym 'purify-symbol-bits)) + + (do-allocated-symbols (sym %dynamic-space) + (remprop sym 'purify-symbol-bits)) + + (%primitive set-allocation-space %dynamic-space)) +); Compiler-Let + +;;;; Save-Stand-Alone-Lisp +;;; +;;; A stand-alone is a lisp that has had everything that doesn't pertain +;;; to a particular application GC'ed away. This can result in a drastic +;;; size reduction, but tends make the Lisp unusable for anything else and +;;; hard to debug in. We do this by blowing away all symbols not directly +;;; referenced and doing a GC. We also blow away random debug info. + + +(defparameter garbage-properties + '(%constant globally-special %constant %fun-documentation %var-documentation + %struct-documentation %type-documentation + %setf-documentation %documentation + setf-method-expander setf-inverse)) + +;;; Save-Stand-Alone-Lisp -- Public +;;; +(defun save-stand-alone-lisp (file root-function) + "Write into File a core file which contains only objects referenced + by Root-Function or needed for the basic system. Root-Function + is called when the core file is resumed. Root-Function should be + a symbol rather than an actual function object." + (let ((all-packages (list-all-packages))) + (fresh-line) + (write-string "[Nuking useless stuff") + (force-output) + ;; + ;; Mark all external symbols so that we can find them later... + ;; We could do this with a property, but this is more fun. + (dolist (p all-packages) + (do-external-symbols (s p) + (setf (symbol-bits s) 1))) + ;; + ;; Nuke all hashtables in packages... + (dolist (p all-packages) + (make-package-hashtable 10 (package-internal-symbols p)) + (make-package-hashtable 10 (package-external-symbols p))) + ;; + ;; Nuke random garbage on all symbols... + (do-allocated-symbols (s %dynamic-space) + ;; + ;; Nuke arglists on functions... + (when (fboundp s) + (let ((fun (symbol-function s))) + (cond ((compiled-function-p fun) + (%primitive header-set fun %function-arg-names-slot ())) + ((and (consp fun) (compiled-function-p (cdr fun))) + (%primitive header-set (cdr fun) %function-arg-names-slot ()))))) + ;; + ;; Nuke unnecessary properties... + (when (symbol-plist s) + (dolist (p garbage-properties) + (when (get s p) + (remprop s p))))) + (write-string "] +[GC'ing it away") + (force-output) + ;; + ;; GC it away.... + (gc nil) + (sleep 30) + (write-string "] +[Snoozing for a minute to let dirty pages get written") + (force-output) + (sleep 60) + ;; + ;; Rebuild packages... + (write-string "] +[Rebuilding packages") + (force-output) + (do-allocated-symbols (s %dynamic-space) + (let ((p (symbol-package s))) + (cond ((null p)) + ((zerop (symbol-bits s)) + (add-symbol (package-internal-symbols p) s)) + (t + (add-symbol (package-external-symbols p) s) + (setf (symbol-bits s) 0))) + (remprop s 'purify-symbol-bits))) + (do-allocated-symbols (s %static-space) + (let ((p (symbol-package s))) + (cond ((null p)) + ((zerop (symbol-bits s)) + (add-symbol (package-internal-symbols p) s)) + (t + (add-symbol (package-external-symbols p) s) + (setf (symbol-bits s) 0))) + (remprop s 'purify-symbol-bits))) + (write-line "]") + (purify :root-structures (list root-function)) + (write-string "[Snoozing for two minutes to let dirty pages get written") + (force-output) + (sleep 120) + (write-line "]") + (if (save file) + (quit) + (funcall root-function)))) diff --git a/code/rand.lisp b/code/rand.lisp new file mode 100644 index 000000000..9bfbe8841 --- /dev/null +++ b/code/rand.lisp @@ -0,0 +1,128 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Functions to random number functions for Spice Lisp +;;; Written by David Adam. +;;; +;;; The random number functions are part of the standard Spicelisp environment. +;;; +;;; ********************************************************************** +;;; +(in-package 'lisp) +(export '(random-state random-state-p random *random-state* + make-random-state)) + +(defconstant random-const-a 8373) +(defconstant random-const-c 101010101) +(defconstant random-upper-bound 134217726) +(defconstant random-max 54) +(defvar rand-seed 0) +(defvar *random-state*) + +(defstruct (random-state (:constructor make-random-object)) + (j 24 :type integer) + (k 0 :type integer) + (seed (make-array (1+ random-max) :initial-contents + (do ((list-rands () (cons (rand1) list-rands)) + (i 0 (1+ i))) + ((> i random-max) list-rands))) + :type simple-vector)) + + +;;; Generates a random number from rand-seed. +(defun rand1 () + (setq rand-seed (mod (+ (* rand-seed random-const-a) random-const-c) + (1+ random-upper-bound)))) + +;;; rand3 -- Internal +;;; +;;; This function generates fixnums between 0 and random-upper-bound, +;;; inclusive For the algorithm to work random-upper-bound must be an +;;; even positive fixnum. State is the random state to use. +;;; +(defun rand3 (state) + (let ((seed (random-state-seed state)) + (j (random-state-j state)) + (k (random-state-k state))) + (declare (fixnum j k) (simple-vector seed)) + (setf (svref seed k) + (let ((a (- random-upper-bound + (svref seed + (setf (random-state-j state) + (if (= j 0) random-max (1- j)))) + (svref seed + (setf (random-state-k state) + (if (= k 0) random-max (1- k))))))) + (if (minusp a) (- a) (- random-upper-bound a)))))) + + +(defun random-init () + (setq *random-state* + (make-random-object :seed + (make-array (1+ random-max) :initial-contents + '(45117816 133464727 86324180 99419799 68851957 87250180 + 52971860 84081967 30854110 121122797 70449044 18801152 + 45149898 15881380 27398356 117706009 49915564 80620628 + 120974070 98193932 43883764 53717012 100954825 82579490 + 17280729 118523949 42282975 127220348 6288263 56575578 + 2474156 47934425 561006 21989698 74046730 105055318 + 113363907 48749716 78183593 109613585 37323232 65101428 + 46453209 76906562 5371267 86544820 33922642 60765033 + 41889257 77176406 38775255 78514879 72553872 66916641 + 100613180))))) + +(defun copy-state (cur-state) + (let ((state (make-random-object + :seed (make-array 55) + :j (random-state-j cur-state) + :k (random-state-k cur-state)))) + (do ((i 0 (1+ i))) + ((= i 55) state) + (declare (fixnum i)) + (setf (aref (random-state-seed state) i) + (aref (random-state-seed cur-state) i))))) + +(defun make-random-state (&optional state) + "Make a random state object. If State is not supplied, return a copy + of the default random state. If State is a random state, then return a + copy of it. If state is T then return a random state generated from + the universal time." + (cond ((not state) (copy-state *random-state*)) + ((random-state-p state) (copy-state state)) + ((eq state t) (setq rand-seed (get-universal-time)) + (make-random-object)) + (t (error "Bad argument, ~A, for RANDOM-STATE." state)))) + +(proclaim '(ftype (function (t) fixnum) rand3)) +(defun random (arg &optional (state *random-state*)) + "Generate a uniformly distributed pseudo-random number between zero + and Arg. State, if supplied, is the random state to use." + (typecase arg + (fixnum + (unless (plusp (the fixnum arg)) + (error "Non-positive argument, ~A, to RANDOM." arg)) + (rem (the fixnum (rand3 state)) (the fixnum arg))) + (float + (unless (plusp arg) + (error "Non-positive argument, ~A, to RANDOM." arg)) + (let ((arg-length (typecase arg + (short-float %short-float-mantissa-length) + (single-float %single-float-mantissa-length) + (double-float %double-float-mantissa-length) + (long-float %long-float-mantissa-length)))) + (* arg (/ (float (random (ash 2 arg-length) state)) + (float (ash 2 arg-length)))))) + (integer + (unless (plusp arg) + (error "Non-positive argument, ~A, to RANDOM." arg)) + (do ((tot (rand3 state) (+ (ash tot %fixnum-length) (rand3 state))) + (end (ash arg (- %fixnum-length)) + (ash end (- %fixnum-length)))) + ((zerop end) (mod tot arg)))) + (t (error "Wrong type argument, ~A, to RANDOM." arg)))) diff --git a/code/reader.lisp b/code/reader.lisp new file mode 100644 index 000000000..d6827f54d --- /dev/null +++ b/code/reader.lisp @@ -0,0 +1,1302 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Spice Lisp Reader +;;; Written by David Dill +;;; Package system interface by Lee Schumacher. +;;; Runs in the standard Spice Lisp environment. +;;; +(in-package 'lisp) +(export '(readtable readtablep *read-base* *readtable* copy-readtable + set-syntax-from-char set-macro-character get-macro-character + make-dispatch-macro-character set-dispatch-macro-character + get-dispatch-macro-character + read *read-default-float-format* read-preserving-whitespace + read-delimited-list parse-integer read-from-string *read-suppress*)) + +;;;Random global variables + +(defvar *read-default-float-format* 'single-float "Float format for 1.0E1") + +(defvar *readtable* () "Variable bound to current readtable.") + + + +;;;; Readtable implementation. + +;;; The readtable is a structure with three components: the +;;; CHARACTER-ATTRIBUTE-TABLE is a vector of 128 integers for describing the +;;; character type. Conceptually, there are 4 distinct "primary" character +;;; attributes (WHITESPACE, TERMINATING-MACRO, ESCAPE, and CONSTITUENT -- +;;; non-terminating macros have the attribute CONSTITUENT, and the symbol +;;; reader is implemented as a non-terminating macro), and a number of +;;; "secondary" attributes that are used by the function READ-QUALIFIED-TOKEN, +;;; which apply only when the primary attribute is CONSTITUENT. In order to +;;; make the READ-QUALIFIED-TOKEN fast, all this information is stored in the +;;; character attribute table by having different varieties of constituents. +;;; In order to conform with the white pages, the primary attributes should be +;;; moved by SET-SYNTAX-FROM-CHARACTER and SET-MACRO-CHARACTER, while the +;;; secondary attributes are constant properties of the characters (as long as +;;; they are constituents). + + +;;; The CHARACTER-MACRO-TABLE is a vector of 128 functions. One of these +;;; functions called with appropriate arguments whenever any non-WHITESPACE +;;; character is encountered inside READ-PRESERVING-WHITESPACE. These +;;; functions are used to implement user-defined read-macros, system +;;; read-macros, and the number-symbol reader. Finally, there is a +;;; DISPATCH-TABLES entry, which is an alist from dispatch characters to +;;; vectors of 128 functions, for use in defining dispatching macros (like +;;; #-macro). + +(defvar std-lisp-readtable () + "Standard lisp readtable. This is for recovery from broken + read-tables, and should not normally be user-visible.") + +(defstruct (readtable + (:conc-name nil) + (:predicate readtablep) + (:copier nil)) + "Readtable is a data structure that maps characters into syntax + types for the Common Lisp expression reader." + (character-attribute-table (make-character-attribute-table) :type simple-vector) + (character-macro-table (make-character-macro-table) :type simple-vector) + (dispatch-tables () :type list)) + + + +;;;; Constants for character attributes. These are all as in the manual. + +(eval-when (compile load eval) + (defconstant whitespace 0) + (defconstant terminating-macro 1) + (defconstant escape 2) + (defconstant constituent 3) + (defconstant constituent-dot 4) + (defconstant constituent-expt 5) + (defconstant constituent-slash 6) + (defconstant constituent-digit 7) + (defconstant constituent-sign 8) + (defconstant sharp-sign 9) + (defconstant multiple-escape 10) + (defconstant package-delimiter 11) + ;;fake attribute for use in read-unqualified-token + (defconstant delimiter 12)) + + + +;;;; Package specials. + +(defvar *old-package* () + "Value of *package* at the start of the last read or Nil.") + +;;; In case we get an error trying to parse a symbol, we want to rebind the +;;; above stuff so it's cool. + +(proclaim '(special *package* *keyword-package* *read-base*)) + + + +;;;; Macros and functions for character tables. + +(defmacro get-cat-entry (char rt) + ;;only give this side-effect-free args. + `(elt (the simple-vector (character-attribute-table ,rt)) + (char-int ,char))) + +(defun set-cat-entry (char newvalue &optional (rt *readtable*)) + (setf (elt (the simple-vector (character-attribute-table rt)) + (char-int char)) + newvalue)) + +(defmacro get-cmt-entry (char rt) + `(elt (the simple-vector (character-macro-table ,rt)) + (char-int ,char))) + +(defun set-cmt-entry (char newvalue &optional (rt *readtable*)) + (setf (elt (the simple-vector (character-macro-table rt)) + (char-int char)) + newvalue)) + +(defun make-character-attribute-table () + (make-array 256 :element-type t :initial-element #.constituent)) + +(defun make-character-macro-table () + (make-array 256 :element-type t + :initial-element #'undefined-macro-char)) + +(defun undefined-macro-char (ignore char) + (declare (ignore ignore)) + (error "Undefined read-macro character ~S" char)) + + +;;; The character attribute table is a 128-long vector of integers. + +(defmacro test-attribute (char whichclass rt) + `(= (the fixnum (get-cat-entry ,char ,rt)) ,whichclass))) + +;;; Predicates for testing character attributes + +;;; Make this a function, since other people want to use it. +;;; +(proclaim '(inline whitespacep)) +(defun whitespacep (char &optional (rt *readtable*)) + (test-attribute char whitespace rt)) + +(defmacro constituentp (char &optional (rt '*readtable*)) + `(>= (get-cat-entry ,char ,rt) #.constituent)) + +(defmacro terminating-macrop (char &optional (rt '*readtable*)) + `(test-attribute ,char #.terminating-macro ,rt)) + +(defmacro escapep (char &optional (rt '*readtable*)) + `(test-attribute ,char #.escape ,rt)) + +(defmacro multiple-escape-p (char &optional (rt '*readtable*)) + `(test-attribute ,char #.multiple-escape ,rt)) + +(defmacro token-delimiterp (char &optional (rt '*readtable*)) + ;;depends on actual attribute numbering above. + `(<= (get-cat-entry ,char ,rt) #.terminating-macro)) + + + +;;;; Secondary attribute table. + +(defvar secondary-attribute-table ()) + +(defun set-secondary-attribute (char attribute) + (setf (elt (the simple-vector secondary-attribute-table) (char-int char)) + attribute)) + + +(defun init-secondary-attribute-table () + (setq secondary-attribute-table + (make-array 128 :element-type t + :initial-element #.constituent)) + (set-secondary-attribute #\: #.package-delimiter) + (set-secondary-attribute #\| #.multiple-escape) ; |) [For EMACS] + (set-secondary-attribute #\. #.constituent-dot) + (set-secondary-attribute #\+ #.constituent-sign) + (set-secondary-attribute #\- #.constituent-sign) + (set-secondary-attribute #\/ #.constituent-slash) + (do ((i (char-int #\0) (1+ i))) + ((> i (char-int #\9))) + (set-secondary-attribute (int-char i) #.constituent-digit)) + (set-secondary-attribute #\E #.constituent-expt) + (set-secondary-attribute #\F #.constituent-expt) + (set-secondary-attribute #\D #.constituent-expt) + (set-secondary-attribute #\S #.constituent-expt) + (set-secondary-attribute #\L #.constituent-expt) + (set-secondary-attribute #\e #.constituent-expt) + (set-secondary-attribute #\f #.constituent-expt) + (set-secondary-attribute #\d #.constituent-expt) + (set-secondary-attribute #\s #.constituent-expt) + (set-secondary-attribute #\l #.constituent-expt)) + +(defmacro get-secondary-attribute (char) + `(elt (the simple-vector secondary-attribute-table) + (char-int ,char))) + + + +;;;; Readtable operations. + +(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable) + "A copy is made of from-readtable and place into to-readtable." + (if (null from-readtable) (setq from-readtable std-lisp-readtable)) + (if (null to-readtable) (setq to-readtable (make-readtable))) + ;;physically clobber contents of internal tables. + (replace (character-attribute-table to-readtable) + (character-attribute-table from-readtable)) + (replace (character-macro-table to-readtable) + (character-macro-table from-readtable)) + (setf (dispatch-tables to-readtable) + (mapcar #'(lambda (pair) (cons (car pair) + (copy-seq (cdr pair)))) + (dispatch-tables from-readtable))) + to-readtable) + +(defun set-syntax-from-char (to-char from-char &optional + (to-readtable *readtable*) + (from-readtable ())) + "Causes the syntax of to-char to be the same as from-char in the + optional readtable (defaults to the current readtable). The + from-table defaults the standard lisp readtable by being nil." + (if (null from-readtable) (setq from-readtable std-lisp-readtable)) + ;;copy from-char entries to to-char entries, but make sure that if + ;;from char is a constituent you don't copy non-movable secondary + ;;attributes (constituent types), and that said attributes magically + ;;appear if you transform a non-constituent to a constituent. + (let ((att (get-cat-entry from-char from-readtable))) + (if (constituentp from-char from-readtable) + (setq att (get-secondary-attribute to-char))) + (set-cat-entry to-char att to-readtable) + (set-cmt-entry to-char + (get-cmt-entry from-char from-readtable) + to-readtable) + NIL)) + +(defun set-macro-character (char function &optional + (non-terminatingp nil) (rt *readtable*)) + "Causes char to be a macro character which invokes function when + seen by the reader. The non-terminatingp flag can be used to + make the macro character non-terminating. The optional readtable + argument defaults to the current readtable. Set-macro-character + returns T." + (if non-terminatingp + (set-cat-entry char (get-secondary-attribute char) rt) + (set-cat-entry char #.terminating-macro rt)) + (set-cmt-entry char function rt) + T) + +(defun get-macro-character (char &optional (rt *readtable*)) + "Returns the function associated with the specified char + which is a macro character. The optional readtable argument + defaults to the current readtable." + ;;check macro syntax, return associated function if it's there. + ;;returns a value for all constituents. + (cond ((constituentp char) + (values (get-cmt-entry char rt) t)) + ((terminating-macrop char) + (values (get-cmt-entry char rt) nil)) + (t nil))) + + + +;;;; These definitions support internal programming conventions. + +(defconstant eof-object '(*eof*)) + +(defmacro eofp (char) `(eq ,char eof-object)) + +(defun flush-whitespace (stream) + ;;This flushes whitespace chars, returning the last char it read (a non-white + ;;one). It always gets an error on end-of-file. + (prepare-for-fast-read-char stream + (do ((attribute-table (character-attribute-table *readtable*)) + (char (fast-read-char t) (fast-read-char t))) + ((/= (the fixnum (svref attribute-table (char-int char))) #.whitespace) + (done-with-fast-read-char) + char)))) + + + +;;;; Temporary initialization hack. + +(defun init-std-lisp-readtable () + (setq std-lisp-readtable (make-readtable)) + ;;all characters default to "constituent" in make-readtable + ;;*** un-constituent-ize some of these *** + (let ((*readtable* std-lisp-readtable)) + (set-cat-entry #\tab #.whitespace) + (set-cat-entry #\linefeed #.whitespace) + (set-cat-entry #\space #.whitespace) + (set-cat-entry #\page #.whitespace) + (set-cat-entry #\return #.whitespace) + (set-cat-entry #\\ #.escape) + (set-cmt-entry #\\ #'read-token) + (set-cat-entry #\rubout #.whitespace) + (set-cmt-entry #\: #'read-token) + (set-cmt-entry #\| #'read-token) + ;;macro definitions + (set-macro-character #\" #'read-string) + ;;* # macro + (set-macro-character #\' #'read-quote) + (set-macro-character #\( #'read-list) + (set-macro-character #\) #'read-right-paren) + (set-macro-character #\; #'read-comment) + ;;* backquote + ;;all constituents + (do ((ichar 0 (1+ ichar)) + (char)) + ((= ichar #O200)) + (setq char (int-char ichar)) + (when (constituentp char std-lisp-readtable) + (set-cat-entry char (get-secondary-attribute char)) + (set-cmt-entry char #'read-token))))) + + + +;;;; read-buffer implementation. + +(defvar read-buffer) +(defvar read-buffer-length) + +(defvar inch-ptr) +(defvar ouch-ptr) + +(defmacro reset-read-buffer () + ;;turn read-buffer into an empty read-buffer. + ;;ouch-ptr always points to next char to write + `(progn + ;;next is in case interrupt processor has re-bound read-buffer to nil. + (unless (or (boundp 'read-buffer) read-buffer) (init-read-buffer)) + (setq ouch-ptr 0) + ;;inch-ptr always points to next char to read + (setq inch-ptr 0))) + +(defun init-read-buffer () + (setq read-buffer (make-string 512)) ;initial bufsize + (setq read-buffer-length 512) + (reset-read-buffer)) + +(defmacro ouch-read-buffer (char) + `(progn + (if (>= (the fixnum ouch-ptr) + (the fixnum read-buffer-length)) + ;;buffer overflow -- double the size + (grow-read-buffer)) + (setf (elt (the simple-string read-buffer) ouch-ptr) ,char) + (setq ouch-ptr (1+ ouch-ptr)))) +;; macro to move ouch-ptr back one. +(defmacro ouch-unread-buffer () + '(if (> (the fixnum ouch-ptr) (the fixnum inch-ptr)) + (setq ouch-ptr (1- (the fixnum ouch-ptr))))) + +(defun grow-read-buffer () + (let ((rbl (length (the simple-string read-buffer)))) + (declare (fixnum rbl)) + (setq read-buffer + (concatenate 'simple-string + (the simple-string read-buffer) + (the simple-string (make-string rbl)))) + (setq read-buffer-length (* 2 rbl)))) + +(defun inchpeek-read-buffer () + (if (>= (the fixnum inch-ptr) (the fixnum ouch-ptr)) + eof-object + (elt (the simple-string read-buffer) inch-ptr))) + +(defun inch-read-buffer () + (cond ((>= (the fixnum inch-ptr) (the fixnum ouch-ptr)) + eof-object) + (t (prog1 (elt (the simple-string read-buffer) inch-ptr) + (setq inch-ptr (1+ (the fixnum inch-ptr))))))) + +(defmacro unread-buffer () + `(decf (the fixnum inch-ptr))) + +(defun read-unwind-read-buffer () + ;;keep contents, but make next (inch..) return first char. + (setq inch-ptr 0)) + +(defun read-buffer-to-string () + (subseq (the simple-string read-buffer) 0 ouch-ptr)) + + + +;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ. + +(defvar *real-eof-errorp* () + "Value checked by reader if recursivep is true.") +(defvar *real-eof-value* () + "Eof-value used for eof-value if recursivep is true.") + +(defvar right-paren-whitespace t + "Flag that READ uses to tell when it's ok to treat right parens as + whitespace.") + +;; Alist for sharp-equal. Used to keep track of objects with labels assigned +;; that have been completly read. +(defvar sharp-equal-alist ()) + +;; Alist for sharp-sharp. Assoc's a number with a symbol produced by gensym. +;; Used by sharp-sharp as an unforgeable label, instead of the number. +(defvar sharp-sharp-alist ()) + +(proclaim '(special *standard-input*)) + +;;; READ-PRESERVING-WHITESPACE behaves just like read only it makes sure +;;; to leave terminating whitespace in the stream. +;;; +(defun read-preserving-whitespace + (&optional (stream *standard-input*) (eof-errorp t) (eof-value ()) + (recursivep ())) + "Reads from stream and returns the object read, preserving the whitespace + that followed the object." + (let ((*real-eof-value* *real-eof-value*) + (*real-eof-errorp* *real-eof-errorp*)) + (if recursivep + (setq eof-errorp *real-eof-errorp* + eof-value *real-eof-value*) + (setq *real-eof-value* eof-value + *real-eof-errorp* eof-errorp + ;; The scope of these two lists is the top level read, so they + ;; have to be reset here. + sharp-equal-alist nil + sharp-sharp-alist nil)) + (progn + ;;loop for repeating when a macro returns nothing. + (do ((char (read-char stream nil eof-object) + (read-char stream nil eof-object))) + (()) + (cond ((eofp char) + (if eof-errorp + (error "Unexpected end-of-file encountered.") + (return eof-value))) + ((whitespacep char)) + (t + (let* ((macrofun (get-cmt-entry char *readtable*)) + (result (multiple-value-list + (funcall macrofun stream char)))) + ;;repeat if macro returned nothing. + (if result (return (car result)))))))))) + +(defun read-maybe-nothing (stream char) + ;;returns nil or a list with one thing, depending. + ;;for functions that want comments to return so they can look + ;;past them. Assumes char is not whitespace. + (let ((retval (multiple-value-list + (funcall (get-cmt-entry char *readtable*) stream char)))) + (if retval (rplacd retval nil)))) + +(defun read (&optional (stream *standard-input*) (eof-errorp t) + (eof-value ()) (recursivep ())) + "Reads in the next object in the stream, which defaults to + *standard-input*. For details see the I/O chapter of + the manual." + (prog1 + (read-preserving-whitespace stream eof-errorp eof-value recursivep) + (let ((whitechar (read-char stream nil eof-object))) + (if (and (not (eofp whitechar)) + (or (not (whitespacep whitechar)) + recursivep)) + (unread-char whitechar stream))))) + +(defun read-delimited-list (endchar &optional + (input-stream *standard-input*) + recursive-p) + "Reads objects from input-stream until the next character after an + object's representation is endchar. A list of those objects read + is returned." + (declare (ignore recursive-p)) + (do ((char (flush-whitespace input-stream) + (flush-whitespace input-stream)) + (retlist ())) + ((char= char endchar) (nreverse retlist)) + (setq retlist (nconc (read-maybe-nothing input-stream char) retlist)))) + + + +;;;; Standard ReadMacro definitions to implement the reader. + +(defun read-quote (stream ignore) + (declare (ignore ignore)) + (list 'quote (read stream () () t))) + +(defun read-comment (stream ignore) + (declare (ignore ignore)) + (prepare-for-fast-read-char stream + (do ((char (fast-read-char nil nil) + (fast-read-char nil nil))) + ((or (not char) (char= char #\newline)) + (done-with-fast-read-char)))) + ;;don't return anything + (values)) + +(defun read-list (stream ignore) + (declare (ignore ignore)) + (let* ((thelist (list nil)) + (listtail thelist)) + (do ((firstchar (flush-whitespace stream) (flush-whitespace stream))) + ((char= firstchar #\) ) (cdr thelist)) + (when (char= firstchar #\.) + (let ((nextchar (read-char stream t))) + (cond ((token-delimiterp nextchar) + (cond ((eq listtail thelist) + (error "Nothing appears before . in list.")) + ((whitespacep nextchar) + (setq nextchar (flush-whitespace stream)))) + (rplacd listtail + ;;return list containing last thing. + (car (read-after-dot stream nextchar))) + (return (cdr thelist))) + ;;put back nextchar so we can read it normally. + (t (unread-char nextchar stream))))) + ;;next thing is not an isolated dot. + (let ((listobj (read-maybe-nothing stream firstchar))) + ;;allows the possibility that a comment was read. + (when listobj + (rplacd listtail listobj) + (setq listtail listobj)))))) + +(defun read-after-dot (stream firstchar) + ;;firstchar is non-whitespace! + (let ((lastobj ())) + (do ((char firstchar (flush-whitespace stream))) + ((char= char #\) ) + (error "Nothing appears after . in list.")) + ;;see if there's something there. + (setq lastobj (read-maybe-nothing stream char)) + (when lastobj (return t))) + ;;at least one thing appears after the dot. + ;;check for more than one thing following dot. + (do ((lastchar (flush-whitespace stream) + (flush-whitespace stream))) + ((char= lastchar #\) ) lastobj) ;success! + ;;try reading virtual whitespace + (if (read-maybe-nothing stream lastchar) + (error "More than one object follows . in list."))))) + +(defun read-string (stream closech) + ;;this accumulates chars until it sees same char that invoked it. + ;;for a very long string, this could end up bloating the read buffer. + (reset-read-buffer) + (prepare-for-fast-read-char stream + (do ((char (fast-read-char t) (fast-read-char t))) + ((char= char closech) + (done-with-fast-read-char)) + (if (escapep char) (setq char (fast-read-char t))) + (ouch-read-buffer char))) + (read-buffer-to-string)) + +(defun read-right-paren (ig1 ig2) + (declare (ignore ig1 ig2)) + (if right-paren-whitespace + (values) + (error "Unmatched right parenthesis."))) + +(defun internal-read-extended-token (stream firstchar + &aux (escape-appearedp nil)) + ;;read the string up to the next delimiter. Leaves resulting token + ;;in read-buffer, returns a flag that is true if an escape (\\) + ;;appeared, meaning that it has to be a symbol. + ;;needs to have package hacks added. + (reset-read-buffer) + (do ((char firstchar (read-char stream nil eof-object))) + ;;for now, treat #\: as a constituent: + ;; does this cond need same fix as the top-level read did ?? + ((cond ((eofp char) t) + ((token-delimiterp char) + (unread-char char stream) + t) + (t nil)) + escape-appearedp) + (cond ((escapep char) + ;;it can't be a number, even if it's 1\23. + (setq escape-appearedp t) + ;;read next char here, so it won't be upper-casified. + (let ((nextchar (read-char stream nil eof-object))) + (if (eofp nextchar) + (error "End-of-file after escape character.") + (ouch-read-buffer nextchar)))) + (t (ouch-read-buffer (char-upcase char)))))) + + + +;;;; Character classes. + +;;; return the character class for a char +;;; +(defmacro char-class (char attable) + `(let ((att (svref ,attable (char-int ,char)))) + (declare (fixnum att)) + (if (<= att #.terminating-macro) + #.delimiter + att))) + +;;; return the character class for a char which might be part of a rational +;;; number +;;; +(defmacro char-class2 (char attable) + `(let ((att (svref ,attable (char-int ,char)))) + (declare (fixnum att)) + (if (<= att #.terminating-macro) + #.delimiter + (if (digit-char-p ,char *read-base*) + constituent-digit + (if (= att constituent-digit) + constituent + att))))) + +;;; return the character class for a char which might be part of a rational or +;;; floating number (assume that it is a digit if it could be) +;;; +(defmacro char-class3 (char attable) + `(let ((att (svref ,attable (char-int ,char)))) + (declare (fixnum att)) + (if possibly-rational + (setq possibly-rational + (or (digit-char-p ,char *read-base*) + (= att constituent-slash)))) + (if possibly-float + (setq possibly-float + (or (digit-char-p ,char 10) + (= att constituent-dot)))) + (if (<= att #.terminating-macro) + #.delimiter + (if (digit-char-p ,char (max *read-base* 10)) + (if (digit-char-p ,char *read-base*) + constituent-digit + constituent) + att)))) + + + +;;;; Token fetching. + +#| +(defmacro backup-char (char stream) + `(if ,char (unread-char ,char ,stream))) +|# + +(defvar *read-suppress* nil + "Suppresses most interpreting of the reader when T") + +(defvar *read-base* 10 + "The radix that Lisp reads numbers in.") + +(defun read-token (stream firstchar) + "This function is just an fsm that recognizes numbers and symbols." + ;;check explicitly whether firstchar has entry for non-terminating + ;;in character-attribute-table and read-dot-number-symbol in CMT. + ;;Report an error if these are violated (if we called this, we want + ;;something that is a legitimate token!). + ;;read in the longest possible string satisfying the bnf for + ;;"unqualified-token". Leave the result in the READ-BUFFER. + ;;Return next char after token (last char read). + (if *read-suppress* + (internal-read-extended-token stream firstchar) + (let ((attribute-table (character-attribute-table *readtable*)) + (package *package*) + (colons 0) + (possibly-rational t) + (possibly-float t)) + (reset-read-buffer) + (prog ((char firstchar)) + (case (char-class3 char attribute-table) + (#.constituent-sign (go SIGN)) + (#.constituent-digit (go LEFTDIGIT)) + (#.constituent-dot (go FRONTDOT)) + (#.escape (go ESCAPE)) + (#.package-delimiter (go COLON)) + (#.multiple-escape (go MULT-ESCAPE)) + ;;can't have eof, whitespace, or terminating macro as first char! + (t (go SYMBOL))) + SIGN + ;;saw "sign" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (setq possibly-rational t + possibly-float t) + (case (char-class3 char attribute-table) + (#.constituent-digit (go LEFTDIGIT)) + (#.constituent-dot (go SIGNDOT)) + (#.escape (go ESCAPE)) + (#.package-delimiter (go COLON)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (t (go SYMBOL))) + LEFTDIGIT + ;;saw "[sign] {digit}+" + (ouch-read-buffer (char-upcase char)) + (setq char (read-char stream nil nil)) + (unless char (return (make-integer))) + (case (char-class3 char attribute-table) + (#.constituent-digit (go LEFTDIGIT)) + (#.constituent-dot (if possibly-float + (go MIDDLEDOT) + (go SYMBOL))) + (#.constituent-expt (go EXPONENT)) + (#.constituent-slash (if possibly-rational + (go RATIO) + (go SYMBOL))) + (#.delimiter (unread-char char stream) (return (make-integer))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + MIDDLEDOT + ;;saw "[sign] {digit}+ dot" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (let ((*read-base* 10)) + (make-integer)))) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.constituent-expt (go EXPONENT)) + (#.delimiter (unread-char char stream) (return (let ((*read-base* 10)) + (make-integer)))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + RIGHTDIGIT + ;;saw "[sign] {digit}* dot {digit}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-float))) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.constituent-expt (go EXPONENT)) + (#.delimiter (unread-char char stream) (return (make-float))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + SIGNDOT + ;;saw "[sign] dot" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (t (go SYMBOL))) + FRONTDOT + ;;saw "dot" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (error "Dot context error.")) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.constituent-dot (go DOTS)) + (#.delimiter (error "Dot context error.")) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + EXPONENT + (ouch-read-buffer (char-upcase char)) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.constituent-sign (go EXPTSIGN)) + (#.constituent-digit (go EXPTDIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + EXPTSIGN + ;;we got to EXPONENT, and saw a sign character. + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.constituent-digit (go EXPTDIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + EXPTDIGIT + ;;got to EXPONENT, saw "[sign] {digit}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-float))) + (case (char-class char attribute-table) + (#.constituent-digit (go EXPTDIGIT)) + (#.delimiter (unread-char char stream) (return (make-float))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + RATIO + ;;saw "[sign] {digit}+ slash" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class2 char attribute-table) + (#.constituent-digit (go RATIODIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + RATIODIGIT + ;;saw "[sign] {digit}+ slash {digit}+" + (ouch-read-buffer (char-upcase char)) + (setq char (read-char stream nil nil)) + (unless char (return (make-ratio))) + (case (char-class2 char attribute-table) + (#.constituent-digit (go RATIODIGIT)) + (#.delimiter (unread-char char stream) (return (make-ratio))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + DOTS + ;;saw "dot {dot}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (error "Too many dots.")) + (case (char-class char attribute-table) + (#.constituent-dot (go DOTS)) + (#.delimiter (unread-char char stream) (error "Too many dots.")) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + SYMBOL + ;;not a dot, dots, or number. + (prepare-for-fast-read-char stream + (prog () + SYMBOL-LOOP + (ouch-read-buffer (char-upcase char)) + (setq char (fast-read-char nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.escape (done-with-fast-read-char) + (go ESCAPE)) + (#.delimiter (done-with-fast-read-char) + (unread-char char stream) + (go RETURN-SYMBOL)) + (#.multiple-escape (done-with-fast-read-char) + (go MULT-ESCAPE)) + (#.package-delimiter (done-with-fast-read-char) + (go COLON)) + (t (go SYMBOL-LOOP))))) + ESCAPE + ;;saw an escape. + ;;don't put the escape in the read-buffer. + ;;read-next char, put in buffer (no case conversion). + (let ((nextchar (read-char stream nil nil))) + (if nextchar + (ouch-read-buffer nextchar) + (error "End-of-file after escape character."))) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + MULT-ESCAPE + (do ((char (read-char stream t) (read-char stream t))) + ((multiple-escape-p char)) + (if (escapep char) (setq char (read-char stream t))) + (ouch-read-buffer char)) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + COLON + (cond ((zerop colons) + (setq colons 1) + (setq package (find-package (read-buffer-to-string))) + (unless package (error "Package ~S not found." + (read-buffer-to-string)))) + (t (error "Too many colons in ~S" (read-buffer-to-string)))) + (reset-read-buffer) + (setq char (read-char stream nil nil)) + (unless char (error "End of file encountered after reading a colon.")) + (case (char-class char attribute-table) + (#.delimiter (unread-char char stream) + (error "Illegal terminating character after a colon, ~S." + char)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go INTERN)) + (t (go SYMBOL))) + INTERN + (setq colons 2) + (setq char (read-char stream nil nil)) + (unless char (error "End of file encountered after reading a colon.")) + (case (char-class char attribute-table) + (#.delimiter (unread-char char stream) + (error "Illegal terminating character after a colon, ~S" + char)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (error "To many colons after ~S:" + (package-name package))) + (t (go SYMBOL))) + RETURN-SYMBOL + (if (or (zerop colons) (= colons 2) (eq package *keyword-package*)) + (return (intern* read-buffer ouch-ptr package)) + (multiple-value-bind (symbol test) + (find-symbol* read-buffer ouch-ptr package) + (cond ((eq test :external) (return symbol)) + ((null test) + (error "Symbol ~S not found in the ~A package." + (read-buffer-to-string) (package-name package))) + (t (cerror "use symbol anyway." + "The symbol ~S is not external in the ~A package." + (read-buffer-to-string) (package-name package)) + (return symbol))))))))) + + +(defun read-extended-token (stream &optional (*readtable* *readtable*)) + ;;for semi-external use: returns 2 values: the string for the token, + ;;and a flag for whether there was an escape char. + (let ((firstch (read-char stream nil nil t))) + (if firstch + (let ((escape-appearedp (internal-read-extended-token stream firstch))) + (values (read-buffer-to-string) escape-appearedp)) + (values "" nil)))) + + + +;;;; Number reading functions. + +(defmacro digit* nil + `(do ((ch char (inch-read-buffer))) + ((or (eofp ch) (not (digit-char-p ch))) (setq char ch)) + ;;report if at least one digit is seen: + (setq one-digit t))) + +(defmacro exponent-letterp (letter) + `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d))) + + +(defvar *integer-reader-safe-digits* + '#(NIL NIL + 26 17 13 11 10 9 8 8 8 7 7 7 7 6 6 6 6 6 6 6 6 5 5 5 5 5 5 5 5 5 5 5 5 5 5) + "Holds the mapping of base to 'safe' number of digits to read for a fixnum.") + +(defvar *integer-reader-base-power* + '#(NIL NIL + 67108864 129140163 67108864 48828125 60466176 40353607 + 16777216 43046721 100000000 19487171 35831808 62748517 105413504 11390625 + 16777216 24137569 34012224 47045881 64000000 85766121 113379904 6436343 + 7962624 9765625 11881376 14348907 17210368 20511149 24300000 28629151 + 33554432 39135393 45435424 52521875 60466176) + "Holds the largest fixnum power of the base for make-integer.") + +#| +(defun init-integer-reader () + (do ((base 2 (1+ base))) + ((> base 36)) + (let ((digits + (do ((fix (truncate most-positive-fixnum base) + (truncate fix base)) + (digits 0 (1+ digits))) + ((zerop fix) digits)))) + (setf (aref *integer-reader-safe-digits* base) + digits + (aref *integer-reader-base-power* base) + (expt base digits))))) +|# + +(defun make-integer () + "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits, + then multiplying by a power of the base and adding." + (let* ((base (if (boundp '*read-base*) + (if (and (fixnump *read-base*) + (<= 1 *read-base* 36)) + *read-base* + (error "~A not a valid number for *read-base*." + *read-base*)) + 10.)) + (digits-per (aref *integer-reader-safe-digits* base)) + (base-power (aref *integer-reader-base-power* base)) + (negativep nil) + (number 0)) + (read-unwind-read-buffer) + (let ((char (inch-read-buffer))) + (cond ((char= char #\-) + (setq negativep t)) + ((char= char #\+)) + (t (unread-buffer)))) + (loop + (let ((num 0)) + (dotimes (digit digits-per) + (let* ((ch (inch-read-buffer))) + (cond ((or (eofp ch) (char= ch #\.)) + (return-from make-integer + (let ((Res + (if (zerop number) num + (+ num (* number + (expt base digit)))))) + (if negativep (- res) res)))) + (t (setq num (+ (digit-char-p ch base) (* num base))))))) + (setq number (+ num (* number base-power))))))) + + + +(defun make-float () + ;;assume that the contents of read-buffer are a legal float, with nothing + ;;else after it. + (read-unwind-read-buffer) + (let ((negative-fraction nil) + (number 0) + (divisor 1) + (negative-exponent nil) + (exponent 0) + (float-char ()) (char (inch-read-buffer))) + (if (cond ((char= char #\+) t) + ((char= char #\-) (setq negative-fraction t))) + ;;flush it + (setq char (inch-read-buffer))) + ;;read digits before the dot + (do* ((ch char (inch-read-buffer)) + (dig (digit-char-p ch) (digit-char-p ch))) + ((not dig) (setq char ch)) + (setq number (+ (* number 10) dig))) + ;;deal with the dot, if it's there. + (when (char= char #\.) + (setq char (inch-read-buffer)) + ;;read digits after the dot. + (do* ((ch char (inch-read-buffer)) + (dig (and (not (eofp ch)) (digit-char-p ch)) + (and (not (eofp ch)) (digit-char-p ch)))) + ((not dig) (setq char ch)) + (setq divisor (* divisor 10)) + (setq number (+ (* number 10) dig)))) + ;;is there an exponent letter? + (cond ((eofp char) + ;;if not, we've read the whole number. + (let ((num (make-float-aux number divisor + *read-default-float-format*))) + (return-from make-float (if negative-fraction (- num) num)))) + ((exponent-letterp char) + (setq float-char char) + ;;build exponent + (setq char (inch-read-buffer)) + ;;check leading sign + (if (cond ((char= char #\+) t) + ((char= char #\-) (setq negative-exponent t))) + ;;flush sign + (setq char (inch-read-buffer))) + ;;read digits for exponent + (do* ((ch char (inch-read-buffer)) + (dig (and (not (eofp ch)) (digit-char-p ch)) + (and (not (eofp ch)) (digit-char-p ch)))) + ((not dig) + (setq exponent (if negative-exponent (- exponent) exponent))) + (setq exponent (+ (* exponent 10) dig))) + ;;generate and return the float, depending on float-char: + (let* ((float-format (case float-char + (#\E *read-default-float-format*) + (#\S 'short-float) + (#\F 'single-float) + (#\D 'double-float) + (#\L 'long-float))) + (num (make-float-aux number divisor float-format))) + (setq num (* num (expt 10 exponent))) + (return-from make-float (if negative-fraction (- num) num)))) + ;;should never happen: + (t (error "Internal error in floating point reader."))))) + +(defun make-float-aux (number divisor float-format) + (let ((fgcd (gcd number divisor))) + (when (/= fgcd 1) + (setq number (truncate number fgcd)) + (setq divisor (truncate divisor fgcd)))) + (when (= divisor 1) + (return-from make-float-aux (coerce number float-format))) + (let ((float-digits (case float-format + ((short-float single-float) 37) + ((double-float long-float) 307) + (t 307))) + (digits (round (integer-length number) (log 10 2)))) + (cond ((<= digits float-digits) + (/ (coerce number float-format) + (coerce divisor float-format))) + (T (let ((adj-amount (expt 10 (- digits float-digits)))) + (/ (coerce (round number adj-amount) float-format) + (coerce (round divisor adj-amount) float-format))))))) + +(defun make-ratio () + ;;assume read-buffer contains a legal ratio. Build the number from + ;;the string. + ;;look for optional "+" or "-". + (let ((numerator 0) (denominator 0) (char ()) (negative-number nil)) + (read-unwind-read-buffer) + (setq char (inch-read-buffer)) + (cond ((char= char #\+) + (setq char (inch-read-buffer))) + ((char= char #\-) + (setq char (inch-read-buffer)) + (setq negative-number t))) + ;;get numerator + (do* ((ch char (inch-read-buffer)) + (dig (digit-char-p ch *read-base*) + (digit-char-p ch *read-base*))) + ((not dig)) + (setq numerator (+ (* numerator *read-base*) dig))) + ;;get denominator + (do* ((ch (inch-read-buffer) (inch-read-buffer)) + (dig ())) + ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*))))) + (setq denominator (+ (* denominator *read-base*) dig))) + (let ((num (/ numerator denominator))) + (if negative-number (- num) num)))) + + + +;;;; dispatching macro cruft + +(defun make-char-dispatch-table () + (make-array 128 :initial-element #'dispatch-char-error)) + +(defun dispatch-char-error (ig1 sub-char ig2) + (declare (ignore ig1 ig2)) + (error "No dispatch function defined for ~S." sub-char)) + +(defun make-dispatch-macro-character (char &optional + (non-terminating-p nil) + (rt *readtable*)) + "Causes char to become a dispatching macro character in readtable + (which defaults to the current readtable). If the non-terminating-p + flag is set to T, the char will be non-terminating. Make-dispatch- + macro-character returns T." + (set-macro-character char #'read-dispatch-char non-terminating-p rt) + (let* ((dalist (dispatch-tables rt)) + (dtable (cdr (find char dalist :test #'char= :key #'car)))) + (cond (dtable + (error "Dispatch character already exists")) + (t + (setf (dispatch-tables rt) + (push (cons char (make-char-dispatch-table)) dalist)))))) + +(defun set-dispatch-macro-character + (disp-char sub-char function &optional (rt *readtable*)) + "Causes function to be called whenever the reader reads + disp-char followed by sub-char. Set-dispatch-macro-character + returns T." + ;;get the dispatch char for macro (error if not there), diddle + ;;entry for sub-char. + (let ((dpair (find disp-char (dispatch-tables rt) + :test #'char= :key #'car))) + (if dpair + (setf (elt (the simple-vector (cdr dpair)) + (char-int sub-char)) + function) + (error "~S is not a dispatch char." disp-char)))) + +(defun get-dispatch-macro-character (disp-char sub-char + &optional (rt *readtable*)) + "Returns the macro character function for sub-char under disp-char + or nil if there is no associated function." + (let ((dpair (find disp-char (dispatch-tables rt) + :test #'char= :key #'car))) + (if dpair + (elt (the simple-vector (cdr dpair)) + (char-int sub-char)) + (error "~S is not a dispatch char." disp-char)))) + +(defun read-dispatch-char (stream char) + ;;read some digits + (let ((numargp nil) + (numarg 0) + (sub-char ())) + (do* ((ch (read-char stream nil eof-object) + (read-char stream nil eof-object)) + (dig ())) + ((or (eofp ch) + (not (setq dig (digit-char-p ch)))) + ;;take care of the extra char. + (if (eofp ch) + (error "End-of-file inside dispatch character.") + (setq sub-char ch))) + (setq numargp t) + (setq numarg (+ (* numarg 10) dig))) + ;;look up the function and call it. + (let ((dpair (find char (dispatch-tables *readtable*) + :test #'char= :key #'car))) + (if dpair + (funcall (elt (the simple-vector (cdr dpair)) + (char-int sub-char)) + stream sub-char (if numargp numarg nil)) + (error "No dispatch table for dispatch char."))))) + + + +;;;; READ-FROM-STRING. + +(defvar read-from-string-spares () + "A resource of string streams for Read-From-String.") + +(defun read-from-string (string &optional eof-error-p eof-value + &key (start 0) (end (length string)) + preserve-whitespace) + "The characters of string are successively given to the lisp reader + and the lisp object built by the reader is returned. Macro chars + will take effect." + (declare (string string)) + (if (null end) (setq end (length string))) + (unless read-from-string-spares + (push (internal-make-string-input-stream "" 0 0) read-from-string-spares)) + (let ((stream (pop read-from-string-spares))) + (setf (string-input-stream-string stream) (coerce string 'simple-string)) + (setf (string-input-stream-current stream) start) + (setf (string-input-stream-end stream) end) + (unwind-protect + (values (if preserve-whitespace + (read-preserving-whitespace stream eof-error-p eof-value) + (read stream eof-error-p eof-value)) + (string-input-stream-current stream)) + (push stream read-from-string-spares)))) + + + +;;;; PARSE-INTEGER. + +(defun parse-integer (string &key (start 0) (end (length string)) + (radix 10) junk-allowed) + "Examine the substring of string delimited by start and end + (default to the beginning and end of the string) It skips over + whitespace characters and then tries to parse an integer. The + radix parameter must be between 2 and 36." + (declare (fixnum end)) + (if (null end) (setq end (length string))) + (let ((index (do ((i start (1+ i))) + ((= i end) + (if junk-allowed + (return-from parse-integer (values nil end)) + (error "No non-whitespace characters in number."))) + (declare (fixnum i)) + (unless (whitespacep (char string i)) (return i)))) + (minusp nil) + (found-digit nil) + (result 0)) + (declare (fixnum index)) + (let ((char (char string index))) + (cond ((char= char #\-) + (setq minusp t) + (incf index)) + ((char= char #\+) + (incf index)))) + (loop + (when (= index end) (return nil)) + (let* ((char (char string index)) + (weight (digit-char-p char radix))) + (cond (weight + (setq result (+ weight (* result radix)) + found-digit t)) + (junk-allowed (return nil)) + ((whitespacep char) + (do ((jndex (1+ index) (1+ jndex))) + ((= jndex end)) + (declare (fixnum jndex)) + (unless (whitespacep (char string jndex)) + (error "There's junk in this string: ~S." string))) + (return nil)) + (t + (error "There's junk in this string: ~S." string)))) + (incf index)) + (values + (if found-digit + (if minusp (- result) result) + (if junk-allowed + nil + (error "There's no digits in this string: ~S" string))) + index))) + + + +;;;; Reader initialization code. + +(defun reader-init () + (init-read-buffer) + (init-secondary-attribute-table) + (init-std-lisp-readtable) +; (init-integer-reader) + ) diff --git a/code/save.lisp b/code/save.lisp new file mode 100644 index 000000000..bc6926cb2 --- /dev/null +++ b/code/save.lisp @@ -0,0 +1,114 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Spice Lisp routines to suspend a process and create a core file. +;;; +;;; Written David B. McDonald. +;;; +;;;********************************************************************** +;;; +;;; To see the format of Spice Lisp core files look at the document +;;; prva:<slisp.docs>core.mss. +(in-package "LISP") + +(in-package "EXTENSIONS") +(export '(*environment-list*)) +(defvar *environment-list* nil) +(in-package "LISP") + + +(proclaim '(special *task-self*)) + +(defconstant save-block-size (* 64 1024) + "Amount to write for each call to write. This is due to RFS limitations.") + +(defvar lisp-environment-list) +(defvar original-lisp-environment) + +;;;; Global state: + +(defun save (file) + "Save the current lisp core image in a core file. When it returns in + the current process, the number of bytes written is returned. + When the saved core image is resumed, Nil is returned." + (declare (optimize (speed 3) (safety 0))) + (format t "~&[Building saved core image: ") + (finish-output) + (let ((size-to-allocate (* (current-space-usage) 2))) + (declare (fixnum size-to-allocate)) + (let* ((addr (int-sap (gr-call* mach::vm_allocate *task-self* + 0 size-to-allocate t))) + (byte-size (%primitive save *current-alien-free-pointer* + NIL addr))) + (cond ((null byte-size) + (mach::vm_deallocate *task-self* addr size-to-allocate) + (error "Save failed.")) + ((eq byte-size T) + (dolist (f *before-save-initializations*) (funcall f)) + (dolist (f *after-save-initializations*) (funcall f)) + (reinit) + (setq original-lisp-environment lisp-environment-list) + (let ((result nil)) + (dolist (ele lisp-environment-list + (setf *environment-list* result)) + (let ((=pos (position #\= (the simple-string ele)))) + ;; + ;; This is dubious since all the strings have an =. + ;; What if one doesn't? What does that mean? + (when =pos + (push (cons (intern (string-upcase (subseq ele 0 =pos)) + *keyword-package*) + (subseq ele (1+ =pos))) + result))))) + NIL) + (T + (format t "~D bytes.~%" byte-size) + (format t "Writing to file: ~A~%" file) + (finish-output) + (multiple-value-bind (fd err) (mach:unix-creat file #o644) + (if (null fd) + (error "Failed to open file ~A, unix error: ~A" + file (mach:get-unix-error-msg err))) + + (do ((left byte-size (- left save-block-size)) + (index 0 (+ index save-block-size))) + ((< left save-block-size) + (when (> left 0) + (multiple-value-bind (res err) + (mach:unix-write fd addr index left) + (if (null res) + (error "Failed to write file ~A, unix error: ~A" + file (mach:get-unix-error-msg err)))))) + (declare (fixnum left index)) + (multiple-value-bind (res err) + (mach:unix-write fd addr index + save-block-size) + (if (null res) + (error "Failed to write file ~A, unix error: ~A" + file (mach:get-unix-error-msg err))))) + (multiple-value-bind (res err) (mach:unix-close fd) + (if (null res) + (error "Failed to close file ~A, unix error: ~A" + file (mach:get-unix-error-msg err))))) + (format t "done.]~%") + (mach::vm_deallocate *task-self* addr size-to-allocate) + (finish-output) + byte-size))))) + +(defun current-space-usage () + (declare (optimize (speed 3) (safety 0))) + (do ((sum 0) + (type 0 (1+ type))) + ((> type %last-pointer-type) sum) + (declare (fixnum type sum)) + (if (not (or (eq type %short-+-float-type) (eq type %short---float-type))) + (multiple-value-bind (dyn stat ro) (space-usage type) + (declare (fixnum dyn stat ro)) + (setq sum (+ sum dyn stat ro)))))) diff --git a/code/search-list.lisp b/code/search-list.lisp new file mode 100644 index 000000000..ffa7c6244 --- /dev/null +++ b/code/search-list.lisp @@ -0,0 +1,154 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Logical name (search list) hackery for Lisp'ers. +;;; +;;; Written by Bill Chiles. + +(in-package 'lisp) +(in-package "EXTENSIONS") +(export 'search-list) +(in-package 'lisp) + + +(defvar *search-list-table* (make-hash-table :test #'equal)) +(defvar *rsl-circularity-check* (make-hash-table :test #'equal)) + + +(defun search-list (name) + "Returns a list of strings that are the of name. + This is setf'able. If any provided string in a setting value + does end with a colon or slash, a slash is added. Also, the + list is copied." + (let ((dev (pathname-device name))) + (unless dev (error "No device in ~S." name)) + (copy-list (gethash dev *search-list-table*)))) + +(defun %set-search-list (name new-value) + (unless (listp new-value) + (error "New value for search-list ~S not a list -- ~S." + name new-value)) + (let ((dev (pathname-device name))) + (unless dev (error "No device in ~S." name)) + (nstring-downcase dev) + (setf (gethash dev *search-list-table*) + (mapcar #'(lambda (x) + (declare (simple-string x)) + (let* ((len (length x)) + (char (schar x (1- len)))) + (if (or (char= char #\:) (char= char #\/)) + x + (concatenate 'simple-string x "/")))) + new-value))) + new-value) + + +(defun resolve-search-list (name first-only-p) + "This takes a Sesame search-list name (\"default\") instead of the form + taken by SEARCH-LIST (\"default:\"). If first-only-p is non-nil, then + only the first complete expansion of name is returned. If, during the + expansion of name, an undefined search list is encountered, an error + is signaled." + (setf name (string-downcase name)) + (setf (gethash name *rsl-circularity-check*) t) + (unwind-protect + (resolve-search-list-aux name first-only-p) + (clrhash *rsl-circularity-check*))) + + +;;; RESOLVE-SEARCH-LIST-BODY is used in RESOLVE-SEARCH-LIST-AUX and +;;; RSL-FIRST. This means the former is recursive, and the former and +;;; latter are mutually recursive. This form first looks at an element of +;;; a list of expansions for a search list for a colon which means that the +;;; element needs to be further resolved. If there is no colon, execute +;;; the already-form. If there is a colon, grab the new element to resolve +;;; recursively. If this new element has been seen already, we have an +;;; infinite recursion brewing. Recursively expand this new element. If +;;; there are no expansions, signal an error with the offending search list; +;;; otherwise, execute the expanded-form if the argument element was only a +;;; search list, or the concat-form if the argument element was a search +;;; list followed by a directory sequence. The locals pos, len, and res +;;; are meant to be referenced at the call sites. +;;; +(eval-when (compile eval) +(defmacro resolve-search-list-body (first-only-p element expanded-form + concat-form already-form) + `(let ((pos (position #\: ,element :test #'char=)) + (len (length ,element))) + (declare (fixnum len)) + (if pos + (let ((dev (nstring-downcase (subseq ,element 0 pos)))) + (if (gethash dev *rsl-circularity-check*) + (error "Circularity in search list -- ~S." dev) + (setf (gethash dev *rsl-circularity-check*) t)) + (let ((res (resolve-search-list-aux dev ,first-only-p))) + (remhash dev *rsl-circularity-check*) + (if res + (if (= (the fixnum pos) (the fixnum (1- len))) + ,expanded-form + ,concat-form) + (error "Undefined search list -- ~S" + (subseq ,element 0 (1+ pos)))))) + ,already-form))) +) ; eval-when + +;;; RESOLVE-SEARCH-LIST-AUX takes a device/search-list string (that is, +;;; without the colon) and whether it should return the first expansion +;;; found. If dev is not defined, signal an error with the offending +;;; search list. If dev is defined, and first-only-p is non-nil, then just +;;; resolve the first possible expansion. Otherwise, we loop over all of +;;; the possible expansions resolving each one completely, appending the +;;; results in order as they appear in entry. If entry is just another +;;; search list, then append the result (res) of its expansion onto result. +;;; If entry is a search list followed by a directory spec, then +;;; concatenate each of the expansions of the search list with the +;;; directory, appending this to result. If entry is just a directory +;;; spec, then append the list of entry to result. +;;; +(defun resolve-search-list-aux (dev first-only-p) + (let ((entry (gethash dev *search-list-table*))) + (if entry + (if first-only-p + (rsl-first (car entry)) + (do ((entries entry (cdr entries)) + (result (cons nil nil))) + ((null entries) (cdr result)) + (let ((entry (car entries))) + (declare (simple-string entry)) + (resolve-search-list-body + nil entry (nconc result res) + (nconc result (rsl-concat res (subseq entry (1+ pos) len))) + (nconc result (list entry)))))) + (error "Undefined search list -- ~S" + (concatenate 'simple-string dev ":"))))) + +;;; RSL-FIRST takes a possible expansion and resolves it if necessary. +;;; If first is just another search list, then return the expansions +;;; of this search list. If first is another search list followed by +;;; directory spec, then concatenate each of the expansions of the +;;; search list with the directory, returning this list. If first is +;;; just a directory spec, then return the list of it. +;;; +(defun rsl-first (first) + (declare (simple-string first)) + (resolve-search-list-body t first res + (rsl-concat res (subseq first (1+ pos) len)) + (list first))) + +;;; RSL-CONCAT takes a list of expansions (prefixes) for a search list +;;; that was concatenated with a directory spec (suffix). Each prefix +;;; is concatenated with the suffix and stored back where the prefix +;;; was. The destructively modified prefixes is returned. +;;; +(defun rsl-concat (prefixes suffix) + (declare (simple-string suffix)) + (do ((ptr prefixes (cdr ptr))) + ((null ptr) prefixes) + (setf (car ptr) + (concatenate 'simple-string (the simple-string (car ptr)) suffix)))) diff --git a/code/seq.lisp b/code/seq.lisp new file mode 100644 index 000000000..bf6f8deba --- /dev/null +++ b/code/seq.lisp @@ -0,0 +1,2281 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Functions to implement generic sequences for Spice Lisp. +;;; Written by Skef Wholey. +;;; Fixed up by Jim Muller on Friday the 13th, January, 1984. +;;; Gone over again by Bill Chiles. Next? +;;; +;;; Be careful when modifying code. A lot of the structure of the code is +;;; affected by the fact that compiler transforms use the lower level support +;;; functions. If transforms are written for some sequence operation, note +;;; how the end argument is handled in other operations with transforms. + +(in-package 'lisp) +(export '(elt subseq copy-seq coerce + length reverse nreverse make-sequence concatenate map some every + notany notevery reduce fill replace remove remove-if remove-if-not + delete delete-if delete-if-not remove-duplicates delete-duplicates + substitute substitute-if substitute-if-not nsubstitute nsubstitute-if + nsubstitute-if-not find find-if find-if-not position position-if + position-if-not count count-if count-if-not mismatch search + identity)) ; Yep, thet's whar it is. + + +;;; Spice-Lisp specific stuff and utilities: + +(eval-when (compile) + +;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence. + +(defmacro seq-dispatch (sequence list-form array-form) + `(if (listp ,sequence) + ,list-form + ,array-form)) + +(defmacro elt-slice (sequences n) + "Returns a list of the Nth element of each of the sequences. Used by MAP + and friends." + `(mapcar #'(lambda (seq) (elt seq ,n)) ,sequences)) + +(defmacro make-sequence-like (sequence length) + "Returns a sequence of the same type as SEQUENCE and the given LENGTH." + `(make-sequence-of-type (type-of ,sequence) ,length)) + +(defmacro type-specifier (type) + "Returns the broad class of which TYPE is a specific subclass." + `(if (atom ,type) ,type (car ,type))) + +) ; eval-when + + + +;;; APPLY-KEY saves us a function call sometimes. +;;; This is not in and (eval-when (compile eval) ... +;;; because this is used in Sort.Lisp +(defmacro apply-key (key element) + `(if ,key + (funcall ,key ,element) + ,element)) + + +(defun identity (thing) + "Returns what was passed to it." + thing) + + +(defun make-sequence-of-type (type length) + "Returns a sequence of the given TYPE and LENGTH." + (declare (fixnum length)) + (case (type-specifier type) + (list (make-list length)) + ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2))) + ((string simple-string) (make-string length)) + (simple-vector (make-array length)) + ((array simple-array vector) + (if (listp type) + (make-array length :element-type (cadr type)) + (make-array length))) + ((bit-vector simple-bit-vector) + (make-array length :element-type '(mod 2))) + (t (error "~S is a bad type specifier for sequence functions." type)))) + +(defun elt (sequence index) + "Returns the element of SEQUENCE specified by INDEX." + (if (listp sequence) + (if (< index 0) + (error "~S: index too small." index) + (do ((count index (1- count))) + ((= count 0) (car sequence)) + (declare (fixnum count)) + (if (atom sequence) + (error "~S: index too large." index) + (setq sequence (cdr sequence))))) + (aref sequence index))) + +(defun %setelt (sequence index newval) + "Store NEWVAL as the component of SEQUENCE specified by INDEX." + (if (listp sequence) + (if (< index 0) + (error "~S: index too small." index) + (do ((count index (1- count)) + (seq sequence)) + ((= count 0) (rplaca seq newval) sequence) + (declare (fixnum count)) + (if (atom (cdr seq)) + (error "~S: index too large." index) + (setq seq (cdr seq))))) + (setf (aref sequence index) newval))) + +(defun length (sequence) + "Returns an integer that is the length of SEQUENCE." + (%primitive length sequence)) + +(defun list-length* (sequence) + (do ((count 0 (1+ count))) + ((atom sequence) count) + (declare (fixnum count)) + (setq sequence (cdr sequence)))) + +(defun make-sequence (type length &key (initial-element NIL iep)) + "Returns a sequence of the given Type and Length, with elements initialized + to :Initial-Element." + (declare (fixnum length)) + (let ((type (type-expand type))) + (cond ((subtypep type 'list) + (make-list length :initial-element initial-element)) + ((subtypep type 'string) + (if iep + (make-string length :initial-element initial-element) + (make-string length))) + ((subtypep type 'simple-vector) + (make-array length :initial-element initial-element)) + ((subtypep type 'bit-vector) + (if iep + (make-array length :element-type '(mod 2) + :initial-element initial-element) + (make-array length :element-type '(mod 2)))) + ((subtypep type 'vector) + (if (listp type) + (if iep + (make-array length :element-type (cadr type) + :initial-element initial-element) + (make-array length :element-type (cadr type) + :initial-element + (if (subtypep (cadr type) 'number) + 0 + NIL))) + (make-array length :initial-element initial-element))) + (t (error "~S is a bad type specifier for sequences." type))))) + + + +;;; Subseq: +;;; +;;; The support routines for SUBSEQ are used by compiler transforms, so we +;;; worry about dealing with end being supplied as or defaulting to nil +;;; at this level. + +(defun vector-subseq* (sequence start &optional end) + (declare (vector sequence) (fixnum start)) + (when (null end) (setf end (length sequence))) + (do ((old-index start (1+ old-index)) + (new-index 0 (1+ new-index)) + (copy (make-sequence-like sequence (- end start)))) + ((= old-index end) copy) + (declare (fixnum old-index new-index)) + (setf (aref copy new-index) (aref sequence old-index)))) + +(defun list-subseq* (sequence start &optional end) + (declare (list sequence) (fixnum start)) + (if (and end (>= start (the fixnum end))) + () + (let* ((groveled (nthcdr start sequence)) + (result (list (car groveled)))) + (if groveled + (do ((list (cdr groveled) (cdr list)) + (splice result (cdr (rplacd splice (list (car list))))) + (index (1+ start) (1+ index))) + ((or (atom list) (and end (= index (the fixnum end)))) + result) + (declare (fixnum index))) + ())))) + +;;; SUBSEQ cannot default end to the length of sequence since it is not +;;; an error to supply nil for its value. We must test for end being nil +;;; in the body of the function, and this is actually done in the support +;;; routines for other reasons (see above). +(defun subseq (sequence start &optional end) + "Returns a copy of a subsequence of SEQUENCE starting with element number + START and continuing to the end of SEQUENCE or the optional END." + (seq-dispatch sequence + (list-subseq* sequence start end) + (vector-subseq* sequence start end))) + + +;;; Copy-seq: + +(eval-when (compile eval) + +(defmacro vector-copy-seq (sequence type) + `(let ((length (length (the vector ,sequence)))) + (declare (fixnum length)) + (do ((index 0 (1+ index)) + (copy (make-sequence-of-type ,type length))) + ((= index length) copy) + (declare (fixnum index)) + (setf (aref copy index) (aref ,sequence index))))) + +(defmacro list-copy-seq (list) + `(if (atom ,list) '() + (let ((result (cons (car ,list) '()) )) + (do ((x (cdr ,list) (cdr x)) + (splice result + (cdr (rplacd splice (cons (car x) '() ))) )) + ((atom x) (unless (null x) + (rplacd splice x)) + result))))) + +) + +(defun copy-seq (sequence) + "Returns a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ." + (seq-dispatch sequence + (list-copy-seq* sequence) + (vector-copy-seq* sequence))) + +;;; Internal Frobs: + +(defun list-copy-seq* (sequence) + (list-copy-seq sequence)) + +(defun vector-copy-seq* (sequence) + (vector-copy-seq sequence (type-of sequence))) + + +;;; Fill: + +(eval-when (compile eval) + +(defmacro vector-fill (sequence item start end) + `(do ((index ,start (1+ index))) + ((= index (the fixnum ,end)) ,sequence) + (declare (fixnum index)) + (setf (aref ,sequence index) ,item))) + +(defmacro list-fill (sequence item start end) + `(do ((current (nthcdr ,start ,sequence) (cdr current)) + (index ,start (1+ index))) + ((or (atom current) (and end (= index (the fixnum ,end)))) + sequence) + (declare (fixnum index)) + (rplaca current ,item))) + +) + +;;; The support routines for FILL are used by compiler transforms, so we +;;; worry about dealing with end being supplied as or defaulting to nil +;;; at this level. + +(defun list-fill* (sequence item start end) + (declare (list sequence)) + (list-fill sequence item start end)) + +(defun vector-fill* (sequence item start end) + (declare (vector sequence)) + (when (null end) (setq end (length sequence))) + (vector-fill sequence item start end)) + +;;; FILL cannot default end to the length of sequence since it is not +;;; an error to supply nil for its value. We must test for end being nil +;;; in the body of the function, and this is actually done in the support +;;; routines for other reasons (see above). +(defun fill (sequence item &key (start 0) end) + "Replace the specified elements of SEQUENCE with ITEM." + (seq-dispatch sequence + (list-fill* sequence item start end) + (vector-fill* sequence item start end))) + + + +;;; Replace: + +(eval-when (compile eval) + +;;; If we are copying around in the same vector, be careful not to copy the +;;; same elements over repeatedly. We do this by copying backwards. +(defmacro mumble-replace-from-mumble () + `(if (and (eq target-sequence source-sequence) (> target-start source-start)) + (let ((nelts (min (- target-end target-start) (- source-end source-start)))) + (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1) + (1- target-index)) + (source-index (+ (the fixnum source-start) (the fixnum nelts) -1) + (1- source-index))) + ((= target-index (the fixnum (1- target-start))) target-sequence) + (declare (fixnum target-index source-index)) + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))) + (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index))) + ((or (= target-index (the fixnum target-end)) + (= source-index (the fixnum source-end))) + target-sequence) + (declare (fixnum target-index source-index)) + (setf (aref target-sequence target-index) + (aref source-sequence source-index))))) + +(defmacro list-replace-from-list () + `(if (and (eq target-sequence source-sequence) (> target-start source-start)) + (let ((new-elts (subseq source-sequence source-start + (+ (the fixnum source-start) + (the fixnum + (min (- (the fixnum target-end) + (the fixnum target-start)) + (- (the fixnum source-end) + (the fixnum source-start)))))))) + (do ((n new-elts (cdr n)) + (o (nthcdr target-start target-sequence) (cdr o))) + ((null n) target-sequence) + (rplaca o (car n)))) + (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (target-sequence-ref (nthcdr target-start target-sequence) + (cdr target-sequence-ref)) + (source-sequence-ref (nthcdr source-start source-sequence) + (cdr source-sequence-ref))) + ((or (= target-index (the fixnum target-end)) + (= source-index (the fixnum source-end)) + (null target-sequence-ref) (null source-sequence-ref)) + target-sequence) + (declare (fixnum target-index source-index)) + (rplaca target-sequence-ref (car source-sequence-ref))))) + +(defmacro list-replace-from-mumble () + `(do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (target-sequence-ref (nthcdr target-start target-sequence) + (cdr target-sequence-ref))) + ((or (= target-index (the fixnum target-end)) + (= source-index (the fixnum source-end)) + (null target-sequence-ref)) + target-sequence) + (declare (fixnum source-index target-index)) + (rplaca target-sequence-ref (aref source-sequence source-index)))) + +(defmacro mumble-replace-from-list () + `(do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (source-sequence (nthcdr source-start source-sequence) + (cdr source-sequence))) + ((or (= target-index (the fixnum target-end)) + (= source-index (the fixnum source-end)) + (null source-sequence)) + target-sequence) + (declare (fixnum target-index source-index)) + (setf (aref target-sequence target-index) (car source-sequence)))) + +) ; eval-when + +;;; The support routines for REPLACE are used by compiler transforms, so we +;;; worry about dealing with end being supplied as or defaulting to nil +;;; at this level. + +(defun list-replace-from-list* (target-sequence source-sequence target-start + target-end source-start source-end) + (when (null target-end) (setq target-end (length target-sequence))) + (when (null source-end) (setq source-end (length source-sequence))) + (list-replace-from-list)) + +(defun list-replace-from-vector* (target-sequence source-sequence target-start + target-end source-start source-end) + (when (null target-end) (setq target-end (length target-sequence))) + (when (null source-end) (setq source-end (length source-sequence))) + (list-replace-from-mumble)) + +(defun vector-replace-from-list* (target-sequence source-sequence target-start + target-end source-start source-end) + (when (null target-end) (setq target-end (length target-sequence))) + (when (null source-end) (setq source-end (length source-sequence))) + (mumble-replace-from-list)) + +(defun vector-replace-from-vector* (target-sequence source-sequence + target-start target-end source-start + source-end) + (when (null target-end) (setq target-end (length target-sequence))) + (when (null source-end) (setq source-end (length source-sequence))) + (mumble-replace-from-mumble)) + +;;; REPLACE cannot default end arguments to the length of sequence since it +;;; is not an error to supply nil for their values. We must test for ends +;;; being nil in the body of the function. +(defun replace (target-sequence source-sequence &key + ((:start1 target-start) 0) + ((:end1 target-end)) + ((:start2 source-start) 0) + ((:end2 source-end))) + "The target sequence is destructively modified by copying successive + elements into it from the source sequence." + (unless target-end (setq target-end (length target-sequence))) + (unless source-end (setq source-end (length source-sequence))) + (seq-dispatch target-sequence + (seq-dispatch source-sequence + (list-replace-from-list) + (list-replace-from-mumble)) + (seq-dispatch source-sequence + (mumble-replace-from-list) + (mumble-replace-from-mumble)))) + + +;;; Reverse: + +(eval-when (compile eval) + +(defmacro vector-reverse (sequence type) + `(let ((length (length ,sequence))) + (declare (fixnum length)) + (do ((forward-index 0 (1+ forward-index)) + (backward-index (1- length) (1- backward-index)) + (new-sequence (make-sequence-of-type ,type length))) + ((= forward-index length) new-sequence) + (declare (fixnum forward-index backward-index)) + (setf (aref new-sequence forward-index) + (aref ,sequence backward-index))))) + +(defmacro list-reverse-macro (sequence) + `(do ((new-list ())) + ((atom ,sequence) new-list) + (push (pop ,sequence) new-list))) + +) + +(defun reverse (sequence) + "Returns a new sequence containing the same elements but in reverse order." + (seq-dispatch sequence + (list-reverse* sequence) + (vector-reverse* sequence))) + +;;; Internal Frobs: + +(defun list-reverse* (sequence) + (list-reverse-macro sequence)) + +(defun vector-reverse* (sequence) + (vector-reverse sequence (type-of sequence))) + + +;;; Nreverse: + +(eval-when (compile eval) + +(defmacro vector-nreverse (sequence) + `(let ((length (length (the vector ,sequence)))) + (declare (fixnum length)) + (do ((left-index 0 (1+ left-index)) + (right-index (1- length) (1- right-index)) + (half-length (truncate length 2))) + ((= left-index half-length) ,sequence) + (declare (fixnum left-index right-index half-length)) + (rotatef (aref ,sequence left-index) + (aref ,sequence right-index))))) + +(defmacro list-nreverse-macro (list) + `(do ((1st (cdr ,list) (if (atom 1st) 1st (cdr 1st))) + (2nd ,list 1st) + (3rd '() 2nd)) + ((atom 2nd) 3rd) + (rplacd 2nd 3rd))) + +) + + +(defun list-nreverse* (sequence) + (list-nreverse-macro sequence)) + +(defun vector-nreverse* (sequence) + (vector-nreverse sequence)) + +(defun nreverse (sequence) + "Returns a sequence of the same elements in reverse order; the argument + is destroyed." + (seq-dispatch sequence + (list-nreverse* sequence) + (vector-nreverse* sequence))) + + +;;; Concatenate: + +(eval-when (compile eval) + +(defmacro concatenate-to-list (sequences) + `(let ((result (list nil))) + (do ((sequences ,sequences (cdr sequences)) + (splice result)) + ((null sequences) (cdr result)) + (let ((sequence (car sequences))) + (seq-dispatch sequence + (do ((sequence sequence (cdr sequence))) + ((atom sequence)) + (setq splice + (cdr (rplacd splice (list (car sequence)))))) + (do ((index 0 (1+ index)) + (length (length sequence))) + ((= index length)) + (declare (fixnum index length)) + (setq splice + (cdr (rplacd splice + (list (aref sequence index))))))))))) + +(defmacro concatenate-to-mumble (output-type-spec sequences) + `(do ((seqs ,sequences (cdr seqs)) + (total-length 0) + (lengths ())) + ((null seqs) + (do ((sequences ,sequences (cdr sequences)) + (lengths lengths (cdr lengths)) + (index 0) + (result (make-sequence-of-type ,output-type-spec total-length))) + ((= index total-length) result) + (declare (fixnum index)) + (let ((sequence (car sequences))) + (seq-dispatch sequence + (do ((sequence sequence (cdr sequence))) + ((atom sequence)) + (setf (aref result index) (car sequence)) + (setq index (1+ index))) + (do ((jndex 0 (1+ jndex)) + (this-length (car lengths))) + ((= jndex this-length)) + (declare (fixnum jndex this-length)) + (setf (aref result index) + (aref sequence jndex)) + (setq index (1+ index))))))) + (let ((length (length (car seqs)))) + (declare (fixnum length)) + (setq lengths (nconc lengths (list length))) + (setq total-length (+ total-length length))))) + +) + +(defun concatenate (output-type-spec &rest sequences) + "Returns a new sequence of all the argument sequences concatenated together + which shares no structure with the original argument sequences of the + specified OUTPUT-TYPE-SPEC." + (case (type-specifier output-type-spec) + (list (apply #'concat-to-list* sequences)) + ((simple-vector simple-string vector string array simple-array + bit-vector simple-bit-vector) + (apply #'concat-to-simple* output-type-spec sequences)) + (t (error "~S: invalid output type specification." output-type-spec)))) + +;;; Internal Frobs: + +(defun concat-to-list* (&rest sequences) + (concatenate-to-list sequences)) + +(defun concat-to-simple* (type &rest sequences) + (concatenate-to-mumble type sequences)) + + +;;; Map: + +(eval-when (compile eval) + +(defmacro map-to-list (function sequences) + `(do ((seqs more-sequences (cdr seqs)) + (min-length (length first-sequence))) + ((null seqs) + (let ((result (list nil))) + (do ((index 0 (1+ index)) + (splice result)) + ((= index min-length) (cdr result)) + (declare (fixnum index)) + (setq splice + (cdr (rplacd splice + (list (apply ,function (elt-slice ,sequences + index))))))))) + (declare (fixnum min-length)) + (let ((length (length (car seqs)))) + (declare (fixnum length)) + (if (< length min-length) + (setq min-length length))))) + +(defmacro map-to-simple (output-type-spec function sequences) + `(do ((seqs more-sequences (cdr seqs)) + (min-length (length first-sequence))) + ((null seqs) + (do ((index 0 (1+ index)) + (result (make-sequence-of-type ,output-type-spec min-length))) + ((= index min-length) result) + (declare (fixnum index)) + (setf (aref result index) + (apply ,function (elt-slice ,sequences index))))) + (declare (fixnum min-length)) + (let ((length (length (car seqs)))) + (declare (fixnum length)) + (if (< length min-length) + (setq min-length length))))) + +(defmacro map-for-effect (function sequences) + `(do ((seqs more-sequences (cdr seqs)) + (min-length (length first-sequence))) + ((null seqs) + (do ((index 0 (1+ index))) + ((= index min-length) nil) + (apply ,function (elt-slice ,sequences index)))) + (declare (fixnum min-length)) + (let ((length (length (car seqs)))) + (declare (fixnum length)) + (if (< length min-length) + (setq min-length length))))) + + +) + +(defun map (output-type-spec function first-sequence &rest more-sequences) + "FUNCTION must take as many arguments as there are sequences provided. The + result is a sequence such that element i is the result of applying FUNCTION + to element i of each of the argument sequences." + (let ((sequences (cons first-sequence more-sequences))) + (case (type-specifier output-type-spec) + ((nil) (map-for-effect function sequences)) + (list (map-to-list function sequences)) + ((simple-vector simple-string vector string array simple-array + bit-vector simple-bit-vector) + (map-to-simple output-type-spec function sequences)) + (t (error "~S: invalid output type specifier." output-type-spec))))) + + +;;; Quantifiers: + +(eval-when (compile eval) +(defmacro defquantifier (name doc-string every-result abort-sense abort-value) + `(defun ,name (predicate first-sequence &rest more-sequences) + ,doc-string + (do ((seqs more-sequences (cdr seqs)) + (length (length first-sequence)) + (sequences (cons first-sequence more-sequences))) + ((null seqs) + (do ((index 0 (1+ index))) + ((= index length) ,every-result) + (declare (fixnum index)) + (let ((result (apply predicate (elt-slice sequences index)))) + (if ,(if abort-sense 'result '(not result)) + (return ,abort-value))))) + (declare (fixnum length)) + (let ((this (length (car seqs)))) + (declare (fixnum this)) + (if (< this length) (setq length this)))))) +) ; eval-when + +(defquantifier some + "PREDICATE is applied to the elements with index 0 of the sequences, then + possibly to those with index 1, and so on. SOME returns the first + non-() value encountered, or () if the end of a sequence is reached." + nil t result) + +(defquantifier every + "PREDICATE is applied to the elements with index 0 of the sequences, then + possibly to those with index 1, and so on. EVERY returns () as soon + as any invocation of PREDICATE returns (), or T if every invocation + is non-()." + t nil nil) + +(defquantifier notany + "PREDICATE is applied to the elements with index 0 of the sequences, then + possibly to those with index 1, and so on. NOTANY returns () as soon + as any invocation of PREDICATE returns a non-() value, or T if the end + of a sequence is reached." + t t nil) + +(defquantifier notevery + "PREDICATE is applied to the elements with index 0 of the sequences, then + possibly to those with index 1, and so on. NOTEVERY returns T as soon + as any invocation of PREDICATE returns (), or () if every invocation + is non-()." + nil nil t) + + + +;;; Reduce: + +(eval-when (compile eval) + +(defmacro mumble-reduce (function sequence start end initial-value ref) + `(do ((index ,start (1+ index)) + (value ,initial-value)) + ((= index (the fixnum ,end)) value) + (declare (fixnum index)) + (setq value (funcall ,function value (,ref ,sequence index))))) + +(defmacro mumble-reduce-from-end (function sequence start end initial-value ref) + `(do ((index (1- ,end) (1- index)) + (value ,initial-value) + (terminus (1- ,start))) + ((= index terminus) value) + (declare (fixnum index terminus)) + (setq value (funcall ,function (,ref ,sequence index) value)))) + +(defmacro list-reduce (function sequence start end initial-value ivp) + `(let ((sequence (nthcdr ,start ,sequence))) + (do ((count (if ,ivp ,start (1+ (the fixnum ,start))) + (1+ count)) + (sequence (if ,ivp sequence (cdr sequence)) + (cdr sequence)) + (value (if ,ivp ,initial-value (car sequence)) + (funcall ,function value (car sequence)))) + ((= count (the fixnum ,end)) value) + (declare (fixnum count))))) + +(defmacro list-reduce-from-end (function sequence start end initial-value ivp) + `(let ((sequence (nthcdr (- (the fixnum (length ,sequence)) (the fixnum ,end)) + (reverse ,sequence)))) + (do ((count (if ,ivp ,start (1+ (the fixnum ,start))) + (1+ count)) + (sequence (if ,ivp sequence (cdr sequence)) + (cdr sequence)) + (value (if ,ivp ,initial-value (car sequence)) + (funcall ,function (car sequence) value))) + ((= count (the fixnum ,end)) value) + (declare (fixnum count))))) + +) + +(defun reduce (function sequence &key from-end (start 0) + end (initial-value nil ivp)) + "The specified Sequence is ``reduced'' using the given Function. + See manual for details." + (declare (fixnum start)) + (when (null end) (setf end (length sequence))) + (cond ((= (the fixnum end) start) + (if ivp initial-value (funcall function))) + ((listp sequence) + (if from-end + (list-reduce-from-end function sequence start end initial-value ivp) + (list-reduce function sequence start end initial-value ivp))) + (from-end + (when (not ivp) + (setq end (1- (the fixnum end))) + (setq initial-value (aref sequence end))) + (mumble-reduce-from-end function sequence start end initial-value aref)) + (t + (when (not ivp) + (setq initial-value (aref sequence start)) + (setq start (1+ start))) + (mumble-reduce function sequence start end initial-value aref)))) + + +;;; Coerce: + +(defun coerce (object output-type-spec) + "Coerces the Object to an object of type Output-Type-Spec." + (cond + ((typep object output-type-spec) + object) + ((eq output-type-spec 'character) + (character object)) + ((eq output-type-spec 'function) + (eval `#',object)) + ((numberp object) + (case output-type-spec + (short-float (%primitive float-short object)) + ((single-float float) (%primitive float-single object)) + ((double-float long-float) (%primitive float-long object)) + (complex + (complex object)) + (t + (error "~S can't be converted to type ~S." object output-type-spec)))) + (t + (typecase object + (list + (case (type-specifier output-type-spec) + ((simple-string string) (list-to-string* object)) + ((simple-bit-vector bit-vector) (list-to-bit-vector* object)) + ((simple-vector vector array simple-array) + (list-to-vector* object output-type-spec)) + (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) + (simple-string + (case (type-specifier output-type-spec) + (list (vector-to-list* object)) + ;; Can't coerce a string to a bit-vector! + ((simple-vector vector array simple-array) + (vector-to-vector* object output-type-spec)) + (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) + (simple-bit-vector + (case (type-specifier output-type-spec) + (list (vector-to-list* object)) + ;; Can't coerce a bit-vector to a string! + ((simple-vector vector array simple-array) + (vector-to-vector* object output-type-spec)) + (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) + (simple-vector + (case (type-specifier output-type-spec) + (list (vector-to-list* object)) + ((simple-string string) (vector-to-string* object)) + ((simple-bit-vector bit-vector) (vector-to-bit-vector* object)) + ((vector array simple-array) (vector-to-vector* object output-type-spec)) + (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) + (string + (case (type-specifier output-type-spec) + (list (vector-to-list* object)) + (simple-string (string-to-simple-string* object)) + ;; Can't coerce a string to a bit-vector! + ((simple-vector vector simple-array array) + (vector-to-vector* object output-type-spec)) + (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) + (bit-vector + (case (type-specifier output-type-spec) + (list (vector-to-list* object)) + ;; Can't coerce a bit-vector to a string! + (simple-bit-vector (bit-vector-to-simple-bit-vector* object)) + ((simple-vector vector array simple-array) + (vector-to-vector* object output-type-spec)) + (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) + (vector + (case (type-specifier output-type-spec) + (list (vector-to-list* object)) + ((simple-string string) (vector-to-string* object)) + ((simple-bit-vector bit-vector) (vector-to-bit-vector* object)) + ((simple-vector vector array simple-array) + (vector-to-vector* object output-type-spec)) + (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) + (t (error "~S is an inappropriate type of object for coerce." object)))))) + + +;;; Internal Frobs: + +(macrolet ((frob (name result access src-type &optional typep) + `(defun ,name (object ,@(if typep '(type) ())) + (do* ((index 0 (1+ index)) + (length (,(case src-type + (:list 'list-length*) + (:vector 'length)) + object)) + (result ,result)) + ((= index length) result) + (declare (fixnum length index)) + (setf (,access result index) + ,(case src-type + (:list '(pop object)) + (:vector '(aref object index)))))))) + + (frob list-to-string* (make-string length) schar :list) + + (frob list-to-bit-vector* (make-array length :element-type '(mod 2)) + sbit :list) + + (frob list-to-vector* (make-sequence-of-type type length) + aref :list t) + + (frob vector-to-vector* (make-sequence-of-type type length) + aref :vector t) + + (frob vector-to-string* (make-string length) schar :vector) + + (frob vector-to-bit-vector* (make-array length :element-type '(mod 2)) + sbit :vector)) + +(defun vector-to-list* (object) + (let ((result (list nil)) + (length (length object))) + (declare (fixnum length)) + (do ((index 0 (1+ index)) + (splice result (cdr splice))) + ((= index length) (cdr result)) + (declare (fixnum index)) + (rplacd splice (list (aref object index)))))) + +(defun string-to-simple-string* (object) + (if (simple-string-p object) + object + (with-array-data ((data object) + (start) + (end (%primitive header-ref object + %array-fill-pointer-slot))) + (declare (simple-string data)) + (subseq data start end)))) + +(defun bit-vector-to-simple-bit-vector* (object) + (if (simple-bit-vector-p object) + object + (with-array-data ((data object) + (start) + (end (%primitive header-ref object + %array-fill-pointer-slot))) + (declare (simple-bit-vector data)) + (subseq data start end)))) + + +;;; Delete: + +(eval-when (compile eval) + +(defmacro mumble-delete (pred) + `(do ((index start (1+ index)) + (jndex start) + (number-zapped 0)) + ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) + (do ((index index (1+ index)) ; copy the rest of the vector + (jndex jndex (1+ jndex))) + ((= index (the fixnum length)) + (shrink-vector sequence jndex)) + (declare (fixnum index jndex)) + (setf (aref sequence jndex) (aref sequence index)))) + (declare (fixnum index jndex number-zapped)) + (setf (aref sequence jndex) (aref sequence index)) + (if ,pred + (setq number-zapped (1+ number-zapped)) + (setq jndex (1+ jndex))))) + +(defmacro mumble-delete-from-end (pred) + `(do ((index (1- (the fixnum end)) (1- index)) ; find the losers + (number-zapped 0) + (losers ()) + this-element + (terminus (1- start))) + ((or (= index terminus) (= number-zapped (the fixnum count))) + (do ((losers losers) ; delete the losers + (index start (1+ index)) + (jndex start)) + ((or (null losers) (= index (the fixnum end))) + (do ((index index (1+ index)) ; copy the rest of the vector + (jndex jndex (1+ jndex))) + ((= index (the fixnum length)) + (shrink-vector sequence jndex)) + (declare (fixnum index jndex)) + (setf (aref sequence jndex) (aref sequence index)))) + (declare (fixnum index jndex)) + (setf (aref sequence jndex) (aref sequence index)) + (if (= index (the fixnum (car losers))) + (pop losers) + (setq jndex (1+ jndex))))) + (declare (fixnum index number-zapped terminus)) + (setq this-element (aref sequence index)) + (when ,pred + (setq number-zapped (1+ number-zapped)) + (push index losers)))) + +(defmacro normal-mumble-delete () + `(mumble-delete + (if test-not + (not (funcall test-not item (apply-key key (aref sequence index)))) + (funcall test item (apply-key key (aref sequence index)))))) + +(defmacro normal-mumble-delete-from-end () + `(mumble-delete-from-end + (if test-not + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) + +(defmacro list-delete (pred) + `(let ((handle (cons nil sequence))) + (do ((current (nthcdr start sequence) (cdr current)) + (previous (nthcdr start handle)) + (index start (1+ index)) + (number-zapped 0)) + ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) + (cdr handle)) + (declare (fixnum index number-zapped)) + (cond (,pred + (rplacd previous (cdr current)) + (setq number-zapped (1+ number-zapped))) + (t + (setq previous (cdr previous))))))) + +(defmacro list-delete-from-end (pred) + `(let* ((reverse (nreverse (the list sequence))) + (handle (cons nil reverse))) + (do ((current (nthcdr (- (the fixnum length) (the fixnum end)) reverse) + (cdr current)) + (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle)) + (index start (1+ index)) + (number-zapped 0)) + ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) + (nreverse (cdr handle))) + (declare (fixnum index number-zapped)) + (cond (,pred + (rplacd previous (cdr current)) + (setq number-zapped (1+ number-zapped))) + (t + (setq previous (cdr previous))))))) + +(defmacro normal-list-delete () + '(list-delete + (if test-not + (not (funcall test-not item (apply-key key (car current)))) + (funcall test item (apply-key key (car current)))))) + +(defmacro normal-list-delete-from-end () + '(list-delete-from-end + (if test-not + (not (funcall test-not item (apply-key key (car current)))) + (funcall test item (apply-key key (car current)))))) +) + +(defun delete (item sequence &key from-end (test #'eql) test-not (start 0) + end (count most-positive-fixnum) key) + "Returns a sequence formed by destructively removing the specified Item from + the given Sequence." + (declare (fixnum start count)) + (when (null end) (setf end (length sequence))) + (let ((length (length sequence))) + (declare (fixnum length)) + (seq-dispatch sequence + (if from-end + (normal-list-delete-from-end) + (normal-list-delete)) + (if from-end + (normal-mumble-delete-from-end) + (normal-mumble-delete))))) + +(eval-when (compile eval) + +(defmacro if-mumble-delete () + `(mumble-delete + (funcall predicate (apply-key key (aref sequence index))))) + +(defmacro if-mumble-delete-from-end () + `(mumble-delete-from-end + (funcall predicate (apply-key key this-element)))) + +(defmacro if-list-delete () + '(list-delete + (funcall predicate (apply-key key (car current))))) + +(defmacro if-list-delete-from-end () + '(list-delete-from-end + (funcall predicate (apply-key key (car current))))) + +) + +(defun delete-if (predicate sequence &key from-end (start 0) key + end (count most-positive-fixnum)) + "Returns a sequence formed by destructively removing the elements satisfying + the specified Predicate from the given Sequence." + (declare (fixnum start count)) + (when (null end) (setf end (length sequence))) + (let ((length (length sequence))) + (declare (fixnum length)) + (seq-dispatch sequence + (if from-end + (if-list-delete-from-end) + (if-list-delete)) + (if from-end + (if-mumble-delete-from-end) + (if-mumble-delete))))) + +(eval-when (compile eval) + +(defmacro if-not-mumble-delete () + `(mumble-delete + (not (funcall predicate (apply-key key (aref sequence index)))))) + +(defmacro if-not-mumble-delete-from-end () + `(mumble-delete-from-end + (not (funcall predicate (apply-key key this-element))))) + +(defmacro if-not-list-delete () + '(list-delete + (not (funcall predicate (apply-key key (car current)))))) + +(defmacro if-not-list-delete-from-end () + '(list-delete-from-end + (not (funcall predicate (apply-key key (car current)))))) + +) + +(defun delete-if-not (predicate sequence &key from-end (start 0) + end key (count most-positive-fixnum)) + "Returns a sequence formed by destructively removing the elements not + satisfying the specified Predicate from the given Sequence." + (declare (fixnum start count)) + (when (null end) (setf end (length sequence))) + (let ((length (length sequence))) + (declare (fixnum length)) + (seq-dispatch sequence + (if from-end + (if-not-list-delete-from-end) + (if-not-list-delete)) + (if from-end + (if-not-mumble-delete-from-end) + (if-not-mumble-delete))))) + + +;;; Remove: + +(eval-when (compile eval) + +;;; MUMBLE-REMOVE-MACRO does not include (removes) each element that +;;; satisfies the predicate. +(defmacro mumble-remove-macro (bump left begin finish right pred) + `(do ((index ,begin (,bump index)) + (result + (do ((index ,left (,bump index)) + (result (make-sequence-like sequence length))) + ((= index (the fixnum ,begin)) result) + (declare (fixnum index)) + (setf (aref result index) (aref sequence index)))) + (new-index ,begin) + (number-zapped 0) + (this-element)) + ((or (= index (the fixnum ,finish)) (= number-zapped (the fixnum count))) + (do ((index index (,bump index)) + (new-index new-index (,bump new-index))) + ((= index (the fixnum ,right)) (shrink-vector result new-index)) + (declare (fixnum index new-index)) + (setf (aref result new-index) (aref sequence index)))) + (declare (fixnum index new-index number-zapped)) + (setq this-element (aref sequence index)) + (cond (,pred (setq number-zapped (1+ number-zapped))) + (t (setf (aref result new-index) this-element) + (setq new-index (,bump new-index)))))) + +(defmacro mumble-remove (pred) + `(mumble-remove-macro 1+ 0 start end length ,pred)) + +(defmacro mumble-remove-from-end (pred) + `(let ((sequence (copy-seq sequence))) + (mumble-delete-from-end ,pred))) + +(defmacro normal-mumble-remove () + `(mumble-remove + (if test-not + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) + +(defmacro normal-mumble-remove-from-end () + `(mumble-remove-from-end + (if test-not + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) + +(defmacro if-mumble-remove () + `(mumble-remove (funcall predicate (apply-key key this-element)))) + +(defmacro if-mumble-remove-from-end () + `(mumble-remove-from-end (funcall predicate (apply-key key this-element)))) + +(defmacro if-not-mumble-remove () + `(mumble-remove (not (funcall predicate (apply-key key this-element))))) + +(defmacro if-not-mumble-remove-from-end () + `(mumble-remove-from-end + (not (funcall predicate (apply-key key this-element))))) + +;;; LIST-REMOVE-MACRO does not include (removes) each element that satisfies +;;; the predicate. +(defmacro list-remove-macro (pred reverse?) + `(let* (,@(if reverse? '((sequence (reverse (the list sequence))))) + (splice (list nil)) + (results (do ((index 0 (1+ index)) + (before-start splice)) + ((= index (the fixnum start)) before-start) + (declare (fixnum index)) + (setq splice + (cdr (rplacd splice (list (pop sequence)))))))) + (do ((index start (1+ index)) + (this-element) + (number-zapped 0)) + ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) + (do ((index index (1+ index))) + ((null sequence) + ,(if reverse? + '(nreverse (the list (cdr results))) + '(cdr results))) + (declare (fixnum index)) + (setq splice (cdr (rplacd splice (list (pop sequence))))))) + (declare (fixnum index number-zapped)) + (setq this-element (pop sequence)) + (if ,pred + (setq number-zapped (1+ number-zapped)) + (setq splice (cdr (rplacd splice (list this-element)))))))) + +(defmacro list-remove (pred) + `(list-remove-macro ,pred nil)) + +(defmacro list-remove-from-end (pred) + `(list-remove-macro ,pred t)) + +(defmacro normal-list-remove () + `(list-remove + (if test-not + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) + +(defmacro normal-list-remove-from-end () + `(list-remove-from-end + (if test-not + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) + +(defmacro if-list-remove () + `(list-remove + (funcall predicate (apply-key key this-element)))) + +(defmacro if-list-remove-from-end () + `(list-remove-from-end + (funcall predicate (apply-key key this-element)))) + +(defmacro if-not-list-remove () + `(list-remove + (not (funcall predicate (apply-key key this-element))))) + +(defmacro if-not-list-remove-from-end () + `(list-remove-from-end + (not (funcall predicate (apply-key key this-element))))) + +) + +(defun remove (item sequence &key from-end (test #'eql) test-not (start 0) + end (count most-positive-fixnum) key) + "Returns a copy of SEQUENCE with elements satisfying the test (default is + EQL) with ITEM removed." + (declare (fixnum start count)) + (when (null end) (setf end (length sequence))) + (let ((length (length sequence))) + (declare (fixnum length)) + (seq-dispatch sequence + (if from-end + (normal-list-remove-from-end) + (normal-list-remove)) + (if from-end + (normal-mumble-remove-from-end) + (normal-mumble-remove))))) + +(defun remove-if (predicate sequence &key from-end (start 0) + end (count most-positive-fixnum) key) + "Returns a copy of sequence with elements such that predicate(element) + is non-null are removed" + (declare (fixnum start count)) + (when (null end) (setf end (length sequence))) + (let ((length (length sequence))) + (declare (fixnum length)) + (seq-dispatch sequence + (if from-end + (if-list-remove-from-end) + (if-list-remove)) + (if from-end + (if-mumble-remove-from-end) + (if-mumble-remove))))) + +(defun remove-if-not (predicate sequence &key + from-end (start 0) end + (count most-positive-fixnum) key) + "Returns a copy of sequence with elements such that predicate(element) + is null are removed" + (declare (fixnum start count)) + (when (null end) (setf end (length sequence))) + (let ((length (length sequence))) + (declare (fixnum length)) + (seq-dispatch sequence + (if from-end + (if-not-list-remove-from-end) + (if-not-list-remove)) + (if from-end + (if-not-mumble-remove-from-end) + (if-not-mumble-remove))))) + + +;;; Remove-Duplicates: + +;;; Remove duplicates from a list. If from-end, remove the later duplicates, +;;; not the earlier ones. Thus if we check from-end we don't copy an item +;;; if we look into the already copied structure (from after :start) and see +;;; the item. If we check from beginning we check into the rest of the +;;; original list up to the :end marker (this we have to do by running a +;;; do loop down the list that far and using our test. +(defun list-remove-duplicates* (list test test-not start end key from-end) + (declare (fixnum start)) + (let* ((result (list ())) ; Put a marker on the beginning to splice with. + (splice result) + (current list)) + (do ((index 0 (1+ index))) + ((= index start)) + (declare (fixnum index)) + (setq splice (cdr (rplacd splice (list (car current))))) + (setq current (cdr current))) + (do ((index 0 (1+ index))) + ((or (and end (= index (the fixnum end))) + (atom current))) + (declare (fixnum index)) + (if (or (and from-end + (not (member (apply-key key (car current)) + (nthcdr start result) + :test test + :test-not test-not + :key (if key key #'identity)))) + (and (not from-end) + (not (do ((it (apply-key key (car current))) + (l (cdr current) (cdr l)) + (i (1+ index) (1+ i))) + ((or (atom l) (and end (= i (the fixnum end)))) + ()) + (declare (fixnum i)) + (if (if test-not + (not (funcall test-not (apply-key key (car l)) it)) + (funcall test (apply-key key (car l)) it)) + (return t)))))) + (setq splice (cdr (rplacd splice (list (car current)))))) + (setq current (cdr current))) + (do () + ((atom current)) + (setq splice (cdr (rplacd splice (list (car current))))) + (setq current (cdr current))) + (cdr result))) + + + +(defun vector-remove-duplicates* (vector test test-not start end key from-end + &optional (length (length vector))) + (declare (vector vector) (fixnum start length)) + (when (null end) (setf end (length vector))) + (let ((result (make-sequence-like vector length)) + (index 0) + (jndex start)) + (declare (fixnum index jndex)) + (do () + ((= index start)) + (setf (aref result index) (aref vector index)) + (setq index (1+ index))) + (do ((elt)) + ((= index end)) + (setq elt (aref vector index)) + (unless (or (and from-end + (position (apply-key key elt) result :start start + :end jndex :test test :test-not test-not :key key)) + (and (not from-end) + (position (apply-key key elt) vector :start (1+ index) + :end end :test test :test-not test-not :key key))) + (setf (aref result jndex) elt) + (setq jndex (1+ jndex))) + (setq index (1+ index))) + (do () + ((= index length)) + (setf (aref result jndex) (aref vector index)) + (setq index (1+ index)) + (setq jndex (1+ jndex))) + (shrink-vector result jndex))) + + +(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) from-end + end key) + "The elements of Sequence are examined, and if any two match, one is + discarded. The resulting sequence is returned." + (declare (fixnum start)) + (seq-dispatch sequence + (if sequence + (list-remove-duplicates* sequence test test-not + start end key from-end)) + (vector-remove-duplicates* sequence test test-not + start end key from-end))) + + + +;;; Delete-Duplicates: + + +(defun list-delete-duplicates* (list test test-not key from-end start end) + (declare (fixnum start)) + (let ((handle (cons nil list))) + (do ((current (nthcdr start list) (cdr current)) + (previous (nthcdr start handle)) + (index start (1+ index))) + ((or (and end (= index (the fixnum end))) (null current)) + (cdr handle)) + (declare (fixnum index)) + (if (do ((x (if from-end + (nthcdr (1+ start) handle) + (cdr current)) + (cdr x)) + (i (1+ index) (1+ i))) + ((or (null x) + (and (not from-end) end (= i (the fixnum end))) + (eq x current)) + nil) + (declare (fixnum i)) + (if (if test-not + (not (funcall test-not + (apply-key key (car current)) + (apply-key key (car x)))) + (funcall test + (apply-key key (car current)) + (apply-key key (car x)))) + (return t))) + (rplacd previous (cdr current)) + (setq previous (cdr previous)))))) + + +(defun vector-delete-duplicates* (vector test test-not key from-end start end + &optional (length (length vector))) + (declare (vector vector) (fixnum start length)) + (when (null end) (setf end (length vector))) + (do ((index start (1+ index)) + (jndex start)) + ((= index end) + (do ((index index (1+ index)) ; copy the rest of the vector + (jndex jndex (1+ jndex))) + ((= index length) + (shrink-vector vector jndex) + vector) + (setf (aref vector jndex) (aref vector index)))) + (declare (fixnum index jndex)) + (setf (aref vector jndex) (aref vector index)) + (unless (position (apply-key key (aref vector index)) vector :key key + :start (if from-end start (1+ index)) :test test + :end (if from-end jndex end) :test-not test-not) + (setq jndex (1+ jndex))))) + + +(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end + end key) + "The elements of Sequence are examined, and if any two match, one is + discarded. The resulting sequence, which may be formed by destroying the + given sequence, is returned." + (seq-dispatch sequence + (if sequence + (list-delete-duplicates* sequence test test-not key from-end start end)) + (vector-delete-duplicates* sequence test test-not key from-end start end))) + +(defun list-substitute* (pred new list start end count key test test-not old) + (declare (fixnum start end count)) + (let* ((result (list nil)) + elt + (splice result) + (list list)) ; Get a local list for a stepper. + (do ((index 0 (1+ index))) + ((= index start)) + (declare (fixnum index)) + (setq splice (cdr (rplacd splice (list (car list))))) + (setq list (cdr list))) + (do ((index start (1+ index))) + ((or (= index end) (null list) (= count 0))) + (declare (fixnum index)) + (setq elt (car list)) + (setq splice + (cdr (rplacd splice + (list + (cond + ((case pred + (normal + (if test-not + (not + (funcall test-not (apply-key key elt) old)) + (funcall test (apply-key key elt) old))) + (if (funcall test (apply-key key elt))) + (if-not (not (funcall test (apply-key key elt))))) + (setq count (1- count)) + new) + (t elt)))))) + (setq list (cdr list))) + (do () + ((null list)) + (setq splice (cdr (rplacd splice (list (car list))))) + (setq list (cdr list))) + (cdr result))) + +;;; Replace old with new in sequence moving from left to right by incrementer +;;; on each pass through the loop. Called by all three substitute functions. +(defun vector-substitute* (pred new sequence incrementer left right length + start end count key test test-not old) + (declare (fixnum start count end incrementer right)) + (let ((result (make-sequence-like sequence length)) + (index left)) + (declare (fixnum index)) + (do () + ((= index start)) + (setf (aref result index) (aref sequence index)) + (setq index (+ index incrementer))) + (do ((elt)) + ((or (= index end) (= count 0))) + (setq elt (aref sequence index)) + (setf (aref result index) + (cond ((case pred + (normal + (if test-not + (not (funcall test-not (apply-key key elt) old)) + (funcall test (apply-key key elt) old))) + (if (funcall test (apply-key key elt))) + (if-not (not (funcall test (apply-key key elt))))) + (setq count (1- count)) + new) + (t elt))) + (setq index (+ index incrementer))) + (do () + ((= index right)) + (setf (aref result index) (aref sequence index)) + (setq index (+ index incrementer))) + result)) + +(eval-when (compile eval) + + +(defmacro subst-dispatch (pred) + `(if (listp sequence) + (if from-end + (nreverse (list-substitute* ,pred new (reverse sequence) + (- (the fixnum length) (the fixnum end)) + (- (the fixnum length) (the fixnum start)) + count key test test-not old)) + (list-substitute* ,pred new sequence start end count key test test-not + old)) + (if from-end + (vector-substitute* ,pred new sequence -1 (1- (the fixnum length)) + -1 length (1- (the fixnum end)) + (1- (the fixnum start)) count key test test-not old) + (vector-substitute* ,pred new sequence 1 0 length length + start end count key test test-not old)))) + +) + + +;;; Substitute: + +(defun substitute (new old sequence &key from-end (test #'eql) test-not + (start 0) (count most-positive-fixnum) + end key) + "Returns a sequence of the same kind as Sequence with the same elements + except that all elements equal to Old are replaced with New. See manual + for details." + (declare (fixnum start count)) + (when (null end) (setf end (length sequence))) + (let ((length (length sequence)) + (old (apply-key key old))) + (declare (fixnum length)) + (subst-dispatch 'normal))) + + +;;; Substitute-If: + +(defun substitute-if (new test sequence &key from-end (start 0) + end (count most-positive-fixnum) key) + "Returns a sequence of the same kind as Sequence with the same elements + except that all elements satisfying the Test are replaced with New. See + manual for details." + (declare (fixnum start count)) + (when (null end) (setf end (length sequence))) + (let ((length (length sequence)) + test-not + old) + (declare (fixnum length)) + (subst-dispatch 'if))) + + +;;; Substitute-If-Not: + +(defun substitute-if-not (new test sequence &key from-end (start 0) + end (count most-positive-fixnum) key) + "Returns a sequence of the same kind as Sequence with the same elements + except that all elements not satisfying the Test are replaced with New. + See manual for details." + (declare (fixnum start count)) + (when (null end) (setf end (length sequence))) + (let ((length (length sequence)) + test-not + old) + (declare (fixnum length)) + (subst-dispatch 'if-not))) + + + +;;; NSubstitute: + +(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not + end (count most-positive-fixnum) key (start 0)) + "Returns a sequence of the same kind as Sequence with the same elements + except that all elements equal to Old are replaced with New. The Sequence + may be destroyed. See manual for details." + (declare (fixnum count start)) + (when (null end) (setf end (length sequence))) + (let ((incrementer 1)) + (declare (fixnum incrementer)) + (if from-end + (psetq start (1- end) + end (1- start) + incrementer -1)) + (if (listp sequence) + (if from-end + (nreverse (nlist-substitute* + new old (nreverse (the list sequence)) + test test-not start end count key)) + (nlist-substitute* new old sequence + test test-not start end count key)) + (nvector-substitute* new old sequence incrementer + test test-not start end count key)))) + +(defun nlist-substitute* (new old sequence test test-not start end count key) + (declare (fixnum start count end)) + (do ((list (nthcdr start sequence) (cdr list)) + (index start (1+ index))) + ((or (= index end) (null list) (= count 0)) sequence) + (declare (fixnum index)) + (when (if test-not + (not (funcall test-not (apply-key key (car list)) old)) + (funcall test (apply-key key (car list)) old)) + (rplaca list new) + (setq count (1- count))))) + +(defun nvector-substitute* (new old sequence incrementer + test test-not start end count key) + (declare (fixnum start incrementer count end)) + (do ((index start (+ index incrementer))) + ((or (= index end) (= count 0)) sequence) + (declare (fixnum index)) + (when (if test-not + (not (funcall test-not (apply-key key (aref sequence index)) old)) + (funcall test (apply-key key (aref sequence index)) old)) + (setf (aref sequence index) new) + (setq count (1- count))))) + + +;;; NSubstitute-If: + +(defun nsubstitute-if (new test sequence &key from-end (start 0) + end (count most-positive-fixnum) key) + "Returns a sequence of the same kind as Sequence with the same elements + except that all elements satisfying the Test are replaced with New. The + Sequence may be destroyed. See manual for details." + (declare (fixnum start count)) + (when (null end) (setf end (length sequence))) + (let ((incrementer 1)) + (declare (fixnum incrementer)) + (if from-end + (psetq start (1- end) + end (1- start) + incrementer -1)) + (if (listp sequence) + (if from-end + (nreverse (nlist-substitute-if* + new test (nreverse (the list sequence)) + start end count key)) + (nlist-substitute-if* new test sequence + start end count key)) + (nvector-substitute-if* new test sequence incrementer + start end count key)))) + +(defun nlist-substitute-if* (new test sequence start end count key) + (declare (fixnum end)) + (do ((list (nthcdr start sequence) (cdr list)) + (index start (1+ index))) + ((or (= index end) (null list) (= count 0)) sequence) + (when (funcall test (apply-key key (car list))) + (rplaca list new) + (setq count (1- count))))) + +(defun nvector-substitute-if* (new test sequence incrementer + start end count key) + (do ((index start (+ index incrementer))) + ((or (= index end) (= count 0)) sequence) + (when (funcall test (apply-key key (aref sequence index))) + (setf (aref sequence index) new) + (setq count (1- count))))) + + +;;; NSubstitute-If-Not: + +(defun nsubstitute-if-not (new test sequence &key from-end (start 0) + end (count most-positive-fixnum) key) + "Returns a sequence of the same kind as Sequence with the same elements + except that all elements not satisfying the Test are replaced with New. + The Sequence may be destroyed. See manual for details." + (declare (fixnum start end count)) + (when (null end) (setf end (length sequence))) + (let ((incrementer 1)) + (if from-end + (psetq start (1- end) + end (1- start) + incrementer -1)) + (if (listp sequence) + (if from-end + (nreverse (nlist-substitute-if-not* + new test (nreverse (the list sequence)) + start end count key)) + (nlist-substitute-if-not* new test sequence + start end count key)) + (nvector-substitute-if-not* new test sequence incrementer + start end count key)))) + +(defun nlist-substitute-if-not* (new test sequence start end count key) + (declare (fixnum end)) + (do ((list (nthcdr start sequence) (cdr list)) + (index start (1+ index))) + ((or (= index end) (null list) (= count 0)) sequence) + (when (not (funcall test (apply-key key (car list)))) + (rplaca list new) + (setq count (1- count))))) + +(defun nvector-substitute-if-not* (new test sequence incrementer + start end count key) + (do ((index start (+ index incrementer))) + ((or (= index end) (= count 0)) sequence) + (when (not (funcall test (apply-key key (aref sequence index)))) + (setf (aref sequence index) new) + (setq count (1- count))))) + + +;;; Locater macros used by FIND and POSITION. + +(eval-when (compile eval) + +(defmacro vector-locater-macro (sequence body-form return-type) + `(let ((incrementer (if from-end -1 1)) + (start (if from-end (1- (the fixnum end)) start)) + (end (if from-end (1- (the fixnum start)) end))) + (declare (fixnum start end incrementer)) + (do ((index start (+ index incrementer)) + ,@(case return-type (:position nil) (:element '(current)))) + ((= index end) ()) + (declare (fixnum index)) + ,@(case return-type + (:position nil) + (:element `((setf current (aref ,sequence index))))) + ,body-form))) + +(defmacro locater-test-not (item sequence seq-type return-type) + (let ((seq-ref (case return-type + (:position + (case seq-type + (:vector `(aref ,sequence index)) + (:list `(pop ,sequence)))) + (:element 'current))) + (return (case return-type + (:position 'index) + (:element 'current)))) + `(if test-not + (if (not (funcall test-not ,item (apply-key key ,seq-ref))) + (return ,return)) + (if (funcall test ,item (apply-key key ,seq-ref)) + (return ,return))))) + +(defmacro vector-locater (item sequence return-type) + `(vector-locater-macro ,sequence + (locater-test-not ,item ,sequence :vector ,return-type) + ,return-type)) + +(defmacro locater-if-test (test sequence seq-type return-type sense) + (let ((seq-ref (case return-type + (:position + (case seq-type + (:vector `(aref ,sequence index)) + (:list `(pop ,sequence)))) + (:element 'current))) + (return (case return-type + (:position 'index) + (:element 'current)))) + (if sense + `(if (funcall ,test (apply-key key ,seq-ref)) + (return ,return)) + `(if (not (funcall ,test (apply-key key ,seq-ref))) + (return ,return))))) + +(defmacro vector-locater-if-macro (test sequence return-type sense) + `(vector-locater-macro ,sequence + (locater-if-test ,test ,sequence :vector ,return-type ,sense) + ,return-type)) + +(defmacro vector-locater-if (test sequence return-type) + `(vector-locater-if-macro ,test ,sequence ,return-type t)) + +(defmacro vector-locater-if-not (test sequence return-type) + `(vector-locater-if-macro ,test ,sequence ,return-type nil)) + + +(defmacro list-locater-macro (sequence body-form return-type) + `(if from-end + (do ((sequence (nthcdr (- (the fixnum (length sequence)) + (the fixnum end)) + (reverse (the list ,sequence)))) + (index (1- (the fixnum end)) (1- index)) + (terminus (1- (the fixnum start))) + ,@(case return-type (:position nil) (:element '(current)))) + ((or (= index terminus) (null sequence)) ()) + (declare (fixnum index terminus)) + ,@(case return-type + (:position nil) + (:element `((setf current (pop ,sequence))))) + ,body-form) + (do ((sequence (nthcdr start ,sequence)) + (index start (1+ index)) + ,@(case return-type (:position nil) (:element '(current)))) + ((or (= index (the fixnum end)) (null sequence)) ()) + (declare (fixnum index)) + ,@(case return-type + (:position nil) + (:element `((setf current (pop ,sequence))))) + ,body-form))) + +(defmacro list-locater (item sequence return-type) + `(list-locater-macro ,sequence + (locater-test-not ,item ,sequence :list ,return-type) + ,return-type)) + +(defmacro list-locater-if-macro (test sequence return-type sense) + `(list-locater-macro ,sequence + (locater-if-test ,test ,sequence :list ,return-type ,sense) + ,return-type)) + +(defmacro list-locater-if (test sequence return-type) + `(list-locater-if-macro ,test ,sequence ,return-type t)) + +(defmacro list-locater-if-not (test sequence return-type) + `(list-locater-if-macro ,test ,sequence ,return-type nil)) + +) ; eval-when + + +;;; Position: + +(eval-when (compile eval) + +(defmacro vector-position (item sequence) + `(vector-locater ,item ,sequence :position)) + +(defmacro list-position (item sequence) + `(list-locater ,item ,sequence :position)) + +) ; eval-when + + +;;; POSITION cannot default end to the length of sequence since it is not +;;; an error to supply nil for its value. We must test for end being nil +;;; in the body of the function, and this is actually done in the support +;;; routines for other reasons (see below). +(defun position (item sequence &key from-end (test #'eql) test-not (start 0) + end key) + "Returns the zero-origin index of the first element in SEQUENCE + satisfying the test (default is EQL) with the given ITEM" + (seq-dispatch sequence + (list-position* item sequence from-end test test-not start end key) + (vector-position* item sequence from-end test test-not start end key))) + + +;;; The support routines for SUBSEQ are used by compiler transforms, so we +;;; worry about dealing with end being supplied as or defaulting to nil +;;; at this level. + +(defun list-position* (item sequence from-end test test-not start end key) + (declare (fixnum start)) + (when (null end) (setf end (length sequence))) + (list-position item sequence)) + +(defun vector-position* (item sequence from-end test test-not start end key) + (declare (fixnum start)) + (when (null end) (setf end (length sequence))) + (vector-position item sequence)) + + +;;; Position-if: + +(eval-when (compile eval) + +(defmacro vector-position-if (test sequence) + `(vector-locater-if ,test ,sequence :position)) + + +(defmacro list-position-if (test sequence) + `(list-locater-if ,test ,sequence :position)) + +) + +(defun position-if (test sequence &key from-end (start 0) key end) + "Returns the zero-origin index of the first element satisfying test(el)" + (declare (fixnum start)) + (when (null end) (setf end (length sequence))) + (seq-dispatch sequence + (list-position-if test sequence) + (vector-position-if test sequence))) + + +;;; Position-if-not: + +(eval-when (compile eval) + +(defmacro vector-position-if-not (test sequence) + `(vector-locater-if-not ,test ,sequence :position)) + +(defmacro list-position-if-not (test sequence) + `(list-locater-if-not ,test ,sequence :position)) + +) + +(defun position-if-not (test sequence &key from-end (start 0) key end) + "Returns the zero-origin index of the first element not satisfying test(el)" + (declare (fixnum start)) + (when (null end) (setf end (length sequence))) + (seq-dispatch sequence + (list-position-if-not test sequence) + (vector-position-if-not test sequence))) + + +;;; Find: + +(eval-when (compile eval) + +(defmacro vector-find (item sequence) + `(vector-locater ,item ,sequence :element)) + +(defmacro list-find (item sequence) + `(list-locater ,item ,sequence :element)) + +) + +;;; FIND cannot default end to the length of sequence since it is not +;;; an error to supply nil for its value. We must test for end being nil +;;; in the body of the function, and this is actually done in the support +;;; routines for other reasons (see above). +(defun find (item sequence &key from-end (test #'eql) test-not (start 0) + end key) + "Returns the first element in SEQUENCE satisfying the test (default + is EQL) with the given ITEM" + (declare (fixnum start)) + (seq-dispatch sequence + (list-find* item sequence from-end test test-not start end key) + (vector-find* item sequence from-end test test-not start end key)))) + + +;;; The support routines for FIND are used by compiler transforms, so we +;;; worry about dealing with end being supplied as or defaulting to nil +;;; at this level. + +(defun list-find* (item sequence from-end test test-not start end key) + (when (null end) (setf end (length sequence))) + (list-find item sequence)) + +(defun vector-find* (item sequence from-end test test-not start end key) + (when (null end) (setf end (length sequence))) + (vector-find item sequence)) + + +;;; Find-if: + +(eval-when (compile eval) + +(defmacro vector-find-if (test sequence) + `(vector-locater-if ,test ,sequence :element)) + +(defmacro list-find-if (test sequence) + `(list-locater-if ,test ,sequence :element)) + +) + +(defun find-if (test sequence &key from-end (start 0) end key) + "Returns the zero-origin index of the first element satisfying the test." + (declare (fixnum start)) + (when (null end) (setf end (length sequence))) + (seq-dispatch sequence + (list-find-if test sequence) + (vector-find-if test sequence))) + + +;;; Find-if-not: + +(eval-when (compile eval) + +(defmacro vector-find-if-not (test sequence) + `(vector-locater-if-not ,test ,sequence :element)) + +(defmacro list-find-if-not (test sequence) + `(list-locater-if-not ,test ,sequence :element)) + +) + +(defun find-if-not (test sequence &key from-end (start 0) end key) + "Returns the zero-origin index of the first element not satisfying the test." + (declare (fixnum start)) + (when (null end) (setf end (length sequence))) + (seq-dispatch sequence + (list-find-if-not test sequence) + (vector-find-if-not test sequence))) + + +;;; Count: + +(eval-when (compile eval) + +(defmacro vector-count (item sequence) + `(do ((index start (1+ index)) + (count 0)) + ((= index (the fixnum end)) count) + (declare (fixnum index count)) + (if test-not + (if (funcall test-not ,item (apply-key key (aref ,sequence index))) + (setq count (1+ count))) + (if (funcall test ,item (apply-key key (aref ,sequence index))) + (setq count (1+ count)))))) + +(defmacro list-count (item sequence) + `(do ((sequence (nthcdr start ,sequence)) + (index start (1+ index)) + (count 0)) + ((or (= index (the fixnum end)) (null sequence)) count) + (declare (fixnum index count)) + (if test-not + (if (funcall test-not ,item (apply-key key (pop sequence))) + (setq count (1+ count))) + (if (funcall test ,item (apply-key key (pop sequence))) + (setq count (1+ count)))))) + +) + +(defun count (item sequence &key from-end (test #'eql) test-not (start 0) + end key) + "Returns the number of elements in SEQUENCE satisfying a test with ITEM, + which defaults to EQL." + (declare (ignore from-end) (fixnum start)) + (when (null end) (setf end (length sequence))) + (seq-dispatch sequence + (list-count item sequence) + (vector-count item sequence))) + + +;;; Count-if: + +(eval-when (compile eval) + +(defmacro vector-count-if (predicate sequence) + `(do ((index start (1+ index)) + (count 0)) + ((= index (the fixnum end)) count) + (declare (fixnum index count)) + (if (funcall ,predicate (apply-key key (aref ,sequence index))) + (setq count (1+ count))))) + +(defmacro list-count-if (predicate sequence) + `(do ((sequence (nthcdr start ,sequence)) + (index start (1+ index)) + (count 0)) + ((or (= index (the fixnum end)) (null sequence)) count) + (declare (fixnum index count)) + (if (funcall ,predicate (apply-key key (pop sequence))) + (setq count (1+ count))))) + +) + +(defun count-if (test sequence &key from-end (start 0) end key) + "Returns the number of elements in SEQUENCE satisfying TEST(el)." + (declare (ignore from-end) (fixnum start)) + (when (null end) (setf end (length sequence))) + (seq-dispatch sequence + (list-count-if test sequence) + (vector-count-if test sequence))) + + +;;; Count-if-not: + +(eval-when (compile eval) + +(defmacro vector-count-if-not (predicate sequence) + `(do ((index start (1+ index)) + (count 0)) + ((= index (the fixnum end)) count) + (declare (fixnum index count)) + (if (not (funcall ,predicate (apply-key key (aref ,sequence index)))) + (setq count (1+ count))))) + +(defmacro list-count-if-not (predicate sequence) + `(do ((sequence (nthcdr start ,sequence)) + (index start (1+ index)) + (count 0)) + ((or (= index (the fixnum end)) (null sequence)) count) + (declare (fixnum index count)) + (if (not (funcall ,predicate (apply-key key (pop sequence)))) + (setq count (1+ count))))) + +) + +(defun count-if-not (test sequence &key from-end (start 0) end key) + "Returns the number of elements in SEQUENCE not satisfying TEST(el)." + (declare (ignore from-end) (fixnum start)) + (when (null end) (setf end (length sequence))) + (seq-dispatch sequence + (list-count-if-not test sequence) + (vector-count-if-not test sequence))) + + +;;; Mismatch utilities: + +(eval-when (compile eval) + + +(defmacro match-vars (&rest body) + `(let ((inc (if from-end -1 1)) + (start1 (if from-end (1- (the fixnum end1)) start1)) + (start2 (if from-end (1- (the fixnum end2)) start2)) + (end1 (if from-end (1- (the fixnum start1)) end1)) + (end2 (if from-end (1- (the fixnum start2)) end2))) + (declare (fixnum inc start1 start2 end1 end2)) + ,@body)) + +(defmacro matchify-list (sequence start length end) + `(setq ,sequence + (if from-end + (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1) + (reverse (the list ,sequence))) + (nthcdr ,start ,sequence)))) + +) + +;;; Mismatch: + +(eval-when (compile eval) + +(defmacro if-mismatch (elt1 elt2) + `(cond ((= (the fixnum index1) (the fixnum end1)) + (return (if (= (the fixnum index2) (the fixnum end2)) + nil + (if from-end + (1+ (the fixnum index1)) + (the fixnum index1))))) + ((= (the fixnum index2) (the fixnum end2)) + (return (if from-end (1+ (the fixnum index1)) index1))) + (test-not + (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2)) + (return (if from-end (1+ (the fixnum index1)) index1)))) + (t (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2))) + (return (if from-end (1+ (the fixnum index1)) index1)))))) + +(defmacro mumble-mumble-mismatch () + `(do ((index1 start1 (+ index1 (the fixnum inc))) + (index2 start2 (+ index2 (the fixnum inc)))) + (()) + (declare (fixnum index1 index2)) + (if-mismatch (aref sequence1 index1) (aref sequence2 index2)))) + +(defmacro mumble-list-mismatch () + `(do ((index1 start1 (+ index1 (the fixnum inc))) + (index2 start2 (+ index2 (the fixnum inc)))) + (()) + (declare (fixnum index1 index2)) + (if-mismatch (aref sequence1 index1) (pop sequence2)))) + +(defmacro list-mumble-mismatch () + `(do ((index1 start1 (+ index1 (the fixnum inc))) + (index2 start2 (+ index2 (the fixnum inc)))) + (()) + (declare (fixnum index1 index2)) + (if-mismatch (pop sequence1) (aref sequence2 index2)))) + +(defmacro list-list-mismatch () + `(do ((index1 start1 (+ index1 (the fixnum inc))) + (index2 start2 (+ index2 (the fixnum inc)))) + (()) + (declare (fixnum index1 index2)) + (if-mismatch (pop sequence1) (pop sequence2)))) + +) + +(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not + (start1 0) end1 (start2 0) end2 key) + "The specified subsequences of Sequence1 and Sequence2 are compared + element-wise. If they are of equal length and match in every element, the + result is Nil. Otherwise, the result is a non-negative integer, the index + within Sequence1 of the leftmost position at which they fail to match; or, if + one is shorter than and a matching prefix of the other, the index within + Sequence1 beyond the last position tested is returned. If a non-Nil :From-End + keyword argument is given, then one plus the index of the rightmost position in + which the sequences differ is returned." + (declare (fixnum start1 start2)) + (when (null end1) (setf end1 (length sequence1))) + (when (null end2) (setf end2 (length sequence2))) + (let ((length1 (length sequence1)) + (length2 (length sequence2))) + (declare (fixnum length1 length2)) + (match-vars + (seq-dispatch sequence1 + (progn (matchify-list sequence1 start1 length1 end1) + (seq-dispatch sequence2 + (progn (matchify-list sequence2 start2 length2 end2) + (list-list-mismatch)) + (list-mumble-mismatch))) + (seq-dispatch sequence2 + (progn (matchify-list sequence2 start2 length2 end2) + (mumble-list-mismatch)) + (mumble-mumble-mismatch)))))) + + +;;; Search comparison functions: + +(eval-when (compile eval) + +;;; Compare two elements and return if they don't match: + +(defmacro compare-elements (elt1 elt2) + `(if test-not + (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2)) + (return nil) + t) + (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2))) + (return nil) + t))) + +(defmacro search-compare-list-list (main sub) + `(do ((main ,main (cdr main)) + (jndex start1 (1+ jndex)) + (sub (nthcdr start1 ,sub) (cdr sub))) + ((or (null main) (null sub) (= (the fixnum end1) jndex)) + t) + (declare (fixnum jndex)) + (compare-elements (car main) (car sub)))) + +(defmacro search-compare-list-vector (main sub) + `(do ((main ,main (cdr main)) + (index start1 (1+ index))) + ((or (null main) (= index (the fixnum end1))) t) + (declare (fixnum index)) + (compare-elements (car main) (aref ,sub index)))) + +(defmacro search-compare-vector-list (main sub index) + `(do ((sub (nthcdr start1 ,sub) (cdr sub)) + (jndex start1 (1+ jndex)) + (index ,index (1+ index))) + ((or (= (the fixnum end1) jndex) (null sub)) t) + (declare (fixnum jndex index)) + (compare-elements (aref ,main index) (car sub)))) + +(defmacro search-compare-vector-vector (main sub index) + `(do ((index ,index (1+ index)) + (sub-index start1 (1+ sub-index))) + ((= sub-index (the fixnum end1)) t) + (declare (fixnum sub-index index)) + (compare-elements (aref ,main index) (aref ,sub sub-index)))) + +(defmacro search-compare (main-type main sub index) + (if (eq main-type 'list) + `(seq-dispatch ,sub + (search-compare-list-list ,main ,sub) + (search-compare-list-vector ,main ,sub)) + `(seq-dispatch ,sub + (search-compare-vector-list ,main ,sub ,index) + (search-compare-vector-vector ,main ,sub ,index)))) + +) + +(eval-when (compile eval) + +(defmacro list-search (main sub) + `(do ((main (nthcdr start2 ,main) (cdr main)) + (index2 start2 (1+ index2)) + (terminus (- (the fixnum end2) + (the fixnum (- (the fixnum end1) + (the fixnum start1))))) + (last-match ())) + ((> index2 terminus) last-match) + (declare (fixnum index2 terminus)) + (if (search-compare list main ,sub index2) + (if from-end + (setq last-match index2) + (return index2))))) + + +(defmacro vector-search (main sub) + `(do ((index2 start2 (1+ index2)) + (terminus (- (the fixnum end2) + (the fixnum (- (the fixnum end1) + (the fixnum start1))))) + (last-match ())) + ((> index2 terminus) last-match) + (declare (fixnum index2 terminus)) + (if (search-compare vector ,main ,sub index2) + (if from-end + (setq last-match index2) + (return index2))))) + +) + + +(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not + (start1 0) end1 (start2 0) end2 key) + "A search is conducted using EQL for the first subsequence of sequence2 + which element-wise matches sequence1. If there is such a subsequence in + sequence2, the index of the its leftmost element is returned; + otherwise () is returned." + (declare (fixnum start1 start2)) + (when (null end1) (setf end1 (length sequence1))) + (when (null end2) (setf end2 (length sequence2))) + (seq-dispatch sequence2 + (list-search sequence2 sequence1) + (vector-search sequence2 sequence1))) diff --git a/code/sharpm.lisp b/code/sharpm.lisp new file mode 100644 index 000000000..c24253b5f --- /dev/null +++ b/code/sharpm.lisp @@ -0,0 +1,456 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Spice Lisp Interim Sharp Macro +;;; Written by David Dill +;;; Runs in the standard Spice Lisp environment. +;;; This uses the special std-lisp-readtable, which is internal to READER.LISP +;;; +;;; **************************************************************** +(in-package 'lisp) + + +;;; declared in READ.LISP + +(proclaim '(special *read-suppress* std-lisp-readtable *bq-vector-flag*)) + +(defun sharp-backslash (stream backslash font) + (unread-char backslash stream) + (let* ((*readtable* std-lisp-readtable) + (bitnames ()) + (charstring (read-extended-token stream))) + (declare (simple-string charstring)) + (when *read-suppress* (return-from sharp-backslash nil)) + ;;find bit name prefixes + (do ((i (position #\- charstring) (position #\- charstring))) + ((or (null i) (zerop (the fixnum i)))) + (let ((bitname (string-upcase (subseq charstring 0 i)))) + (setq charstring (subseq charstring (1+ (the fixnum i)))) + ;;* symbols in alist are a kludge to circumvent xc bogosity. + (let ((expansion (cdr (assoc bitname '(("C" . CONTROL) + ("M" . META) + ("H" . HYPER) + ("S" . SUPER)) + :test #'equal)))) + (if expansion (setq bitname (symbol-name expansion))) + (cond ((member bitname '("CONTROL" "META" "HYPER" "SUPER") + :test #'EQUAL) + (if (not (member bitname bitnames :test #'EQUAL)) + (push bitname bitnames) + (error + "Redundant bit name in character name: ~A" + bitname))) + (t (error + "Meaningless bit name in character name: ~A" + bitname)))))) + ;;build un-hyphenated char, add specified bits: + (let ((char (if (= (the fixnum (length charstring)) 1) + (char charstring 0) + (name-char charstring)))) + (cond (char + (if font + (setq char (make-char char 0 font))) + (if (member "CONTROL" bitnames :test #'EQUAL) + (setq char (set-char-bit char :control t))) + (if (member "META" bitnames :test #'EQUAL) + (setq char (set-char-bit char :meta t))) + (if (member "HYPER" bitnames :test #'EQUAL) + (setq char (set-char-bit char :hyper t))) + (if (member "SUPER" bitnames :test #'EQUAL) + (setq char (set-char-bit char :super t))) + char) + (t (error "Meaningless character name ~A" + charstring)))))) + +(defun sharp-quote (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + ;; 4th arg tells read that this is a recrusive call. + `(function ,(read stream () () t))) + +(defun sharp-left-paren (stream ignore length) + (declare (ignore ignore)) + (declare (special *backquote-count*)) + (let* ((list (read-list stream nil)) + (listlength (length list))) + (declare (list list) + (fixnum listlength)) + (cond (*read-suppress*) + ((zerop *backquote-count*) + (if length + (cond ((> listlength (the fixnum length)) + (error + "Vector longer than specified length: #~S~S" + length list)) + (t + (fill (the simple-vector + (replace (the simple-vector (make-array length)) + list)) + (car (last list)) + :start listlength))) + (coerce list 'vector))) + (t (cons *bq-vector-flag* list))))) + +(defun sharp-star (stream ignore numarg) + (declare (ignore ignore)) + (multiple-value-bind (bstring escape-appearedp) + (read-extended-token stream) + (declare (simple-string bstring)) + (cond (*read-suppress*) + (escape-appearedp + (error "Escape character appeared after #*")) + ((and numarg (zerop (length bstring)) (not (zerop numarg))) + (error "You have to give a little bit for non-zero #* bit-vectors.")) + ((or (null numarg) (>= (the fixnum numarg) (length bstring))) + (let* ((len1 (length bstring)) + (last1 (1- len1)) + (len2 (or numarg len1)) + (bvec (make-array len2 :element-type 'bit + :initial-element 0))) + (declare (fixnum len1 last1 len2)) + (do ((i 0 (1+ i)) + (char ())) + ((= i len2)) + (declare (fixnum i)) + (setq char (elt bstring (if (< i len1) i last1))) + (setf (elt bvec i) + (cond ((char= char #\0) 0) + ((char= char #\1) 1) + (t + (error "Illegal element given for ~ + bitvector #~A*~A" + numarg bstring))))) + bvec)) + (t + (error "Bit vector is longer than specified length #~A*~A" + numarg bstring))))) + + +(defun sharp-colon (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + (when *read-suppress* + (read stream () () t) + (return-from sharp-colon nil)) + (let ((token (read-extended-token stream))) + (declare (simple-string token)) + (cond (*read-suppress*) + ((find #\: token) + (error "Symbol following #: contains a #\: ~S" token)) + ((eql (length token) 0) + (let ((ch (read-char stream nil nil t))) + (if ch + (error "Illegal terminating character after a colon, ~S." ch) + (error "Illegal terminating character after a colon.")))) + (T (make-symbol token))))) + +(defun sharp-dot (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + (let ((token (read stream () () t))) + (unless *read-suppress* (eval token)))) + +(defun sharp-comma (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + (let ((token (read stream () () t))) + (unless *read-suppress* (eval token)))) + +(defun sharp-R (stream ignore radix) + (declare (ignore ignore)) + (multiple-value-bind (token escape-appearedp) + (read-extended-token stream) + (declare (simple-string token)) + (when *read-suppress* (return-from sharp-R nil)) + (let ((numval 0) (denval 0) (resttok 0) (toklength (length token)) + (sign 1)) + (declare (fixnum toklength)) + (if escape-appearedp + (error "Escape character appears in number.")) + ;;look for leading sign + (let ((firstchar (elt token 0))) + (cond ((char= firstchar #\-) + (setq sign -1) + (setq resttok 1)) + ((char= firstchar #\+) + (setq resttok 1)))) + ;;read numerator + (do ((position resttok (1+ position)) + (dig ())) + ((or (>= position toklength) + (not (setq dig (digit-char-p (elt token position) radix)))) + (setq resttok position)) + (setq numval (+ (* numval radix) dig))) + ;;see if we're at the end. + (cond ((>= resttok toklength) + ;;just return numerator -- that's all there is. + (* numval sign)) + ((char= (elt token resttok) #\/) + ;;it's a ratio. + (do ((position (1+ resttok) (1+ position)) + (dig ()) + (retval ())) + ((cond ((>= position toklength) + (setq retval (/ (* numval sign) denval))) + ((not (setq dig (digit-char-p (elt token position) + radix))) + ;;there's bogus stuff at the end + (error + "Illegal digits ~S for radix ~S" token radix) + (setq retval (/ (* numval sign) denval))) + ;;continue looping + (t nil)) + retval) + (setq denval (+ (* denval radix) dig)))) + ;;it's bogus + (t (error + "Illegal digits ~S for radix ~S" token radix))))))) + +(defun sharp-B (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + (sharp-r stream nil 2)) + +(defun sharp-O (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + (sharp-r stream nil 8)) + +(defun sharp-X (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + (sharp-r stream nil 16)) + +(defun sharp-A (stream ignore dimensions) + (declare (ignore ignore)) + (when *read-suppress* + (read stream () () t) + (return-from sharp-A nil)) + (unless dimensions (error "No dimensions argument to #A.")) + (unless (and (integerp dimensions) (>= dimensions 0)) + (error "Dimensions argument to #A not a non-negative integer: ~S" + dimensions)) + (if (> dimensions 0) + (let ((dlist (make-list dimensions)) + (init-list + (if (char= (read-char stream t) #\( #|)|#) + (read-list stream nil) + (error "Array values must be a list.")))) + (do ((dl dlist (cdr dl)) + (il init-list (car il))) + ;; I think the nreverse is causing the problem. + ((null dl)) + (if (listp il) + (rplaca dl (length il)) + (error + "Initial contents for #A is inconsistent with ~ + dimensions: #~SA~S" dimensions init-list))) + (make-array dlist :initial-contents init-list)) + (make-array nil :initial-element (read stream t nil t)))) + + +(defun sharp-S (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + ;;this needs to know about defstruct implementation + (when *read-suppress* + (read stream () () t) + (return-from sharp-S nil)) + (let ((body + (if (char= (read-char stream t) #\( ) + (read-list stream nil) + (error "Non-list following #S")))) + (cond ((listp body) + (unless (symbolp (car body)) + (error "Structure type is not a symbol: ~S" (car body))) + (let ((defstruct (info type structure-info (car body)))) + (unless defstruct + (error "~S is not a defined structure type." (car body))) + (unless (c::dd-constructor defstruct) + (error "The ~S structure does not have a default constructor." (car body))) + (do ((arg (cdr body) (cddr arg)) + (res ())) + ((endp arg) (apply (c::dd-constructor defstruct) res)) + (push (cadr arg) res) + (push (intern (string (car arg)) *keyword-package*) res)))) + (t (error "Non-list following #S: ~S" body)))))) + +(defmacro int-subst-array (new old array rank var-list) + (if (> rank (array-rank array)) + (let ((new-list (nreverse var-list))) + `(if (eq ,old (aref ,array ,@new-list)) + (setf (aref ,array ,@new-list) ,new))) + (let ((newvar (gensym))) + `(dotimes (,newvar (array-dimension ,array ,rank)) + (int-subst-array ,new ,old ,array (1+ ,rank) + (push ,newvar ,var-list)))))) + +(defmacro subst-array (new old array) + `(int-subst-array ,new ,old ,array 0 nil)) + +(defvar sharp-cons-table () + "Holds the cons cells seen already by circle-subst") + +;; This function is the same as nsubst, except that it checks for circular +;; lists. the first arg is an alist of the things to be replaced assoc'd with +;; the things to replace them. +(defun circle-subst (old-new-alist tree) + (cond ((and (atom tree) + (not (and (arrayp tree) + (eq (array-element-type tree) t)))) + (let ((pair (assq tree old-new-alist))) + (if pair (cdr pair) tree))) + ((null (gethash tree sharp-cons-table)) + (setf (gethash tree sharp-cons-table) t) + (cond ((simple-vector-p tree) + (do ((i 0 (1+ i)) + (len (length tree))) + ((>= i len)) + (declare (fixnum i len)) + (setf (svref tree i) + (circle-subst old-new-alist (svref tree i)))) + tree) + ((arrayp tree) + (with-array-data ((data tree) (start) (end)) + (declare (fixnum start end)) + (do ((i start (1+ i))) + ((>= i end)) + (setf (aref data i) + (circle-subst old-new-alist (aref data i))))) + tree) + (T (let ((a (circle-subst old-new-alist (car tree))) + (d (circle-subst old-new-alist (cdr tree)))) + (if (eq a (car tree)) + tree + (rplaca tree a)) + (if (eq d (cdr tree)) + tree + (rplacd tree d))) + tree))) + (t tree))) + +;; Sharp-equal works as follows. When a label is assigned +;; (ie when #= is called) a symbol (ref) is gensym'd and +;; a cons cell whose car is the label, and cdr is the symbol +;; is put on the sharp-sharp alist. When sharp-sharp encounters +;; a reference to a label it returns the symbol assoc'd with the label. +;; When an object has been read then a cons cell whose car is the symbol +;; and cdr is the object is pushed onto the sharp-sharp-alist. Then +;; for each cons cell on the sharp-sharp-alist, the current object is searched +;; and where a symbol eq to the car of the current cons cell is found, +;; the object is substituted in. +(defun sharp-equal (stream ignore label &aux (ref (gensym))) + (declare (ignore ignore)) + (declare (special sharp-equal-alist sharp-sharp-alist)) + (when *read-suppress* (return-from sharp-equal (values))) + (unless (integerp label) + (error "non-integer label #~S=" label)) + (push (cons label ref) sharp-sharp-alist) + (let ((obj (read stream () () t))) + (push (cons ref obj) sharp-equal-alist) + (clrhash sharp-cons-table) + (circle-subst sharp-equal-alist obj))) + +(defun sharp-sharp (ignore1 ignore2 label) + (declare (ignore ignore1 ignore2)) + (declare (special sharp-equal-alist sharp-sharp-alist)) + (when *read-suppress* (return-from sharp-sharp nil)) + (if (integerp label) + (let ((pair (assoc label sharp-sharp-alist))) + (if pair + (let ((ret-obj (cdr (assoc (cdr pair) sharp-equal-alist)))) + (if ret-obj ret-obj + (cdr pair))) + (error "Object is not labelled #~S#" label))) + (error "Non-integer label #~S#" label))) + +(defun sharp-plus (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + (cond (*read-suppress* + (read stream () () t) + (values)) + ((featurep (let ((*package* *keyword-package*)) + (read stream () () t))) + (read stream () () t)) + (t (let ((*read-suppress* t)) + (read stream () () t) + (values))))) + +(defun sharp-minus (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + (cond (*read-suppress* + (read stream () () t) + (values)) + ((not (featurep (let ((*package* *keyword-package*)) + (read stream () () t)))) + (read stream () () t)) + (t (let ((*read-suppress* t)) + (read stream () () t) + (values))))) + +(defun sharp-C (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + ;;next thing better be a list of two numbers. + (let ((cnum (read stream () () t))) + (when *read-suppress* (return-from sharp-c nil)) + (if (= (length cnum) 2) + (complex (car cnum) (cadr cnum)) + (error "Illegal complex number format" cnum)))) + +(defun sharp-vertical-bar (stream ignore1 ignore2) + (declare (ignore ignore1 ignore2)) + (prepare-for-fast-read-char stream + (do ((level 1) + (prev (fast-read-char) char) + (char (fast-read-char) (fast-read-char))) + (()) + (cond ((and (char= prev #\|) (char= char #\#)) + (setq level (1- level)) + (when (zerop level) + (done-with-fast-read-char) + (return (values))) + (setq char (fast-read-char))) + ((and (char= prev #\#) (char= char #\|)) + (setq char (fast-read-char)) + (setq level (1+ level))))))) + +(defun sharp-illegal (ignore1 sub-char ignore2) + (declare (ignore ignore1 ignore2)) + (error "Illegal sharp character ~S" sub-char)) + + +(defun sharp-init () + (declare (special std-lisp-readtable)) + (setq sharp-cons-table (make-hash-table :size 50)) + (let ((*readtable* std-lisp-readtable)) + (make-dispatch-macro-character #\#) + (set-dispatch-macro-character #\# #\\ #'sharp-backslash) + (set-dispatch-macro-character #\# #\' #'sharp-quote) + (set-dispatch-macro-character #\# #\( #'sharp-left-paren) + (set-dispatch-macro-character #\# #\* #'sharp-star) + (set-dispatch-macro-character #\# #\: #'sharp-colon) + (set-dispatch-macro-character #\# #\. #'sharp-dot) + (set-dispatch-macro-character #\# #\, #'sharp-comma) + (set-dispatch-macro-character #\# #\R #'sharp-R) + (set-dispatch-macro-character #\# #\r #'sharp-R) + (set-dispatch-macro-character #\# #\B #'sharp-B) + (set-dispatch-macro-character #\# #\b #'sharp-B) + (set-dispatch-macro-character #\# #\O #'sharp-O) + (set-dispatch-macro-character #\# #\o #'sharp-O) + (set-dispatch-macro-character #\# #\X #'sharp-X) + (set-dispatch-macro-character #\# #\x #'sharp-X) + (set-dispatch-macro-character #\# #\A #'sharp-A) + (set-dispatch-macro-character #\# #\a #'sharp-A) + (set-dispatch-macro-character #\# #\S #'sharp-S) + (set-dispatch-macro-character #\# #\s #'sharp-S) + (set-dispatch-macro-character #\# #\= #'sharp-equal) + (set-dispatch-macro-character #\# #\# #'sharp-sharp) + (set-dispatch-macro-character #\# #\+ #'sharp-plus) + (set-dispatch-macro-character #\# #\- #'sharp-minus) + (set-dispatch-macro-character #\# #\C #'sharp-C) + (set-dispatch-macro-character #\# #\c #'sharp-C) + (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar) + (set-dispatch-macro-character #\# #\tab #'sharp-illegal) + (set-dispatch-macro-character #\# #\ #'sharp-illegal) + (set-dispatch-macro-character #\# #\) #'sharp-illegal) + (set-dispatch-macro-character #\# #\< #'sharp-illegal) + (set-dispatch-macro-character #\# #\form #'sharp-illegal) + (set-dispatch-macro-character #\# #\return #'sharp-illegal))) diff --git a/code/sort.lisp b/code/sort.lisp new file mode 100644 index 000000000..c1183a566 --- /dev/null +++ b/code/sort.lisp @@ -0,0 +1,442 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Sort functions for Spice Lisp +;;; these functions are part of the standard spice lisp environment. +;;; +;;; Written by Jim Large +;;; Hacked on and maintained by Skef Wholey +;;; Rewritten by Bill Chiles +;;; +;;; ******************************************************************* + +(in-package 'lisp) + +(export '(sort stable-sort merge)) + + + +(defun sort (sequence predicate &key key) + "Destructively sorts sequence. Predicate should returns non-Nil if + Arg1 is to precede Arg2." + (typecase sequence + (simple-vector + (if (> (the fixnum (length (the simple-vector sequence))) 0) + (sort-simple-vector sequence predicate key) + sequence)) + (list + (sort-list sequence predicate key)) + (vector + (if (> (the fixnum (length sequence)) 0) + (sort-vector sequence predicate key) + sequence)) + (t + (error "~S is not a sequence." sequence)))) + + + +;;; Sorting Vectors + +;;; Sorting is done with a heap sort. + +(eval-when (compile eval) + +;;; HEAPIFY, assuming both sons of root are heaps, percolates the root element +;;; through the sons to form a heap at root. Root and max are zero based +;;; coordinates, but the heap algorithm only works on arrays indexed from 1 +;;; through N (not 0 through N-1); This is because a root at I has sons at 2*I +;;; and 2*I+1 which does not work for a root at 0. Because of this, boundaries, +;;; roots, and termination are computed using 1..N indexes. + +(defmacro heapify (seq vector-ref root max pred key) + (let ((heap-root (gensym)) (heap-max (gensym)) (root-ele (gensym)) + (root-key (gensym)) (heap-max/2 (gensym)) (heap-l-son (gensym)) + (one-son (gensym)) (one-son-ele (gensym)) (one-son-key (gensym)) + (r-son-ele (gensym)) (r-son-key (gensym)) (var-root (gensym))) + `(let* ((,var-root ,root) ; necessary to not clobber calling root var. + (,heap-root (1+ ,root)) + (,heap-max (1+ ,max)) + (,root-ele (,vector-ref ,seq ,root)) + (,root-key (apply-key ,key ,root-ele)) + (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2) + (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2)) + (loop + (if (> ,heap-root ,heap-max/2) (return)) + (let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root) + ;; l-son index in seq (0..N-1) is one less than heap computation + (,one-son (1- ,heap-l-son)) + (,one-son-ele (,vector-ref ,seq ,one-son)) + (,one-son-key (apply-key ,key ,one-son-ele))) + (declare (fixnum ,heap-l-son ,one-son)) + (if (< ,heap-l-son ,heap-max) + ;; there is a right son. + (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son)) + (,r-son-key (apply-key ,key ,r-son-ele))) + ;; choose the greater of the two sons. + (when (funcall ,pred ,one-son-key ,r-son-key) + (setf ,one-son ,heap-l-son) + (setf ,one-son-ele ,r-son-ele) + (setf ,one-son-key ,r-son-key)))) + ;; if greater son is less than root, then we've formed a heap again. + (if (funcall ,pred ,one-son-key ,root-key) (return)) + ;; else put greater son at root and make greater son node be the root. + (setf (,vector-ref ,seq ,var-root) ,one-son-ele) + (setf ,heap-root (1+ ,one-son)) ; one plus to be in heap coordinates. + (setf ,var-root ,one-son))) ; actual index into vector for root ele. + ;; now really put percolated value into heap at the appropriate root node. + (setf (,vector-ref ,seq ,var-root) ,root-ele)))) + + +;;; BUILD-HEAP rearranges seq elements into a heap to start heap sorting. +(defmacro build-heap (seq type len-1 pred key) + (let ((i (gensym))) + `(do ((,i (floor ,len-1 2) (1- ,i))) + ((minusp ,i) ,seq) + (declare (fixnum ,i)) + (heapify ,seq ,type ,i ,len-1 ,pred ,key)))) + +) ; eval-when + + +;;; Make simple-vector and miscellaneous vector sorting functions. +(macrolet ((frob-rob (fun-name vector-ref) + `(defun ,fun-name (seq pred key) + (let ((len-1 (1- (length (the vector seq))))) + (declare (fixnum len-1)) + (build-heap seq ,vector-ref len-1 pred key) + (do* ((i len-1 i-1) + (i-1 (1- i) (1- i-1))) + ((zerop i) seq) + (declare (fixnum i i-1)) + (rotatef (,vector-ref seq 0) (,vector-ref seq i)) + (heapify seq ,vector-ref 0 i-1 pred key)))))) + + (frob-rob sort-vector aref) + + (frob-rob sort-simple-vector svref)) + + + +;;;; Stable Sorting + +(defun stable-sort (sequence predicate &key key) + "Destructively sorts sequence. Predicate should returns non-Nil if + Arg1 is to precede Arg2." + (typecase sequence + (simple-vector + (stable-sort-simple-vector sequence predicate key)) + (list + (sort-list sequence predicate key)) + (vector + (stable-sort-vector sequence predicate key)) + (t + (error "~S is not a sequence." sequence)))) + + +;;; Stable Sorting Lists + + +;;; SORT-LIST uses a bottom up merge sort. First a pass is made over +;;; the list grabbing one element at a time and merging it with the next one +;;; form pairs of sorted elements. Then n is doubled, and elements are taken +;;; in runs of two, merging one run with the next to form quadruples of sorted +;;; elements. This continues until n is large enough that the inner loop only +;;; runs for one iteration; that is, there are only two runs that can be merged, +;;; the first run starting at the beginning of the list, and the second being +;;; the remaining elements. + +(defun sort-list (list pred key) + (let ((head (cons :header list)) ; head holds on to everything + (n 1) ; bottom-up size of lists to be merged + unsorted ; unsorted is the remaining list to be + ; broken into n size lists and merged + list-1 ; list-1 is one length n list to be merged + last) ; last points to the last visited cell + (declare (fixnum n)) + (loop + ;; start collecting runs of n at the first element + (setf unsorted (cdr head)) + ;; tack on the first merge of two n-runs to the head holder + (setf last head) + (let ((n-1 (1- n))) + (declare (fixnum n-1)) + (loop + (setf list-1 unsorted) + (let ((temp (nthcdr n-1 list-1)) + list-2) + (cond (temp + ;; there are enough elements for a second run + (setf list-2 (cdr temp)) + (setf (cdr temp) nil) + (setf temp (nthcdr n-1 list-2)) + (cond (temp + (setf unsorted (cdr temp)) + (setf (cdr temp) nil)) + ;; the second run goes off the end of the list + (t (setf unsorted nil))) + (multiple-value-bind (merged-head merged-last) + (merge-lists* list-1 list-2 pred key) + (setf (cdr last) merged-head) + (setf last merged-last)) + (if (null unsorted) (return))) + ;; if there is only one run, then tack it on to the end + (t (setf (cdr last) list-1) + (return))))) + (setf n (ash n 1)) ; (+ n n) + ;; If the inner loop only executed once, then there were only enough + ;; elements for two runs given n, so all the elements have been merged + ;; into one list. This may waste one outer iteration to realize. + (if (eq list-1 (cdr head)) + (return list-1)))))) + + +;;; APPLY-PRED saves us a function call sometimes. +(eval-when (compile eval) + (defmacro apply-pred (one two pred key) + `(if ,key + (funcall ,pred (funcall ,key ,one) + (funcall ,key ,two)) + (funcall ,pred ,one ,two))) +) ; eval-when + +(defvar *merge-lists-header* (list :header)) + +;;; MERGE-LISTS* originally written by Jim Large. +;;; modified to return a pointer to the end of the result +;;; and to not cons header each time its called. +;;; It destructively merges list-1 with list-2. In the resulting +;;; list, elements of list-2 are guaranteed to come after equal elements +;;; of list-1. +(defun merge-lists* (list-1 list-2 pred key) + (do* ((result *merge-lists-header*) + (P result)) ; P points to last cell of result + ((or (null list-1) (null list-2)) ; done when either list used up + (if (null list-1) ; in which case, append the + (rplacd p list-2) ; other list + (rplacd p list-1)) + (do ((drag p lead) + (lead (cdr p) (cdr lead))) + ((null lead) + (values (prog1 (cdr result) ; return the result sans header + (rplacd result nil)) ; (free memory, be careful) + drag)))) ; and return pointer to last element + (cond ((apply-pred (car list-2) (car list-1) pred key) + (rplacd p list-2) ; append the lesser list to last cell of + (setq p (cdr p)) ; result. Note: test must bo done for + (pop list-2)) ; list-2 < list-1 so merge will be + (T (rplacd p list-1) ; stable for list-1 + (setq p (cdr p)) + (pop list-1))))) + + + +;;; Stable Sort Vectors + +;;; Stable sorting vectors is done with the same algorithm used for lists, +;;; using a temporary vector to merge back and forth between it and the +;;; given vector to sort. + + +(eval-when (compile eval) + +;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences, +;;; start-1 (inclusive) ... end-1 (exclusive) and +;;; end-1 (inclusive) ... end-2 (exclusive), +;;; and merges them into a target vector starting at index start-1. + +(defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2 + pred key source-ref target-ref) + (let ((i (gensym)) + (j (gensym)) + (target-i (gensym))) + `(let ((,i ,start-1) + (,j ,end-1) ; start-2 + (,target-i ,start-1)) + (declare (fixnum ,i ,j ,target-i)) + (loop + (cond ((= ,i ,end-1) + (loop (if (= ,j ,end-2) (return)) + (setf (,target-ref ,target ,target-i) + (,source-ref ,source ,j)) + (incf ,target-i) + (incf ,j)) + (return)) + ((= ,j ,end-2) + (loop (if (= ,i ,end-1) (return)) + (setf (,target-ref ,target ,target-i) + (,source-ref ,source ,i)) + (incf ,target-i) + (incf ,i)) + (return)) + ((apply-pred (,source-ref ,source ,j) + (,source-ref ,source ,i) + ,pred ,key) + (setf (,target-ref ,target ,target-i) + (,source-ref ,source ,j)) + (incf ,j)) + (t (setf (,target-ref ,target ,target-i) + (,source-ref ,source ,i)) + (incf ,i))) + (incf ,target-i))))) + + +;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but +;;; it uses a temporary vector. Direction determines whether we are merging +;;; into the temporary (T) or back into the given vector (NIL). + +(defmacro vector-merge-sort (vector pred key vector-ref) + (let ((vector-len (gensym)) (n (gensym)) + (direction (gensym)) (unsorted (gensym)) + (start-1 (gensym)) (end-1 (gensym)) + (end-2 (gensym)) (temp-len (gensym)) + (i (gensym))) + `(let ((,vector-len (length (the vector ,vector))) + (,n 1) ; bottom-up size of contiguous runs to be merged + (,direction t) ; t vector --> temp nil temp --> vector + (,temp-len (length (the simple-vector *merge-sort-temp-vector*))) + (,unsorted 0) ; unsorted..vector-len are the elements that need + ; to be merged for a given n + (,start-1 0)) ; one n-len subsequence to be merged with the next + (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1)) + (if (> ,vector-len ,temp-len) + (setf *merge-sort-temp-vector* + (make-array (max ,vector-len (+ ,temp-len ,temp-len))))) + (loop + ;; for each n, we start taking n-runs from the start of the vector + (setf ,unsorted 0) + (loop + (setf ,start-1 ,unsorted) + (let ((,end-1 (+ ,start-1 ,n))) + (declare (fixnum ,end-1)) + (cond ((< ,end-1 ,vector-len) + ;; there are enough elements for a second run + (let ((,end-2 (+ ,end-1 ,n))) + (declare (fixnum ,end-2)) + (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len)) + (setf ,unsorted ,end-2) + (if ,direction + (stable-sort-merge-vectors* + ,vector *merge-sort-temp-vector* + ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref) + (stable-sort-merge-vectors* + *merge-sort-temp-vector* ,vector + ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref)) + (if (= ,unsorted ,vector-len) (return)))) + ;; if there is only one run, copy those elements to the end + (t (if ,direction + (do ((,i ,start-1 (1+ ,i))) + ((= ,i ,vector-len)) + (declare (fixnum ,i)) + (setf (svref *merge-sort-temp-vector* ,i) + (,vector-ref ,vector ,i))) + (do ((,i ,start-1 (1+ ,i))) + ((= ,i ,vector-len)) + (declare (fixnum ,i)) + (setf (,vector-ref ,vector ,i) + (svref *merge-sort-temp-vector* ,i)))) + (return))))) + ;; If the inner loop only executed once, then there were only enough + ;; elements for two subsequences given n, so all the elements have + ;; been merged into one list. Start-1 will have remained 0 upon exit. + (when (zerop ,start-1) + (if ,direction + ;; if we just merged into the temporary, copy it all back + ;; to the given vector. + (dotimes (,i ,vector-len) + (setf (,vector-ref ,vector ,i) + (svref *merge-sort-temp-vector* ,i)))) + (return ,vector)) + (setf ,n (ash ,n 1)) ; (* 2 n) + (setf ,direction (not ,direction)))))) + +) ; eval-when + + +;;; Temporary vector for stable sorting vectors. +(defvar *merge-sort-temp-vector* + (make-array 50)) + +(proclaim '(simple-vector *merge-sort-temp-vector*)) + +(defun stable-sort-simple-vector (vector pred key) + (declare (simple-vector vector)) + (vector-merge-sort vector pred key svref)) + +(defun stable-sort-vector (vector pred key) + (vector-merge-sort vector pred key aref)) + + + +;;;; Merge + +(eval-when (compile eval) + +;;; MERGE-VECTORS returns a new vector which contains an interleaving +;;; of the elements of vector-1 and vector-2. Elements from vector-2 are +;;; chosen only if they are strictly less than elements of vector-1, +;;; (pred elt-2 elt-1), as specified in the manual. + +(defmacro merge-vectors (vector-1 length-1 vector-2 length-2 + result-vector pred key access) + (let ((result-i (gensym)) + (i (gensym)) + (j (gensym))) + `(let* ((,result-i 0) + (,i 0) + (,j 0)) + (declare (fixnum ,result-i ,i ,j)) + (loop + (cond ((= ,i ,length-1) + (loop (if (= ,j ,length-2) (return)) + (setf (,access ,result-vector ,result-i) + (,access ,vector-2 ,j)) + (incf ,result-i) + (incf ,j)) + (return ,result-vector)) + ((= ,j ,length-2) + (loop (if (= ,i ,length-1) (return)) + (setf (,access ,result-vector ,result-i) + (,access ,vector-1 ,i)) + (incf ,result-i) + (incf ,i)) + (return ,result-vector)) + ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i) + ,pred ,key) + (setf (,access ,result-vector ,result-i) + (,access ,vector-2 ,j)) + (incf ,j)) + (t (setf (,access ,result-vector ,result-i) + (,access ,vector-1 ,i)) + (incf ,i))) + (incf ,result-i))))) + +) ; eval-when + +(defun merge (result-type sequence1 sequence2 predicate &key key) + "The sequences Sequence1 and Sequence2 are destructively merged into + a sequence of type Result-Type using the Predicate to order the elements." + (if (eq result-type 'list) + (let ((result (merge-lists* (coerce sequence1 'list) + (coerce sequence2 'list) + predicate key))) + result) + (let* ((vector-1 (coerce sequence1 'vector)) + (vector-2 (coerce sequence2 'vector)) + (length-1 (length vector-1)) + (length-2 (length vector-2)) + (result (make-sequence-of-type result-type (+ length-1 length-2)))) + (declare (vector vector-1 vector-2) + (fixnum length-1 length-2)) + (if (and (simple-vector-p result) + (simple-vector-p vector-1) + (simple-vector-p vector-2)) + (merge-vectors vector-1 length-1 vector-2 length-2 + result predicate key svref) + (merge-vectors vector-1 length-1 vector-2 length-2 + result predicate key aref))))) diff --git a/code/stream.lisp b/code/stream.lisp new file mode 100644 index 000000000..c340d64d3 --- /dev/null +++ b/code/stream.lisp @@ -0,0 +1,1043 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Stream functions for Spice Lisp. +;;; Written by Skef Wholey and Rob MacLachlan. +;;; +;;; This file contains the machine-independent stream functions. Another +;;; file (VAXIO, SPIO, or VMIO) contains functions used by this file for +;;; a specific machine. +;;; +(in-package 'lisp) + +(export '(make-broadcast-stream make-synonym-stream + make-broadcast-stream make-concatenated-stream make-two-way-stream + make-echo-stream make-string-input-stream make-string-output-stream + get-output-stream-string stream-element-type input-stream-p + output-stream-p close read-line read-char + unread-char peek-char listen read-char-no-hang clear-input read-byte + write-char write-string write-line terpri fresh-line + finish-output force-output clear-output write-byte + stream streamp *standard-input* *standard-output* + *error-output* *query-io* *debug-io* *terminal-io* *trace-output*)) + +(in-package 'system) +(export '(make-indenting-stream read-n-bytes)) +(in-package 'lisp) + +;;;; Standard streams: +;;; +;;; The initialization of these streams is performed by Stream-Init, +;;; which lives in the file of machine-specific stream functions. +;;; +(defvar *terminal-io* () "Terminal I/O stream.") +(defvar *standard-input* () "Default input stream.") +(defvar *standard-output* () "Default output stream.") +(defvar *error-output* () "Error output stream.") +(defvar *query-io* () "Query I/O stream.") +(defvar *trace-output* () "Trace output stream.") +(defvar *debug-io* () "Interactive debugging stream.") + +(defun ill-in (stream &rest ignore) + (declare (ignore ignore)) + (error "~S is not a character input stream." stream)) +(defun ill-out (stream &rest ignore) + (declare (ignore ignore)) + (error "~S is not a character output stream." stream)) +(defun ill-bin (stream &rest ignore) + (declare (ignore ignore)) + (error "~S is not a binary input stream." stream)) +(defun ill-bout (stream &rest ignore) + (declare (ignore ignore)) + (error "~S is not a binary output stream." stream)) +(defun closed-flame (stream &rest ignore) + (declare (ignore ignore)) + (error "~S is closed." stream)) +(defun do-nothing (&rest ignore) + (declare (ignore ignore))) + +(defun %print-stream (structure stream d) + (declare (ignore d structure)) + (write-string "#<Bare Stream>" stream)) + +;;; HOW THE STREAM STRUCTURE IS USED: +;;; +;;; Many of the slots of the stream structure contain functions +;;; which are called to perform some operation on the stream. Closed +;;; streams have #'Closed-Flame in all of their function slots. If +;;; one side of an I/O or echo stream is closed, the whole stream is +;;; considered closed. The functions in the operation slots take +;;; arguments as follows: +;;; +;;; In: Stream, Eof-Errorp, Eof-Value +;;; Bin: Stream, Eof-Errorp, Eof-Value +;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp +;;; Out: Stream, Character +;;; Bout: Stream, Integer +;;; Sout: Stream, String, Start, End +;;; Misc: Stream, Operation, &Optional Arg1, Arg2 +;;; +;;; In order to save space, some of the less common stream operations +;;; are handled by just one function, the Misc method. This function +;;; is passed a keyword which indicates the operation to perform. +;;; The following keywords are used: +;;; :read-line - Do a read-line. +;;; :listen - Return true if any input waiting. +;;; :unread - Unread the character Arg. +;;; :close - Do any stream specific stuff to close the stream. +;;; The methods are set to closed-flame by the close +;;; function, so that need not be done by this +;;; function. +;;; :clear-input - Clear any unread input +;;; :finish-output, +;;; :force-output - Cause output to happen +;;; :clear-output - Clear any undone output +;;; :element-type - Return the type of element the stream deals with. +;;; :line-length - Return the length of a line of output. +;;; :charpos - Return current output position on the line. +;;; :file-length - Return the file length of a file stream. +;;; :file-position - Return or change the current position of a file stream. +;;; :file-name - Return the name of an associated file. +;;; +;;; In order to do almost anything useful, it is necessary to +;;; define a new type of structure that includes stream, so that the +;;; stream can have some state information. +;;; +;;; THE STREAM IN-BUFFER: +;;; +;;; The In-Buffer in the stream holds characters or bytes that +;;; are ready to be read by some input function. If there is any +;;; stuff in the In-Buffer, then the reading function can use it +;;; without calling any stream method. Any stream may put stuff in +;;; the In-Buffer, and may also assume that any input in the In-Buffer +;;; has been consumed before any in-method is called. If a text +;;; stream has in In-Buffer, then the first character should not be +;;; used to buffer normal input so that it is free for unreading into. +;;; +;;; The In-Buffer slot is a vector In-Buffer-Length long. The +;;; In-Index is the index in the In-Buffer of the first available +;;; object. The available objects are thus between In-Index and the +;;; length of the In-Buffer. +;;; +;;; When this buffer is only accessed by the normal stream +;;; functions, the number of function calls is halved, thus +;;; potentially doubling the speed of simple operations. If the +;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all +;;; function call overhead is removed, vastly speeding up these +;;; important operations. +;;; +;;; If a stream does not have an In-Buffer, then the In-Buffer slot +;;; must be nil, and the In-Index must be In-Buffer-Length. These are +;;; the default values for the slots. + +;;; Stream manipulation functions. + +(defun input-stream-p (stream) + "Returns non-nil if the given Stream can perform input operations." + (and (streamp stream) + (not (eq (stream-in stream) #'closed-flame)) + (or (not (eq (stream-in stream) #'ill-in)) + (not (eq (stream-bin stream) #'ill-bin))))) + +(defun output-stream-p (stream) + "Returns non-nil if the given Stream can perform output operations." + (and (streamp stream) + (not (eq (stream-in stream) #'closed-flame)) + (or (not (eq (stream-out stream) #'ill-out)) + (not (eq (stream-bout stream) #'ill-bout))))) + +(defun stream-element-type (stream) + "Returns a type specifier for the kind of object returned by the Stream." + (if (streamp stream) + (funcall (stream-misc stream) stream :element-type) + (error "~S is not a stream." stream))) + +(defun close (stream &key abort) + "Closes the given Stream. No more I/O may be performed, but inquiries + may still be made. If :Abort is non-nil, an attempt is made to clean + up the side effects of having created the stream." + (if (streamp stream) + (unless (eq (stream-in stream) #'closed-flame) + (funcall (stream-misc stream) stream :close abort)) + (error "~S is not a stream." stream)) + t) + +(defun set-closed-flame (stream) + (setf (stream-in stream) #'closed-flame) + (setf (stream-bin stream) #'closed-flame) + (setf (stream-n-bin stream) #'closed-flame) + (setf (stream-in stream) #'closed-flame) + (setf (stream-out stream) #'closed-flame) + (setf (stream-bout stream) #'closed-flame) + (setf (stream-sout stream) #'closed-flame) + (setf (stream-misc stream) #'closed-flame)) + +;;; Input functions: + +(defun read-line (&optional (stream *standard-input*) (eof-errorp t) eof-value + recursive-p) + "Returns a line of text read from the Stream as a string, discarding the + newline character." + (declare (ignore recursive-p)) + (let* ((stream (in-synonym-of stream)) + (buffer (stream-in-buffer stream)) + (index (stream-in-index stream))) + (declare (fixnum index)) + (if (simple-string-p buffer) + (let ((nl (%primitive find-character buffer index in-buffer-length + #\newline))) + (if nl + (values (prog1 (subseq (the simple-string buffer) index nl) + (setf (stream-in-index stream) (1+ (the fixnum nl)))) + nil) + (multiple-value-bind (str eofp) + (funcall (stream-misc stream) stream + :read-line eof-errorp eof-value) + (declare (simple-string str)) + (if (= index in-buffer-length) + (values str eofp) + (values (prog1 + (concatenate 'simple-string + (subseq buffer index in-buffer-length) + str) + (setf (stream-in-index stream) in-buffer-length)) + eofp))))) + (funcall (stream-misc stream) stream :read-line eof-errorp eof-value)))) + +;;; We proclaim them inline here, then proclaim them notinline at EOF, +;;; so, except in this file, they are not inline by default, but they can be. +;;; +(proclaim '(inline read-char unread-char read-byte listen)) +(defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value + recursive-p) + "Inputs a character from Stream and returns it." + (declare (ignore recursive-p)) + (let* ((stream (in-synonym-of stream)) + (index (stream-in-index stream))) + (declare (fixnum index)) + (if (eql index in-buffer-length) + (funcall (stream-in stream) stream eof-errorp eof-value) + (prog1 (aref (stream-in-buffer stream) index) + (setf (stream-in-index stream) (1+ index)))))) + +(defun unread-char (character &optional (stream *standard-input*)) + "Puts the Character back on the front of the input Stream." + (let* ((stream (in-synonym-of stream)) + (index (1- (the fixnum (stream-in-index stream)))) + (buffer (stream-in-buffer stream))) + (declare (fixnum index)) + (when (minusp index) (error "Nothing to unread.")) + (if buffer + (setf (aref (the simple-array buffer) index) character + (stream-in-index stream) index) + (funcall (stream-misc stream) stream :unread character))) + nil) + +(defun peek-char (&optional (peek-type nil) (stream *standard-input*) + (eof-errorp t) eof-value recursive-p) + "Peeks at the next character in the input Stream. See manual for details." + (declare (ignore recursive-p)) + (let* ((stream (in-synonym-of stream)) + (char (read-char stream eof-errorp eof-value))) + (cond ((eq char eof-value) char) + ((characterp peek-type) + (do ((char char (read-char stream eof-errorp eof-value))) + ((or (eq char eof-value) (char= char peek-type)) + (unless (eq char eof-value) + (unread-char char stream)) + char))) + ((eq peek-type t) + (do ((char char (read-char stream eof-errorp eof-value))) + ((or (eq char eof-value) (not (whitespace-char-p char))) + (unless (eq char eof-value) + (unread-char char stream)) + char))) + (t + (unread-char char stream) + char)))) + +(defun listen (&optional (stream *standard-input*)) + "Returns T if a character is availible on the given Stream." + (let ((stream (in-synonym-of stream))) + (or (/= (the fixnum (stream-in-index stream)) in-buffer-length) + (funcall (stream-misc stream) stream :listen)))) + +(defun read-char-no-hang (&optional (stream *standard-input*) + (eof-errorp t) eof-value recursive-p) + "Returns the next character from the Stream if one is availible, or nil." + (declare (ignore recursive-p)) + (if (listen stream) (read-char stream eof-errorp eof-value) nil)) + +(defun clear-input (&optional (stream *standard-input*)) + "Clears any buffered input associated with the Stream." + (let ((stream (in-synonym-of stream))) + (setf (stream-in-index stream) in-buffer-length) + (funcall (stream-misc stream) stream :clear-input))) + +(defun read-byte (stream &optional (eof-errorp t) eof-value) + "Returns the next byte of the Stream." + (let* ((stream (in-synonym-of stream)) + (index (stream-in-index stream))) + (declare (fixnum index)) + (if (eql index in-buffer-length) + (funcall (stream-bin stream) stream eof-errorp eof-value) + (prog1 (aref (stream-in-buffer stream) index) + (setf (stream-in-index stream) (1+ index)))))) + +(defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t)) + "Reads Numbytes bytes into the Buffer starting at Start, and returns + the number of bytes actually read if the end of file was hit before Numbytes + bytes were read (and Eof-Errorp is false)." + (declare (fixnum numbytes)) + (let* ((stream (in-synonym-of stream)) + (in-buffer (stream-in-buffer stream)) + (index (stream-in-index stream)) + (num-buffered (- in-buffer-length index))) + (declare (fixnum index num-buffered)) + (cond + ((not buffer) + (with-in-stream stream stream-n-bin buffer start numbytes eof-errorp)) + ((not (eql (%primitive get-vector-access-code in-buffer) 3)) + (error "N-Bin only works on 8-bit-like streams.")) + ((<= numbytes num-buffered) + (%primitive byte-blt in-buffer index buffer start (+ start numbytes)) + (setf (stream-in-index stream) (+ index numbytes)) + numbytes) + (t + (let ((end (+ start num-buffered))) + (%primitive byte-blt in-buffer index buffer start end) + (setf (stream-in-index stream) in-buffer-length) + (+ (with-in-stream stream stream-n-bin buffer end + (- numbytes num-buffered) + eof-errorp) + num-buffered)))))) + +;;; Output functions: + +(defun write-char (character &optional (stream *standard-output*)) + "Outputs the Character to the Stream." + (with-out-stream stream stream-out character) + character) + +(defun terpri (&optional (stream *standard-output*)) + "Outputs a new line to the Stream." + (with-out-stream stream stream-out #\newline) + nil) + +(defun fresh-line (&optional (stream *standard-output*)) + "Outputs a new line to the Stream if it is not positioned at the begining of + a line. Returns T if it output a new line, nil otherwise." + (let ((stream (out-synonym-of stream))) + (when (/= (or (charpos stream) 1) 0) + (funcall (stream-out stream) stream #\newline) + t))) + +(defun write-string (string &optional (stream *standard-output*) + &key (start 0) (end (length (the vector string)))) + "Outputs the String to the given Stream." + (write-string* string stream start end)) + +(defun write-string* (string &optional (stream *standard-output*) + (start 0) (end (length (the vector string)))) + (declare (fixnum start end)) + (if (array-header-p string) + (with-array-data ((data string) (offset-start start) (offset-end end)) + (with-out-stream stream stream-sout data offset-start offset-end)) + (with-out-stream stream stream-sout string start end)) + string) + +(defun write-line (string &optional (stream *standard-output*) + &key (start 0) (end (length string))) + "Outputs the String to the given Stream, followed by a newline character." + (write-line* string stream start end)) + +(defun write-line* (string &optional (stream *standard-output*) + (start 0) (end (length string))) + (declare (fixnum start end)) + (let ((stream (out-synonym-of stream))) + (if (array-header-p string) + (with-array-data ((data string) (offset-start start) (offset-end end)) + (with-out-stream stream stream-sout data offset-start offset-end)) + (with-out-stream stream stream-sout string start end)) + (funcall (stream-out stream) stream #\newline)) + string) + +(defun charpos (&optional (stream *standard-output*)) + "Returns the number of characters on the current line of output of the given + Stream, or Nil if that information is not availible." + (with-out-stream stream stream-misc :charpos)) + +(defun line-length (&optional (stream *standard-output*)) + "Returns the number of characters that will fit on a line of output on the + given Stream, or Nil if that information is not available." + (with-out-stream stream stream-misc :line-length)) + +(defun finish-output (&optional (stream *standard-output*)) + "Attempts to ensure that all output sent to the the Stream has reached its + destination, and only then returns." + (with-out-stream stream stream-misc :finish-output) + nil) + +(defun force-output (&optional (stream *standard-output*)) + "Attempts to force any buffered output to be sent." + (with-out-stream stream stream-misc :force-output) + nil) + +(defun clear-output (&optional (stream *standard-output*)) + "Clears the given output Stream." + (with-out-stream stream stream-misc :clear-output) + nil) + +(defun write-byte (integer stream) + "Outputs the Integer to the binary Stream." + (with-out-stream stream stream-bout integer) + integer) + +;;;; Broadcast streams: + +(defstruct (broadcast-stream (:include stream + (out #'broadcast-out) + (bout #'broadcast-bout) + (sout #'broadcast-sout) + (misc #'broadcast-misc)) + (:print-function %print-broadcast-stream) + (:constructor make-broadcast-stream (&rest streams))) + ;; This is a list of all the streams we broadcast to. + streams) + +(setf (documentation 'make-broadcast-stream 'function) + "Returns an ouput stream which sends its output to all of the given streams.") + +(defun %print-broadcast-stream (s stream d) + (declare (ignore s d)) + (write-string "#<Broadcast Stream>" stream)) + +(macrolet ((out-fun (fun method &rest args) + `(defun ,fun (stream ,@args) + (dolist (stream (broadcast-stream-streams stream)) + (funcall (,method stream) stream ,@args))))) + (out-fun broadcast-out stream-out char) + (out-fun broadcast-bout stream-bout byte) + (out-fun broadcast-sout stream-sout string start end)) + +(defun broadcast-misc (stream operation &optional arg1 arg2) + (let ((streams (broadcast-stream-streams stream))) + (case operation + (:charpos + (dolist (stream streams) + (let ((charpos (funcall (stream-misc stream) stream :charpos))) + (if charpos (return charpos))))) + (:line-length + (let ((min nil)) + (dolist (stream streams min) + (let ((res (funcall (stream-misc stream) stream :line-length))) + (when res (setq min (if min (min res min) res))))))) + (:element-type + (let (res) + (dolist (stream streams (if (> (length res) 1) `(and ,@res) res)) + (pushnew (funcall (stream-misc stream) stream :element-type) res + :test #'equal)))) + (t + (let ((res nil)) + (dolist (stream streams res) + (setq res (funcall (stream-misc stream) stream operation + arg1 arg2)))))))) + +;;;; Synonym Streams: + +(defstruct (synonym-stream (:include stream + (in #'synonym-in) + (bin #'synonym-bin) + (n-bin #'synonym-n-bin) + (out #'synonym-out) + (bout #'synonym-bout) + (sout #'synonym-sout) + (misc #'synonym-misc)) + (:print-function %print-synonym-stream) + (:constructor make-synonym-stream (symbol))) + ;; This is the symbol, the value of which is the stream we are synonym to. + symbol) + +(defun %print-synonym-stream (s stream d) + (declare (ignore d)) + (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s))) + +(setf (documentation 'make-synonym-stream 'function) + "Returns a stream which performs its operations on the stream which is the + value of the dynamic variable named by Symbol.") + +;;; The output simple output methods just call the corresponding method +;;; in the synonymed stream. +;;; +(macrolet ((out-fun (name slot &rest args) + `(defun ,name (stream ,@args) + (let ((syn (symbol-value (synonym-stream-symbol stream)))) + (funcall (,slot syn) syn ,@args))))) + (out-fun synonym-out stream-out ch) + (out-fun synonym-bout stream-bout n) + (out-fun synonym-sout stream-sout string start end)) + + +;;; Bind synonym stream to this so that SPIO can turn on the right frob in +;;; the icon when we are in a terminal input wait. +;;; +(defvar *previous-stream* nil) + +;;; For the input methods, we just call the corresponding function on the +;;; synonymed stream. These functions deal with getting input out of +;;; the In-Buffer if there is any. +;;; +(macrolet ((in-fun (name fun &rest args) + `(defun ,name (stream ,@args) + (let ((*previous-stream* stream)) + (,fun (symbol-value (synonym-stream-symbol stream)) ,@args))))) + (in-fun synonym-in read-char eof-errorp eof-value) + (in-fun synonym-bin read-byte eof-errorp eof-value) + (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp)) + + +;;; Synonym-Misc -- Internal +;;; +;;; We have to special-case the operations which could look at stuff in +;;; the in-buffer. +;;; +(defun synonym-misc (stream operation &optional arg1 arg2) + (let ((syn (symbol-value (synonym-stream-symbol stream))) + (*previous-stream* stream)) + (case operation + (:read-line (read-line syn)) + (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length) + (funcall (stream-misc syn) syn :listen))) + (t + (funcall (stream-misc syn) syn operation arg1 arg2))))) + +;;;; Two-Way streams: + +(defstruct (two-way-stream + (:include stream + (in #'two-way-in) + (bin #'two-way-bin) + (n-bin #'two-way-n-bin) + (out #'two-way-out) + (bout #'two-way-bout) + (sout #'two-way-sout) + (misc #'two-way-misc)) + (:print-function %print-two-way-stream) + (:constructor make-two-way-stream (input-stream output-stream))) + ;; We read from this stream... + input-stream + ;; And write to this one + output-stream) + +(defun %print-two-way-stream (s stream d) + (declare (ignore d)) + (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>" + (two-way-stream-input-stream s) + (two-way-stream-output-stream s))) + +(setf (documentation 'make-two-way-stream 'function) + "Returns a bidirectional stream which gets its input from Input-Stream and + sends its output to Output-Stream.") + +(macrolet ((out-fun (name slot &rest args) + `(defun ,name (stream ,@args) + (let ((syn (two-way-stream-output-stream stream))) + (funcall (,slot syn) syn ,@args))))) + (out-fun two-way-out stream-out ch) + (out-fun two-way-bout stream-bout n) + (out-fun two-way-sout stream-sout string start end)) + +(macrolet ((in-fun (name fun &rest args) + `(defun ,name (stream ,@args) + (,fun (two-way-stream-input-stream stream) ,@args)))) + (in-fun two-way-in read-char eof-errorp eof-value) + (in-fun two-way-bin read-byte eof-errorp eof-value) + (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp)) + +(defun two-way-misc (stream operation &optional arg1 arg2) + (let* ((in (two-way-stream-input-stream stream)) + (in-method (stream-misc in)) + (out (two-way-stream-output-stream stream)) + (out-method (stream-misc out))) + (case operation + (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length) + (funcall in-method in :listen))) + (:read-line (read-line in arg1 arg2)) + ((:finish-output :force-output :clear-output) + (funcall out-method out operation arg1 arg2)) + ((:clear-input :unread) + (funcall in-method in operation arg1 arg2)) + (:element-type + (let ((in-type (funcall in-method in :element-type)) + (out-type (funcall out-method out :element-type))) + (if (equal in-type out-type) + in-type `(and ,in-type ,out-type)))) + (:close + (funcall in-method in :close arg1) + (funcall out-method out :close arg1) + (set-closed-flame stream)) + (t + (or (funcall in-method in operation arg1 arg2) + (funcall out-method out operation arg1 arg2)))))) + +;;;; Concatenated Streams: + +(defstruct (concatenated-stream + (:include stream + (in #'concatenated-in) + (bin #'concatenated-bin) + (misc #'concatenated-misc)) + (:print-function %print-concatenated-stream) + (:constructor + make-concatenated-stream (&rest streams &aux (current streams)))) + ;; The car of this is the stream we are reading from now. + current + ;; This is a list of all the streams. We need to remember them so that + ;; we can close them. + streams) + +(defun %print-concatenated-stream (s stream d) + (declare (ignore d)) + (format stream "#<Concatenated Stream, Streams = ~S>" + (concatenated-stream-streams s))) + +(setf (documentation 'make-concatenated-stream 'function) + "Returns a stream which takes its input from each of the Streams in turn, + going on to the next at EOF.") + +(macrolet ((in-fun (name fun) + `(defun ,name (stream eof-errorp eof-value) + (do ((current (concatenated-stream-current stream) (cdr current))) + ((null current) + (eof-or-lose stream eof-errorp eof-value)) + (let* ((stream (car current)) + (result (,fun stream nil nil))) + (when result (return result))) + (setf (concatenated-stream-current stream) current))))) + (in-fun concatenated-in read-char) + (in-fun concatenated-bin read-byte)) + +;;; Concatenated-Readline is somewhat hairy, since we may need to +;;; do several readlines and concatenate the result if the lines are +;;; terminated by eof. +;;; +(defun concatenated-readline (stream eof-errorp eof-value) + ;; Loop until we find a stream that will give us something or we error + ;; out. + (do ((current (concatenated-stream-current stream) (cdr current))) + ((null current) + (eof-or-lose stream eof-errorp eof-value)) + (setf (concatenated-stream-current stream) current) + (let ((this (car current))) + (multiple-value-bind (result eofp) + (read-line this nil nil) + (declare (simple-string result)) + ;; Once we have found some input, we loop until we either find a + ;; line not terminated by eof or hit eof on the last stream. + (when result + (do ((current (cdr current) (cdr current)) + (new "")) + ((or (not eofp) (null current)) + (return-from concatenated-readline (values result eofp))) + (declare (simple-string new)) + (setf (concatenated-stream-current stream) current) + (let ((this (car current))) + (multiple-value-setq (new eofp) + (read-line this nil nil)) + (if new + (setq result (concatenate 'simple-string result new)) + (setq eofp t))))))))) + +(defun concatenated-misc (stream operation &optional arg1 arg2) + (if (eq operation :read-line) + (concatenated-readline stream arg1 arg2) + (let ((left (concatenated-stream-current stream))) + (when left + (let* ((current (car left)) + (misc (stream-misc current))) + (case operation + (:listen (or (/= (the fixnum (stream-in-index current)) in-buffer-length) + (funcall misc current :listen))) + (:close + (dolist (stream (concatenated-stream-streams stream)) + (funcall (stream-misc stream) stream :close arg1)) + (set-closed-flame stream)) + (t + (funcall misc current operation arg1 arg2)))))))) + +;;;; Echo Streams: + +(defstruct (echo-stream + (:include two-way-stream + (in #'echo-in) + (bin #'echo-bin) + (misc #'echo-misc) + (n-bin #'ill-bin)) + (:print-function %print-echo-stream) + (:constructor make-echo-stream (input-stream output-stream)))) + + +(macrolet ((in-fun (name fun out-slot &rest args) + `(defun ,name (stream ,@args) + (let* ((in (two-way-stream-input-stream stream)) + (out (two-way-stream-output-stream stream)) + (result (,fun in ,@args))) + (funcall (,out-slot out) out result) + result)))) + (in-fun echo-in read-char stream-out eof-errorp eof-value) + (in-fun echo-bin read-byte stream-bout eof-errorp eof-value)) + +(defun echo-misc (stream operation &optional arg1 arg2) + (let* ((in (two-way-stream-input-stream stream)) + (in-method (stream-misc in)) + (out (two-way-stream-output-stream stream)) + (out-method (stream-misc out))) + (case operation + (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length) + (funcall in-method in :listen))) + (:read-line + (multiple-value-bind (result eofp) + (read-line in arg1 arg2) + (if eofp + (write-string result out) + (write-line result out)) + (values result eofp))) + (:element-type + (let ((in-type (funcall in-method in :element-type)) + (out-type (funcall out-method out :element-type))) + (if (equal in-type out-type) + in-type `(and ,in-type ,out-type)))) + (:close + (funcall in-method in :close arg1) + (funcall out-method out :close arg1) + (set-closed-flame stream)) + (t + (or (funcall in-method in operation arg1 arg2) + (funcall out-method out operation arg1 arg2)))))) + +(defun %print-echo-stream (s stream d) + (declare (ignore d)) + (format stream "#<Echo Stream, Input = ~S, Output = ~S>" + (two-way-stream-input-stream s) + (two-way-stream-output-stream s))) + +(setf (documentation 'make-echo-stream 'function) + "Returns a bidirectional stream which gets its input from Input-Stream and + sends its output to Output-Stream. In addition, all input is echoed to + the output stream") + +;;;; String Input Streams: + +(defstruct (string-input-stream + (:include stream + (in #'string-inch) + (misc #'string-in-misc)) + (:print-function %print-string-input-stream) + (:constructor nil) + (:constructor internal-make-string-input-stream + (string current end))) + (string nil :type simple-string) + (current nil :type fixnum) + (end nil :type fixnum)) + +(defun %print-string-input-stream (s stream d) + (declare (ignore s d)) + (write-string "#<String-Input Stream>" stream)) + +(defun string-inch (stream eof-errorp eof-value) + (let ((string (string-input-stream-string stream)) + (index (string-input-stream-current stream))) + (declare (simple-string string) (fixnum index)) + (cond ((= index (the fixnum (string-input-stream-end stream))) + (eof-or-lose stream eof-errorp eof-value)) + (t + (setf (string-input-stream-current stream) (1+ index)) + (aref string index))))) + +(defun string-in-misc (stream operation &optional arg1 arg2) + (case operation + (:read-line + (let ((string (string-input-stream-string stream)) + (current (string-input-stream-current stream)) + (end (string-input-stream-end stream))) + (declare (simple-string string) (fixnum current end)) + (if (= current end) + (eof-or-lose stream arg1 arg2) + (let ((pos (%primitive find-character string current end #\newline))) + (if pos + (let* ((res-length (- (the fixnum pos) current)) + (result (make-string res-length))) + (%primitive byte-blt string current result 0 res-length) + (setf (string-input-stream-current stream) + (1+ (the fixnum pos))) + (values result nil)) + (let* ((res-length (- end current)) + (result (make-string res-length))) + (%primitive byte-blt string current result 0 res-length) + (setf (string-input-stream-current stream) end) + (values result t))))))) + (:unread (decf (string-input-stream-current stream))) + (:listen (not (= (the fixnum (string-input-stream-current stream)) + (the fixnum (string-input-stream-end stream))))) + (:element-type 'string-char))) + +(defun make-string-input-stream (string &optional + (start 0) (end (length string))) + "Returns an input stream which will supply the characters of String between + Start and End in order." + (if (stringp string) + (internal-make-string-input-stream (coerce string 'simple-string) + start end) + (error "~S is not a string." string))) + +;;;; String Output Streams: + +(defstruct (string-output-stream + (:include stream + (out #'string-ouch) + (sout #'string-sout) + (misc #'string-out-misc)) + (:print-function %print-string-output-stream) + (:constructor make-string-output-stream ())) + ;; The string we throw stuff in. + (string (make-string 40) :type simple-string) + ;; Index of the next location to use. + (index 0 :type fixnum)) + +(defun %print-string-output-stream (s stream d) + (declare (ignore s d)) + (write-string "#<String-Output Stream>" stream)) + +(setf (documentation 'make-string-output-stream 'function) + "Returns an Output stream which will accumulate all output given it for + the benefit of the function Get-Output-Stream-String.") + +(defun string-ouch (stream character) + (let ((current (string-output-stream-index stream)) + (workspace (string-output-stream-string stream))) + (declare (simple-string workspace) (fixnum current)) + (if (= current (the fixnum (length workspace))) + (let ((new-workspace (make-string (* current 2)))) + (%primitive byte-blt workspace 0 new-workspace 0 current) + (setf (aref new-workspace current) character) + (setf (string-output-stream-string stream) new-workspace)) + (setf (aref workspace current) character)) + (setf (string-output-stream-index stream) (1+ current)))) + +(defun string-sout (stream string start end) + (declare (simple-string string) (fixnum start end)) + (let* ((current (string-output-stream-index stream)) + (length (- end start)) + (dst-end (+ length current)) + (workspace (string-output-stream-string stream))) + (declare (simple-string workspace) + (fixnum current length dst-end)) + (if (> dst-end (the fixnum (length workspace))) + (let ((new-workspace (make-string (+ (* current 2) length)))) + (%primitive byte-blt workspace 0 new-workspace 0 current) + (%primitive byte-blt string start new-workspace current dst-end) + (setf (string-output-stream-string stream) new-workspace)) + (%primitive byte-blt string start workspace current dst-end)) + (setf (string-output-stream-index stream) dst-end))) + +(defun string-out-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + (:charpos + (do ((index (1- (the fixnum (string-output-stream-index stream))) + (1- index)) + (count 0 (1+ count)) + (string (string-output-stream-string stream))) + ((< index 0) count) + (declare (simple-string string) + (fixnum index count)) + (if (char= (schar string index) #\newline) + (return count)))) + (:element-type 'string-char))) + +(defun get-output-stream-string (stream) + "Returns a string of all the characters sent to a stream made by + Make-String-Output-Stream since the last call to this function." + (if (streamp stream) + (let* ((length (string-output-stream-index stream)) + (result (make-string length))) + (%primitive byte-blt (string-output-stream-string stream) 0 + result 0 length) + (setf (string-output-stream-index stream) 0) + result) + (error "~S is not a string stream."))) + +(defun dump-output-stream-string (in-stream out-stream) + "Dumps the characters buffer up in the In-Stream to the Out-Stream as + Get-Output-Stream-String would return them." + (write-string (string-output-stream-string in-stream) out-stream + :start 0 :end (string-output-stream-index in-stream)) + (setf (string-output-stream-index in-stream) 0)) + +;;;; Fill-pointer streams: +;;; +;;; Fill pointer string output streams are not explicitly mentioned in +;;; the CLM, but they are required for the implementation of With-Output-To-String. + +(defstruct (fill-pointer-output-stream + (:include stream + (out #'fill-pointer-ouch) + (sout #'fill-pointer-sout) + (misc #'fill-pointer-misc)) + (:print-function + (lambda (s stream d) + (declare (ignore s d)) + (write-string "#<Fill-Pointer String Output Stream>" stream))) + (:constructor make-fill-pointer-output-stream (string))) + ;; The string we throw stuff in. + string) + + +(defun fill-pointer-ouch (stream character) + (let* ((buffer (fill-pointer-output-stream-string stream)) + (current (%primitive header-ref buffer %array-fill-pointer-slot)) + (current+1 (1+ current))) + (declare (fixnum current)) + (with-array-data ((workspace buffer) (start) (end)) + (declare (simple-string workspace)) + (let ((offset-current (+ start current))) + (declare (fixnum offset-current)) + (if (= offset-current end) + (let* ((new-length (* current 2)) + (new-workspace (make-string new-length))) + (declare (simple-string new-workspace)) + (%primitive byte-blt workspace start new-workspace 0 current) + (setf workspace new-workspace) + (setf offset-current current) + (set-array-header buffer workspace new-length + current+1 0 new-length nil)) + (%primitive header-set buffer %array-fill-pointer-slot current+1)) + (setf (schar workspace offset-current) character))) + current+1)) + + +(defun fill-pointer-sout (stream string start end) + (declare (simple-string string) (fixnum start end)) + (let* ((buffer (fill-pointer-output-stream-string stream)) + (current (%primitive header-ref buffer %array-fill-pointer-slot)) + (string-len (- end start)) + (dst-end (+ string-len current))) + (declare (fixnum current dst-end string-len)) + (with-array-data ((workspace buffer) (dst-start) (dst-length)) + (declare (simple-string workspace)) + (let ((offset-dst-end (+ dst-start dst-end)) + (offset-current (+ dst-start current))) + (declare (fixnum offset-dst-end offset-current)) + (if (> offset-dst-end dst-length) + (let* ((new-length (+ (the fixnum (* current 2)) string-len)) + (new-workspace (make-string new-length))) + (declare (simple-string new-workspace)) + (%primitive byte-blt workspace dst-start new-workspace 0 current) + (setf workspace new-workspace) + (setf offset-current current) + (setf offset-dst-end dst-end) + (set-array-header buffer workspace new-length + dst-end 0 new-length nil)) + (%primitive header-set buffer %array-fill-pointer-slot dst-end)) + (%primitive byte-blt string start + workspace offset-current offset-dst-end))) + dst-end)) + + +(defun fill-pointer-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + (:charpos + (let* ((buffer (fill-pointer-output-stream-string stream)) + (current (%primitive header-ref buffer %array-fill-pointer-slot))) + (with-array-data ((string buffer) (start) (end current)) + (declare (simple-string string) (ignore start)) + (let ((found (position #\newline string :test #'char= + :end end :from-end t))) + (if found + (- end (the fixnum found)) + current))))) + (:element-type 'string-char))) + +;;;; Indenting streams: + +(defstruct (indenting-stream (:include stream + (out #'indenting-out) + (sout #'indenting-sout) + (misc #'indenting-misc)) + (:print-function %print-indenting-stream) + (:constructor make-indenting-stream (stream))) + ;; The stream we're based on: + stream + ;; How much we indent on each line: + (indentation 0)) + +(setf (documentation 'make-indenting-stream 'function) + "Returns an ouput stream which indents its output by some amount.") + +(defun %print-indenting-stream (s stream d) + (declare (ignore s d)) + (write-string "#<Indenting Stream>" stream)) + +;;; Indenting-Indent writes the right number of spaces needed to indent output on +;;; the given Stream based on the specified Sub-Stream. + +(defmacro indenting-indent (stream sub-stream) + `(do ((i 0 (+ i 60)) + (indentation (indenting-stream-indentation ,stream))) + ((>= i indentation)) + (funcall (stream-sout ,sub-stream) ,sub-stream + " " + 0 (min 60 (- indentation i))))) + +;;; Indenting-Out writes a character to an indenting stream. + +(defun indenting-out (stream char) + (let ((sub-stream (indenting-stream-stream stream))) + (funcall (stream-out sub-stream) sub-stream char) + (if (char= char #\newline) + (indenting-indent stream sub-stream)))) + +;;; Indenting-Sout writes a string to an indenting stream. + +(defun indenting-sout (stream string start end) + (declare (simple-string string) (fixnum start end)) + (do ((i start) + (sub-stream (indenting-stream-stream stream))) + ((= i end)) + (let ((newline (position #\newline string :start i :end end))) + (cond (newline + (funcall (stream-sout sub-stream) sub-stream string i (1+ newline)) + (indenting-indent stream sub-stream) + (setq i (+ newline 1))) + (t + (funcall (stream-sout sub-stream) sub-stream string i end) + (setq i end)))))) + +;;; Indenting-Misc just treats just the :Line-Length message differently. +;;; Indenting-Charpos says the charpos is the charpos of the base stream minus +;;; the stream's indentation. + +(defun indenting-misc (stream operation &optional arg1 arg2) + (let* ((sub-stream (indenting-stream-stream stream)) + (method (stream-misc sub-stream))) + (case operation + (:line-length + (let ((line-length (funcall method sub-stream operation))) + (if line-length + (- line-length (indenting-stream-indentation stream))))) + (:charpos + (let* ((sub-stream (indenting-stream-stream stream)) + (charpos (funcall method sub-stream operation))) + (if charpos + (- charpos (indenting-stream-indentation stream))))) + (t + (funcall method sub-stream operation arg1 arg2))))) + +(proclaim '(notinline read-char unread-char read-byte listen)) diff --git a/code/string.lisp b/code/string.lisp new file mode 100644 index 000000000..c9c960880 --- /dev/null +++ b/code/string.lisp @@ -0,0 +1,608 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Functions to implement strings for Spice Lisp +;;; Written by David Dill +;;; Rewritten and currently maintained by Skef Wholey +;;; +;;; Runs in the standard Spice Lisp environment. +;;; +;;; **************************************************************** +;;; +(in-package 'lisp) +(export '(char schar string + string= string-equal string< string> string<= string>= string/= + string-lessp string-greaterp string-not-lessp string-not-greaterp + string-not-equal + make-string + string-trim string-left-trim string-right-trim + string-upcase + string-downcase string-capitalize nstring-upcase nstring-downcase + nstring-capitalize)) + +(eval-when (compile) + +;;; %String returns its arg if it is a string, otherwise calls String. +;;; +(defmacro %string (thing) + `(if (stringp ,thing) ,thing (string ,thing))) +) + +(defun string (X) + "Coerces X into a string. If X is a string, X is returned. If X is a + symbol, X's pname is returned. If X is a character then a one element + string containing that character is returned. If X cannot be coerced + into a string, an error occurs." + (cond ((stringp x) x) + ((symbolp x) (symbol-name x)) + ((characterp x) + (let ((res (make-string 1))) + (setf (schar res 0) x) res)) + (t + (error "~S cannot be coerced to a string." x)))) + + +;;; With-One-String is used to set up some string hacking things. The keywords +;;; are parsed, and the string is hacked into a simple-string. + +(eval-when (compile) + +(defmacro with-one-string (string start end cum-offset &rest forms) + (let ((data (gensym)) + (data-start (gensym)) + (data-end (gensym)) + (offset (gensym))) + `(progn + (if (symbolp ,string) (setq ,string (symbol-name ,string))) + (if (array-header-p ,string) + (with-array-data ((,data ,string :offset-var ,offset) + (,data-start ,start) + (,data-end (or ,end + (%primitive header-ref ,string + %array-fill-pointer-slot)))) + (psetq ,string ,data + ,cum-offset ,offset + ,start ,data-start + ,end ,data-end)) + (if (not ,end) (setq ,end (length (the simple-string ,string))))) + ,@forms))) + +) + +;;; With-String is like With-One-String, but doesn't parse keywords. + +(eval-when (compile) + +(defmacro with-string (string &rest forms) + `(let ((start 0) + (end ())) + (if (symbolp ,string) (setq ,string (symbol-name ,string))) + (if (array-header-p ,string) + (with-array-data ((data ,string) + (data-start start) + (data-end (%primitive header-ref ,string + %array-fill-pointer-slot))) + (psetq ,string data + start data-start + end data-end)) + (setq end (length (the simple-string ,string)))) + ,@forms)) + +) + +;;; With-Two-Strings is used to set up string comparison operations. The +;;; keywords are parsed, and the strings are hacked into simple-strings. + +(eval-when (compile) + +(defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1 + start2 end2 &rest forms) + (let ((data (gensym)) + (data-start (gensym)) + (data-end (gensym)) + (offset (gensym))) + `(progn + (if (symbolp ,string1) (setq ,string1 (symbol-name ,string1))) + (if (symbolp ,string2) (setq ,string2 (symbol-name ,string2))) + (if (array-header-p ,string1) + (with-array-data ((,data ,string1 :offset-var ,offset) + (,data-start ,start1) + (,data-end (or ,end1 + (%primitive header-ref ,string1 + %array-fill-pointer-slot)))) + (psetq ,string1 ,data + ,cum-offset-1 ,offset + ,start1 ,data-start + ,end1 ,data-end)) + (if (not ,end1) (setq ,end1 (length (the simple-string ,string1))))) + (if (array-header-p ,string2) + (with-array-data ((,data ,string2) + (,data-start ,start2) + (,data-end (or ,end2 + (%primitive header-ref ,string2 + %array-fill-pointer-slot)))) + (psetq ,string2 ,data + ,start2 ,data-start + ,end2 ,data-end)) + (if (not ,end2) (setq ,end2 (length (the simple-string ,string2))))) + ,@forms))) + +) + +(defun char (string index) + "Given a string and a non-negative integer index less than the length of + the string, returns the character object representing the character at + that position in the string." + (char string index)) + +(defun %charset (string index new-el) + (setf (char string index) new-el)) + +(defun schar (string index) + "SCHAR returns the character object at an indexed position in a string + just as CHAR does, except the string must be a simple-string." + (schar string index)) + +(defun %scharset (string index new-el) + (setf (schar string index) new-el)) + +(defun string=* (string1 string2 start1 end1 start2 end2) + (let ((offset1 0)) + (with-two-strings string1 string2 start1 end1 offset1 start2 end2 + (not (%sp-string-compare string1 start1 end1 string2 start2 end2))))) + + +(defun string/=* (string1 string2 start1 end1 start2 end2) + (let ((offset1 0)) + (with-two-strings string1 string2 start1 end1 offset1 start2 end2 + (let ((comparison (%sp-string-compare string1 start1 end1 + string2 start2 end2))) + (if comparison (- (the fixnum comparison) offset1)))))) + +(eval-when (compile eval) + +;;; Lessp is true if the desired expansion is for string<* or string<=*. +;;; Equalp is true if the desired expansion is for string<=* or string>=*. +(defmacro string<>=*-body (lessp equalp) + (let ((offset1 (gensym))) + `(let ((,offset1 0)) + (declare (fixnum ,offset1)) + (with-two-strings string1 string2 start1 end1 ,offset1 start2 end2 + (let ((index (%sp-string-compare string1 start1 end1 + string2 start2 end2))) + (if index + (cond ((= (the fixnum index) + ,(if lessp `(the fixnum end1) `(the fixnum end2))) + (- (the fixnum index) ,offset1)) + ((= (the fixnum index) + ,(if lessp `(the fixnum end2) `(the fixnum end1))) + nil) + ((,(if lessp 'char< 'char>) + (schar string1 index) + (schar string2 (+ (the fixnum index) (- start2 start1)))) + (- (the fixnum index) ,offset1)) + (t nil)) + ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))) +) ; eval-when + +(defun string<* (string1 string2 start1 end1 start2 end2) + (declare (fixnum start1 start2)) + (string<>=*-body t nil)) + +(defun string>* (string1 string2 start1 end1 start2 end2) + (declare (fixnum start1 start2)) + (string<>=*-body nil nil)) + +(defun string<=* (string1 string2 start1 end1 start2 end2) + (declare (fixnum start1 start2)) + (string<>=*-body t t)) + +(defun string>=* (string1 string2 start1 end1 start2 end2) + (declare (fixnum start1 start2)) + (string<>=*-body nil t)) + + + +(defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Given two strings, if the first string is lexicographically less than + the second string, returns the longest common prefix (using char=) + of the two strings. Otherwise, returns ()." + (string<* string1 string2 start1 end1 start2 end2)) + +(defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Given two strings, if the first string is lexicographically greater than + the second string, returns the longest common prefix (using char=) + of the two strings. Otherwise, returns ()." + (string>* string1 string2 start1 end1 start2 end2)) + + +(defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Given two strings, if the first string is lexicographically less than + or equal to the second string, returns the longest common prefix + (using char=) of the two strings. Otherwise, returns ()." + (string<=* string1 string2 start1 end1 start2 end2)) + +(defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Given two strings, if the first string is lexicographically greater + than or equal to the second string, returns the longest common prefix + (using char=) of the two strings. Otherwise, returns ()." + (string>=* string1 string2 start1 end1 start2 end2)) + +(defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Given two strings (string1 and string2), and optional integers start1, + start2, end1 and end2, compares characters in string1 to characters in + string2 (using char=)." + (string=* string1 string2 start1 end1 start2 end2)) + +(defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Given two strings, if the first string is not lexicographically equal + to the second string, returns the longest common prefix (using char=) + of the two strings. Otherwise, returns ()." + (string/=* string1 string2 start1 end1 start2 end2)) + + +(eval-when (compile eval) + +;;; STRING-NOT-EQUAL-LOOP is used to generate character comparison loops for +;;; STRING-EQUAL and STRING-NOT-EQUAL. +(defmacro string-not-equal-loop (end end-value + &optional (abort-value nil abortp)) + (declare (fixnum end)) + (let ((end-test (if (= end 1) + `(= index1 (the fixnum end1)) + `(= index2 (the fixnum end2))))) + `(do ((index1 start1 (1+ index1)) + (index2 start2 (1+ index2))) + (,(if abortp + end-test + `(or ,end-test + (not (char-equal (schar string1 index1) + (schar string2 index2))))) + ,end-value) + (declare (fixnum index1 index2)) + ,@(if abortp + `((if (not (char-equal (schar string1 index1) + (schar string2 index2))) + (return ,abort-value))))))) + +) ; eval-when + +(defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Given two strings (string1 and string2), and optional integers start1, + start2, end1 and end2, compares characters in string1 to characters in + string2 (using char-equal)." + (declare (fixnum start1 start2)) + (let ((offset1 0)) + (with-two-strings string1 string2 start1 end1 offset1 start2 end2 + (let ((slen1 (- (the fixnum end1) start1)) + (slen2 (- (the fixnum end2) start2))) + (declare (fixnum slen1 slen2)) + (if (or (minusp slen1) (minusp slen2)) + ;;prevent endless looping later. + (error "Improper bounds for string comparison.")) + (if (= slen1 slen2) + ;;return () immediately if lengths aren't equal. + (string-not-equal-loop 1 t nil)))))) + +(defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Given two strings, if the first string is not lexicographically equal + to the second string, returns the longest common prefix (using char-equal) + of the two strings. Otherwise, returns ()." + (let ((offset1 0)) + (declare (fixnum offset1)) + (with-two-strings string1 string2 start1 end1 offset1 start2 end2 + (let ((slen1 (- end1 start1)) + (slen2 (- end2 start2))) + (declare (fixnum slen1 slen2)) + (if (or (minusp slen1) (minusp slen2)) + ;;prevent endless looping later. + (error "Improper bounds for string comparison.")) + (cond ((or (minusp slen1) (or (minusp slen2))) + (error "Improper substring for comparison.")) + ((= slen1 slen2) + (string-not-equal-loop 1 nil (- index1 offset1))) + ((< slen1 slen2) + (string-not-equal-loop 1 (- index1 offset1))) + (t + (string-not-equal-loop 2 (- index1 offset1)))))))) + + + +(eval-when (compile eval) + +;;; STRING-LESS-GREATER-EQUAL-TESTS returns a test on the lengths of string1 +;;; and string2 and a test on the current characters from string1 and string2 +;;; for the following macro. +(defun string-less-greater-equal-tests (lessp equalp) + (if lessp + (if equalp + ;; STRING-NOT-GREATERP + (values '<= `(not (char-greaterp char1 char2))) + ;; STRING-LESSP + (values '< `(char-lessp char1 char2))) + (if equalp + ;; STRING-NOT-LESSP + (values '>= `(not (char-lessp char1 char2))) + ;; STRING-GREATERP + (values '> `(char-greaterp char1 char2))))) + +(defmacro string-less-greater-equal (lessp equalp) + (multiple-value-bind (length-test character-test) + (string-less-greater-equal-tests lessp equalp) + `(let ((offset1 0)) + (declare (fixnum offset1)) + (with-two-strings string1 string2 start1 end1 offset1 start2 end2 + (let ((slen1 (- (the fixnum end1) start1)) + (slen2 (- (the fixnum end2) start2))) + (declare (fixnum slen1 slen2)) + (if (or (minusp slen1) (minusp slen2)) + ;;prevent endless looping later. + (error "Improper bounds for string comparison.")) + (do ((index1 start1 (1+ index1)) + (index2 start2 (1+ index2)) + (char1) + (char2)) + ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2))) + (if (,length-test slen1 slen2) (- index1 offset1))) + (declare (fixnum index1 index2)) + (setq char1 (schar string1 index1)) + (setq char2 (schar string2 index2)) + (if (not (char-equal char1 char2)) + (if ,character-test + (return (- index1 offset1)) + (return ()))))))))) + +) ; eval-when + +(defun string-lessp* (string1 string2 start1 end1 start2 end2) + (declare (fixnum start1 start2)) + (string-less-greater-equal t nil)) + +(defun string-greaterp* (string1 string2 start1 end1 start2 end2) + (declare (fixnum start1 start2)) + (string-less-greater-equal nil nil)) + +(defun string-not-lessp* (string1 string2 start1 end1 start2 end2) + (declare (fixnum start1 start2)) + (string-less-greater-equal nil t)) + +(defun string-not-greaterp* (string1 string2 start1 end1 start2 end2) + (declare (fixnum start1 start2)) + (string-less-greater-equal t t)) + +(defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Given two strings, if the first string is lexicographically less than + the second string, returns the longest common prefix (using char-equal) + of the two strings. Otherwise, returns ()." + (string-lessp* string1 string2 start1 end1 start2 end2)) + +(defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Given two strings, if the first string is lexicographically greater than + the second string, returns the longest common prefix (using char-equal) + of the two strings. Otherwise, returns ()." + (string-greaterp* string1 string2 start1 end1 start2 end2)) + +(defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Given two strings, if the first string is lexicographically greater + than or equal to the second string, returns the longest common prefix + (using char-equal) of the two strings. Otherwise, returns ()." + (string-not-lessp* string1 string2 start1 end1 start2 end2)) + +(defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0) + end2) + "Given two strings, if the first string is lexicographically less than + or equal to the second string, returns the longest common prefix + (using char-equal) of the two strings. Otherwise, returns ()." + (string-not-greaterp* string1 string2 start1 end1 start2 end2)) + + +(defun make-string (count &key ((:initial-element fill-char))) + "Given a character count and an optional fill character, makes and returns + a new string Count long filled with the fill character." + (declare (fixnum count)) + (if fill-char + (do ((i 0 (1+ i)) + (string (make-string count))) + ((= i count) string) + (declare (fixnum i)) + (setf (schar string i) fill-char)) + (make-string count))) + +(defun string-upcase (string &key (start 0) end) + "Given a string, returns a new string that is a copy of it with + all lower case alphabetic characters converted to uppercase." + (declare (fixnum start)) + (if (symbolp string) (setq string (symbol-name string))) + (let ((slen (length string)) + (offset 0)) + (declare (fixnum slen offset)) + (with-one-string string start end offset + (let ((offset-slen (+ slen offset)) + (newstring (make-string slen))) + (declare (fixnum offset-slen)) + (do ((index offset (1+ index)) + (new-index 0 (1+ new-index))) + ((= index start)) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) (schar string index))) + (do ((index start (1+ index)) + (new-index (- start offset) (1+ new-index))) + ((= index (the fixnum end))) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) + (char-upcase (schar string index)))) + (do ((index end (1+ index)) + (new-index (- (the fixnum end) offset) (1+ new-index))) + ((= index offset-slen)) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) (schar string index))) + newstring)))) + +(defun string-downcase (string &key (start 0) end) + "Given a string, returns a new string that is a copy of it with + all upper case alphabetic characters converted to lowercase." + (declare (fixnum start)) + (if (symbolp string) (setq string (symbol-name string))) + (let ((slen (length string)) + (offset 0)) + (declare (fixnum slen offset)) + (with-one-string string start end offset + (let ((offset-slen (+ slen offset)) + (newstring (make-string slen))) + (declare (fixnum offset-slen)) + (do ((index offset (1+ index)) + (new-index 0 (1+ new-index))) + ((= index start)) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) (schar string index))) + (do ((index start (1+ index)) + (new-index (- start offset) (1+ new-index))) + ((= index (the fixnum end))) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) + (char-downcase (schar string index)))) + (do ((index end (1+ index)) + (new-index (- (the fixnum end) offset) (1+ new-index))) + ((= index offset-slen)) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) (schar string index))) + newstring)))) + +(defun string-capitalize (string &key (start 0) end) + "Given a string, returns a copy of the string with the first + character of each ``word'' converted to upper-case, and remaining + chars in the word converted to lower case. A ``word'' is defined + to be a string of case-modifiable characters delimited by + non-case-modifiable chars." + (declare (fixnum start)) + (if (symbolp string) (setq string (symbol-name string))) + (let ((slen (length string)) + (offset 0)) + (declare (fixnum slen offset)) + (with-one-string string start end offset + (let ((offset-slen (+ slen offset)) + (newstring (make-string slen))) + (declare (fixnum offset-slen)) + (do ((index offset (1+ index)) + (new-index 0 (1+ new-index))) + ((= index start)) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) (schar string index))) + (do ((index start (1+ index)) + (new-index (- start offset) (1+ new-index)) + (newword t) + (char ())) + ((= index (the fixnum end))) + (declare (fixnum index new-index)) + (setq char (schar string index)) + (cond ((not (alphanumericp char)) + (setq newword t)) + (newword + ;;char is first case-modifiable after non-case-modifiable + (setq char (char-upcase char)) + (setq newword ())) + ;;char is case-modifiable, but not first + (t (setq char (char-downcase char)))) + (setf (schar newstring new-index) char)) + (do ((index end (1+ index)) + (new-index (- (the fixnum end) offset) (1+ new-index))) + ((= index offset-slen)) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) (schar string index))) + newstring)))) + +(defun nstring-upcase (string &key (start 0) end) + "Given a string, returns that string with all lower case alphabetic + characters converted to uppercase." + (declare (fixnum start)) + (let ((save-header string) + offset) + (with-one-string string start end offset + (do ((index start (1+ index))) + ((= index (the fixnum end))) + (declare (fixnum index)) + (setf (schar string index) (char-upcase (schar string index))))) + save-header)) + +(defun nstring-downcase (string &key (start 0) end) + "Given a string, returns that string with all upper case alphabetic + characters converted to lowercase." + (declare (fixnum start)) + (let ((save-header string) + offset) + (with-one-string string start end offset + (do ((index start (1+ index))) + ((= index (the fixnum end))) + (declare (fixnum index)) + (setf (schar string index) (char-downcase (schar string index))))) + save-header))) + +(defun nstring-capitalize (string &key (start 0) end) + "Given a string, returns that string with the first + character of each ``word'' converted to upper-case, and remaining + chars in the word converted to lower case. A ``word'' is defined + to be a string of case-modifiable characters delimited by + non-case-modifiable chars." + (declare (fixnum start)) + (let ((save-header string) + offset) + (with-one-string string start end offset + (do ((index start (1+ index)) + (newword t) + (char ())) + ((= index (the fixnum end))) + (declare (fixnum index)) + (setq char (schar string index)) + (cond ((not (alphanumericp char)) + (setq newword t)) + (newword + ;;char is first case-modifiable after non-case-modifiable + (setf (schar string index) (char-upcase char)) + (setq newword ())) + (t + (setf (schar string index) (char-downcase char)))))) + save-header)) + +(defun string-left-trim (char-bag string) + "Given a set of characters (a list or string) and a string, returns + a copy of the string with the characters in the set removed from the + left end." + (with-string string + (do ((index start (1+ index))) + ((or (= index (the fixnum end)) + (not (find (schar string index) char-bag))) + (subseq (the simple-string string) index end)) + (declare (fixnum index))))) + +(defun string-right-trim (char-bag string) + "Given a set of characters (a list or string) and a string, returns + a copy of the string with the characters in the set removed from the + right end." + (with-string string + (do ((index (1- (the fixnum end)) (1- index))) + ((or (< index start) (not (find (schar string index) char-bag))) + (subseq (the simple-string string) start (1+ index))) + (declare (fixnum index))))) + +(defun string-trim (char-bag string) + "Given a set of characters (a list or string) and a string, returns a + copy of the string with the characters in the set removed from both + ends." + (with-string string + (let* ((left-end (do ((index start (1+ index))) + ((or (= index (the fixnum end)) + (not (find (schar string index) char-bag))) + index) + (declare (fixnum index)))) + (right-end (do ((index (1- (the fixnum end)) (1- index))) + ((or (< index left-end) + (not (find (schar string index) char-bag))) + (1+ index)) + (declare (fixnum index))))) + (subseq (the simple-string string) left-end right-end)))) diff --git a/code/struct.lisp b/code/struct.lisp new file mode 100644 index 000000000..a8f362856 --- /dev/null +++ b/code/struct.lisp @@ -0,0 +1,156 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains structure definitions that need to be compiled early +;;; for bootstrapping reasons. +;;; +(in-package 'lisp) + +;;;; Defstruct structures: + +(in-package 'c) + +;;; Initialization hacks: + +#+new-compiler +(progn +;;; Make these types be sort-of-defined to allow bootstrapping. +(setf (info type kind 'defstruct-description) :structure) +(setf (info type kind 'defstruct-slot-description) :structure) + + +;;; Define this now so that EQUAL works: +;;; +(defun pathnamep (x) + (and (structurep x) + (eq (%primitive header-ref x %g-vector-structure-name-slot) + 'pathname))) + +;;; Define so that we can test for VOLATILE-INFO-ENVs from the beginning of +;;; initialization. +;;; +(defun c::volatile-info-env-p (x) + (and (structurep x) + (eq (%primitive header-ref x %g-vector-structure-name-slot) + 'c::volatile-info-env))) + +;;; Not really a structure, but at least a type-related initialization hack: +;;; +(deftype c::inlinep () + '(member :inline :maybe-inline :notinline nil)) +;;; +(deftype c::boolean () + '(member t nil)) + +); #+new-compiler + + +(defstruct (defstruct-description + (:conc-name dd-) + (:print-function print-defstruct-description)) + name ; name of the structure + doc ; documentation on the structure + slots ; list of slots + conc-name ; prefix for slot names + constructor ; name of standard constructor function + boa-constructors ; BOA constructors (cdr of option). + copier ; name of copying function + predicate ; name of type predictate + include ; name of included structure + (includes ()) ; names of all structures included by this one + (included-by ()) ; names of all strctures that include this one + print-function ; function used to print it + type ; type specified, Structure if no type specified. + lisp-type ; actual type used for implementation. + named ; T if named, Nil otherwise + offset ; first slot's offset into implementation sequence + (length nil :type (or fixnum null))) ; total length of the thing + + +(defstruct (defstruct-slot-description + (:conc-name dsd-) + (:print-function print-defstruct-slot-description)) + %name ; string name of slot + (index nil :type fixnum) ; its position in the implementation sequence + accessor ; name of it accessor function + default ; default value + type ; declared type + read-only) ; T if there's to be no setter for it + + +(in-package 'lisp) + +;;;; The stream structure: + +(defconstant in-buffer-length 100 "The size of a stream in-buffer.") + +(defstruct (stream (:predicate streamp) (:print-function %print-stream)) + (in-buffer nil) ; Buffered input + (in-index in-buffer-length :type fixnum) ; Index into in-buffer + (in #'ill-in) ; Read-Char function + (bin #'ill-bin) ; Byte input function + (n-bin #'ill-bin) ; N-Byte input function + (out #'ill-out) ; Write-Char function + (bout #'ill-bout) ; Byte output function + (sout #'ill-out) ; String output function + (misc #'do-nothing)) ; Less used methods + + +;;;; Alien structures: + +(defstruct (alien-value + (:constructor make-alien-value (sap offset size type)) + (:print-function %print-alien-value)) + "This structure represents an Alien value." + sap + offset + size + type) + +(defstruct (ct-a-val + (:print-function + (lambda (s stream d) + (declare (ignore s d)) + (write-string "#<Alien compiler info>" stream)))) + type ; Type of expression, NIL if unknown. + size ; Expression for the size of the alien. + sap ; Expression for SAP. + offset ; Expression for bit offset. + alien) ; Expression for alien-value or NIL. + + +(defstruct (alien-info + (:print-function %print-alien-info) + (:constructor + make-alien-info (function num-args arg-types result-type))) + function ; The function the definition was made into. + num-args ; The total number of arguments. + arg-types ; Alist of arg numbers to types of Alien args. + result-type) ; The type of the resulting Alien. + + +(defstruct (stack-info + (:print-function + (lambda (s stream d) + (declare (ignore s d)) + (format stream "#<Alien stack info>")))) + type + size + head + current + grow) + + +(defstruct enumeration-info + signed ; True if minimum value negative. + size ; Minimum number of bits needed to hold value. + from ; Symbol holding alist from keywords to integers. + to ; Symbol holding alist or vector from integers to keywords. + kind ; Kind of from mapping, :vector or :alist. + offset) ; Offset to add to value for :vector from mapping. diff --git a/code/symbol.lisp b/code/symbol.lisp new file mode 100644 index 000000000..50f0598a2 --- /dev/null +++ b/code/symbol.lisp @@ -0,0 +1,189 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Symbol manipulating functions for Spice Lisp. +;;; +;;; Written by Scott Fahlman. +;;; Hacked on and maintained by Skef Wholey. +;;; +;;; Many of these are trivial interpreter entries to functions +;;; open-coded by the compiler. +;;; +(in-package 'lisp) +(export '(get remprop symbol-plist getf get-properties symbol-name + make-symbol copy-symbol gensym gentemp *gensym-counter* + symbol-package keywordp makunbound symbol-value symbol-function + boundp set)) + +(defun set (variable new-value) + "VARIABLE must evaluate to a symbol. This symbol's special value cell is + set to the specified new value." + (set variable new-value)) + +(defun makunbound (variable) + "VARIABLE must evaluate to a symbol. This symbol is made unbound, + removing any value it may currently have." + (makunbound variable)) + +(defun symbol-value (variable) + "VARIABLE must evaluate to a symbol. This symbol's current special + value is returned." + (symbol-value variable)) + +(defun symbol-function (variable) + "VARIABLE must evaluate to a symbol. This symbol's current definition + is returned." + (symbol-function variable)) + +(defun %sp-set-definition (symbol new-value) + (setf (symbol-function symbol) new-value)) + +(defun boundp (variable) + "VARIABLE must evaluate to a symbol. Return () if this symbol is + unbound, T if it has a value." + (boundp variable)) + +(defun symbol-plist (variable) + "VARIABLE must evaluate to a symbol. Return its property list." + (symbol-plist variable)) + +(defun %sp-set-plist (symbol new-value) + (setf (symbol-plist symbol) new-value)) + +(defun symbol-name (variable) + "VARIABLE must evaluate to a symbol. Return its print name." + (symbol-name variable)) + +(defun symbol-package (variable) + "VARIABLE must evaluate to a symbol. Return its package." + (symbol-package variable)) + +(defun make-symbol (string) + "Make and return a new symbol with the STRING as its print name." + (make-symbol string)) + +(defun get (symbol indicator &optional (default nil)) + "Look on the property list of SYMBOL for the specified INDICATOR. If this + is found, return the associated value, else return DEFAULT." + (do ((pl (symbol-plist symbol) (cddr pl))) + ((atom pl) default) + (cond ((atom (cdr pl)) + (error "~S has an odd number of items in its property list." + symbol)) + ((eq (car pl) indicator) + (return (cadr pl)))))) + +(defun %put (symbol indicator value) + "The VALUE is added as a property of SYMBOL under the specified INDICATOR. + Returns VALUE." + (%primitive put symbol indicator value) +#| (do ((pl (symbol-plist symbol) (cddr pl))) + ((atom pl) + (setf (symbol-plist symbol) + (list* indicator value (symbol-plist symbol))) + value) + (cond ((atom (cdr pl)) + (error "~S has an odd number of items in its property list." + symbol)) + ((eq (car pl) indicator) + (rplaca (cdr pl) value) + (return value))))|# + ) + +(defun remprop (symbol indicator) + "Look on property list of SYMBOL for property with specified + INDICATOR. If found, splice this indicator and its value out of + the plist, and return the tail of the original list starting with + INDICATOR. If not found, return () with no side effects." + (do ((pl (symbol-plist symbol) (cddr pl)) + (prev nil pl)) + ((atom pl) nil) + (cond ((atom (cdr pl)) + (error "~S has an odd number of items in its property list." + symbol)) + ((eq (car pl) indicator) + (cond (prev (rplacd (cdr prev) (cddr pl))) + (t + (setf (symbol-plist symbol) (cddr pl)))) + (return pl))))) + +(defun getf (place indicator &optional (default ())) + "Searches the property list stored in Place for an indicator EQ to Indicator. + If one is found, the corresponding value is returned, else the Default is + returned." + (do ((plist place (cddr plist))) + ((null plist) default) + (cond ((atom (cdr plist)) + (error "~S is a malformed property list." + place)) + ((eq (car plist) indicator) + (return (cadr plist)))))) + + +(defun get-properties (place indicator-list) + "Like GETF, except that Indicator-List is a list of indicators which will + be looked for in the property list stored in Place. Three values are + returned, see manual for details." + (do ((plist place (cddr plist))) + ((null plist) (values nil nil nil)) + (cond ((atom (cdr plist)) + (error "~S is a malformed proprty list." + place)) + ((memq (car plist) indicator-list) + (return (values (car plist) (cadr plist) plist)))))) + +(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol) + "Make and return a new uninterned symbol with the same print name + as SYMBOL. If COPY-PROPS is null, the new symbol has no properties. + Else, it has a copy of SYMBOL's property list." + (setq new-symbol (make-symbol (symbol-name symbol))) + (if copy-props + (setf (symbol-plist new-symbol) (copy-list (symbol-plist symbol)))) + new-symbol) + +(proclaim '(special *keyword-package*)) + +(defun keywordp (object) + "Returns true if Object is a symbol in the keyword package." + (and (symbolp object) + (eq (symbol-package object) *keyword-package*))) + + +;;;; Gensym and friends. + +(defvar *gensym-counter* 0 + "Counter for generating unique GENSYM symbols.") + +(defun gensym (&optional string) + "Creates a new uninterned symbol whose name is a prefix string (defaults + to \"G\"), followed by a decimal number. String, when supplied, will + alter the prefix if it is a string, or the decimal number if it is a + number, of this symbol. The number, defaultly *gensym-counter*, is + incremented by each call to GENSYM." + (let* ((*print-base* 10) + (*print-radix* nil) + (*print-pretty* nil) + (prefix (if (stringp string) string "G")) + (number (prin1-to-string (if (numberp string) + string + (incf *gensym-counter*))))) + (make-symbol (concatenate 'simple-string prefix number)))) + +(defun gentemp (&optional (prefix t) (package *package*)) + "Creates a new symbol interned in package Package with the given Prefix." + (loop + (let ((*print-base* 10) + (*print-radix* nil) + (*print-pretty* nil) + (new-pname (format nil "~A~D" + (string prefix) (incf *gensym-counter*)))) + (multiple-value-bind (symbol existsp) + (find-symbol new-pname package) + (declare (ignore symbol)) + (unless existsp (return (values (intern new-pname package)))))))) diff --git a/code/sysmacs.lisp b/code/sysmacs.lisp new file mode 100644 index 000000000..95693b1a2 --- /dev/null +++ b/code/sysmacs.lisp @@ -0,0 +1,274 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Miscellaneous system hacking macros. +;;; +(in-package "LISP" :use '("SYSTEM" "DEBUG")) + +#-new-compiler +(eval-when (compile) + (setq lisp::*bootstrap-defmacro* t)) + +;;; WITH-ARRAY-DATA follows an arbitrarily long chain of displaced arrays +;;; binding data-var to the data vector, offset-var to the cumulative +;;; displacement offset, start-var to the actual start index in the data +;;; vector, and end-var to the actual end of the data vector. Put all the +;;; bindings in the LET, so declarations can be made on the variables (for +;;; example, declaring data-var to be a simple-string. +(defmacro with-array-data (((data-var array &key (offset-var (gensym))) + (start-var &optional (svalue 0)) + (end-var &optional (evalue nil))) + &rest forms) + "Bind data-var to the data-vector eventually reached by following displacement + links from array, offset-var to a cumulative offset, start-var to the first + index in the data vector, and end-var to the total length of the array plus + the cumulative offset. Offset-var, start-var, and end-var are declared to be + fixnums." + `(multiple-value-bind (,data-var ,offset-var) + (find-data-vector ,array) + (let* ((,data-var ,data-var) + (,offset-var ,offset-var) + (,start-var (+ ,svalue ,offset-var)) + (,end-var (+ ,offset-var (or ,evalue (array-total-size ,array))))) + (declare (fixnum ,offset-var ,start-var ,end-var)) + ,@forms))) + + +(defmacro %displacedp (array-header) + `(= (the fixnum (%primitive get-vector-subtype ,array-header)) + (the fixnum %array-displaced-subtype))) + +(defmacro %set-array-displacedp (array-header value) + `(%primitive set-vector-subtype ,array-header + (if ,value %array-displaced-subtype %array-normal-subtype))) + + +(defmacro without-gcing (&rest body) + "Executes the forms in the body without doing a garbage collection." + `(multiple-value-prog1 + (let ((*gc-inhibit* t)) + ,@body) + (when (and *need-to-collect-garbage* (not *gc-inhibit*)) + (maybe-gc nil)))) + + +(defmacro with-interrupts (&body body) + `(let ((iin %sp-interrupts-inhibited)) + (setq %sp-interrupts-inhibited NIL) + (when (consp iin) + (dolist (x iin) + (let ((f (svref *software-interrupt-vector* (car x)))) + (when f (apply f x))))) + (unwind-protect + (progn ,@body) + (if iin (setq %sp-interrupts-inhibited T))))) + +(defmacro without-interrupts (&rest body) + "Evaluates the forms in the Body without allowing interrupts." + `(let* ((old-interrupts-inhibited %sp-interrupts-inhibited) + (%sp-interrupts-inhibited (or %sp-interrupts-inhibited T))) + (multiple-value-prog1 + (progn ,@body) + (when (and (null old-interrupts-inhibited) + (consp %sp-interrupts-inhibited)) + (dolist (x %sp-interrupts-inhibited) + (let ((f (svref *software-interrupt-vector* (car x)))) + (when f (apply f x)))))))) + + +(defmacro with-enabled-interrupts (interrupt-list &body body) + "With-enabled-interrupts ({(interrupt function [character])}*) {form}* + Establish function as a handler for the Unix signal interrupt which + should be a number between 1 and 31 inclusive. For the signals that + can be generated from the keyboard, the optional character specifies + the character to use to generate the signal." + (let ((il (gensym)) + (fn (gensym)) + (ch (gensym)) + (it (gensym))) + `(let ((,il NIL)) + (unwind-protect + (progn + ,@(do* ((item interrupt-list (cdr item)) + (intr (caar item) (caar item)) + (ifcn (cadar item) (cadar item)) + (ichr (caddar item) (caddar item)) + (forms NIL)) + ((null item) (nreverse forms)) + (if (symbolp intr) + (setq intr (symbol-value intr))) + (push `(multiple-value-bind (,fn ,ch) + (enable-interrupt ,intr ,ifcn + ,ichr) + (push `(,,intr ,,fn ,,ch) ,il)) forms)) + ,@body) + (dolist (,it (nreverse ,il)) + (funcall #'enable-interrupt (car ,it) (cadr ,it) (caddr ,it))))))) + + +(defvar hi::*in-the-editor* nil) + +(defmacro without-hemlock (&body body) + `(progn + (when (and hi::*in-the-editor* (null debug::*in-the-debugger*)) + (let ((device (hi::device-hunk-device + (hi::window-hunk (hi::current-window))))) + (funcall (hi::device-exit device) device))) + ,@body + (when (and hi::*in-the-editor* (null debug::*in-the-debugger*)) + (let ((device (hi::device-hunk-device + (hi::window-hunk (hi::current-window))))) + (funcall (hi::device-init device) device))))) + + +;;; With-Reply-Port -- Public +;;; +;;; If we find that the number of ports in use (as indicated by +;;; *reply-port-pointer*) disagrees with our dynamic depth in +;;; With-Reply-Port forms (as indicated by *reply-port-depth*), +;;; then we must have been unwound at some point in the past. +;;; We reallocate the ports that were in use when we were +;;; unwound, since they may have random messages hanging on them. +;;; +(defmacro with-reply-port ((var) &body body) + "With-Reply-Port (Var) {Form}* + Binds Var to a port during the evaluation of the Forms." + (let ((index (gensym)) + (old-flag (gensym)) + (res (gensym))) + `(let ((,old-flag %sp-interrupts-inhibited) + ,res) + (without-interrupts + (let* ((,index *reply-port-depth*) + (*reply-port-depth* (1+ ,index)) + ,var) + (unless (eql ,index *reply-port-pointer*) + (reallocate-reply-ports ,index)) + (setq ,var (svref *reply-port-stack* ,index)) + (setq *reply-port-pointer* (1+ ,index)) + (unless ,var (setq ,var (allocate-new-reply-ports))) + (setq %sp-interrupts-inhibited ,old-flag) + (setq ,res (multiple-value-list (progn ,@body))) + (when (eql (car ,res) mach:rcv-timed-out) + (gr-call mach:port_deallocate *task-self* ,var) + (setf (svref *reply-port-stack* ,index) + (gr-call* mach:port_allocate *task-self*))) + (setq %sp-interrupts-inhibited (or ,old-flag T)) + (if (eql ,index (1- *reply-port-pointer*)) + (setq *reply-port-pointer* ,index) + (reallocate-reply-ports (1+ ,index))) + (values-list ,res)))))) + + +;;; Eof-Or-Lose is a useful macro that handles EOF. + +(defmacro eof-or-lose (stream eof-errorp eof-value) + `(if ,eof-errorp + (error "~S: Stream hit EOF unexpectedly." ,stream) + ,eof-value)) + +;;; These macros handle the special cases of t and nil for input and +;;; output streams. +;;; +(defmacro in-synonym-of (stream) + (let ((svar (gensym))) + `(let ((,svar ,stream)) + (cond ((null ,svar) *standard-input*) + ((eq ,svar t) *terminal-io*) + (t (check-type ,svar stream) + ,svar))))) + +(defmacro out-synonym-of (stream) + (let ((svar (gensym))) + `(let ((,svar ,stream)) + (cond ((null ,svar) *standard-output*) + ((eq ,svar t) *terminal-io*) + (T (check-type ,svar stream) + ,svar))))) + +;;; With-Mumble-Stream calls the function in the given Slot of the Stream with +;;; the Args. +;;; +(defmacro with-in-stream (stream slot &rest args) + `(let ((stream (in-synonym-of ,stream))) + (funcall (,slot stream) stream ,@args))) + +(defmacro with-out-stream (stream slot &rest args) + `(let ((stream (out-synonym-of ,stream))) + (funcall (,slot stream) stream ,@args))) + + +;;;; These are hacks to make the reader win. + +;;; Prepare-For-Fast-Read-Char -- Internal +;;; +;;; This macro sets up some local vars for use by the Fast-Read-Char +;;; macro within the enclosed lexical scope. +;;; +(defmacro prepare-for-fast-read-char (stream &body forms) + `(let* ((%frc-stream% (in-synonym-of ,stream)) + (%frc-method% (stream-in %frc-stream%)) + (%frc-buffer% (stream-in-buffer %frc-stream%)) + (%frc-index% (stream-in-index %frc-stream%))) + (declare (type (or simple-string null) %frc-buffer%) (fixnum %frc-index%)) + ,@forms)) + +;;; Done-With-Fast-Read-Char -- Internal +;;; +;;; This macro must be called after one is done with fast-read-char +;;; inside it's scope to decache the stream-in-index. +;;; +(defmacro done-with-fast-read-char () + `(setf (stream-in-index %frc-stream%) %frc-index%)) + +;;; Fast-Read-Char -- Internal +;;; +;;; This macro can be used instead of Read-Char within the scope of +;;; a Prepare-For-Fast-Read-Char. +;;; +(defmacro fast-read-char (&optional (eof-errorp t) (eof-value ())) + `(cond + ((= %frc-index% in-buffer-length) + (setf (stream-in-index %frc-stream%) %frc-index%) + (prog1 (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value) + (setq %frc-index% (stream-in-index %frc-stream%)))) + (t + (prog1 (aref %frc-buffer% %frc-index%) + (incf %frc-index%))))) + +;;;; And these for the fasloader... + +;;; Prepare-For-Fast-Read-Byte -- Internal +;;; +;;; Just like Prepare-For-Fast-Read-Char except that we get the Bin +;;; method. +;;; +(defmacro prepare-for-fast-read-byte (stream &body forms) + `(let* ((%frc-stream% (in-synonym-of ,stream)) + (%frc-method% (stream-bin %frc-stream%)) + (%frc-buffer% (stream-in-buffer %frc-stream%)) + (%frc-index% (stream-in-index %frc-stream%))) + (declare (type (or simple-array null) %frc-buffer%) (fixnum %frc-index%)) + ,@forms)) + +;;; Fast-Read-Byte, Done-With-Fast-Read-Byte -- Internal +;;; +;;; Identical to the text versions, but we get some gratuitous +;;; psuedo-generality by having different names. +;;; +(defmacro done-with-fast-read-byte () + `(done-with-fast-read-char)) +;;; +(defmacro fast-read-byte (&rest stuff) + `(fast-read-char ,@stuff)) + + +#-new-compiler +(eval-when (compile) + (setq lisp::*bootstrap-defmacro* nil)) diff --git a/code/time.lisp b/code/time.lisp new file mode 100644 index 000000000..9f98887f1 --- /dev/null +++ b/code/time.lisp @@ -0,0 +1,404 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains the definitions for the Spice Lisp time functions. +;;; They are mostly fairly straightforwardly implemented as calls to the +;;; time server. +;;; +;;; Written by Rob MacLachlan. +;;; +(in-package 'lisp) +(export '(internal-time-units-per-second get-internal-real-time + get-internal-run-time get-universal-time + get-decoded-time encode-universal-time decode-universal-time)) + +(defconstant internal-time-units-per-second 100 + "The number of internal time units that fit into a second. See + Get-Internal-Real-Time and Get-Internal-Run-Time.") + +(defmacro not-leap-year (year) + (let ((sym (gensym))) + `(let ((,sym ,year)) + (cond ((eq (mod ,sym 4) 0) + (and (eq (mod ,sym 100) 0) + (not (eq (mod ,sym 400) 0)))) + (T T))))) + +;;; Get-Internal-Real-Time -- Public +;;; +;;; +(defun get-internal-real-time () + "Return the real time in the internal time format. This is useful for + finding elapsed time. See Internal-Time-Units-Per-Second." + (let ((val (system:%primitive get-real-time))) + (when (eq val -1) + (error "Failed to get real time.")) + val)) + +#| +(defun get-internal-real-time () + "Return the real time in the internal time format. This is useful for + finding elapsed time. See Internal-Time-Units-Per-Second." + (multiple-value-bind (result seconds useconds) (mach:unix-gettimeofday) + (if result (+ (* seconds internal-time-units-per-second) useconds) + (error "Unix system call gettimeofday failed: ~A" + (mach:get-unix-error-msg seconds))))) +|# + +;;; Get-Internal-Run-Time -- Public +;;; +;;; PmGetTimes returns run time in microseconds. Convert to jiffies. +;;; +(defun get-internal-run-time () + "Return the run time in the internal time format. This is useful for + finding CPU usage." + (let ((val (system:%primitive get-run-time))) + (when (eq val -1) + (error "Failed to obtain run time.")) + val)) + +#| +(defun get-internal-run-time () + "Return the run time in the internal time format. This is useful for + finding CPU usage." + (multiple-value-bind (result utime stime) + (mach:unix-getrusage mach:rusage_self) + (if result (+ utime stime) + (error "Unix system call getrusage failed: ~A" + (mach:get-unix-error-msg utime))))) +|# + +;;; Subtract from the returned Internal_Time to get the universal time. +;;; The offset between our time base and the Perq one is 2145 weeks and +;;; five days. +;;; +(defconstant seconds-in-week (* 60 60 24 7)) +(defconstant weeks-offset 2145) +(defconstant seconds-offset 432000) +(defconstant minutes-per-day (* 24 60)) +(defconstant quarter-days-per-year (1+ (* 365 4))) +(defconstant quarter-days-per-century 146097) +(defconstant november-17-1858 678882) +(defconstant weekday-november-17-1858 2) +(defconstant unix-to-universal-time 2208988800) + +;;; Make-Universal-Time -- Internal +;;; +;;; Convert a Unix Internal_Time into a universal time. +;;; +(defun make-universal-time (weeks msec) + (+ (* (- weeks weeks-offset) seconds-in-week) + (- (truncate msec 1000) seconds-offset))) + +;;; Get-Universal-Time -- Public +;;; +;;; +(defun get-universal-time () + "Returns a single integer for the current time of + day in universal time format." + (multiple-value-bind (res secs) (mach:unix-gettimeofday) + (declare (ignore res)) + (+ secs unix-to-universal-time))) + +;;; Get-Decoded-Time -- Public +;;; +;;; + +(defun get-decoded-time () + "Returns nine values specifying the current time as follows: + second, minute, hour, date, month, year, day of week (0 = Monday), + T (daylight savings times) or NIL (standard time), and timezone." + (decode-universal-time (get-universal-time))) + +;;; Decode-Universal-Time -- Public +;;; +;;; + +(defun decode-universal-time (universal-time &optional time-zone) + "Converts a universal-time to decoded time format returning + the following nine values: second, minute, hour, date, month, + year, day of week (0 = Monday), T (daylight savings time) or + NIL (standard time), and timezone." + (declare (type (or fixnum null) time-zone)) + (multiple-value-bind (weeks secs) + (truncate (+ universal-time seconds-offset) + seconds-in-week) + (let ((weeks (+ weeks weeks-offset)) + (second NIL) + (minute NIL) + (hour NIL) + (date NIL) + (month NIL) + (year NIL) + (day NIL) + (daylight NIL) + (timezone (if (null time-zone) + (multiple-value-bind (res s us tz) + (mach:unix-gettimeofday) + (declare (ignore s us)) + (if res tz 0)) + (* time-zone 60)))) + (declare (fixnum timezone)) + (multiple-value-bind (t1 seconds) (truncate secs 60) + (setq second seconds) + (setq t1 (- t1 timezone)) + (let* ((tday (if (< t1 0) + (1- (truncate (1+ t1) minutes-per-day)) + (truncate t1 minutes-per-day)))) + (multiple-value-setq (hour minute) + (truncate (- t1 (* tday minutes-per-day)) 60)) + (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))) + (tcent (truncate t2 quarter-days-per-century))) + (setq t2 (mod t2 quarter-days-per-century)) + (setq t2 (+ (- t2 (mod t2 4)) 3)) + (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year))) + (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year) + 4)))) + (setq day (mod (+ tday weekday-november-17-1858) 7)) + (if (setq daylight (dst-check days-since-mar0 hour day)) + (cond ((eq hour 23) + (setq hour 0) + (setq day (mod (1+ day) 7)) + (setq days-since-mar0 (1+ days-since-mar0)) + (if (>= days-since-mar0 366) + (if (or (> days-since-mar0 366) + (not-leap-year (1+ year))) + (setq days-since-mar0 368)))) + (T (setq hour (1+ hour))))) + (let ((t3 (+ (* days-since-mar0 5) 456))) + (cond ((>= t3 1989) + (setq t3 (- t3 1836)) + (setq year (1+ year)))) + (multiple-value-setq (month t3) (truncate t3 153)) + (setq date (1+ (truncate t3 5)))))))) + (values second minute hour date month year day + daylight (truncate timezone 60))))) + +;;; Encode-Universal-Time -- Public +;;; +;;; Just do a TimeUser:T_UserToInt. If the year is between 0 and 99 we +;;; have to figure out which the "obvious" year is. +;;; + +(defun encode-universal-time (second minute hour date month year + &optional time-zone) + "The time values specified in decoded format are converted to + universal time, which is returned." + (let* ((year (if (< year 100) + (multiple-value-bind (sec min hour day month now-year) + (get-decoded-time) + (declare (ignore sec min hour day month)) + (do ((y (+ year (* 100 (1- (truncate now-year 100)))) + (+ y 100))) + ((<= (abs (- y now-year)) 50) y))) + year)) + (zone (if time-zone (* time-zone 60) + (multiple-value-bind (res s us tz) (mach:unix-gettimeofday) + (declare (ignore s us)) + (if res tz)))) + (tmonth (- month 3))) + (cond ((< tmonth 0) + (setq tmonth (+ tmonth 12)) + (setq year (1- year)))) + (let ((days-since-mar0 (+ (truncate (+ (* tmonth 153) 2) 5) date))) + (multiple-value-bind (tcent tyear) (truncate year 100) + (let* ((tday (- (+ (truncate (* tcent quarter-days-per-century) 4) + (truncate (* tyear quarter-days-per-year) 4) + days-since-mar0) + november-17-1858)) + (daylight (dst-check days-since-mar0 (1- hour) + (mod (+ tday weekday-november-17-1858) 7))) + (tminutes (+ (* hour 60) minute zone))) + (if daylight (setq tminutes (- tminutes 60))) + (do ((i tminutes (+ i minutes-per-day))) + ((>= i 0) (setq tminutes i)) + (declare (fixnum i)) + (decf tday 1)) + (do ((i tminutes (- i minutes-per-day))) + ((< i minutes-per-day) (setq tminutes i)) + (declare (fixnum i)) + (incf tday 1)) + (multiple-value-bind (weeks dpart) (truncate tday 7) + (make-universal-time weeks (* (+ (* (+ (* dpart minutes-per-day) + tminutes) 60) + second) 1000)))))))) + +;;; Dst-check -- Internal +(defconstant april-1 (+ (truncate (+ (* (- 4 3) 153) 2) 5) 1)) +(defconstant october-31 (+ (truncate (+ (* (- 10 3) 153) 2) 5) 31)) + +(eval-when (compile eval) + + (defmacro dst-check-start-of-month-ge (day hour weekday daybound) + (let ((d (gensym)) + (h (gensym)) + (w (gensym)) + (db (gensym))) + `(let ((,d ,day) + (,h ,hour) + (,w ,weekday) + (,db ,daybound)) + (declare (fixnum ,d ,h ,w ,db)) + (cond ((< ,d ,db) NIL) + ((> (the fixnum (- ,d ,w)) ,db) T) + ((and (eq ,w 6) (> ,h 0)) T) + (T NIL))))) + + (defmacro dst-check-end-of-month-ge (day hour weekday daybound) + (let ((d (gensym)) + (h (gensym)) + (w (gensym)) + (db (gensym))) + `(let ((,d ,day) + (,h ,hour) + (,w ,weekday) + (,db ,daybound)) + (declare (fixnum ,d ,h ,w ,db)) + (cond ((< (the fixnum (+ ,d 6)) ,db) NIL) + ((> (the fixnum (- (the fixnum (+ ,d 6)) ,w)) ,db) T) + ((and (eq ,w 6) (> ,h 0)) T) + (T NIL))))) + ) + +(defun dst-check (day hour weekday) + (and (dst-check-start-of-month-ge day hour weekday april-1) + (not (dst-check-end-of-month-ge day hour weekday october-31)))) + +(defmacro time (form) + "Evaluates the Form and prints timing information on *Trace-Output*." + (let ((old-run-utime (gensym)) + (new-run-utime (gensym)) + (old-run-stime (gensym)) + (new-run-stime (gensym)) + (old-real-time (gensym)) + (new-real-time (gensym)) + (old-page-faults (gensym)) + (new-page-faults (gensym)) + (real-time-overhead (gensym)) + (run-utime-overhead (gensym)) + (run-stime-overhead (gensym)) + (page-faults-overhead (gensym)) + (old-bytes-consed (gensym)) + (new-bytes-consed (gensym)) + (cons-overhead (gensym)) + (err? (gensym)) + (utime (gensym)) + (stime (gensym))) + `(let (,old-run-utime + ,new-run-utime + ,old-run-stime + ,new-run-stime + ,old-real-time + ,new-real-time + ,old-page-faults + ,new-page-faults + ,real-time-overhead + ,run-utime-overhead + ,run-stime-overhead + ,page-faults-overhead + ,old-bytes-consed + ,new-bytes-consed + ,cons-overhead) + ;; Calculate the overhead... + (multiple-value-bind (,err? ,utime ,stime) + (mach:unix-getrusage mach:rusage_self) + (cond ((null ,err?) + (error "Unix system call getrusage failed: ~A." + (mach:get-unix-error-msg ,utime))) + (T (setq ,old-run-utime ,utime) + (setq ,old-run-stime ,stime)))) + (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) + (mach:vm_statistics *task-self*) + (declare (ignore ps fc ac ic wc zf ra in ot)) + (gr-error 'mach:vm_allocate gr) + (setq ,old-page-faults pf)) + (setq ,old-bytes-consed (get-bytes-consed)) + ;; Do it a second time, to make sure everything is faulted in. + (multiple-value-bind (,err? ,utime ,stime) + (mach:unix-getrusage mach:rusage_self) + (cond ((null ,err?) + (error "Unix system call getrusage failed: ~A." + (mach:get-unix-error-msg ,utime))) + (T (setq ,old-run-utime ,utime) + (setq ,old-run-stime ,stime)))) + (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) + (mach:vm_statistics *task-self*) + (declare (ignore ps fc ac ic wc zf ra in ot)) + (gr-error 'mach:vm_statistics gr) + (setq ,old-page-faults pf)) + (setq ,old-bytes-consed (get-bytes-consed)) + + (multiple-value-bind (,err? ,utime ,stime) + (mach:unix-getrusage mach:rusage_self) + (cond ((null ,err?) + (error "Unix system call getrusage failed: ~A." + (mach:get-unix-error-msg ,utime))) + (T (setq ,new-run-utime ,utime) + (setq ,new-run-stime ,stime)))) + (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) + (mach:vm_statistics *task-self*) + (declare (ignore ps fc ac ic wc zf ra in ot)) + (gr-error 'mach:vm_statistics gr) + (setq ,new-page-faults pf)) + (setq ,new-bytes-consed (get-bytes-consed)) + + (setq ,run-utime-overhead (- ,new-run-utime ,old-run-utime)) + (setq ,run-stime-overhead (- ,new-run-stime ,old-run-stime)) + (setq ,page-faults-overhead (- ,new-page-faults ,old-page-faults)) + (setq ,old-real-time (get-internal-real-time)) + (setq ,old-real-time (get-internal-real-time)) + (setq ,new-real-time (get-internal-real-time)) + (setq ,real-time-overhead (- ,new-real-time ,old-real-time)) + (setq ,cons-overhead (- ,new-bytes-consed ,old-bytes-consed)) + ;; Now get the initial times. + (multiple-value-bind (,err? ,utime ,stime) + (mach:unix-getrusage mach:rusage_self) + (cond ((null ,err?) + (error "Unix system call getrusage failed: ~A." + (mach:get-unix-error-msg ,utime))) + (T (setq ,old-run-utime ,utime) + (setq ,old-run-stime ,stime)))) + (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) + (mach:vm_statistics *task-self*) + (declare (ignore ps fc ac ic wc zf ra in ot)) + (gr-error 'mach:vm_statistics gr) + (setq ,old-page-faults pf)) + (setq ,old-real-time (get-internal-real-time)) + (setq ,old-bytes-consed (get-bytes-consed)) + (multiple-value-prog1 + ;; Execute the form, and return its values. + ,form + (multiple-value-bind (,err? ,utime ,stime) + (mach:unix-getrusage mach:rusage_self) + (cond ((null ,err?) + (error "Unix system call getrusage failed: ~A." + (mach:get-unix-error-msg ,utime))) + (T (setq ,new-run-utime (- ,utime ,run-utime-overhead)) + (setq ,new-run-stime (- ,stime ,run-stime-overhead))))) + (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf) + (mach:vm_statistics *task-self*) + (declare (ignore ps fc ac ic wc zf ra in ot)) + (gr-error 'mach:vm_statistics gr) + (setq ,new-page-faults (- pf ,page-faults-overhead))) + (setq ,new-real-time (- (get-internal-real-time) ,real-time-overhead)) + (setq ,new-bytes-consed (- (get-bytes-consed) ,cons-overhead)) + (format *trace-output* + "~&Evaluation took:~% ~ + ~S second~:P of real time,~% ~ + ~S second~:P of user run time,~% ~ + ~S second~:P of system run time,~% ~ + ~S page fault~:P, and~% ~ + ~S bytes consed.~%" + (max (/ (- ,new-real-time ,old-real-time) + (float internal-time-units-per-second)) + 0.0) + (max (/ (- ,new-run-utime ,old-run-utime) 1000000.0) 0.0) + (max (/ (- ,new-run-stime ,old-run-stime) 1000000.0) 0.0) + (max (- ,new-page-faults ,old-page-faults) 0) + (max (- ,new-bytes-consed ,old-bytes-consed) 0)))))) diff --git a/code/tty-inspect.lisp b/code/tty-inspect.lisp new file mode 100644 index 000000000..ceb7abb23 --- /dev/null +++ b/code/tty-inspect.lisp @@ -0,0 +1,195 @@ +;;; -*- Log: code.log; Package: inspect -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Tty interface for INSPECT. +;;; +;;; Written by Blaine Burks + +(in-package "INSPECT") + +;;; The tty inspector views LISP objects as being composed of parts. A list, +;;; for example, would be divided into it's members, and a structure into its +;;; slots. These parts are stored in a list. The first two elements of this +;;; list are for bookkeeping. The first element is a preamble string that will +;;; be displayed before the object. The second element is a boolean value that +;;; indicates whether a label will be printed in front of a value, or just the +;;; value. Symbols and structures need to display both a slot name and a +;;; value, while lists, vectors, and atoms need only display a value. If the +;;; second member of a parts list is t, then the third and successive members +;;; must be an association list of slot names and values. When the second slot +;;; is nil, the third and successive slots must be the parts of an object. +;;; + +;;; *tty-object-stack* is an assoc list of objects to their parts. +;;; +(defvar *tty-object-stack* ()) + +(proclaim '(inline numbered-parts-p)) +(defun numbered-parts-p (parts) + (second parts)) + +(defconstant parts-offset 2) + +(defun nth-parts (parts n) + (if (numbered-parts-p parts) + (cdr (nth (+ n parts-offset) parts)) + (nth (+ n parts-offset) parts))) + +(defun tty-inspect (object) + (unwind-protect + (input-loop object (describe-parts object) *standard-output*) + (setf *tty-object-stack* nil))) + +;;; When %illegal-object% occurs in a parts list, it indicates that that slot +;;; is unbound. +(defvar %illegal-object% (cons nil nil)) + +(defun input-loop (object parts s) + (tty-display-object parts s) + (loop + (format s "~%> ") + (let ((command (read)) + (parts-len-2 (- (length parts) 2))) + (typecase command + (number + (cond ((< -1 command parts-len-2) + (cond ((eq (nth-parts parts command) %illegal-object%) + (format s "~%That slot is unbound.~%")) + (t + (push (cons object parts) *tty-object-stack*) + (setf object (nth-parts parts command)) + (setf parts (describe-parts object)) + (tty-display-object parts s)))) + (t + (format s "~%Enter a VALID number.~%")))) + (symbol + (case (find-symbol (symbol-name command) (find-package "KEYWORD")) + ((:q :e) + (return object)) + (:u + (cond (*tty-object-stack* + (setf object (caar *tty-object-stack*)) + (setf parts (cdar *tty-object-stack*)) + (pop *tty-object-stack*) + (tty-display-object parts s)) + (t (format s "~%Bottom of Stack.~%")))) + (:r + (setf parts (describe-parts object)) + (tty-display-object parts s)) + (:d + (tty-display-object parts s)) + ((:h :? :help) + (show-help s)) + (t + (format s "~%Invalid command. Type H for help.~%")))))))) + +(defun show-help (s) + (terpri) + (write-line "TTY-Inspector Help:" s) + (write-line " R - recompute current object." s) + (write-line " D - redisplay current object." s) + (write-line " U - Move upward through the object stack." s) + (write-line " Q, E - Quit TTY-INSPECTOR." s) + (write-line " ?, H, Help - Show this help." s)) + +(defun tty-display-object (parts stream) + (format stream "~%~a" (car parts)) + (let ((numbered-parts-p (numbered-parts-p parts)) + (parts (cddr parts))) + (do ((part parts (cdr part)) + (i 0 (1+ i))) + ((endp part) nil) + (if numbered-parts-p + (format stream "~d. ~a: ~a~%" i (caar part) + (if (eq (cdar part) %illegal-object%) + "Unbound" + (cdar part))) + (format stream "~d. ~a~%" i (car part)))))) + + + +;;;; DESCRIBE-PARTS + +(defun describe-parts (object) + (typecase object + (symbol (describe-symbol-parts object)) + (structure (describe-structure-parts object)) + (function (describe-function-parts object)) + (vector (describe-vector-parts object)) + (array (describe-array-parts object)) + (cons (describe-cons-parts object)) + (t (describe-atomic-parts object)))) + +(defun describe-symbol-parts (object) + (list (format nil "~s is a symbol.~%" object) t + (cons "Value" (if (boundp object) + (symbol-value object) + %illegal-object%)) + (cons "Function" (if (fboundp object) + (symbol-function object) + %illegal-object%)) + (cons "Plist" (symbol-plist object)) + (cons "Package" (symbol-package object)))) + +(defun describe-structure-parts (object) + (let ((dd-slots + (c::dd-slots + (ext:info type structure-info + (system:%primitive header-ref object + system:%g-vector-structure-name-slot)))) + (parts-list ())) + (push (format nil "~s is a structure.~%" object) parts-list) + (push t parts-list) + (dolist (dd-slot dd-slots (nreverse parts-list)) + (push (cons (c::dsd-%name dd-slot) + (system:%primitive header-ref object (c::dsd-index dd-slot))) + parts-list)))) + +(defun describe-function-parts (object) + (list (format nil "Function ~s.~%Argument List: ~a." object + (system:%primitive header-ref object + lisp::%function-arg-names-slot) + #|### + (system:%primitive header-ref object + lisp::%function-defined-from-slot) + ~%Defined from: ~a + |# + ) + t)) + +(defun describe-vector-parts (object) + (list* (format nil "Object is a ~:[~;displaced ~]vector of length ~d.~%" + (lisp::%displacedp object) (length object)) + nil + (coerce object 'list))) + +(defun describe-cons-parts (object) + (list* (format nil "Object is a LIST of length ~d.~%" (length object)) + nil + object)) + +(defun describe-array-parts (object) + (let* ((length (min (array-total-size object) inspect-length)) + (reference-array (make-array length :displaced-to object)) + (dimensions (array-dimensions object)) + (parts ())) + (push (format nil "Object is ~:[a displaced~;an~] array of ~a.~%~ + Its dimensions are ~s.~%" + (array-element-type object) (lisp::%displacedp object) + dimensions) + parts) + (push t parts) + (dotimes (i length (nreverse parts)) + (push (cons (format nil "~a " (index-string i (reverse dimensions))) + (aref reference-array i)) + parts)))) + +(defun describe-atomic-parts (object) + (list (format nil "Object is an atom.~%") nil object)) + diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp new file mode 100644 index 000000000..8ca0b2089 --- /dev/null +++ b/tools/worldcom.lisp @@ -0,0 +1,118 @@ +;;; -*- Package: User; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** + +(in-package "USER") + +(with-compiler-log-file ("ncode:compile-lisp.log") + +;;; these guys need to be first. + +(comf "ncode:globals" :always-once t) ; For global variables. +(comf "ncode:struct" :always-once t) ; For structures. + +;;; these guys can supposedly come in any order, but not really. +;;; some are put at the end so macros don't run interpreted and stuff. + +(comf "ncode:lispinit") +(comf "ncode:error") +(comf "ncode:alieneval") +(comf "ncode:stream") +(comf "ncode:arith") +(comf "ncode:array") +(comf "ncode:backq") +(comf "ncode:c-call") +(comf "ncode:char") +(comf "ncode:list") +;(comf "ncode:clx-ext") +(comf "ncode:commandline") +(comf "ncode:eval") +(comf "ncode:debug") +(comf "ncode:trace") +(comf "ncode:extensions") +(comf "ncode:fdefinition") +(comf "ncode:filesys") +(comf "ncode:format") +(comf "ncode:hash") +(comf "ncode:lfloatcon") +(comf "ncode:load") +(comf "ncode:machio") +(comf "ncode:miscop") +(comf "ncode:package") +(comf "ncode:rompstrops") +(comf "ncode:pred") +(comf "ncode:print") +(comf "ncode:provide") +(comf "ncode:query") +(comf "ncode:rand") +(comf "ncode:reader") +(comf "ncode:rompnum") +(comf "ncode:salterror") +(comf "ncode:save") +(comf "ncode:search-list") +(comf "ncode:seq") +(comf "ncode:sharpm") +(comf "ncode:sort") +(comf "ncode:run-program") +(comf "ncode:spirrat") +(comf "ncode:xp") +(comf "ncode:xp-patch") +(comf "ncode:pprint") +(comf "ncode:string") +(comf "ncode:subtypep") +(comf "ncode:symbol") +(comf "ncode:syscall") +(comf "ncode:sysmacs") +(comf "ncode:time") +(comf "ncode:foreign") +(comf "c:proclaim") +(comf "c:knownfun") +(comf "ncode:debug-info") + +;;; Later so that miscellaneous structures are defined (not crucial, but nice.) +(comf "ncode:describe") +;(comf "ncode:inspect") +(comf "ncode:tty-inspect") + +(comf "ncode:purify") +(comf "ncode:gc") +(comf "ncode:misc") +(comf "ncode:format-time") +(comf "ncode:parse-time") + +(comf "ncode:internet") +(comf "ncode:wire") +(comf "ncode:remote") + +(comf "assem:ropdefs") +(comf "assem:rompconst") +(comf "assem:disassemble") + +(comf "ncode:machdef") +(comf "ncode:mmlispdefs") +(comf "nicode:machdefs") +(comf "nicode:netnamedefs") +#-new-compiler ; Leave these out for now... +(load "nicode:machmsgdefs.lisp") +#-new-compiler +(comf "nicode:machuser") +#-new-compiler +(load "nicode:netnamemsgdefs.lisp") +#-new-compiler +(comf "nicode:netnameuser") + +(comf "ncode:defstruct") +(comf "ncode:defmacro") +(comf "ncode:macros") +(comf "ncode:defrecord") +(comf "ncode:constants") + +(comf "c:globaldb") + +); with-compiler-log-file diff --git a/tools/worldload.lisp b/tools/worldload.lisp new file mode 100644 index 000000000..16c5a028f --- /dev/null +++ b/tools/worldload.lisp @@ -0,0 +1,164 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file loads the parts of the system that aren't cold loaded and saves +;;; the resulting core image. It writes "lisp.core" in the DEFAULT-DIRECTORY. +;;; + +;;; Turn of GC so bad things don't happen. +;;; +(setq lisp::*already-maybe-gcing* t) +#| Can't eval conditionals now... +;;; Setup some packages. +;;; +(unless (eq *package* (find-package "USER")) + (error "Set *package* to the User package and try again.")) +|# + +(in-package "CLOS" :nicknames '("PCL")) +(in-package "USER" :use '("LISP" "EXTENSIONS" "CONDITIONS" "DEBUG" "CLOS")) +(in-package "HEMLOCK") +(in-package "LISP") + +;;; Must load this here, instead of before loading this file, otherwise +;;; SEARCH-LIST is unknown. +;;; +(load "/afs/cs/project/clisp/new-compiler/logical-names.lisp") + +;;; Get some data on this core. +;;; +(write-string "What is the current lisp-implementation-version? ") +(set '*lisp-implementation-version* (read-line)) +(write-string "What is the compiler version? ") +(set 'compiler-version (read-line)) +(write-string "What is the Hemlock version? ") +(set '*hemlock-version* (read-line)) + +;;; +;;; Keep us entertained... +(setq *load-verbose* t) + +(export 'ed) + +(load "code:run-program") +(load "code:lfloatcon") +(load "code:spirrat") +(load "code:foreign") +(load "code:format-time") +(load "code:parse-time") +;(load "code:xp-patch") +(load "assem:ropdefs") +(load "assem:rompconst") +(load "assem:disassemble") + + +(load "c:loadcom.lisp") + +(setq lisp::original-lisp-environment NIL) + + +;;; Load the symbol table information for the Lisp start up code. +;;; Used by CLX for the C routine to connect to the X11 server. +;;; +(load-foreign nil) + +#| +;;; CLX. +;;; +(load "clx:defsystem") +(load-clx (pathname "clx:")) + +;;; A hack to fix a bug in the X11 R3 server. This should go away when +;;; the server is fixed. +;;; +(load "/afs/cs/project/clisp/systems-work/font-patch") +|# + +;;; Stick these after LOAD-FORIEGN but before Hemlock. +;;; +(load "code:internet") +(load "code:wire") +(load "code:remote") + +#| +;;; Hemlock. +;;; +(load "hem:rompsite") ;Contains site-init stuff called at load time. +(load "hem:load-hem.lisp") +(hi::build-hemlock) + +;;; Setup definition editing defaults to look in the stable AFS directory. +;;; The first translation says what we want most clearly, but we require +;;; the others due to symbol links. +;;; +(ed::add-definition-dir-translation "/afs/cs/project/clisp/systems-work/" + "/afs/cs/project/clisp/systems/") +(ed::add-definition-dir-translation "/afs/cs/project/clisp-1/systems-work/" + "/afs/cs/project/clisp/systems/") +(ed::add-definition-dir-translation + "/afs/cs.cmu.edu/project/clisp-1/systems-work/" + "/afs/cs/project/clisp/systems/") +(ed::add-definition-dir-translation + "/afs/cs.cmu.edu/project/clisp/systems-work/" + "/afs/cs/project/clisp/systems/") + +;;; For some interim time, translate old compilation directories to the new +;;; working directories. Do it for symbolic links and actual paths. +;;; +(ed::add-definition-dir-translation "/usr/lisp/" + "/afs/cs/project/clisp/systems/") +(ed::add-definition-dir-translation "/usr1/lisp/" + "/afs/cs/project/clisp/systems/") +(ed::add-definition-dir-translation "/usr2/lisp/" + "/afs/cs/project/clisp/systems/") + + +;;; PCL. +;;; +(load "pcl:defsys") +(pcl::load-pcl) + +|# + +;;; Load these after PCL. +;;; +;(load "code:inspect") +(load "code:tty-inspect") + + +;;; There should be no search lists defined in a full core. +;;; +(clrhash lisp::*search-list-table*) + + +;;; Okay, build the thing! +;;; +(in-package "USER") +(progn + (setq + NIL) + (setq * NIL) + (setq ++ NIL) + (setq ** NIL) + (setq +++ NIL) + (setq *** NIL) + (setq lisp::*already-maybe-gcing* t) + (setq *load-verbose* nil) + (setq *info-environment* + (list (make-info-environment :name "Working") + (compact-info-environment (car *info-environment*)))) + (save-lisp (namestring (merge-pathnames "lisp.core" (default-directory))) + :purify t + :root-structures `(ed + #|,hi::*global-command-table*|# + lisp::%top-level + extensions:save-lisp + ,lisp::fop-codes + compile-file) + :init-function #'abort)) -- GitLab