;;; This is a -*-Lisp-*- file.
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; Initialization for Spice Lisp system, called by TOP-LEVEL.
;;; Also, assorted implementation-dependent stuff.
;;; This file contains variables that may need to be known at
;;; compile time, so this file should be part of the compilation
;;; environment.
;;; The cold loader is able to digest setq's of variables to
;;; simple constants that can be evaluated in Maclisp. If a variable
;;; needs to be initialized to something that must be evaluated in
;;; the Spice Lisp environment, do it here, not in a DEFVAR.
;;; Written by Scott Fahlman and Walter van Roggen.
;;; May be added to by anyone supplying a code module for the cold load
;;; who needs init service.
;;; *******************************************************************
(declare (special %catch-all-object *prompt* *features*
*lisp-initialization-functions* *lisp-command*))
(defvar %sp-internal-throw-tag)
;;; There are a number of variables which specify implementation
;;; dependent characteristics that would be useful to have available.
;;; These would be set up at Lisp initialization, in the xxINIT.SLISP
;;; file. They should also be available to the compiler.
;;; Variables that end in -BYTE are byte specifiers.
;;; Variables that end in -SLOT are fixnums giving the index in the vector
;;; or offset on the stack.
(defconstant current-machine 'PERQ)
(defconstant current-system 'SPICE)
(defconstant target-machine 'PERQ)
(defconstant target-system 'SPICE)
(defvar compiler-version)
(defvar assembler-version)
(defvar *features* '(common perq spice cmu))
(defconstant %fasl-code-format 0)
;;; Various miscellaneous objects and fields
(defconstant %character-code-byte (byte 8 0))
(defconstant %character-control-byte (byte 8 8))
(defconstant %character-font-byte (byte 8 16))
(defconstant %character-code-mask #o377)
(defconstant %character-control-mask #o177400)
(defconstant %character-font-mask #o77600000)
(defconstant %character-int-mask #o77777777)
(defconstant %character-code-control-mask #o177777)
(defconstant %values-marker-num-byte (byte 16 0))
(defconstant %frame-header-escape-byte (byte 1 22))
(defconstant %frame-header-values-byte (byte 1 21))
;;; Type codes as returned by the TYPE instruction:
(defconstant %misc-type 0)
(defconstant %bit-vector-type 1)
(defconstant %integer-vector-type 2)
(defconstant %string-type 3)
(defconstant %bignum-type 4)
(defconstant %long-float-type 5)
(defconstant %complex-type 6)
(defconstant %ratio-type 7)
(defconstant %general-vector-type 8)
(defconstant %function-type 9)
(defconstant %array-type 10)
(defconstant %symbol-type 11)
(defconstant %list-type 12)
(defconstant %fixnum-type 16)
(defconstant %+-fixnum-type 16)
(defconstant %--fixnum-type 17)
(defconstant %+-short-float-type 18)
(defconstant %--short-float-type 19)
(defconstant %character-type 20)
(defconstant %values-marker-type 21)
(defconstant %call-header-type 22)
(defconstant %catch-header-type 23)
(defconstant %catch-all-type 24)
(defconstant %gc-forward-type 25)
;;; Space codes:
(defconstant %dynamic-0-space 0)
(defconstant %dynamic-1-space 1)
(defconstant %dynamic-space 0)
(defconstant %static-space 2)
(defconstant %read-only-space 3)
;;; Format of a function object:
(defconstant %function-fexpr-slot 0)
(defconstant %function-fexpr-byte (byte 1 27))
(defconstant %function-min-args-slot 2)
(defconstant %function-min-args-byte (byte 8 0))
(defconstant %function-syms-consts-slot 0)
(defconstant %function-syms-consts-byte (byte 15 0))
(defconstant %function-code-slot 1)
(defconstant %function-rest-arg-slot 2)
(defconstant %function-rest-arg-byte (byte 1 27))
(defconstant %function-max-args-slot 2)
(defconstant %function-max-args-byte (byte 8 8))
(defconstant %function-locals-slot 2)
(defconstant %function-locals-byte (byte 11 16))
(defconstant %function-name-slot 3)
(defconstant %function-arg-names-slot 4)
(defconstant %function-constants-offset 5)
;;; Format of an array:
(defconstant %array-data-slot 0)
(defconstant %array-length-slot 1)
(defconstant %array-fill-pointer-slot 2)
(defconstant %array-displacement-slot 3)
(defconstant %array-dim-base 3)
(defconstant %array-first-dim-slot 4)
(defconstant %array-header-overhead 3)
;;; Format of a call frame:
(defconstant %frame-header-slot 0)
(defconstant %frame-func-slot 1)
(defconstant %frame-prev-active-slot 2)
(defconstant %frame-prev-open-slot 3)
(defconstant %frame-prev-binding-slot 4)
(defconstant %frame-pc-slot 5)
(defconstant %frame-arg-start-slot 6)
;;; Site information.
(defvar *lisp-implementation-version* "2.0")
(defvar *machine-instance* "Some Random Perq")
;;; System dependent error information.
;;; The maximum error code for system dependent error messages.
(defconstant Max-internal-error 65
"The largest internal error number for Spice Lisp")
;;; Useful macros
(defmacro %sp-make-fixnum (object)
`(%primitive make-immediate-type ,object %+-fixnum-type))
(defmacro %sp-make-misc (fixnum)
`(%primitive make-immediate-type ,fixnum %misc-type))
;;; Stack accessing macros
(defvar %stack-increment 2)
;;; stack+
;;; stack-pointer -- a fixnum which is a stack pointer after %SP-Make-Misc
;;; offset -- number of entries toward the top of the stack
(defmacro stack+ (stack-pointer offset)
`(+ ,stack-pointer (* %stack-increment ,offset)))
(defmacro read-cstack (pointer offset)
"Read control stack at pointer + integer offset."
`(%primitive read-control-stack
(%sp-make-misc (stack+ (%sp-make-fixnum ,pointer) ,offset))))
(defmacro write-cstack (pointer offset value)
"Write value onto control stack at pointer + integer offset."
`(%primitive write-control-stack
(%sp-make-misc (stack+ (%sp-make-fixnum ,pointer) ,offset))
,value))
(defmacro read-bstack (pointer offset)
"Read binding stack at pointer + integer offset."
`(%primitive read-binding-stack
(%sp-make-misc (stack+ (%sp-make-fixnum ,pointer) ,offset))))
(defmacro write-bstack (pointer offset value)
"Write value onto binding stack at pointer + integer offset."
`(%primitive write-binding-stack
(%sp-make-misc (stack+ (%sp-make-fixnum ,pointer) ,offset))
,value))
;;; Super-fast implementation-dependent char-upcase for the reader.
;;; Does no checking -- CHAR had better be a character.
;;; Evals CHAR twice.
(defmacro fast-char-upcase (char)
`(let ((ch (%sp-make-fixnum ,char)))
(if (and (> ch #o140) ; Octal 141 is #\a.
(< ch #o173)) ; Octal 172 is #\z.
(%sp-make-immediate-type (- ch 32) %character-type)
,char)))
;;; Numeric arithmetic constants
(defconstant %fixnum-length 28)
(defconstant most-positive-fixnum 134217727
"The fixnum closest in value to positive infinity.")
(defconstant most-negative-fixnum -134217728
"The fixnum closest in value to negative infinity.")
(defconstant short-float-radix 2 "The radix of short-floats.")
(defconstant single-float-radix 2 "The radix of single-floats.")
(defconstant double-float-radix 2 "The radix of double-floats.")
(defconstant long-float-radix 2 "The radix of long-floats.")
(defconstant %short-float-exponent-length 8)
(defconstant %short-float-mantissa-length 20)
(defconstant %long-float-exponent-length 11)
(defconstant %long-float-mantissa-length 53)
(defconstant %double-float-exponent-length 11)
(defconstant %double-float-mantissa-length 53)
;;; Some system dependent functions for the Perq.
;;; Get-internal-time returns the date & time in an implementation
;;; dependent way. In the VM, we can't get the time, so we return
;;; the scribe date (Saturday 8-march-1952 4:30pm) as a universal time.
;;; The number is factored because the vm can not load bignums.
(defun get-internal-time ()
"Returns the date and time in an implementation dependent form."
(* 235251 7000))
(defconstant internal-time-units-per-second 1)
;;; Get-Universal-Time returns the date and time as a number of seconds
;;; since midnight 01 Jan 1900 GMT. Once again, we can't get the time,
;;; so return the scribe date.
(defun get-universal-time ()
"Returns the number of seconds since midnight 01 Jan 1900 GMT."
(/ (get-internal-time) internal-time-units-per-second))
;;; %Initial-Function is called by the microcode when a cold system
;;; starts up. First we zoom down the *Lisp-Initialization-Functions*
;;; doing things that wanted to happen at "load time." Then we initialize
;;; the various subsystems and call the read-eval-print loop.
(defun %initial-function ()
"Gives the world a shove and hopes it spins."
(setq *already-maybe-gcing* t)
;; Some of the random top-level forms call Make-Array, which calls Subtypep...
(subtypep-init)
(setq *lisp-initialization-functions*
(nreverse *lisp-initialization-functions*))
(dolist (fun *lisp-initialization-functions*)
(funcall fun))
(setq *lisp-initialization-functions* 'gone!) ; So it gets GC'ed.
(setq *prompt* "* "
%catch-all-object (%primitive make-immediate-type 0 %catch-all-type))
(kernel-init)
(typescript-init)
(sesame-init)
(filesys-init)
(error-init)
(reader-init)
(backq-init)
(sharp-init)
;; After the various reader subsystems have done their thing to the standard
;; readtable, copy it to *readtable*.
(setq *readtable* (copy-readtable std-lisp-readtable))
(stream-init)
(print-init)
(pprint-init)
(fasload-init)
(random-init)
(format-init)
(save-aux-init)
(env-mgr-init)
;; Viewport-Init must follow Sapphire-Init.
(sapphire-init)
(viewport-init)
(package-init)
(msgn-init)
;; Hack so interpreted DO-ALL-SYMBOLS works...
(unintern '%internal-special-marker%)
(setq *already-maybe-gcing* nil)
(unless (zerop (length *lisp-command*))
(let ((command (with-input-from-string (lc *lisp-command*) (read lc))))
(eval command)))
(terpri)
(princ "Spice Lisp kernel core image ")
(princ (lisp-implementation-version))
(princ ".")
(terpri)
(princ "[You are in the LISP package.]")
(terpri)
(do ()
(())
(%top-level)
(write-line "?Wise guy attempted to return from top-level function.")))
;;; This function is called to reinitialize the world when a saved core image
;;; is resumed.
(defun reinit ()
(setq *already-maybe-gcing* t)
(kernel-init)
(save-aux-init)
(typescript-init)
(sapphire-init)
(viewport-init)
(sesame-init)
(env-mgr-init)
(stream-init)
(menu-choose-init)
(msgn-init)
(setq *already-maybe-gcing* nil))
;;; %SP-Software-Interrupt-Handler is called by the microcode when various
;;; asynchronous events happen. Exactly which event occurred corresponds
;;; to the Event argument, which is a fixnum:
;;; 0 - The Accent debug interrupt character was typed at the Lisp.
;;; On this event, we go into a break loop.
;;; 1 - The storage allocator just crossed a 64K boundary.
;;; Call the function Maybe-GC, but not if such a call is in progress.
;;; 2 - A normal message has been sent to us.
;;; 3 - An emergency message has been sent to us.
;;; 4 - The instruction execution profiler should be called with the
;;; given instruction number.
(defvar *already-maybe-gcing* nil)
(defun %sp-software-interrupt-handler (event &optional extra)
(case event
(0 (break "Debug"))
(1 (unless *already-maybe-gcing*
(let ((*already-maybe-gcing* t))
(maybe-gc))))
(2 (error "We can't handle this yet!"))
(3 (error "We can't handle this yet!"))
(4 (instruction-execution-profiler extra))
(t (break "Strange software interrupt.")))
(%primitive break-return))
(defun print-herald ()
(write-string "Spice 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 Spice@CMU-CS-Spice.")
(values))
(defun save-spice-lisp (core-file-name)
"Saves a Spice Lisp core image in the file of the specified name. A purifying
GC is done first, and the command line is frobbed when the dumped Lisp starts
up."
(setq *lisp-command* "")
(purify)
(write-line "Hit a key when the machine stops paging.")
(get-event 2)
(save core-file-name)
(set-title
(concatenate 'string
(lisp-implementation-type) " " (lisp-implementation-version)))
(or (load "init.sfasl" :if-does-not-exist nil)
(load "init.slisp" :if-does-not-exist nil))
(if (zerop (length *lisp-command*))
(print-herald)
(let ((command (with-input-from-string (lc *lisp-command*) (read lc))))
(eval command))))