From 66a7c31053ce4093f96db202a7bae5c42d108a24 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Fri, 24 Aug 1990 18:15:10 +0000 Subject: [PATCH] Moved MIPS branch onto trunk; no merge necessary. --- code/alieneval.lisp | 625 ++++++++++++--------- code/array.lisp | 1206 ++++++++++++++++++++++------------------- code/defstruct.lisp | 36 +- code/describe.lisp | 35 +- code/error.lisp | 257 +-------- code/fd-stream.lisp | 342 ++++++------ code/fdefinition.lisp | 2 +- code/filesys.lisp | 18 +- code/format.lisp | 151 ++---- code/gc.lisp | 450 ++++----------- code/lispinit.lisp | 470 +++------------- code/list.lisp | 17 +- code/load.lisp | 365 +++++-------- code/machdef.lisp | 83 +-- code/macros.lisp | 140 +++-- code/misc.lisp | 20 +- code/pred.lisp | 779 ++++++++++---------------- code/print.lisp | 464 ++++++++-------- code/purify.lisp | 18 + code/reader.lisp | 56 +- code/save.lisp | 2 +- code/seq.lisp | 74 +-- code/serve-event.lisp | 21 +- code/stream.lisp | 41 +- code/symbol.lisp | 26 +- code/time.lisp | 36 +- code/tty-inspect.lisp | 50 +- tools/worldcom.lisp | 196 +++---- tools/worldload.lisp | 115 ++-- 29 files changed, 2609 insertions(+), 3486 deletions(-) diff --git a/code/alieneval.lisp b/code/alieneval.lisp index e4837681e..703907440 100644 --- a/code/alieneval.lisp +++ b/code/alieneval.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.3 1990/08/24 18:09:34 wlott Exp $ +;;; ;;; This file contains any the part of the Alien implementation that ;;; is not part of the compiler. ;;; @@ -35,12 +37,14 @@ ;;; The number of bits corresponding to a change of 1 in the value of a SAP. ;;; -(defconstant alien-address-unit 8) +(defconstant alien-address-unit vm:byte-bits) +(defconstant alien-address-shift (1- (integer-length alien-address-unit))) ;;; The address pointed to by the SAP in an alien is always a multiple of this ;;; number of bits. ;;; -(defconstant alien-alignment 16) +(defconstant alien-alignment vm:word-bits) + (defvar *alien-eval-when* '(compile load eval) "This is a list of the times to eval Alien compiler info.") @@ -48,10 +52,11 @@ (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)))) + (format + stream + "#<Alien value, Address = #x~X~:[+~D/~D~;~2*~], Size = ~D, Type = ~S>" + (sap-int (alien-value-sap s)) (zerop offset) offset alien-address-unit + (alien-value-size s) (alien-value-type s)))) (defun %print-alien-info (s stream d) (declare (ignore s d)) @@ -61,34 +66,128 @@ ;;;; Interpreter stubs for SAP functions: #+new-compiler (progn + +(defun pointer< (x y) + "Return T iff the SAP X points to a smaller address then the SAP Y." + (declare (type system-area-pointer x y)) + (pointer< x y)) + +(defun pointer> (x y) + "Return T iff the SAP X points to a larger address then the SAP Y." + (declare (type system-area-pointer x y)) + (pointer> x y)) + +(defun sap+ (sap offset) + "Return a new sap OFFSET bytes from SAP." + (declare (type system-area-pointer sap) + (fixnum offset)) + (sap+ sap offset)) + +(defun sap- (sap1 sap2) + "Return the byte offset between SAP1 and SAP2." + (declare (type system-area-pointer sap1 sap2)) + (sap- sap1 sap2)) + (defun sap-int (sap) "Converts a System Area Pointer into an integer." + (declare (type system-area-pointer sap)) (sap-int sap)) (defun int-sap (int) "Converts an integer into a System Area Pointer." + (declare (type (unsigned-byte #.vm:word-bits) int)) (int-sap int)) (defun sap-ref-8 (sap offset) - "Returns the 8-bit byte at Offset bytes from SAP." + "Returns the 8-bit byte at OFFSET bytes from SAP." + (declare (type system-area-pointer sap) + (type index offset)) (sap-ref-8 sap offset)) (defun sap-ref-16 (sap offset) - "Returns the 16-bit word at Offset words from SAP." + "Returns the 16-bit word at OFFSET half-words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) (sap-ref-16 sap offset)) (defun sap-ref-32 (sap offset) - "Returns the 32-bit dualword at Offset words from SAP." + "Returns the 32-bit dualword at OFFSET words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) (sap-ref-32 sap offset)) -(defun (setf sap-ref-8) (sap offset new-value) +(defun sap-ref-sap (sap offset) + "Returns the 32-bit system-area-pointer at OFFSET words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (sap-ref-sap sap offset)) + +(defun sap-ref-single (sap offset) + "Returns the 32-bit single-float at OFFSET words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (sap-ref-single sap offset)) + +(defun sap-ref-double (sap offset) + "Returns the 64-bit double-float at OFFSET words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (sap-ref-double sap offset)) + +(defun signed-sap-ref-8 (sap offset) + "Returns the signed 8-bit byte at Offset bytes from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (signed-sap-ref-8 sap offset)) + +(defun signed-sap-ref-16 (sap offset) + "Returns the signed 16-bit word at Offset words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (signed-sap-ref-16 sap offset)) + +(defun signed-sap-ref-32 (sap offset) + "Returns the signed 32-bit dualword at Offset words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (signed-sap-ref-32 sap offset)) + +(defun %set-sap-ref-8 (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type (or (signed-byte 8) (unsigned-byte 8)) new-value)) (setf (sap-ref-8 sap offset) new-value)) -(defun (setf sap-ref-16) (sap offset new-value) +(defun %set-sap-ref-16 (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type (or (signed-byte 16) (unsigned-byte 16)) 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)) +(defun %set-sap-ref-32 (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type (or (signed-byte 32) (unsigned-byte 32)) new-value)) + (if (minusp new-value) + (truly-the (signed-byte 32) (setf (sap-ref-32 sap offset) new-value)) + (truly-the (unsigned-byte 32) (setf (sap-ref-32 sap offset) new-value)))) + +(defun %set-sap-ref-sap (sap offset new-value) + (declare (type system-area-pointer sap new-value) + (type index offset)) + (setf (sap-ref-sap sap offset) new-value)) + +(defun %set-sap-ref-single (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type single-float new-value)) + (setf (sap-ref-single sap offset) new-value)) + +(defun %set-sap-ref-double (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type double-float new-value)) + (setf (sap-ref-double sap offset) new-value)) ); #+New-Compiler @@ -112,17 +211,19 @@ (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)) + (unless (zerop (logand size (1- alien-address-unit))) (error "Size of assigned Alien is not a byte multiple:~%~S" from-alien)) - (unless (zerop (logand src-off 7)) + (unless (zerop (logand src-off (1- alien-address-unit))) (error "Alien is not byte aligned:~%~S" from-alien)) - (unless (zerop (logand dst-off 7)) + (unless (zerop (logand dst-off (1- alien-address-unit))) (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) + (let ((dst-start (ash dst-off (- alien-address-shift)))) + (%primitive byte-blt + (alien-value-sap from-alien) + (ash src-off (- alien-address-shift)) (alien-value-sap to-alien) dst-start - (+ dst-start (ash size -3)))) + (+ dst-start (ash size (- alien-address-shift))))) to-alien)) @@ -144,7 +245,7 @@ (defun alien-address (alien) "Return the address of the data for Alien." (check-type alien alien-value) - (+ (%primitive sap-int (alien-value-sap alien)) + (+ (sap-int (alien-value-sap alien)) (/ (alien-value-offset alien) alien-address-unit))) (defun alien-sap (alien) @@ -190,22 +291,11 @@ (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)))))) + The aliens have the specifed Type and Size, and are allocated on the + number stack." + `(eval-when ,*alien-eval-when* + (setf (info alien-stack info ',name) + (make-stack-info :type ',type :size ,size)))) ;;; Defoperator -- Public @@ -241,22 +331,19 @@ ;;;; 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) +#+new-compiler +(defparameter system-space-start (int-sap #x80000000) "The address of the first statically allocated alien.") -(defparameter alien-allocation-end - (%primitive make-immediate-type #x40000 %static-alien-area) +#+new-compiler +(defparameter alien-allocation-end (int-sap #x8fffffff) "The end of statically allocated aliens.") +#+new-compiler (defvar *current-alien-free-pointer* system-space-start "The next word in system space for static alien allocation.") @@ -265,26 +352,60 @@ ;;; Allocate enough storage to hold the specified number of bits ;;; and return the address. ;;; +#+new-compiler (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) + (bytes (logand (ash (the fixnum (+ bits alien-alignment -1)) + (- alien-address-shift)) + (lognot (1- (truncate alien-alignment + alien-address-unit))))) + (new (sap+ *current-alien-free-pointer* bytes))) + (when (#-new-compiler %primitive pointer> new alien-allocation-end) (error "Not enough room to allocate a ~D bit alien." bits)) (setq *current-alien-free-pointer* new) alien)) -;;; DO-VALIDATE -- Internal Interface. -;;; -;;; Do a ValidateMemory on our kernel port and flame out if error. -;;; -;;; Hemlock and other code files use this, even though it is not exported from -;;; a more appropriate package. -;;; -(defun do-validate (addr bytes mask) - (gr-call* mach::vm_allocate *task-self* addr bytes (if (eq mask -1) t NIL))) +;;; ALLOCATE-SYSTEM-MEMORY -- public +;;; +;;; Allocate random memory from the system area. +;;; +(defun allocate-system-memory (bytes) + (declare (type index bytes)) + (gr-call* mach:vm_allocate *task-self* (int-sap 0) bytes t)) + +;;; REALLOCATE-SYSTEM-MEMORY -- public +;;; +;;; Either allocate more memory at the end of this block, or allocate a new +;;; block and move the old memory into it. +;;; +(defun reallocate-system-memory (old old-size new-size) + (declare (type system-area-pointer old) + (type index old-size new-size)) + ;; ### Got to work the page size into this somehow. The vm_allocate + ;; will fail much more often than it otherwise would 'cause if the old + ;; block stops in the middle of a page, we can't extend it. + (if (eql (mach:vm_allocate *task-self* + (sap+ old old-size) + (- new-size old-size) + nil) + mach:kern-success) + old + (let ((new (allocate-system-memory new-size))) + (declare (type system-area-pointer new)) + (system-area-copy old 0 new 0 (* old-size vm:byte-bits)) + (deallocate-system-memory old old-size) + new))) + +;;; DEALLOCATE-SYSTEM-MEMORY -- public +;;; +;;; Deallocate that memory. +;;; +(defun deallocate-system-memory (addr bytes) + (declare (type system-area-pointer addr) + (type index bytes)) + (gr-call* mach:vm_deallocate *task-self* addr bytes)) ;;; Make-Alien -- Public @@ -299,20 +420,19 @@ supplied then memory is allocated to contain the data." (case address (:dynamic - (setq address (do-validate 0 (ash size -3) -1))) + (setq address (allocate-system-memory (ash size (- alien-address-shift))))) (: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 address (or #+new-compiler system-area-pointer + (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 (int-sap base) offset size type))) (make-alien-value address 0 size type))) @@ -329,9 +449,11 @@ (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) + (bytes (ash (+ length offset alien-alignment -1) + (- alien-address-shift))) + (new (allocate-system-memory bytes))) + (%primitive byte-blt + (alien-value-sap alien) (ash offset (- alien-address-shift)) new 0 bytes) (make-alien-value new offset length (alien-value-type alien)))) @@ -341,14 +463,16 @@ ;;; Invalidate the memory pointed to by unless it is a statically ;;; allocated alien. ;;; +#+new-compiler (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))) + (unless (not (or (pointer< address system-space-start) + (pointer> address alien-allocation-end))) (gr-call mach:vm_deallocate *task-self* address - (logand #x-200 (ash (+ (alien-value-size alien) #xFFF) -3)))))) + (logand #x-200 (ash (+ (alien-value-size alien) #xFFF) + (- alien-address-shift))))))) ;;;; Operator definition primitives: @@ -368,9 +492,11 @@ (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) + (truncate (+ offset (alien-value-offset alien)) + alien-alignment) (make-alien-value - (%primitive int-sap (+ words (%primitive sap-int (alien-value-sap alien)))) + (int-sap (+ (* words (/ alien-alignment alien-address-unit)) + (sap-int (alien-value-sap alien)))) bits size nil))) @@ -391,14 +517,13 @@ (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)))) + (value (sap-ref-sap sap 0))) #| (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))) + (make-alien-value value 0 size nil))) ;;; Bits, Bytes, Words, Long-Words -- Public @@ -426,11 +551,11 @@ ;;; (defun %alien-indirect (size sap offset exp) (unless (eql size 32) - (error "Argument to Alien-Indirect is ~D bits, 32:~% ~S." size exp)) + (error "Argument to Alien-Indirect is ~D bits, not 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))) + (sap-ref-sap sap (ash offset -5))) ;;; %Aligned-SAP -- Internal @@ -439,49 +564,69 @@ ;;; aligned. In this case, we absorb the offset into the SAP, and make the ;;; bound offset 0. ;;; +#+new-compiler (defun %aligned-sap (sap offset form) - (unless (zerop (logand offset #xF)) + (unless (zerop (logand offset #x1F)) (error "Offset ~S was declared to be word aligned, but isn't:~% ~S" offset form)) - (%primitive sap+ sap (ash offset -3))) + (sap+ sap (ash offset (- alien-address-unit)))) #+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. +;;; Read a possibly signed integer somewhere. ;;; (defun naturalize-integer (signed sap offset size form) - (multiple-value-bind (q r) (truncate offset 16) + (declare (type boolean signed) + (type system-area-pointer sap) + (type index offset size)) + (let ((bit-offset (logand offset #x1f))) (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)) + ((and (= size 32) (zerop bit-offset)) + (if signed + (signed-sap-ref-32 sap (ash offset -5)) + (sap-ref-32 sap (ash offset -5)))) + ((and (= size 16) (zerop (logand offset #xf))) + (if signed + (signed-sap-ref-16 sap (ash offset -4)) + (sap-ref-16 sap (ash offset -4)))) + ((and (= size 8) (zerop (logand offset #x7))) (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))))))) + (signed-sap-ref-8 sap (ash offset -3)) + (sap-ref-8 sap (ash offset -3)))) + ((> size 32) + (error "Access of ~D bit integers is not supported:~% ~S" size form)) + ((zerop bit-offset) + (let ((value (ldb (byte size 0) (sap-ref-32 sap (ash offset -5))))) + (if (and signed (logbitp value (1- size))) + (logior value (ash -1 size)) + value))) + ((<= (+ size bit-offset) 32) + (let ((value (ldb (byte size bit-offset) + (sap-ref-32 sap (ash offset -5))))) + (if (and signed (logbitp value (1- size))) + (logior value (ash -1 size)) + value))) + (t + (macrolet ((low-byte () + (ecase vm:target-byte-order + (:little-endian 'offset) + (:bit-endian '(1+ offset)))) + (high-byte () + (ecase vm:target-byte-order + (:little-endian '(1+ offset)) + (:bit-endian 'offset)))) + (let* ((high-bits (- 32 bit-offset)) + (low-bits (- size high-bits)) + (value (logior (ash (ldb (byte high-bits 0) + (sap-ref-32 sap (high-byte))) + low-bits) + (ash (sap-ref-32 sap (low-byte)) + (- (- 32 low-bits)))))) + (if (and signed (logbitp value (1- size))) + (logior value (ash -1 size)) + value))))))) + #+new-compiler ;;; Deport-Integer -- Internal @@ -489,46 +634,44 @@ ;;; Like Naturalize-Integer, but writes an integer. ;;; (defun deport-integer (signed sap offset size value form) + (declare (type boolean signed) + (type system-area-pointer sap) + (type index offset size) + (type integer value)) (declare (ignore signed)) - (multiple-value-bind (q r) (truncate offset 16) + (multiple-value-bind (q r) (truncate offset 32) (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))))))) + ((and (= size 32) (zerop r)) + (setf (sap-ref-32 sap q) value)) + ((and (= size 16) (zerop (logand r #xf))) + (setf (sap-ref-16 sap (ash offset -4)) value)) + ((and (= size 8) (zerop (logand r #x7))) + (setf (sap-ref-8 sap (ash offset -3)) value)) + ((> size 32) + (error "Storing of ~D bit integers is not supported:~% ~S" + size form)) + ((zerop r) + (setf (ldb (byte size 0) (sap-ref-32 sap q)) value)) + ((<= (+ r size) 32) + (setf (ldb (byte size r) (sap-ref-32 sap q)) value)) + (t + (macrolet ((low-byte () + (ecase vm:target-byte-order + (:little-endian 'offset) + (:bit-endian '(1+ offset)))) + (high-byte () + (ecase vm:target-byte-order + (:little-endian '(1+ offset)) + (:bit-endian 'offset)))) + (let* ((high-bits (- 32 r)) + (low-bits (- size high-bits))) + (setf (ldb (byte high-bits 0) + (sap-ref-32 sap (high-byte))) + (ash value (- low-bits))) + (setf (ldb (byte low-bits (- 32 low-bits)) + (sap-ref-32 sap (low-byte))) + value)))))) nil) @@ -539,11 +682,16 @@ ;;; #+new-compiler (defun naturalize-boolean (sap offset size form) + (declare (type system-area-pointer sap) + (type index offset size)) (declare (notinline naturalize-integer)) (not (zerop (naturalize-integer nil sap offset size form)))) ;;; #+new-compiler (defun deport-boolean (sap offset size value form) + (declare (type system-area-pointer sap) + (type index offset size) + (type boolean value)) (declare (notinline deport-integer)) (deport-integer nil sap offset size (if value 1 0) form) nil) @@ -735,7 +883,7 @@ 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). + :unit -- A integer (default 32). 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. @@ -750,31 +898,36 @@ (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))))) + `(progn + (%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 (member (mostcar ,alien-var) '(,atype ,@more-types) + :test #'eq) + (error "Wrong Alien type ~S, should have been ~S~ + ~{~#[~; or~:;,~] ~S~}." + ,alien-var ',atype ',more-types)) + + (macrolet ((with-alien ((sap) + (offset &key + ((:unit ounit) 32)) + (size &key + ((:constant sconst) nil) + ((:minimum smin) nil) + ((:unit sunit) 32)) + &body (body decls)) + (%with-alien sap offset ounit + size sconst smin sunit + ',n-sap ',n-offset ',n-size + body decls))) + ,@body))) + #-new-compiler + (eval-when (compile) + (clc::clc-mumble "alien-access ~S compiled.~%" ',lisp-type))))) (eval-when (compile load eval) @@ -960,59 +1113,32 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. `(naturalize-boolean ,sap ,offset ,size ',form) `(deport-boolean ,sap ,offset ,size ,value ',form)))) - -;;; Alien-Access expert for short-floats +;;; Alien-Access expert for single-floats ;;; -(define-alien-access (short-float) (type kind value) +(define-alien-access (single-float) (type kind value) (with-alien (sap) (offset) - (size :constant 2) + (size :constant 1) (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)))))) + `(sap-ref-single ,sap ,offset) + `(setf (sap-ref-single ,sap ,offset) ,value)))) - -;;; Alien-Access expert for long-floats +;;; Alien-Access expert for double-floats ;;; -(define-alien-access (long-float) (type kind value) +(define-alien-access (double-float) (type kind value) (with-alien (sap) (offset) - (size :constant 4) + (size :unit 64 :constant 1) (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))))))) + `(sap-ref-double ,sap ,offset) + `(setf (sap-ref-double ,sap ,offset) ,value)))) ;;; Alien-access expert for procedure objects. These should be used ;;; with caution. ;;; +#+nil ; ### This will need work. (define-alien-access (c-procedure) (type kind value) (with-alien (sap) (offset) @@ -1039,7 +1165,7 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. (if (eq kind :read) (let ((size (gensym)) (str (gensym))) - `(let* ((,size (%primitive 8bit-system-ref ,n-sap ,n-offset)) + `(let* ((,size (sap-ref-8 ,n-sap ,n-offset)) (,str (make-string ,size))) (%primitive byte-blt ,n-sap (1+ ,n-offset) ,str 0 ,size) ,str)) @@ -1049,7 +1175,7 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. ,n-value))) (,1+off (1+ ,n-offset))) (check<= ,len ,(cadr type)) - (%primitive 8bit-system-set ,n-sap ,n-offset ,len) + (setf (sap-ref-8 ,n-sap ,n-offset) ,len) (%primitive byte-blt ,n-value 0 ,n-sap ,1+off (+ ,1+off ,len))))))) @@ -1067,26 +1193,30 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. (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)) + (str (gensym)) + (ptr (gensym)) + (start (gensym))) + `(do* ((,start (sap+ ,n-sap ,n-offset)) + (,ptr ,start (sap+ ,ptr 1))) + ((zerop (sap-ref-8 ,ptr 0)) + (let* ((,size (sap- ,ptr ,start)) + (,str (make-string ,size))) + (declare (fixnum ,size) + (type simple-base-string ,str)) + (copy-from-system-area ,start 0 + ,str (* vm:vector-data-offset + vm:word-bits) + (* ,size vm:byte-bits)) + ,str)) + (declare (type system-area-pointer ,start ,ptr)))) + (let ((len (gensym))) + `(let ((,len (the fixnum (1+ (length (the simple-string + ,n-value)))))) + (declare (fixnum ,len)) (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)))))) + (copy-to-system-area ,n-value (* vm:vector-data-offset + vm:word-bits) + ,n-sap ,n-offset ,len)))))) ;;;; Pointer alien access: @@ -1100,11 +1230,11 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. (type kind value) (with-alien (sap) (offset) - (size :constant 2) + (size :constant 1) (declare (ignore size)) (if (eq kind :read) - `(%primitive sap-system-ref ,sap ,offset) - `(%primitive pointer-system-set ,sap ,offset ,value)))) + `(sap-ref-sap ,sap ,offset) + `(setf (sap-ref-sap ,sap ,offset) ,value)))) ;;; Alien-Access expert for (Alien <type> [<bits>]) -- Internal ;;; @@ -1114,7 +1244,7 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. (define-alien-access (alien) (type kind value) (with-alien (sap) (offset) - (size :constant 2) + (size :constant 1) (declare (ignore size)) (unless (and (consp type) (consp (cdr type))) (error "Bad type for accessing as an Alien: ~S" type)) @@ -1127,13 +1257,13 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. (unless (and (integerp size) (>= size 0)) (error "Size is not a positive integer: ~S" type)) `(make-alien-value - (%primitive sap-system-ref ,sap ,offset) + (sap-ref-sap ,sap ,offset) 0 ,size ',atype)) (t - `(%primitive pointer-system-set ,sap ,offset - (alien-value-sap ,value))))))) + `(setf (sap-ref-sap ,sap ,offset) + (alien-value-sap ,value))))))) ;;; Alien-Access expert for (Pointer xxx) -- Internal ;;; @@ -1143,11 +1273,22 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. (define-alien-access (pointer pointer alien) (type kind value) (with-alien (sap) (offset) - (size :constant 2) + (size :constant 1) (declare (ignore size)) - (when (eq kind :read) - (error "Cannot read with Pointer Alien type:~%~S" type)) - `(%primitive pointer-system-set ,sap ,offset ,value))) + (if (eq kind :read) + `(error "Cannot reference pointer aliens") + (let ((n-value (gensym))) + `(setf (sap-ref-sap ,sap ,offset) + (let ((,n-value ,value)) + ,@(when (and (consp type) (consp (cdr type))) + `((declare (type ,(cadr type) ,n-value)))) + (etypecase ,n-value + (null (int-sap 0)) + (system-area-pointer ,n-value) + ((or simple-string + simple-bit-vector + (simple-array unsigned-byte (*))) + (%primitive c::vector-sap ,n-value))))))))) ;;;; Enumeration Alien access: @@ -1189,7 +1330,7 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. (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)) + (when (assoc sym (cdr el) :test #'eq) (error "Enumeration element ~S used more than once." sym)))) (let* ((signed (minusp min)) (to (intern (concatenate 'simple-string (string name) @@ -1244,7 +1385,7 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. (mapcar #'car alist)) (write-string "New value: " *query-io*) (let* ((response (read *query-io*)) - (res (cdr (assq response alist)))) + (res (cdr (assoc response alist :test #'eq)))) (when res (return res))))) @@ -1272,7 +1413,7 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. ,to)))) `(deport-integer ,signed ,sap ,offset ,size - (or (cdr (assq ,value ,from)) + (or (cdr (assoc ,value ,from :test #'eq)) (enumeration-error ,from)) ',form))))) diff --git a/code/array.lisp b/code/array.lisp index 77cbf80e1..5f1a04b7e 100644 --- a/code/array.lisp +++ b/code/array.lisp @@ -7,8 +7,11 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; Functions to implement arrays for Spice Lisp +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.3 1990/08/24 18:10:14 wlott Exp $ +;;; +;;; Functions to implement arrays for CMU Common Lisp. ;;; Written by Skef Wholey. +;;; Worked over for the MIPS port by William Lott. ;;; (in-package "LISP") @@ -21,6 +24,7 @@ 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.") @@ -31,23 +35,75 @@ "The exclusive upper bound on the total number of elements in an array.") + +;;;; Random accessor functions. + +;;; These functions are needed by the interpreter, 'cause the compiler inlines +;;; them. + +(macrolet ((frob (name) + `(progn + (defun ,name (array) + (,name array)) + (defun (setf ,name) (value array) + (setf (,name array) value))))) + (frob %array-fill-pointer) + (frob %array-fill-pointer-p) + (frob %array-available-elements) + (frob %array-data-vector) + (frob %array-displacement) + (frob %array-displaced-p)) + +(defun %array-dimension (array axis) + (%array-dimension array axis)) + +(defun %set-array-dimension (array axis value) + (%set-array-dimension array axis value)) + +(defun %check-bound (array bound index) + (declare (type index bound) + (fixnum index)) + (%check-bound array bound index)) + ;;; Random function used by WITH-ARRAY-DATA, which has to be defined in -;;; init.lisp. +;;; sysmacs.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)))) - + (let ((cumulative-offset 0)) + (declare (fixnum cumulative-offset)) + (do ((data array (%array-data-vector array))) + ((not (array-header-p data)) + (values data cumulative-offset)) + (when (%array-displaced-p array) + (incf cumulative-offset (%array-displacement array)))))) + +;;;; MAKE-ARRAY + +(defmacro pick-type (type &rest specs) + `(cond ,@(mapcar #'(lambda (spec) + `((subtypep ,type ',(car spec)) + ,@(cdr spec))) + specs))) + +(defun %vector-type-code (type) + (pick-type type + (base-character (values #.vm:simple-string-type #.vm:byte-bits)) + (bit (values #.vm:simple-bit-vector-type 1)) + ((unsigned-byte 2) (values #.vm:simple-array-unsigned-byte-2-type 2)) + ((unsigned-byte 4) (values #.vm:simple-array-unsigned-byte-4-type 4)) + ((unsigned-byte 8) (values #.vm:simple-array-unsigned-byte-8-type 8)) + ((unsigned-byte 16) (values #.vm:simple-array-unsigned-byte-16-type 16)) + ((unsigned-byte 32) (values #.vm:simple-array-unsigned-byte-32-type 32)) + (single-float (values #.vm:simple-array-single-float-type 32)) + (double-float (values #.vm:simple-array-double-float-type 64)) + (t (values #.vm:simple-vector-type #.vm:word-bits)))) + +(defun %complex-vector-type-code (type) + (pick-type type + (base-character #.vm:complex-string-type) + (bit #.vm:complex-bit-vector-type) + (t #.vm:complex-vector-type))) (defun make-array (dimensions &key (element-type t) @@ -56,75 +112,106 @@ 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)))) + (let ((array-rank (length (the list dimensions))) + (simple (and (null fill-pointer) + (not adjustable) + (null displaced-to)))) (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)) - + (when (and displaced-index-offset (null displaced-to)) + (error "Can't specify :displaced-index-offset without :displaced-to")) + (if (and simple (= array-rank 1)) + ;; Its a (simple-array * (*)) + (multiple-value-bind (type bits) + (%vector-type-code element-type) + (declare (type (unsigned-byte 8) type) + (type (integer 1 64) bits)) + (let* ((length (car dimensions)) + (array (%primitive + allocate-vector + type + length + (the index + (ceiling (* (if (= type + vm:simple-string-type) + (1+ length) + length) + bits) + vm:word-bits))))) + (declare (type index length)) + (when initial-element-p + (fill array initial-element)) + (when initial-contents + (when initial-element + (error "Cannot specify both :initial-element and ~ + :initial-contents")) + (unless (= length (length initial-contents)) + (error "~D elements in the initial-contents, but the ~ + vector length is ~D." + (length initial-contents) + length)) + (replace array initial-contents)) + array)) + ;; It's either a complex array or a multidemsional array. + (let* ((total-size (reduce #'* dimensions)) + (data (or displaced-to + (data-vector-from-inits + dimensions total-size element-type + initial-contents initial-element initial-element-p))) + (array (%primitive + make-array-header + (cond ((= array-rank 1) + (%complex-vector-type-code element-type)) + (simple vm:simple-array-type) + (t vm:complex-array-type)) + array-rank))) + (cond (fill-pointer + (unless (= array-rank 1) + (error "Only vectors can have fill pointers.")) + (setf (%array-fill-pointer array) + (if (eq fill-pointer t) + (car dimensions) + fill-pointer)) + (setf (%array-fill-pointer-p array) t)) + (t + (setf (%array-fill-pointer array) total-size) + (setf (%array-fill-pointer-p array) nil))) + (setf (%array-available-elements array) total-size) + (setf (%array-data-vector array) data) + (cond (displaced-to + (when (or initial-element-p initial-contents) + (error "Neither :initial-element nor :initial-contents ~ + can be specified along with :displaced-to")) + (unless displaced-index-offset + (setf displaced-index-offset 0)) + (when (> (+ displaced-index-offset total-size) + (array-total-size displaced-to)) + (error "~S doesn't have enough elements." displaced-to)) + (setf (%array-displacement array) displaced-index-offset) + (setf (%array-displaced-p array) t)) + (t + (setf (%array-displaced-p array) nil))) + (let ((axis 0)) + (dolist (dim dimensions) + (setf (%array-dimension array axis) dim) + (incf axis))) + array)))) + ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array -;;; characteristics. Dimensions is only used to pass to COPY-CONTENTS-AUX +;;; characteristics. Dimensions is only used to pass to FILL-DATA-VECTOR ;;; for error checking on the structure of initial-contents. ;;; -(defun data-vector-from-inits (dimensions total-size rank element-type +(defun data-vector-from-inits (dimensions total-size 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))))) + (when (and initial-contents initial-element-p) + (error "Cannot supply both :initial-contents and :initial-element to + either make-array or adjust-array.")) + (let ((data (if initial-element-p + (make-array total-size + :element-type element-type + :initial-element initial-element) + (make-array total-size + :element-type element-type)))) (cond (initial-element-p (unless (simple-vector-p data) (unless (typep initial-element element-type) @@ -132,329 +219,313 @@ initial-element element-type)) (fill (the vector data) initial-element))) (initial-contents - (copy-contents-aux dimensions initial-contents element-type - rank 0 data))) + (fill-data-vector data dimensions initial-contents))) 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 fill-data-vector (vector dimensions initial-contents) + (let ((index 0)) + (labels ((frob (axis dims contents) + (cond ((null dims) + (setf (aref vector index) contents) + (incf index)) + (t + (unless (= (length contents) (car dims)) + (error "Malformed :initial-contents. Dimension of ~ + axis ~D is ~D, but ~S is ~D long." + axis (car dims) contents (length contents))) + (unless (listp contents) + (error "Malformed :initial-contents. ~S is an atom, ~ + but ~D more layer~:P needed." + contents + (- (length dimensions) axis))) + (dolist (content contents) + (frob (1+ axis) (cdr dims) content)))))) + (frob 0 dimensions initial-contents)))) + + +;;; Some people out there are still calling MAKE-VECTOR: ;;; -(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)))))) +(setf (symbol-function 'make-vector) #'make-array) -(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)) +(defun vector (&rest objects) + "Constructs a simple-vector from the given objects." + (coerce (the list objects) 'simple-vector)) + + + +;;;; Accessor/Setter functions. + +(defun data-vector-ref (array index) + (with-array-data ((vector array) (index index) (end)) + (declare (ignore end)) + (macrolet ((dispatch (&rest stuff) + `(etypecase vector + ,@(mapcar #'(lambda (type) + `(,type + (data-vector-ref (the ,type vector) + index))) + stuff)))) + (dispatch + simple-vector + simple-bit-vector + simple-string + (simple-array (unsigned-byte 2) (*)) + (simple-array (unsigned-byte 4) (*)) + (simple-array (unsigned-byte 8) (*)) + (simple-array (unsigned-byte 16) (*)) + (simple-array (unsigned-byte 32) (*)) + (simple-array single-float (*)) + (simple-array double-float (*)))))) + +(defun data-vector-set (array index new-value) + (with-array-data ((vector array) (index index) (end)) + (declare (ignore end)) + (macrolet ((dispatch (&rest stuff) + `(etypecase vector + ,@(mapcar #'(lambda (type) + `(,type + (data-vector-set (the ,type vector) + index + new-value))) + stuff)))) + (dispatch + simple-vector + simple-bit-vector + simple-string + (simple-array (unsigned-byte 2) (*)) + (simple-array (unsigned-byte 4) (*)) + (simple-array (unsigned-byte 8) (*)) + (simple-array (unsigned-byte 16) (*)) + (simple-array (unsigned-byte 32) (*)) + (simple-array single-float (*)) + (simple-array double-float (*)))))) + + + +(defun %array-row-major-index (array subscripts + &optional (invalid-index-error-p t)) + (declare (array array) + (list subscripts)) + (let ((rank (array-rank array))) + (unless (= rank (length subscripts)) + (error "Wrong number of subscripts, ~D, for array of rank ~D" + (length subscripts) rank)) + (if (array-header-p array) + (do ((subs (nreverse subscripts) (cdr subs)) + (axis (1- (array-rank array)) (1- axis)) (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))))))))) + ((null subs) result) + (declare (list subs) (fixnum axis chunk-size result)) + (let ((index (car subs)) + (dim (%array-dimension array axis))) + (declare (fixnum index dim)) + (unless (< -1 index dim) + (if invalid-index-error-p + (error "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S" + index axis array) + (return-from %array-row-major-index nil))) + (incf result (* chunk-size index)) + (setf chunk-size (* chunk-size dim)))) + (let ((index (first subscripts))) + (unless (< -1 index (length (the (simple-array * (*)) array))) + (if invalid-index-error-p + (error "Invalid index ~D in ~S" index array) + (return-from %array-row-major-index nil))) + index)))) + +(defun array-in-bounds-p (array &rest subscripts) + "Returns T if the Subscipts are in bounds for the Array, Nil otherwise." + (if (%array-row-major-index array subscripts nil) + t)) + +(defun array-row-major-index (array &rest subscripts) + (%array-row-major-index array subscripts)) + +(defun aref (array &rest subscripts) + "Returns the element of the Array specified by the Subscripts." + (row-major-aref array (%array-row-major-index array subscripts))) +(defun %aset (array &rest stuff) + (let ((subscripts (butlast stuff)) + (new-value (car (last stuff)))) + (setf (row-major-aref array (%array-row-major-index array subscripts)) + new-value))) ;;; %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 %apply-aset (new-value array &rest subscripts) + (setf (row-major-aref array (%array-row-major-index array subscripts)) + new-value)) + + +(defun row-major-aref (array index) + "Returns the element of array corressponding to the row-major index. This is + SETF'able." + (row-major-aref array index)) + +(defun %set-row-major-aref (array index new-value) + (setf (row-major-aref array index) new-value)) + + + +(defun svref (simple-vector index) + "Returns the Index'th element of the given Simple-Vector." + (declare (simple-vector simple-vector) (fixnum index)) + (aref simple-vector index)) + +(defun %svset (simple-vector index new) + (declare (simple-vector simple-vector) (fixnum index)) + (setf (aref simple-vector index) new)) + +;;; The following function is used when (setf (apply #'svref ...) new +;;; is compiled. + +(defun %apply-svset (new simple-vector index) + (declare (simple-vector simple-vector) (fixnum index)) + (setf (aref simple-vector index) new)) + + +(defun bit (bit-array &rest subscripts) + "Returns the bit from the Bit-Array at the specified Subscripts." + (declare (type (array bit) bit-array)) + (row-major-aref bit-array (%array-row-major-index bit-array subscripts))) + + +(defun %bitset (bit-array &rest stuff) + (declare (type (array bit) bit-array)) + (let ((subscripts (butlast stuff)) + (new-value (car (last stuff)))) + (setf (row-major-aref bit-array + (%array-row-major-index bit-array subscripts)) + new-value))) + +(defun sbit (simple-bit-array &rest subscripts) + "Returns the bit from the Simple-Bit-Array at the specified Subscripts." + (declare (type (simple-array bit) simple-bit-array)) + (row-major-aref simple-bit-array + (%array-row-major-index simple-bit-array subscripts))) + + +(defun %sbitset (simple-bit-array &rest stuff) + (declare (type (simple-array bit) simple-bit-array)) + (let ((subscripts (butlast stuff)) + (new-value (car (last stuff)))) + (setf (row-major-aref simple-bit-array + (%array-row-major-index simple-bit-array subscripts)) + new-value))) + + + + + +;;;; Random array properties. (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)))) + (let ((type (get-type array))) + (macrolet ((pick-element-type (&rest stuff) + `(cond ,@(mapcar #'(lambda (stuff) + (cons + (let ((item (car stuff))) + (cond ((eq item t) + t) + ((listp item) + (cons 'or + (mapcar #'(lambda (x) + `(= type ,x)) + item))) + (t + `(= type ,item)))) + (cdr stuff))) + stuff)))) + (pick-element-type + ((vm:simple-string-type vm:complex-string-type) 'base-character) + ((vm:simple-bit-vector-type vm:complex-bit-vector-type) 'bit) + (vm:simple-vector-type t) + (vm:simple-array-unsigned-byte-2-type '(unsigned-byte 2)) + (vm:simple-array-unsigned-byte-4-type '(unsigned-byte 4)) + (vm:simple-array-unsigned-byte-8-type '(unsigned-byte 8)) + (vm:simple-array-unsigned-byte-16-type '(unsigned-byte 16)) + (vm:simple-array-unsigned-byte-32-type '(unsigned-byte 32)) + (vm:simple-array-single-float-type 'single-float) + (vm:simple-array-double-float-type 'double-float) + ((vm:simple-array-type vm:complex-vector-type vm:complex-array-type) + (with-array-data ((array array) (start) (end)) + (declare (ignore start end)) + (array-element-type array))) + (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)) + (cond ((array-header-p array) + (%array-rank array)) + ((vectorp array) + 1) + (t + (error "~S is not an array." array)))) (defun array-dimension (array axis-number) "Returns length of dimension Axis-Number of the Array." - (declare (fixnum axis-number)) + (declare (array array) (type index axis-number)) + (when (>= axis-number (array-rank array)) + (error "~D is too big; ~S only has ~D dimension~:P" + axis-number array (array-rank array))) (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)))) + (%array-dimension array axis-number) + (length (the (simple-array * (*)) array)))) (defun array-dimensions (array) "Returns a list whose elements are the dimensions of the array" + (declare (array 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)))) + (do ((results nil (cons (array-dimension array index) results)) + (index (1- (array-rank array)) (1- index))) + ((minusp index) results)) + (list (array-dimension array 0)))) (defun array-total-size (array) "Returns the total number of elements in the Array." + (declare (array array)) (if (array-header-p array) - (%primitive header-ref array %array-length-slot) - (%primitive vector-length array))) + (%array-available-elements array) + (length (the vector 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." + "Returns T if the given Array is adjustable, or NIL otherwise." + (declare (array array)) (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)) + +;;;; Fill pointer frobbing stuff. (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))) + (declare (array array)) + (and (array-header-p array) (%array-fill-pointer-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) + (declare (vector vector)) + (if (and (array-header-p vector) (%array-fill-pointer-p vector)) + (%array-fill-pointer vector) (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)) + (declare (vector vector) (fixnum new)) + (if (and (array-header-p vector) (%array-fill-pointer-p vector)) + (if (> new (%array-available-elements vector)) + (error "New fill pointer, ~S, is larger than the length of the vector." + new) + (setf (%array-fill-pointer vector) new)) (error "~S is not an array with a fill-pointer." vector))) (defun vector-push (new-el array) @@ -462,71 +533,46 @@ 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))) + (declare (vector array)) + (let ((fill-pointer (fill-pointer array))) + (declare (fixnum fill-pointer)) + (cond ((= fill-pointer (%array-available-elements array)) + nil) + (t + (setf (aref array fill-pointer) new-el) + (setf (%array-fill-pointer array) (1+ fill-pointer)))))) + +(defun vector-push-extend (new-el array &optional + (extension (if (zerop (length array)) + 1 + (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))) + (declare (vector array) (fixnum extension)) + (let ((fill-pointer (fill-pointer array))) + (declare (fixnum fill-pointer)) + (when (= fill-pointer (%array-available-elements array)) + (adjust-array array (+ fill-pointer extension))) + (setf (aref array fill-pointer) new-el) + (setf (%array-fill-pointer array) (1+ fill-pointer)))) (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))) + (declare (vector array)) + (let ((fill-pointer (fill-pointer array))) + (declare (fixnum fill-pointer)) + (cond ((zerop fill-pointer) + (error "Nothing left to pop.")) + (t + (setf (%array-fill-pointer array) + (1- fill-pointer)) + (aref array fill-pointer))))) + + +;;;; Adjust-array (defun adjust-array (array dimensions &key (element-type (array-element-type array)) @@ -551,9 +597,9 @@ (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)) + (let* ((array-size (apply #'* dimensions)) (array-data (data-vector-from-inits - dimensions array-size array-rank element-type + dimensions array-size element-type initial-contents initial-element initial-element-p))) (set-array-header array array-data array-size @@ -568,7 +614,7 @@ (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))) + (array-size (apply #'* dimensions))) (declare (fixnum displacement array-size)) (if (< (the fixnum (array-total-size displaced-to)) (the fixnum (+ displacement array-size))) @@ -578,37 +624,37 @@ fill-pointer) displacement dimensions t))) ((= array-rank 1) - (let ((old-length (%primitive header-ref array %array-length-slot)) + (let ((old-length (%array-available-elements array)) (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)) + (cond ((or (%array-displaced-p array) (< old-length new-length)) (setf new-data (data-vector-from-inits - dimensions new-length array-rank element-type + dimensions new-length 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)))) + (shrink-vector old-data new-length)))) (set-array-header array new-data new-length (get-new-fill-pointer array new-length fill-pointer) 0 dimensions nil)))) (t - (let ((old-length (%primitive header-ref array %array-length-slot)) - (new-length (array-linear-length dimensions))) + (let ((old-length (%array-available-elements array)) + (new-length (apply #'* 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) + (let ((new-data (if (or (%array-displaced-p array) (> new-length old-length)) (data-vector-from-inits - dimensions new-length array-rank + dimensions new-length element-type () initial-element initial-element-p) old-data))) @@ -621,40 +667,75 @@ (defun get-new-fill-pointer (old-array new-array-size fill-pointer) (cond ((not fill-pointer) - (%primitive header-ref old-array %array-fill-pointer-slot)) + (when (array-has-fill-pointer-p old-array) + (when (> (%array-fill-pointer old-array) new-array-size) + (error "Cannot adjust-array an array (~S) to a size (~S) that is ~ + smaller than it's fill pointer (~S)." + old-array new-array-size (fill-pointer old-array))) + (%array-fill-pointer old-array))) + ((not (array-has-fill-pointer-p old-array)) + (error "Cannot supply a non-NIL value (~S) for :fill-pointer ~ + in adjust-array unless the array (~S) was originally ~ + created with a fill pointer." + fill-pointer + old-array)) ((numberp fill-pointer) + (when (> fill-pointer new-array-size) + (error "Cannot supply a value for :fill-pointer (~S) that is larger ~ + than the new length of the vector (~S)." + fill-pointer new-array-size)) fill-pointer) - (t new-array-size))) + ((eq fill-pointer t) + new-array-size) + (t + (error "Bogus value for :fill-pointer in adjust-array: ~S" + fill-pointer)))) (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)))) + (declare (vector vector)) + (unless (array-header-p vector) + (macrolet ((frob (name &rest things) + `(etypecase ,name + ,@(mapcar #'(lambda (thing) + `(,(car thing) + (fill (truly-the ,(car thing) ,name) + ,(cadr thing) + :start new-size))) + things)))) + (frob vector + (simple-vector 0) + (simple-base-string (code-char 0)) + (simple-bit-vector 0) + ((simple-array (unsigned-byte 2) (*)) 0) + ((simple-array (unsigned-byte 4) (*)) 0) + ((simple-array (unsigned-byte 8) (*)) 0) + ((simple-array (unsigned-byte 16) (*)) 0) + ((simple-array (unsigned-byte 32) (*)) 0) + ((simple-array single-float (*)) (coerce 0 'single-float)) + ((simple-array double-float (*)) (coerce 0 'double-float))))) + (setf (%array-fill-pointer vector) new-size) + vector) (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) + (setf (%array-data-vector array) data) + (setf (%array-available-elements array) length) + (cond (fill-pointer + (setf (%array-fill-pointer array) fill-pointer) + (setf (%array-fill-pointer-p array) t)) + (t + (setf (%array-fill-pointer array) length) + (setf (%array-fill-pointer-p array) nil))) + (setf (%array-displacement array) 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) + (dotimes (axis (array-rank array)) + (declare (type index axis)) + (setf (%array-dimension array axis) (pop dimensions))) + (setf (%array-dimension array 0) dimensions)) + (setf (%array-displaced-p array) displacedp) array) @@ -663,18 +744,20 @@ ;;; 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)) +(defvar *zap-array-data-temp* (make-array 1000 :initial-element t)) (defun zap-array-data-temp (length element-type initial-element initial-element-p) (declare (fixnum length)) (when (> length (the fixnum (length *zap-array-data-temp*))) - (setf *zap-array-data-temp* (%primitive alloc-g-vector length t))) + (setf *zap-array-data-temp* + (make-array length :initial-element 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)) + (fill (the simple-vector *zap-array-data-temp*) initial-element + :end length)) *zap-array-data-temp*) @@ -701,7 +784,6 @@ (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) @@ -714,7 +796,8 @@ ((null subscripts) nil) (cond ((< (the fixnum (car subscripts)) (the fixnum (car limits))) - (rplaca subscripts (1+ (the fixnum (car subscripts)))) + (rplaca subscripts + (1+ (the fixnum (car subscripts)))) (return ,index)) (t (rplaca subscripts 0)))))) (do ((index (make-list (length old-dims) :initial-element 0) @@ -748,126 +831,111 @@ ;;;; Some bit stuff. -(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 (%primitive header-length array1))) - ((= 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)) + (declare (type (array bit) array1 array2)) + (and (= (array-rank array1) + (array-rank array2)) + (dotimes (index (array-rank array1) t) + (when (/= (array-dimension array1 index) + (array-dimension array2 index)) + (return nil))))) + +(defun pick-result-array (result-bit-array bit-array-1) + (case result-bit-array + ((t) bit-array-1) + ((nil) (make-array (array-dimensions bit-array-1) + :element-type 'bit + :initial-element 0)) + (t + (unless (bit-array-same-dimensions-p bit-array-1 + result-bit-array) + (error "~S and ~S do not have the same dimensions." + bit-array-1 result-bit-array)) + result-bit-array))) + +(defmacro def-bit-array-op (name function 32bit-function) + `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array) + ,(format nil + "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~ + BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ + If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ + RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ + All the arrays must have the same rank and dimensions." + (symbol-name function)) + (declare (type (array bit) bit-array-1 bit-array-2) + (type (or (array bit) (member t nil)) result-bit-array)) + (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2) + (error "~S and ~S do not have the same dimensions." + bit-array-1 bit-array-2)) + (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) + (if (and (simple-bit-vector-p bit-array-1) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (do ((index vm:vector-data-offset (1+ index)) + (end (+ vm:vector-data-offset + (truncate (the index + (+ (length bit-array-1) + vm:word-bits -1)) + vm:word-bits)))) + ((= index end) result-bit-array) + (declare (optimize (speed 3)) + (type index index end)) + (setf (%raw-bits result-bit-array index) + (,32bit-function (%raw-bits bit-array-1 index) + (%raw-bits bit-array-2 index)))) + (with-array-data ((data1 bit-array-1) (start1) (end1)) + (declare (ignore end1)) + (with-array-data ((data2 bit-array-2) (start2) (end2)) + (declare (ignore end2)) + (with-array-data ((data3 result-bit-array) (start3) (end3)) + (do ((index-1 start1 (1+ index-1)) + (index-2 start2 (1+ index-2)) + (index-3 start3 (1+ index-3))) + ((>= index-3 end3) result-bit-array) + (declare (type index index-1 index-2 index-3)) + (setf (sbit data3 index-3) + (logand (,function (sbit data1 index-1) + (sbit data2 index-2)) + 1)))))))))) + +(def-bit-array-op bit-and logand 32bit-logical-and) +(def-bit-array-op bit-ior logior 32bit-logical-or) +(def-bit-array-op bit-xor logxor 32bit-logical-xor) +(def-bit-array-op bit-eqv logeqv 32bit-logical-eqv) +(def-bit-array-op bit-nand lognand 32bit-logical-nand) +(def-bit-array-op bit-nor lognor 32bit-logical-nor) +(def-bit-array-op bit-andc1 logandc1 32bit-logical-andc1) +(def-bit-array-op bit-andc2 logandc2 32bit-logical-andc2) +(def-bit-array-op bit-orc1 logorc1 32bit-logical-orc1) +(def-bit-array-op bit-orc2 logorc2 32bit-logical-orc2) (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)) + "Performs a bit-wise logical NOT on the elements of BIT-ARRAY, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. Both arrays must have the same rank and dimensions." + (declare (type (array bit) bit-array) + (type (or (array bit) (member t nil)) result-bit-array)) + (let ((result-bit-array (pick-result-array result-bit-array bit-array))) + (if (and (simple-bit-vector-p bit-array) + (simple-bit-vector-p result-bit-array)) + (do ((index vm:vector-data-offset (1+ index)) + (end (+ vm:vector-data-offset + (truncate (the index + (+ (length bit-array) vm:word-bits -1)) + vm:word-bits)))) + ((= index end) result-bit-array) + (declare (type index index end) + (optimize (speed 3))) + (setf (%raw-bits result-bit-array index) + (32bit-logical-not (%raw-bits bit-array index)))) + (with-array-data ((src bit-array) (src-start) (src-end)) + (declare (ignore src-end)) + (with-array-data ((dst result-bit-array) (dst-start) (dst-end)) + (do ((src-index src-start (1+ src-index)) + (dst-index dst-start (1+ dst-index))) + ((>= dst-index dst-end) result-bit-array) + (declare (type index src-index dst-index)) + (setf (sbit dst dst-index) + (logxor (sbit src src-index) 1)))))))) + diff --git a/code/defstruct.lisp b/code/defstruct.lisp index b8ed70a14..4f464095c 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -7,21 +7,16 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.9 1990/08/24 18:10:38 wlott Exp $ +;;; ;;; 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. -;;; -(proclaim '(inline structurify)) -(defun structurify (structure) - "Frobs a vector to turn it into a named structure. Returns the vector." - (%primitive set-vector-subtype structure %g-vector-structure-subtype)) +;;; Note: STRUCTURIFY is defined in struct.lisp. It converts a simple-vector +;;; into a structure. ;;; This version of Defstruct is implemented using Defstruct, and is free of @@ -285,11 +280,13 @@ ;;; This is called by the accessor closures, which have a handle on the type's ;;; Defstruct-Description. ;;; +#+new-compiler (proclaim '(inline typep-to-structure)) +#+new-compiler (defun typep-to-structure (obj info) (declare (type defstruct-description info) (inline member)) (and (structurep obj) - (let ((name (%primitive header-ref obj 0))) + (let ((name (%primitive structure-ref obj 0))) (or (eq name (dd-name info)) (member name (dd-included-by info) :test #'eq))))) @@ -312,7 +309,7 @@ (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)))) + (%primitive structure-index-ref structure (dsd-index dsd)))) (unless (dsd-read-only slot) (setf (fdefinition `(setf ,(dsd-accessor slot))) @@ -326,7 +323,7 @@ (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) + (%primitive structure-index-set structure (dsd-index dsd) new-value)))))) (when (dd-predicate info) @@ -348,11 +345,11 @@ (do ((i 1 (1+ i)) (res (%primitive alloc-g-vector len nil))) ((= i len) - (%primitive header-set res 0 (dd-name info)) + (%primitive structure-set res (dd-name info) 0) (structurify res)) (declare (fixnum i)) - (%primitive header-set res i - (%primitive header-ref structure i))))))) + (%primitive structure-index-set res i + (%primitive structure-index-ref structure i))))))) (when (dd-doc info) (setf (documentation (dd-name info) 'type) (dd-doc info)))) @@ -378,7 +375,7 @@ (declare (type ,type structure)) (the ,slot-type (elt structure ,index))) ,@(unless (dsd-read-only slot) - `((defun (setf ,name) (structure new-value) + `((defun (setf ,name) (new-value structure) (declare (type ,type structure) (type ,slot-type new-value)) (setf (elt structure ,index) new-value))))) stuff)))) @@ -476,7 +473,7 @@ (let ((arg (car args))) (cond ((not (atom arg)) (push (find-legal-slot defstruct (car arg)) slots-in-arglist)) - ((memq arg '(&optional &rest &aux &key)) + ((member arg '(&optional &rest &aux &key) :test #'eq) (setq arg-kind arg)) (t (case arg-kind @@ -494,7 +491,8 @@ :initial-element `',(dd-name defstruct)) (make-list (dd-offset defstruct)))) (thing (mapcar #'(lambda (slot) - (if (memq slot slots-in-arglist) + (if (member slot slots-in-arglist + :test #'eq) (dsd-name slot) (dsd-default slot))) slots))) @@ -567,7 +565,7 @@ (let ((def (info type structure-info type))) (if (and def (eq (dd-type def) 'structure) (dd-predicate def)) `(and (structurep ,object) - (if (eq (%primitive header-ref ,object 0) ',type) + (if (eq (%primitive structure-ref ,object 0) ',type) t (,(dd-predicate def) ,object))) `(lisp::structure-typep ,object ',type)))) diff --git a/code/describe.lisp b/code/describe.lisp index f63e49bed..9a1831a44 100644 --- a/code/describe.lisp +++ b/code/describe.lisp @@ -206,12 +206,12 @@ (let ((rank (array-rank x))) (cond ((> rank 1) (format t "~&~S is " x) - (write-string (if (%displacedp x) "a displaced" "an")) + (write-string (if (%array-displaced-p 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)) + (and (array-header-p x) (%array-displaced-p x)) (length x)) (if (array-has-fill-pointer-p x) (format t "~&It has a fill pointer, currently ~d" (fill-pointer x)) @@ -228,32 +228,30 @@ ,output)))) (defun describe-function (x) - (case (%primitive get-vector-subtype x) - (#.%function-entry-subtype - (describe-function-compiled x)) - (#.%function-closure-subtype + (declare (type function x)) + (case (get-type x) + (#.vm:closure-header-type (describe-function-lex-closure x)) + ((#.vm:function-header-type #.vm:closure-function-header-type) + (describe-function-compiled 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))) + (let ((args (%function-header-arglist x))) (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))) + (type (%function-header-type x))) (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))) + (let ((name (%function-header-name x))) (when (symbolp name) (desc-doc name 'function "Function Documention:"))) - (let ((info (%primitive header-ref - (%primitive header-ref x - %function-entry-constants-slot) - %function-constants-debug-info-slot))) + (let ((info (di::code-debug-info (di::function-code-header x)))) (when info (let ((sources (c::compiled-debug-info-source info))) (format t "~&On ~A it was compiled from:" @@ -275,14 +273,11 @@ (defun describe-function-lex-closure (x) (print-for-describe x) (format t " is a lexical closure.~%") + (describe-function-compiled (%closure-function x)) (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))) + (indenting-further *standard-output* 8) + (dotimes (i (get-header-data x)) + (format t "~&~D: ~S" i (%closure-index-ref x i)))) (defun print-for-describe (x &optional (freshp t)) diff --git a/code/error.lisp b/code/error.lisp index 6ded62740..4c1917ae6 100644 --- a/code/error.lisp +++ b/code/error.lisp @@ -530,7 +530,8 @@ The previous version is uglier, but it sets up unique run-time tags. ;;; hyperspace. ;;; (defmacro infinite-error-protect (form) - `(if (and (boundp '*error-system-initialized*) (numberp *current-error-depth*)) + `(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.") @@ -974,265 +975,13 @@ The previous version sets up unique run-time tags. 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-caller-name) - 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/fd-stream.lisp b/code/fd-stream.lisp index 24215c3d3..fe3c44ae8 100644 --- a/code/fd-stream.lisp +++ b/code/fd-stream.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.5 1990/08/24 18:10:52 wlott Exp $ +;;; ;;; Streams for UNIX file descriptors. ;;; ;;; Written by William Lott, July 1989 - January 1990. @@ -29,15 +31,6 @@ (in-package "LISP") -(defmacro byte-blt (src-string src-start dst-string dst-start dst-end) - "Move the bytes from src-string to dst-string." - `(system:%primitive byte-blt - ,src-string - ,src-start - ,dst-string - ,dst-start - ,dst-end)) - ;;;; Buffer manipulation routines. @@ -56,8 +49,7 @@ (defun next-available-buffer () (if *available-buffers* (pop *available-buffers*) - (system:make-alien 'alien (* bytes-per-buffer 8)))) - + (allocate-system-memory bytes-per-buffer))) ;;;; The FD-STREAM structure. @@ -73,7 +65,7 @@ (original nil) ; The original file (for :if-exists :rename) (delete-original nil) ; for :if-exists :rename-and-delete (element-size 1) ; Number of bytes per element. - (element-type 'string-char) ; The type of element being transfered. + (element-type 'base-character) ; The type of element being transfered. (fd -1 :type fixnum) ; The file descriptor (buffering :full) ; One of :none, :line, or :full (char-pos nil) ; Character position if known. @@ -81,14 +73,12 @@ ;; The input buffer. (unread nil) - (ibuf nil) (ibuf-sap nil) (ibuf-length nil) (ibuf-head 0 :type fixnum) (ibuf-tail 0 :type fixnum) ;; The output buffer. - (obuf nil) (obuf-sap nil) (obuf-length nil) (obuf-tail 0 :type fixnum) @@ -122,7 +112,7 @@ (base (car stuff)) (start (cadr stuff)) (end (caddr stuff)) - (buffer (cadddr stuff)) + (reuse-sap (cadddr stuff)) (length (- end start))) (multiple-value-bind (count errno) @@ -131,13 +121,12 @@ start length) (cond ((eql count length) ; Hot damn, it workded. - (when buffer - (push buffer *available-buffers*))) + (when reuse-sap + (push base *available-buffers*))) ((not (null count)) ; Sorta worked. (push (list base (+ start count) - end - buffer) + end) (fd-stream-output-later stream))) ((= errno mach:ewouldblock) (error "Write would have blocked, but SERVER told us to go.")) @@ -153,10 +142,10 @@ ;;; ;;; Arange to output the string when we can write on the file descriptor. ;;; -(defun output-later (stream base start end buffer) +(defun output-later (stream base start end reuse-sap) (cond ((null (fd-stream-output-later stream)) (setf (fd-stream-output-later stream) - (list (list base start end buffer))) + (list (list base start end reuse-sap))) (setf (fd-stream-handler stream) (system:add-fd-handler (fd-stream-fd stream) :output @@ -165,14 +154,11 @@ (do-output-later stream))))) (t (nconc (fd-stream-output-later stream) - (list (list base start end buffer))))) - (when buffer + (list (list base start end reuse-sap))))) + (when reuse-sap (let ((new-buffer (next-available-buffer))) - (setf (fd-stream-obuf stream) new-buffer) - (setf (fd-stream-obuf-sap stream) - (system:alien-sap new-buffer)) - (setf (fd-stream-obuf-length stream) - (/ (system:alien-size new-buffer) 8))))) + (setf (fd-stream-obuf-sap stream) new-buffer) + (setf (fd-stream-obuf-length stream) bytes-per-buffer)))) ;;; DO-OUTPUT -- internal ;;; @@ -180,11 +166,11 @@ ;;; so, just queue this one. Otherwise, try to write it. If this would block, ;;; queue it. ;;; -(defun do-output (stream base start end buffer) +(defun do-output (stream base start end reuse-sap) (if (not (null (fd-stream-output-later stream))) ; something buffered. (progn - (output-later stream base start end buffer) - ;; XXX check to see if any of this noise can be output + (output-later stream base start end reuse-sap) + ;; ### check to see if any of this noise can be output ) (let ((length (- end start))) (multiple-value-bind @@ -192,9 +178,9 @@ (mach:unix-write (fd-stream-fd stream) base start length) (cond ((eql count length)) ; Hot damn, it worked. ((not (null count)) - (output-later stream base (+ start count) end buffer)) + (output-later stream base (+ start count) end reuse-sap)) ((= errno mach:ewouldblock) - (output-later stream base start end buffer)) + (output-later stream base start end reuse-sap)) (t (error "While writing ~S: ~A" stream @@ -207,11 +193,7 @@ (defun flush-output-buffer (stream) (let ((length (fd-stream-obuf-tail stream))) (unless (= length 0) - (do-output stream - (fd-stream-obuf-sap stream) - 0 - length - (fd-stream-obuf stream)) + (do-output stream (fd-stream-obuf-sap stream) 0 length t) (setf (fd-stream-obuf-tail stream) 0)))) ;;; DEF-OUTPUT-ROUTINES -- internal @@ -255,46 +237,45 @@ (cdr buffering))))))) bufferings))) +(def-output-routines ("OUTPUT-CHAR-~A-BUFFERED" + 1 + (:none base-character) + (:line base-character) + (:full base-character)) + (if (eq (char-code byte) + (char-code #\Newline)) + (setf (fd-stream-char-pos stream) 0) + (incf (fd-stream-char-pos stream))) + (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) + (char-code byte))) + (def-output-routines ("OUTPUT-BYTE-~A-BUFFERED" 1 - (:none (signed-byte 8) (unsigned-byte 8) string-char) - (:line string-char) - (:full (signed-byte 8) (unsigned-byte 8) string-char)) + (:none (signed-byte 8) (unsigned-byte 8)) + (:full (signed-byte 8) (unsigned-byte 8))) (when (characterp byte) (if (eq (char-code byte) (char-code #\Newline)) (setf (fd-stream-char-pos stream) 0) (incf (fd-stream-char-pos stream)))) - (system:%primitive 8bit-system-set - (fd-stream-obuf-sap stream) - (fd-stream-obuf-tail stream) - byte)) + (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) + byte)) (def-output-routines ("OUTPUT-SHORT-~A-BUFFERED" 2 (:none (signed-byte 16) (unsigned-byte 16)) (:full (signed-byte 16) (unsigned-byte 16))) - (system:%primitive 16bit-system-set - (fd-stream-obuf-sap stream) - (/ (fd-stream-obuf-tail stream) 2) - byte)) -(def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED" - 4 - (:none (signed-byte 32)) - (:full (signed-byte 32))) - (system:%primitive signed-32bit-system-set - (fd-stream-obuf-sap stream) - (/ (fd-stream-obuf-tail stream) 2) - byte)) -; XXX What? no unsigned-32bit-system-set? -(def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED" + (setf (sap-ref-16 (fd-stream-obuf-sap stream) + (truncate (fd-stream-obuf-tail stream) 2)) + byte)) + +(def-output-routines ("OUTPUT-LONG-~A-BUFFERED" 4 - (:none (unsigned-byte 31)) - (:full (unsigned-byte 31))) - (system:%primitive signed-32bit-system-set - (fd-stream-obuf-sap stream) - (/ (fd-stream-obuf-tail stream) 2) - byte)) + (:none (signed-byte 32) (unsigned-byte 32)) + (:full (signed-byte 32) (unsigned-byte 32))) + (setf (sap-ref-32 (fd-stream-obuf-sap stream) + (truncate (fd-stream-obuf-tail stream) 4)) + byte)) ;;; OUTPUT-RAW-BYTES -- public ;;; @@ -321,11 +302,33 @@ 'output-raw-bytes)) ((zerop bytes)) ; Easy case ((<= bytes space) - (byte-blt thing start (fd-stream-obuf-sap stream) tail newtail) + (if (system-area-pointer-p thing) + (system-area-copy thing + (* start vm:byte-bits) + (fd-stream-obuf-sap stream) + (* tail vm:byte-bits) + (* bytes vm:byte-bits)) + (copy-to-system-area thing + (+ (* start vm:byte-bits) + (* vm:vector-data-offset vm:word-bits)) + (fd-stream-obuf-sap stream) + (* tail vm:byte-bits) + (* bytes vm:byte-bits))) (setf (fd-stream-obuf-tail stream) newtail)) ((<= bytes len) (flush-output-buffer stream) - (byte-blt thing start (fd-stream-obuf-sap stream) 0 bytes) + (if (system-area-pointer-p thing) + (system-area-copy thing + (* start vm:byte-bits) + (fd-stream-obuf-sap stream) + 0 + (* bytes vm:byte-bits)) + (copy-to-system-area thing + (+ (* start vm:byte-bits) + (* vm:vector-data-offset vm:word-bits)) + (fd-stream-obuf-sap stream) + 0 + (* bytes vm:byte-bits))) (setf (fd-stream-obuf-tail stream) bytes)) (t (flush-output-buffer stream) @@ -347,31 +350,31 @@ (end (or end (length thing)))) (declare (fixnum start end)) (if (stringp thing) - (let ((last-newline (and (find #\newline (the simple-string thing) - :start start :end end) - (position #\newline (the simple-string thing) - :from-end t - :start start - :end end)))) + (let ((last-newline (and (find #\newline (the simple-string thing) + :start start :end end) + (position #\newline (the simple-string thing) + :from-end t + :start start + :end end)))) + (ecase (fd-stream-buffering stream) + (:full + (output-raw-bytes stream thing start end)) + (:line + (output-raw-bytes stream thing start end) + (when last-newline + (flush-output-buffer stream))) + (:none + (do-output stream thing start end nil))) + (if last-newline + (setf (fd-stream-char-pos stream) + (- end last-newline 1)) + (incf (fd-stream-char-pos stream) + (- end start)))) (ecase (fd-stream-buffering stream) - (:full + ((:line :full) (output-raw-bytes stream thing start end)) - (:line - (output-raw-bytes stream thing start end) - (when last-newline - (flush-output-buffer stream))) (:none - (do-output stream thing start end nil))) - (if last-newline - (setf (fd-stream-char-pos stream) - (- end last-newline 1)) - (incf (fd-stream-char-pos stream) - (- end start)))) - (ecase (fd-stream-buffering stream) - ((:line :full) - (output-raw-bytes stream thing start end)) - (:none - (do-output stream thing start end nil)))))) + (do-output stream thing start end nil)))))) ;;; PICK-OUTPUT-ROUTINE -- internal ;;; @@ -414,11 +417,13 @@ (setf (fd-stream-ibuf-tail stream) 0)) (t (decf tail head) - (byte-blt ibuf-sap head ibuf-sap 0 tail) + (system-area-copy ibuf-sap (* head vm:byte-bits) + ibuf-sap 0 (* tail vm:byte-bits)) (setf head 0) (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) tail)))) (setf (fd-stream-listen stream) nil) + #+serve-event (multiple-value-bind (count errno) (mach:unix-select (1+ fd) (ash 1 fd) 0 0 0) @@ -436,7 +441,8 @@ (system:int-sap (+ (system:sap-int ibuf-sap) tail)) (- buflen tail)) (cond ((null count) - (if (eql errno mach:ewouldblock) + (if #+serve-event (eql errno mach:ewouldblock) + #-serve-event nil (progn (system:wait-until-fd-usable fd :input) (do-input stream)) @@ -477,7 +483,8 @@ (if (fd-stream-unread ,stream) (prog1 (fd-stream-unread ,stream) - (setf (fd-stream-unread ,stream) nil)) + (setf (fd-stream-unread ,stream) nil) + (setf (fd-stream-listen ,stream) nil)) (let ((,element-var (catch 'eof-input-catcher (input-at-least ,stream-var ,bytes) @@ -507,13 +514,13 @@ (nconc *input-routines* (list (list ',type ',name ',size)))))) -;;; INPUT-STRING-CHAR -- internal +;;; INPUT-BASE-CHARACTER -- internal ;;; ;;; Routine to use in stream-in slot for reading string chars. ;;; -(def-input-routine input-string-char - (string-char 1 sap head) - (code-char (system:%primitive 8bit-system-ref sap head))) +(def-input-routine input-base-character + (base-character 1 sap head) + (code-char (sap-ref-8 sap head))) ;;; INPUT-UNSIGNED-8BIT-BYTE -- internal ;;; @@ -521,7 +528,7 @@ ;;; (def-input-routine input-unsigned-8bit-byte ((unsigned-byte 8) 1 sap head) - (system:%primitive 8bit-system-ref sap head)) + (sap-ref-8 sap head)) ;;; INPUT-SIGNED-8BIT-BYTE -- internal ;;; @@ -529,10 +536,7 @@ ;;; (def-input-routine input-signed-8bit-number ((signed-byte 8) 1 sap head) - (let ((byte (system:%primitive 8bit-system-ref sap head))) - (if (logand byte #x80) - (- byte #x100) - byte))) + (signed-sap-ref-8 sap head)) ;;; INPUT-UNSIGNED-16BIT-BYTE -- internal ;;; @@ -540,9 +544,7 @@ ;;; (def-input-routine input-unsigned-16bit-byte ((unsigned-byte 16) 2 sap head) - (system:%primitive 16bit-system-ref - sap - (/ head 2))) + (sap-ref-16 sap (truncate head 2))) ;;; INPUT-SIGNED-16BIT-BYTE -- internal ;;; @@ -550,9 +552,7 @@ ;;; (def-input-routine input-signed-16bit-byte ((signed-byte 16) 2 sap head) - (system:%primitive signed-16bit-system-ref - sap - (/ head 2))) + (signed-sap-ref-16 sap (truncate head 2))) ;;; INPUT-UNSIGNED-32BIT-BYTE -- internal ;;; @@ -560,9 +560,7 @@ ;;; (def-input-routine input-unsigned-32bit-byte ((unsigned-byte 32) 4 sap head) - (system:%primitive unsigned-32bit-system-ref - sap - (/ head 2))) + (sap-ref-32 sap (truncate head 4))) ;;; INPUT-SIGNED-32BIT-BYTE -- internal ;;; @@ -570,9 +568,7 @@ ;;; (def-input-routine input-signed-32bit-byte ((signed-byte 32) 4 sap head) - (system:%primitive signed-32bit-system-ref - sap - (/ head 2))) + (signed-sap-ref-32 sap (truncate head 2))) ;;; PICK-INPUT-ROUTINE -- internal ;;; @@ -593,7 +589,9 @@ (defun string-from-sap (sap start end) (let* ((length (- end start)) (string (make-string length))) - (byte-blt sap start string 0 length) + (copy-from-system-area sap (* start vm:byte-bits) + string (* vm:vector-data-offset vm:word-bits) + (* length vm:byte-bits)) string)) ;;; FD-STREAM-READ-LINE -- internal @@ -605,24 +603,25 @@ (let ((eof t)) (values (or (let ((sap (fd-stream-ibuf-sap stream)) - (results (if (fd-stream-unread stream) - (prog1 - (list (string (fd-stream-unread stream))) - (setf (fd-stream-unread stream) nil))))) + (results (when (fd-stream-unread stream) + (prog1 + (list (string (fd-stream-unread stream))) + (setf (fd-stream-unread stream) nil) + (setf (fd-stream-listen stream) nil))))) (catch 'eof-input-catcher (loop (input-at-least stream 1) (let* ((head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream)) - (newline (system:%primitive find-character - sap - head - tail - #\Newline)) + (newline (do ((index head (1+ index))) + ((= index tail) nil) + (when (= (sap-ref-8 sap index) + (char-code #\newline)) + (return index)))) (end (or newline tail))) (push (string-from-sap sap head end) results) - + (when newline (setf eof nil) (setf (fd-stream-ibuf-head stream) @@ -650,19 +649,28 @@ (elsize (fd-stream-element-size stream)) (offset (* elsize start)) (bytes (* elsize requested)) - (result (catch 'eof-input-catcher - (loop - (input-at-least stream 1) - (let* ((head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) - (available (- tail head)) - (copy (min available bytes))) - (byte-blt sap head buffer offset (+ offset copy)) - (incf (fd-stream-ibuf-head stream) copy) - (incf offset copy) - (decf bytes copy)) - (when (zerop bytes) - (return requested)))))) + (result + (catch 'eof-input-catcher + (loop + (input-at-least stream 1) + (let* ((head (fd-stream-ibuf-head stream)) + (tail (fd-stream-ibuf-tail stream)) + (available (- tail head)) + (copy (min available bytes))) + (if (typep buffer 'system-area-pointer) + (system-area-copy sap (* head vm:byte-bits) + buffer (* offset vm:byte-bits) + (* copy vm:byte-bits)) + (copy-from-system-area sap (* head vm:byte-bits) + buffer (+ (* offset vm:byte-bits) + (* vm:vector-data-offset + vm:word-bits)) + (* copy vm:byte-bits))) + (incf (fd-stream-ibuf-head stream) copy) + (incf offset copy) + (decf bytes copy)) + (when (zerop bytes) + (return requested)))))) (cond (result) ((not eof-error-p) (- requested (/ bytes elsize))) @@ -696,12 +704,12 @@ (input-size nil) (output-size nil)) - (when (fd-stream-obuf stream) - (push (fd-stream-obuf stream) *available-buffers*) - (setf (fd-stream-obuf stream) nil)) - (when (fd-stream-ibuf stream) - (push (fd-stream-ibuf stream) *available-buffers*) - (setf (fd-stream-ibuf stream) nil)) + (when (fd-stream-obuf-sap stream) + (push (fd-stream-obuf-sap stream) *available-buffers*) + (setf (fd-stream-obuf-sap stream) nil)) + (when (fd-stream-ibuf-sap stream) + (push (fd-stream-ibuf-sap stream) *available-buffers*) + (setf (fd-stream-ibuf-sap stream) nil)) (when input-p (multiple-value-bind @@ -709,14 +717,9 @@ (pick-input-routine target-type) (unless routine (error "Could not find any input routine for ~S" target-type)) - (setf (fd-stream-ibuf stream) - (next-available-buffer)) - (setf (fd-stream-ibuf-sap stream) - (system:alien-sap (fd-stream-ibuf stream))) - (setf (fd-stream-ibuf-length stream) - (/ (system:alien-size (fd-stream-ibuf stream)) 8)) - (setf (fd-stream-ibuf-tail stream) - 0) + (setf (fd-stream-ibuf-sap stream) (next-available-buffer)) + (setf (fd-stream-ibuf-length stream) bytes-per-buffer) + (setf (fd-stream-ibuf-tail stream) 0) (if (subtypep type 'character) (setf (fd-stream-in stream) routine (fd-stream-bin stream) #'ill-bin @@ -735,18 +738,15 @@ (error "Could not find any output routine for ~S buffered ~S." (fd-stream-buffering stream) target-type)) - (setf (fd-stream-obuf stream) (next-available-buffer)) - (setf (fd-stream-obuf-sap stream) - (system:alien-sap (fd-stream-obuf stream))) - (setf (fd-stream-obuf-length stream) - (/ (system:alien-size (fd-stream-obuf stream)) 8)) + (setf (fd-stream-obuf-sap stream) (next-available-buffer)) + (setf (fd-stream-obuf-length stream) bytes-per-buffer) (setf (fd-stream-obuf-tail stream) 0) (if (subtypep type 'character) (setf (fd-stream-out stream) routine (fd-stream-bout stream) #'ill-bout) (setf (fd-stream-out stream) (or (if (eql size 1) - (pick-output-routine 'string-char + (pick-output-routine 'base-character (fd-stream-buffering stream))) #'ill-out) (fd-stream-bout stream) routine)) @@ -767,7 +767,7 @@ (setf (fd-stream-element-type stream) (cond ((equal input-type output-type) input-type) - ((subtypep input-type output-type) + ((or (null output-type) (subtypep input-type output-type)) input-type) ((subtypep output-type input-type) output-type) @@ -795,12 +795,13 @@ 0 0)))))) (:unread - (setf (fd-stream-unread stream) arg1)) + (setf (fd-stream-unread stream) arg1) + (setf (fd-stream-listen stream) t)) (:close (cond (arg1 ;; We got us an abort on our hands. (when (and (fd-stream-file stream) - (fd-stream-obuf stream)) + (fd-stream-obuf-sap stream)) ;; Can't do anything unless we know what file were dealing with, ;; and we don't want to do anything strange unless we were ;; writing to the file. @@ -838,18 +839,19 @@ stream (mach:get-unix-error-msg err))))))) (mach:unix-close (fd-stream-fd stream)) - (when (fd-stream-obuf stream) - (push (fd-stream-obuf stream) *available-buffers*) - (setf (fd-stream-obuf stream) nil)) - (when (fd-stream-ibuf stream) - (push (fd-stream-ibuf stream) *available-buffers*) - (setf (fd-stream-ibuf stream) nil)) + (when (fd-stream-obuf-sap stream) + (push (fd-stream-obuf-sap stream) *available-buffers*) + (setf (fd-stream-obuf-sap stream) nil)) + (when (fd-stream-ibuf-sap stream) + (push (fd-stream-ibuf-sap stream) *available-buffers*) + (setf (fd-stream-ibuf-sap stream) nil)) (lisp::set-closed-flame stream)) (:clear-input) (:force-output (flush-output-buffer stream)) (:finish-output (flush-output-buffer stream) + #+serve-event (do () ((null (fd-stream-output-later stream))) (system:serve-all-events))) @@ -928,6 +930,8 @@ (setf (fd-stream-unread stream) nil) (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) 0) + ;; Trash cashed value for listen, so that we check next time. + (setf (fd-stream-listen stream) nil) ;; Now move it. (cond ((eq newpos :start) (setf offset 0 origin mach:l_set)) @@ -962,7 +966,7 @@ &key (input nil input-p) (output nil output-p) - (element-type 'string-char) + (element-type 'base-character) (buffering :full) file original @@ -1032,13 +1036,13 @@ (defun open (filename &key (direction :input) - (element-type 'string-char) + (element-type 'base-character) (if-exists nil if-exists-given) (if-does-not-exist nil if-does-not-exist-given)) "Return a stream which reads from or writes to Filename. Defined keywords: :direction - one of :input, :output, :io, or :probe - :element-type - Type of object to read or write, default STRING-CHAR + :element-type - Type of object to read or write, default BASE-CHARACTER :if-exists - one of :error, :new-version, :rename, :rename-and-delete, :overwrite, :append, :supersede or nil :if-does-not-exist - one of :error, :create or nil diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp index 8f08bb514..4806894f7 100644 --- a/code/fdefinition.lisp +++ b/code/fdefinition.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.1.1.2 1990/04/20 00:36:19 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.2 1990/08/24 18:10:58 wlott Exp $ ;;; ;;; Functions that hack on the global function namespace (primarily ;;; concerned with SETF functions here.) diff --git a/code/filesys.lisp b/code/filesys.lisp index 49e97c122..0f9e00828 100644 --- a/code/filesys.lisp +++ b/code/filesys.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.3 1990/08/24 18:11:00 wlott Exp $ +;;; ;;; Ugly pathname functions for Spice Lisp. ;;; these functions are part of the standard Spice Lisp environment. ;;; @@ -42,8 +44,12 @@ "Set to the default pathname-defaults pathname (Got that?)") (defun filesys-init () - (setq *default-pathname-defaults* - (%make-pathname "Mach" nil nil nil nil nil))) + (setq *default-pathname-defaults* + (%make-pathname "Mach" nil nil nil nil nil)) + (multiple-value-bind (won dir) + (mach:unix-current-directory) + (when won + (setf (search-list "default:") (list dir))))) ;;; The pathname type is defined with a defstruct. @@ -316,7 +322,7 @@ ((zerop q) (incf i) (replace res res :start2 i :end2 len) - (%primitive shrink-vector res (- len i))) + (shrink-vector res (- len i))) (declare (simple-string res) (fixnum len i r)) (multiple-value-setq (q r) (truncate q 10)) @@ -1092,8 +1098,8 @@ (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))))) + (pathname (concatenate 'simple-string dir-or-error "/")) + (error dir-or-error)))) ;;; ;;; Maybe this shouldn't go here... @@ -1109,5 +1115,5 @@ (mach:unix-chdir (predict-name new-val nil)) (if gr (car (setf (search-list "default:") - (cdr (multiple-value-list (mach:unix-current-directory))))) + (list (default-directory)))) (error (mach:get-unix-error-msg error))))) diff --git a/code/format.lisp b/code/format.lisp index 31fcc893e..24cc4e19a 100644 --- a/code/format.lisp +++ b/code/format.lisp @@ -948,33 +948,19 @@ (cond ((not colon) (cond (atsign (prin1 char)) - ((zerop (char-bits char)) - (write-char char)) (t (format-print-named-character char nil)))) (t (format-print-named-character char t)))))) -(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))) +(defun format-print-named-character (char) + (let* ((name (char-name char))) (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))))) - - - + (t (write-char char))))) ;;;; NUMERIC PRINTING @@ -1227,45 +1213,54 @@ (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) + (coerce number 'single-float) w d k ovf pad atsign) (let ((*print-base* 10)) (format-write-field (princ-to-string number) w 1 0 #\space t))))))) +;;; We return true if we overflowed, so that ~G can output the overflow char +;;; instead of spaces. +;;; (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) + (cond + ((not (or w d)) + (prin1 number) + nil) + (t + (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 + ;;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 (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)))))))) + (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) + (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)) + nil))))))) ;;;; Exponential-format floating point ~E @@ -1281,7 +1276,7 @@ (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) + (coerce number 'single-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))))))) @@ -1289,11 +1284,11 @@ (defun format-exponent-marker (number) (if (typep number *read-default-float-format*) - #\E + #\e (typecase number - (short-float #\S) -; (single-float #\F) - (double-float #\D) + (single-float #\f) + (double-float #\d) + (short-float #\s) (long-float #\L)))) @@ -1356,7 +1351,7 @@ (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)) + ((w nil) (d nil) (e nil) (k nil) (ovf nil) (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 @@ -1365,7 +1360,7 @@ (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) + (coerce number 'single-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))))))) @@ -1389,10 +1384,13 @@ (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)))))) + (let ((char (if (format-fixed-aux number ww dd nil ovf pad + atsign) + ovf + #\space))) + (dotimes (i ee) (write-char char)))) + (t + (format-exp-aux number w d e (or k 1) ovf pad marker atsign)))))) ;;; Dollars floating-point format ~$ @@ -1400,7 +1398,7 @@ (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 (rationalp number) (setq number (coerce number 'single-float))) (if (floatp number) (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) (signlen (length signstr))) @@ -1416,39 +1414,6 @@ (let ((*print-base* 10)) (format-write-field (princ-to-string number) w 1 0 #\space t)))))) - -;;;; Some stuff for Compiler, MACLISP interaction. - -;;; 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 diff --git a/code/gc.lisp b/code/gc.lisp index 9622aaf35..575c5b873 100644 --- a/code/gc.lisp +++ b/code/gc.lisp @@ -8,9 +8,12 @@ ;;; Scott Fahlman (Scott.Fahlman@CS.CMU.EDU). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.4 1990/08/24 18:11:14 wlott Exp $ +;;; ;;; Garbage collection and allocation related code. ;;; ;;; Written by Christopher Hoover, Rob MacLachlan, Dave McDonald, et al. +;;; New code for MIPS port by Christopher Hoover. ;;; (in-package "EXTENSIONS") @@ -21,91 +24,90 @@ (in-package "LISP") (export '(room)) - -;;;; Room. +;;;; DYNAMIC-USAGE and friends. + +(proclaim '(special *read-only-space-free-pointer* + *static-space-free-pointer*)) + +(macrolet ((frob (lisp-fun c-var-name) + `(progn + (def-c-variable ,c-var-name (unsigned-byte 32)) + (defun ,lisp-fun () + (system:alien-access ,(intern (string-upcase c-var-name))))))) + (frob read-only-space-start "read_only_space") + (frob static-space-start "static_space") + (frob dynamic-0-space-start "dynamic_0_space") + (frob dynamic-1-space-start "dynamic_1_space") + (frob control-stack-start "control_stack") + (frob binding-stack-start "binding_stack") + (frob current-dynamic-space-start "current_dynamic_space")) -(defvar alloctable-address (int-sap %fixnum-alloctable-address) - "A system area pointer that addresses the the alloctable.") +(defun dynamic-usage () + (- (system:sap-int (c::dynamic-space-free-pointer)) + (current-dynamic-space-start))) -(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 static-space-usage () + (- (* lisp::*static-space-free-pointer* vm:word-bytes) + (static-space-start))) -(defun space-usage (type) - (let ((base (ash type %alloc-ref-type-shift))) - (values (alloc-ref base) - (alloc-ref (+ base 8)) - (alloc-ref (+ base 12))))) +(defun read-only-space-usage () + (- (* lisp::*read-only-space-free-pointer* vm:word-bytes) + (read-only-space-start))) -(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 control-stack-usage () + (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack-start))) + +(defun binding-stack-usage () + (- (system:sap-int (c::binding-stack-pointer-sap)) (binding-stack-start))) -(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))))))) + +(defun current-dynamic-space () + (let ((start (current-dynamic-space-start))) + (cond ((= start (dynamic-0-space-start)) + 0) + ((= start (dynamic-1-space-start)) + 1) + (t + (error "Oh no. The current dynamic space is missing!"))))) -;;;; DYNAMIC-USAGE. +;;;; Room. -;;; -;;; 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)) +(defun room-maximal-info () + (format t "The current dynamic space is ~D.~%" (current-dynamic-space)) + (format t "Dynamic Space Usage: ~10:D bytes.~%" (dynamic-usage)) + (format t "Read-Only Space Usage: ~10:D bytes.~%" (read-only-space-usage)) + (format t "Static Space Usage: ~10:D bytes.~%" (static-space-usage)) + (format t "Control Stack Usage: ~10:D bytes.~%" (control-stack-usage)) + (format t "Binding Stack Usage: ~10:D bytes.~%" (binding-stack-usage))) + +(defun room-minimal-info () + (format t "Dynamic Space Usage: ~10:D bytes.~%" (dynamic-usage))) + +(defun room-intermediate-info () + (format t "Dynamic Space Usage: ~10:D bytes.~%" (dynamic-usage)) + (format t "Read-Only Space Usage: ~10:D bytes.~%" (read-only-space-usage)) + (format t "Static Space Usage: ~10:D bytes.~%" (static-space-usage))) + +(defun room (&optional (verbosity :default)) + "Prints to *STANDARD-OUTPUT* information about the state of internal + storage and its management. The optional argument controls the + verbosity of ROOM. If it is T, ROOM prints out a maximal amount of + information. If it is NIL, ROOM prints out a minimal amount of + information. If it is :DEFAULT or it is not supplied, ROOM prints out + an intermediate amount of information." + (fresh-line) + (case verbosity + ((t) + (room-maximal-info)) + ((nil) + (room-minimal-info)) + (:default + (room-intermediate-info)) + (t + (error "No way man! The optional argument to ROOM must be T, NIL, ~ + or :DEFAULT.~%What do you think you are doing?")))) ;;;; GET-BYTES-CONSED. @@ -130,7 +132,7 @@ (incf *total-bytes-consed* (- bytes *last-bytes-in-use*)) (setq *last-bytes-in-use* bytes)))) *total-bytes-consed*) - + ;;;; Variables and Constants. @@ -153,7 +155,6 @@ (defvar *gc-trigger* default-bytes-consed-between-gcs) - ;;; ;;; The following specials are used to control when garbage collection ;;; occurs. @@ -249,251 +250,19 @@ threshold. The function should notify the user that the system has finished GC'ing.") - -;;;; 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-fp) - (- %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. -;;; +(def-c-routine ("collect_garbage" collect-garbage) (int)) + (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))) + (let ((old-usage (dynamic-usage))) + (collect-garbage) + (let ((new-bytes (dynamic-usage))) (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)) + (incf *total-bytes-consed* (- old-usage *last-bytes-in-use*)) + (setq *last-bytes-in-use* new-bytes))))) + ;;; ;;; *INTERNAL-GC* @@ -546,32 +315,23 @@ (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!")))))))) + (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*))))))) nil) ;;; @@ -581,7 +341,7 @@ ;;; should occur. The argument, object, is the newly allocated object ;;; which must be returned to the caller. ;;; -(defun maybe-gc (object) +(defun maybe-gc (&optional object) (sub-gc *gc-verbose* nil) object) diff --git a/code/lispinit.lisp b/code/lispinit.lisp index eaebaea58..6b1a18a99 100644 --- a/code/lispinit.lisp +++ b/code/lispinit.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.10 1990/08/24 18:11:26 wlott Exp $ +;;; ;;; Initialization and low-level interrupt support for the Spice Lisp system. ;;; Written by Skef Wholey and Rob MacLachlan. ;;; @@ -37,49 +39,53 @@ default-interrupt)) (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*)) +(export '(quit *prompt* save-lisp gc-on gc-off *clx-server-displays*)) (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 +(defconstant most-positive-fixnum #.vm:target-most-positive-fixnum "The fixnum closest in value to positive infinity.") -(defconstant most-negative-fixnum -134217728 +(defconstant most-negative-fixnum #.vm:target-most-negative-fixnum "The fixnum closest in value to negative infinity.") ;;; Random information: (defvar compiler-version "???") -(defvar *lisp-implementation-version* "3.0(?)") +(defvar *lisp-implementation-version* "4.0(?)") -(defvar *in-the-compiler* () +(defvar *in-the-compiler* nil "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) +(defparameter %fasl-code-format #.vm:target-fasl-code-format) ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs... (proclaim '(special *gc-inhibit* *already-maybe-gcing* *need-to-collect-garbage* *gc-verbose* *before-gc-hooks* *after-gc-hooks* c::*type-system-initialized*)) + + +;;;; Random magic specials. + + +;;; These are filled in by Genesis. + +(defvar *the-undefined-function*) +(defvar *current-catch-block*) +(defvar *current-unwind-block*) +(defvar *free-interrupt-context-index*) + + +;;; + +(defvar %sp-interrupts-inhibited nil) + + ;;;; Global ports: @@ -92,293 +98,6 @@ (defvar *nameserverport* () "Port to the name server.") - -;;; 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 :sigint) - (mach:sigmask :sigquit) - (mach:sigmask :sigfpe) - (mach:sigmask :sigsys) - (mach:sigmask :sigpipe) - (mach:sigmask :sigalrm) - (mach:sigmask :sigurg) - (mach:sigmask :sigstop) - (mach:sigmask :sigtstp) - (mach:sigmask :sigcont) - (mach:sigmask :sigchld) - (mach:sigmask :sigttin) - (mach:sigmask :sigttou) - (mach:sigmask :sigio) - (mach:sigmask :sigxcpu) - (mach:sigmask :sigxfsz) - (mach:sigmask :sigvtalrm) - (mach:sigmask :sigprof) - (mach:sigmask :sigwinch) - (mach:sigmask :sigmsg) - (mach:sigmask :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 :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. @@ -386,6 +105,9 @@ ;;; We maintain a global stack of reply ports which is shared among ;;; all matchmaker interfaces, and could be used by other people as well. ;;; + +#| More stuff that will probably be drastically different. + ;;; 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. @@ -458,9 +180,11 @@ (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 @@ -594,6 +318,9 @@ ;;; (defsetf object-set-operation %set-object-set-operation "Sets the handler function for an object set operation.") +|# + + ;;;; Emergency Message Handling: ;;; @@ -604,6 +331,8 @@ ;;; Instead, we use MessagesWaiting to find the ports with emergency ;;; messages. +#| still more noise that will be different. + (defalien waiting-ports nil (long-words 128)) ;;; Service-Emergency-Message-Interrupt -- Internal @@ -739,6 +468,9 @@ (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 @@ -753,7 +485,7 @@ (eval-when (compile) (defmacro print-and-call (name) `(progn - (%primitive print ',name) + (%primitive print ,(symbol-name name)) (,name)))) (defun %initial-function () @@ -772,7 +504,7 @@ (print-and-call c::globaldb-init) ;; Some of the random top-level forms call Make-Array, which calls Subtypep... - (print-and-call subtypep-init) + (print-and-call type-init) (setq *lisp-initialization-functions* (nreverse *lisp-initialization-functions*)) @@ -781,9 +513,14 @@ (funcall fun)) (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed. + ;; Only do this after top level forms have run, 'cause thats where + ;; deftypes are. + (setq c::*type-system-initialized* t) + (print-and-call os-init) (print-and-call filesys-init) (print-and-call conditions::error-init) + (print-and-call kernel::signal-init) (print-and-call reader-init) (print-and-call backq-init) @@ -793,11 +530,16 @@ (setq *readtable* (copy-readtable std-lisp-readtable)) (print-and-call stream-init) + (print-and-call loader-init) + #+nil (print-and-call random-init) (print-and-call format-init) (print-and-call package-init) + #+nil (print-and-call pprint-init) + (%primitive print "Done initializing.") + (setq *already-maybe-gcing* nil) (terpri) (princ "CMU Common Lisp kernel core image ") @@ -820,16 +562,17 @@ (defvar *task-notify* NIL) (defun reinit () + (%primitive print "In REINIT.") (without-interrupts (setq *already-maybe-gcing* t) - (os-init) - (stream-reinit) + (print-and-call os-init) + (print-and-call kernel::signal-init) + (print-and-call stream-reinit) (setq *already-maybe-gcing* nil)) - (setq *task-notify* (mach:mach-task_notify)) + #+nil (mach:port_enable (mach:mach-task_self) *task-notify*) - (add-port-object *task-notify* nil *kernel-messages*) - (init-mach-signals)) - + #+nil + (add-port-object *task-notify* nil *kernel-messages*)) ;;; 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 @@ -837,7 +580,8 @@ (defun os-init () (setq *task-self* (mach:mach-task_self)) - (setq *task-data* (mach:mach-task_data))) + (setq *task-data* (mach:mach-task_data)) + (setq *task-notify* (mach:mach-task_notify))) ;;; Setup-path-search-list returns a list of the directories that are @@ -864,107 +608,17 @@ ;;;; 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) - (enable-gc 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. - - :enable-gc - If true, turn GC on if it was off." - - (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 enable-gc - (gc-on)) - (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))) +#| might be something different. (defalien sleep-msg mach:msg (record-size 'mach:msg)) (setf (alien-access (mach:msg-simplemsg sleep-msg)) T) @@ -990,6 +644,8 @@ (gr-error 'mach:receive gr))))))) nil) +|# + ;;;; TOP-LEVEL loop. diff --git a/code/list.lisp b/code/list.lisp index 11e987f5e..1be15d459 100644 --- a/code/list.lisp +++ b/code/list.lisp @@ -126,13 +126,14 @@ (y list (cddr y)) (z list (cdr z))) (()) + (declare (fixnum n) (list y 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))) + (car (nthcdr n list))) (defun first (list) "Returns the 1st object in a list or NIL if the list is empty." @@ -170,11 +171,15 @@ (defun nthcdr (n list) "Performs the cdr function n times on a list." - (%primitive nthcdr n list)) + (do ((i n (1- i)) + (result list (cdr result))) + ((not (plusp i)) result))) (defun last (list) "Returns the last cons (not the last element!) of a list." - (%primitive last list)) + (do ((list list (cdr list)) + (result nil list)) + ((null list) result))) (defun list (&rest args) "Returns constructs and returns a list of its arguments." @@ -793,8 +798,6 @@ ((endp alist)) (if (car alist) (if ,test-guy (return (car alist)))))) -) ;eval-when - (defun assoc (item alist &key key test test-not) "Returns the cons in alist whose car is equal (by a given test or EQL) to @@ -893,11 +896,11 @@ (defun memq (item list) "Returns tail of list beginning with first element eq to item" - (memq item list)) + (member item list :test #'eq)) (defun assq (item alist) "Return the first pair of alist where item EQ the key of pair" - (assq item alist)) + (assoc item alist :test #'eq)) (defun delq (item list &optional (n 0 np)) (declare (fixnum n)) diff --git a/code/load.lisp b/code/load.lisp index 8b20c5df9..69a1d6f4c 100644 --- a/code/load.lisp +++ b/code/load.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.5 1990/08/24 18:11:40 wlott Exp $ +;;; ;;; Loader for Spice Lisp. ;;; Written by Skef Wholey and Rob MacLachlan. ;;; @@ -338,13 +340,13 @@ (defun check-header (file) (let ((byte (read-byte file NIL '*eof*))) (cond ((eq byte '*eof*) ()) - ((eq byte (char-int #\F)) + ((eq byte (char-code #\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))))) + (not (eql byte (char-code (schar "FASL FILE" count))))) (error "Bad FASL file format.")))) (t (error "Bad FASL file format."))))) @@ -398,8 +400,7 @@ (tn (probe-file pn))) (cond (tn - (if (or (string-equal (pathname-type tn) "nfasl") - (string-equal (pathname-type tn) "fasl")) + (if (string-equal (pathname-type tn) #.vm:target-fasl-file-type) (with-open-file (file tn :direction :input :element-type '(unsigned-byte 8)) @@ -417,7 +418,8 @@ (t (let* ((srcn (make-pathname :type "lisp" :defaults pn)) (src (probe-file srcn)) - (objn (make-pathname :type "nfasl" :defaults pn)) + (objn (make-pathname :type #.vm:target-fasl-file-type + :defaults pn)) (obj (probe-file objn))) (cond (obj @@ -465,10 +467,10 @@ (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)) + (%primitive make-other-immediate-type 0 vm:unbound-marker-type)) (define-fop (fop-character 68) - (int-char (read-arg 3))) + (code-char (read-arg 3))) (define-fop (fop-short-character 69) (code-char (read-arg 1))) @@ -563,22 +565,23 @@ (define-fop (fop-ratio 70) (let ((den (pop-stack))) - (%primitive make-ratio (pop-stack) den))) + (%make-ratio (pop-stack) den))) (define-fop (fop-complex 71) (let ((im (pop-stack))) - (%primitive make-complex (pop-stack) im))) + (%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))))) + (number (if (or (not (<= vm:single-float-normal-exponent-min + (+ exponent vm:single-float-bias) + vm:single-float-normal-exponent-max)) + (> m (1+ vm:single-float-digits))) + (coerce mantissa 'double-float) + (coerce mantissa 'single-float)))) (multiple-value-bind (f ex s) (decode-float number) (declare (ignore ex)) (* s (scale-float f exponent))))) @@ -645,14 +648,13 @@ (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))) + (res (%primitive make-array-header vm:simple-array-type rank))) (declare (simple-array vec)) (set-array-header res vec length length 0 - (do ((i (1- size) (1- i)) + (do ((i rank (1- i)) (dimensions () (cons (pop-stack) dimensions))) - ((< i %array-first-dim-slot) dimensions)) + ((zerop i) dimensions)) nil) res)) @@ -668,12 +670,21 @@ (prepare-for-fast-read-byte *fasl-file* (let* ((len (fast-read-u-integer 4)) (size (fast-read-byte)) - (ac (1- (integer-length size))) - (res (%primitive alloc-i-vector len ac))) + (type (case size + (1 vm:simple-bit-vector-type) + (2 vm:simple-array-unsigned-byte-2-type) + (4 vm:simple-array-unsigned-byte-4-type) + (8 vm:simple-array-unsigned-byte-8-type) + (16 vm:simple-array-unsigned-byte-16-type) + (32 vm:simple-array-unsigned-byte-32-type) + (t (error "Losing i-vector element size: ~S")))) + (bits (* len size)) + (res (%primitive allocate-vector type len + (the index (ceiling bits vm:word-bits))))) + (declare (type (unsigned-byte 8) type) + (type index len)) (done-with-fast-read-byte) - (unless (and (<= ac 5) (= size (ash 1 ac))) - (error "Losing element size ~S." size)) - (read-n-bytes *fasl-file* res 0 (ash (+ (ash len ac) 7) -3)) + (read-n-bytes *fasl-file* res 0 (ceiling bits vm:byte-bits)) res))) @@ -762,28 +773,23 @@ ;;; 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. +;;; the boxed storage section, then Size bytes of code are read in. ;;; (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)))) + `(let ((box-num ,nitems) + (code-length ,size)) + (declare (fixnum box-num code-length)) + (let ((code (%primitive c::allocate-code-object box-num code-length))) + (%primitive c::set-code-debug-info code (pop-stack)) + (do ((index (1- box-num) (1- index))) + ((minusp index)) + (declare (fixnum index)) + (%primitive c::code-constant-set code index (pop-stack))) + (system:without-gcing + (let ((inst (truly-the system-area-pointer + (%primitive c::code-instructions code)))) + (read-n-bytes *fasl-file* inst 0 code-length))) + code))) (define-fop (fop-code 58) (if (eql *current-code-format* %fasl-code-format) @@ -812,197 +818,102 @@ (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))) - + (index (- (clone-arg) vm:code-constants-offset))) + (declare (type index index)) + (%primitive c::code-constant-set code index value) + (undefined-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)) + (let ((type (pop-stack)) + (arglist (pop-stack)) + (name (pop-stack)) + (code-object (pop-stack)) + (offset (read-arg 4))) + (declare (type index offset)) + (unless (zerop (logand offset vm:lowtag-mask)) + (error "Unaligned function object, offset = #x~X." offset)) + (let ((fun (%primitive c::compute-function code-object offset))) + (%primitive c::set-function-self fun fun) + (%primitive c::set-function-next fun + (%primitive c::code-entry-points code-object)) + (%primitive c::set-code-entry-points code-object fun) + (%primitive c::set-function-name fun name) + (%primitive c::set-function-arglist fun arglist) + (%primitive c::set-function-type fun type) + fun))) -;;;; Loading assembler routines: -;;; +;;;; Linkage fixups. -;;; 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* ()) +;;; These two variables are initially filled in by Genesis. +(defvar *initial-assembler-routines*) +(defvar *initial-foreign-symbols*) -;;; 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. +(defvar *assembler-routines* (make-hash-table :test #'eq)) +(defvar *foreign-symbols* (make-hash-table :test #'equal)) -;;; 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* ())) +(defun loader-init () + (dolist (routine *initial-assembler-routines*) + (setf (gethash (car routine) *assembler-routines*) (cdr routine))) + (dolist (symbol *initial-foreign-symbols*) + (setf (gethash (car symbol) *foreign-symbols*) (cdr symbol))) + (makunbound '*initial-assembler-routines*) + (makunbound '*initial-foreign-symbols*)) + +(define-fop (fop-foreign-fixup 143) + (let* ((code-object (pop-stack)) + (offset (read-arg 4)) + (len (read-arg 1)) + (sym (make-string len))) + (read-n-bytes *fasl-file* sym 0 len) + (multiple-value-bind + (value found) + (gethash sym *foreign-symbols* 0) + (unless found + (error "Unknown foreign symbol: ~S" sym)) + (fixup-code-object code-object offset value)) + code-object)) + +(define-fop (fop-assembler-code 144) + (error "Cannot load assembler code.")) + +(define-fop (fop-assembler-routine 145) + (error "Cannot load assembler code.")) + +(define-fop (fop-assembler-fixup 146) + (let ((routine (pop-stack)) + (code-object (pop-stack)) + (offset (read-arg 4))) + (multiple-value-bind + (value found) + (gethash routine *assembler-routines*) + (unless found + (error "Undefined assembler routine: ~S" routine)) + (fixup-code-object code-object offset value) + code-object))) + +(defun fixup-code-object (code offset fixup) + ;; Currently, the only kind of fixup we can have is a lui followed by an + ;; addi. + (multiple-value-bind + (word-offset rem) + (truncate offset vm:word-bytes) + (unless (zerop rem) + (error "Unaligned instruction? offset=#x~X." offset)) + (system:without-gcing + (let* ((sap (truly-the system-area-pointer + (%primitive c::code-instructions code))) + (half-word-offset (* word-offset 2)) + (new-val (+ fixup + (ash (sap-ref-16 sap half-word-offset) 16) + (signed-sap-ref-16 sap (+ half-word-offset 2)))) + (low (logand new-val (1- (ash 1 16)))) + (high (+ (ash new-val -16) + (if (logbitp 15 low) 1 0)))) + (setf (sap-ref-16 sap half-word-offset) high) + (setf (sap-ref-16 sap (+ half-word-offset 2)) low))))) + + (proclaim '(notinline read-byte)) diff --git a/code/machdef.lisp b/code/machdef.lisp index 2d3471e46..eb06c475a 100644 --- a/code/machdef.lisp +++ b/code/machdef.lisp @@ -10,9 +10,21 @@ ;;; 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)) +(export '(int-array int-array-ref)) + +(export '(sigcontext-onstack sigcontext-mask sigcontext-pc sigcontext-regs + sigcontext-mdlo sigcontext-mdhi sigcontext-ownedfp sigcontext-fpregs + sigcontext-fpc_csr sigcontext-fpc_eir sigcontext-cause + sigcontext-badvaddr sigcontext-badpaddr sigcontext *sigcontext + indirect-*sigcontext)) + + +(def-c-type c-string (pointer simple-base-string)) + (defrecord Msg (Reserved1 (unsigned-byte 8) 8) (Reserved2 (unsigned-byte 8) 8) @@ -29,41 +41,30 @@ (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)) +#+new-compiler +(def-c-array int-array unsigned-long 32) + +#+new-compiler +(def-c-record sigcontext + (onstack unsigned-long) + (mask unsigned-long) + (pc system-area-pointer) + (regs int-array) + (mdlo unsigned-long) + (mdhi unsigned-long) + (ownedfp unsigned-long) + (fpregs int-array) + (fpc_csr unsigned-long) + (fpc_eir unsigned-long) + (cause unsigned-long) + (badvaddr system-area-pointer) + (badpaddr system-area-pointer)) (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)) @@ -72,7 +73,6 @@ (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)) @@ -81,7 +81,6 @@ (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) @@ -90,16 +89,20 @@ (eval-when (compile) (setq lisp::*bootstrap-defmacro* t)) -(defmacro sigmask (signal) - "Returns a mask given a signal." - `(ash 1 (1- ,(unix-signal-number signal)))) +(defmacro with-trap-arg-block (type var &body forms) + `(with-stack-alien (,var ,type (record-size ',type)) + ,@forms)) + +;;; SIGMASK -- Public +;;; +#-new-compiler +(defmacro sigmask (&rest signals) + "Returns a mask given a set of signals." + (apply #'logior + (mapcar #'(lambda (signal) + (ash 1 (1- (unix-signal-number signal)))) + signals))) -(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 index d59606850..b38bfc4df 100644 --- a/code/macros.lisp +++ b/code/macros.lisp @@ -7,13 +7,15 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.10 1990/08/24 18:11:50 wlott Exp $ +;;; ;;; 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) +(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 @@ -133,8 +135,12 @@ ;;; (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) + #+new-compiler + (setf (macro-function name) definition) + #-new-compiler + (progn + (setf (info function macro-function name) definition) + (setf (info function kind name) :macro)) (setf (documentation name 'function) doc) name) @@ -177,6 +183,11 @@ (defparameter deftype-error-string "Type ~S cannot be used with ~S args.") +#-new-compiler +(defvar *bootstrap-deftype* :both) + +(compiler-let ((*bootstrap-defmacro* :both)) + (defmacro deftype (name arglist &body body) "Syntax like DEFMACRO, but defines a new type." (unless (symbolp name) @@ -186,19 +197,37 @@ (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) - (%deftype ',name - #'(lambda (,whole) ,@local-decs (block ,name ,body)) - ,@(when doc `(,doc))))))) + :error-string 'deftype-error-string) + (let ((guts `(%deftype ',name + #'(lambda (,whole) + ,@local-decs + (block ,name ,body)) + ,@(when doc `(,doc))))) + #-new-compiler + (unless (member :new-compiler *features*) + (setf guts + `(let ((*bootstrap-deftype* ,*bootstrap-deftype*)) + ,guts))) + `(eval-when (compile load eval) + ,guts))))) + +); compile-let ;;; (defun %deftype (name expander &optional doc) - (setf (info type kind name) :defined) - (setf (info type expander name) expander) + #-new-compiler + (unless (or (eq *bootstrap-deftype* t) + (member :new-compiler *features*)) + (setf (get name 'deftype-expander) + expander)) + (when #-new-compiler *bootstrap-deftype* #+new-compiler t + (setf (info type kind name) :defined) + (setf (info type expander name) expander)) (when doc (setf (documentation name 'type) doc)) - (c::%note-type-defined name) + ;; ### Bootstrap hack -- we need to define types before %note-type-defined + ;; is defined. + (when (fboundp 'c::note-type-defined) + (c::%note-type-defined name)) name) @@ -507,9 +536,9 @@ ;; ### Bootstrap hack... ;; Ignore any DEFSETF info for structure accessors. ((info function accessor-for (car form)) - (get-setf-method-inverse form `(funcall #'(setf ,(car form))))) + (get-setf-method-inverse form `(funcall #'(setf ,(car form))) t)) ((setq temp (info setf inverse (car form))) - (get-setf-method-inverse form `(,temp))) + (get-setf-method-inverse form `(,temp) nil)) ((setq temp (info setf expander (car form))) (funcall temp form environment)) (t @@ -517,11 +546,11 @@ (macroexpand-1 form environment) (if win (foo-get-setf-method res environment) - (get-setf-method-inverse - form - `(funcall #'(setf ,(car form)))))))))) + (get-setf-method-inverse form + `(funcall #'(setf ,(car form))) + t))))))) -(defun get-setf-method-inverse (form inverse) +(defun get-setf-method-inverse (form inverse setf-function) (let ((new-var (gensym)) (vars nil) (vals nil)) @@ -530,7 +559,9 @@ (push x vals)) (setq vals (nreverse vals)) (values vars vals (list new-var) - `(,@inverse ,@vars ,new-var) + (if setf-function + `(,@inverse ,new-var ,@vars) + `(,@inverse ,@vars ,new-var)) `(,(car form) ,@vars)))) @@ -612,9 +643,11 @@ 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)))) + (setf (info setf documentation ',access-fn) ',doc))) + `((eval-when (load eval) + (or (clear-info setf documentation ',access-fn) + (setf (info setf documentation ',access-fn) + nil))))) ',access-fn))) (t (error "Ill-formed DEFSETF for ~S." access-fn)))) @@ -630,7 +663,7 @@ (cond ((atom (car args)) `(setq ,(car args) ,(cadr args))) ((info function accessor-for (caar args)) - `(funcall #'(setf ,(caar args)) ,@(cdar args) ,(cadr args))) + `(funcall #'(setf ,(caar args)) ,(cadr args) ,@(cdar args))) ((setq temp (info setf inverse (caar args))) `(,temp ,@(cdar args) ,(cadr args))) (t (multiple-value-bind (dummies vals newval setter getter) @@ -927,11 +960,14 @@ (defsetf elt %setelt) (defsetf aref %aset) +(defsetf row-major-aref %set-row-major-aref) (defsetf svref %svset) (defsetf char %charset) (defsetf bit %bitset) (defsetf schar %scharset) (defsetf sbit %sbitset) +(defsetf %array-dimension %set-array-dimension) +(defsetf %raw-bits %set-raw-bits) (defsetf symbol-value set) (defsetf symbol-function %sp-set-definition) (defsetf symbol-plist %sp-set-plist) @@ -940,6 +976,15 @@ (defsetf fill-pointer %set-fill-pointer) (defsetf search-list %set-search-list) +(defsetf sap-ref-8 %set-sap-ref-8) +(defsetf signed-sap-ref-8 %set-sap-ref-8) +(defsetf sap-ref-16 %set-sap-ref-16) +(defsetf signed-sap-ref-16 %set-sap-ref-16) +(defsetf sap-ref-32 %set-sap-ref-32) +(defsetf signed-sap-ref-32 %set-sap-ref-32) +(defsetf sap-ref-sap %set-sap-ref-sap) +(defsetf sap-ref-single %set-sap-ref-single) +(defsetf sap-ref-double %set-sap-ref-double) (define-setf-method getf (place prop &optional default &environment env) (multiple-value-bind (temps values stores set get) @@ -1021,21 +1066,35 @@ `(apply (function ,(car getter)) ,@(cdr getter))))))) +;;; Special-case a BYTE bytespec so that the compiler can recognize it. +;;; (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))))) + (if (and (consp bytespec) (eq (car bytespec) 'byte)) + (let ((n-size (gensym)) + (n-pos (gensym)) + (n-new (gensym))) + (values (list* n-size n-pos dummies) + (list* (second bytespec) (third bytespec) vals) + (list n-new) + `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos) + ,getter))) + ,setter + ,n-new) + `(ldb (byte ,n-size ,n-pos) ,getter))) + (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) @@ -1055,23 +1114,6 @@ `(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) diff --git a/code/misc.lisp b/code/misc.lisp index f6b13dffd..80e7d8680 100644 --- a/code/misc.lisp +++ b/code/misc.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/misc.lisp,v 1.3 1990/08/24 18:11:59 wlott Exp $ +;;; ;;; Assorted miscellaneous functions for Spice Lisp. ;;; ;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan. @@ -53,7 +55,7 @@ (info random-documentation stuff name)))))) string) -(defvar *features* '(:common :cmu :mach :ibm-rt-pc :new-compiler) +(defvar *features* '(:common :cmu :mach :decstation-3100 :pmax :new-compiler) "Holds a list of symbols that describe features provided by the implementation.") @@ -82,19 +84,11 @@ (defun machine-type () "Returns a string describing the type of the local machine." - "IBM RT PC") + "DECstation 3100") (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"))) + "DECstation 3100") (defun machine-instance () "Returns a string giving the name of the local machine." @@ -110,11 +104,11 @@ (defun short-site-name () "Returns a string with the abbreviated site name." - "CMU-CSD") + "CMU-SCS") (defun long-site-name () "Returns a string with the long form of the site name." - "Carnegie-Mellon University Computer Science Department") + "Carnegie-Mellon University School of Computer Science") diff --git a/code/pred.lisp b/code/pred.lisp index 50593f9fb..a4e387903 100644 --- a/code/pred.lisp +++ b/code/pred.lisp @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the Spice Lisp project at @@ -7,15 +7,21 @@ ;;; 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. +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.7 1990/08/24 18:12:12 wlott Exp $ ;;; -;;; Written and currently maintained by Scott Fahlman. -;;; Based on an earlier version by Joe Ginder. +;;; Predicate functions for CMU Common Lisp. ;;; -(in-package 'lisp) +;;; Written by William Lott. +;;; + +(in-package "EXTENSIONS") +(export '(structurep fixnump bignump bitp ratiop realp weak-pointer-p)) + +(in-package "SYSTEM") +(export '(system-area-pointer system-area-pointer-p)) + +(in-package "LISP" :use "KERNEL") + (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 @@ -25,487 +31,292 @@ 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 + null number ratio rational real 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. - -(defparameter 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) - (c::structure-vector . simple-vector-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. +;;;; Primitive predicates. These must be supported by the compiler. + +(eval-when (compile eval) + (defparameter primitive-predicates + '(array-header-p + arrayp + atom + base-char-p + bignump + bit-vector-p + characterp + consp + compiled-function-p + complexp + double-float-p + fixnump + floatp + functionp + integerp + listp + not + null + numberp + rationalp + ratiop + realp + simple-array-p + simple-bit-vector-p + simple-string-p + simple-vector-p + single-float-p + stringp + symbolp + system-area-pointer-p + weak-pointer-p + vectorp + c::unsigned-byte-32-p + c::signed-byte-32-p + c::simple-array-unsigned-byte-2-p + c::simple-array-unsigned-byte-4-p + c::simple-array-unsigned-byte-8-p + c::simple-array-unsigned-byte-16-p + c::simple-array-unsigned-byte-32-p + c::simple-array-single-float-p + c::simple-array-double-float-p + ))) + +(macrolet + ((frob () + `(progn + ,@(mapcar #'(lambda (pred) + `(defun ,pred (object) + ,(format nil + "Return T if OBJECT is a~:[~;n~] ~(~A~) ~ + and NIL otherwise." + (find (schar (string pred) 0) "AEIOUaeiou") + (string pred)) + (,pred object))) + primitive-predicates)))) + (frob)) + +;;;; TYPE-OF -- public. +;;; +;;; Return the specifier for the type of object. This is not simply +;;; (type-specifier (ctype-of object)) because ctype-of has different goals +;;; than type-of. +;;; (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. + "Return the type of OBJECT." + (typecase object + (null 'null) + (cons 'cons) + (character + (typecase object + (standard-char 'standard-char) + (base-character 'base-character) + (t 'character))) + (number + (etypecase object + (fixnum 'fixnum) + (bignum 'bignum) + (float + (etypecase object + (double-float 'double-float) + (single-float 'single-float) + (short-float 'short-float) + (long-float 'long-float))) + (ratio 'ratio) + (complex 'complex))) + (symbol (if (typep object 'keyword) + 'keyword + 'symbol)) + (structure + (%primitive c::structure-ref object 0)) + (array + (type-specifier (ctype-of object))) + (function + (type-specifier (ctype-of object))) + (t + (warn "Can't figure out the type of ~S" object) + t))) -(defun type-of-g-vector (object) - (if (structurep object) - (%primitive header-ref object - %g-vector-structure-name-slot) - `(simple-vector ,(%primitive vector-length object)))) - -;;; I-Vector-Element-Type -- Internal -;;; -;;; Return a type specifier for the element type of an I-Vector. + +;;;; SUBTYPEP -- public. ;;; -(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. +;;; Just parse the type specifiers and call csubtype. +;;; +(defun subtypep (type1 type2) + "Return two values indicating the relationship between type1 and type2: + T and T: type1 definatly is a subtype of type2. + NIL and T: type1 definatly is not a subtype of type2. + NIL and NIL: who knows?" + (csubtypep (specifier-type type1) (specifier-type type2))) -(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)) - - -;;; 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 *). +;;;; TYPEP -- public. ;;; -(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))))) +;;; Just call %typep +;;; +(defun typep (object type) + "Return T iff OBJECT is of type TYPE." + (declare (type (or list symbol) type)) + (%typep object type)) + +;;; %TYPEP -- internal. +;;; +;;; The actual typep engine. The compiler only generates calls to this +;;; function when it can't figure out anything more intelligent to do. +;;; +(defun %typep (object specifier) + (declare (type (or list symbol ctype) specifier)) + (let ((type (if (ctype-p specifier) + specifier + (specifier-type specifier)))) + (etypecase type + (named-type + (ecase (named-type-name type) + ((* t) + t) + ((nil) + nil) + (character (characterp object)) + (base-character (base-char-p object)) + (standard-char (and (characterp object) (standard-char-p object))) + (extended-character + (and (characterp object) (not (base-char-p object)))) + (function (functionp object)) + (cons (consp object)) + (symbol (symbolp object)) + (keyword + (and (symbolp object) + (eq (symbol-package object) + (symbol-package :foo)))) + (system-area-pointer (system-area-pointer-p object)) + (weak-pointer (weak-pointer-p object)) + (structure (structurep object)))) + (numeric-type + (and (numberp object) + (let ((num (if (complexp object) (realpart object) object))) + (ecase (numeric-type-class type) + (integer (integerp num)) + (rational (rationalp num)) + (float + (ecase (numeric-type-format type) + (short-float (typep object 'short-float)) + (single-float (typep object 'single-float)) + (double-float (typep object 'double-float)) + (long-float (typep object 'long-float)) + ((nil) (floatp num)))) + ((nil) t))) + (flet ((bound-test (val) + (let ((low (numeric-type-low type)) + (high (numeric-type-high type))) + (and (cond ((null low) t) + ((listp low) (> val (car low))) + (t (>= val low))) + (cond ((null high) t) + ((listp high) (< val (car high))) + (t (<= val high))))))) + (ecase (numeric-type-complexp type) + ((nil) t) + (:complex + (and (complexp object) + (let ((re (realpart object)) + (im (imagpart object))) + (and (bound-test (min re im)) + (bound-test (max re im)))))) + (:real + (and (not (complexp object)) + (bound-test object))))))) + (array-type + (and (arrayp object) + (ecase (array-type-complexp type) + ((t) (not (typep object 'simple-array))) + ((nil) (typep object 'simple-array)) + (* t)) + (or (eq (array-type-dimensions type) '*) + (do ((want (array-type-dimensions type) (cdr want)) + (got (array-dimensions object) (cdr got))) + ((and (null want) (null got)) t) + (unless (and want got + (or (eq (car want) '*) + (= (car want) (car got)))) + (return nil)))) + (or (eq (array-type-element-type type) *wild-type*) + (type= (array-type-specialized-element-type type) + (specifier-type (array-element-type object)))))) + (member-type + (if (member object (member-type-members type)) t)) + (structure-type + (structure-typep object (structure-type-name type))) + (union-type + (dolist (type (union-type-types type)) + (when (%typep object type) + (return t)))) + (unknown-type + (let ((orig-spec (unknown-type-specifier type))) + (if (eq type specifier) + ;; The type was unknown at compile time. Therefore, we should + ;; try again at runtime, 'cause it might be known now. + (%typep object orig-spec) + (error "Unknown type specifier: ~S" orig-spec)))) + (hairy-type + ;; Now the tricky stuff. + (let* ((hairy-spec (hairy-type-specifier type)) + (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) + (ecase symbol + (and + (or (atom hairy-spec) + (dolist (spec (cdr hairy-spec)) + (unless (%typep object spec) + (return nil))))) + (not + (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) + (error "Invalid type specifier: ~S" hairy-spec)) + (not (%typep object (cadr hairy-spec)))) + (satisfies + (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) + (error "Invalid type specifier: ~S" hairy-spec)) + (if (funcall (cadr hairy-spec) object) t))))) + (function-type + (error "Function types are not a legal argument to TYPEP:~% ~S" + specifier))))) ;;; 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. +;;; This is called by %typep when it tries to match against a structure type, +;;; and typep of types that are known to be structure types at compile time +;;; are converted to this. ;;; (defun structure-typep (object type) (declare (optimize speed)) - (let ((type (type-expand type))) - (if (symbolp type) - (let ((info (info type defined-structure-info type))) - (if info - (and (structurep object) - (let ((obj-name (%primitive header-ref object 0))) - (or (eq obj-name type) - (if (memq obj-name (c::dd-included-by info)) - t nil)))) - (error "~S is an unknown type specifier." type))) - (error "~S is an unknown type specifier." type)))) + (let ((info (info type defined-structure-info type))) + (if info + (and (structurep object) + (let ((obj-name (%primitive structure-ref object 0))) + (or (eq obj-name type) + (if (member obj-name (c::dd-included-by info) + :test #'eq) + t nil)))) + (error "~S is an unknown structure 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)) +;;;; Equality predicates. -(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. +;;; EQ -- public. +;;; +;;; Real simple, 'cause the compiler takes care of it. +;;; -(defun eq (x y) - "Returns T if X and Y are the same object, else returns NIL." - (eq x y)) +(defun eq (obj1 obj2) + "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL." + (eq obj1 obj2)) -(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)) +;;; EQUAL -- public. +;;; (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 @@ -537,8 +348,7 @@ (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)) + (unless (equal x-el y-el) (return nil))))))) ((bit-vector-p x) (and (bit-vector-p y) @@ -553,7 +363,8 @@ (return nil))))) (t nil))) - +;;; EQUALP -- public. +;;; (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 @@ -569,9 +380,8 @@ (equalp (cdr x) (cdr y)))) ((vectorp x) (let ((length (length x))) - (declare (fixnum length)) (and (vectorp y) - (= length (the fixnum (length y))) + (= length (length y)) (dotimes (i length t) (let ((x-el (aref x i)) (y-el (aref y i))) @@ -579,27 +389,14 @@ (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))))))))) + (and (arrayp y) + (= (array-rank x) (array-rank y)) + (dotimes (axis (array-rank x) t) + (unless (= (array-dimension x axis) + (array-dimension y axis)) + (return nil))) + (dotimes (index (array-total-size x) t) + (unless (equalp (row-major-aref x index) + (row-major-aref y index)) + (return nil))))) (t nil))) diff --git a/code/print.lisp b/code/print.lisp index efaf7d7c1..a86927029 100644 --- a/code/print.lisp +++ b/code/print.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.9 1990/08/24 18:12:20 wlott Exp $ +;;; ;;; CMU Common Lisp printer. ;;; ;;; Written by Neal Feinberg, Bill Maddox, Steven Handerson, and Skef Wholey. @@ -22,7 +24,7 @@ (defvar *print-escape* T "Flag which indicates that slashification is on. See the manual") -(defvar *print-pretty* T +(defvar *print-pretty* nil "Flag which indicates that pretty printing is to be used") (defvar *print-base* 10. "The output base for integers and rationals.") @@ -224,50 +226,48 @@ (>= currlevel (the fixnum *print-level*))) (write-char #\# stream) (typecase object - (symbol - (if *print-escape* - (output-symbol object stream) - (case *print-case* - (:upcase (write-string (symbol-name object) stream)) - (:downcase - (let ((name (symbol-name object))) - (declare (simple-string name)) - (dotimes (i (length name)) - (write-char (char-downcase (char name i)) stream)))) - (:capitalize - (write-string (string-capitalize (symbol-name object)) - stream))))) - ;; If a list, go through element by element, being careful - ;; about not running over the printlength - (list - (output-list object stream (1+ currlevel))) - (string - (if *print-escape* - (quote-string object stream) - (write-string object stream))) - (integer - (output-integer object stream)) - (float - (output-float object stream)) - (ratio - (output-ratio object stream)) - (complex - (output-complex object stream)) - (structure - (output-structure object stream currlevel)) - (character - (output-character object stream)) - (vector - #+new-compiler - (if (eql (%primitive get-type object) system:%code-type) - (output-random object stream) - (output-vector object stream)) - #-new-compiler - (output-vector object stream)) - (array - (output-array object stream (1+ currlevel))) - (t (output-random object stream))))) - + (symbol + (if *print-escape* + (output-symbol object stream) + (case *print-case* + (:upcase (write-string (symbol-name object) stream)) + (:downcase + (let ((name (symbol-name object))) + (declare (simple-string name)) + (dotimes (i (length name)) + (write-char (char-downcase (char name i)) stream)))) + (:capitalize + (write-string (string-capitalize (symbol-name object)) + stream))))) + ;; If a list, go through element by element, being careful + ;; about not running over the printlength + (list + (output-list object stream (1+ currlevel))) + (string + (if *print-escape* + (quote-string object stream) + (write-string object stream))) + (integer + (output-integer object stream)) + (float + (output-float object stream)) + (ratio + (output-ratio object stream)) + (complex + (output-complex object stream)) + (structure + (output-structure object stream currlevel)) + (character + (output-character object stream)) + (vector + (output-vector object stream)) + (array + (output-array object stream (1+ currlevel))) + (system-area-pointer + (output-sap object stream)) + (weak-pointer + (output-weak-pointer object stream)) + (t (output-random object stream))))) ;;;; Symbol Printing Subfunctions @@ -428,9 +428,9 @@ (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)))) + (return (not (null (%sp-find-character-with-attribute + name (1- index) len + attributes funny-attribute)))) START (when (digitp) (if (test letter) @@ -778,10 +778,10 @@ (sub-output-integer quotient stream)) ;; 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))) + (write-char (code-char (if (and (> remainder 9.) + (> *print-base* 10.)) + (+ (char-code #\A) (- remainder 10.)) + (+ (char-code #\0) remainder))) stream))) @@ -812,38 +812,53 @@ ;;; 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. +;;; Rewritten to remove assumptions about the length of fixnums for the +;;; MIPS port by William Lott. +;;; + +;;; *BASE-POWER* holds the number that we keep dividing into the bignum for +;;; each *print-base*. We want this number as close to *most-positive-fixnum* +;;; as possible, i.e. (floor (log most-positive-fixnum *print-base*)). +;;; +(defparameter *base-power* (make-array 36)) + +;;; *FIXNUM-POWER--1* holds the number of digits for each *print-base* that +;;; fit in the corresponding *base-power*. +;;; +(defparameter *fixnum-power--1* (make-array 36)) + +;;; PRINT-BIGNUM -- internal. ;;; -(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)) - +;;; Print the bignum to the stream. We first generate the correct value for +;;; *base-power* and *fixnum-power--1* if we have not already. Then we call +;;; bignum-print-aux to do the printing. +;;; (defun print-bignum (big stream) + (unless (aref *base-power* *print-base*) + (do ((power-1 -1 (1+ power-1)) + (new-divisor *print-base* (* new-divisor *print-base*)) + (divisor 1 new-divisor)) + ((not (fixnump new-divisor)) + (setf (aref *base-power* *print-base*) divisor) + (setf (aref *fixnum-power--1* *print-base*) power-1)))) (bignum-print-aux (cond ((minusp big) (write-char #\- stream) (- big)) - (t (copy-xnum big))) + (t big)) + (aref *base-power* *print-base*) + (aref *fixnum-power--1* *print-base*) stream) big) -(defun bignum-print-aux (big stream) - (multiple-value-bind (newbig fix) - (bignum-fixnum-divide-inplace - big (aref *base-power* *print-base*)) +;;; BIGNUM-PRINT-AUX -- internal. +;;; +(defun bignum-print-aux (big divisor power-1 stream) + (multiple-value-bind (newbig fix) (truncate big divisor) (if (fixnump newbig) (sub-output-integer newbig stream) - (bignum-print-aux newbig stream)) - (do ((zeros (aref *fixnum-power--1* *print-base*) (1- zeros)) + (bignum-print-aux newbig divisor power-1 stream)) + (do ((zeros power-1 (1- zeros)) (base-power *print-base* (* base-power *print-base*))) ((> base-power fix) (dotimes (i zeros) (write-char #\0 stream)) @@ -851,7 +866,6 @@ -;;;; Floating Point printing ;;; ;;; Written by Bill Maddox ;;; @@ -929,7 +943,8 @@ (defvar *digits* "0123456789") (defvar *digit-string* - (make-array 50 :element-type 'string-char :fill-pointer 0 :adjustable t)) + (make-array 50 :element-type 'base-character :fill-pointer 0 :adjustable t + :initial-element #\?)) ; ### Hack around make-array bug. (defun flonum-to-string (x &optional width fdigits scale fmin) (cond ((zerop x) @@ -940,15 +955,12 @@ (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)))))) + (setf (fill-pointer *digit-string*) 0) + (multiple-value-bind (sig exp) + (integer-decode-float x) + (float-string sig exp (float-digits x) 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) @@ -1062,40 +1074,34 @@ (values *digit-string* (1+ digits) (= decpnt 0) (= decpnt digits) decpnt))) -(defconstant short-log10-of-2 0.30103s0) - ;;; 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. - -;;; (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))))))))) + (let ((zero (float 0 x)) + (one (float 1 x)) + (ten (float 10 x)) + (one-tenth (float 1/10 x)) + (log10-of-2 (float (log 2l0 10) x))) + (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. @@ -1104,65 +1110,70 @@ ;;; 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 +;;; 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. +;;; large exponents, the bignums really get out of hand. If bignum arithmetic +;;; becomes reasonably fast and the exponent range is not too large, then it +;;; might become 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 stream) - (if (typep x 'short-float) - (output-float-aux x stream 1.0s-3 1.0s7) - (output-float-aux x stream %long-float1l-3 %long-float1l7))) +;;; PRINT-FLOAT-EXPONENT -- Internal +;;; +;;; Print the appropriate exponent marker for X and the specified exponent. +;;; +(defun print-float-exponent (x exp stream) + (declare (float x) (integer exp) (stream stream)) + (let ((*print-radix* nil) + (plusp (plusp exp))) + (if (typep x *read-default-float-format*) + (unless (eql exp 0) + (format stream "e~:[~;+~]~D" plusp exp)) + (format stream "~A~:[~;+~]~D" + (etypecase x + (single-float #\f) + (double-float #\d) + (short-float #\s) + (long-float #\L)) + plusp exp)))) +(defun output-float (x stream) + (let ((x (cond ((minusp (float-sign x)) + (write-char #\- stream) + (- x)) + (t + x)))) + (cond ((zerop x) + (write-string "0.0" stream) + (print-float-exponent x 0 stream)) + (t + (output-float-aux x stream (float 1/1000 x) (float 10000000 x)))))) +;;; (defun output-float-aux (x stream e-min e-max) - (cond ((zerop x) - (write-string "0.0" stream) - (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") stream))) - (t (when (minusp x) - (write-char #\- stream) - (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 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - (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") - stream))) - ;;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 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - (write-char (if (typep x *read-default-float-format*) - #\E - (if (typep x 'short-float) #\S #\L)) - stream) - ;;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 #\+ stream)) - (output-integer (1- ex) stream))))))) + (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 stream)) + (write-string str stream) + (when tpoint (write-char #\0 stream)) + (print-float-exponent x 0 stream)) + ;;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 stream)) + (write-string str stream) + (when tpoint (write-char #\0 stream)) + ;; subtract out scale factor of 1 passed to flonum-to-string + (print-float-exponent x (1- ex) stream))))) ;;;; Output Character @@ -1171,9 +1182,11 @@ ;;; 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))))) +; (and (not (zerop (char-bits ,char))) +; (not (zerop (logand (aref character-attributes (char-code ,char)) +; funny-attribute)))) + `(not (zerop (logand (aref character-attributes (char-code ,char)) + funny-attribute)))) ;;; OUTPUT-CHARACTER -- Internal ;;; @@ -1183,23 +1196,15 @@ ;;; itself to the stream. ;;; (defun output-character (char stream) - (let ((base (make-char char))) - (if *print-escape* - (let ((name (char-name base))) - (write-string "#\\" stream) - (macrolet ((frob (key string) - `(when (char-bit char ,key) - (write-string ,string stream)))) - (frob :control "CONTROL-") - (frob :meta "META-") - (frob :super "SUPER-") - (frob :hyper "HYPER-")) - (cond (name (write-string name stream)) - (t - (when (funny-character-char-p char) - (write-char #\\ stream)) - (write-char base stream)))) - (write-char base stream)))) + (if *print-escape* + (let ((name (char-name char))) + (write-string "#\\" stream) + (cond (name (write-string name stream)) + (t + (when (funny-character-char-p char) + (write-char #\\ stream)) + (write-char char stream)))) + (write-char char stream))) @@ -1211,35 +1216,9 @@ ;;; below. (defun output-function-object (subr stream) - (let ((name (%primitive header-ref subr %function-name-slot))) - (case (%primitive get-vector-subtype subr) - (#.%function-entry-subtype - (if (stringp name) - (format stream "Internal Function ~S" name) - (format stream "Function ~S" name))) - (#.%function-closure-subtype - (if (eval:interpreted-function-p subr) - (multiple-value-bind - (def ignore name) - (eval:interpreted-function-lambda-expression subr) - (declare (ignore ignore)) - (let ((*print-level* 3)) - (format stream "Interpreted Function ~S" (or name def)))) - (format stream "Closure ~S" - (%primitive header-ref name %function-name-slot)))) - (#.%function-closure-entry-subtype - (format stream "Closure Entry ~S" name)) - (#.%function-constants-subtype - (format stream "Function Constants ~S" name)) - (#.%function-value-cell-subtype - (assert (= %function-value-cell-value-slot %function-name-slot)) - (format stream "Indirect Value Cell ~S" name)) - #| - (#.%function-funcallable-instance-subtype - (format stream "Funcallable Instance ~S" name)) - |# - (t (error "Unknown function subtype."))))) - + (let ((name (%primitive c::function-name subr))) + (write-string "Function " stream) + (prin1 name stream))) ;;; FINISH-RANDOM is a helping function for OUTPUT-RANDOM below. ;;; It outputs the numerical value of the low 28 bits of @@ -1258,9 +1237,58 @@ (defun output-random (object stream) (write-string "#<" stream) - (if (compiled-function-p object) - (output-function-object object stream) - (let ((type (%primitive get-type object))) - (write-string "Pointer into Hell, level " stream) - (sub-output-integer type stream))) + (let ((lowtag (get-lowtag object))) + (case lowtag + ((#.vm:other-pointer-type #.vm:function-pointer-type) + (let ((type (get-type object))) + (case type + (#.vm:code-header-type + (write-string "Code Object" stream)) + ((#.vm:function-header-type #.vm:closure-function-header-type) + (output-function-object object stream)) + (#.vm:return-pc-header-type + (write-string "Return PC Object" stream)) + (#.vm:closure-header-type + (write-string "Closure Over " stream) + (output-function-object (%primitive c::closure-function object) + stream)) + (#.vm:value-cell-header-type + (write-string "Value Cell" stream)) + (#.vm:unbound-marker-type + (write-string "Unbound Marker" stream)) + (t + (write-string "Unknown Object, type=" stream) + (let ((*print-base* 16) (*print-radix* t)) + (output-integer type stream)))))) + (#.vm:structure-pointer-type + (write-string "Structure?")) + (#.vm:list-pointer-type + (write-string "List?")) + (t + (write-string "Unknown Immediate Object, lowtag=" stream) + (let ((*print-base* 2) (*print-radix* t)) + (output-integer lowtag stream)) + (write-string ", type=" stream) + (let ((*print-base* 16) (*print-radix* t)) + (output-integer (get-type object) stream))))) (finish-random object stream)) + + +(defun output-sap (sap stream) + (declare (type system-area-pointer sap)) + (write-string "#<System-Area pointer: " stream) + (let ((*print-base* 16) (*print-radix* t)) + (output-integer (sap-int sap) stream)) + (write-char #\> stream)) + +(defun output-weak-pointer (weak-pointer stream) + (declare (type weak-pointer weak-pointer)) + (multiple-value-bind + (value validp) + (weak-pointer-value weak-pointer) + (cond (validp + (write-string "#<Weak Pointer: " stream) + (write value :stream stream) + (write-char #\> stream)) + (t + (write-string "#<Broken Weak Pointer>"))))) diff --git a/code/purify.lisp b/code/purify.lisp index c41786d68..34912dc99 100644 --- a/code/purify.lisp +++ b/code/purify.lisp @@ -23,6 +23,22 @@ ;;; (in-package 'lisp) + +(def-c-routine ("purify" %purify) (int) + (roots unsigned-long)) + +(defun purify (&key root-structures) + (write-string "[Doing purification: ") + (force-output) + (without-gcing + (%purify (di::get-lisp-obj-address root-structures))) + (write-line "Done.]") + (force-output) + nil) + + +#| + (defun purify (&key root-structures) (declare (special lisp-environment-list)) (setq lisp-environment-list NIL) @@ -534,3 +550,5 @@ (if (save file) (quit) (funcall root-function)))) + +|# diff --git a/code/reader.lisp b/code/reader.lisp index 717b6c4f8..e2bd37606 100644 --- a/code/reader.lisp +++ b/code/reader.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.3 1990/08/24 18:12:38 wlott Exp $ +;;; ;;; Spice Lisp Reader ;;; Written by David Dill ;;; Package system interface by Lee Schumacher. @@ -108,20 +110,20 @@ (defmacro get-cat-entry (char rt) ;;only give this side-effect-free args. `(elt (the simple-vector (character-attribute-table ,rt)) - (char-int ,char))) + (char-code ,char))) (defun set-cat-entry (char newvalue &optional (rt *readtable*)) (setf (elt (the simple-vector (character-attribute-table rt)) - (char-int char)) + (char-code char)) newvalue)) (defmacro get-cmt-entry (char rt) `(elt (the simple-vector (character-macro-table ,rt)) - (char-int ,char))) + (char-code ,char))) (defun set-cmt-entry (char newvalue &optional (rt *readtable*)) (setf (elt (the simple-vector (character-macro-table rt)) - (char-int char)) + (char-code char)) newvalue)) (defun make-character-attribute-table () @@ -172,7 +174,7 @@ (defvar secondary-attribute-table ()) (defun set-secondary-attribute (char attribute) - (setf (elt (the simple-vector secondary-attribute-table) (char-int char)) + (setf (elt (the simple-vector secondary-attribute-table) (char-code char)) attribute)) @@ -186,9 +188,9 @@ (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)) + (do ((i (char-code #\0) (1+ i))) + ((> i (char-code #\9))) + (set-secondary-attribute (code-char i) #.constituent-digit)) (set-secondary-attribute #\E #.constituent-expt) (set-secondary-attribute #\F #.constituent-expt) (set-secondary-attribute #\D #.constituent-expt) @@ -202,7 +204,7 @@ (defmacro get-secondary-attribute (char) `(elt (the simple-vector secondary-attribute-table) - (char-int ,char))) + (char-code ,char))) @@ -283,7 +285,7 @@ (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) + ((/= (the fixnum (svref attribute-table (char-code char))) #.whitespace) (done-with-fast-read-char) char)))) @@ -318,7 +320,7 @@ (do ((ichar 0 (1+ ichar)) (char)) ((= ichar #O200)) - (setq char (int-char ichar)) + (setq char (code-char ichar)) (when (constituentp char std-lisp-readtable) (set-cat-entry char (get-secondary-attribute char)) (set-cmt-entry char #'read-token))))) @@ -597,7 +599,7 @@ ;;; return the character class for a char ;;; (defmacro char-class (char attable) - `(let ((att (svref ,attable (char-int ,char)))) + `(let ((att (svref ,attable (char-code ,char)))) (declare (fixnum att)) (if (<= att #.terminating-macro) #.delimiter @@ -607,7 +609,7 @@ ;;; number ;;; (defmacro char-class2 (char attable) - `(let ((att (svref ,attable (char-int ,char)))) + `(let ((att (svref ,attable (char-code ,char)))) (declare (fixnum att)) (if (<= att #.terminating-macro) #.delimiter @@ -621,7 +623,7 @@ ;;; floating number (assume that it is a digit if it could be) ;;; (defmacro char-class3 (char attable) - `(let ((att (svref ,attable (char-int ,char)))) + `(let ((att (svref ,attable (char-code ,char)))) (declare (fixnum att)) (if possibly-rational (setq possibly-rational @@ -1085,24 +1087,10 @@ ;;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))))))) + (coerce (/ number divisor) float-format)) + (defun make-ratio () ;;assume read-buffer contains a legal ratio. Build the number from @@ -1168,7 +1156,7 @@ :test #'char= :key #'car))) (if dpair (setf (elt (the simple-vector (cdr dpair)) - (char-int sub-char)) + (char-code sub-char)) function) (error "~S is not a dispatch char." disp-char)))) @@ -1181,7 +1169,7 @@ :test #'char= :key #'car))) (if dpair (elt (the simple-vector (cdr dpair)) - (char-int sub-char)) + (char-code sub-char)) (error "~S is not a dispatch char." disp-char)))) (defun read-dispatch-char (stream char) @@ -1205,7 +1193,7 @@ :test #'char= :key #'car))) (if dpair (funcall (elt (the simple-vector (cdr dpair)) - (char-int sub-char)) + (char-code sub-char)) stream sub-char (if numargp numarg nil)) (error "No dispatch table for dispatch char."))))) diff --git a/code/save.lisp b/code/save.lisp index 9b9f0568d..29b81f2b4 100644 --- a/code/save.lisp +++ b/code/save.lisp @@ -8,7 +8,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.1.1.5 1990/07/26 19:12:33 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.2 1990/08/24 18:13:22 wlott Exp $ ;;; ;;; Dump the current lisp image into a core file. All the real work is done ;;; be C. diff --git a/code/seq.lisp b/code/seq.lisp index 10f16043e..07a3895b1 100644 --- a/code/seq.lisp +++ b/code/seq.lisp @@ -48,7 +48,7 @@ "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) +(defmacro type-specifier-atom (type) "Returns the broad class of which TYPE is a specific subclass." `(if (atom ,type) ,type (car ,type))) @@ -59,10 +59,11 @@ (defun make-sequence-of-type (type length) "Returns a sequence of the given TYPE and LENGTH." (declare (fixnum length)) - (case (type-specifier type) + (case (type-specifier-atom type) (list (make-list length)) ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2))) - ((string simple-string) (make-string length)) + ((string simple-string base-string simple-base-string) + (make-string length)) (simple-vector (make-array length)) ((array simple-array vector) (if (listp type) @@ -101,19 +102,15 @@ (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)))) + (etypecase sequence + (vector (length (truly-the vector sequence))) + (list (length (truly-the list 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))) + (let ((type (kernel::type-expand type))) (cond ((subtypep type 'list) (make-list length :initial-element initial-element)) ((subtypep type 'string) @@ -532,10 +529,10 @@ "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) + (case (type-specifier-atom output-type-spec) (list (apply #'concat-to-list* sequences)) ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector) + bit-vector simple-bit-vector base-string simple-base-string) (apply #'concat-to-simple* output-type-spec sequences)) (t (error "~S: invalid output type specification." output-type-spec)))) @@ -608,11 +605,11 @@ 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) + (case (type-specifier-atom 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) + bit-vector simple-bit-vector base-string simple-base-string) (map-to-simple output-type-spec function sequences)) (t (error "~S: invalid output type specifier." output-type-spec))))) @@ -749,9 +746,10 @@ (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)) + ((short-float single-float float) + (%single-float object)) + ((double-float long-float) + (%double-float object)) (complex (complex object)) (t @@ -759,43 +757,46 @@ (t (typecase object (list - (case (type-specifier output-type-spec) - ((simple-string string) (list-to-string* object)) + (case (type-specifier-atom output-type-spec) + ((simple-string string simple-base-string base-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) + (case (type-specifier-atom 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) + (case (type-specifier-atom 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) + (case (type-specifier-atom output-type-spec) (list (vector-to-list* object)) - ((simple-string string) (vector-to-string* object)) + ((simple-string string simple-base-string base-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) + (case (type-specifier-atom output-type-spec) (list (vector-to-list* object)) - (simple-string (string-to-simple-string* object)) + ((simple-string simple-base-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) + (case (type-specifier-atom 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)) @@ -803,9 +804,10 @@ (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) + (case (type-specifier-atom output-type-spec) (list (vector-to-list* object)) - ((simple-string string) (vector-to-string* object)) + ((simple-string string base-string simple-base-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)) @@ -818,10 +820,10 @@ (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)) + (length (length (the ,(case src-type + (:list 'list) + (:vector 'vector)) + object))) (result ,result)) ((= index length) result) (declare (fixnum length index)) @@ -861,8 +863,7 @@ object (with-array-data ((data object) (start) - (end (%primitive header-ref object - %array-fill-pointer-slot))) + (end (length object))) (declare (simple-string data)) (subseq data start end)))) @@ -871,8 +872,7 @@ object (with-array-data ((data object) (start) - (end (%primitive header-ref object - %array-fill-pointer-slot))) + (end (length object))) (declare (simple-bit-vector data)) (subseq data start end)))) diff --git a/code/serve-event.lisp b/code/serve-event.lisp index c6ac2df64..c7ab73168 100644 --- a/code/serve-event.lisp +++ b/code/serve-event.lisp @@ -32,6 +32,8 @@ "*In-server* is set to T when the SIGMSG interrupt has been enabled in Server.") +#| + (defvar server-unique-object (cons 1 2) "Object thrown by the message interrupt handler.") @@ -78,6 +80,7 @@ (unless (eql gr mach:kern-success) (gr-error 'server gr))))))) mach:kern-success) +|# ;;;; File descriptor IO noise. @@ -279,6 +282,7 @@ seconds) and then return, otherwise it will wait until something happens. Server returns T if something happened and NIL otherwise." ;; First, check any X displays for any pending events. + #+nil (dolist (d/h *display-event-handlers*) (let ((d (car d/h))) (when (xlib::event-listen d) @@ -292,7 +296,8 @@ (value readable writeable) (wait-for-event timeout) ;; Now see what it was (if anything) - (cond ((eq value server-unique-object) + (cond #+nil + ((eq value server-unique-object) ;; The interrupt handler fired. (grab-message-loop) t) @@ -349,19 +354,17 @@ (unwind-protect (progn ;; Block message interrupts. - (multiple-value-bind - (noise mask) - (mach:unix-sigsetmask (mach:sigmask :sigmsg)) - (declare (ignore noise)) - (setf old-mask mask)) + (setf old-mask (mach:unix-sigblock (mach:sigmask :sigmsg))) ;; Check for any pending messages, because we are only signaled ;; for newly arived messages. This must be done after the ;; unix-sigsetmask. + #+nil (when (grab-message-loop) (return-from wait-for-event t)) ;; Indicate that we are in the server. (let ((*in-server* t)) ;; Establish the interrupt handlers. + #+nil (enable-interrupt mach:sigmsg #'ih-sigmsg) ;; Enable all interrupts. (mach:unix-sigsetmask 0) @@ -369,8 +372,8 @@ (mach:unix-select count read-mask write-mask except-mask timeout-sec timeout-usec))) ;; Restore interrupt handler state. - (mach:unix-sigsetmask (mach:sigmask :sigmsg)) + #+nil + (mach:unix-sigblock (mach:sigmask :sigmsg)) + #+nil (default-interrupt mach:sigmsg) (mach:unix-sigsetmask old-mask))))))) - - diff --git a/code/stream.lisp b/code/stream.lisp index a59b83484..d2c821dc3 100644 --- a/code/stream.lisp +++ b/code/stream.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.4 1990/08/24 18:14:16 wlott Exp $ +;;; ;;; Stream functions for Spice Lisp. ;;; Written by Skef Wholey and Rob MacLachlan. ;;; @@ -190,25 +192,27 @@ (index (stream-in-index stream))) (declare (fixnum index)) (if (simple-string-p buffer) - (let ((nl (%primitive find-character buffer index in-buffer-length - #\newline))) + (let ((nl (%sp-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)))) + (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)))) + (let ((first (subseq buffer index in-buffer-length))) + (setf (stream-in-index stream) in-buffer-length) + (if (eq str eof-value) + (values first t) + (values (concatenate 'simple-string first + (the simple-string str)) + 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. @@ -304,7 +308,8 @@ (cond ((not in-buffer) (with-in-stream stream stream-n-bin buffer start numbytes eof-errorp)) - ((not (eql (%primitive get-vector-access-code in-buffer) 3)) + ((not (typep in-buffer + '(or simple-string (simple-array (unsigned-byte 8) (*))))) (error "N-Bin only works on 8-bit-like streams.")) ((<= numbytes num-buffered) (%primitive byte-blt in-buffer index buffer start (+ start numbytes)) @@ -773,7 +778,7 @@ (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))) + (let ((pos (position #\newline string :start current :end end))) (if pos (let* ((res-length (- (the fixnum pos) current)) (result (make-string res-length))) @@ -908,7 +913,7 @@ (defun fill-pointer-ouch (stream character) (let* ((buffer (fill-pointer-output-stream-string stream)) - (current (%primitive header-ref buffer %array-fill-pointer-slot)) + (current (fill-pointer buffer)) (current+1 (1+ current))) (declare (fixnum current)) (with-array-data ((workspace buffer) (start) (end)) @@ -924,7 +929,7 @@ (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 (fill-pointer buffer) current+1)) (setf (schar workspace offset-current) character))) current+1)) @@ -932,7 +937,7 @@ (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)) + (current (fill-pointer buffer)) (string-len (- end start)) (dst-end (+ string-len current))) (declare (fixnum current dst-end string-len)) @@ -951,7 +956,7 @@ (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)) + (setf (fill-pointer buffer) dst-end)) (%primitive byte-blt string start workspace offset-current offset-dst-end))) dst-end)) @@ -962,7 +967,7 @@ (case operation (:charpos (let* ((buffer (fill-pointer-output-stream-string stream)) - (current (%primitive header-ref buffer %array-fill-pointer-slot))) + (current (fill-pointer buffer))) (with-array-data ((string buffer) (start) (end current)) (declare (simple-string string) (ignore start)) (let ((found (position #\newline string :test #'char= diff --git a/code/symbol.lisp b/code/symbol.lisp index 8c1870872..2bf98e669 100644 --- a/code/symbol.lisp +++ b/code/symbol.lisp @@ -29,7 +29,11 @@ (defun makunbound (variable) "VARIABLE must evaluate to a symbol. This symbol is made unbound, removing any value it may currently have." - (makunbound variable)) + (set variable + (%primitive make-other-immediate-type + 0 + vm:unbound-marker-type)) + variable) (defun symbol-value (variable) "VARIABLE must evaluate to a symbol. This symbol's current special @@ -82,19 +86,17 @@ (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) + (do ((pl (symbol-plist symbol) (cddr pl))) + ((endp pl) (setf (symbol-plist symbol) (list* indicator value (symbol-plist symbol))) value) - (cond ((atom (cdr pl)) + (cond ((endp (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))))|# - ) + (return value))))) (defun remprop (symbol indicator) "Look on property list of SYMBOL for property with specified @@ -125,8 +127,14 @@ ((eq (car plist) indicator) (return (cadr plist)))))) -(defun %putf (x y z) - (%primitive putf x y z)) +(defun %putf (place property new-value) + (declare (type list place)) + (do ((plist place (cddr plist))) + ((endp plist) (list* property new-value place)) + (declare (type list plist)) + (when (eq (car plist) property) + (setf (cadr plist) new-value) + (return place)))) (defun get-properties (place indicator-list) diff --git a/code/time.lisp b/code/time.lisp index 0b99f9bb1..031e4788a 100644 --- a/code/time.lisp +++ b/code/time.lisp @@ -22,6 +22,10 @@ "The number of internal time units that fit into a second. See Get-Internal-Real-Time and Get-Internal-Run-Time.") +(defconstant micro-seconds-per-internal-time-unit + (/ 1000000 internal-time-units-per-second)) + + (defmacro not-leap-year (year) (let ((sym (gensym))) `(let ((,sym ,year)) @@ -32,47 +36,29 @@ ;;; 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) + (if result + (+ (* seconds internal-time-units-per-second) + (truncate useconds micro-seconds-per-internal-time-unit)) (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) + (if result + (values (truncate (+ utime stime) + micro-seconds-per-internal-time-unit)) (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 diff --git a/code/tty-inspect.lisp b/code/tty-inspect.lisp index e3c3e4acf..0a66b3206 100644 --- a/code/tty-inspect.lisp +++ b/code/tty-inspect.lisp @@ -31,6 +31,10 @@ ;;; (defvar *tty-object-stack* ()) +;;; ### Copied from inspect.lisp. Remove after it is up. +(defparameter inspect-length 10) +(defparameter inspect-level 1) + (proclaim '(inline numbered-parts-p)) (defun numbered-parts-p (parts) (second parts)) @@ -42,7 +46,9 @@ (cdr (nth (+ n parts-offset) parts)) (nth (+ n parts-offset) parts))) -(defun tty-inspect (object) +;;; ### Change name back to tty-inspect when we have the real inspector up. +;;; +(defun inspect (object) (unwind-protect (input-loop object (describe-parts object) *standard-output*) (setf *tty-object-stack* nil))) @@ -55,6 +61,7 @@ (tty-display-object parts s) (loop (format s "~&> ") + (force-output) (let ((command (read)) ;; Use 2 less than length because first 2 elements are bookkeeping. (parts-len-2 (- (length parts) 2))) @@ -157,37 +164,29 @@ (defun describe-structure-parts (object) (let ((dd-slots (c::dd-slots - (ext:info type defined-structure-info - (system:%primitive header-ref object - system:%g-vector-structure-name-slot)))) + (ext:info type defined-structure-info (type-of object)))) (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))) + (funcall (c::dsd-accessor dd-slot) object)) parts-list)))) (defun describe-function-parts (object) - (let ((object (if (= (system:%primitive get-vector-subtype object) - system:%function-closure-subtype) - (system:%primitive header-ref object - system:%function-name-slot) - object))) + (let* ((type (kernel:get-type object)) + (object (if (= type vm:closure-header-type) + (kernel:%closure-function object) + object))) (list (format nil "Function ~s.~%Argument List: ~a." object - (system:%primitive header-ref object - lisp::%function-entry-arglist-slot) - #|### - (system:%primitive header-ref object - lisp::%function-defined-from-slot) - ~%Defined from: ~a - |# + (lisp::%function-header-arglist object) + ;; Defined from stuff used to be here. Someone took it out. ) t))) (defun describe-vector-parts (object) (list* (format nil "Object is a ~:[~;displaced ~]vector of length ~d.~%" - (lisp::%displacedp object) (length object)) + (lisp::%array-displaced-p object) (length object)) nil (coerce object 'list))) @@ -196,6 +195,19 @@ nil object)) +;;; ### Copied from inspect.lisp. Remove when it is up. +;;; +(defun index-string (index rev-dimensions) + (if (null rev-dimensions) + "[]" + (let ((list nil)) + (dolist (dim rev-dimensions) + (multiple-value-bind (q r) + (floor index dim) + (setq index q) + (push r list))) + (format nil "[~D~{,~D~}]" (car list) (cdr list))))) + (defun describe-array-parts (object) (let* ((length (min (array-total-size object) inspect-length)) (reference-array (make-array length :displaced-to object)) @@ -203,7 +215,7 @@ (parts ())) (push (format nil "Object is ~:[a displaced~;an~] array of ~a.~%~ Its dimensions are ~s.~%" - (array-element-type object) (lisp::%displacedp object) + (array-element-type object) (lisp::%array-displaced-p object) dimensions) parts) (push t parts) diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp index 4f1c6eca4..d62a2c1da 100644 --- a/tools/worldcom.lisp +++ b/tools/worldcom.lisp @@ -10,114 +10,98 @@ (in-package "USER") -(c::%proclaim '(optimize (speed 2) (space 2) (c::brevity 2))) -(setq *print-pretty* nil) +(setf *new-compile* t) -(with-compiler-log-file ("code:compile-lisp.log") +(with-compiler-log-file ("target:compile-lisp.log") ;;; these guys need to be first. -(comf "code:globals" :always-once t) ; For global variables. -(comf "code: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 "code:serve-event") -(comf "code:lispinit") -(comf "code:error") -(comf "code:alieneval") -(comf "code:stream") -(comf "code:arith") -(comf "code:array") -(comf "code:backq") -(comf "code:c-call") -(comf "code:char") -(comf "code:list") -;(comf "code:clx-ext") -(comf "code:commandline") -(comf "code:eval") -(comf "code:debug-info") -(comf "code:debug-int") -(comf "code:debug") -(comf "code:trace") -(comf "code:extensions") -(comf "code:fd-stream") -(comf "code:fdefinition") -(comf "code:filesys") -(comf "code:format") -(comf "code:hash") -(comf "code:lfloatcon") -(comf "code:load") -(comf "code:miscop") -(comf "code:package") -(comf "code:rompstrops") -(comf "code:pred") -(comf "code:print") -(comf "code:provide") -(comf "code:query") -(comf "code:rand") -(comf "code:reader") -(comf "code:rompnum") -(comf "code:salterror") -(comf "code:save") -(comf "code:search-list") -(comf "code:seq") -(comf "code:sharpm") -(comf "code:sort") -(comf "code:type-boot") -(comf "code:run-program") -(comf "code:spirrat") -(comf "code:xp") -(comf "code:xp-patch") -(comf "code:pprint") -(comf "code:string") -(comf "code:subtypep") -(comf "code:symbol") -(comf "code:syscall") -(comf "code:sysmacs") -(comf "code:time") -(comf "code:foreign") -(comf "c:proclaim") +(comf "target:code/globals" :always-once t) ; For global variables. +(comf "target:code/struct" :always-once t) ; For structures. + + +;;; Assembly files. +(comf "target:assembly/assem-rtns" :assem t) +(comf "target:assembly/array" :assem t) +(comf "target:assembly/bit-bash" :assem t) + +(comf "target:compiler/type") +(comf "target:compiler/mips/vm-type") +(comf "target:compiler/type-init") + +(comf "target:code/serve-event") +(comf "target:code/lispinit") +(comf "target:code/error") +(comf "target:code/alieneval") +(comf "target:code/stream") +(comf "target:code/arith") +(comf "target:code/array") +(comf "target:code/backq") +(comf "target:code/c-call") +(comf "target:code/char") +(comf "target:code/list") +;(comf "target:code/clx-ext") +(comf "target:code/commandline") +(comf "target:code/eval") +(comf "target:code/debug") +(comf "target:code/trace") +(comf "target:code/extensions") +(comf "target:code/fd-stream") +(comf "target:code/fdefinition") +(comf "target:code/filesys") +(comf "target:code/format") +(comf "target:code/hash") +;(comf "target:code/lfloatcon") +(comf "target:code/load") +;(comf "target:code/miscop") +(comf "target:code/package") +(comf "target:code/mipsstrops") +(comf "target:code/pred") +(comf "target:code/print") +(comf "target:code/provide") +(comf "target:code/query") +(comf "target:code/rand") +(comf "target:code/reader") +(comf "target:code/mipsnum") +(comf "target:code/salterror") +;(comf "target:code/save") +(comf "target:code/search-list") +(comf "target:code/seq") +(comf "target:code/sharpm") +(comf "target:code/sort") +(comf "target:code/type-boot") +(comf "target:code/run-program") +;(comf "target:code/spirrat") +;(comf "target:code/xp") +;(comf "target:code/xp-patch") +;(comf "target:code/pprint") +(comf "target:code/string") +(comf "target:code/symbol") +(comf "target:code/syscall") +(comf "target:code/sysmacs") +(comf "target:code/time") +;(comf "target:code/foreign") +(comf "target:compiler/proclaim") +(comf "target:compiler/knownfun") +(comf "target:code/debug-info") ;;; Later so that miscellaneous structures are defined (not crucial, but nice.) -(comf "code:describe") -;(comf "code:inspect") -(comf "code:tty-inspect") - -(comf "code:purify") -(comf "code:gc") -(comf "code:misc") -(comf "code:format-time") -(comf "code:parse-time") - -(comf "code:internet") -(comf "code:wire") -(comf "code:remote") - -(comf "assem:ropdefs") -(comf "assem:rompconst") -(comf "assem:disassemble") -#+new-compiler -(comf "assem:assem") -#+new-compiler -(comf "assem:assembler") - -(comf "code:machdef") -(comf "code:mmlispdefs") -(comf "icode:machdefs") -(comf "icode:netnamedefs") - -(let ((system:*alien-eval-when* '(compile eval))) - (unless (probe-file "icode:machuser.nfasl") - (load "icode:machmsgdefs.lisp") - (comf "icode:machuser")) - - (unless (probe-file "icode:netnameuser.nfasl") - (load "icode:netnamemsgdefs.lisp") - (comf "icode:netnameuser"))) +(comf "target:code/describe") +;(comf "target:code/inspect") +(comf "target:code/tty-inspect") + +;(comf "target:code/purify") +;(comf "target:code/gc") +(comf "target:code/misc") +(comf "target:code/format-time") +(comf "target:code/parse-time") + +(comf "target:code/internet") +(comf "target:code/wire") +(comf "target:code/remote") + -(comf "code:constants") +;(comf "target:code/constants") ;;; Compile basic macros that we assume are already in the compilation ;;; environment. We inhibit compile-time definition to prevent these functions @@ -127,11 +111,11 @@ ;;; definition of a macro which uses itself. ;;; (let ((c:*compile-time-define-macros* nil)) - (comf "code:defstruct") - (comf "code:defmacro") - (comf "code:macros") - (comf "code:defrecord") + (comf "target:code/defstruct") + (comf "target:code/defmacro") + (comf "target:code/macros") + (comf "target:code/defrecord") - (comf "c:globaldb")) + (comf "target:compiler/globaldb")) ); with-compiler-log-file diff --git a/tools/worldload.lisp b/tools/worldload.lisp index a9d83d236..a2d857546 100644 --- a/tools/worldload.lisp +++ b/tools/worldload.lisp @@ -12,24 +12,27 @@ ;;; the resulting core image. It writes "lisp.core" in the DEFAULT-DIRECTORY. ;;; - -#| Can't eval conditionals now... -;;; Setup some packages. +;;; Define a bunch of search lists relative to lisp: ;;; -(unless (eq *package* (find-package "USER")) - (error "Set *package* to the User package and try again.")) -|# +(setf (ext:search-list "code:") '("lisp:code/")) +(setf (ext:search-list "c:") '("lisp:compiler/")) +(setf (ext:search-list "mips:") '("c:mips/")) +(setf (ext:search-list "assem:") '("lisp:assembly/")) +(setf (ext:search-list "hem:") '("lisp:hemlock/")) + +;;; This must be here, because it's where assert-user-package is defined. +(load "code:save") + +;;; Make sure the core will start up in the user package. +(lisp::assert-user-package) -(in-package "CLOS" :nicknames '("PCL")) -(in-package "USER" :use '("LISP" "EXTENSIONS" "CONDITIONS" "DEBUG" "CLOS")) -(in-package "HEMLOCK") +;;; We want to be in the LISP package for the rest of the file. (in-package "LISP") -#| -;;; Must load this here, instead of before loading this file, otherwise -;;; SEARCH-LIST is unknown. + +;;; Make sure the package structure is correct. ;;; -(load "/afs/cs/project/clisp/new-compiler/logical-names.lisp") -|# +(load "code:exports") + ;;; Get some data on this core. ;;; (write-string "What is the current lisp-implementation-version? ") @@ -42,67 +45,62 @@ (force-output) (set '*hemlock-version* (read-line)) -;;; ;;; Keep us entertained... (setq *load-verbose* t) -(export 'ed) - -(load "code:lfloatcon") -(load "code:spirrat") -(load "code:foreign") +;;; Load random code sources. +;(load "code:lfloatcon") +;(load "code:spirrat") (load "code:format-time") (load "code:parse-time") -;(load "code:xp-patch") -(load "assem:ropdefs") -(load "assem:rompconst") -(load "assem:disassemble") +(load "code:purify") +(load "code:commandline") +(load "code:sort") +(load "code:time") +(load "code:tty-inspect") +(load "code:describe") +(load "code:rand") +(load "code:trace") +(load "code:weak") +(load "code:sysmacs") +(load "code:pprint") +(load "code:run-program") +;;; Load the compiler. (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 '("-lc") "/usr/cs/bin/ld" - (namestring (truename "build:boot/lisp"))) - -;;; This has to occur after the call to LOAD-FOREIGN. -;;; -(load "code:run-program") - +;;; Load the pretty printer after the compiler, 'cause it compiles stuff +;;; at load time. +(load "code:xp") +(pprint-init) +#| ;;; CLX. ;;; -#+clx(progn (load "clx:defsystem") -(setf (symbol-function 'xlib::clx-foreign-files) #'list); #### Hack... -(xlib::load-clx (pathname "clx:")) -) +(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. +;;; Stick these before Hemlock. ;;; (load "code:internet") (load "code:wire") (load "code:remote") -#+hemlock(progn ;;; Hemlock. ;;; -(load "hem:rompsite") ;Contains site-init stuff called at load time. (load "hem:load-hem.lisp") +(load "hem:rompsite") ;Contains site-init stuff called at load time. (hi::build-hemlock) #| +Don't install any dir translations, 'cause we want the real things. + ;;; 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. @@ -127,11 +125,8 @@ "/afs/cs/project/clisp/systems/") (ed::add-definition-dir-translation "/usr2/lisp/" "/afs/cs/project/clisp/systems/") -|# -); #+hemlock progn -#| ;;; PCL. ;;; (load "pcl:defsys") @@ -142,7 +137,7 @@ ;;; Load these after PCL. ;;; ;(load "code:inspect") -(load "code:tty-inspect") +;(load "code:tty-inspect") ;;; There should be no search lists defined in a full core. @@ -152,22 +147,26 @@ ;;; Okay, build the thing! ;;; -(in-package "USER") -(progn - (setq + NIL) - (setq * NIL) - (setq ++ NIL) - (setq ** NIL) - (setq +++ NIL) - (setq *** NIL) +(progn + (setq - nil) + (setq + nil) + (setq * nil) + (setq / nil) + (setq ++ nil) + (setq ** nil) + (setq // nil) + (setq +++ nil) + (setq *** nil) + (setq /// nil) (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 + :init-function #'initial-init-function :root-structures `(ed - #|,hi::*global-command-table*|# + ,hi::*global-command-table* lisp::%top-level extensions:save-lisp ,lisp::fop-codes -- GitLab