mirror of
https://github.com/PDP-10/its.git
synced 2026-02-08 01:11:18 +00:00
cc8e6c1964
the lisp interpreter is first booted. Redumps lisp compiler with updated FASL files built from source.
599 lines
18 KiB
Common Lisp
Executable File
599 lines
18 KiB
Common Lisp
Executable File
;;; EXTEND -*-Mode:Lisp;Package:SI;Lowercase:T-*-
|
||
;;; ****************************************************************
|
||
;;; *** MacLISP ******** EXTENDed datatype scheme ******************
|
||
;;; ****************************************************************
|
||
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ****
|
||
;;; ****************************************************************
|
||
|
||
(herald EXTEND /292)
|
||
|
||
;;; In MACLISP, the term "EXTEND" refers to data objects not natively
|
||
;;; supported by Maclisp which are implemented using HUNKs according
|
||
;;; to the (STATUS USRHUNK) feature); primarily, it is the NIL data
|
||
;;; types and class sytems which is being supported.
|
||
|
||
(eval-when (eval compile)
|
||
(or (get 'SUBLOAD 'VERSION)
|
||
(load '((lisp) subload)))
|
||
(subload EXTMAC) ;; Remember, EXTMAC down-loads CERROR
|
||
)
|
||
|
||
|
||
(eval-when (eval load compile)
|
||
(subload SENDI)
|
||
(let ((x (get 'EXTSTR 'VERSION)))
|
||
(cond ((or (null x) (alphalessp x "91"))
|
||
(remprop 'EXTSTR 'VERSION)
|
||
(let ((FASLOAD () ))
|
||
(load (autoload-filename EXTSTR))))))
|
||
(subload EXTBAS) ;Defines SI:XREF, SI:XSET, etc. Also loads EXTHUK.
|
||
(cond ((status FEATURE COMPLR)
|
||
(*lexpr SEND SEND-AS LEXPR-SEND LEXPR-SEND-AS
|
||
Y-OR-N-P YES-OR-NO-P SI:LOST-MESSAGE-HANDLER)
|
||
(fixnum (SI:HASH-Q-EXTEND))))
|
||
)
|
||
|
||
|
||
;;; SI:EXTSTR-SETUP-CLASSES is set up by EXTMAC, and includes things
|
||
;;; like CLASS-CLASS OBJECT-CLASS STRUCT=INFO-CLASS STRUCT-CLASS VECTOR-CLASS
|
||
(eval-when (eval compile load)
|
||
(cond ((status feature COMPLR)
|
||
#.`(SPECIAL ,.si:extstr-setup-classes)
|
||
(special SI:SKELETAL-CLASSES)))
|
||
)
|
||
|
||
;; There should be no user-level macro definitions in this file
|
||
(declare (setq DEFMACRO-FOR-COMPILING () DEFMACRO-DISPLACE-CALL () )
|
||
(setq USE-STRT7 'T MACROS () ))
|
||
|
||
;; These are just to stop silly warning msgs about redefining.
|
||
(declare (own-symbol PTR-TYPEP))
|
||
;; This is to prevent COMPLR from trying to autoload in this function
|
||
;; when a usage of it appears in the file (due to DEFCLASS*'s or
|
||
;; to DEFMETHOD*'s)
|
||
(declare (own-symbol FIND-METHOD ADD-METHOD SI:DEFCLASS*-1))
|
||
|
||
|
||
|
||
;;;; Defvars, and some Typical EXTEND functions
|
||
|
||
|
||
(defvar *:TRUTH 'T) ;In MACLISP, provide for necessary stuff
|
||
|
||
(defvar STANDARD-OUTPUT T)
|
||
|
||
;; Just to be sure that error output can go somewhere. A more substantial
|
||
;; definition is in the QUERIO file
|
||
(defvar ERROR-OUTPUT 'T)
|
||
|
||
(defvar /#-MACRO-DATALIST () )
|
||
|
||
(defun |EX-#-MACRO-T| (() ) *:TRUTH)
|
||
|
||
;; An open-coding of SETSYNTAX-SHARP-MACRO
|
||
(let ((x (get 'SHARPM 'VERSION))
|
||
(y '(#/T () MACRO . |EX-#-MACRO-T|)))
|
||
(cond ((and x (alphalessp x '/82))
|
||
(push y /#-MACRO-DATALIST))
|
||
('T (if (null (setq x (assoc READTABLE /#-MACRO-DATALIST)))
|
||
(push (setq x `(,READTABLE . () )) /#-MACRO-DATALIST))
|
||
(push y (cdr x)))))
|
||
|
||
|
||
(defun PTR-TYPEP (x)
|
||
(cond ((null x) 'CONSTANT)
|
||
((not (hunkp x))
|
||
(if (eq (setq x (typep x)) 'LIST)
|
||
'PAIR
|
||
x))
|
||
((extendp x)
|
||
;;Note how this implies that extends must be hunks
|
||
(let ((type (type-of x)))
|
||
(if (or (memq type '(VECTOR STRING BITS CHARACTER CONSTANT))
|
||
(memq type '#.(mapcan '(lambda (x)
|
||
(cond ((memq x '(VECTOR STRING BITS CHARACTER CONSTANT)) () )
|
||
((list x))))
|
||
;;this var loaded by EXTMAC
|
||
*:vax-primitive-types)))
|
||
type
|
||
'EXTEND)))
|
||
('T 'HUNK)))
|
||
|
||
(declare (own-symbol EQ-FOR-EQUAL?))
|
||
|
||
(defvar TARGET-FEATURES 'LOCAL
|
||
"So it won't be unbound, nor NIL.")
|
||
|
||
(defun EQ-FOR-EQUAL? (x &aux (type (typep x)))
|
||
(cond ((eq type 'SYMBOL) *:TRUTH)
|
||
((memq type '(LIST FLONUM BIGNUM)) () )
|
||
((and (eq type 'FIXNUM)
|
||
(not (eq TARGET-FEATURES 'NIL)))
|
||
;;FIXNUM type is not 'eq-for-equal?' in MacLISP, due to Pdlnums,
|
||
;; but watch out for cross-compilation!!
|
||
() )
|
||
((memq (type-of x) '(SYMBOL CONSTANT CHARACTER SMALL-FLONUM))
|
||
*:TRUTH)))
|
||
|
||
|
||
;;;; SI:DEFCLASS*-1 (must be in early, for use by later mungeables)
|
||
|
||
;;; Some old dumps may have a losing SI:DEFCLASS*-2
|
||
(eval-when (eval compile load)
|
||
(if (equal (args 'SI:DEFCLASS*-2) '(4 . 5))
|
||
(args 'SI:DEFCLASS*-2 '(4 . 511.)))
|
||
)
|
||
|
||
|
||
(defun SI:DEFCLASS*-1 (typep class-var supr &optional (class-name typep)
|
||
source-file &aux class)
|
||
(if (cond
|
||
((null (setq class (get class-name 'CLASS))))
|
||
('T ;;Be sure it's complete
|
||
(cond (SI:SKELETAL-CLASSES
|
||
(mapc #'SI:INITIALIZE-CLASS SI:SKELETAL-CLASSES)
|
||
(setq SI:SKELETAL-CLASSES () )))
|
||
(format
|
||
MSGFILES
|
||
"~&;Re-defining class ~S ~:[~;(previously from file ~1G~A)~]~@
|
||
~:[~;(in file ~2G~A)~]"
|
||
class-name (get (si:class-plist class) ':SOURCE-FILE) source-file)
|
||
(y-or-n-p "~&;Overwrite the existing class?")))
|
||
(setq class (si:defclass*-2 class-name
|
||
typep
|
||
class-var
|
||
supr
|
||
source-file
|
||
class)))
|
||
class)
|
||
|
||
|
||
;; SI:INITIALIZE-CLASS sets the slots in the class object that require that
|
||
;; EXTEND have been loaded.
|
||
|
||
(defun SI:INITIALIZE-CLASS (class)
|
||
(setf (si:class-SENDI-sym class) 'SI:DEFAULT-SENDI)
|
||
(setf (si:class-sendi class) (get 'SI:DEFAULT-SENDI 'SENDI))
|
||
(setf (si:class-CALLI-sym class) 'SI:DEFAULT-CALLI)
|
||
(setf (si:class-calli class) (get 'SI:DEFAULT-CALLI 'CALLI))
|
||
(setf (si:class-map-methods-sym class) 'SI:STANDARD-MAP-OVER-METHODS)
|
||
(setf (si:class-map-methods-i class)
|
||
(get 'SI:STANDARD-MAP-OVER-METHODS 'MAP-METHODS))
|
||
(setf (si:class-map-classes-sym class) 'SI:STANDARD-MAP-OVER-CLASSES)
|
||
(setf (si:class-map-classes-i class)
|
||
(get 'SI:STANDARD-MAP-OVER-CLASSES 'MAP-CLASSES))
|
||
(setf (si:class-add-method-fun class) 'SI:DEFAULT-ADD-METHOD)
|
||
|
||
()
|
||
)
|
||
|
||
|
||
|
||
;;;; Create top of CLASS hierarchy
|
||
|
||
;The class heirarchy has this as its main structure. In actuality, it
|
||
;is more complex and classes can have more than one superior.
|
||
; (OBJECT CLASS
|
||
; (SEQUENCE STRING (VECTOR HEAP-VECTOR STACK-VECTOR)
|
||
; BITS (LIST PAIR NULL))
|
||
; (NUMBER (INTEGER FIXNUM (BIGNUM POSITIVE-BIGNUM NEGATIVE-BIGNUM))
|
||
; (FLOAT FLONUM SMALL-FLONUM BIGFLOAT)
|
||
; COMPLEX)
|
||
; SUBR CHARACTER SYMBOL (CONSTANT NULL)
|
||
; FROBS-OF-YOUR-CHOICE-HERE-AND-BELOW)
|
||
|
||
|
||
;; Now initialize the skeletal classes, (including OBJECT-CLASS)
|
||
(mapc #'(lambda (class)
|
||
(setf (si:extend-class-of (car class)) CLASS-CLASS)
|
||
(setf (si:class-superiors (car class)) (cadr class))
|
||
(si:initialize-class (car class))
|
||
(if (boundp 'PURCOPY) ;Speed up PURCOPY
|
||
(setq PURCOPY (delq (car class) PURCOPY))))
|
||
SI:SKELETAL-CLASSES)
|
||
(setq SI:SKELETAL-CLASSES () )
|
||
|
||
|
||
#.(if (filep infile)
|
||
`(PROGN (SETF (GET (SI:CLASS-PLIST CLASS-CLASS) ':SOURCE-FILE)
|
||
',(namestring (truename infile)))
|
||
(SETF (GET (SI:CLASS-PLIST OBJECT-CLASS) ':SOURCE-FILE)
|
||
',(namestring (truename infile)))))
|
||
|
||
|
||
;;;; Setup SI:INITIAL-CLASSES
|
||
|
||
(defmacro GEN-DEFCLASSES (x)
|
||
`(PROGN 'COMPILE
|
||
,.(mapcar
|
||
'(lambda (x)
|
||
(let (((name supr . options) x) class-var)
|
||
(setq supr (cond ((atom supr)
|
||
(symbolconc supr '/-CLASS))
|
||
((mapcar '(lambda (x)
|
||
(symbolconc x '/-CLASS))
|
||
supr))))
|
||
(setq class-var (symbolconc name '/-CLASS))
|
||
`(DEFCLASS* ,name ,class-var ,supr ,. options)))
|
||
(eval x))))
|
||
|
||
(eval-when (eval load compile)
|
||
(SETQ SI:INITIAL-CLASSES '((NUMBER OBJECT)
|
||
(FLOAT NUMBER)
|
||
(INTEGER NUMBER)
|
||
(MACLISP-PRIMITIVE OBJECT)
|
||
(LIST SEQUENCE)
|
||
(PAIR (LIST MACLISP-PRIMITIVE))
|
||
(CONSTANT OBJECT)
|
||
(NULL ( CONSTANT
|
||
LIST
|
||
MACLISP-PRIMITIVE)
|
||
TYPEP CONSTANT) ;; Boo! Hiss!
|
||
(SYMBOL MACLISP-PRIMITIVE)
|
||
(FIXNUM (INTEGER MACLISP-PRIMITIVE))
|
||
(FLONUM (FLOAT MACLISP-PRIMITIVE))
|
||
(RANDOM MACLISP-PRIMITIVE)
|
||
(ARRAY MACLISP-PRIMITIVE)
|
||
(SFA MACLISP-PRIMITIVE)
|
||
(FILE MACLISP-PRIMITIVE)
|
||
(JOB MACLISP-PRIMITIVE)
|
||
(BIGNUM (INTEGER MACLISP-PRIMITIVE))
|
||
(HUNK MACLISP-PRIMITIVE) ))
|
||
)
|
||
|
||
(GEN-DEFCLASSES SI:INITIAL-CLASSES)
|
||
|
||
(SETQ SI:INITIAL-CLASSES `((OBJECT ())
|
||
(CLASS OBJECT)
|
||
(STRUCT OBJECT)
|
||
(SEQUENCE OBJECT)
|
||
,.si:initial-classes))
|
||
|
||
(setf (si:class-sendi-sym sfa-class) 'SI:SFA-SENDI)
|
||
(setf (si:class-sendi sfa-class) (get 'SI:SFA-SENDI 'SENDI))
|
||
(def-or-autoloadable GENTEMP MACAID)
|
||
|
||
|
||
(defun LEXPR-SEND (&rest argl)
|
||
;; By analogy to LEXPR-FUNCALL, invoke a method with a &REST list of extra
|
||
;; arguments.
|
||
(lexpr-funcall #'lexpr-funcall #'send argl))
|
||
|
||
(defun LEXPR-SEND-AS (&rest argl)
|
||
;; By analogy to LEXPR-FUNCALL, invoke a method with a &REST list of extra
|
||
;; arguments.
|
||
(lexpr-funcall #'lexpr-funcall #'send-as argl))
|
||
|
||
;;;; ADD-METHOD, and special methods for class CLASS
|
||
|
||
(defun ADD-METHOD (message-key method-fun class)
|
||
;; Add a method to a class
|
||
(cond ((and *RSET (fboundp 'SI:CHECK-TYPER))
|
||
(check-type message-key #'SYMBOLP 'ADD-METHOD)
|
||
(check-type class #'CLASSP 'ADD-METHOD)))
|
||
(funcall (SI:class-add-method-fun class) message-key method-fun class))
|
||
|
||
|
||
(defun SI:default-add-method (msg-key method-fun class)
|
||
(declare (special error-output))
|
||
(let ((temp (or (memq msg-key (si:class-methods class))
|
||
(setf (si:class-methods class) ;SETF being used for value!
|
||
(make-a-method KEY msg-key
|
||
NEXT (si:class-methods class)))))
|
||
(prop (and (symbolp method-fun)
|
||
(getl method-fun '(lsubr expr subr)))))
|
||
(setf (method-fun-sym temp) method-fun)
|
||
(cond
|
||
((symbolp method-fun)
|
||
(if (cond ((null prop)
|
||
(format error-output
|
||
"~&;Warning: Function ~S not yet defined~%"
|
||
method-fun)
|
||
'T)
|
||
((eq (car prop) 'SUBR)
|
||
(format error-output
|
||
"~&;Warning: Function ~S was compiled as a SUBR~%"
|
||
method-fun)
|
||
'T))
|
||
(format error-output
|
||
";Discovered adding method ~S to class ~S.~@
|
||
;Method calls will remain interpreted.~%"
|
||
msg-key
|
||
class))))
|
||
(setf (method-fun temp) (if (eq (car prop) 'LSUBR) (cadr prop))))
|
||
method-fun)
|
||
|
||
|
||
|
||
(defmethod* (:PRINT-SELF CLASS-CLASS) (obj stream () () )
|
||
(si:print-extend obj (si:class-name-careful obj) stream))
|
||
|
||
(defmethod* (FLATSIZE CLASS-CLASS) (obj printp () () )
|
||
(si:flatsize-extend obj (si:class-typep obj) printp))
|
||
|
||
(defmethod* (PURCOPY CLASS-CLASS) (self)
|
||
;; Don't copy class objects at all; Pray to heaven that it doesn't go away.
|
||
self)
|
||
|
||
|
||
;;Try hard to recreate the class when the file is loaded.
|
||
;;Note that CLASS-CLASS, OBJECT-CLASS, STRUCT-CLASS and certain other
|
||
;; classes will be present when SI:DEFCLASS*-2 can be done, so we don't
|
||
;; try to create those.
|
||
|
||
(defmethod* (USERATOMS-HOOK CLASS-CLASS) (obj)
|
||
(let* ((name (si:class-name-careful obj))
|
||
(getter `(GET ',name 'CLASS)))
|
||
(list (if (memq name '#.si:extstr-setup-classes)
|
||
getter
|
||
`(OR ,getter
|
||
(AND (GET 'EXTSTR 'VERSION)
|
||
(SI:DEFCLASS*-2
|
||
',name
|
||
',(si:class-typep obj)
|
||
',(si:class-var obj)
|
||
',(si:class-superiors obj)
|
||
',(get (si:class-plist obj) ':SOURCE-FILE))))))))
|
||
|
||
|
||
;;;; Methods for class OBJECT
|
||
|
||
(DEFMETHOD* (EQUAL OBJECT-CLASS) (OBJ OTHER-OBJ)
|
||
(IF (EXTENDP OBJ)
|
||
(EQ OBJ OTHER-OBJ)
|
||
(EQUAL OBJ OTHER-OBJ)))
|
||
|
||
;; needed by both DEFVST and STRING.
|
||
(defmethod* (PURCOPY object-class) (obj)
|
||
(without-interrupts
|
||
(let ((class (class-of obj)) (new-obj))
|
||
(setf (si:extend-class-of obj) ())
|
||
(setq new-obj (purcopy obj))
|
||
(setf (si:extend-class-of obj) class)
|
||
(setf (si:extend-class-of new-obj) class)
|
||
new-obj)))
|
||
|
||
(DEFMETHOD* (SUBST OBJECT-CLASS) (OBJ () ()) OBJ)
|
||
|
||
(DEFMETHOD* (SPRINT OBJECT-CLASS) (OBJ () ())
|
||
; (DECLARE (SPECIAL L N M))
|
||
(PRINT-OBJECT OBJ 0. 'T (SI:NORMALIZE-STREAM OUTFILES)))
|
||
|
||
|
||
(DEFMETHOD* (GFLATSIZE OBJECT-CLASS) (OBJ)
|
||
(FLATSIZE-OBJECT OBJ () 0. 'T ))
|
||
|
||
(DEFMETHOD* (SXHASH OBJECT-CLASS) (OBJ)
|
||
(SI:HASH-Q-EXTEND
|
||
OBJ
|
||
(SXHASH (SI:CLASS-NAME-CAREFUL (SI:EXTEND-CLASS-OF OBJ)))))
|
||
|
||
(DEFUN SI:HASH-Q-EXTEND (OB ACCUMULATION)
|
||
(DECLARE (FIXNUM ACCUMULATION I))
|
||
(DO I (1- (EXTEND-LENGTH OB)) (1- I) (< I 0)
|
||
(SETQ ACCUMULATION (+ (ROT (SXHASH (SI:XREF OB I)) 11.)
|
||
(ROT ACCUMULATION 7))))
|
||
ACCUMULATION)
|
||
|
||
(DEFMETHOD* (USERATOMS-HOOK OBJECT-CLASS) (()) () )
|
||
|
||
|
||
(DEFUN SI:PRINT-EXTEND (OBJ NAME STREAM)
|
||
(SI:PRINT-EXTEND-1 OBJ NAME 'T STREAM))
|
||
(DEFUN SI:PRINT-EXTEND-MAKNUM (OBJ STREAM &AUX (BASE 8.))
|
||
(SI:PRINT-EXTEND-1 OBJ () () STREAM))
|
||
|
||
(DEFUN SI:PRINT-EXTEND-1 (OBJ NAME NAMEP STREAM)
|
||
(SETQ STREAM (SI:NORMALIZE-STREAM STREAM))
|
||
(PRINC '|#{| STREAM)
|
||
(PRIN1 (SI:CLASS-NAME-CAREFUL (CLASS-OF OBJ)) STREAM)
|
||
(TYO #\SPACE STREAM)
|
||
(COND (NAMEP (PRIN1 NAME STREAM))
|
||
('T (PRINC (MAKNUM OBJ) STREAM)))
|
||
(TYO #/} STREAM))
|
||
|
||
(DEFUN SI:NORMALIZE-STREAM (STREAM)
|
||
(IF (AND STREAM
|
||
(AND ^R (NULL ^W))
|
||
(PAIRP STREAM)
|
||
(NOT (MEMQ 'T STREAM))
|
||
(NOT (MEMQ TYO STREAM)))
|
||
(CONS 'T STREAM)
|
||
STREAM))
|
||
|
||
|
||
|
||
(DEFUN SI:FLATSIZE-EXTEND (OBJ NAME PRINTP)
|
||
(+ (FLATSIZE (SI:CLASS-TYPEP (CLASS-OF OBJ)))
|
||
(COND (PRINTP 2)
|
||
('T (+ (FLATSIZE NAME) 4)))))
|
||
|
||
|
||
(DEFMETHOD* (PRINT OBJECT-CLASS) (OBJECT &REST ARGL)
|
||
(LEXPR-SEND OBJECT ':PRINT-SELF ARGL))
|
||
|
||
(DEFMETHOD* (:PRINT-SELF OBJECT-CLASS) (OBJ STREAM DEPTH SLASHIFYP)
|
||
(COND ((EXTENDP OBJ)
|
||
(SI:PRINT-EXTEND-MAKNUM OBJ STREAM))
|
||
('T (PRINT-OBJECT OBJ DEPTH SLASHIFYP (SI:NORMALIZE-STREAM STREAM)))))
|
||
|
||
|
||
(DEFMETHOD* (EVAL OBJECT-CLASS) (OBJ) OBJ) ;self-evaluation defaults!
|
||
|
||
|
||
;;;; FIND-METHOD and WHICH-OPERATIONS method
|
||
|
||
(defun FIND-METHOD (m class)
|
||
;; Return the function that gets run for a method-key in specified class
|
||
(declare (special m))
|
||
(si:map-over-methods
|
||
#'(lambda (() method fun)
|
||
(declare (special m))
|
||
(if (eq method m) fun))
|
||
class))
|
||
|
||
(DEFPROP SI:FIND-METHOD FIND-METHOD EXPR) ;; Foo! 11/7/80 - Jonl
|
||
|
||
(defun SI:WHERE-IS-METHOD (m class)
|
||
;; Return the class in which method "m" is found for class "class"
|
||
(declare (special m))
|
||
(si:map-over-methods
|
||
#'(lambda (class1 method ())
|
||
(declare (special m))
|
||
(if (eq method m) class1))
|
||
class))
|
||
|
||
(defun SI:OPERATIONS-LIST (class)
|
||
;; Collect a list of 'operations'
|
||
(let (l)
|
||
(declare (special l))
|
||
(si:map-over-methods
|
||
#'(lambda (class1 meth fun)
|
||
(declare (special l))
|
||
(push `(,meth ,fun ,class1) l)
|
||
() )
|
||
class)
|
||
(nreverse l)))
|
||
|
||
(defmethod* (WHICH-OPERATIONS object-class) (object)
|
||
;;Collect a list of methods
|
||
(let (l)
|
||
(declare (special l))
|
||
(mapc #'(lambda (meth)
|
||
(declare (special l))
|
||
(if (not (memq (car meth) l))
|
||
(push (car meth) l)))
|
||
(si:operations-list (class-of object)))
|
||
l))
|
||
|
||
|
||
(defun SI:HAS-SUPERIOR (object class)
|
||
;; Returns T iff "object" is in a class which has "class" as superior
|
||
(declare (special class))
|
||
(si:map-over-classes
|
||
#'(lambda (class1 ())
|
||
(declare (special class))
|
||
(eq class1 class))
|
||
object))
|
||
|
||
|
||
|
||
;;;; FLATSIZE, EXPLODE methods
|
||
|
||
(defvar SI:ACCUMULATION ()
|
||
"Used to collect the results of the FLATSIZE-HANDLER, or EXPLODE-HANDLER.")
|
||
|
||
|
||
|
||
;; Default FLATSIZE method for objects is to just print the object to
|
||
;; an counting stream which counts the size in a special variable.
|
||
;; A special variable is used since that's easier than consing up a new
|
||
;; stream whenever entered recursively.
|
||
|
||
(defvar SI:FLAT-PRINT-P ()
|
||
"If non-(), then the FLATSIZE method wants to throw out on the first space.")
|
||
|
||
(defmacro CONS-A-FLAT-STREAM ()
|
||
`(SFA-CREATE 'SI:FLAT-HANDLER 0 'SI:FLAT-HANDLER))
|
||
|
||
(defun SI:FLAT-HANDLER (() operation character)
|
||
(caseq operation
|
||
(TYO (cond ((not (< character 0))
|
||
(if (and SI:FLAT-PRINT-P (= character #\SPACE))
|
||
(*throw 'SI:FLAT SI:ACCUMULATION))
|
||
(setq SI:ACCUMULATION (1+ SI:ACCUMULATION))
|
||
T)))
|
||
(WHICH-OPERATIONS '(TYO))))
|
||
|
||
(defvar SI:FLAT-STREAM (cons-a-FLAT-STREAM))
|
||
|
||
(defmethod* (FLATSIZE object-class) (object printp depth slashifyp)
|
||
(let ((SI:ACCUMULATION 0)
|
||
(SI:FLAT-PRINT-P printp))
|
||
(*catch 'SI:FLAT
|
||
(send object ':PRINT-SELF SI:FLAT-STREAM depth slashifyp))
|
||
SI:ACCUMULATION))
|
||
|
||
|
||
;; Default EXPLODE method for objects is to just print the object to
|
||
;; an accumulation stream which accumulates the list of characters in a
|
||
;; special variable. A special variable is used since that's easier
|
||
;; than consing up a new stream whenever entered recursively.
|
||
;; Whether numbers or single character atoms are to be accumulated is
|
||
;; controlled by the special variable SI:EXPLODE-NUMBER-P
|
||
|
||
(defvar SI:EXPLODE-NUMBER-P ()
|
||
"If non-(), then EXPLODEN type method rather than EXPLODEC type.")
|
||
|
||
(defmacro CONS-A-EXPLODE-STREAM ()
|
||
`(SFA-CREATE 'SI:EXPLODE-HANDLER 0 'SI:EXPLODE-HANDLER))
|
||
|
||
(defun SI:EXPLODE-HANDLER (() operation character)
|
||
(caseq operation
|
||
(TYO (cond ((< character 0)
|
||
(if (not SI:EXPLODE-NUMBER-P)
|
||
(setq character (ascii character)))
|
||
(push character SI:ACCUMULATION)
|
||
T)))
|
||
(WHICH-OPERATIONS '(TYO))))
|
||
|
||
(defvar SI:EXPLODE-STREAM (cons-a-EXPLODE-STREAM))
|
||
|
||
(defmethod* (EXPLODE object-class) (object slashify-p si:explode-number-p)
|
||
(let ((SI:ACCUMULATION)) ;Initialize list to ()
|
||
(send object ':PRINT-SELF SI:EXPLODE-STREAM -1 slashify-p)
|
||
(nreverse SI:ACCUMULATION)))
|
||
|
||
|
||
;;;; GRINDEF, HUNKSPRIN1, and USERATOMS hooks -- and some setups
|
||
|
||
|
||
(defun SI:EXTEND-HUNKSPRIN1 (obj n m)
|
||
; (declare (special l n m))
|
||
(cond ((extendp obj) (send obj 'SPRINT n m))
|
||
(T (standard-hunksprin1 obj n m))))
|
||
|
||
(defun SI:EXTEND-GFLATSIZE (obj)
|
||
(declare (special l n m))
|
||
(cond ((extendp obj) (send obj 'GFLATSIZE))
|
||
('T (funcall (get 'STANDARD-HUNKSPRIN1 'HUNKGFLATSIZE) obj ;n m
|
||
))))
|
||
|
||
(setq HUNKSPRIN1 'SI:EXTEND-HUNKSPRIN1)
|
||
(defprop SI:EXTEND-HUNKSPRIN1 SI:EXTEND-GFLATSIZE HUNKGFLATSIZE)
|
||
|
||
|
||
;; Activate the message-passing interpreter
|
||
(sstatus SENDI 'SEND)
|
||
(sstatus USRHUNK 'EXTENDP)
|
||
(sstatus CALLI 'SI:CALLI-TRANSFER)
|
||
|
||
(def-or-autoloadable SI:LOST-MESSAGE-HANDLER CERROR)
|
||
|
||
(let ((x (status LISPV)))
|
||
(cond
|
||
((alphalessp x "2094")
|
||
;;Just in case someone tries to use this in a really old lisp!
|
||
(if (alphalessp x "2057")
|
||
(mapc
|
||
#'(lambda (z)
|
||
(let ((y (subst (car z) 'Z #%(AUTOLOAD-FILENAME Z))))
|
||
(mapc #'(lambda (x)
|
||
(or (fboundp x)
|
||
(equal (get x AUTOLOAD) y)
|
||
(putprop x y 'AUTOLOAD)))
|
||
(cadr z))))
|
||
'( (MLMAC (PAIRP))
|
||
(EXTMAC (DEFCLASS* DEFMETHOD*))
|
||
(CERROR (CERROR FERROR ))
|
||
(ERRCK (CHECK-TYPE SI:CHECK-TYPER CHECK-SUBSEQUENCE
|
||
SI:CHECK-SUBSEQUENCER))
|
||
(SUBSEQ (TO-LIST TO-VECTOR TO-STRING TO-BITS SUBSEQ REPLACE))
|
||
(YESNOP (Y-OR-N-P YES-OR-NO-P)))))
|
||
;;WOW! What a kludge! In old LISP's we somehow have to force in
|
||
;; the DESCRIBE file (since, who knows, we may be autoloading just
|
||
;; in order to get the DESCRIBE function.) And DESCRIBE, of course,
|
||
;; tries to force-load in the EXTEND file. Circularity. Q.E.D.
|
||
(or (get 'EXTEND 'VERSION) (defprop EXTEND /0 VERSION))
|
||
#%(subload DESCRIBE))))
|