;;; 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))))