Commit 66a7c310 authored by wlott's avatar wlott
Browse files

Moved MIPS branch onto trunk; no merge necessary.

parent ab01e4bf
This diff is collapsed.
This diff is collapsed.
......@@ -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))))
......
......@@ -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))
......
......@@ -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))
This diff is collapsed.
......@@ -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.)
......
......@@ -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)))))
......@@ -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)