r450 - trunk/tools/cold
rswindells at common-lisp.net
rswindells at common-lisp.net
Tue May 24 15:43:51 UTC 2016
Author: rswindells
Date: Tue May 24 15:43:51 2016
New Revision: 450
Log:
Initial import of Common Lisp port of cold load generator.
Added:
trunk/tools/cold/
trunk/tools/cold/README
trunk/tools/cold/cold.asd
trunk/tools/cold/coldld.lisp
trunk/tools/cold/coldst.lisp (contents, props changed)
trunk/tools/cold/coldut.lisp
trunk/tools/cold/defmic.lisp
trunk/tools/cold/defmic99.lisp
trunk/tools/cold/global.lisp (contents, props changed)
trunk/tools/cold/qcom.lisp
trunk/tools/cold/qcom90.lisp
trunk/tools/cold/qcom99.lisp
trunk/tools/cold/qdefs.lisp
trunk/tools/cold/qdefs99.lisp
trunk/tools/cold/sysdcl.lisp
trunk/tools/cold/sysdcl99.lisp
trunk/tools/cold/system.lisp
Added: trunk/tools/cold/README
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/README Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,13 @@
+This directory contains a port of the Lisp Machine cold load generator
+to Common Lisp.
+
+It probably requires a 64-bit Common Lisp implementation to run.
+
+The .asd file isn't functional yet with ASDF, to use the code do:
+
+(load "cold.asd")
+(load "coldut")
+(load "coldld")
+(load "sysdcl")
+(cold:make-cold "filename.lod")
+
Added: trunk/tools/cold/cold.asd
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/cold.asd Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,218 @@
+;;; -*- Mode:LISP; Readtable:T; Base:8; Lowercase:T; Package: cold -*-
+;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+;;This package is the program
+
+(defpackage :cold (:use :cl)
+ (:export #:assign-alternate #:get-alternate
+ #:assign-values #:assign-values-init-delta
+ #:make-cold
+ #:vprint-q
+ #:defmic
+ #:load-parameters
+ #:defprop))
+
+;;This package is used to contain symbols which stand for symbols in the cold-load
+;;being built; this includes all the system data structure definition symbols.
+
+(defpackage :cold-symbols (:nicknames :sym)
+ (:use :cold)
+ (:import-from :common-lisp t nil)
+ (:export #:page-size
+ #:dtp-trap #:dtp-null #:dtp-free
+ #:dtp-symbol #:dtp-symbol-header
+ #:dtp-fix #:dtp-extended-number #:dtp-header #:dtp-gc-forward
+ #:dtp-external-value-cell-pointer #:dtp-one-q-forward
+ #:dtp-header-forward #:dtp-body-forward #:dtp-locative #:dtp-list
+ #:dtp-u-entry
+ #:dtp-fef-pointer #:dtp-array-pointer #:dtp-array-header
+ #:dtp-stack-group #:dtp-closure #:dtp-small-flonum
+ #:dtp-select-method #:dtp-instance #:dtp-instance-header
+ #:dtp-entity #:dtp-stack-closure #:dtp-self-ref-pointer
+ #:dtp-character
+ #:%%q-data-type
+ #:%%q-cdr-code
+ #:%%q-all-but-typed-pointer
+ #:%%q-all-but-pointer
+ #:%%q-pointer
+ #:%%q-typed-pointer
+ #:cdr-normal #:cdr-error #:cdr-nil #:cdr-next
+ #:q-data-types #:q-cdr-codes
+ #:q-corresponding-variable-lists
+ #:%%array-type-field #:%%array-long-length-flag
+ #:%%array-displaced-bit #:%%array-leader-bit
+ #:%%array-index-length-if-short
+ #:%array-max-short-index-length
+ #:%%array-number-dimensions
+ #:array-dim-mult #:array-types
+ #:art-1b #:art-8b #:art-16b #:art-32b
+ #:art-q #:art-q-list #:art-string #:art-stack-group-head
+ #:art-special-pdl #:art-reg-pdl
+ #:system-constant-lists
+ #:cold-load-area-sizes
+ #:cold-load-region-sizes
+ #:scratch-pad-pointers
+ #:scratch-pad-parameters
+ #:scratch-pad-parameter-offset
+ #:support-vector-contents
+ #:constants-page
+ #:read-only-area-list
+ #:wired-area-list
+ #:pdl-buffer-area-list
+ #:list-structured-areas
+ #:static-areas
+ #:area-name #:region-origin #:region-length
+ #:region-free-pointer #:region-gc-pointer #:region-bits
+ #:area-region-list #:area-region-size
+ #:area-maximum-size #:region-list-thread
+ #:micro-code-entry-area
+ #:micro-code-entry-name-area
+ #:micro-code-entry-args-info-area
+ #:micro-code-entry-arglist-area
+ #:micro-code-entry-max-pdl-usage
+ #:micro-code-symbol-area
+ #:micro-code-symbol-name-area
+ #:support-entry-vector
+ #:constants-area
+ #:system-communication-area
+ #:page-table-area
+ #:area-list
+ #:init-list-area
+ #:working-storage-area
+ #:extra-pdl-area
+ #:scratch-pad-init-area
+ #:default-cons-area
+ #:linear-pdl-area #:linear-bind-pdl-area
+ #:property-list-area
+ #:resident-symbol-area
+ #:fasl-symbol-head-area
+ #:fasl-symbol-string-area
+ #:fasl-array-area
+ #:fasl-frame-area
+ #:fasl-list-area
+ #:fasl-temp-list-area
+ #:fasl-temp-area
+ #:a-memory-array-locations
+ #:a-memory-location-names
+ #:a-memory-virtual-address
+ #:m-memory-location-names
+ #:forwarding-virtual-address
+ #:%gc-generation-number
+ #:%sys-com-gc-generation-number
+ #:new-array-index-order
+ #:prin1 #:base #:ibase #:*print-base* #:*read-base*
+ #:*print-radix*
+ #:*nopoint #:for-cadr
+ #:lambda-list-keywords
+ #:qintcmp #:qlval
+ #:&optional #:&rest #:&aux #:&special #:&local #:&functional #:&eval
+ #:"e #:"e-dontcare #:&dt-dontcare #:&dt-number #:&dt-fixnum
+ #:&dt-symbol #:&dt-atom #:&dt-list #:&dt-frame #:&function-cell
+ #:&list-of #:&body #:&key #:&allow-other-keys
+ #:%address-space-quantum-size
+ #:%%region-map-bits
+ #:%%region-oldspace-meta-bit
+ #:%%region-extra-pdl-meta-bit
+ #:%%region-representation-type
+ #:%region-space-extra-pdl
+ #:%region-space-fixed
+ #:%region-space-static
+ #:%region-space-new
+ #:%%region-space-type
+ #:%%region-scavenge-enable
+ #:physical-page-data
+ #:address-space-map
+ #:%address-space-map-byte-size
+ #:p-n-string #:nr-sym
+ #:length-of-atom-head
+ #:array-elements-per-q
+ #:array-bits-per-element
+ #:%header-type-error #:%header-type-fef #:%header-type-array-leader
+ #:%header-type-flonum #:%header-type-complex #:%header-type-bignum
+ #:%header-type-rational-bignum
+ #:%%header-type-field #:%%array-leader-length
+ #:array-leader-bit
+ #:array-named-structure-flag
+ #:array-displaced-bit
+ #:array-long-length-flag
+ #:function #:quote #:*catch #:argdesc #:t #:nil
+ #:control-tables #:obarray
+ #:fef-arg-rest #:fef-arg-req #:fef-arg-opt
+ #:fef-qt-eval #:fef-qt-dontcare
+ #:%arg-desc-quoted-rest #:%arg-desc-evaled-rest
+ #:%arg-desc-fef-quote-hair
+ #:%%fefh-pc-in-words
+ #:%fefhi-storage-length #:%fefhi-fctn-name
+ #:%instance-descriptor-header #:%instance-descriptor-reserved
+ #:%instance-descriptor-size
+ #:initial-top-level-function #:lisp-top-level
+ #:current-stack-group #:initial-stack-group
+ #:error-handler-stack-group #:main-stack-group
+ #:sg-state-active #:sg-state #:sg-name
+ #:sg-regular-pdl #:sg-special-pdl
+ #:sg-regular-pdl-limit #:sg-special-pdl-limit
+ #:stack-group-head-leader-qs
+ #:reg-pdl-leader-qs #:special-pdl-leader-qs
+ #:special-pdl-sg-head-pointer #:reg-pdl-sg-head-pointer
+ #:sg-initial-function-index
+ #:%sys-com-area-origin-pntr
+ #:%sys-com-valid-size
+ #:%sys-com-page-table-pntr
+ #:%sys-com-page-table-size
+ #:%sys-com-obarray-pntr
+ #:%sys-com-ether-free-list
+ #:%sys-com-ether-transmit-list
+ #:%sys-com-ether-receive-list
+ #:%sys-com-band-format
+ #:%sys-com-gc-generation-number
+ #:%sys-com-unibus-interrupt-list
+ #:%sys-com-temporary
+ #:%sys-com-free-area#-list
+ #:%sys-com-free-region#-list
+ #:%sys-com-memory-size
+ #:%sys-com-wired-size
+ #:%sys-com-chaos-free-list
+ #:%sys-com-chaos-transmit-list
+ #:%sys-com-chaos-receive-list
+ #:%sys-com-debugger-requests
+ #:%sys-com-debugger-keep-alive
+ #:%sys-com-debugger-data-1
+ #:%sys-com-debugger-data-2
+ #:%sys-com-major-version
+ #:%sys-com-desired-microcode-version
+ #:%sys-com-highest-virtual-address
+ #:%sys-com-pointer-width
+ #:system-communication-area-qs
+ #:active-micro-code-entries
+ #:size-of-area-arrays
+ #:setq #:and #:or #:cond #:macro #:fset #:lambda #:set
+ #:lisp-crash-list
+ #:mouse-cursor-pattern #:mouse-buttons-buffer
+ #:mouse-x-scale-array #:mouse-y-scale-array
+ #:definitions
+ #:*cold-loaded-file-property-lists*
+ #:file-id-package-alist
+ #:fasl-table-working-offset
+ #:length-of-fasl-table
+ #:macro-compiled-program
+ #:fasl-ops
+ #:%fasl-group-check
+ #:%fasl-group-flag
+ #:%%fasl-group-length
+ #:%fasl-group-type
+ #:fasl-evaled-value
+ #:si #:system-internals #:system #:sys #:global
+ #:cold-load-function-property-lists
+ #:unspecific #:|:UNSPECIFIC|
+ #:newest #:|:NEWEST|
+ #:record-source-file-name #:|:SOURCE-FILE-NAME|
+ #:|:PROPERTY| #:|:INTERNAL| #:|:INTERNAL-FEF-OFFSETS|
+ #:|FS:MAKE-PATHNAME-INTERNAL|
+ #:|FS:MAKE-FASLOAD-PATHNAME|
+ #:deff #:forward-value-cell
+ #:defvar-1 #:defconst-1
+ ))
+
+;(fset 'cold-symbols:logdpb #'dpb)
+
+
Added: trunk/tools/cold/coldld.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/coldld.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,935 @@
+; -*- Mode:LISP; Package:COLD ; Base:8; Lowercase:T; Readtable:T -*-
+; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+(in-package :cold)
+
+;Loader of QFASL files into cold-loads
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; To compile this: ;;;
+;;; (1) Load COLDUT QFASL ;;;
+;;; (2) Run (LOAD-PARAMETERS) ;;;
+;;; (3) Now you may compile it ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declaim (special evals-to-be-sent-over
+ last-fasl-eval ;the element of evals-to-be-sent-over created
+ ; by the last fasl-op-eval.
+ cold-list-area
+ fef-debugging-info-alist
+ current-function)) ;debugging aid
+
+(declaim (special fasl-table fasl-table-fill-pointer fasl-return-flag
+ fasl-group-bits fasl-group-type fasl-group-length fasl-group-flag
+ q-fasl-group-dispatch m-fasl-group-dispatch fasl-group-dispatch-size
+ file-property-list cold-loaded-file-property-lists
+ cold-loaded-function-property-lists))
+
+(declaim (special qfasl-binary-file fdefine-file-pathname))
+
+;Each function defined has its name pushed on this list.
+;Then we send the list over together with the package to make
+;the DEFINITIONS property of the file.
+(defvar this-file-definitions)
+
+;Q-FASL-xxxx refers to functions which load into the cold load, and
+; return a "Q", i.e. a list of data-type and address-expression.
+;M-FASL-xxxx refers to functions which load into the current Lisp environment
+; (M used to be for Maclisp), and return a Lisp object.
+; However M-objects still have all their symbols in the SYM package.
+;In the FASL-TABLE, each entry in both the prefix and the main part
+; is a list whose car is the M (lisp) value and whose cadr is either
+; NIL or the Q-value. If it needs a Q-value and one hasn't been
+; computed yet, it will compute one, but this may put it in the wrong area.
+
+;These functions are used to refer to the FASL-TABLE
+
+;Get a Q object from FASL table
+(defun q-arft (x)
+ (cond ((atom (setq x (aref fasl-table x)))
+ (error "not a q - q-arft"))
+ ((cadr x))
+ (t (rplaca (cdr x) (make-q-list 'sym:init-list-area (car x)))
+ (cadr x))))
+
+;Get an M object
+(defun m-arft (x)
+ (cond ((atom (setq x (aref fasl-table x)))
+ (error "not a q - m-arft"))
+ (t (car x))))
+
+;Store an M object
+(defmacro m-asft (d x)
+ `(setf (aref fasl-table ,x) (list ,d nil)))
+
+;Store both M and Q objects
+(defmacro m-q-asft (d q x)
+ `(setf (aref fasl-table ,x) (list ,d ,q)))
+
+(defun cold-fasload (file)
+ (or (boundp 'q-fasl-group-dispatch) (initialize-fasl-environment))
+ (setq file (logical-pathname file))
+ (format t "~&Cold-fasload ~A~%" (namestring file))
+ (with-open-file (qfasl-binary-file file :direction :input
+ :element-type '(unsigned-byte 16))
+ (initialize-file-plist file)
+ (setq fdefine-file-pathname (store-string 'sym:p-n-string
+ (namestring (translate-logical-pathname file))))
+ (or (and (= (qfasl-nibble) #o143150)
+ (= (qfasl-nibble) #o71660))
+ (error "~A is not a QFASL file" (namestring file)))
+ (let (this-file-definitions)
+ (do () ((eq (qfasl-whack) 'eof)))
+ (set-file-loaded-id file)
+ ;; restore this for sys99
+ ;(record-definitions this-file-definitions)
+ )))
+
+;Add the list of function specs defined in a file
+;to that file's property list. The argument is a list in this world.
+(defun record-definitions (definitions)
+ (vstore-contents (1+ file-property-list)
+ (vlist* 'sym:property-list-area
+ (qintern 'sym:definitions)
+ ;;(list (cons package definitions))
+ (vlist 'sym:property-list-area
+ (vlist* 'sym:property-list-area
+ qnil
+ (make-q-list 'sym:property-list-area definitions)))
+ (vread (1+ file-property-list)))))
+
+;Initialize an element of *cold-loaded-file-property-lists* for this file.
+;The value of *cold-loaded-file-property-lists* is a list of elements:
+; (filenamestring . generic-file-plist)
+(defun initialize-file-plist (pathname)
+ (cond ((not (boundp 'cold-loaded-file-property-lists))
+ (setq cold-loaded-file-property-lists
+ (qintern 'sym:*cold-loaded-file-property-lists*))
+ (vwrite (+ cold-loaded-file-property-lists 1) qnil)))
+ (setq file-property-list (vlist* 'sym:property-list-area
+ (store-string 'sym:p-n-string (file-namestring pathname))
+ qnil))
+ (vstore-contents (+ cold-loaded-file-property-lists 1)
+ (vlist* 'sym:property-list-area
+ file-property-list
+ (vread (+ cold-loaded-file-property-lists 1)))))
+
+;This remembers where the file that we are building comes from
+(defun set-file-loaded-id (file &aux qid)
+ (setq qid (vlist* 'sym:property-list-area
+ (store-string 'sym:p-n-string
+ (file-namestring file))
+ (store-string 'sym:p-n-string
+ (multiple-value-bind (s m h d mo y)
+ (decode-universal-time (file-write-date file))
+
+ (format nil "~D/~D/~D ~D:~D:~D" mo d y h m s)))))
+ ;; ((nil fileversionid "coldloaded"))
+ (let ((id-prop (vlist 'sym:property-list-area
+ (vlist 'sym:property-list-area
+ qnil qid (store-string 'sym:p-n-string "COLDLOADED")))))
+ (let ((plist (vlist* 'sym:property-list-area
+ (qintern 'sym:file-id-package-alist)
+ id-prop
+ (vread (1+ file-property-list)))))
+ ;; plist = (file-id-package-alist ((nil fileversionid)))
+ ;; The nil will get replaced with the SI package later
+ (vstore-contents (+ file-property-list 1) plist))))
+
+;This is the function which gets a 16-bit "nibble" from the fasl file.
+(defun qfasl-nibble ()
+ (read-byte qfasl-binary-file))
+
+;This function processes one "whack" (independent section) of a fasl file.
+(defun qfasl-whack ()
+ (let ((fasl-table-fill-pointer sym:fasl-table-working-offset)
+ (fasl-return-flag nil))
+ (or (boundp 'fasl-table)
+ (setq fasl-table (make-array sym:length-of-fasl-table
+ :initial-element nil)))
+ (initialize-qfasl-table)
+ (do () (fasl-return-flag)
+ (qfasl-group nil))
+ fasl-return-flag))
+
+;Initialize FASL-TABLE prefix
+(defun initialize-qfasl-table ()
+ (setf (aref fasl-table sym:fasl-symbol-head-area) '(sym:nr-sym nil))
+ (setf (aref fasl-table sym:fasl-symbol-string-area) '(sym:p-n-string nil))
+ (setf (aref fasl-table sym:fasl-array-area)
+ '(sym:control-tables nil)) ;I GUESS
+ (setf (aref fasl-table sym:fasl-frame-area)
+ '(sym:macro-compiled-program nil))
+ (setf (aref fasl-table sym:fasl-list-area)
+ '(sym:init-list-area nil)) ;Not FASL-CONSTANTS-AREA!!
+ (setf (aref fasl-table sym:fasl-temp-list-area)
+ '(sym:fasl-temp-area nil)))
+
+(defun initialize-fasl-environment ()
+ (setf (logical-pathname-translations "sys")
+ '(("SYS:**;*.*.*" "/u12/lisp/mit/work/**/*.*")))
+ (setq fef-debugging-info-alist nil)
+ (setq fasl-group-dispatch-size (length sym:fasl-ops))
+ (setq q-fasl-group-dispatch (make-array fasl-group-dispatch-size))
+ (setq m-fasl-group-dispatch (make-array fasl-group-dispatch-size))
+ (do ((i 0 (1+ i))
+ (l sym:fasl-ops (cdr l))
+ (*package* (find-package "COLD"))
+ (m-op) (q-op))
+ ((= i fasl-group-dispatch-size))
+ (setq m-op (intern (format nil "M-~A" (car l)))
+ q-op (intern (format nil "Q-~A" (car l))))
+ (setf (aref m-fasl-group-dispatch i) m-op)
+ (setf (aref q-fasl-group-dispatch i) q-op)))
+
+;Process one "group" (a single operation)
+;Argument is NIL for Q-FASL, T for M-FASL.
+(defun qfasl-group (m-p &aux fasl-group-flag fasl-group-bits
+ fasl-group-type fasl-group-length)
+ (setq fasl-group-bits (qfasl-nibble))
+ (or (bit-test sym:%fasl-group-check fasl-group-bits)
+ (error "fasl-group-nibble-without-check-bit"))
+ (setq fasl-group-flag (bit-test sym:%fasl-group-flag fasl-group-bits)
+ fasl-group-length (lispm-ldb sym:%%fasl-group-length fasl-group-bits))
+ (and (= fasl-group-length #o377)
+ (setq fasl-group-length (qfasl-nibble)))
+ (setq fasl-group-type (logand sym:%fasl-group-type fasl-group-bits))
+ (or (< fasl-group-type fasl-group-dispatch-size)
+ (error "~O erroneous fasl group type" fasl-group-type))
+ (funcall (aref (if m-p m-fasl-group-dispatch q-fasl-group-dispatch) fasl-group-type)))
+
+;Get next nibble out of current group
+(defun qfasl-next-nibble ()
+ (cond ((zerop fasl-group-length) (error "fasl-group-overflow"))
+ (t (setq fasl-group-length (1- fasl-group-length))
+ (qfasl-nibble))))
+
+;Get next value for current group. Works by recursively evaluating a group.
+;This one gets a Q value
+(defun q-fasl-next-value ()
+ (q-arft (qfasl-group nil)))
+
+;This one gets an M value
+(defun m-fasl-next-value ()
+ (m-arft (qfasl-group t)))
+
+;This one gets both
+(defun m-q-fasl-next-value ()
+ (let ((idx (qfasl-group nil)))
+ (values (m-arft idx) (q-arft idx))))
+
+;FASL-OP's that create a value end up by calling this. The value is saved
+;away in the FASL-TABLE for later use, and the index is returned (as the
+;result of QFASL-GROUP).
+;This one enters an M object and a Q
+(defun m-q-enter-fasl-table (m q)
+ (cond ((not (< fasl-table-fill-pointer sym:length-of-fasl-table))
+ (error "fasl table overflow"))
+ (t
+ (m-q-asft m q fasl-table-fill-pointer)
+ (prog1 fasl-table-fill-pointer
+ (setq fasl-table-fill-pointer (1+ fasl-table-fill-pointer))))))
+
+;This one enters an M value
+(defun m-enter-fasl-table (v)
+ (cond ((not (< fasl-table-fill-pointer sym:length-of-fasl-table))
+ (error "fasl table overflow"))
+ (t
+ (m-asft v fasl-table-fill-pointer)
+ (prog1 fasl-table-fill-pointer
+ (setq fasl-table-fill-pointer (1+ fasl-table-fill-pointer))))))
+
+(defun m-q-store-evaled-value (m q)
+ (m-q-asft m q sym:fasl-evaled-value)
+ sym:fasl-evaled-value)
+
+
+;;;; --M-FASL ops
+
+(defun m-fasl-op-noop () 0)
+
+(defun m-fasl-op-index () (qfasl-next-nibble))
+
+(defun m-fasl-op-string ()
+ (m-enter-fasl-table (m-fasl-pname)))
+
+(defun m-fasl-op-symbol ()
+ (m-enter-fasl-table (cond (fasl-group-flag (make-symbol (m-fasl-pname)))
+ (t (intern (m-fasl-pname) sym-package)))))
+
+(defun m-fasl-op-package-symbol ()
+ (do ((i 0 (1+ i))
+ (path nil)
+ (sym)
+ (len (qfasl-next-nibble)))
+ ((= i len)
+ (setq path (nreverse path))
+ (cond ((> (length path) 2)
+ (error "Package path ~S has more than one prefix, I can't handle this"
+ path))
+ ((memq (car path) ;don't get faked out into splitting one symbol into two.
+ '(sym:si sym:system-internals sym:system sym:sys sym:global))
+ (m-enter-fasl-table (cadr path)))
+ (t
+ (setq sym (intern (format nil "~{~A~^:~}" path) sym-package))
+ (setf (get sym 'package-path) path)
+ (m-enter-fasl-table sym))))
+ (push (intern (m-fasl-next-value) sym-package) path))) ;fasl-value is string
+
+(defun m-fasl-pname () ;Return a string
+ (let ((len (* fasl-group-length 2))
+ lst lst2
+ str
+ tem)
+ (dotimes (i fasl-group-length)
+ (setq tem (qfasl-next-nibble))
+ (push (code-char (ldb (byte 8 0) tem)) lst)
+ (setq tem (ash tem -8))
+ (if (eq tem #o200)
+ (setq len (1- len))
+ (push (code-char tem) lst)))
+ (setq lst2 (nreverse lst))
+ (setq str (make-string len))
+ (dotimes (i len)
+ (setf (aref str i) (car lst2))
+ (setq lst2 (cdr lst2)))
+ str))
+
+;Generate a FIXNUM (or BIGNUM) value.
+(defun m-fasl-op-fixed ()
+ (do ((pos (* (1- fasl-group-length) #o20) (- pos #o20))
+ (c fasl-group-length (1- c))
+ (ans 0))
+ ((zerop c) (cond (fasl-group-flag (setq ans (- 0 ans))))
+ (m-enter-fasl-table ans))
+ (setq ans (lispm-dpb (qfasl-next-nibble) (+ (ash pos 6) #o20) ans))))
+
+;Generate a FIXNUM (or BIGNUM) value.
+(defun m-fasl-op-character ()
+ (error "m-fasl-op-character"))
+
+; (do ((pos (* (1- fasl-group-length) #o20) (- pos #o20))
+; (c fasl-group-length (1- c))
+; (ans 0))
+; ((zerop c)
+; (cond (fasl-group-flag (setq ans (- 0 ans))))
+; (setq ans (%make-pointer sym:dtp-character ans))
+; (m-enter-fasl-table ans))
+; (setq ans (lispm-dpb (qfasl-next-nibble) (+ (ash pos 6) #o20) ans))))
+
+;;; NEW FLOAT OP!! not yet written. See sys; qfasl
+
+(defun m-fasl-op-float ()
+ (q-fasl-op-float))
+
+(defun m-fasl-op-float-float ()
+ (prog (ans tmp)
+ (setq ans (float 0))
+ (%p-dpb-offset (qfasl-next-nibble) #o1013 ans 0)
+ (setq tmp (qfasl-next-nibble))
+ (%p-dpb-offset (lispm-ldb #o1010 tmp) #o0010 ans 0)
+ (%p-dpb-offset (lispm-dpb tmp #o2010 (qfasl-next-nibble)) #o0030 ans 1)
+ (return (m-enter-fasl-table ans))))
+
+
+(defun m-fasl-op-list () (q-fasl-op-list))
+
+(defun m-fasl-op-temp-list () (m-fasl-op-list1))
+
+(defun m-fasl-op-list-component () (q-fasl-op-list t))
+
+(defun m-fasl-op-list1 ()
+ (do ((list-length (qfasl-next-nibble) (1- list-length))
+ (lst nil) (adr) (tem))
+ ((zerop list-length)
+ (m-q-enter-fasl-table lst '**screw**))
+ (cond ((and fasl-group-flag (= list-length 1)) ;dotted
+ (rplacd adr (m-fasl-next-value)))
+ (t (setq tem (cons (m-fasl-next-value) nil))
+ (and adr (rplacd adr tem))
+ (or lst (setq lst tem))
+ (setq adr tem)))))
+
+;;;; --Q-FASL ops
+
+(defun q-fasl-op-noop () 0)
+
+(defun q-fasl-op-index () (qfasl-next-nibble))
+
+(defun q-fasl-op-string ()
+ (let ((str (m-fasl-pname)))
+ (m-q-enter-fasl-table str (store-string 'sym:p-n-string str))))
+
+(defun q-fasl-op-package-symbol ()
+ (let ((x (m-fasl-op-package-symbol)))
+ (q-arft x)
+ x))
+
+(defun q-fasl-op-symbol ()
+ (let ((sym (m-fasl-pname)))
+ (m-q-enter-fasl-table (if fasl-group-flag (make-symbol sym)
+ (setq sym (intern sym sym-package)))
+ (if fasl-group-flag ;uninterned
+ (store-symbol-vector sym 'sym:nr-sym)
+ (qintern sym)))))
+
+(defun q-fasl-op-fixed ()
+ (let ((x (m-fasl-op-fixed)))
+ (q-arft x)
+ x))
+
+(defun q-fasl-op-character ()
+ (let ((x (m-fasl-op-character)))
+ (q-arft x)
+ x))
+
+(defun q-fasl-op-float ()
+ (cond (fasl-group-flag (q-fasl-op-small-float))
+ (t (q-fasl-op-float-float))))
+
+(defun q-fasl-op-small-float ()
+ (let ((as-fixnum (lispm-dpb (qfasl-next-nibble) #o2010 (qfasl-next-nibble))))
+ ;; When running in systems after 98, we will want to
+ ;; change exponent from excess #o100 to excess #o200.
+; (setq as-fixnum (if (zerop as-fixnum) 0 (%pointer-plus as-fixnum #o40000000)))
+ (let ((num (%make-pointer sym:dtp-small-flonum as-fixnum)))
+ (m-q-enter-fasl-table num (make-small-flonum num)))))
+
+(defun q-fasl-op-float-float ()
+ (let ((x (m-fasl-op-float-float)))
+ (q-arft x)
+ x))
+
+
+;;; Total kludgery. FASL-OP-TEMP-LIST makes an M list, assumed to be
+;;; going to get fed to something like FASL-OP-ARRAY or FASL-OP-EVAL.
+;;; FASL-OP-LIST, on the other hand, makes a Q list, assumed to
+;;; be going to be used for something like a macro. In either case the
+;;; area specification in the FASL table is ignored.
+;;; Hopefully this kludgery stands some chance of working.
+
+(defun q-fasl-op-temp-list ()
+ (m-fasl-op-list))
+
+(defun q-fasl-op-list-component ()
+ (q-fasl-op-list t))
+
+(defun q-fasl-op-list (&optional component-flag)
+ (let ((area cold-list-area)
+ (list-length (qfasl-next-nibble))
+ lst c-code maclisp-list fasl-idx)
+ (or (memq area sym:list-structured-areas)
+ (error "q-fasl-op-list in non-list-structured area"))
+ (setq lst (allocate-block area list-length))
+ (do ((adr lst (1+ adr))
+ (len list-length (1- len)))
+ ((zerop len))
+ (setq c-code (cond ((and fasl-group-flag (= len 2)) sym:cdr-normal)
+ ((and fasl-group-flag (= len 1)) sym:cdr-error)
+ ((= len 1) sym:cdr-nil)
+ (t sym:cdr-next)))
+ (setq fasl-idx (qfasl-group nil))
+ (vwrite-cdr adr c-code (q-arft fasl-idx))
+ (setq maclisp-list (nconc maclisp-list
+ (if (and fasl-group-flag (= len 1)) (m-arft fasl-idx)
+ (cons (m-arft fasl-idx) nil)))))
+ (if (null component-flag)
+ (m-q-enter-fasl-table maclisp-list (vmake-pointer sym:dtp-list lst))
+ (m-q-store-evaled-value maclisp-list (vmake-pointer sym:dtp-list lst)))))
+
+;;;; Array stuff
+
+(defvar last-array-dims)
+(defvar last-array-type)
+
+;FASL-OP-ARRAY arguments are
+; <value> Area
+; <value> Type symbol
+; <value> The dimension or dimension list (use temp-list)
+; <value> Displace pointer (NIL if none)
+; <value> Leader (NIL, number, or list) (use temp-list)
+; <value> Index offset (NIL if none)
+; <value> Named-structure (only present if flag bit set)
+(defun q-fasl-op-array ()
+ (let* ((flag fasl-group-flag)
+ (area (m-fasl-next-value))
+ (type-sym (m-fasl-next-value))
+ (dims (m-fasl-next-value))
+ (displaced-p (m-fasl-next-value)) ;if non-nil, will it work?
+ (leader (m-fasl-next-value))
+ (index-offset (m-fasl-next-value)) ;if non-nil, will it work?
+ (named-structure nil)
+ (array nil) (data-length nil) (adr nil))
+ (setq area 'sym:control-tables) ;kludge, may not be needed any more
+ (cond (flag
+ (setq named-structure (m-fasl-next-value))))
+ (and (not (atom leader))
+ (setq leader (mapcar (function (lambda (x) (make-q-list 'sym:init-list-area x)))
+ leader)))
+ (setq last-array-dims (if (numberp dims) (list dims) dims))
+ (setq last-array-type type-sym)
+ (setq array (init-q-array-named-str area
+ nil ;return list of address and data-length
+ index-offset
+ type-sym
+ dims
+ displaced-p
+ leader
+ named-structure))
+ (setq data-length (cadr array)
+ array (vmake-pointer sym:dtp-array-pointer (car array)))
+ ;now store the data area
+ (and displaced-p (error "displaced array not handled"))
+ (setq adr (allocate-block area data-length))
+ (cond ((cdr (assoc type-sym sym:array-bits-per-element :test #'eq)) ;numeric
+ (dotimes (i data-length)
+ (vwrite (+ adr i) 0)))
+ (t
+ (cond ((and named-structure (not leader))
+ (vwrite adr (qintern named-structure))
+ (setq adr (1+ adr)
+ data-length (1- data-length))))
+ (dotimes (i data-length)
+ (vwrite (+ adr i) qnil))))
+ (m-q-enter-fasl-table
+ "note - you have been screwed to the wall by an array"
+ array)))
+
+;Get values and store them into an array.
+(defun q-fasl-op-initialize-array ()
+ (prog (array num hack ptr header long-flag ndims)
+ (setq hack (qfasl-group nil))
+ (setq array (q-arft hack))
+ (or (= (vdata-type array) sym:dtp-array-pointer)
+ (error "fasl-op-initialize-array of non-array"))
+ (setq num (m-fasl-next-value)) ;number of values to initialize with
+ ;; Take header apart to find address of data
+ (setq ptr (logand q-pointer-mask array))
+ (setq header (vread ptr))
+ (setq long-flag (bit-test sym:array-long-length-flag header)
+ ndims (logand (rem header sym:array-dim-mult) 7))
+ (and (bit-test sym:array-displaced-bit header)
+ (error "attempt to initialize displaced array, give it up"))
+ (unless (<= 1 (length last-array-dims) 2)
+ (error "Only 1 and 2-dimensional arrays can be loaded."))
+ (setq ptr (+ ptr (if long-flag 1 0) ndims)) ;To data
+ (if (eq array-index-order sym:new-array-index-order)
+ ;; Order of data matches order in world being created, so it's easy.
+ (dotimes (n num) ;Initialize specified num of vals
+ (vwrite ptr (q-fasl-next-value))
+ (setq ptr (1+ ptr)))
+ (error "Need to swap array dimensions."))
+ ;; XXX
+; (let ((temp1 (make-array last-array-dims :initial-element qnil)) temp2)
+; ;; Read in the values, then transpose them,
+; (dotimes (n num)
+; (setf (ar-1-force temp1 n) (q-fasl-next-value)))
+; (setq temp2 (math:transpose-matrix temp1))
+ ;; Then write them into the cold load in their new order.
+; (dotimes (n (array-length temp2))
+; (vwrite ptr (ar-1-force temp2 n))
+; (setq ptr (1+ ptr)))))
+ (return hack)))
+
+;Get 16-bit nibbles and store them into an array.
+(defun q-fasl-op-initialize-numeric-array ()
+ (prog (array num hack ptr header long-flag ndims)
+ (setq hack (qfasl-group nil))
+ (setq array (q-arft hack))
+ (or (= (vdata-type array) sym:dtp-array-pointer)
+ (error "fasl-op-initialize-array of non-array"))
+ (setq num (m-fasl-next-value)) ;number of values to initialize with
+ ;; Take header apart to find address of data
+ (setq ptr (logand q-pointer-mask array))
+ (setq header (vread ptr))
+ (setq long-flag (bit-test sym:array-long-length-flag header)
+ ndims (lispm-ldb sym:%%array-number-dimensions header))
+ (and (bit-test sym:array-displaced-bit header)
+ (error "attempt to initialize displaced array, give it up"))
+ (setq ptr (+ ptr (if long-flag 1 0) ndims)) ;To data
+ (unless (or (= (length last-array-dims) 1)
+ (and (= (length last-array-dims) 2)
+ (eq last-array-type 'sym:art-16b)))
+ (error "Only 1-dimensional, or 2-dimensional art-16b, numeric arrays can be loaded."))
+
+ (if (or (= (length last-array-dims) 1)
+ (eq array-index-order sym:new-array-index-order))
+ ;; Order of data matches order in world being created, so it's easy.
+ (progn
+ (dotimes (n (/ num 2)) ;Initialize specified num of vals
+ (vwrite ptr (+ (qfasl-nibble) (ash (qfasl-nibble) 16.)))
+ (setq ptr (1+ ptr)))
+ (cond ((oddp num) ;odd, catch last nibble
+ (vwrite ptr (qfasl-nibble)))))
+ (error "Need to swap array dimensions."))
+ ;; XXX
+; (let ((temp1 (make-array last-array-dims ':type art-16b)) temp2)
+ ;; Read in the values, then transpose them,
+; (dotimes (n num) ;Initialize specified num of vals
+; (setf (ar-1-force temp1 n) (qfasl-nibble)))
+; (setq temp2 (math:transpose-matrix temp1))
+ ;; Then write them into the cold load in their new order.
+; (dotimes (n (floor (array-length temp2) 2))
+; (vwrite ptr (lispm-dpb (ar-1-force temp2 (+ n n 1)) 2020 (ar-1-force temp2 (+ n n))))
+; (incf ptr))
+; (if (oddp (array-length temp2))
+; (vwrite ptr (ar-1-force temp2 (1- (array-length temp2)))))))
+ (return hack)))
+
+(defun q-fasl-op-eval ()
+ (error "FASL-OP-EVAL isn't supposed to be used any more."))
+
+;(defun q-fasl-op-eval ()
+; (let ((exp (m-arft (qfasl-next-nibble))))
+; (cond ((and (not (atom exp))
+; (eq (car exp) 'sym:record-source-file-name)
+; (not (atom (cadr exp)))
+; (eq (caadr exp) 'sym:quote)
+; (symbolp (cadadr exp)))
+; (store-source-file-name-property (qintern (cadadr exp))))
+; (t ;; If this is a defvar or defconst, store the value now
+; ;; in addition to causing it to be evaluated later.
+; ;; The evaluation later sets appropriate properties,
+; ;; while storing the value now prevents lossage
+; ;; if the value is used while performing the initialization.
+; (and (not (atom exp))
+; (memq (car exp) '(sym:defvar-1 sym:defconst-1))
+; (cddr exp) ;Only if a value is specified!
+; (or (memq (caddr exp) '(sym:t sym:nil))
+; (stringp (caddr exp)) (numberp (caddr exp))
+; (quotep (caddr exp)))
+; (progn
+; (vstore-contents (1+ (qintern (cadr exp)))
+; (make-q-list 'sym:init-list-area
+; (if (quotep (caddr exp))
+; (cadr (caddr exp))
+; (caddr exp))))))
+; (setq evals-to-be-sent-over
+; (setq last-fasl-eval (cons exp evals-to-be-sent-over))))))
+; (m-q-store-evaled-value 'value-only-available-in-the-future
+; 'value-only-available-in-the-future))
+
+(defun quotep (exp)
+ (and (consp exp) (eq (car exp) 'sym:quote)))
+
+(defun q-fasl-op-move ()
+ (let* ((from (qfasl-next-nibble))
+ (to (qfasl-next-nibble)))
+ (cond ((= to #o177777) (m-q-enter-fasl-table (car (aref fasl-table from))
+ (cadr (aref fasl-table from))))
+ (t (setf (aref fasl-table to) (aref fasl-table from))
+ to))))
+
+;;;; Macrocompiled code
+
+(defun q-fasl-op-frame ()
+ (let* ((q-count (qfasl-next-nibble)) ;number of boxed qs
+ (unboxed-count (qfasl-next-nibble)) ;number of unboxed qs (half num instructions)
+ (fef) ;the fef being created
+ (obj)
+ (m-obj)
+ (fname)
+ (tem)
+ (offset 0)
+ (area 'sym:macro-compiled-program)) ;(m-arft sym:fasl-frame-area)
+ (setq fasl-group-length (qfasl-next-nibble)) ;amount of stuff that follows
+ (setq fef (vmake-pointer sym:dtp-fef-pointer ;Store header
+ (storeq area (vmake-pointer sym:dtp-header
+ (m-fasl-next-value)))))
+ (qfasl-next-nibble) ;skip modifier nibble for header q
+ (do ((i 1 (1+ i))) ((>= i q-count)) ;fill in boxed qs
+ (multiple-value-setq (m-obj obj) (m-q-fasl-next-value)) ;get object to be stored
+ (setq tem (qfasl-next-nibble)) ;get ultra-kludgey modifier
+ (or (zerop (setq offset (logand #o17 tem))) ;add offset if necessary
+ (setq obj (+ obj offset)))
+ (and (bit-test #o420 tem) ;try not to get shafted totally
+ (or (= (vdata-type obj) sym:dtp-symbol)
+ (error "about to get shafted totally - q-fasl-op-frame")))
+ (and (bit-test #o20 tem) ;make into external value cell pointer
+ (setq obj (vmake-pointer sym:dtp-external-value-cell-pointer obj)))
+ (and (bit-test #o400 tem) ;make into locative
+ (setq obj (vmake-pointer sym:dtp-locative obj)))
+ (setq obj (lispm-dpb (ash tem -6) sym:%%q-cdr-code obj))
+ (storeq area obj)
+ (if (= i sym:%fefhi-fctn-name) (setq fname m-obj)))
+ (push (cons fname m-obj) fef-debugging-info-alist)
+ (begin-store-halfwords area unboxed-count) ;now store the unboxed qs
+ (do ((n 0 (1+ n))
+ (num (* 2 unboxed-count)))
+ ((= n num))
+ (store-halfword (qfasl-next-nibble)))
+ (end-store-halfwords)
+ (m-q-enter-fasl-table
+ "note - you have been screwed to the wall by a fef"
+ fef)))
+
+(defun q-fasl-op-function-header ()
+ (prog (f-sxh)
+ (setq current-function (m-fasl-next-value)
+ f-sxh (m-fasl-next-value))
+ (return 0)))
+
+(defun q-fasl-op-function-end () 0)
+
+(defprop sym:|:INTERNAL| (keyword internal) package-path)
+(defprop sym:|:PROPERTY| (keyword property) package-path)
+(defprop sym:|:INTERNAL-FEF-OFFSETS| (keyword internal-fef-offsets) package-path)
+(defprop sym:|:SOURCE-FILE-NAME| (keyword source-file-name) package-path)
+
+(defun q-fasl-storein-symbol-cell (n put-source-file-name-property)
+ (prog (newp adr data sym nib)
+ (setq nib (qfasl-next-nibble))
+ (setq sym (m-fasl-next-value))
+ (and put-source-file-name-property
+ (or (atom sym) (not (eq (car sym) 'sym:|:INTERNAL|)))
+ (store-source-file-name-property sym (if (= n 1) 'defvar 'defun)))
+ (and (cond ((= nib sym:fasl-evaled-value)
+ ;; From fasl-op-eval
+ (or (setq data last-fasl-eval)
+ (error "~S invalid storein-symbol" sym))
+ t)
+ ;; From fasl-op-eval1
+ ((listp (setq data (q-arft nib)))))
+ ;; Setting symbol to result of some evaluation
+ (cond ((atom sym) ;Modify the entry in EVALS-TO-BE-SENT-OVER
+ (rplaca data
+ `(,(case n
+ (1 'set)
+ (2 'fset)
+ (otherwise
+ (error
+ "Result of evaluation must be stored in value or function cell"
+ )))
+ (sym:quote ,sym) ,(car data)))
+ (return 0)) ;Skip the rest of this function
+ (t (error "Must be a sym evaled-value"))))
+ (cond ((atom sym)
+ (setq sym (qintern sym))
+ (vstore-contents (+ sym n) data))
+ ((eq (car sym) 'sym:|:INTERNAL|)
+ (or (= n 2) (error "~S only allowed for function cell" sym))
+ (let* ((parent (cadr sym))
+ (index (caddr sym))
+ (table (cdr (assoc 'sym:|:INTERNAL-FEF-OFFSETS|
+ (cdr (assoc parent fef-debugging-info-alist))
+ :test #'eq)))
+ (fef (qfdefinition parent)))
+ (or table (error "Cannot locate internal-fef-offsets for ~S" sym))
+ (or (= (lispm-ldb sym:%%q-data-type fef) sym:dtp-fef-pointer)
+ (error "~S not fef as function definition of ~S" fef parent))
+ (vstore-contents (+ fef (nth index table)) data)))
+ ;; E.g. (DEFUN (FOO PROP) (X Y) BODY)
+ ;; - thinks it's storing function cell but really PUTPROP
+ ((not (and (= n 2) (eq (car sym) 'sym:|:PROPERTY|)))
+ (error "~S not a symbol or property spec" sym))
+ (t (setq adr (qintern (cadr sym)))
+ (setq newp (vmake-pointer sym:dtp-list
+ (store-cdr-q 'sym:property-list-area sym:cdr-next
+ (qintern (caddr sym)))))
+ (store-cdr-q 'sym:property-list-area sym:cdr-normal data)
+ (store-cdr-q 'sym:property-list-area sym:cdr-error (vread (+ adr 3)))
+ (vstore-contents (+ adr 3) newp)))
+ (return 0)))
+
+(defun qfdefinition (sym)
+ (cond ((symbolp sym) (vread (+ (qintern sym) 2)))
+ ((eq (car sym) 'sym:|:INTERNAL|)
+ (let* ((parent (cadr sym))
+ (index (caddr sym))
+ (table (cdr (assoc 'sym:|:INTERNAL-FEF-OFFSETS|
+ (cdr (assoc parent fef-debugging-info-alist))
+ :test #'eq)))
+ (fef (qfdefinition parent)))
+ (or table (error "Cannot locate internal-fef-offsets for ~S" sym))
+ (vread (+ fef (nth index table)))))
+ (t (error "~S garbage function spec" sym))))
+
+;The value of cold-load-function-property-lists is a list of elements:
+; (function-spec indicator value)
+(defun store-source-file-name-property (sym type)
+ (push (cons sym type)
+ this-file-definitions)
+ (cond ((atom sym)
+ (let* ((sym (qintern sym))
+ (old-prop-location (vget-location-or-nil (+ sym 3)
+ (qintern 'sym:|:SOURCE-FILE-NAME|))))
+ (cond ((= old-prop-location qnil)
+ ;; No existing :source-file-name property. Create one.
+ (let ((lst (if (eq type 'defun)
+ fdefine-file-pathname
+ (vlist 'sym:property-list-area
+ (vlist 'sym:property-list-area (qintern type)
+ fdefine-file-pathname)))))
+ (vstore-contents (+ sym 3)
+ (vlist* 'sym:property-list-area
+ (qintern 'sym:|:SOURCE-FILE-NAME|)
+ lst
+ (vcontents (+ sym 3))))))
+ (t
+ ;; Existing property. If it is not a list, just a pathname,
+ ;; convert it to a list.
+ (unless (= (vdata-type (vcontents old-prop-location)) sym:dtp-list)
+ (vstore-contents old-prop-location
+ (vlist 'sym:property-list-area
+ (vlist 'sym:property-list-area
+ (qintern 'defun)
+ (vcontents old-prop-location)))))
+ ;; Then add a new element to the property value.
+ (vstore-contents old-prop-location
+ (vlist* 'sym:property-list-area
+ (vlist 'sym:property-list-area (qintern type)
+ fdefine-file-pathname)
+ (vcontents old-prop-location)))))))
+ (t
+ (cond ((not (boundp 'cold-loaded-function-property-lists))
+ (setq cold-loaded-function-property-lists
+ (qintern 'sym:cold-load-function-property-lists))
+ (vwrite (+ cold-loaded-function-property-lists 1) qnil)))
+ (let ((elem (vmake-pointer sym:dtp-list
+ (store-cdr-q 'sym:property-list-area sym:cdr-next
+ (make-q-list 'sym:property-list-area sym)))))
+ (store-cdr-q 'sym:property-list-area sym:cdr-next (qintern 'sym:|:SOURCE-FILE-NAME|))
+ (store-cdr-q 'sym:property-list-area sym:cdr-nil fdefine-file-pathname)
+ (let ((newp (vmake-pointer sym:dtp-list
+ (store-cdr-q 'sym:property-list-area sym:cdr-normal
+ elem))))
+ (store-cdr-q 'sym:property-list-area sym:cdr-error
+ (vread (+ cold-loaded-function-property-lists 1)))
+ (vstore-contents (+ cold-loaded-function-property-lists 1) newp))))))
+
+(defun q-fasl-op-storein-symbol-value ()
+ (q-fasl-storein-symbol-cell 1 nil))
+
+(defun q-fasl-op-storein-function-cell ()
+ (q-fasl-storein-symbol-cell 2 t))
+
+(defun q-fasl-op-storein-property-cell ()
+ (q-fasl-storein-symbol-cell 3 nil))
+
+(defun q-fasl-op-storein-array-leader ()
+ (let* ((array (q-arft (qfasl-next-nibble)))
+ (subscr (m-arft (qfasl-next-nibble)))
+ (value (q-arft (qfasl-next-nibble))))
+ ;;error checking might be nice
+ ;(store-array-leader value array subscr)
+ (vwrite (- array (+ 2 subscr)) value)
+ 0))
+
+(defun q-fasl-fetch-symbol-cell (n)
+ (let* ((sym (q-fasl-next-value))
+ (val (vcontents (+ sym n))))
+ (if (= (vdata-type val) sym:dtp-null)
+ (error "fetch of unbound symbol cell"))
+ (m-q-enter-fasl-table "symbol component" val)))
+
+(defun q-fasl-op-fetch-symbol-value ()
+ (q-fasl-fetch-symbol-cell 1))
+
+(defun q-fasl-op-fetch-function-cell ()
+ (q-fasl-fetch-symbol-cell 2))
+
+(defun q-fasl-op-fetch-property-cell ()
+ (q-fasl-fetch-symbol-cell 3))
+
+(defun q-fasl-op-end-of-whack ()
+ (setq fasl-return-flag 'end-of-whack)
+ 0)
+
+(defun q-fasl-op-end-of-file ()
+ (setq fasl-return-flag 'eof)
+ 0)
+
+(defun q-fasl-op-soak ()
+ (dotimes (count (qfasl-next-nibble))
+ (m-fasl-next-value))
+ (qfasl-group t))
+
+(defun q-fasl-op-set-parameter ()
+ (let* ((to (m-fasl-next-value))
+ (from (qfasl-group t)))
+ (setf (aref fasl-table to) (aref fasl-table from))
+ 0))
+
+(defun q-fasl-op-file-property-list ()
+ (vstore-contents (+ file-property-list 1) (q-fasl-next-value))
+ 0)
+
+;;; Pathnames are dumped out so as to turn into real ones when fasloaded,
+;;; fake up a string instead. fs:canonicalize-cold-load-pathames will fix it back.
+(defun q-fasl-op-eval1 (&aux form pathname)
+ (setq form (m-fasl-next-value))
+ ;(format t "op-eval1: ~S~%" form)
+ (cond ((memq (car form) '(sym:|FS:MAKE-PATHNAME-INTERNAL|
+ sym:|FS:MAKE-FASLOAD-PATHNAME|))
+ (or (setq pathname (do ((flist (cdr form) (cdr flist))
+ (plist nil)
+ (elem))
+ ((null flist)
+ (nreverse plist))
+ (setq elem (car flist))
+ (or (and (listp elem)
+ (eq (car elem) 'sym:quote))
+ (return nil))
+ (setq elem (cadr elem))
+ ;; Fix up host
+ (cond ((and (null plist) (stringp elem)))
+ ((memq elem '(sym:unspecific sym:|:UNSPECIFIC|))
+ (setq elem :unspecific))
+ ((memq elem '(sym:newest sym:|:NEWEST|))
+ (setq elem 1))
+ ((or (null elem) (stringp elem) (numberp elem)))
+ ((listp elem)
+ (if (dolist (elemelem elem)
+ (or (stringp elemelem) (return t)))
+ (return nil)))
+ (t (return nil)))
+ (push elem plist)))
+ (error "This pathname is too complicated for me ~S" form))
+ (setq pathname (cold-pathname pathname))
+ (m-q-enter-fasl-table pathname (store-string 'sym:p-n-string pathname)))
+ ((eq (car form) 'sym:record-source-file-name)
+ (store-source-file-name-property (cadr (cadr form)) (cadr (caddr form)))
+ (m-q-enter-fasl-table nil qnil))
+ ;; I have a suspicion the next clause does nothing
+ ;; because the compiler does not express DEFF in this way.
+ ((and (eq (car form) `sym:deff)
+ (symbolp (cadr (cadr form))))
+ (store-source-file-name-property (cadr (cadr form)) 'defun)
+ (push form evals-to-be-sent-over)
+; (vstore-contents (+ (qintern function) 2)
+; (make-q-list 'sym:init-list-area defsym))
+; (unless (= (lispm-ldb sym:%%q-data-type (vcontents (+ (qintern defsym) 2)))
+; sym:dtp-null)
+; (vstore-contents (+ (qintern function) 2) (vcontents (+ (qintern defsym) 2))))
+ )
+ ((and (eq (car form) `sym:forward-value-cell) ;(sym:quote ,alias-sym) (sym:quote ,defsym))
+ (symbolp (cadr (cadr form))) (symbolp (cadr (caddr form))))
+ (push form evals-to-be-sent-over)
+ (vstore-contents (+ (qintern (cadr (cadr form))) 1)
+ (lispm-dpb sym:dtp-one-q-forward
+ sym:%%q-data-type
+ (+ (qintern (cadr (caddr form))) 1))))
+ (t
+ ;; If this is a defvar or defconst, store the value now
+ ;; in addition to causing it to be evaluated later.
+ ;; The evaluation later sets appropriate properties,
+ ;; while storing the value now prevents lossage
+ ;; if the value is used while performing the initialization.
+ (cond ((and (not (atom form))
+ (memq (car form) '(sym:defvar-1 sym:defconst-1)))
+ (and (cddr form) ;Only if a value is specified!
+ (or (memq (caddr form) '(sym:t sym:nil))
+ (stringp (caddr form)) (numberp (caddr form))
+ (quotep (caddr form)))
+ (vstore-contents (1+ (qintern (cadr form)))
+ (make-q-list 'sym:init-list-area
+ (if (quotep (caddr form))
+ (cadr (caddr form))
+ (caddr form)))))
+ (store-source-file-name-property (cadr form) 'defvar)))
+ (push form evals-to-be-sent-over)
+ ;; We store a pointer to the position in the evals to be sent over in the
+ ;; q fasl table. q-fasl-storein-symbol-cell knows how to interpret this.
+ (m-q-enter-fasl-table 'value-only-available-in-the-future
+ evals-to-be-sent-over))))
+
Added: trunk/tools/cold/coldst.lisp
==============================================================================
Binary file. No diff available.
Added: trunk/tools/cold/coldut.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/coldut.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,1481 @@
+; -*- Mode:LISP; Package:COLD; Base:8; Lowercase:T; Readtable:T -*-
+; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+; Utilities for cold-load generator
+
+(in-package :cold)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; To compile this: ;;;
+;;; (1) Load the old QFASL of it ;;;
+;;; (2) Run (LOAD-PARAMETERS) ;;;
+;;; (3) Now you may compile it ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Little variables that have to do with the word format
+(defvar big-fixnum)
+(defvar little-fixnum)
+(defvar q-typed-pointer-mask) ;Due to deficiencies in LDB and DPB
+(defvar q-pointer-mask)
+(defvar array-index-order nil)
+
+;; Needed for sys99
+(defvar sym:lambda-list-keywords
+ '(&optional &rest &key &allow-other-keys &aux
+ &special &local &functional &eval "e
+ &environment &list-of &body &whole))
+
+(defun assign-alternate (x)
+ (prog nil
+ l (cond ((null x)(return nil)))
+ (set (intern (symbol-name (car x))) (cadr x))
+ (setq x (cddr x))
+ (go l)))
+
+(defun get-alternate (x)
+ (prog (y)
+ l (cond ((null x) (return (reverse y))))
+ (setq y (cons (car x) y))
+ (setq x (cddr x))
+ (go l)))
+
+(defun assign-values (input-list &optional (shift 0) (init 0) (delta 1))
+ (prog ()
+lp (cond ((null input-list) (return init)))
+ (proclaim `(special ,(car input-list)))
+ (set (car input-list) (ash init shift))
+ (setq input-list (cdr input-list))
+ (setq init (+ init delta))
+ (go lp)))
+
+(defun assign-values-init-delta (input-list shift init delta)
+ (prog nil
+lp (cond ((null input-list) (return init)))
+ (set (car input-list) (ash init shift))
+ (setq input-list (cdr input-list))
+ (setq init (+ init delta))
+ (go lp)))
+
+(defmacro defprop (s v p)
+ `(setf (get ',s ',p) ',v))
+
+(defun atomeval (x)
+ (cond ((numberp x) x)
+ (t (symbol-value x))))
+
+(defun list-product (x)
+ (do ((l x (cdr l))
+ (ans 1))
+ ((null l) ans)
+ (setq ans (* ans (atomeval (car l))))))
+
+(defun memq (o l)
+ (member o l :test #'eq))
+
+(defun lispm-ldb (ppss val)
+ (let ((p (ldb (byte 5 6) ppss))
+ (s (ldb (byte 5 0) ppss)))
+ (ldb (byte s p) val)))
+
+(defun lispm-dpb (newbyte ppss val)
+ (let ((p (ldb (byte 5 6) ppss))
+ (s (ldb (byte 5 0) ppss)))
+ (dpb newbyte (byte s p) val)))
+
+(defun bit-test (x y)
+ (not (zerop (logand x y))))
+
+(defun cold-pathname (p)
+ (format nil "~A: ~{/~A~}/~A.~A"
+ (car p) (caddr p) (cadddr p) (car (cddddr p))))
+
+(defun %make-pointer (data-type address)
+ (lispm-dpb data-type sym:%%q-all-but-pointer address))
+
+(defun %pointer (x)
+ (logand q-pointer-mask x))
+
+(defun lispm-length (x)
+ (cond ((atom x) 0)
+ ((and (consp x) (atom (cdr x))) 1)
+ (t (1+ (lispm-length (cdr x))))))
+
+;;; The virtual memory
+
+;; On the Lispm there is a cache of 16 pages in use and pages are read
+;; in and flushed to disk as necessary. In a 64-bit Common Lisp we may
+;; as well just keep all the pages in memory until the end.
+;;
+;; Also just use a fixnum array for each page in Common Lisp
+
+(defvar n-vmem-pages 0)
+
+;(i,0) is virtual page number, (i,1) is rqb
+;Both slots are nil if unused
+(defvar vmem-pages)
+
+(defvar vmem-highest-address nil)
+
+(defun vmem-initialize ()
+ (setq n-vmem-pages (/ vmem-highest-address sym:page-size))
+ (setq vmem-pages (make-array n-vmem-pages :initial-element nil)))
+
+(defun write-page (p s)
+ (do ((i 0 (1+ i))
+ (w))
+ ((= i sym:page-size) nil)
+ (setq w (aref p i))
+ (write-byte (ldb (byte 8 0) w) s)
+ (write-byte (ldb (byte 8 8) w) s)
+ (write-byte (ldb (byte 8 16) w) s)
+ (write-byte (ldb (byte 8 24) w) s)))
+
+(defun write-blank-page (s vpn)
+ (do ((i 0 (1+ i))
+ (w (lispm-dpb sym:dtp-free sym:%%q-data-type (* vpn sym:page-size))
+ (1+ w)))
+ ((= i sym:page-size) nil)
+ (write-byte (ldb (byte 8 0) w) s)
+ (write-byte (ldb (byte 8 8) w) s)
+ (write-byte (ldb (byte 8 16) w) s)
+ (write-byte (ldb (byte 8 24) w) s)))
+
+;Write out all the buffered pages and return the rqb's
+(defun vmem-finish (name &aux buf)
+ (with-open-file (s name :direction :output :if-exists :supersede
+ :element-type '(unsigned-byte 8))
+ (dotimes (i n-vmem-pages)
+ (cond ((setq buf (aref vmem-pages i))
+ (write-page (aref vmem-pages i) s)
+ ;(setf (aref vmem-pages i) nil)
+ )
+ (t (write-blank-page s i))
+ ))))
+
+;Given address returns fixnum array containing that page.
+(defun vmem-find-page (address &optional (init nil))
+ (if (> (logand q-pointer-mask address) vmem-highest-address)
+ (error "vmem-highest-address exceeded"))
+ (let* ((vpn (truncate ;(lispm-ldb sym:%%q-pointer address)
+ (logand q-pointer-mask address)
+ sym:page-size))
+ (buf (aref vmem-pages vpn)))
+ (when (null buf)
+ (setq buf (make-array sym:page-size :element-type 'fixnum))
+ (when init
+ (do ((j 0 (1+ j))
+ (tem (lispm-dpb sym:dtp-free sym:%%q-data-type
+ (* vpn sym:page-size))))
+ ((= j sym:page-size))
+ (setf (aref buf j)
+ (+ tem j))))
+ (setf (aref vmem-pages vpn) buf))
+ buf))
+
+(defun vread (address)
+ (let ((buf (vmem-find-page address)))
+ (aref buf (rem address sym:page-size))))
+
+(defun vwrite (address value)
+ (let ((buf (vmem-find-page address)))
+ (setf (aref buf (rem address sym:page-size)) value)))
+
+;(defun vwrite-low (address value)
+; (let ((buf (vmem-find-page address))
+; (i (* 2 (rem address sym:page-size))))
+; (setf (aref buf i) value )))
+
+;(defun vwrite-high (address value)
+; (let ((buf (vmem-find-page address))
+; (i (* 2 (rem address sym:page-size))))
+; (aset value buf (1+ i))))
+
+(defun vcontents (address)
+ (logand q-typed-pointer-mask (vread address)))
+
+(defun vcdr-code (address)
+ (lispm-ldb sym:%%q-cdr-code (vread address)))
+
+(defun vstore-contents (address value)
+ (let ((buf (vmem-find-page address))
+ (i (rem address sym:page-size)))
+ (setf (aref buf i)
+ (lispm-dpb value sym:%%q-typed-pointer (aref buf i)))))
+
+(defun vstore-cdr-code (address value)
+ (let ((buf (vmem-find-page address))
+ (i (rem address sym:page-size)))
+ (setf (aref buf i)
+ (lispm-dpb value sym:%%q-cdr-code (aref buf i)))))
+
+(defun vwrite-cdr (address cdr-code value)
+ (vwrite address (lispm-dpb cdr-code sym:%%q-cdr-code value)))
+
+(defmacro vmake-pointer (data-type address)
+ `(lispm-dpb ,data-type sym:%%q-all-but-pointer ,address))
+
+(defmacro vpointer (value)
+ `(logand q-pointer-mask ,value))
+
+(defmacro vdata-type (value)
+ `(lispm-ldb sym:%%q-data-type ,value))
+
+(defmacro vfix (value)
+ `(vmake-pointer sym:dtp-fix ,value))
+
+(defun vlist (area &rest elements)
+ (if (null elements)
+ qnil
+ (let ((value (vmake-pointer sym:dtp-list
+ (store-cdr-q area sym:cdr-next (car elements)))))
+ (dolist (element (cdr elements))
+ (store-cdr-q area sym:cdr-next element))
+ (vstore-cdr-code (+ value (length elements) -1) sym:cdr-nil)
+ value)))
+
+(defun vlist* (area &rest elements)
+ (cond ((null elements) (error "Too few arguments to VLIST*"))
+ ((null (cdr elements)) (car elements))
+ (t
+ (let ((value (vmake-pointer sym:dtp-list
+ (store-cdr-q area sym:cdr-next (car elements)))))
+ (dolist (element (cdr elements))
+ (store-cdr-q area sym:cdr-next element))
+ (vstore-cdr-code (+ value (length elements) -1) sym:cdr-error)
+ (vstore-cdr-code (+ value (length elements) -2) sym:cdr-normal)
+ value))))
+
+(defun vcar (location)
+ (vcontents location))
+
+(defun vcdr (location)
+ (let ((cdr-code (vcdr-code location)))
+ (cond ((= cdr-code sym:cdr-nil) qnil)
+ ((= cdr-code sym:cdr-next) (1+ location))
+ ((= cdr-code sym:cdr-normal) (vcontents (1+ location)))
+ ((= cdr-code sym:cdr-error)
+ (error "Location ~O contains CDR-ERROR." (vpointer location))))))
+
+;If no property, returns a NIL in this machine.
+;If property found, returns other-machine pointer to cell whose car is the property value.
+(defun vget-location-or-nil (location property)
+ (do ((cell (vcontents location) (vcdr (vcdr cell))))
+ ((= cell qnil) qnil)
+ (if (= (vcontents cell) property)
+ (return (vcdr cell)))))
+
+
+;;;; a bit of stuff for debugging
+
+(defun vprint-q (q)
+ (format t "~%CDR-CODE ~s, DATA-TYPE ~s (~s), POINTER ~s"
+ (lispm-ldb sym:%%q-cdr-code q)
+ (vdata-type q)
+ (nth (vdata-type q) sym:q-data-types)
+ (vpointer q)))
+
+(defvar vprinlength #o200)
+(defvar vprinlevel #o20)
+(defvar vmax-stringlength #o200)
+
+(defun vprint (typed-pointer &optional (vprinlevel vprinlevel))
+ (let ((prinlength-count 0)
+ (data-type (vdata-type typed-pointer))
+ (pointer (vpointer typed-pointer)))
+ (cond ((vatom? typed-pointer)
+ (cond ((= data-type sym:dtp-symbol)
+ (vprint-string (vcontents pointer)))
+ ((= data-type sym:dtp-fix)
+ (print pointer))
+ (t (vprint-bomb typed-pointer))))
+ ((= data-type sym:dtp-array-pointer)
+ (let ((header (vcontents pointer)))
+ (cond ((= (mask-field-from-fixnum sym:%%array-type-field header)
+ sym:art-string)
+ (princ "#\"")
+ (vprint-string typed-pointer)
+ (princ "#\""))
+ (t (vprint-bomb typed-pointer)))))
+ ((= data-type sym:dtp-list)
+ (cond ((= vprinlevel 0)
+ (princ "#"))
+ (t
+ (princ "(")
+ (prog ((l typed-pointer))
+ l (cond ((> (setq prinlength-count (1+ prinlength-count))
+ vprinlength)
+ (princ "...")
+ (return nil))
+ ((vatom? l)
+ (cond ((vnull? l)
+ (princ ")"))
+ (t
+ (princ " . ")
+ (vprint l (1- vprinlevel))))))
+ (vprint (vcar l) (1- vprinlevel))
+ (setq l (vcdr l))
+ (go l)))))
+ (t (vprint-bomb typed-pointer)))))
+
+(defun vprint-bomb (typed-pointer)
+ (vprint-q typed-pointer))
+
+(defun vprint-string (string)
+ (let* ((pointer (vpointer string))
+ (header (vcontents pointer))
+ (long-flag (lispm-ldb sym:%%array-long-length-flag header))
+ (len (min vmax-stringlength
+ (if (zerop long-flag)
+ (lispm-ldb sym:%%array-index-length-if-short header)
+ (vpointer (1+ (vcontents pointer)))))))
+ (dotimes (c len)
+ (let ((wd (vread (+ pointer 1 long-flag (ash c -2)))))
+ (write-char (code-char (logand #o377 (ash wd (- 0 (* 8 (logand c 3)))))))))))
+
+(defun vatom? (typed-pointer)
+ (let ((data-type (vdata-type typed-pointer)))
+ (cond ((or (= data-type sym:dtp-symbol)
+ (= data-type sym:dtp-fix)
+ (= data-type sym:dtp-extended-number))
+ t))))
+
+(defun vnull? (typed-pointer)
+ (= typed-pointer qnil))
+
+(defun mask-field-from-fixnum (ppss word)
+ (logand word (lispm-dpb -1 ppss 0)))
+
+(defvar sym-package (find-package "COLD-SYMBOLS"))
+(defvar misc-function-list)
+(defvar misc-instruction-list)
+
+;;; These have to be explicitly declared special because they only exist in
+;;; the cold-load generator, and are not sent over.
+(declaim (special sym:cold-load-area-sizes sym:cold-load-region-sizes
+ sym:scratch-pad-pointers sym:scratch-pad-parameters
+ sym:scratch-pad-parameter-offset sym:q-corresponding-variable-lists
+ sym:support-vector-contents sym:constants-page
+ sym:read-only-area-list sym:wired-area-list sym:pdl-buffer-area-list
+ sym:list-structured-areas sym:static-areas
+ sym:a-memory-array-locations sym:new-array-index-order
+ sym:prin1 sym:base sym:ibase sym:*nopoint sym:for-cadr
+ sym:*print-base* sym:*read-base* sym:*print-radix*
+ sym:lambda-list-keywords))
+
+;;; Set up the sym: package by loading the appropriate files
+(defun load-parameters ()
+ (let ((*package* sym-package)
+ (*read-base* 8))
+ (load "qcom.lisp")
+ (load "qdefs.lisp")
+ (setq misc-function-list nil)
+ (setq misc-instruction-list nil)
+ (load "defmic.lisp")
+ (dolist (l sym:system-constant-lists) ;Make declarations so can compile self
+ (dolist (s (symbol-value l))
+ (setf (get s 'special) t)))
+ (setq big-fixnum (1- (ash 1 (1- sym:%%q-pointer)))
+ little-fixnum (1- (- big-fixnum))
+ q-typed-pointer-mask (1- (ash 1 sym:%%q-typed-pointer))
+ q-pointer-mask (1- (ash 1 sym:%%q-pointer)))
+ (setq sym:lambda-list-keywords
+ '(sym:&optional sym:&rest sym:&aux sym:&special sym:&local
+ sym:&functional sym:&eval sym:"e
+ sym:"e-dontcare sym:&dt-dontcare sym:&dt-number
+ sym:&dt-fixnum sym:&dt-symbol sym:&dt-atom sym:&dt-list
+ sym:&dt-frame sym:&function-cell sym:&list-of
+ sym:&body sym:&key sym:&allow-other-keys))))
+
+
+;Put on QLVAL and QINTCMP properties
+;Creates MISC-FUNCTION-LIST for STORE-MISC-LINK (CALLED FROM STORE-MISC-U-ENTRY-LINKS)
+; and MISC-INSTRUCTION-LIST for STORE-MICRO-CODE-SYMBOL-NAMES
+(defmacro defmic (name opcode arglist lisp-function-p &optional no-qintcmp)
+ (let ((function-name (if (atom name) name (car name)))
+ (instruction-name (if (atom name) name (cdr name))))
+ `(progn
+ (cond ((not ,no-qintcmp)
+ (loop for x in ',arglist
+ when (memq x sym:lambda-list-keywords)
+ do (error "~S has ~S in its arglist which is not allowed"
+ ',instruction-name x))
+ (setf (get ',instruction-name 'sym:qintcmp) (length ',arglist))
+ (or (eq ',function-name ',instruction-name)
+ (setf (get ',function-name 'sym:qintcmp) (length ',arglist))))
+ (t ;The number of arguments is needed anyway for the cold-load generator
+ (let ((nargs (length ',arglist))
+ (restarg (memq 'sym:&rest ',arglist)))
+ (loop for x in ',arglist
+ when (memq x sym:lambda-list-keywords)
+ when (not (eq x 'sym:&rest)) ;&rest allowed if no-qintcmp
+ do (error "~S has ~S in its arglist which is not allowed"
+ ',instruction-name x))
+ ;; Note that if it says &rest, for a microcode function we don't really
+ ;; want to get a list of args, we want to see the args on the stack, so
+ ;; we translate this into the maximum possible number of optional arguments.
+ ;; EVAL doesn't check the rest-arg bits for microcode entries anyway.
+ (cond (restarg
+ (or (not ,lisp-function-p)
+ (= (length restarg) 2)
+ (error "~S has garbage ~S in its arglist" ',instruction-name restarg))
+ (setq nargs (cons (- nargs 2) #o77)))) ;(min . max)
+ (setf (get ',instruction-name 'defmic-nargs-info) nargs)
+ (or (eq ',function-name ',instruction-name)
+ (setf (get ',function-name 'defmic-nargs-info) nargs)))))
+ (setf (get ',instruction-name 'sym:qlval) ,opcode)
+ (push ',instruction-name misc-instruction-list)
+ (and ,lisp-function-p
+ (push ',name misc-function-list)))))
+
+;;;; Basic area-processing and data-storing stuff
+
+;;; Note that area names are always symbols in the sym: package
+
+(defvar symbol-creation-trace-list nil)
+(defvar qnil)
+(defvar qtruth)
+(defvar area-origins (make-array #o400))
+(defvar area-alloc-pointers (make-array #o400))
+(defvar area-alloc-bounds (make-array #o400))
+
+(defvar area-corresponding-arrays
+ '(sym:area-name sym:region-origin sym:region-length
+ sym:region-free-pointer
+ sym:region-gc-pointer sym:region-bits sym:area-region-list ; area-region-bits
+ sym:area-region-size sym:area-maximum-size sym:region-list-thread))
+
+(defvar micro-code-entry-corresponding-arrays
+ '(sym:micro-code-entry-area
+ sym:micro-code-entry-name-area
+ sym:micro-code-entry-args-info-area
+ sym:micro-code-entry-arglist-area
+ sym:micro-code-entry-max-pdl-usage))
+
+(defvar areas-with-fill-pointers
+ (append '(sym:micro-code-symbol-area
+ sym:micro-code-symbol-name-area
+ sym:support-entry-vector
+ sym:constants-area)
+ area-corresponding-arrays micro-code-entry-corresponding-arrays))
+
+;;; areas in this list get art-q-list
+(defvar list-referenced-areas areas-with-fill-pointers)
+
+;;; areas in this list get art-q, all other areas get art-32b
+(defvar array-referenced-areas '(sym:system-communication-area sym:page-table-area))
+
+(defun create-areas (&aux high-loc the-region-bits)
+ (do ((l sym:cold-load-area-sizes (cddr l))) ;Area sizes in pages
+ ((null l) t)
+ (setf (get (car l) 'area-size) (cadr l)))
+ ;(fillarray area-origins '(nil))
+ (dotimes (x (array-dimension area-origins 0))
+ (setf (aref area-origins x) nil))
+ ;; Set up the area origin and allocation tables
+ (loop with quantum = sym:page-size
+ for area in sym:area-list
+ for area-number from 0 by 1
+ for loc = 0 then (+ loc size)
+ as size = (* (ceiling (* (get-area-size area) sym:page-size) quantum)
+ quantum)
+ when (eq area 'sym:init-list-area) ;Last fixed area
+ do (setq quantum sym:%address-space-quantum-size)
+ (let ((foo (rem (+ loc size) quantum))) ;Start next area on quantum boundary
+ (or (zerop foo) (setq size (+ (- size foo) quantum))))
+ do (setf (aref area-origins area-number) loc)
+ finally (setq high-loc loc))
+ ;(copy-array-contents area-origins area-alloc-pointers)
+ (dotimes (x (array-dimension area-origins 0))
+ (setf (aref area-alloc-pointers x) (aref area-origins x)))
+ ;(copy-array-portion area-origins 1 #o400 area-alloc-bounds 0 #o400)
+ (dotimes (x (1- (array-dimension area-origins 0)))
+ (setf (aref area-alloc-bounds x) (aref area-origins (1+ x))))
+ (setf (aref area-alloc-bounds (1- (length sym:area-list))) high-loc)
+ (setq vmem-highest-address high-loc)
+ (vmem-initialize)
+ ;; Fill various areas with default stuff
+ (init-area-contents 'sym:area-region-size (vfix #o40000))
+ (init-area-contents 'sym:area-maximum-size (vfix big-fixnum))
+ (init-area-contents 'sym:region-origin (vfix 0)) ;so good type in free region#'s
+ (init-area-contents 'sym:region-length (vfix 0)) ;..
+ (init-area-contents 'sym:region-free-pointer (vfix 0))
+ (init-area-contents 'sym:region-gc-pointer (vfix 0))
+ (init-area-contents 'sym:region-bits (vfix 0)) ;Suitable for free region
+ ; (init-area-contents 'sym:area-region-bits (vfix 0))
+ ;; Crank up region size for certain big areas
+ (do ((l sym:cold-load-region-sizes (cddr l)))
+ ((null l) nil)
+ (vwrite (+ (get-area-origin 'sym:area-region-size) (get-area-number (car l)))
+ (vfix (cadr l))))
+ ;; Set up contents of certain initial areas
+ (do ((i 0 (1+ i))
+ (al sym:area-list (cdr al))
+ (fixed-p t))
+ ((null al) nil)
+ (and (eq (car al) 'sym:working-storage-area) (setq fixed-p nil))
+ (vwrite (+ (get-area-origin 'sym:area-region-list) i) (vfix i))
+ (vwrite (+ (get-area-origin 'sym:region-list-thread) i) (vfix (+ i little-fixnum)))
+ (vwrite (+ (get-area-origin 'sym:region-bits) i)
+ (setq the-region-bits
+ (vfix (+ (lispm-dpb (cond ((memq (car al) sym:read-only-area-list) #o1200) ;ro
+ ((memq (car al) sym:wired-area-list) #o1400) ;rw
+ ((memq (car al) sym:pdl-buffer-area-list)
+ #o500) ;may be in pdl-buffer, no access.
+ (t #o1300)) ;rwf
+ sym:%%region-map-bits
+ 0)
+ (lispm-dpb 1 sym:%%region-oldspace-meta-bit 0)
+ (lispm-dpb (if (eq (car al) 'sym:extra-pdl-area) 0 1)
+ sym:%%region-extra-pdl-meta-bit 0)
+ (lispm-dpb (if (memq (car al) sym:list-structured-areas) 0 1)
+ sym:%%region-representation-type 0)
+ (lispm-dpb (cond ((eq (car al) 'sym:extra-pdl-area)
+ sym:%region-space-extra-pdl)
+ (fixed-p sym:%region-space-fixed)
+ ((memq (car al) sym:static-areas) sym:%region-space-static)
+ (t sym:%region-space-new))
+ sym:%%region-space-type 0)
+ ;; Set up the scavenge enable. Note! The extra-pdl does not follow the
+ ;; prescribed protocol for header/body forward, and gets randomly reset.
+ ;; Fortunately it never points at anything.
+ (lispm-dpb (cond ((eq (car al) 'sym:extra-pdl-area) 0)
+ (fixed-p ;These usually should be scavenged, except
+ ;for efficiency certain ones
+ ;that only contain fixnums will be bypassed
+ (if (memq (car al)
+ '(sym:micro-code-symbol-area sym:page-table-area
+ sym:physical-page-data sym:region-origin
+ sym:region-length sym:region-bits sym:region-free-pointer
+ sym:address-space-map
+ sym:region-gc-pointer sym:region-list-thread
+ sym:area-region-list
+ ; sym:area-region-bits
+ sym:area-region-size sym:area-maximum-size
+ sym:micro-code-entry-area
+ sym:micro-code-entry-max-pdl-usage))
+ 0 1))
+ ((memq (car al) sym:static-areas) 1) ;Static needs scav
+ (t 0)) ;Newspace doesn't need scavenging
+ sym:%%region-scavenge-enable 0)
+ ))))
+; (vwrite (+ (get-area-origin 'sym:area-region-bits) i)
+; the-region-bits)
+ (vwrite (+ (get-area-origin 'sym:region-origin) i)
+ (vfix (aref area-origins i)))
+ (vwrite (+ (get-area-origin 'sym:region-length) i)
+ (vfix (- (aref area-alloc-bounds i) (aref area-origins i))))))
+
+(defun get-area-number (area)
+ (cond ((numberp area) area)
+ ((position area sym:area-list)) ;No symeval, the might have changed.
+ ((error "~S bad area-name" area))))
+
+(defun get-area-origin (area)
+ (aref area-origins (get-area-number area)))
+
+(defun get-area-bound (area)
+ (aref area-alloc-bounds (get-area-number area)))
+
+(defun get-area-free-pointer (area)
+ (aref area-alloc-pointers (get-area-number area)))
+
+(defun allocate-block (area size &aux address high)
+ (setq area (get-area-number area))
+ (setq address (aref area-alloc-pointers area))
+ (setq high (+ address size))
+ (and (> high (aref area-alloc-bounds area))
+ (error "~A area overflow" (nth area sym:area-list)))
+ (setf (aref area-alloc-pointers area) high)
+ ;Page in all the fresh pages without really paging them in, thus initializing them
+ (do ((vpn (ceiling address sym:page-size) (1+ vpn))
+ (hpn (ceiling high sym:page-size)))
+ ((>= vpn hpn))
+ (vmem-find-page (* vpn sym:page-size) t))
+ address)
+
+;;; In pages
+(defun get-area-size (area)
+ ;(check-arg area (memq area sym:area-list) "an area-name")
+ (cond ((get area 'area-size))
+ (t 1)))
+
+;;; Doesn't advance allocation pointer, i.e. sets it back to origin when done
+(defun init-area-contents (area contents)
+ (let ((count (* sym:page-size (get-area-size area))))
+ (setq area (get-area-number area))
+ (do ((adr (allocate-block area count) (1+ adr))
+ (n count (1- n)))
+ ((zerop n)
+ (store-nxtnil-cdr-code area)
+ (setf (aref area-alloc-pointers area) (aref area-origins area)))
+ (vwrite-cdr adr sym:cdr-next contents))))
+
+(defvar store-halfwords-address)
+(defvar store-halfwords-count)
+(defvar store-halfwords-buffer)
+
+(defun begin-store-halfwords (name-of-area n-words)
+ (let* ((area-number (get-area-number name-of-area))
+ (address (allocate-block area-number n-words)))
+ (setq store-halfwords-address address
+ store-halfwords-count (* 2 n-words))
+ address))
+
+(defun store-halfword (hwd)
+ (cond ((oddp (setq store-halfwords-count (1- store-halfwords-count)))
+ (setq store-halfwords-buffer hwd))
+ (t
+ (vwrite store-halfwords-address (lispm-dpb hwd #o2020 store-halfwords-buffer))
+ (setq store-halfwords-address (1+ store-halfwords-address)))))
+
+(defun end-store-halfwords ()
+ (or (zerop store-halfwords-count)
+ (error "store-halfword called wrong number of times")))
+
+;;; Given an object in our world, construct a matching one in the cold load world
+;;; and return a cold-load pointer to it.
+(defun make-q-list (area s-exp &aux bsize value)
+ (cond ((numberp s-exp)
+ (cond ;((small-floatp s-exp) (make-small-flonum s-exp))
+ ((floatp s-exp) (store-flonum 'sym:working-storage-area s-exp))
+ ((and (<= s-exp big-fixnum) (>= s-exp little-fixnum)) (vfix s-exp))
+ (t (store-bignum 'sym:working-storage-area s-exp))))
+; ((characterp s-exp)
+; (vmake-pointer sym:dtp-character (char-int s-exp)))
+ ((symbolp s-exp) (qintern s-exp))
+ ((stringp s-exp) (store-string 'sym:p-n-string s-exp))
+ ((atom s-exp) (error "~S unknown type" s-exp))
+ (t (or (memq area sym:list-structured-areas)
+ (error "make-q-list in non-list-structured area ~S" area))
+ (setq bsize (lispm-length s-exp))
+ ; This will break if it isn't a pure dotted list
+ (cond ((cdr (last s-exp))
+ (setq bsize (1+ bsize))) ;ends in dotted pair
+ (t (setq bsize (length s-exp))))
+ (setq value (vmake-pointer sym:dtp-list (allocate-block area bsize)))
+ (do ((s-exp s-exp (cdr s-exp))
+ (adr (logand q-pointer-mask value) (1+ adr))
+ (c-code))
+ ((atom s-exp)
+ (or (null s-exp)
+ (vwrite-cdr adr sym:cdr-error (make-q-list area s-exp))))
+ (setq c-code (cond ((null (cdr s-exp)) sym:cdr-nil)
+ ((atom (cdr s-exp)) sym:cdr-normal)
+ (t sym:cdr-next)))
+ (vwrite-cdr adr c-code (make-q-list area (car s-exp))))
+ value)))
+
+(defun make-small-flonum (s-exp) ;I hope the format doesn't change!
+ (let ((as-fixnum (%pointer s-exp)))
+;; The following line should be removed once we are running in system 99 or above.
+ ;(setq as-fixnum (%pointer-plus as-fixnum #o40000000))
+ (vmake-pointer sym:dtp-small-flonum as-fixnum)))
+
+(defun magic-aref (a i n)
+ (if (< i n) (char-code (aref a i)) #o200))
+
+(defun store-string (area string)
+ (and (memq area sym:list-structured-areas)
+ (error "store-string in list-structured area"))
+ (let* ((n-chars (length string))
+ (n-words (+ 1 (ceiling n-chars 4)))
+ long-flag
+ adr)
+ (and (> n-chars sym:%array-max-short-index-length)
+ (setq long-flag t
+ n-words (1+ n-words)))
+ (setq adr (allocate-block area n-words))
+ (vwrite adr (vmake-pointer sym:dtp-array-header
+ (+ sym:array-dim-mult ;1-dim
+ sym:art-string
+ (if long-flag
+ (lispm-dpb 1 sym:%%array-long-length-flag 0)
+ n-chars))))
+ (when long-flag
+ (vwrite (1+ adr) n-chars))
+ (do ((i (if long-flag 2 1) (1+ i))
+ (j 0 (+ j 4)))
+ ((= i n-words))
+ (vwrite (+ adr i)
+ (+ (magic-aref string j n-chars)
+ (ash (magic-aref string (1+ j) n-chars) 8)
+ (ash (magic-aref string (+ j 2) n-chars) 16)
+ (ash (magic-aref string (+ j 3) n-chars) 24))))
+ (vmake-pointer sym:dtp-array-pointer adr)))
+
+(defun store-symbol-vector (atom-name area)
+ (and (memq area sym:list-structured-areas)
+ (error "store-symbol-vector in list-structured area ~S" area))
+ (and (eq atom-name '**screw**)
+ (error "you've probably encountered a bug in COLDLD" atom-name))
+ (prog (adr sym path real-atom-name package-name pname)
+ (cond ((setq path (get atom-name 'package-path))
+ (or (= (length path) 2)
+ (error "package path ~S not 2 long - code not hairy enough"))
+ (setq package-name (qintern (car path))
+ real-atom-name (car (last path))))
+ (t (setq package-name qnil real-atom-name atom-name)))
+ (when symbol-creation-trace-list ;debugging tool to track down appears twice in
+ (do ((l symbol-creation-trace-list (cdr l))) ;cold load messages.
+ ((null l))
+ (cond ((inhibit-style-warnings
+ (samepnamep real-atom-name (car l)))
+ (format t "
+A-flavor-of ~S being-created, atom-name ~S, path ~S, package-name ~S"
+ real-atom-name atom-name path package-name)))))
+ (setq pname (store-string 'sym:p-n-string (string real-atom-name)))
+ (setq adr (allocate-block area sym:length-of-atom-head))
+ (vwrite-cdr adr sym:cdr-next (vmake-pointer sym:dtp-symbol-header pname))
+ (vwrite-cdr (+ adr 1) sym:cdr-next (vmake-pointer sym:dtp-null adr))
+ (vwrite-cdr (+ adr 2) sym:cdr-next (vmake-pointer sym:dtp-null adr))
+ (vwrite-cdr (+ adr 3) sym:cdr-next qnil)
+ (vwrite-cdr (+ adr 4) sym:cdr-nil package-name)
+ (setq sym (vmake-pointer sym:dtp-symbol adr))
+ (setf (get atom-name 'q-atom-head) sym)
+ (return sym)))
+
+;;; Need to explicitly create a Lispm format bignum when running in
+;;; Common Lisp
+
+(defun store-bignum (area number)
+ (and (memq area sym:list-structured-areas)
+ (error "extended-number in list-structured area ~S" area))
+ (let* ((size 3) ; XXX was (%structure-total-size number)
+ (adr (allocate-block area size)))
+ (vwrite-cdr adr sym:cdr-nil
+ (lispm-dpb sym:dtp-header sym:%%q-all-but-pointer
+ (lispm-dpb sym:%header-type-bignum
+ sym:%%header-type-field (1- size))))
+ (vwrite (+ adr 1) (ldb (byte 31 0) number))
+ (vwrite (+ adr 2) (ldb (byte 31 0) (ash number -31)))
+ (vmake-pointer sym:dtp-extended-number adr)))
+
+(defun store-flonum (area number)
+ (and (memq area sym:list-structured-areas)
+ (error "extended-number in list-structured area ~S" area))
+ (format t "store-flonum: ~S ~S~%" (type-of number) number)
+ (let* ((size 2) ; XXX (%structure-total-size number)
+ (adr (allocate-block area size)))
+ (loop for i from 0 below size
+ do (vwrite (+ adr i) number))
+ (vmake-pointer sym:dtp-extended-number adr)))
+
+;;; New version of qintern. Machine builds obarray when it first comes up (easy enough).
+(defun qintern (atom-name)
+ (or (eq (symbol-package atom-name) sym-package)
+ (setq atom-name (intern (string atom-name) sym-package)))
+ (or (get atom-name 'q-atom-head)
+ (store-symbol-vector atom-name 'sym:nr-sym)))
+
+(defun q-atom-head-reset (&optional (pkg sym-package))
+ (do-symbols (x pkg) (remprop x 'q-atom-head)))
+
+(defun print-q-symbols (&optional (pkg sym-package))
+ (do-symbols (x pkg)
+ (let ((q-atom (get x 'q-atom-head)))
+ (if q-atom
+ (format t "~%Symbol ~s, q-atom-head ~s" x q-atom)))))
+
+(defun store-nxtnil-cdr-code (area)
+ (vstore-cdr-code (1- (aref area-alloc-pointers (get-area-number area))) sym:cdr-nil))
+
+(defun store-list-of-atoms (area loa)
+ (let ((adr (allocate-block area (length loa))))
+ (do ((loa loa (cdr loa))
+ (adr adr (1+ adr)))
+ ((null loa))
+ (vwrite-cdr adr (if (null (cdr loa)) sym:cdr-nil sym:cdr-next)
+ (q-convert-atom (car loa))))
+ adr))
+
+(defun q-convert-atom (atm)
+ (if (numberp atm) (make-q-list nil atm) (qintern atm)))
+
+(defun store-list (area lst)
+ (let ((adr (allocate-block area (length lst))))
+ (do ((lst lst (cdr lst))
+ (adr adr (1+ adr)))
+ ((null lst))
+ (vwrite-cdr adr (if (null (cdr lst)) sym:cdr-nil sym:cdr-next)
+ (make-q-list 'sym:init-list-area (car lst))))
+ adr))
+
+(defun store-nils (area number)
+ (let ((adr (allocate-block area number)))
+ (do ((number number (1- number))
+ (adr adr (1+ adr)))
+ ((zerop number))
+ (vwrite-cdr adr (if (= number 1) sym:cdr-nil sym:cdr-next) qnil))
+ adr))
+
+(defun storeq (area data)
+ (let ((adr (allocate-block area 1)))
+ (vwrite adr data)
+ adr))
+
+(defun store-cdr-q (area cdr-code data)
+ (let ((adr (allocate-block area 1)))
+ (vwrite-cdr adr cdr-code data)
+ adr))
+
+;;;; Hair for making arrays
+
+(defun init-q-array (area name offset type dimlist displaced-p leader)
+ (init-q-array-named-str area name offset type dimlist displaced-p leader nil))
+
+;NOTE!! LEADER IS STOREQ ED DIRECTLY SO IT MUST ALREADY BE MAKE-Q-LIST IFIED
+(defun init-q-array-named-str (area name offset type dimlist displaced-p leader named-str)
+ ; leader is contents of array leader, if desired. it is in "storage order"
+ ;which is reversed from index order.
+ ; if leader is numeric, it means make leader consisting of that many q's
+ ;initialized to nil.
+ ; if name -> nil, return (list <array-adr> <data-length>) and dont try
+ ;to store in function or value cell.
+ ;offset 1 for storing pointer to array in value cell, 2 for function cell
+ (and (memq area sym:list-structured-areas)
+ (error "init-q-array in list-structured area"))
+ (prog (tem ndims index-length data-length tem1 leader-length header-q long-array-flag adr)
+ (and (numberp dimlist) (setq dimlist (list dimlist)))
+ (setq ndims (length dimlist))
+ (when sym:new-array-index-order
+ (setq dimlist (reverse dimlist)))
+ ;; The rest of this is correct for column-major order.
+ (setq index-length (list-product dimlist))
+ (cond ((and (> index-length sym:%array-max-short-index-length)
+ (null displaced-p))
+ (setq long-array-flag t)))
+ (setq leader-length (cond ((null leader) 0)
+ ((numberp leader) (+ 2 leader))
+ (t (+ 2 (length leader)))))
+ (cond ((null (setq tem (assoc type sym:array-elements-per-q :test #'eq)))
+ (error "~S bad array type" type)))
+ (setq tem (cdr tem))
+ (cond ((not (null leader))
+ (setq adr (allocate-block area leader-length))
+ (vwrite adr (vmake-pointer sym:dtp-header
+ (lispm-dpb sym:%header-type-array-leader
+ sym:%%header-type-field
+ leader-length)))
+ (cond ((numberp leader)
+ (dotimes (i leader)
+ (vwrite (+ adr i 1) qnil))
+ (and named-str (vwrite (+ adr leader -1) ;(array-leader x 1)
+ (qintern named-str))))
+ (t (do ((l leader (cdr l))
+ (i 1 (1+ i)))
+ ((null l))
+ (vwrite (+ adr i) (car l)))))
+ (vwrite (+ adr leader-length -1) (vfix (- leader-length 2)))))
+ (setq data-length (ceiling index-length tem))
+ (setq header-q (vmake-pointer sym:dtp-array-header
+ (+ (* sym:array-dim-mult ndims)
+ (symbol-value type))))
+ (and leader (setq header-q (+ header-q sym:array-leader-bit)))
+ (and named-str (setq header-q (+ header-q sym:array-named-structure-flag)))
+ (cond (displaced-p ;note, no index-offset arrays in cold-load
+ (setq tem 1 header-q (+ header-q sym:array-displaced-bit 2)))
+ ((null long-array-flag)
+ (setq tem 1 header-q (+ header-q index-length)))
+ (t (setq tem 2 header-q (+ header-q sym:array-long-length-flag))))
+ (setq tem1 (setq adr (allocate-block area (+ tem ndims -1))))
+ (vwrite adr header-q)
+ (and (= tem 2) (vwrite (setq adr (1+ adr)) (vfix index-length)))
+ ;Store all dimensions except for last
+ (do ((l dimlist (cdr l)))
+ ((null (cdr l)) nil)
+ (vwrite (setq adr (1+ adr)) (vfix (car dimlist))))
+ (cond ((null name) (return (list tem1 data-length))))
+ (vstore-contents (+ (qintern name) offset)
+ (vmake-pointer sym:dtp-array-pointer tem1))
+ (return data-length)))
+
+(defun store-q-array-leader (arrayp idx data)
+ (vwrite (- arrayp (+ 2 idx)) ;1 for array header, 1 for ldr len
+ data))
+
+;;;; Setting up various magic data structures,
+;;;; mostly having to do with the microcode and the fixed-areas
+
+(defun store-support-vector (item)
+ (let ((adr (allocate-block 'sym:support-entry-vector 1)))
+ (vwrite-cdr adr sym:cdr-next
+ (cond ((eq (car item) 'sym:function)
+ (get-q-fctn-cell (cadr item)))
+ ((memq (car item) '(quote sym:quote))
+ (make-q-list 'sym:init-list-area (cadr item)))
+ (t (error "bad-support-code: ~S" item))))
+ adr))
+
+(defun get-q-fctn-cell (fctn &aux tem)
+ (and (setq tem (get fctn 'q-atom-head))
+ (vcontents (+ tem 2))))
+
+(defun store-displaced-array-pointer (area)
+ (prog (fillp area-array-type data-length adr)
+ (setq fillp (memq area areas-with-fill-pointers))
+ (setq area-array-type
+ (cond ((eq area 'sym:address-space-map) 'sym:art-8b) ;%address-space-map-byte-size
+ ((memq area list-referenced-areas) 'sym:art-q-list)
+ ((memq area array-referenced-areas) 'sym:art-q)
+ (t 'sym:art-32b)))
+ (init-q-array 'sym:control-tables
+ area
+ 2
+ area-array-type
+ (setq data-length ;In entries, not Qs!
+ (if (eq area 'sym:address-space-map)
+ (/ (1+ q-pointer-mask) sym:%address-space-quantum-size)
+ (* sym:page-size (get-area-size area))))
+ t
+ (and fillp
+ (list (vfix (cond ((memq area area-corresponding-arrays)
+ (length sym:area-list))
+ ((memq area
+ micro-code-entry-corresponding-arrays)
+ (length micro-code-entry-vector))
+ ((eq area 'sym:address-space-map)
+ (/ (1+ q-pointer-mask)
+ sym:%address-space-quantum-size))
+ (t
+ (* sym:page-size (get-area-size area))))))))
+ (setq adr (allocate-block 'sym:control-tables 2))
+ (vwrite adr (vfix (get-area-origin area)))
+ (vwrite (1+ adr) (vfix data-length))))
+
+;;; x is a symbol or cons function-name instruction-name
+(defun store-misc-link (x)
+ (cond ((atom x)
+ (misc-store-micro-entry x x))
+ ((misc-store-micro-entry (car x) (cdr x)))))
+
+;;; special kludge which filters out *catch
+(defun store-misc-link-1 (x)
+ (or (eq x 'sym:*catch)
+ (store-misc-link x)))
+
+;;; This creates an indirect through the MICRO-CODE-SYMBOL-AREA by using
+;;; DTP-FIX and #o200 less than the misc function index. This makes
+;;; the core image independent of the microcode version.
+(defun misc-store-micro-entry (name me-name)
+ (prog (misc-index u-entry-prop u-entry-index)
+ (cond ((null (setq misc-index (get me-name 'sym:qlval)))
+ (error "No QLVAL property: ~S" me-name)))
+ (setq u-entry-prop (vfix (- misc-index #o200)))
+ (setq u-entry-index (get-u-entry-index name))
+ (vstore-contents (+ (qintern name) 2) ;function cell
+ (vmake-pointer sym:dtp-u-entry u-entry-index))
+ (vstore-contents (+ (get-area-origin 'sym:micro-code-entry-area) u-entry-index)
+ u-entry-prop)
+ (vstore-contents (+ (get-area-origin 'sym:micro-code-entry-args-info-area)
+ u-entry-index)
+ (make-q-list 'sym:init-list-area (get-q-args-prop name)))))
+
+;;; This abbreviated version of the stuff in UTIL2 should be enough to get us off the ground
+(defun get-q-args-prop (fctn &aux tem)
+ (cond ((setq tem (get fctn 'sym:argdesc))
+ (get-q-args-prop-from-argdesc-prop tem))
+ ((setq tem (get fctn 'sym:qintcmp))
+ (+ (ash tem 6) tem))
+ ;; You may think this is a kludge, but in the Maclisp cold-load generator
+ ;; it gets the number of arguments out of the Maclisp subr of the same name!
+ ((setq tem (get fctn 'defmic-nargs-info))
+ (if (listp tem) (+ (ash (car tem) 6) (cdr tem))
+ (+ (ash tem 6) tem)))
+ (t (error "Cannot find arg desc for ~S" fctn))))
+
+(defun get-q-args-prop-from-argdesc-prop (arg-desc)
+ (prog (prop min-args max-args count item)
+ (setq prop 0 min-args 0 max-args 0)
+ l (cond ((null arg-desc) (return (+ prop (ash min-args 6) max-args))))
+ (setq count (caar arg-desc))
+ (setq item (cadar arg-desc)) ;list of arg syntax, quote type, other attributes
+ (setq arg-desc (cdr arg-desc))
+ l1 (cond ((= 0 count) (go l))
+ ((memq 'sym:fef-arg-rest item)
+ (setq prop (logior prop (if (or (memq 'sym:fef-qt-eval item)
+ (memq 'sym:fef-qt-dontcare item))
+ sym:%arg-desc-evaled-rest
+ sym:%arg-desc-quoted-rest)))
+ (go l))
+ ((memq 'sym:fef-arg-req item)
+ (setq min-args (1+ min-args)))
+ ((memq 'sym:fef-arg-opt item))
+ (t (go l)))
+ (setq max-args (1+ max-args))
+ (or (memq 'sym:fef-qt-eval item)
+ (memq 'sym:fef-qt-dontcare item)
+ (setq prop (logior prop sym:%arg-desc-fef-quote-hair)))
+ (setq count (1- count))
+ (go l1)))
+
+(defvar micro-code-entry-vector nil)
+
+(defun get-u-entry-index (fctn)
+ (prog (tem)
+ (cond ((setq tem (position fctn micro-code-entry-vector))
+ (return tem)))
+ (setq tem (length micro-code-entry-vector))
+ (store-cdr-q 'sym:micro-code-entry-area sym:cdr-next qnil) ;will be changed
+ (store-cdr-q 'sym:micro-code-entry-name-area sym:cdr-next (qintern fctn))
+ (store-cdr-q 'sym:micro-code-entry-args-info-area sym:cdr-next qnil) ;will be chngd
+ (store-cdr-q 'sym:micro-code-entry-arglist-area sym:cdr-next qnil) ;set on startup
+ (setq micro-code-entry-vector (nconc micro-code-entry-vector
+ (list fctn)))
+ (return tem)))
+
+(defun store-micro-code-symbol-name (name)
+ (let ((opcode (get name 'sym:qlval)))
+ (or opcode (error "no qlval property in store-micro-code-symbol-name: ~S" name))
+ (vstore-contents (+ (get-area-origin 'sym:micro-code-symbol-name-area) (- opcode 200))
+ (qintern name))))
+
+(defun store-lisp-value-list (x)
+ (mapc #'store-lisp-value (symbol-value x)))
+
+(defun store-lisp-value (sym)
+ (storein-q-value-cell sym (make-q-list 'sym:init-list-area (symbol-value sym))))
+
+;;; Store cdr-coded list of #o1000 (or however many) NIL's.
+(defun init-micro-code-symbol-name-area ()
+ (store-nils 'sym:micro-code-symbol-name-area
+ (* sym:page-size
+ (get 'sym:micro-code-symbol-name-area 'area-size))))
+
+(defun cold-load-time-setq (pair-list &aux var value)
+ (do ((pair-list pair-list (cddr pair-list))) ((null pair-list))
+ (setq var (car pair-list) value (cadr pair-list))
+ (cond ((and (atom value) (or (numberp value)
+ (stringp value)
+ (memq value '(sym:t sym:nil)))))
+ ((eq (car value) 'sym:quote)
+ (setq value (cadr value)))
+ (t (error "(setq ~S ~S) no can do" var value)))
+ (storein-q-value-cell var (make-q-list 'sym:init-list-area value))))
+
+(defun storein-q-value-cell (sym data)
+ (vstore-contents (1+ (qintern sym)) data))
+
+(defun store-constant (c)
+ (vwrite-cdr (allocate-block 'sym:constants-area 1)
+ sym:cdr-next
+ (make-q-list 'sym:init-list-area c)))
+
+(defun init-scratch-pad-area ()
+ (init-area-contents 'sym:scratch-pad-init-area (vfix 0))
+ (setf (aref area-alloc-pointers (get-area-number 'sym:scratch-pad-init-area))
+ (+ (aref area-origins (get-area-number 'sym:scratch-pad-init-area))
+ sym:scratch-pad-parameter-offset
+ (length sym:scratch-pad-parameters)))
+ (scratch-store-q 'sym:initial-top-level-function
+ (vmake-pointer sym:dtp-locative
+ (+ (qintern 'sym:lisp-top-level) 2)))
+ ;trap-handler (not used)
+ (let ((initial-stack-group-pointer (make-initial-stack-group-structure)))
+ (scratch-store-q 'sym:current-stack-group initial-stack-group-pointer)
+ (scratch-store-q 'sym:initial-stack-group initial-stack-group-pointer))
+ (scratch-store-q 'sym:error-handler-stack-group qnil) ;initialized at run time
+ (scratch-store-q 'sym:default-cons-area (vfix (get-area-number 'sym:working-storage-area))))
+
+(defun scratch-store-q (symbolic-name data)
+ (prog (tem origin)
+ (setq origin (get-area-origin 'sym:scratch-pad-init-area))
+ (cond ((setq tem (position symbolic-name sym:scratch-pad-pointers))
+ (vstore-contents (+ origin tem) data))
+ ((setq tem (position symbolic-name sym:scratch-pad-parameters))
+ (vstore-contents (+ origin sym:scratch-pad-parameter-offset tem) data))
+ (t (error "unknown-scratch-quantity: ~S" symbolic-name)))))
+
+(defun store-a-mem-location-names ()
+ (do ((name sym:a-memory-location-names (cdr name))
+ (locn (+ #o40 sym:a-memory-virtual-address) (1+ locn)))
+ ((null name) t)
+ (store-mem-location (car name) locn))
+ (do ((name sym:m-memory-location-names (cdr name)))
+ ((null name) t)
+ (store-mem-location (car name) (get (car name) 'sym:forwarding-virtual-address)))
+ (store-mem-location 'sym:%gc-generation-number
+ (+ #o400 sym:%sys-com-gc-generation-number))
+ )
+
+(defun store-mem-location (name locn)
+ (storein-q-value-cell name (vmake-pointer sym:dtp-one-q-forward locn)))
+
+(defun make-ordered-array-list (assoc-list)
+ (mapcar #'(lambda (x) (cdr (assoc x assoc-list :test #'eq)))
+ sym:array-types))
+
+;;;The order store-misc-link is called determines the final micro-code-entry
+;;; numbers that are assigned. however, except for 0 which must be *catch,
+;;; micro-code-entry numbers are unconstrained and independant from everything
+;;; else. So the other entries below may be in any order.
+(defun store-misc-u-entry-links ()
+ (store-misc-link 'sym:*catch) ;must be first
+ (mapc #'store-misc-link-1 misc-function-list)
+ ;; now set up the first #o600 locations of micro-code-symbol-name-area
+ (init-micro-code-symbol-name-area)
+ (mapc #'store-micro-code-symbol-name misc-instruction-list))
+
+(defun make-initial-stack-group-structure ()
+ (make-stack-group-structure 'sym:main-stack-group 'sym:control-tables
+ 'sym:linear-pdl-area 'sym:linear-bind-pdl-area
+ sym:sg-state-active))
+
+(defun make-stack-group-structure (name sg-area linear-area l-b-p-area initial-state)
+ (prog (sg pdl-array l-b-p-array reg-len spec-len)
+ (setq sg (car (init-q-array sg-area nil nil 'sym:art-stack-group-head '(0)
+ nil (length sym:stack-group-head-leader-qs))))
+ (setq pdl-array
+ (car (init-q-array linear-area nil nil 'sym:art-reg-pdl
+ (list (setq reg-len (- (* sym:page-size
+ (get-area-size 'sym:linear-pdl-area))
+ (+ (length sym:reg-pdl-leader-qs) 4))))
+ ;4: leader header + leader-length-q + array-header-q + long-length-q
+ nil (length sym:reg-pdl-leader-qs))))
+ (allocate-block linear-area reg-len) ;advance free pointer
+ (setq l-b-p-array
+ (car (init-q-array l-b-p-area nil nil 'sym:art-special-pdl
+ (list (setq spec-len (- (* sym:page-size
+ (get-area-size 'sym:linear-bind-pdl-area))
+ (+ (length sym:special-pdl-leader-qs) 4))))
+ nil (length sym:special-pdl-leader-qs))))
+ (allocate-block l-b-p-area spec-len) ;advance free pointer
+ (stack-group-linkup sg pdl-array l-b-p-array)
+ (store-q-array-leader sg sym:sg-state (vfix initial-state))
+ (store-q-array-leader sg sym:sg-name (make-q-list 'sym:init-list-area name))
+ (store-q-array-leader sg sym:sg-regular-pdl-limit
+ (make-q-list 'sym:init-list-area (- reg-len #o100)))
+ (store-q-array-leader sg sym:sg-special-pdl-limit
+ (make-q-list 'sym:init-list-area (- spec-len #o100)))
+ (return (vmake-pointer sym:dtp-stack-group sg))))
+
+(defun stack-group-linkup (sg pdl-arrayp l-b-p-arrayp)
+ (store-q-array-leader l-b-p-arrayp sym:special-pdl-sg-head-pointer
+ (vmake-pointer sym:dtp-stack-group sg))
+ (store-q-array-leader pdl-arrayp sym:reg-pdl-sg-head-pointer
+ (vmake-pointer sym:dtp-stack-group sg))
+ (store-q-array-leader sg sym:sg-special-pdl
+ (vmake-pointer sym:dtp-array-pointer l-b-p-arrayp))
+ (store-q-array-leader sg sym:sg-regular-pdl
+ (vmake-pointer sym:dtp-array-pointer pdl-arrayp))
+ (store-q-array-leader sg sym:sg-initial-function-index (vfix 3)))
+
+;This better agree with the order of the list of qs in QCOM
+(defun init-system-communication-area (&aux (nqs 27.) adr)
+ (setq adr (allocate-block 'sym:system-communication-area nqs))
+ (vwrite (+ adr sym:%sys-com-area-origin-pntr)
+ (vmake-pointer sym:dtp-locative (get-area-origin 'sym:region-origin)))
+ (vwrite (+ adr sym:%sys-com-valid-size) (vfix 0)) ;fixed later
+ (vwrite (+ adr sym:%sys-com-page-table-pntr)
+ (vmake-pointer sym:dtp-locative (get-area-origin 'sym:page-table-area)))
+ (vwrite (+ adr sym:%sys-com-page-table-size) ;Real value put in by microcode
+ (vfix (* (get-area-size 'sym:page-table-area) sym:page-size)))
+ (vwrite (+ adr sym:%sys-com-obarray-pntr) (qintern 'sym:obarray))
+ (vwrite (+ adr sym:%sys-com-ether-free-list) qnil)
+ (vwrite (+ adr sym:%sys-com-ether-transmit-list) qnil)
+ (vwrite (+ adr sym:%sys-com-ether-receive-list) qnil)
+ (vwrite (+ adr sym:%sys-com-band-format) (vfix 0)) ;not compressed format
+ (vwrite (+ adr sym:%sys-com-gc-generation-number) (vfix 0))
+ (vwrite (+ adr sym:%sys-com-unibus-interrupt-list) (vfix 0))
+ (vwrite (+ adr sym:%sys-com-temporary) (vfix 0))
+ (vwrite (+ adr sym:%sys-com-free-area#-list) 0) ;fixed later
+ (vwrite (+ adr sym:%sys-com-free-region#-list) 0) ;fixed later
+ (vwrite (+ adr sym:%sys-com-memory-size) (vfix #o100000)) ;assume 32k, fixed later
+ (vwrite (+ adr sym:%sys-com-wired-size) ;region-gc-pointer is the first pageable area
+ (vfix (get-area-origin 'sym:region-free-pointer)))
+ (vwrite (+ adr sym:%sys-com-chaos-free-list) qnil)
+ (vwrite (+ adr sym:%sys-com-chaos-transmit-list) qnil)
+ (vwrite (+ adr sym:%sys-com-chaos-receive-list) qnil)
+ (vwrite (+ adr sym:%sys-com-debugger-requests) (vfix 0))
+ (vwrite (+ adr sym:%sys-com-debugger-keep-alive) (vfix 0))
+ (vwrite (+ adr sym:%sys-com-debugger-data-1) (vfix 0))
+ (vwrite (+ adr sym:%sys-com-debugger-data-2) (vfix 0))
+ (vwrite (+ adr sym:%sys-com-major-version) qnil) ;I.e. fresh cold-load
+ (vwrite (+ adr sym:%sys-com-desired-microcode-version) qnil) ;Set by system initialization
+ (vwrite (+ adr sym:%sys-com-highest-virtual-address)
+ (vfix 0)) ;used only if compressed band.
+ (vwrite (+ adr sym:%sys-com-pointer-width) (vfix sym:%%q-pointer))
+ (or (= nqs (length sym:system-communication-area-qs))
+ (error "QCOM and COLDUT disagree about system-communication-area")))
+
+(defun q-storage-finalize ()
+ (mapc #'store-support-vector sym:support-vector-contents)
+ (store-nxtnil-cdr-code 'sym:support-entry-vector)
+ (mapc #'store-displaced-array-pointer sym:area-list)
+ (scratch-store-q 'sym:active-micro-code-entries (vfix (length micro-code-entry-vector)))
+ ;; Transfer over free pointers
+ (do ((area-number 0 (1+ area-number))
+ (a-l sym:area-list (cdr a-l))
+ (rfp (get-area-origin 'sym:region-free-pointer)))
+ ((null a-l) t)
+ (vwrite (+ rfp area-number)
+ (vfix (- (aref area-alloc-pointers area-number) (aref area-origins area-number))))
+ )
+
+ (let ((high-loc (aref area-alloc-bounds (1- (length sym:area-list)))))
+ (vwrite (+ (get-area-origin 'sym:system-communication-area) sym:%sys-com-valid-size)
+ (vfix high-loc)))
+ ;; Set up the area# and region# free lists
+ (vwrite (+ (get-area-origin 'sym:system-communication-area) sym:%sys-com-free-area#-list)
+ (vfix (length sym:area-list)))
+ (vwrite (+ (get-area-origin 'sym:system-communication-area) sym:%sys-com-free-region#-list)
+ (vfix (length sym:area-list)))
+ (do ((i (length sym:area-list) (1+ i)))
+ ((= i sym:size-of-area-arrays) nil) ;all but the last
+ (vwrite (+ (get-area-origin 'sym:region-list-thread) i) (vfix (1+ i)))
+ (vwrite (+ (get-area-origin 'sym:area-region-list) i) (vfix (1+ i))))
+ (vwrite (+ (get-area-origin 'sym:region-list-thread) sym:size-of-area-arrays) (vfix 0))
+ (vwrite (+ (get-area-origin 'sym:area-region-list) sym:size-of-area-arrays) (vfix 0))
+ ;; Make certain areas look full
+ (dolist (area '(sym:region-origin sym:region-length sym:region-free-pointer sym:region-gc-pointer
+ sym:region-bits sym:region-list-thread sym:area-name sym:area-region-list
+ ; sym:area-region-bits
+ sym:area-region-size sym:area-maximum-size
+ sym:linear-pdl-area sym:linear-bind-pdl-area))
+ (vwrite (+ (get-area-origin 'sym:region-free-pointer) (get-area-number area))
+ (vfix (* (get-area-size area) sym:page-size))))
+ ;; Initialize unused portions of the disk
+ (initialize-unused-pages)
+ (init-address-space-map)
+ ;; Don't bother setting up the PHT and PPD, the microcode will take care of it
+ ;; Cold-booting into this band will then do the right thing with it
+ (init-area-contents 'sym:page-table-area (vfix 0))
+ ;; Terminate areas which have overlying lists
+ (store-nxtnil-cdr-code 'sym:constants-area)
+ (store-nxtnil-cdr-code 'sym:scratch-pad-init-area)
+ (store-nxtnil-cdr-code 'sym:area-name)
+ (store-nxtnil-cdr-code 'sym:micro-code-entry-area)
+ (store-nxtnil-cdr-code 'sym:micro-code-entry-name-area)
+ (store-nxtnil-cdr-code 'sym:micro-code-entry-args-info-area)
+ (store-nxtnil-cdr-code 'sym:micro-code-entry-arglist-area))
+
+(defun initialize-unused-pages (&aux area address high)
+ (dolist (name-of-area (memq 'sym:extra-pdl-area sym:area-list)) ;no trash low fixed areas
+ (setq area (get-area-number name-of-area)
+ address (aref area-alloc-pointers area)
+ high (aref area-alloc-bounds area))
+ ;Page in all the fresh pages without really paging them in, thus initializing them
+ (do ((vpn (ceiling address sym:page-size) (1+ vpn))
+ (hpn (ceiling high sym:page-size)))
+ ((>= vpn hpn))
+ (vmem-find-page (* vpn sym:page-size) t))))
+
+(defun init-address-space-map ()
+ (or (= sym:%address-space-map-byte-size 8)
+ (error "This code only works for %address-space-map-byte-size = 8"))
+ (let ((map (make-array #o2000 :element-type '(unsigned-byte 8))) ;Initializes to 0
+ (asm (get-area-origin 'sym:address-space-map))
+ (asqs sym:%address-space-quantum-size))
+ ;For each non-fixed area, find all the address space quanta in the area's initial
+ ;region and store them into the map
+ (loop for area from (1+ (get-area-number 'sym:init-list-area))
+ below (length sym:area-list)
+ unless (and (zerop (rem (aref area-origins area) asqs))
+ (zerop (rem (aref area-alloc-bounds area) asqs)))
+ do (error "Area ~A is not an integral number of address space quanta"
+ (nth area sym:area-list))
+ do (loop for q from (/ (aref area-origins area) asqs)
+ below (/ (aref area-alloc-bounds area) asqs)
+ do (setf (aref map q) area)))
+ ;Now dump this into the cold load
+ (loop for i from 0 below #o400 for j from 0 by 4
+ do (vwrite (+ asm i)
+ (lispm-dpb (aref map (+ j 3)) #o3010
+ (lispm-dpb (aref map (+ j 2)) #o2010
+ (lispm-dpb (aref map (+ j 1)) #o1010
+ (aref map j))))))
+ ;cause address-space-map region to appear full so it gets dumped by band dumper.
+ (vwrite (+ (get-area-origin 'sym:region-free-pointer)
+ (get-area-number 'sym:address-space-map))
+ (vfix (* (get-area-size 'sym:address-space-map) sym:page-size)))))
+
+(defun make-sorted-region-list ()
+ (sort (do ((i 0 (1+ i))
+ (al sym:area-list (cdr al))
+ (l nil))
+ ((null al)
+ (nreverse l))
+ (push (cons (aref area-origins i) i) l))
+ #'(lambda (x y)
+ (cond ((= (car x) (car y)) ;if one is zero length, it -must- go first
+ (cond
+ ((= (aref area-origins (cdr x)) (aref area-alloc-bounds (cdr x))) t)
+ ((= (aref area-origins (cdr y)) (aref area-alloc-bounds (cdr y))) nil)
+ (t (error "2 non-zero-length areas at same address"))))
+ ((< (car x) (car y)))))))
+
+;;;; Driver
+
+(defvar cold-list-area 'sym:init-list-area) ;Where FROID (COLDLD) puts lists (usually)
+(defvar evals-to-be-sent-over)
+
+;;; User calls this to build a cold-load into a file
+(defun make-cold (part-name)
+ (if (numberp part-name) (setq part-name (format nil "LOD~d" part-name)))
+ (or (boundp 'big-fixnum) (load-parameters))
+ ;; Flush old state
+ (do-symbols (x sym-package) (remprop x 'q-atom-head))
+ (q-atom-head-reset)
+ ;;(q-atom-head-reset (pkg-find-package "GLOBAL"))
+ (makunbound 'cold-loaded-file-property-lists)
+ (makunbound 'cold-loaded-function-property-lists)
+ (setq evals-to-be-sent-over nil)
+ (unwind-protect (make-cold-1 +cold-load-file-list+)
+ (vmem-finish part-name)))
+
+(defun make-cold-1 (file-list)
+ ;; Divide up virtual memory into areas and initialize tables
+ (assign-values sym:area-list 0)
+ (create-areas)
+ (make-t-and-nil)
+ ;; Initialize various fixed areas and really random data tables
+ (init-area-contents 'sym:area-name qnil)
+ (store-list-of-atoms 'sym:area-name sym:area-list)
+ (mapc #'store-constant sym:constants-page) ;set up constants page
+ (storein-q-value-cell 'sym:constants-page
+ (vmake-pointer sym:dtp-list (get-area-origin 'sym:constants-area)))
+ (init-scratch-pad-area)
+ (init-system-communication-area)
+ (fix-certain-variables)
+ (mapc #'store-lisp-value-list sym:q-corresponding-variable-lists)
+ (init-random-variables)
+ (store-a-mem-location-names)
+ (setq micro-code-entry-vector nil)
+ (store-misc-u-entry-links)
+ ;A copy of AREA-LIST was previously sent over. Change it to share with AREA-NAME.
+ (storein-q-value-cell 'sym:area-list
+ (vmake-pointer sym:dtp-list (get-area-origin 'sym:area-name)))
+ ;;Load up all those QFASL files
+ (mapc #'cold-fasload file-list)
+ ;;Don't let list-structure portion of the readtable end up in a read-only area
+ (let ((cold-list-area 'sym:property-list-area)) ;Random list-structured area
+ (cold-fasload "sys:io;rdtbl.qfasl")
+ ;(cold-fasload "sys:io;crdtbl.qfasl") ; sys99
+ )
+ ;;Translate all pathnames needed before logical pathnames work
+ (dolist (sym mini-file-alist-list)
+ (storein-q-value-cell
+ sym
+ (make-q-list 'sym:init-list-area
+ (loop for (file pack) in (symbol-value sym)
+ as pathname = (merge-pathnames file)
+ collect (list (namestring (translate-logical-pathname pathname))
+ pack
+ (equal (pathname-type pathname) "QFASL")
+ )))))
+#| ;MACRO, SETQ, etc. are in QFCTNS, which is now in the cold load.
+ ;;THIS KLUDGE FIXES UP MACROS, SINCE THE FUNCTION MACRO IS NOT DEFINED YET
+ ;;(BY SPECIAL DISPENSATION WE HAVE DEFPROP, PUTPROP, AND SPECIAL AROUND)
+ ;;FURTHERMORE, SETQ ISN'T DEFINED YET, LOAD-TIME-SETQ FASL-OP SHOULD HAVE BEEN USED
+ (do ((l evals-to-be-sent-over (cdr l))) ((null l))
+ (cond ((memq (caar l) '(sym:setq sym:and sym:or sym:cond))
+ (error "~A will get undefined function during initialization" (car l)))
+ ((eq (caar l) 'sym:macro)
+ (rplaca l (sublis (list (cons 'fcn (cadar l))
+ (cons 'name (caddar l))
+ (cons 'body (cdddar l)))
+ '(sym:fset (sym:quote fcn)
+ (sym:quote (sym:macro
+ . (sym:lambda name . body)))))))))
+|#
+ (setq evals-to-be-sent-over (nreverse evals-to-be-sent-over)) ;do in order specified
+ (storein-q-value-cell 'sym:lisp-crash-list
+ ;; This MAKE-Q-LIST must not use the FASL-TEMP-AREA,
+ ;; because the list structure being created includes
+ ;; definitions of important macros.
+ (make-q-list 'sym:init-list-area evals-to-be-sent-over))
+ ;;Everything compiled, etc. close off and write it out
+ (format t "~&q-storage-finalize...")
+ (q-storage-finalize))
+
+;nil and t must be stored manually since qnil and qtruth would not be bound when needed
+(defun make-t-and-nil ()
+ (setq qnil (vmake-pointer sym:dtp-symbol
+ (allocate-block 'sym:resident-symbol-area sym:length-of-atom-head)))
+ (vwrite-cdr qnil sym:cdr-next (vmake-pointer sym:dtp-symbol-header
+ (store-string 'sym:p-n-string "NIL")))
+ (vwrite-cdr (+ qnil 1) sym:cdr-next qnil)
+ (vwrite-cdr (+ qnil 2) sym:cdr-next (vmake-pointer sym:dtp-null qnil))
+ (vwrite-cdr (+ qnil 3) sym:cdr-next qnil)
+ (vwrite-cdr (+ qnil 4) sym:cdr-next qnil)
+ (setf (get 'sym:nil 'q-atom-head) qnil)
+ ;(setf (symbol-value 'sym:nil) nil)
+ (setq qtruth (vmake-pointer sym:dtp-symbol
+ (allocate-block 'sym:resident-symbol-area sym:length-of-atom-head)))
+ (vwrite-cdr qtruth sym:cdr-next (vmake-pointer sym:dtp-symbol-header
+ (store-string 'sym:p-n-string "T")))
+ (vwrite-cdr (+ qtruth 1) sym:cdr-next qtruth)
+ (vwrite-cdr (+ qtruth 2) sym:cdr-next (vmake-pointer sym:dtp-null qtruth))
+ (vwrite-cdr (+ qtruth 3) sym:cdr-next qnil)
+ (vwrite-cdr (+ qtruth 4) sym:cdr-next qnil)
+ ;(setf (symbol-value 'sym:t) t)
+ (setf (get 'sym:t 'q-atom-head) qtruth))
+
+;Fix the values of certain variables before they are sent over
+(defun fix-certain-variables ()
+ (setq sym:prin1 nil)
+ (setq sym:base (setq sym:ibase 10.))
+ (setq sym:*print-base* (setq sym:*read-base* 10.))
+ (setq sym:*nopoint t)
+ (setq sym:for-cadr t) ;Is this still used?
+ )
+
+;;; Initializations of all sorts of random variables. Must follow the map
+;;; over q-corresponding-variable-lists, because previous initializations are stored over.
+(defun init-random-variables ()
+ ;;set up array-types symbol (both value and function cells).
+ ;; the function cell is an array which gives maps numeric array type to symbolic name.
+ ;; the value cell is a list pointer into the above array, so is an ordered list
+ ;; of the array types.
+ (init-q-array 'sym:control-tables 'sym:array-types 2 'sym:art-q-list '(32.) nil nil)
+ (store-list-of-atoms 'sym:control-tables sym:array-types)
+ (store-nils 'sym:control-tables (- 32. (length sym:array-types)))
+ (storein-q-value-cell 'sym:array-types
+ (vmake-pointer sym:dtp-list (- (aref area-alloc-pointers
+ (get-area-number 'sym:control-tables))
+ 32.)))
+ ;;set up the array-elements-per-q array.
+ (init-q-array 'sym:control-tables 'sym:array-elements-per-q 2 ;fcn
+ 'sym:art-q-list '(32.) nil nil)
+ (store-list-of-atoms 'sym:control-tables (make-ordered-array-list sym:array-elements-per-q))
+ (store-nils 'sym:control-tables (- 32. (length sym:array-types)))
+ ;;value cell of array-elements-per-q has assq list, is not same as array.
+ ;;set up the array-bits-per-element array, similar
+ (init-q-array 'sym:control-tables 'sym:array-bits-per-element 2 ;fcn
+ 'sym:art-q-list '(32.) nil nil)
+ (store-list-of-atoms 'sym:control-tables
+ (make-ordered-array-list sym:array-bits-per-element))
+ (store-nils 'sym:control-tables (- 32. (length sym:array-types)))
+ ;;set up q-data-types
+ (init-q-array 'sym:control-tables 'sym:q-data-types 2 'sym:art-q-list '(32.) nil
+ (list (make-q-list 'sym:init-list-area (length sym:q-data-types))))
+ (store-list-of-atoms 'sym:control-tables sym:q-data-types)
+ (store-nils 'sym:control-tables (- 32. (length sym:q-data-types)))
+ (storein-q-value-cell 'sym:q-data-types
+ (vmake-pointer sym:dtp-list (- (aref area-alloc-pointers
+ (get-area-number 'sym:control-tables))
+ 32.)))
+ ;;Make the arrays which are mapped into A-memory
+ (init-q-array 'sym:control-tables 'sym:mouse-cursor-pattern 1
+ 'sym:art-1b '(32. 32.) t nil)
+ (let ((adr (allocate-block 'sym:control-tables 2)))
+ (vwrite adr (vfix (+ (cadr (memq 'sym:mouse-cursor-pattern sym:a-memory-array-locations))
+ sym:a-memory-virtual-address)))
+ (vwrite (1+ adr) (vfix 1024.)))
+ (init-q-array 'sym:control-tables 'sym:mouse-buttons-buffer 1
+ 'sym:art-q '(32.) t nil)
+ (let ((adr (allocate-block 'sym:control-tables 2)))
+ (vwrite adr (vfix (+ (cadr (memq 'sym:mouse-buttons-buffer sym:a-memory-array-locations))
+ sym:a-memory-virtual-address)))
+ (vwrite (1+ adr) (vfix 32.)))
+ (init-q-array 'sym:control-tables 'sym:mouse-x-scale-array 1
+ 'sym:art-q '(16.) t nil)
+ (let ((adr (allocate-block 'sym:control-tables 2)))
+ (vwrite adr (vfix (+ (cadr (memq 'sym:mouse-x-scale-array sym:a-memory-array-locations))
+ sym:a-memory-virtual-address)))
+ (vwrite (1+ adr) (vfix 16.)))
+ (init-q-array 'sym:control-tables 'sym:mouse-y-scale-array 1
+ 'sym:art-q '(16.) t nil)
+ (let ((adr (allocate-block 'sym:control-tables 2)))
+ (vwrite adr (vfix (+ (cadr (memq 'sym:mouse-y-scale-array sym:a-memory-array-locations))
+ sym:a-memory-virtual-address)))
+ (vwrite (1+ adr) (vfix 16.))))
Added: trunk/tools/cold/defmic.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/defmic.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,598 @@
+;;; -*-MODE:LISP; BASE:8;-*-
+
+; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+;;; This file contains all the definitions for the machine instruction set
+;;; and some other stuff needed by the compiler.
+
+
+;;; This section contains various information regarding the misc. instructions
+;;; on the Lisp Machine. Every entry is of the form:
+;;; (DEFMIC <name> <opcode> <arglist> <lisp-function-p> <no-QINTCMP>)
+;;; <name> is the name of the instruction. If the Lisp function name
+;;; is different from the instruction name, this is a cons
+;;; of the function name and the instruction name (e.g. (CAR . M-CAR))
+;;; <opcode> is the number which appears in the macro-instruction.
+;;; <arglist> is a list resembling a lambda-list for the Lisp function
+;;; corresponding to the instruction. & keywords not allowed.
+;;; <lisp-function-p> should be either T or NIL. If T, then there
+;;; will be a Lisp function defined in the initial Lisp
+;;; environment (available in the interpreter) corresponding
+;;; to the instruction.
+;;; <no-QINTCMP> is OPTIONAL. If it is not present it is taken to be NIL.
+;;; If it is non-NIL, then no QINTCMP property will be created
+;;; for the symbol. Otherwise the QINTCMP property is created from
+;;; the length of <arglist>. The QINTCMP property permits the
+;;; compiler to compile calls to this function as a misc instruction.
+
+;240 241 FREE
+(DEFMIC (CAR . M-CAR) 242 (X) CL:T CL:T)
+(DEFMIC (CDR . M-CDR) 243 (X) CL:T CL:T)
+(DEFMIC (CAAR . M-CAAR) 244 (X) CL:T CL:T)
+(DEFMIC (CADR . M-CADR) 245 (X) CL:T CL:T)
+(DEFMIC (CDAR . M-CDAR) 246 (X) CL:T CL:T)
+(DEFMIC (CDDR . M-CDDR) 247 (X) CL:T CL:T)
+(DEFMIC CAAAR 250 (X) CL:T)
+(DEFMIC CAADR 251 (X) CL:T)
+(DEFMIC CADAR 252 (X) CL:T)
+(DEFMIC CADDR 253 (X) CL:T)
+(DEFMIC CDAAR 254 (X) CL:T)
+(DEFMIC CDADR 255 (X) CL:T)
+(DEFMIC CDDAR 256 (X) CL:T)
+(DEFMIC CDDDR 257 (X) CL:T)
+(DEFMIC CAAAAR 260 (X) CL:T)
+(DEFMIC CAAADR 261 (X) CL:T)
+(DEFMIC CAADAR 262 (X) CL:T)
+(DEFMIC CAADDR 263 (X) CL:T)
+(DEFMIC CADAAR 264 (X) CL:T)
+(DEFMIC CADADR 265 (X) CL:T)
+(DEFMIC CADDAR 266 (X) CL:T)
+(DEFMIC CADDDR 267 (X) CL:T)
+(DEFMIC CDAAAR 270 (X) CL:T)
+(DEFMIC CDAADR 271 (X) CL:T)
+(DEFMIC CDADAR 272 (X) CL:T)
+(DEFMIC CDADDR 273 (X) CL:T)
+(DEFMIC CDDAAR 274 (X) CL:T)
+(DEFMIC CDDADR 275 (X) CL:T)
+(DEFMIC CDDDAR 276 (X) CL:T)
+(DEFMIC CDDDDR 277 (X) CL:T)
+
+(DEFMIC %LOAD-FROM-HIGHER-CONTEXT 300 (ENVPTR) CL:T)
+(DEFMIC %LOCATE-IN-HIGHER-CONTEXT 301 (ENVPTR) CL:T)
+(DEFMIC %STORE-IN-HIGHER-CONTEXT 302 (VALUE ENVPTR) CL:T)
+(DEFMIC %DATA-TYPE 303 (X) CL:T)
+(DEFMIC %POINTER 304 (X) CL:T)
+;305-307 FREE
+(DEFMIC %MAKE-POINTER 310 (DTP ADDRESS) CL:T)
+(DEFMIC %SPREAD 311 (LIST) CL:NIL CL:T)
+(DEFMIC %P-STORE-CONTENTS 312 (POINTER X) CL:T)
+(DEFMIC %LOGLDB 313 (PPSS WORD) CL:T) ;THESE DONT COMPLAIN ABOUT LOADING/CLOBBERING SIGN
+(DEFMIC %LOGDPB 314 (VALUE PPSS WORD) CL:T) ;RESULT IS ALWAYS A FIXNUM
+(DEFMIC LDB 315 (PPSS WORD) CL:T)
+(DEFMIC DPB 316 (VALUE PPSS WORD) CL:T)
+(DEFMIC %P-STORE-TAG-AND-POINTER 317 (POINTER MISC-FIELDS POINTER-FIELD) CL:T)
+
+(DEFMIC GET 320 (SYMBOL INDICATOR) CL:T)
+(DEFMIC GETL 321 (SYMBOL INDICATOR-LIST) CL:T)
+(DEFMIC ASSQ 322 (X ALIST) CL:T)
+(DEFMIC LAST 323 (LIST) CL:T)
+(DEFMIC LENGTH 324 (LIST) CL:T)
+(DEFMIC 1+ 325 (N) CL:T)
+(DEFMIC 1- 326 (N) CL:T)
+(DEFMIC RPLACA 327 (CONS X) CL:T)
+(DEFMIC RPLACD 330 (CONS X) CL:T)
+(DEFMIC ZEROP 331 (NUMBER) CL:T)
+(DEFMIC SET 332 (SYMBOL X) CL:T)
+(DEFMIC FIXP 333 (X) CL:T)
+(DEFMIC FLOATP 334 (X) CL:T)
+(DEFMIC EQUAL 335 (X Y) CL:T)
+;(DEFMIC STORE 336 )
+(DEFMIC XSTORE 337 (NEWDATA ARRAYREF) CL:T)
+
+(DEFMIC FALSE 340 () CL:T)
+(DEFMIC TRUE 341 () CL:T)
+(DEFMIC NOT 342 (X) CL:T)
+(DEFMIC (NULL . NOT) 342 (X) CL:T)
+(DEFMIC ATOM 343 (X) CL:T)
+(DEFMIC ODDP 344 (NUMBER) CL:T)
+(DEFMIC EVENP 345 (NUMBER) CL:T)
+(DEFMIC %HALT 346 () CL:T)
+(DEFMIC GET-PNAME 347 (SYMBOL) CL:T)
+(DEFMIC LSH 350 (N NBITS) CL:T)
+(DEFMIC ROT 351 (N NBITS) CL:T)
+(DEFMIC *BOOLE 352 (FN ARG1 ARG2) CL:T)
+(DEFMIC NUMBERP 353 (X) CL:T)
+(DEFMIC PLUSP 354 (NUMBER) CL:T)
+(DEFMIC MINUSP 355 (NUMBER) CL:T)
+(DEFMIC |\\| 356 (X Y) CL:T)
+(DEFMIC MINUS 357 (NUMBER) CL:T)
+(DEFMIC PRINT-NAME-CELL-LOCATION 360 (SYMBOL) CL:T)
+(DEFMIC VALUE-CELL-LOCATION 361 (SYMBOL) CL:T)
+(DEFMIC FUNCTION-CELL-LOCATION 362 (SYMBOL) CL:T)
+(DEFMIC PROPERTY-CELL-LOCATION 363 (SYMBOL) CL:T)
+(DEFMIC NCONS 364 (X) CL:T)
+(DEFMIC NCONS-IN-AREA 365 (X AREA) CL:T)
+(DEFMIC CONS 366 (X Y) CL:T)
+(DEFMIC CONS-IN-AREA 367 (X Y AREA) CL:T)
+(DEFMIC XCONS 370 (X Y) CL:T)
+(DEFMIC XCONS-IN-AREA 371 (X Y AREA) CL:T)
+(DEFMIC %SPREAD-N 372 (N) CL:NIL)
+(DEFMIC SYMEVAL 373 (SYMBOL) CL:T)
+(DEFMIC POP-M-FROM-UNDER-N 374 (NUM-POPS NUM-TO-KEEP) CL:NIL)
+(DEFMIC %OLD-MAKE-LIST 375 (AREA LENGTH) CL:T)
+(DEFMIC %CALL-MULT-VALUE 376 () CL:NIL CL:T)
+(DEFMIC %CALL0-MULT-VALUE 377 () CL:NIL CL:T)
+(DEFMIC %RETURN-2 400 () CL:NIL CL:T)
+(DEFMIC %RETURN-3 401 () CL:NIL CL:T)
+(DEFMIC %RETURN-N 402 () CL:NIL CL:T)
+(DEFMIC RETURN-NEXT-VALUE 403 (X) CL:NIL)
+(DEFMIC RETURN-LIST 404 (VALUES) CL:NIL CL:T)
+(DEFMIC UNBIND-TO-INDEX-UNDER-N 405 (N) CL:NIL)
+(DEFMIC BIND 406 (POINTER X) CL:NIL)
+(DEFMIC %MAKE-LEXICAL-CLOSURE 407 (LOCALNUM) CL:NIL CL:T)
+(DEFMIC MEMQ 410 (X LIST) CL:T)
+(DEFMIC (INTERNAL-< . M-<) 411 (NUM1 NUM2) CL:T)
+(DEFMIC (INTERNAL-> . M->) 412 (NUM1 NUM2) CL:T)
+(DEFMIC (= . M-=) 413 (NUM1 NUM2) CL:T)
+(DEFMIC CHAR-EQUAL 414 (CH1 CH2) CL:T)
+(DEFMIC %STRING-SEARCH-CHAR 415 (CHAR STRING START END) CL:T)
+(DEFMIC %STRING-EQUAL 416 (STRING1 INDEX1 STRING2 INDEX2 COUNT) CL:T)
+(DEFMIC NTH 417 (N LIST) CL:T)
+(DEFMIC NTHCDR 420 (N LIST) CL:T)
+(DEFMIC (*PLUS . M-+) 421 (NUM1 NUM2) CL:T)
+(DEFMIC (*DIF . M--) 422 (NUM1 NUM2) CL:T)
+(DEFMIC (*TIMES . M-*) 423 (NUM1 NUM2) CL:T)
+(DEFMIC (*QUO . M-//) 424 (NUM1 NUM2) CL:T)
+(DEFMIC (*LOGAND . M-LOGAND) 425 (NUM1 NUM2) CL:T)
+(DEFMIC (*LOGXOR . M-LOGXOR) 426 (NUM1 NUM2) CL:T)
+(DEFMIC (*LOGIOR . M-LOGIOR) 427 (NUM1 NUM2) CL:T)
+(DEFMIC ARRAY-LEADER 430 (ARRAY INDEX) CL:T)
+(DEFMIC STORE-ARRAY-LEADER 431 (X ARRAY INDEX) CL:T)
+(DEFMIC GET-LIST-POINTER-INTO-ARRAY 432 (ARRAY) CL:T)
+(DEFMIC ARRAY-PUSH 433 (ARRAY X) CL:T)
+(DEFMIC APPLY 434 (FN ARGS) CL:T)
+(DEFMIC %MAKE-LIST 435 (INITIAL-VALUE AREA LENGTH) CL:T)
+(DEFMIC LIST 436 (&REST ELEMENTS) CL:T CL:T)
+(DEFMIC LIST* 437 (FIRST &REST ELEMENTS) CL:T CL:T) ;"(&REST ELEMENTS LAST)"
+(DEFMIC LIST-IN-AREA 440 (AREA &REST ELEMENTS) CL:T CL:T)
+(DEFMIC LIST*-IN-AREA 441 (AREA FIRST &REST ELEMENTS) CL:T CL:T) ;"(AREA &REST ELEMENTS LAST)"
+;442 FREE
+(DEFMIC %P-CDR-CODE 443 (POINTER) CL:T)
+(DEFMIC %P-DATA-TYPE 444 (POINTER) CL:T)
+(DEFMIC %P-POINTER 445 (POINTER) CL:T)
+(DEFMIC %PAGE-TRACE 446 (TABLE) CL:T)
+;447 FREE
+(DEFMIC %P-STORE-CDR-CODE 450 (POINTER CDR-CODE) CL:T)
+(DEFMIC %P-STORE-DATA-TYPE 451 (POINTER DATA-TYPE) CL:T)
+(DEFMIC %P-STORE-POINTER 452 (POINTER POINTER) CL:T)
+;453-455 FREE
+(DEFMIC %CATCH-OPEN 456 () CL:NIL CL:T)
+(DEFMIC %CATCH-OPEN-MV 457 () CL:NIL CL:T)
+;461, 462 FREE
+(DEFMIC %FEXPR-CALL 462 () CL:NIL CL:T)
+(DEFMIC %FEXPR-CALL-MV 463 () CL:NIL CL:T)
+(DEFMIC %LEXPR-CALL 464 () CL:NIL CL:T)
+(DEFMIC %LEXPR-CALL-MV 465 () CL:NIL CL:T)
+(DEFMIC *CATCH 466 (TAG &REST FORMS) CL:T CL:T)
+(DEFMIC %BLT 467 (FROM-ADDRESS TO-ADDRESS COUNT INCREMENT) CL:T)
+(DEFMIC *THROW 470 (TAG VALUE) CL:T)
+(DEFMIC %XBUS-WRITE-SYNC 471 (IO-ADDR WORD DELAY SYNC-LOC SYNC-MASK SYNC-VAL) CL:T)
+(DEFMIC %P-LDB 472 (PPSS POINTER) CL:T)
+(DEFMIC %P-DPB 473 (VALUE PPSS POINTER) CL:T)
+(DEFMIC MASK-FIELD 474 (PPSS FIXNUM) CL:T)
+(DEFMIC %P-MASK-FIELD 475 (PPSS POINTER) CL:T)
+(DEFMIC DEPOSIT-FIELD 476 (VALUE PPSS FIXNUM) CL:T)
+(DEFMIC %P-DEPOSIT-FIELD 477 (VALUE PPSS POINTER) CL:T)
+(DEFMIC COPY-ARRAY-CONTENTS 500 (FROM TO) CL:T)
+(DEFMIC COPY-ARRAY-CONTENTS-AND-LEADER 501 (FROM TO) CL:T)
+(DEFMIC %FUNCTION-INSIDE-SELF 502 () CL:T)
+(DEFMIC ARRAY-HAS-LEADER-P 503 (ARRAY) CL:T)
+(DEFMIC COPY-ARRAY-PORTION 504 (FROM-ARRAY FROM-START FROM-END TO-ARRAY TO-START TO-END) CL:T)
+(DEFMIC FIND-POSITION-IN-LIST 505 (X LIST) CL:T)
+;(DEFMIC FIND-POSITION-IN-LIST-EQUAL 506 )
+(DEFMIC G-L-P 507 (ARRAY) CL:T)
+(DEFMIC FIND-POSITION-IN-VECTOR 510 (X LIST) CL:NIL)
+;(DEFMIC FIND-POSITION-IN-VECTOR-EQUAL 511 )
+(DEFMIC AR-1 512 (ARRAY SUB) CL:T)
+(DEFMIC AR-2 513 (ARRAY SUB1 SUB2) CL:T)
+(DEFMIC AR-3 514 (ARRAY SUB1 SUB2 SUB3) CL:T)
+(DEFMIC AS-1 515 (VALUE ARRAY SUB) CL:T)
+(DEFMIC AS-2 516 (VALUE ARRAY SUB1 SUB2) CL:T)
+(DEFMIC AS-3 517 (VALUE ARRAY SUB1 SUB2 SUB3) CL:T)
+(DEFMIC %INSTANCE-REF 520 (INSTANCE INDEX) CL:T)
+(DEFMIC %INSTANCE-LOC 521 (INSTANCE INDEX) CL:T)
+(DEFMIC %INSTANCE-SET 522 (VAL INSTANCE INDEX) CL:T)
+(DEFMIC %BINDING-INSTANCES 523 (LIST-OF-SYMBOLS) CL:T)
+(DEFMIC %INTERNAL-VALUE-CELL 524 (SYMBOL) CL:T)
+(DEFMIC %USING-BINDING-INSTANCES 525 (BINDING-INSTANCES) CL:T)
+(DEFMIC %GC-CONS-WORK 526 (NQS) CL:T)
+(DEFMIC %P-CONTENTS-OFFSET 527 (POINTER OFFSET) CL:T)
+(DEFMIC %DISK-RESTORE 530 (PARTITION-HIGH-16-BITS LOW-16-BITS) CL:T)
+(DEFMIC %DISK-SAVE 531 (MAIN-MEMORY-SIZE PARTITION-HIGH-16-BITS LOW-16-BITS) CL:T)
+(DEFMIC %ARGS-INFO 532 (FUNCTION) CL:T)
+(DEFMIC %OPEN-CALL-BLOCK 533 (FUNCTION ADI-PAIRS DESTINATION) CL:NIL)
+(DEFMIC %PUSH 534 (X) CL:NIL)
+(DEFMIC %ACTIVATE-OPEN-CALL-BLOCK 535 () CL:NIL)
+(DEFMIC %ASSURE-PDL-ROOM 536 (ROOM) CL:NIL)
+(DEFMIC STACK-GROUP-RETURN 537 (X) CL:T)
+;(DEFMIC %STACK-GROUP-RETURN-MULTI 540 )
+;Perhaps the next one should be flushed.
+(DEFMIC %MAKE-STACK-LIST 541 (N) CL:NIL)
+(DEFMIC STACK-GROUP-RESUME 542 (SG X) CL:T)
+(DEFMIC %CALL-MULT-VALUE-LIST 543 () CL:NIL CL:T)
+(DEFMIC %CALL0-MULT-VALUE-LIST 544 () CL:NIL CL:T)
+(DEFMIC %GC-SCAV-RESET 545 (REGION) CL:T)
+(DEFMIC %P-STORE-CONTENTS-OFFSET 546 (X POINTER OFFSET) CL:T)
+(DEFMIC %GC-FREE-REGION 547 (REGION) CL:T)
+(DEFMIC %GC-FLIP 550 (REGION) CL:T)
+(DEFMIC ARRAY-LENGTH 551 (ARRAY) CL:T)
+(DEFMIC ARRAY-ACTIVE-LENGTH 552 (ARRAY) CL:T)
+(DEFMIC %COMPUTE-PAGE-HASH 553 (ADDR) CL:T)
+(DEFMIC GET-LOCATIVE-POINTER-INTO-ARRAY 554 (ARRAY-REF) CL:T)
+(DEFMIC %UNIBUS-READ 555 (UNIBUS-ADDR) CL:T)
+(DEFMIC %UNIBUS-WRITE 556 (UNIBUS-ADDR WORD) CL:T)
+(DEFMIC %GC-SCAVENGE 557 (WORK-UNITS) CL:T)
+(DEFMIC %CHAOS-WAKEUP 560 () CL:T)
+(DEFMIC %AREA-NUMBER 561 (X) CL:T)
+(DEFMIC *MAX 562 (NUM1 NUM2) CL:T)
+(DEFMIC *MIN 563 (NUM1 NUM2) CL:T)
+(DEFMIC CLOSURE 565 (SYMBOL-LIST FUNCTION) CL:T)
+;(DEFMIC DOWNWARD-CLOSURE 566 (SYMBOL-LIST FUNCTION) CL:T)
+(DEFMIC LISTP 567 (X) CL:T)
+(DEFMIC NLISTP 570 (X) CL:T)
+(DEFMIC SYMBOLP 571 (X) CL:T)
+(DEFMIC NSYMBOLP 572 (X) CL:T)
+(DEFMIC ARRAYP 573 (X) CL:T)
+(DEFMIC FBOUNDP 574 (SYMBOL) CL:T)
+(DEFMIC STRINGP 575 (X) CL:T)
+(DEFMIC BOUNDP 576 (SYMBOL) CL:T)
+(DEFMIC INTERNAL-\\ 577 (NUM1 NUM2) CL:T)
+(DEFMIC FSYMEVAL 600 (SYMBOL) CL:T)
+(DEFMIC AP-1 601 (ARRAY SUB) CL:T)
+(DEFMIC AP-2 602 (ARRAY SUB1 SUB2) CL:T)
+(DEFMIC AP-3 603 (ARRAY SUB1 SUB2 SUB3) CL:T)
+(DEFMIC AP-LEADER 604 (ARRAY SUB) CL:T)
+(DEFMIC %P-LDB-OFFSET 605 (PPSS POINTER OFFSET) CL:T)
+(DEFMIC %P-DPB-OFFSET 606 (VALUE PPSS POINTER OFFSET) CL:T)
+(DEFMIC %P-MASK-FIELD-OFFSET 607 (PPSS POINTER OFFSET) CL:T)
+(DEFMIC %P-DEPOSIT-FIELD-OFFSET 610 (VALUE PPSS POINTER OFFSET) CL:T)
+(DEFMIC %MULTIPLY-FRACTIONS 611 (NUM1 NUM2) CL:T)
+(DEFMIC %DIVIDE-DOUBLE 612 (HIGH-DIVIDEND LOW-DIVIDEND DIVISOR) CL:T)
+(DEFMIC %REMAINDER-DOUBLE 613 (HIGH-DIVIDEND LOW-DIVIDEND DIVISOR) CL:T)
+(DEFMIC HAULONG 614 (NUM) CL:T)
+(DEFMIC %ALLOCATE-AND-INITIALIZE 615 (RETURN-DTP HEADER-DTP HEADER WORD2 AREA NQS) CL:T)
+(DEFMIC %ALLOCATE-AND-INITIALIZE-ARRAY 616 (HEADER INDEX-LENGTH LEADER-LENGTH AREA NQS) CL:T)
+(DEFMIC %MAKE-POINTER-OFFSET 617 (NEW-DTP POINTER OFFSET) CL:T)
+(DEFMIC ^ 620 (NUM EXPT) CL:T)
+(DEFMIC %CHANGE-PAGE-STATUS 621 (VIRT-ADDR SWAP-STATUS ACCESS-AND-META) CL:T)
+(DEFMIC %CREATE-PHYSICAL-PAGE 622 (PHYS-ADDR) CL:T)
+(DEFMIC %DELETE-PHYSICAL-PAGE 623 (PHYS-ADDR) CL:T)
+(DEFMIC %24-BIT-PLUS 624 (NUM1 NUM2) CL:T)
+(DEFMIC %24-BIT-DIFFERENCE 625 (NUM1 NUM2) CL:T)
+(DEFMIC %24-BIT-TIMES 626 (NUM1 NUM2) CL:T)
+(DEFMIC ABS 627 (NUM) CL:T)
+(DEFMIC %POINTER-DIFFERENCE 630 (PTR1 PTR2) CL:T)
+(DEFMIC %P-CONTENTS-AS-LOCATIVE 631 (POINTER) CL:T)
+(DEFMIC %P-CONTENTS-AS-LOCATIVE-OFFSET 632 (POINTER OFFSET) CL:T)
+(DEFMIC (EQ . M-EQ) 633 (X Y) CL:T)
+(DEFMIC %STORE-CONDITIONAL 634 (POINTER OLD NEW) CL:T)
+(DEFMIC %STACK-FRAME-POINTER 635 () CL:NIL)
+(DEFMIC *UNWIND-STACK 636 (TAG VALUE FRAME-COUNT ACTION) CL:T)
+(DEFMIC %XBUS-READ 637 (IO-ADDR) CL:T)
+(DEFMIC %XBUS-WRITE 640 (IO-ADDR WORD) CL:T)
+(DEFMIC PACKAGE-CELL-LOCATION 641 (SYMBOL) CL:T)
+(DEFMIC MOVE-PDL-TOP 642 CL:NIL CL:NIL CL:T)
+(DEFMIC SHRINK-PDL-SAVE-TOP 643 (VALUE-TO-MOVE N-SLOTS) CL:NIL CL:T)
+(DEFMIC SPECIAL-PDL-INDEX 644 CL:NIL CL:NIL CL:T)
+(DEFMIC UNBIND-TO-INDEX 645 (SPECIAL-PDL-INDEX) CL:NIL CL:T)
+(DEFMIC UNBIND-TO-INDEX-MOVE 646 (SPECIAL-PDL-INDEX VALUE-TO-MOVE) CL:NIL CL:T)
+(DEFMIC FIX 647 (NUMBER) CL:T)
+(DEFMIC FLOAT 650 (NUMBER) CL:T)
+(DEFMIC SMALL-FLOAT 651 (NUMBER) CL:T)
+(DEFMIC %FLOAT-DOUBLE 652 (NUMBER NUMBER) CL:T)
+(DEFMIC BIGNUM-TO-ARRAY 653 (BIGNUM BASE) CL:T)
+(DEFMIC ARRAY-TO-BIGNUM 654 (ARRAY BASE SIGN) CL:T)
+(DEFMIC %UNWIND-PROTECT-CONTINUE 655 (VALUE TAG COUNT ACTION) CL:NIL CL:T)
+(DEFMIC %WRITE-INTERNAL-PROCESSOR-MEMORIES 656 (CODE ADR D-HI D-LOW) CL:T)
+(DEFMIC %PAGE-STATUS 657 (PTR) CL:T)
+(DEFMIC %REGION-NUMBER 660 (PTR) CL:T)
+(DEFMIC %FIND-STRUCTURE-HEADER 661 (PTR) CL:T)
+(DEFMIC %STRUCTURE-BOXED-SIZE 662 (PTR) CL:T)
+(DEFMIC %STRUCTURE-TOTAL-SIZE 663 (PTR) CL:T)
+(DEFMIC %MAKE-REGION 664 (BITS SIZE) CL:T)
+(DEFMIC BITBLT 665 (ALU WIDTH HEIGHT FROM-ARRAY FROM-X FROM-Y TO-ARRAY TO-X TO-Y) CL:T)
+(DEFMIC %DISK-OP 666 (RQB) CL:T)
+(DEFMIC %PHYSICAL-ADDRESS 667 (PTR) CL:T)
+(DEFMIC POP-OPEN-CALL 670 CL:NIL CL:NIL CL:T)
+(DEFMIC %BEEP 671 (HALF-WAVELENGTH DURATION) CL:T)
+(DEFMIC %FIND-STRUCTURE-LEADER 672 (PTR) CL:T)
+(DEFMIC BPT 673 CL:NIL CL:T)
+(DEFMIC %FINDCORE 674 () CL:T)
+(DEFMIC %PAGE-IN 675 (PFN VPN) CL:T)
+(DEFMIC ASH 676 (N NBITS) CL:T)
+(DEFMIC %MAKE-EXPLICIT-STACK-LIST 677 (LENGTH) CL:T)
+(DEFMIC %DRAW-CHAR 700 (FONT-ARRAY CHAR-CODE X-BITPOS Y-BITPOS ALU-FUNCTION SHEET) CL:T)
+(DEFMIC %DRAW-RECTANGLE 701 (WIDTH HEIGHT X-BITPOS Y-BITPOS ALU-FUNCTION SHEET) CL:T)
+(DEFMIC %DRAW-LINE 702 (X0 Y0 X Y ALU DRAW-END-POINT SHEET) CL:T)
+(DEFMIC %DRAW-TRIANGLE 703 (X1 Y1 X2 Y2 X3 Y3 ALU SHEET) CL:T)
+(DEFMIC %COLOR-TRANSFORM 704 (N17 N16 N15 N14 N13 N12 N11 N10 N7 N6 N5 N4 N3 N2 N1 N0
+ WIDTH HEIGHT ARRAY START-X START-Y) CL:T)
+(DEFMIC %RECORD-EVENT 705 (DATA-4 DATA-3 DATA-2 DATA-1 STACK-LEVEL EVENT MUST-BE-4) CL:T)
+(DEFMIC %AOS-TRIANGLE 706 (X1 Y1 X2 Y2 X3 Y3 INCREMENT SHEET) CL:T)
+(DEFMIC %SET-MOUSE-SCREEN 707 (SHEET) CL:T)
+(DEFMIC %OPEN-MOUSE-CURSOR 710 () CL:T)
+
+
+; FROM HERE TO 777 FREE
+
+;;; The ARGDESC properties, telling the compiler special things about
+;;; a few functions whose arguments would otherwise be compiled wrong.
+
+;AN ARGDESC PROPERTY IS A LIST OF 2-LISTS. THE FIRST ELEMENT OF EA
+;2-LIST IS A REPEAT COUNT. THE SECOND IS A LIST OF ADL SPECIFIER TYPE TOKENS.
+
+;The following are commented out since we no longer attempt to run the
+;compiler in Maclisp and therefore no longer get confused by SUBR/FSUBR/LSUBR properties.
+;;MAKE SURE CALLS TO DEFPROP GET COMPILED RIGHT (IE SPREAD ARGS). OTHERWISE,
+;; WOULD LOSE BECAUSE ITS A MACLISP FSUBR.
+;
+; (DEFPROP DEFPROP ((3 (FEF-ARG-REQ FEF-QT-QT))) ARGDESC)
+; (DEFPROP FASLOAD ((1 (FEF-ARG-REQ FEF-QT-EVAL)) (1 (FEF-ARG-OPT FEF-QT-EVAL))) ARGDESC)
+; ;Likewise FASLOAD which is a SUBR in LISPM since strings self-evaluate.
+
+;These remain here because the compiler loses on QUOTE-HAIR functions.
+ (DEFPROP BREAK ((1 (FEF-ARG-OPT FEF-QT-QT))
+ (1 (FEF-ARG-OPT FEF-QT-EVAL))) ARGDESC)
+
+ (DEFPROP SIGNP ((1 (FEF-ARG-REQ FEF-QT-QT)) (1 (FEF-ARG-REQ FEF-QT-EVAL))) ARGDESC)
+
+ (DEFPROP STATUS ((1 (FEF-ARG-REQ FEF-QT-QT))
+ (1 (FEF-ARG-OPT FEF-QT-QT))) ARGDESC)
+ (DEFPROP SSTATUS ((2 (FEF-ARG-REQ FEF-QT-QT))) ARGDESC)
+
+;MAKE SURE FUNCTIONAL ARGS TO MAPPING FUNCTIONS GET BROKEN OFF AND COMPILED
+; EVEN IF QUOTE USED INSTEAD OF FUNCTION. (HOWEVER, A POINTER TO THE
+; BROKEN-OFF SYMBOL INSTEAD OF THE CONTENTS OF ITS FUNCTION CELL WILL BE PASSED
+; IF QUOTE IS USED).
+
+ (DEFPROP MAP ((1 (FEF-ARG-REQ FEF-QT-EVAL FEF-FUNCTIONAL-ARG))
+ (1 (FEF-ARG-REQ FEF-QT-EVAL))
+ (105 (FEF-ARG-OPT FEF-QT-EVAL)) ) ARGDESC)
+ (DEFPROP MAPC ((1 (FEF-ARG-REQ FEF-QT-EVAL FEF-FUNCTIONAL-ARG))
+ (1 (FEF-ARG-REQ FEF-QT-EVAL))
+ (105 (FEF-ARG-OPT FEF-QT-EVAL)) ) ARGDESC)
+ (DEFPROP MAPCAR ((1 (FEF-ARG-REQ FEF-QT-EVAL FEF-FUNCTIONAL-ARG))
+ (1 (FEF-ARG-REQ FEF-QT-EVAL))
+ (105 (FEF-ARG-OPT FEF-QT-EVAL)) ) ARGDESC)
+ (DEFPROP MAPLIST ((1 (FEF-ARG-REQ FEF-QT-EVAL FEF-FUNCTIONAL-ARG))
+ (1 (FEF-ARG-REQ FEF-QT-EVAL))
+ (105 (FEF-ARG-OPT FEF-QT-EVAL)) ) ARGDESC)
+ (DEFPROP MAPCAN ((1 (FEF-ARG-REQ FEF-QT-EVAL FEF-FUNCTIONAL-ARG))
+ (1 (FEF-ARG-REQ FEF-QT-EVAL))
+ (105 (FEF-ARG-OPT FEF-QT-EVAL)) ) ARGDESC)
+ (DEFPROP MAPCON ((1 (FEF-ARG-REQ FEF-QT-EVAL FEF-FUNCTIONAL-ARG))
+ (1 (FEF-ARG-REQ FEF-QT-EVAL))
+ (105 (FEF-ARG-OPT FEF-QT-EVAL)) ) ARGDESC)
+ (DEFPROP APPLY ((2 (FEF-ARG-REQ FEF-QT-EVAL))) ARGDESC)
+ ;Because LSUBR in Maclisp?
+
+;;; Instructions and other symbols for LAP
+
+(DEFPROP CALL 0 QLVAL)
+
+(DEFPROP CALL0 1000 QLVAL)
+
+(DEFPROP MOVE 2000 QLVAL)
+
+(DEFPROP CAR 3000 QLVAL)
+
+(DEFPROP CDR 4000 QLVAL)
+
+(DEFPROP CADR 5000 QLVAL)
+
+(DEFPROP CDDR 6000 QLVAL)
+
+(DEFPROP CDAR 7000 QLVAL)
+
+(DEFPROP CAAR 10000 QLVAL)
+
+;ND1
+;(DEFPROP UNUSED 11000 QLVAL) ;NOT USED
+(DEFPROP *PLUS 31000 QLVAL) ;THESE USED TO BE CALLED +, -, ETC. BUT THOSE ARE NOW N-ARG
+(DEFPROP *DIF 51000 QLVAL) ;WHILE THESE SEVEN ARE TWO-ARGUMENTS-ONLY (INSTRUCTIONS).
+(DEFPROP *TIMES 71000 QLVAL)
+(DEFPROP *QUO 111000 QLVAL)
+(DEFPROP *LOGAND 131000 QLVAL)
+(DEFPROP *LOGXOR 151000 QLVAL)
+(DEFPROP *LOGIOR 171000 QLVAL)
+
+;ND2
+(DEFPROP = 12000 QLVAL)
+(DEFPROP INTERNAL-> 32000 QLVAL)
+(DEFPROP INTERNAL-< 52000 QLVAL)
+(DEFPROP EQ 72000 QLVAL)
+;;; SETE CDR 112000
+;;; SETE CDDR 132000
+;;; SETE 1+ 152000
+;;; SETE 1- 172000
+
+;ND3
+;;; 13000 unused, used to be BIND.
+(DEFPROP BINDNIL 33000 QLVAL)
+(DEFPROP BINDPOP 53000 QLVAL)
+(DEFPROP SETNIL 73000 QLVAL)
+(DEFPROP SETZERO 113000 QLVAL)
+(DEFPROP PUSH-E 133000 QLVAL)
+(DEFPROP MOVEM 153000 QLVAL)
+(DEFPROP POP 173000 QLVAL)
+
+;;; 14 BRANCH
+(DEFPROP MISC 15000 QLVAL)
+
+;;; - MISCELLANEOUS FUNCTIONS -
+;These two are no longer used
+;(DEFPROP LIST 0 QLVAL)
+;(DEFPROP LIST-IN-AREA 100 QLVAL)
+(DEFPROP UNBIND 200 QLVAL)
+ (DEFMIC UNBIND-0 200 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-1 201 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-2 202 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-3 203 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-4 204 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-5 205 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-6 206 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-7 207 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-10 210 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-11 211 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-12 212 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-13 213 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-14 214 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-15 215 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-16 216 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC UNBIND-17 217 CL:NIL CL:NIL CL:T) ;FOR UCONS
+(DEFPROP POPPDL 220 QLVAL)
+ (DEFMIC POPPDL-0 220 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-1 221 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-2 222 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-3 223 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-4 224 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-5 225 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-6 226 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-7 227 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-10 230 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-11 231 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-12 232 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-13 233 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-14 234 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-15 235 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-16 236 CL:NIL CL:NIL CL:T) ;FOR UCONS
+ (DEFMIC POPPDL-17 237 CL:NIL CL:NIL CL:T) ;FOR UCONS
+;The rest of these come from the DEFMIC table above.
+
+;"BASE REGISTERS"
+(DEFPROP FEF 0 QLVAL)
+
+(DEFPROP CONST-PAGE 400 QLVAL)
+
+(DEFPROP LOCBLOCK 500 QLVAL)
+
+(DEFPROP ARG 600 QLVAL)
+
+(DEFPROP LPDL 700 QLVAL)
+
+;DESTINATIONS
+(DEFPROP D-IGNORE 0 QLVAL)
+
+(DEFPROP D-INDS 0 QLVAL)
+
+(DEFPROP D-PDL 20000 QLVAL)
+
+(DEFPROP D-NEXT 40000 QLVAL)
+
+(DEFPROP D-LAST 60000 QLVAL)
+
+(DEFPROP D-RETURN 100000 QLVAL)
+
+;(DEFPROP DEST-ARG-QTD 60000 QLVAL) ;ADDED TO D-NEXT,D-LAST
+
+(DEFPROP D-NEXT-LIST 160000 QLVAL)
+
+;;; Properties for the micro-compiler
+
+(DEFPROP M-CAR QMA LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-CDR QMD LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-CAAR QMAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-CADR QMAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-CDAR QMDA LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-CDDR QMDD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAAAR QMAAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAADR QMAAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADAR QMADA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADDR QMADD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDAAR QMDAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDADR QMDAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDAR QMDDA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDDR QMDDD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAAAAR QMAAAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAAADR QMAAAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAADAR QMAADA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAADDR QMAADD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADAAR QMADAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADADR QMADAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADDAR QMADDA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADDDR QMADDD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDAAAR QMDAAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDAADR QMDAAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDADAR QMDADA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDADDR QMDADD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDAAR QMDDAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDADR QMDDAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDDAR QMDDDA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDDDR QMDDDD LAST-ARG-IN-T-ENTRY)
+
+(DEFPROP M-+ XTCADD LAST-ARG-IN-T-ENTRY) ;CHECKS INPUT D.T. TO ASSURE FIXED
+(DEFPROP M-- XTCSUB LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-* XTCMUL LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-// XTCDIV LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-LOGAND XTCAND LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-LOGXOR XTCXOR LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-LOGIOR XTCIOR LAST-ARG-IN-T-ENTRY)
+
+;(DEFPROP XTCADD XTADD NO-TYPE-CHECKING-ENTRY) ;ONE ARG IN T, ONE ON PDL
+;(DEFPROP XTCSUB XTSUB NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP XTCMUL XTMUL NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP XTCDIV XTDIV NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP XTCAND XTAND NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP XTCXOR XTXOR NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP XTCIOR XTIOR NO-TYPE-CHECKING-ENTRY)
+
+;(DEFPROP M-+ XTADD UNBOXED-NUM-IN-T-ENTRY) ;THESE GUYS DONT REALLY CHECK ANYWAY
+;(DEFPROP M-- XTSUB UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP M-* XTMUL UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP M-// XTDIV UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP M-LOGAND XTAND UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP M-LOGXOR XTXOR UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP M-LOGIOR XTIOR UNBOXED-NUM-IN-T-ENTRY)
+
+;(DEFPROP M-+ XMADD NO-TYPE-CHECKING-ENTRY) ;THESE ARE A BIT FASTER
+;(DEFPROP M-- XMSUB NO-TYPE-CHECKING-ENTRY) ;TAKE 2 ARGS ON PDL
+;(DEFPROP M-* XMMUL NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP M-// XMDIV NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP M-LOGAND XMAND NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP M-LOGXOR XMXOR NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP M-LOGIOR XMIOR NO-TYPE-CHECKING-ENTRY)
+
+;(DEFPROP ATOM XTATOM LAST-ARG-IN-T-ENTRY)
+;(DEFPROP ZEROP XTZERO LAST-ARG-IN-T-ENTRY)
+(DEFPROP NUMBERP XTNUMB LAST-ARG-IN-T-ENTRY)
+(DEFPROP FIXP XTFIXP LAST-ARG-IN-T-ENTRY)
+(DEFPROP FLOATP XTFLTP LAST-ARG-IN-T-ENTRY)
+;(DEFPROP PLUSP XTPLUP LAST-ARG-IN-T-ENTRY)
+;(DEFPROP MINUSP XTMNSP LAST-ARG-IN-T-ENTRY)
+;(DEFPROP MINUS XTMNS LAST-ARG-IN-T-ENTRY)
+;(DEFPROP 1+ XT1PLS LAST-ARG-IN-T-ENTRY)
+;(DEFPROP 1- XT1MNS LAST-ARG-IN-T-ENTRY)
+;(DEFPROP SYMEVAL XTSYME LAST-ARG-IN-T-ENTRY)
+(DEFPROP LENGTH XTLENG LAST-ARG-IN-T-ENTRY)
+
+;(DEFPROP ZEROP XBZERO UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP PLUSP XBPLUP UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP MINUSP XBMNSP UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP MINUS XBMNS UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP 1+ XB1PLS UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP 1- XB1MNS UNBOXED-NUM-IN-T-ENTRY)
+
+;;; Certain MISC-instructions make assumptions about what destinations
+;;; they are used with. Some require D-IGNORE, because they assume that
+;;; there is no return address on the micro-stack. Some do not allow D-IGNORE,
+;;; because they popj and start a memory cycle. Some are really random.
+(CL:DEFVAR MISC-INSTRUCTION-REQUIRED-DESTINATION-ALIST
+ '( (%ALLOCATE-AND-INITIALIZE D-PDL D-NEXT D-LAST D-RETURN D-NEXT-LIST)
+ (%ALLOCATE-AND-INITIALIZE-ARRAY D-PDL D-NEXT D-LAST D-RETURN D-NEXT-LIST)
+ (%SPREAD D-NEXT D-LAST)
+ (RETURN-LIST D-RETURN)
+ (%OPEN-CALL-BLOCK D-IGNORE D-INDS)
+ (%ACTIVATE-OPEN-CALL-BLOCK D-IGNORE D-INDS)
+ (%RETURN-2 D-IGNORE D-INDS)
+ (%RETURN-3 D-IGNORE D-INDS)
+ (%RETURN-N D-IGNORE D-INDS)
+ (%RETURN-NEXT-VALUE D-IGNORE D-INDS)))
Added: trunk/tools/cold/defmic99.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/defmic99.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,743 @@
+;;; -*- Mode:LISP; Base:8; Readtable:T -*-
+
+; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+;;; This file contains all the definitions for the machine instruction set
+;;; and some other stuff needed by the compiler.
+
+
+;;; This section contains various information regarding the misc. instructions
+;;; on the Lisp Machine. Every entry is of the form:
+;;; (DEFMIC <name> <opcode> <arglist> <lisp-function-p> <no-QINTCMP>)
+;;; <name> is the name of the instruction. If the Lisp function name
+;;; is different from the instruction name, this is a cons
+;;; of the function name and the instruction name (e.g. (CAR . M-CAR))
+;;; <opcode> is the number which appears in the macro-instruction.
+;;; <arglist> is a list resembling a lambda-list for the Lisp function
+;;; corresponding to the instruction. & keywords not allowed.
+;;; <lisp-function-p> should be either T or NIL. If T, then there
+;;; will be a Lisp function defined in the initial Lisp
+;;; environment (available in the interpreter) corresponding
+;;; to the instruction.
+;;; <no-QINTCMP> is OPTIONAL. If it is not present it is taken to be NIL.
+;;; If it is non-NIL, then no QINTCMP property will be created
+;;; for the symbol. Otherwise the QINTCMP property is created from
+;;; the length of <arglist>. The QINTCMP property permits the
+;;; compiler to compile calls to this function as a misc instruction.
+
+;240 241 FREE
+(DEFMIC (CAR . M-CAR) 242 (X) cl:T cl:T)
+(DEFMIC (CDR . M-CDR) 243 (X) cl:T cl:T)
+(DEFMIC (CAAR . M-CAAR) 244 (X) cl:T cl:T)
+(DEFMIC (CADR . M-CADR) 245 (X) cl:T cl:T)
+(DEFMIC (CDAR . M-CDAR) 246 (X) cl:T cl:T)
+(DEFMIC (CDDR . M-CDDR) 247 (X) cl:T cl:T)
+(DEFMIC CAAAR 250 (X) cl:T)
+(DEFMIC CAADR 251 (X) cl:T)
+(DEFMIC CADAR 252 (X) cl:T)
+(DEFMIC CADDR 253 (X) cl:T)
+(DEFMIC CDAAR 254 (X) cl:T)
+(DEFMIC CDADR 255 (X) cl:T)
+(DEFMIC CDDAR 256 (X) cl:T)
+(DEFMIC CDDDR 257 (X) cl:T)
+(DEFMIC CAAAAR 260 (X) cl:T)
+(DEFMIC CAAADR 261 (X) cl:T)
+(DEFMIC CAADAR 262 (X) cl:T)
+(DEFMIC CAADDR 263 (X) cl:T)
+(DEFMIC CADAAR 264 (X) cl:T)
+(DEFMIC CADADR 265 (X) cl:T)
+(DEFMIC CADDAR 266 (X) cl:T)
+(DEFMIC CADDDR 267 (X) cl:T)
+(DEFMIC CDAAAR 270 (X) cl:T)
+(DEFMIC CDAADR 271 (X) cl:T)
+(DEFMIC CDADAR 272 (X) cl:T)
+(DEFMIC CDADDR 273 (X) cl:T)
+(DEFMIC CDDAAR 274 (X) cl:T)
+(DEFMIC CDDADR 275 (X) cl:T)
+(DEFMIC CDDDAR 276 (X) cl:T)
+(DEFMIC CDDDDR 277 (X) cl:T)
+
+(DEFMIC %LOAD-FROM-HIGHER-CONTEXT 300 (ENVPTR) cl:T)
+(DEFMIC %LOCATE-IN-HIGHER-CONTEXT 301 (ENVPTR) cl:T)
+(DEFMIC %STORE-IN-HIGHER-CONTEXT 302 (VALUE ENVPTR) cl:T)
+(DEFMIC %DATA-TYPE 303 (X) cl:T)
+(DEFMIC %POINTER 304 (X) cl:T)
+(DEFMIC %MAKE-REST-ARG-SAFE 305 () cl:T)
+(DEFMIC %PERMIT-TAIL-RECURSION 306 () cl:NIL cl:T)
+(DEFMIC INTERNAL-FLOAT 307 (NUMBER) cl:NIL)
+(DEFMIC %MAKE-POINTER 310 (DTP ADDRESS) cl:T)
+(DEFMIC %SPREAD 311 (LIST) cl:NIL cl:T)
+(DEFMIC %P-STORE-CONTENTS 312 (POINTER VALUE) cl:T)
+(DEFMIC %LOGLDB 313 (PPSS WORD) cl:T) ;These don't complain about loading/clobbering
+(DEFMIC %LOGDPB 314 (VALUE PPSS WORD) cl:T) ; sign bit. Result is always a fixnum
+(DEFMIC LDB 315 (PPSS WORD) cl:T)
+(DEFMIC DPB 316 (VALUE PPSS WORD) cl:T)
+(DEFMIC %P-STORE-TAG-AND-POINTER 317 (POINTER MISC-FIELDS POINTER-FIELD) cl:T)
+
+(DEFMIC INTERNAL-GET-2 320 (SYMBOL PROPERTY) cl:NIL)
+(DEFMIC GETL 321 (SYMBOL PROPERTY-NAME-LIST) cl:T)
+(DEFMIC ASSQ 322 (X ALIST) cl:T)
+(DEFMIC LAST 323 (LIST) cl:T)
+(DEFMIC LENGTH 324 (LIST-OR-ARRAY) cl:T)
+(DEFMIC 1+ 325 (N) cl:T)
+(DEFMIC 1- 326 (N) cl:T)
+(DEFMIC RPLACA 327 (CONS NEW-CAR) cl:T)
+(DEFMIC RPLACD 330 (CONS NEW-CDR) cl:T)
+(DEFMIC ZEROP 331 (NUMBER) cl:T)
+(DEFMIC SET 332 (SYMBOL VALUE) cl:T)
+(DEFMIC INTEGERP 333 (X) cl:T)
+(DEFMIC (FIXP . INTEGERP) 333 (X) cl:T)
+(DEFMIC FLOATP 334 (X) cl:T)
+(DEFMIC EQUAL 335 (X Y) cl:T)
+(DEFMIC %SET-SELF-MAPPING-TABLE 336 (MAPPING-TABLE) cl:T)
+(DEFMIC PDL-WORD 337 (N) cl:NIL cl:T)
+(DEFMIC FALSE 340 () cl:T)
+(DEFMIC TRUE 341 () cl:T)
+(DEFMIC NOT 342 (X) cl:T)
+(DEFMIC (NULL . NOT) 342 (X) cl:T)
+(DEFMIC ATOM 343 (X) cl:T)
+(DEFMIC ODDP 344 (NUMBER) cl:NIL)
+(DEFMIC EVENP 345 (NUMBER) cl:NIL)
+(DEFMIC %HALT 346 () cl:T)
+(DEFMIC GET-PNAME 347 (SYMBOL) cl:T)
+(DEFMIC (SYMBOL-NAME . GET-PNAME) 347 (SYMBOL) cl:T)
+(DEFMIC LSH 350 (N NBITS) cl:T)
+(DEFMIC ROT 351 (N NBITS) cl:T)
+(DEFMIC *BOOLE 352 (FN ARG1 ARG2) cl:T)
+(DEFMIC NUMBERP 353 (X) cl:T)
+(DEFMIC PLUSP 354 (NUMBER) cl:T)
+(DEFMIC MINUSP 355 (NUMBER) cl:T)
+(DEFMIC |\\| 356 (X Y) cl:T)
+(DEFMIC MINUS 357 (NUMBER) cl:T)
+(DEFMIC %SXHASH-STRING 360 (STRING CHARACTER-MASK) cl:T)
+(DEFMIC VALUE-CELL-LOCATION 361 (SYMBOL) cl:T)
+(DEFMIC FUNCTION-CELL-LOCATION 362 (SYMBOL) cl:T)
+(DEFMIC PROPERTY-CELL-LOCATION 363 (SYMBOL) cl:T)
+(DEFMIC NCONS 364 (CAR) cl:T)
+(DEFMIC NCONS-IN-AREA 365 (CAR AREA) cl:T)
+(DEFMIC CONS 366 (CAR CDR) cl:T)
+(DEFMIC CONS-IN-AREA 367 (CAR CDR AREA) cl:T)
+(DEFMIC XCONS 370 (CDR CAR) cl:T)
+(DEFMIC XCONS-IN-AREA 371 (CDR CAR AREA) cl:T)
+(DEFMIC %SPREAD-N 372 (LIST N) cl:NIL)
+(DEFMIC SYMEVAL 373 (SYMBOL) cl:T)
+(DEFMIC (SYMBOL-VALUE . SYMEVAL) 373 (SYMBOL) cl:T)
+(DEFMIC POP-M-FROM-UNDER-N 374 (NUM-POPS NUM-TO-KEEP) cl:NIL)
+(DEFMIC GET-LEXICAL-VALUE-CELL 375 (ENV-LIST SYMBOL-CELL-LOCATION) cl:T)
+(DEFMIC %CALL-MULT-VALUE 376 () cl:NIL cl:T)
+(DEFMIC %CALL0-MULT-VALUE 377 () cl:NIL cl:T)
+(DEFMIC %RETURN-2 400 () cl:NIL cl:T)
+(DEFMIC %RETURN-3 401 () cl:NIL cl:T)
+(DEFMIC %RETURN-N 402 () cl:NIL cl:T)
+(DEFMIC RETURN-NEXT-VALUE 403 (VALUE) cl:NIL)
+(DEFMIC RETURN-LIST 404 (VALUES) cl:NIL cl:T)
+(DEFMIC UNBIND-TO-INDEX-UNDER-N 405 (N) cl:NIL)
+(DEFMIC %BIND 406 (POINTER VALUE) cl:NIL)
+(DEFMIC (BIND . %BIND) 406 (POINTER VALUE) cl:NIL)
+;; 407 unused
+(DEFMIC MEMQ 410 (X LIST) cl:T)
+(DEFMIC (INTERNAL-< . M-<) 411 (NUM1 NUM2) cl:T)
+(DEFMIC (INTERNAL-> . M->) 412 (NUM1 NUM2) cl:T)
+(DEFMIC (INTERNAL-= . M-=) 413 (NUM1 NUM2) cl:T)
+(DEFMIC INTERNAL-CHAR-EQUAL 414 (CH1 CH2) cl:T)
+(DEFMIC %STRING-SEARCH-CHAR 415 (CHAR STRING START END) cl:T)
+(DEFMIC %STRING-EQUAL 416 (STRING1 INDEX1 STRING2 INDEX2 COUNT) cl:T)
+(DEFMIC NTH 417 (N LIST) cl:T)
+(DEFMIC NTHCDR 420 (N LIST) cl:T)
+(DEFMIC (*PLUS . M-+) 421 (NUM1 NUM2) cl:T)
+(DEFMIC (*DIF . M--) 422 (NUM1 NUM2) cl:T)
+(DEFMIC (*TIMES . M-*) 423 (NUM1 NUM2) cl:T)
+(DEFMIC (*QUO . M-//) 424 (NUM1 NUM2) cl:T)
+(DEFMIC (*LOGAND . M-LOGAND) 425 (NUM1 NUM2) cl:T)
+(DEFMIC (*LOGXOR . M-LOGXOR) 426 (NUM1 NUM2) cl:T)
+(DEFMIC (*LOGIOR . M-LOGIOR) 427 (NUM1 NUM2) cl:T)
+(DEFMIC ARRAY-LEADER 430 (ARRAY INDEX) cl:T)
+(DEFMIC STORE-ARRAY-LEADER 431 (VALUE ARRAY INDEX) cl:T)
+(DEFMIC GET-LIST-POINTER-INTO-ARRAY 432 (ARRAY) cl:T)
+(DEFMIC ARRAY-PUSH 433 (ARRAY VALUE) cl:T)
+(DEFMIC INTERNAL-APPLY 434 (FN ARGS) cl:NIL) ;was APPLY with NO-QINTCMP
+(DEFMIC %MAKE-LIST 435 (INITIAL-VALUE AREA LENGTH) cl:T)
+(DEFMIC LIST 436 (&REST ELEMENTS) cl:T cl:T)
+(DEFMIC LIST* 437 (FIRST &REST ELEMENTS) cl:T cl:T) ;(&REST ELEMENTS LAST)
+(DEFMIC LIST-IN-AREA 440 (AREA &REST ELEMENTS) cl:T cl:T)
+(DEFMIC LIST*-IN-AREA 441 (AREA FIRST &REST ELEMENTS) cl:T cl:T) ;(AREA &REST ELEMENTS LAST)
+(DEFMIC LOCATE-IN-INSTANCE 442 (INSTANCE SYMBOL) cl:T)
+(DEFMIC %P-CDR-CODE 443 (POINTER) cl:T)
+(DEFMIC %P-DATA-TYPE 444 (POINTER) cl:T)
+(DEFMIC %P-POINTER 445 (POINTER) cl:T)
+(DEFMIC %PAGE-TRACE 446 (TABLE) cl:T)
+(DEFMIC THROW-N 447 (TAG &REST VALUES-AND-COUNT) cl:NIL cl:T)
+(DEFMIC %P-STORE-CDR-CODE 450 (POINTER CDR-CODE) cl:T)
+(DEFMIC %P-STORE-DATA-TYPE 451 (POINTER DATA-TYPE) cl:T)
+(DEFMIC %P-STORE-POINTER 452 (POINTER POINTER-TO-STORE) cl:T)
+(DEFMIC FLOAT-EXPONENT 453 (FLONUM) cl:T)
+(DEFMIC FLOAT-FRACTION 454 (FLONUM) cl:T)
+(DEFMIC SCALE-FLOAT 455 (FLONUM INTEGER) cl:T)
+(DEFMIC %CATCH-OPEN 456 () cl:NIL cl:T)
+(DEFMIC %CATCH-OPEN-MV 457 () cl:NIL cl:T)
+(DEFMIC INTERNAL-FLOOR-1 460 (DIVIDEND DIVISOR) cl:NIL cl:T)
+;;; due to lossage, this INTERNAL-FLOOR-1 is pretty weird.
+;;; does not store in its destination. Instead, destination field decodes:
+;;; 0 => FLOOR, 1 => CEIL, 2 => TRUNC, 3 => ROUND
+
+(DEFMIC %DIV 461 (DIVIDEND DIVISOR) cl:T)
+(DEFMIC %FEXPR-CALL 462 () cl:NIL cl:T)
+(DEFMIC %FEXPR-CALL-MV 463 () cl:NIL cl:T)
+(DEFMIC %FEXPR-CALL-MV-LIST 464 () cl:NIL cl:T)
+(DEFMIC %CATCH-OPEN-MV-LIST 465 () cl:NIL cl:T)
+(DEFMIC *CATCH 466 (TAG &REST FORMS) cl:T cl:T)
+(DEFMIC (CATCH . *CATCH) 466 (TAG &REST FORMS) cl:T cl:T)
+(DEFMIC %BLT 467 (FROM-ADDRESS TO-ADDRESS COUNT INCREMENT) cl:T)
+(DEFMIC *THROW 470 (TAG VALUE) cl:NIL cl:T)
+(DEFMIC (THROW . *THROW) 470 (TAG VALUE) cl:NIL cl:T)
+(DEFMIC %XBUS-WRITE-SYNC 471 (IO-ADDR WORD DELAY SYNC-LOC SYNC-MASK SYNC-VAL) cl:T)
+(DEFMIC %P-LDB 472 (PPSS POINTER) cl:T)
+(DEFMIC %P-DPB 473 (VALUE PPSS POINTER) cl:T)
+(DEFMIC MASK-FIELD 474 (PPSS FIXNUM) cl:T)
+(DEFMIC %P-MASK-FIELD 475 (PPSS POINTER) cl:T)
+(DEFMIC DEPOSIT-FIELD 476 (VALUE PPSS FIXNUM) cl:T)
+(DEFMIC %P-DEPOSIT-FIELD 477 (VALUE PPSS POINTER) cl:T)
+(DEFMIC COPY-ARRAY-CONTENTS 500 (FROM TO) cl:T)
+(DEFMIC COPY-ARRAY-CONTENTS-AND-LEADER 501 (FROM TO) cl:T)
+(DEFMIC %FUNCTION-INSIDE-SELF 502 () cl:T)
+(DEFMIC ARRAY-HAS-LEADER-P 503 (ARRAY) cl:T)
+(DEFMIC COPY-ARRAY-PORTION 504 (FROM-ARRAY FROM-START FROM-END TO-ARRAY TO-START TO-END) cl:T)
+(DEFMIC FIND-POSITION-IN-LIST 505 (ELEMENT LIST) cl:T)
+(DEFMIC %GET-SELF-MAPPING-TABLE 506 (METHOD-FLAVOR-NAME) cl:T)
+(DEFMIC G-L-P 507 (ARRAY) cl:T)
+(DEFMIC INTERNAL-FLOOR-2 510 (DIVIDEND DIVISOR) cl:NIL cl:T)
+;;; takes two args on stack, two values also to stack.
+;;; destination of this one also weird. See INTERNAL-FLOOR-1.
+(DEFMIC EQL 511 (X Y) cl:T)
+(DEFMIC AR-1 512 (ARRAY SUB) cl:T)
+(DEFMIC AR-2 513 (ARRAY SUB1 SUB2) cl:T)
+(DEFMIC AR-3 514 (ARRAY SUB1 SUB2 SUB3) cl:T)
+(DEFMIC AS-1 515 (VALUE ARRAY SUB) cl:T)
+(DEFMIC AS-2 516 (VALUE ARRAY SUB1 SUB2) cl:T)
+(DEFMIC AS-3 517 (VALUE ARRAY SUB1 SUB2 SUB3) cl:T)
+(DEFMIC %INSTANCE-REF 520 (INSTANCE INDEX) cl:T)
+(DEFMIC %INSTANCE-LOC 521 (INSTANCE INDEX) cl:T)
+(DEFMIC %INSTANCE-SET 522 (VAL INSTANCE INDEX) cl:T)
+(DEFMIC %BINDING-INSTANCES 523 (LIST-OF-SYMBOLS) cl:T)
+(DEFMIC %EXTERNAL-VALUE-CELL 524 (SYMBOL) cl:T)
+(DEFMIC %USING-BINDING-INSTANCES 525 (BINDING-INSTANCES) cl:T)
+(DEFMIC %GC-CONS-WORK 526 (NQS) cl:T)
+(DEFMIC %P-CONTENTS-OFFSET 527 (POINTER OFFSET) cl:T)
+(DEFMIC %DISK-RESTORE 530 (PARTITION-HIGH-16-BITS LOW-16-BITS) cl:T)
+(DEFMIC %DISK-SAVE 531 (MAIN-MEMORY-SIZE PARTITION-HIGH-16-BITS LOW-16-BITS) cl:T)
+(DEFMIC %ARGS-INFO 532 (FUNCTION) cl:T)
+(DEFMIC %OPEN-CALL-BLOCK 533 (FUNCTION ADI-PAIRS DESTINATION) cl:NIL)
+(DEFMIC %PUSH 534 (X) cl:NIL)
+(DEFMIC %ACTIVATE-OPEN-CALL-BLOCK 535 () cl:NIL)
+(DEFMIC %ASSURE-PDL-ROOM 536 (ROOM) cl:NIL)
+(DEFMIC STACK-GROUP-RETURN 537 (X) cl:T)
+(DEFMIC AS-2-REVERSE 540 (VALUE ARRAY INDEX2 INDEX1) cl:T)
+;Perhaps the next one should be flushed.
+(DEFMIC %MAKE-STACK-LIST 541 (N) cl:NIL)
+(DEFMIC STACK-GROUP-RESUME 542 (SG X) cl:T)
+(DEFMIC %CALL-MULT-VALUE-LIST 543 () cl:NIL cl:T)
+(DEFMIC %CALL0-MULT-VALUE-LIST 544 () cl:NIL cl:T)
+(DEFMIC %GC-SCAV-RESET 545 (REGION) cl:T)
+(DEFMIC %P-STORE-CONTENTS-OFFSET 546 (VALUE POINTER OFFSET) cl:T)
+(DEFMIC %GC-FREE-REGION 547 (REGION) cl:T)
+(DEFMIC %GC-FLIP 550 (REGION) cl:T)
+(DEFMIC ARRAY-LENGTH 551 (ARRAY) cl:T)
+(DEFMIC ARRAY-TOTAL-SIZE 551 (ARRAY) cl:T)
+(DEFMIC ARRAY-ACTIVE-LENGTH 552 (ARRAY) cl:T)
+(DEFMIC %COMPUTE-PAGE-HASH 553 (ADDR) cl:T)
+(DEFMIC THROW-SPREAD 554 (TAG VALUE-LIST) cl:T)
+(DEFMIC %UNIBUS-READ 555 (UNIBUS-ADDR) cl:T)
+(DEFMIC %UNIBUS-WRITE 556 (UNIBUS-ADDR WORD) cl:T)
+(DEFMIC %GC-SCAVENGE 557 (WORK-UNITS) cl:T)
+(DEFMIC %CHAOS-WAKEUP 560 () cl:T)
+(DEFMIC %AREA-NUMBER 561 (X) cl:T)
+(DEFMIC *MAX 562 (NUM1 NUM2) cl:T)
+(DEFMIC *MIN 563 (NUM1 NUM2) cl:T)
+(DEFMIC CLOSURE 565 (SYMBOL-LIST FUNCTION) cl:T)
+(DEFMIC AR-2-REVERSE 566 (ARRAY INDEX2 INDEX1) cl:T)
+(DEFMIC LISTP 567 (X) cl:T)
+(DEFMIC NLISTP 570 (X) cl:T)
+(DEFMIC SYMBOLP 571 (X) cl:T)
+(DEFMIC NSYMBOLP 572 (X) cl:T)
+(DEFMIC ARRAYP 573 (X) cl:T)
+(DEFMIC FBOUNDP 574 (SYMBOL) cl:T)
+(DEFMIC STRINGP 575 (X) cl:T)
+(DEFMIC BOUNDP 576 (SYMBOL) cl:T)
+(DEFMIC INTERNAL-\\ 577 (NUM1 NUM2) cl:T)
+(DEFMIC FSYMEVAL 600 (SYMBOL) cl:T)
+(DEFMIC (SYMBOL-FUNCTION . FSYMEVAL) 600 (SYMBOL) cl:T)
+(DEFMIC AP-1 601 (ARRAY SUB) cl:T)
+(DEFMIC AP-2 602 (ARRAY SUB1 SUB2) cl:T)
+(DEFMIC AP-3 603 (ARRAY SUB1 SUB2 SUB3) cl:T)
+(DEFMIC AP-LEADER 604 (ARRAY INDEX) cl:T)
+(DEFMIC %P-LDB-OFFSET 605 (PPSS POINTER OFFSET) cl:T)
+(DEFMIC %P-DPB-OFFSET 606 (VALUE PPSS POINTER OFFSET) cl:T)
+(DEFMIC %P-MASK-FIELD-OFFSET 607 (PPSS POINTER OFFSET) cl:T)
+(DEFMIC %P-DEPOSIT-FIELD-OFFSET 610 (VALUE PPSS POINTER OFFSET) cl:T)
+(DEFMIC %MULTIPLY-FRACTIONS 611 (NUM1 NUM2) cl:T)
+(DEFMIC %DIVIDE-DOUBLE 612 (HIGH-DIVIDEND LOW-DIVIDEND DIVISOR) cl:T)
+(DEFMIC %REMAINDER-DOUBLE 613 (HIGH-DIVIDEND LOW-DIVIDEND DIVISOR) cl:T)
+(DEFMIC HAULONG 614 (INTEGER) cl:T)
+(DEFMIC %ALLOCATE-AND-INITIALIZE 615 (RETURN-DTP HEADER-DTP HEADER WORD2 AREA NQS) cl:T)
+(DEFMIC %ALLOCATE-AND-INITIALIZE-ARRAY 616 (HEADER INDEX-LENGTH LEADER-LENGTH AREA NQS) cl:T)
+(DEFMIC %MAKE-POINTER-OFFSET 617 (NEW-DTP POINTER OFFSET) cl:T)
+(DEFMIC ^ 620 (NUM EXPT) cl:T)
+(DEFMIC %CHANGE-PAGE-STATUS 621 (VIRT-ADDR SWAP-STATUS ACCESS-AND-META) cl:T)
+(DEFMIC %CREATE-PHYSICAL-PAGE 622 (PHYS-ADDR) cl:T)
+(DEFMIC %DELETE-PHYSICAL-PAGE 623 (PHYS-ADDR) cl:T)
+(DEFMIC %24-BIT-PLUS 624 (NUM1 NUM2) cl:T)
+(DEFMIC %24-BIT-DIFFERENCE 625 (NUM1 NUM2) cl:T)
+(DEFMIC %24-BIT-TIMES 626 (NUM1 NUM2) cl:T)
+(DEFMIC ABS 627 (NUM) cl:T)
+(DEFMIC %POINTER-DIFFERENCE 630 (PTR1 PTR2) cl:T)
+(DEFMIC %P-CONTENTS-AS-LOCATIVE 631 (POINTER) cl:T)
+(DEFMIC %P-CONTENTS-AS-LOCATIVE-OFFSET 632 (POINTER OFFSET) cl:T)
+(DEFMIC (EQ . M-EQ) 633 (X Y) cl:T)
+(DEFMIC %STORE-CONDITIONAL 634 (POINTER OLD NEW) cl:T)
+(DEFMIC %STACK-FRAME-POINTER 635 () cl:T)
+(DEFMIC *UNWIND-STACK 636 (TAG VALUE FRAME-COUNT ACTION) cl:T)
+(DEFMIC %XBUS-READ 637 (IO-ADDR) cl:T)
+(DEFMIC %XBUS-WRITE 640 (IO-ADDR WORD) cl:T)
+(DEFMIC ELT 641 (SEQUENCE INDEX) cl:T)
+(DEFMIC MOVE-PDL-TOP 642 cl:NIL cl:NIL cl:T)
+(DEFMIC SHRINK-PDL-SAVE-TOP 643 (VALUE-TO-MOVE N-SLOTS) cl:NIL cl:T)
+(DEFMIC SPECIAL-PDL-INDEX 644 cl:NIL cl:T)
+(DEFMIC UNBIND-TO-INDEX 645 (SPECIAL-PDL-INDEX) cl:NIL cl:T)
+(DEFMIC UNBIND-TO-INDEX-MOVE 646 (SPECIAL-PDL-INDEX VALUE-TO-MOVE) cl:NIL cl:T)
+(DEFMIC FIX 647 (NUMBER) cl:T)
+;; Changed in 95 to exist only for old code. -- now use INTERNAL-FLOAT
+(DEFMIC FLOAT 650 (NUMBER OTHER) cl:NIL cl:T)
+(DEFMIC SMALL-FLOAT 651 (NUMBER) cl:T)
+(DEFMIC %FLOAT-DOUBLE 652 (LOW HIGH) cl:T)
+(DEFMIC BIGNUM-TO-ARRAY 653 (BIGNUM BASE) cl:T)
+(DEFMIC ARRAY-TO-BIGNUM 654 (ARRAY BASE SIGN) cl:T)
+(DEFMIC %UNWIND-PROTECT-CONTINUE 655 (VALUE TAG COUNT ACTION) cl:NIL cl:T)
+(DEFMIC %WRITE-INTERNAL-PROCESSOR-MEMORIES 656 (CODE ADR D-HI D-LOW) cl:T)
+(DEFMIC %PAGE-STATUS 657 (PTR) cl:T)
+(DEFMIC %REGION-NUMBER 660 (PTR) cl:T)
+(DEFMIC %FIND-STRUCTURE-HEADER 661 (PTR) cl:T)
+(DEFMIC %STRUCTURE-BOXED-SIZE 662 (PTR) cl:T)
+(DEFMIC %STRUCTURE-TOTAL-SIZE 663 (PTR) cl:T)
+(DEFMIC %MAKE-REGION 664 (BITS SIZE) cl:T)
+(DEFMIC BITBLT 665 (ALU WIDTH HEIGHT FROM-ARRAY FROM-X FROM-Y TO-ARRAY TO-X TO-Y) cl:T)
+(DEFMIC %DISK-OP 666 (RQB) cl:T)
+(DEFMIC %PHYSICAL-ADDRESS 667 (PTR) cl:T)
+(DEFMIC POP-OPEN-CALL 670 cl:NIL cl:NIL cl:T)
+(DEFMIC %BEEP 671 (HALF-WAVELENGTH DURATION) cl:T)
+(DEFMIC %FIND-STRUCTURE-LEADER 672 (PTR) cl:T)
+(DEFMIC BPT 673 cl:NIL cl:T)
+(DEFMIC %FINDCORE 674 () cl:T)
+(DEFMIC %PAGE-IN 675 (PFN VPN) cl:T)
+(DEFMIC ASH 676 (N NBITS) cl:T)
+(DEFMIC %MAKE-EXPLICIT-STACK-LIST 677 (LENGTH) cl:NIL cl:T)
+(DEFMIC %DRAW-CHAR 700 (FONT-ARRAY CHAR-CODE X-BITPOS Y-BITPOS ALU-FUNCTION SHEET) cl:T)
+(DEFMIC %DRAW-RECTANGLE 701 (WIDTH HEIGHT X-BITPOS Y-BITPOS ALU-FUNCTION SHEET) cl:T)
+(DEFMIC %DRAW-LINE 702 (X0 Y0 X Y ALU DRAW-END-POINT SHEET) cl:T)
+(DEFMIC %DRAW-TRIANGLE 703 (X1 Y1 X2 Y2 X3 Y3 ALU SHEET) cl:T)
+(DEFMIC %COLOR-TRANSFORM 704 (N17 N16 N15 N14 N13 N12 N11 N10 N7 N6 N5 N4 N3 N2 N1 N0
+ WIDTH HEIGHT ARRAY START-X START-Y) cl:T)
+(DEFMIC %RECORD-EVENT 705 (DATA-4 DATA-3 DATA-2 DATA-1 STACK-LEVEL EVENT MUST-BE-4) cl:T)
+(DEFMIC %AOS-TRIANGLE 706 (X1 Y1 X2 Y2 X3 Y3 INCREMENT SHEET) cl:T)
+(DEFMIC %SET-MOUSE-SCREEN 707 (SHEET) cl:T)
+(DEFMIC %OPEN-MOUSE-CURSOR 710 () cl:T)
+(DEFMIC SETELT 711 (SEQUENCE INDEX VALUE) cl:T)
+(DEFMIC %BLT-TYPED 712 (FROM-ADDRESS TO-ADDRESS COUNT INCREMENT) cl:T)
+;(DEFMIC %ETHER-WAKEUP 711 (RESET-P) cl:T)
+;(DEFMIC %CHECKSUM-PUP 712 (ART-16B-PUP START LENGTH) cl:T)
+;(DEFMIC %DECODE-PUP 713 (ART-BYTE-PUP START LENGTH STATE SUPER-IMAGE-P) cl:T)
+(DEFMIC AR-1-FORCE 714 (ARRAY INDEX) cl:T)
+(DEFMIC AS-1-FORCE 715 (VALUE ARRAY INDEX) cl:T)
+(DEFMIC AP-1-FORCE 716 (ARRAY INDEX) cl:T)
+(DEFMIC AREF 717 (ARRAY &REST SUBSCRIPTS) cl:T cl:T)
+(DEFMIC ASET 720 (VALUE ARRAY &REST SUBSCRIPTS) cl:T cl:T)
+(DEFMIC ALOC 721 (ARRAY &REST SUBSCRIPTS) cl:T cl:T)
+
+(DEFMIC EQUALP 722 (X Y) cl:T)
+(DEFMIC %MAKE-EXPLICIT-STACK-LIST* 723 (LENGTH) cl:NIL cl:T)
+(DEFMIC SETCAR 724 (CONS NEWCAR) cl:T)
+(DEFMIC SETCDR 725 (CONS NEWCDR) cl:T)
+(DEFMIC GET-LOCATION-OR-NIL 726 (SYMBOL PROPERTY) cl:T)
+(DEFMIC %STRING-WIDTH 727 (TABLE OFFSET STRING START END STOP-WIDTH) cl:NIL)
+(DEFMIC AR-1-CACHED-1 730 (ARRAY SUBSCRIPT) cl:T)
+(DEFMIC AR-1-CACHED-2 731 (ARRAY SUBSCRIPT) cl:T)
+
+(DEFMIC %MULTIBUS-READ-16 732 (MULTIBUS-BYTE-ADR) cl:T)
+(DEFMIC %MULTIBUS-WRITE-16 733 (MULTIBUS-BYTE-ADR WORD) cl:T)
+(DEFMIC %MULTIBUS-READ-8 734 (MULTIBUS-BYTE-ADR) cl:T)
+(DEFMIC %MULTIBUS-WRITE-8 735 (MULTIBUS-BYTE-ADR WORD) cl:T)
+(DEFMIC %MULTIBUS-READ-32 736 (MULTIBUS-BYTE-ADR) cl:T)
+(DEFMIC %MULTIBUS-WRITE-32 737 (MULTIBUS-BYTE-ADR WORD) cl:T)
+
+(DEFMIC SET-AR-1 740 (ARRAY SUBSCRIPT VALUE) cl:T)
+(DEFMIC SET-AR-2 741 (ARRAY SUBSCRIPT1 SUBSCRIPT2 VALUE) cl:T)
+(DEFMIC SET-AR-3 742 (ARRAY SUBSCRIPT1 SUBSCRIPT2 SUBSCRIPT3 VALUE) cl:T)
+(DEFMIC SET-AR-1-FORCE 743 (ARRAY SUBSCRIPT VALUE) cl:T)
+(DEFMIC SET-AREF 744 (ARRAY &REST SUBSCRIPTS-AND-VALUE) cl:T cl:T)
+(DEFMIC SET-ARRAY-LEADER 745 (ARRAY INDEX VALUE) cl:T)
+(DEFMIC SET-%INSTANCE-REF 746 (INSTANCE INDEX VALUE) cl:T)
+(DEFMIC VECTOR-PUSH 747 (NEW-ELEMENT VECTOR) cl:T)
+(DEFMIC ARRAY-HAS-FILL-POINTER-P 750 (ARRAY) cl:T)
+(DEFMIC ARRAY-LEADER-LENGTH 751 (ARRAY) cl:T)
+(DEFMIC ARRAY-RANK 752 (ARRAY) cl:T)
+(DEFMIC ARRAY-DIMENSION 753 (ARRAY DIMENSION) cl:T)
+(DEFMIC ARRAY-IN-BOUNDS-P 754 (ARRAY &REST SUBSCRIPTS) cl:T cl:T)
+(DEFMIC ARRAY-ROW-MAJOR-INDEX 755 (ARRAY &REST SUBSCRIPTS) cl:T cl:T)
+
+(DEFMIC RETURN-N-KEEP-CONTROL 756 (&REST VALUES N) cl:NIL cl:T)
+(DEFMIC RETURN-SPREAD-KEEP-CONTROL 757 (VALUE-LIST) cl:NIL cl:T)
+(DEFMIC COMMON-LISP-LISTP 760 (OBJECT) cl:T)
+
+(DEFMIC %NUBUS-READ 761 (NUBUS-SLOT SLOT-BYTE-ADR) cl:T)
+ ;SLOT is really the high 8 bits.
+ ;the "top F" can be supplied via slot, avoiding bignums.
+(DEFMIC %NUBUS-WRITE 762 (NUBUS-SLOT SLOT-BYTE-ADR WORD) cl:T)
+(DEFMIC %MICROSECOND-TIME 763 () cl:T) ; Returns 32 bits maybe as a bignum
+(DEFMIC %FIXNUM-MICROSECOND-TIME 764 () cl:T)
+(DEFMIC %IO-SPACE-READ 765 (IO-ADDR) cl:T)
+ ;32 bit read from HARDWARE-VIRTUAL-ADDRESS space.
+ ;actual ucode is identical to that for %XBUS-READ on CADR.
+(DEFMIC %IO-SPACE-WRITE 766 (IO-ADDR WORD) cl:T) ;actual microcode is identical to %XBUS-WRITE
+ ;on CADR.
+(DEFMIC %NUBUS-PHYSICAL-ADDRESS 767 (APPARENT-PHYSICAL-PAGE) cl:T)
+ ;arg is "apparent" physical page number (gotten, for example,
+ ;by shifting value from %PHYSICAL-ADDRESS).
+ ;value is 22 bit NUBUS page number.
+
+(DEFMIC VECTORP 770 (OBJECT) cl:T)
+(DEFMIC SIMPLE-VECTOR-P 771 (OBJECT) cl:T)
+(DEFMIC SIMPLE-ARRAY-P 772 (OBJECT) cl:T)
+(DEFMIC SIMPLE-STRING-P 773 (OBJECT) cl:T)
+(DEFMIC BIT-VECTOR-P 774 (OBJECT) cl:T)
+(DEFMIC SIMPLE-BIT-VECTOR-P 775 (OBJECT) cl:T)
+(DEFMIC NAMED-STRUCTURE-P 776 (OBJECT) cl:T)
+(DEFMIC NAMED-STRUCTURE-SYMBOL 776 (OBJECT) cl:T)
+(DEFMIC TYPEP-STRUCTURE-OR-FLAVOR 777 (OBJECT TYPE) cl:T)
+(DEFMIC FIXNUMP 1000 (OBJECT) cl:T)
+(DEFMIC SMALL-FLOATP 1001 (OBJECT) cl:T)
+(DEFMIC CHARACTERP 1002 (OBJECT) cl:T)
+
+(DEFMIC CAR-SAFE 1003 (OBJECT) cl:T)
+(DEFMIC CDR-SAFE 1004 (OBJECT) cl:T)
+(DEFMIC CADR-SAFE 1005 (OBJECT) cl:T)
+(DEFMIC CDDR-SAFE 1006 (OBJECT) cl:T)
+(DEFMIC CDDDDR-SAFE 1007 (OBJECT) cl:T)
+(DEFMIC NTHCDR-SAFE 1010 (N OBJECT) cl:T)
+(DEFMIC NTH-SAFE 1011 (N OBJECT) cl:T)
+(DEFMIC CARCDR 1012 (LIST) cl:NIL)
+(DEFMIC ENDP 1013 (X) cl:T)
+(DEFMIC CONSP-OR-POP 1014 (OBJECT) cl:NIL)
+(DEFMIC INDICATORS-VALUE 1015 (OBJECT) cl:NIL cl:T)
+(DEFMIC %POINTER-TIMES 1016 (POINTER1 POINTER2) cl:T)
+(DEFMIC COMMON-LISP-AREF 1017 (ARRAY &REST INDICES) cl:T cl:T)
+(DEFMIC COMMON-LISP-AR-1 1020 (ARRAY INDEX) cl:T)
+(DEFMIC COMMON-LISP-AR-1-FORCE 1021 (ARRAY INDEX) cl:T)
+(DEFMIC INTERNAL-GET-3 1022 (SYMBOL PROPERTY DEFAULT) cl:NIL cl:T)
+
+(DEFMIC CHAR-INT 1023 (CHAR) cl:T)
+(DEFMIC INT-CHAR 1024 (INTEGER) cl:T)
+(DEFMIC ALPHA-CHAR-P 1025 (CHAR) cl:T)
+(DEFMIC UPPER-CASE-P 1026 (CHAR) cl:T)
+(DEFMIC ALPHANUMERICP 1027 (CHAR) cl:T)
+(DEFMIC PACKAGE-CELL-LOCATION 1030 (SYMBOL) cl:T)
+(DEFMIC MEMBER-EQL 1031 (ELT LIST) cl:T)
+(DEFMIC RATIONALP 1032 (OBJECT) cl:T)
+(DEFMIC RATIOP 1033 (OBJECT) cl:T)
+(DEFMIC COMPLEXP 1034 (OBJECT) cl:T)
+(DEFMIC %RATIO-CONS 1035 (NUMERATOR DENOMINATOR) cl:T)
+(DEFMIC %COMPLEX-CONS 1036 (REALPART IMAGPART) cl:T)
+(DEFMIC BOTH-CASE-P 1037 (CHAR) cl:T)
+(DEFMIC CHAR-UPCASE 1040 (CHAR) cl:T)
+(DEFMIC CHAR-DOWNCASE 1041 (CHAR) cl:T)
+(DEFMIC LOWER-CASE-P 1042 (CHAR) cl:T)
+
+(defmic %micro-paging 1100 (arg) cl:t)
+(DEFMIC %PROCESSOR-SWITCHES 1101 (ARG) cl:T)
+(DEFMIC %COLD-BOOT 1102 () cl:T)
+
+(defmic %test-multiply-return-low 1103 (n1 n2) cl:t) ;these changed from sys 94 defs.
+(defmic %test-multiply-return-high 1104 (n1 n2) cl:t)
+(defmic %mult-16 1105 (n1 n2) cl:t)
+(defmic %mult-32 1106 (n1 n2) cl:t)
+
+(defmic %quart-transfer 1107 (quart-flags array n-blocks) cl:t)
+;;; quart-flags bit0 0-> read, 1-> write. value is number blocks transferred
+(defmic %nubus-read-8 1110 (nubus-slot slot-byte-adr) cl:t)
+;;; SLOT is really the high 8 bits. The "top F" can be supplied via slot, avoiding bignums.
+(defmic %nubus-write-8 1111 (nubus-slot slot-byte-adr word) cl:t)
+
+(defmic %lambda-rg-quad-slot 1112 () cl:t)
+(defmic %lambda-tv-quad-slot 1113 () cl:t)
+(defmic %lambda-mouse-buttons 1114 () cl:t)
+;;; CADR can read mouse buttons directly with %unibus-read.
+;;; In LAMBDA, they live in A-mem so we need this.
+(defmic %sys-conf-physical-page 1115 () cl:t)
+(defmic %lambda-sdu-quad-slot 1116 () cl:t)
+
+;;; FROM HERE TO 1777 FREE
+
+;;;; Instructions and other symbols for LAP
+
+(DEFPROP CALL 0 QLVAL)
+
+(DEFPROP CALL0 1000 QLVAL)
+
+(DEFPROP MOVE 2000 QLVAL)
+
+(DEFPROP CAR 3000 QLVAL)
+
+(DEFPROP CDR 4000 QLVAL)
+
+(DEFPROP CADR 5000 QLVAL)
+
+(DEFPROP CDDR 6000 QLVAL)
+
+(DEFPROP CDAR 7000 QLVAL)
+
+(DEFPROP CAAR 10000 QLVAL)
+
+;ND1
+;(DEFPROP UNUSED 11000 QLVAL) ;Not used
+(DEFPROP *PLUS 31000 QLVAL) ;These used to be called +, -, etc,
+(DEFPROP *DIF 51000 QLVAL) ; but those are now n-arg, while these seven
+(DEFPROP *TIMES 71000 QLVAL) ; are two-arguments-only (instructions).
+(DEFPROP *QUO 111000 QLVAL)
+(DEFPROP *LOGAND 131000 QLVAL)
+(DEFPROP *LOGXOR 151000 QLVAL)
+(DEFPROP *LOGIOR 171000 QLVAL)
+
+;ND2
+(DEFPROP INTERNAL-= 12000 QLVAL)
+(DEFPROP INTERNAL-> 32000 QLVAL)
+(DEFPROP INTERNAL-< 52000 QLVAL)
+(DEFPROP EQ 72000 QLVAL)
+;;; SETE CDR 112000
+;;; SETE CDDR 132000
+;;; SETE 1+ 152000
+;;; SETE 1- 172000
+
+;ND3
+;;; 13000 unused, used to be BIND.
+(DEFPROP BINDNIL 33000 QLVAL)
+(DEFPROP BINDPOP 53000 QLVAL)
+(DEFPROP SETNIL 73000 QLVAL)
+(DEFPROP SETZERO 113000 QLVAL)
+(DEFPROP PUSH-E 133000 QLVAL)
+(DEFPROP MOVEM 153000 QLVAL)
+(DEFPROP POP 173000 QLVAL)
+
+;BRANCH is 14
+
+;MISC
+(DEFPROP MISC 15000 QLVAL)
+(DEFPROP MISC1 34000 QLVAL) ;MISC code 1000 turns into insn 35000,
+ ; by adding 34000
+
+;; ND4
+(DEFPROP STACK-CLOSURE-DISCONNECT 16000 QLVAL)
+(DEFPROP STACK-CLOSURE-UNSHARE 36000 QLVAL)
+(DEFPROP MAKE-STACK-CLOSURE 56000 QLVAL)
+(DEFPROP PUSH-NUMBER 76000 QLVAL)
+(DEFPROP STACK-CLOSURE-DISCONNECT-FIRST 116000 QLVAL)
+(DEFPROP PUSH-CDR-IF-CAR-EQUAL 136000 QLVAL)
+(DEFPROP PUSH-CDR-STORE-CAR-IF-CONS 156000 QLVAL)
+
+;; AREFI
+(DEFPROP AREFI 20000 QLVAL)
+(DEFPROP AREFI-LEADER 20100 QLVAL)
+(DEFPROP AREFI-INSTANCE 20200 QLVAL)
+(DEFPROP AREFI-COMMON-LISP 20300 QLVAL)
+(DEFPROP AREFI-SET 20400 QLVAL)
+(DEFPROP AREFI-SET-LEADER 20500 QLVAL)
+(DEFPROP AREFI-SET-INSTANCE 20600 QLVAL)
+;; One unused code
+
+
+;;; - MISCELLANEOUS FUNCTIONS -
+(DEFPROP ASETI 100 QLVAL)
+(DEFPROP ASETI-LEADER 120 QLVAL)
+(DEFPROP ASETI-INSTANCE 140 QLVAL)
+
+(DEFPROP UNBIND 200 QLVAL)
+ (DEFMIC UNBIND-0 200 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-1 201 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-2 202 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-3 203 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-4 204 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-5 205 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-6 206 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-7 207 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-10 210 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-11 211 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-12 212 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-13 213 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-14 214 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-15 215 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-16 216 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC UNBIND-17 217 cl:NIL cl:NIL cl:T) ;FOR UCONS
+(DEFPROP POPPDL 220 QLVAL)
+ (DEFMIC POPPDL-0 220 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-1 221 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-2 222 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-3 223 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-4 224 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-5 225 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-6 226 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-7 227 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-10 230 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-11 231 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-12 232 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-13 233 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-14 234 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-15 235 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-16 236 cl:NIL cl:NIL cl:T) ;FOR UCONS
+ (DEFMIC POPPDL-17 237 cl:NIL cl:NIL cl:T) ;FOR UCONS
+;The rest of these come from the DEFMIC table above.
+
+;;;Source address types
+
+(DEFPROP FEF 0 QLVAL)
+
+(DEFPROP CONST-PAGE 400 QLVAL)
+
+(DEFPROP LOCBLOCK 500 QLVAL)
+
+(DEFPROP ARG 600 QLVAL)
+
+;OBSOLETE NAME
+(DEFPROP LPDL 700 QLVAL)
+
+;Following word holds the actual source address
+(DEFPROP EXTEND 776 QLVAL)
+
+(DEFPROP PDL-POP 777 QLVAL)
+
+;DESTINATIONS
+(cl:defvar %%MACRO-DEST-FIELD 1602)
+
+(DEFPROP D-IGNORE 0 QLVAL)
+
+(DEFPROP D-INDS 0 QLVAL)
+
+(DEFPROP D-PDL 40000 QLVAL)
+(DEFPROP D-NEXT 40000 QLVAL)
+
+(DEFPROP D-RETURN 100000 QLVAL)
+
+(DEFPROP D-LAST 140000 QLVAL)
+
+;Old values from when the dest field was 3 bits long.
+;(DEFPROP D-PDL 20000 QLVAL)
+;(DEFPROP D-NEXT 20000 QLVAL)
+
+;(DEFPROP D-PDL-NEW 40000 QLVAL)
+
+;(DEFPROP D-LAST 60000 QLVAL)
+
+;(DEFPROP D-RETURN 100000 QLVAL)
+
+;(DEFPROP D-LAST-NEW 140000 QLVAL)
+
+
+;(DEFPROP DEST-ARG-QTD 60000 QLVAL) ;ADDED TO D-NEXT,D-LAST
+
+;(DEFPROP D-NEXT-LIST 160000 QLVAL)
+
+;;; Properties for the micro-compiler
+
+(DEFPROP M-CAR QMA LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-CDR QMD LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-CAAR QMAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-CADR QMAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-CDAR QMDA LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-CDDR QMDD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAAAR QMAAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAADR QMAAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADAR QMADA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADDR QMADD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDAAR QMDAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDADR QMDAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDAR QMDDA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDDR QMDDD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAAAAR QMAAAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAAADR QMAAAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAADAR QMAADA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CAADDR QMAADD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADAAR QMADAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADADR QMADAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADDAR QMADDA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CADDDR QMADDD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDAAAR QMDAAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDAADR QMDAAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDADAR QMDADA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDADDR QMDADD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDAAR QMDDAA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDADR QMDDAD LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDDAR QMDDDA LAST-ARG-IN-T-ENTRY)
+(DEFPROP CDDDDR QMDDDD LAST-ARG-IN-T-ENTRY)
+
+(DEFPROP M-+ XTCADD LAST-ARG-IN-T-ENTRY) ;CHECKS INPUT D.T. TO ASSURE FIXED
+(DEFPROP M-- XTCSUB LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-* XTCMUL LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-// XTCDIV LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-LOGAND XTCAND LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-LOGXOR XTCXOR LAST-ARG-IN-T-ENTRY)
+(DEFPROP M-LOGIOR XTCIOR LAST-ARG-IN-T-ENTRY)
+
+;(DEFPROP XTCADD XTADD NO-TYPE-CHECKING-ENTRY) ;ONE ARG IN T, ONE ON PDL
+;(DEFPROP XTCSUB XTSUB NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP XTCMUL XTMUL NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP XTCDIV XTDIV NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP XTCAND XTAND NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP XTCXOR XTXOR NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP XTCIOR XTIOR NO-TYPE-CHECKING-ENTRY)
+
+;(DEFPROP M-+ XTADD UNBOXED-NUM-IN-T-ENTRY) ;THESE GUYS DONT REALLY CHECK ANYWAY
+;(DEFPROP M-- XTSUB UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP M-* XTMUL UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP M-// XTDIV UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP M-LOGAND XTAND UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP M-LOGXOR XTXOR UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP M-LOGIOR XTIOR UNBOXED-NUM-IN-T-ENTRY)
+
+;(DEFPROP M-+ XMADD NO-TYPE-CHECKING-ENTRY) ;THESE ARE A BIT FASTER
+;(DEFPROP M-- XMSUB NO-TYPE-CHECKING-ENTRY) ;TAKE 2 ARGS ON PDL
+;(DEFPROP M-* XMMUL NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP M-// XMDIV NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP M-LOGAND XMAND NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP M-LOGXOR XMXOR NO-TYPE-CHECKING-ENTRY)
+;(DEFPROP M-LOGIOR XMIOR NO-TYPE-CHECKING-ENTRY)
+
+;(DEFPROP ATOM XTATOM LAST-ARG-IN-T-ENTRY)
+;(DEFPROP ZEROP XTZERO LAST-ARG-IN-T-ENTRY)
+(DEFPROP NUMBERP XTNUMB LAST-ARG-IN-T-ENTRY)
+(DEFPROP FIXP XTFIXP LAST-ARG-IN-T-ENTRY)
+(DEFPROP FLOATP XTFLTP LAST-ARG-IN-T-ENTRY)
+;(DEFPROP PLUSP XTPLUP LAST-ARG-IN-T-ENTRY)
+;(DEFPROP MINUSP XTMNSP LAST-ARG-IN-T-ENTRY)
+;(DEFPROP MINUS XTMNS LAST-ARG-IN-T-ENTRY)
+;(DEFPROP 1+ XT1PLS LAST-ARG-IN-T-ENTRY)
+;(DEFPROP 1- XT1MNS LAST-ARG-IN-T-ENTRY)
+;(DEFPROP SYMEVAL XTSYME LAST-ARG-IN-T-ENTRY)
+(DEFPROP LENGTH XTLENG LAST-ARG-IN-T-ENTRY)
+
+;(DEFPROP ZEROP XBZERO UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP PLUSP XBPLUP UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP MINUSP XBMNSP UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP MINUS XBMNS UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP 1+ XB1PLS UNBOXED-NUM-IN-T-ENTRY)
+;(DEFPROP 1- XB1MNS UNBOXED-NUM-IN-T-ENTRY)
+
+;;; Certain MISC-instructions make assumptions about what destinations
+;;; they are used with. Some require D-IGNORE, because they assume that
+;;; there is no return address on the micro-stack. Some do not allow D-IGNORE,
+;;; because they popj and start a memory cycle. Some are really random.
+(cl:DEFVAR MISC-INSTRUCTION-REQUIRED-DESTINATION-ALIST
+ '((%ALLOCATE-AND-INITIALIZE D-PDL D-NEXT D-LAST D-RETURN)
+ (%ALLOCATE-AND-INITIALIZE-ARRAY D-PDL D-NEXT D-LAST D-RETURN)
+ (%SPREAD D-NEXT D-LAST)
+ (RETURN-LIST D-RETURN)
+ (%OPEN-CALL-BLOCK D-IGNORE D-INDS)
+ (%ACTIVATE-OPEN-CALL-BLOCK D-IGNORE D-INDS)
+ (%RETURN-2 D-IGNORE D-INDS)
+ (%RETURN-3 D-IGNORE D-INDS)
+ (%RETURN-N D-IGNORE D-INDS)
+ (%RETURN-NEXT-VALUE D-IGNORE D-INDS)))
Added: trunk/tools/cold/global.lisp
==============================================================================
Binary file. No diff available.
Added: trunk/tools/cold/qcom.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/qcom.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,1187 @@
+;-*-MODE:LISP; BASE:8; PACKAGE:SYSTEM-INTERNALS -*-
+
+; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+;LOADING THIS WITH A BASE OF OTHER THAN 8 CAN REALLY CAUSE BIZARRE EFFECTS
+;(OR (= IBASE 8) (BREAK IBASE-NOT-8))
+
+(cl:defvar AREA-LIST '(
+ RESIDENT-SYMBOL-AREA ;T AND NIL
+ SYSTEM-COMMUNICATION-AREA ;USED BY PAGING, CONSOLE, PDP10 I/O, ETC.
+ SCRATCH-PAD-INIT-AREA ;LOAD MICRO CODE VARIABLES UPON STARTUP
+ MICRO-CODE-SYMBOL-AREA ;600 QS MISC DISPATCH, UCODE ENTRY DISPATCH
+ PAGE-TABLE-AREA ;PAGE HASH TABLE
+ PHYSICAL-PAGE-DATA ;GC DATA,,PHT INDEX
+ ;-1 IF OUT OF SERVICE
+ ;PHT-INDEX=-1 IF FIXED-WIRED (NO PHT ENTRY)
+ ;GC-DATA=0 IF NOT IN USE
+ REGION-ORIGIN ;FIXNUM BASE ADDRESS INDEXED BY REGION #
+ REGION-LENGTH ;FIXNUM LENGTH INDEXED BY REGION #
+ REGION-BITS ;FIXNUM, SEE %%REGION- SYMS FOR FIELDS
+ ADDRESS-SPACE-MAP ;SEE %ADDRESS-SPACE-MAP-BYTE-SIZE BELOW
+ ;END WIRED AREAS
+ REGION-FREE-POINTER ;FIXNUM, RELATIVE ALLOCATION POINT.
+ REGION-GC-POINTER ;GC USE, MAINLY RELATIVE DIRTY/CLEAN BOUNDARY
+ REGION-LIST-THREAD ;NEXT REGION# IN AREA, OR 1_23.+AREA#
+ ; THREADS FREE REGION SLOTS, TOO.
+ AREA-NAME ;ATOMIC NAME INDEXED BY AREA #
+ AREA-REGION-LIST ;FIRST REGION# IN AREA
+ AREA-REGION-SIZE ;RECOMMENDED SIZE FOR NEW REGIONS
+ AREA-MAXIMUM-SIZE ;APPROXIMATE MAXIMUM #WDS ALLOWED IN THIS AREA
+ AREA-SWAP-RECOMMENDATIONS ;FIXNUM, SEE %%AREA-SWAP- SYMS FOR FIELDS
+ GC-TABLE-AREA ;GARBAGE COLLECTOR TABLES
+ SUPPORT-ENTRY-VECTOR ;CONSTANTS NEEDED BY BASIC MICROCODE
+ CONSTANTS-AREA ;COMMON CONSTANTS USED BY MACROCODE
+ EXTRA-PDL-AREA ;SEPARATELY GC-ABLE AREA, MAINLY EXTENDED NUMS
+ ; MUST BE RIGHT BEFORE MICRO-CODE-ENTRY-AREA
+ MICRO-CODE-ENTRY-AREA ;MICRO ENTRY ADDRESS
+ ;OR LOCATIVE INDIRECT MICRO-CODE-SYMBOL-AREA
+ MICRO-CODE-ENTRY-NAME-AREA ;MICRO ENTRY NAME
+ MICRO-CODE-ENTRY-ARGS-INFO-AREA ;MICRO ENTRY %ARGS-INFO
+ MICRO-CODE-ENTRY-MAX-PDL-USAGE ;MICRO ENTRY PDL DEPTH INCL MICRO-MICRO CALLS
+ ;AREAS AFTER HERE ARE NOT "INITIAL", NOT KNOWN SPECIALLY BY MICROCODE
+ MICRO-CODE-ENTRY-ARGLIST-AREA ;VALUE FOR ARGLIST FUNCTION TO RETURN
+ MICRO-CODE-SYMBOL-NAME-AREA ;NAMES OF MICRO-CODE-SYMBOL-AREA ENTRIES
+ LINEAR-PDL-AREA ;MAIN PDL
+ LINEAR-BIND-PDL-AREA ;CORRESPONDING BIND PDL
+ INIT-LIST-AREA ;LIST CONSTANTS CREATED BY COLD LOAD
+ ;END FIXED AREAS, WHICH MUST HAVE ONLY ONE REGION
+ WORKING-STORAGE-AREA ;ORDINARY CONSING HAPPENS HERE
+ PERMANENT-STORAGE-AREA ;PUT "PERMANENT" DATA STRUCTURES HERE
+ PROPERTY-LIST-AREA ;EXISTS FOR PAGING REASONS
+ P-N-STRING ;PRINT NAMES AND STRINGS
+ CONTROL-TABLES ;OBARRAY, READTABLE (SEMI-OBSOLETE)
+ OBT-TAILS ;OBARRAY BUCKET CONSES (SEMI-OBSOLETE)
+ NR-SYM ;SYMBOLS NOT IN RESIDENT-SYMBOL-AREA
+ MACRO-COMPILED-PROGRAM ;MACRO CODE LOADED HERE
+ PDL-AREA ;PUT STACK-GROUP REGULAR-PDLS HERE
+ FASL-TABLE-AREA ;FASLOAD'S TABLE IS HERE
+ FASL-TEMP-AREA ;FASLOAD TEMPORARY CONSING
+ FASL-CONSTANTS-AREA ;FASLOAD LOADS CONSTANTS HERE
+ ))
+
+;Assuming no more than 256 regions
+(cl:defvar %ADDRESS-SPACE-MAP-BYTE-SIZE 10)
+(cl:defvar %ADDRESS-SPACE-QUANTUM-SIZE 40000)
+;Each quantum has a byte in the ADDRESS-SPACE-MAP area,
+;which is the region number, or 0 if free or fixed area.
+;INIT-LIST-AREA is the last fixed area.
+
+ ;THESE AREAS ARE ENCACHED IN THE PDL BUFFER.
+(cl:defvar PDL-BUFFER-AREA-LIST '(
+ LINEAR-PDL-AREA ;MAIN PDL
+ PDL-AREA ;PDLS FOR MISC STACK GROUPS
+))
+
+ ;NOTE THAT AT PRESENT ALL AREAS UP THROUGH ADDRESS-SPACE-MAP MUST BE WIRED.
+ ;THE REASON IS THAT WHEN THE MICROCODE STARTS UP IT STRAIGHT-MAPS THAT
+ ;AMOUNT OF VIRTUAL MEMORY, WITHOUT CHECKING SEPARATELY FOR EACH PAGE.
+ ;IT WOULD LOSE BIG IF ONE OF THOSE STRAIGHT-MAPPED PAGES GOT SWAPPED OUT.
+ ;EXCEPT, UNUSED PORTIONS OF PAGE-TABLE-AREA AND PHYSICAL-PAGE-DATA GET UNWIRED
+(cl:defvar WIRED-AREA-LIST '( ;AREAS THAT MAY NOT BE MOVED NOR SWAPPED OUT
+ RESIDENT-SYMBOL-AREA ;NO GOOD REASON
+ SYSTEM-COMMUNICATION-AREA ;FOR CONSOLE, PDP10, MICRO INTERRUPT, ETC.
+ SCRATCH-PAD-INIT-AREA ;LOAD MICRO CODE VARIABLES UPON STARTUP
+ MICRO-CODE-SYMBOL-AREA ;NO GOOD REASON, ACTUALLY
+ PAGE-TABLE-AREA ;USED BY PAGE FAULT HANDLER
+ PHYSICAL-PAGE-DATA ;USED BY PAGE FAULT HANDLER
+ REGION-ORIGIN ;USED BY PAGE FAULT HANDLER
+ REGION-LENGTH ;USED BY PAGE FAULT HANDLER
+ REGION-BITS ;USED BY PAGE FAULT HANDLER
+ ADDRESS-SPACE-MAP ;USED BY PAGE FAULT HANDLER
+))
+
+;THIS LIST ISN'T NECESSARILY UP TO DATE. FEATURE ISN'T REALLY USED YET.
+(cl:defvar READ-ONLY-AREA-LIST '( ;AREAS TO BE SET UP READ ONLY BY COLD LOAD
+ SCRATCH-PAD-INIT-AREA
+ MICRO-CODE-SYMBOL-AREA
+ SUPPORT-ENTRY-VECTOR
+ CONSTANTS-AREA
+ INIT-LIST-AREA
+ MICRO-CODE-SYMBOL-NAME-AREA
+))
+
+(cl:defvar COLD-LOAD-AREA-SIZES ;DEFAULT AREA SIZE IS ONE PAGE
+ '(P-N-STRING 600 OBT-TAILS 100 NR-SYM 500 MACRO-COMPILED-PROGRAM 1000
+ PAGE-TABLE-AREA 128. ;ENOUGH FOR 2 MEGAWORDS OF MAIN MEMORY
+ PHYSICAL-PAGE-DATA 32. ;ENOUGH FOR 2 MEGAWORDS OF MAIN MEMORY
+ ADDRESS-SPACE-MAP 1 ;ASSUMING 8-BIT BYTES
+ GC-TABLE-AREA 400 ;64K
+ LINEAR-PDL-AREA 100 LINEAR-BIND-PDL-AREA 10 PDL-AREA 300
+ WORKING-STORAGE-AREA 400 PERMANENT-STORAGE-AREA 200 PROPERTY-LIST-AREA 100
+ CONTROL-TABLES 13 INIT-LIST-AREA 64
+ MICRO-CODE-ENTRY-AREA 2 MICRO-CODE-ENTRY-NAME-AREA 2
+ MICRO-CODE-ENTRY-ARGS-INFO-AREA 2 MICRO-CODE-ENTRY-ARGLIST-AREA 2
+ MICRO-CODE-ENTRY-MAX-PDL-USAGE 2
+ MICRO-CODE-SYMBOL-NAME-AREA 2 MICRO-CODE-SYMBOL-AREA 2
+ FASL-TABLE-AREA 201 ;3 TIMES LENGTH-OF-FASL-TABLE PLUS 1 PAGE
+ FASL-CONSTANTS-AREA 600 EXTRA-PDL-AREA 10
+ FASL-TEMP-AREA 40))
+
+(cl:defvar COLD-LOAD-REGION-SIZES ;DEFAULT REGION SIZE IS 16K
+ '(WORKING-STORAGE-AREA 400000 MACRO-COMPILED-PROGRAM 200000
+ P-N-STRING 200000 NR-SYM 200000 FASL-CONSTANTS-AREA 200000
+ PROPERTY-LIST-AREA 200000))
+
+;In the cold-load, areas have only one region, so you can only use one
+;representation type per area. These are the list areas, the rest are structure areas.
+(cl:defvar LIST-STRUCTURED-AREAS '(
+ SYSTEM-COMMUNICATION-AREA SCRATCH-PAD-INIT-AREA MICRO-CODE-SYMBOL-AREA
+ PAGE-TABLE-AREA PHYSICAL-PAGE-DATA REGION-ORIGIN REGION-LENGTH
+ REGION-BITS REGION-FREE-POINTER REGION-GC-POINTER
+ REGION-LIST-THREAD AREA-NAME AREA-REGION-LIST AREA-REGION-SIZE
+ AREA-MAXIMUM-SIZE AREA-SWAP-RECOMMENDATIONS SUPPORT-ENTRY-VECTOR CONSTANTS-AREA
+ MICRO-CODE-ENTRY-AREA MICRO-CODE-ENTRY-NAME-AREA
+ MICRO-CODE-ENTRY-ARGS-INFO-AREA MICRO-CODE-ENTRY-MAX-PDL-USAGE
+ MICRO-CODE-ENTRY-ARGLIST-AREA
+ MICRO-CODE-SYMBOL-NAME-AREA INIT-LIST-AREA PROPERTY-LIST-AREA
+ OBT-TAILS FASL-CONSTANTS-AREA
+))
+
+(cl:defvar STATIC-AREAS '( ;not including Fixed areas
+ INIT-LIST-AREA PERMANENT-STORAGE-AREA P-N-STRING CONTROL-TABLES
+ NR-SYM MACRO-COMPILED-PROGRAM
+ FASL-TABLE-AREA FASL-TEMP-AREA FASL-CONSTANTS-AREA
+))
+
+; Numeric values of data types, shifted over into the data type field,
+; suitable for being added to the pointer to produce the contents of a Q.
+; These do NOT go into the cold load.
+; What are these used for nowadays? They are not used in UCADR. -- RMS
+(cl:defvar DATA-TYPES '(QZTRAP QZNULL QZFREE ;ERRORS
+ QZSYM QZSYMH QZFIX QZXNUM ;ORDINARY ATOMS
+ QZHDR
+ QZGCF QZEVCP QZ1QF QZHF QXBF ;FORWARDS
+ QZLOC ;LOCATIVES
+ QZLIST ;LISTS
+ QZUENT ;FUNCTIONS, ETC...
+ QZFEFP QZARYP QZARYH ;...
+ QZSTKG QZCLOS
+ QZSFLO QZSMTH QZINST QZINSH QZENTY QZSCLS
+ ))
+
+; Numeric values of data types, suitable for being DPB'd into the
+; data type field, or returned by (%DATA-TYPE ...).
+(cl:defvar Q-DATA-TYPES '(DTP-TRAP DTP-NULL DTP-FREE
+ DTP-SYMBOL DTP-SYMBOL-HEADER DTP-FIX DTP-EXTENDED-NUMBER DTP-HEADER
+ DTP-GC-FORWARD DTP-EXTERNAL-VALUE-CELL-POINTER DTP-ONE-Q-FORWARD
+ DTP-HEADER-FORWARD DTP-BODY-FORWARD
+ DTP-LOCATIVE
+ DTP-LIST
+ DTP-U-ENTRY
+ DTP-FEF-POINTER DTP-ARRAY-POINTER DTP-ARRAY-HEADER
+ DTP-STACK-GROUP DTP-CLOSURE DTP-SMALL-FLONUM DTP-SELECT-METHOD
+ DTP-INSTANCE DTP-INSTANCE-HEADER DTP-ENTITY
+ DTP-STACK-CLOSURE
+ ))
+
+; Numeric values of CDR codes, right-justified in word for %P-CDR-CODE, etc.
+(cl:defvar Q-CDR-CODES '(CDR-NORMAL CDR-ERROR CDR-NIL CDR-NEXT))
+
+; Byte pointers at the parts of a Q or other thing, and their values.
+; Q-FIELD-VALUES does NOT itself go into the cold load.
+(cl:defvar Q-FIELD-VALUES '(%%Q-CDR-CODE 3602
+ ;%%Q-FLAG-BIT 3501
+ %%Q-DATA-TYPE 3005 %%Q-POINTER 0030 %%Q-POINTER-WITHIN-PAGE 0007
+ %%Q-TYPED-POINTER 0035 %%Q-ALL-BUT-TYPED-POINTER 3503
+ %%Q-ALL-BUT-POINTER 3010 %%Q-ALL-BUT-CDR-CODE 0036
+ %%Q-HIGH-HALF 2020 %%Q-LOW-HALF 0020 ;USE THESE FOR REFERENCING MACRO INSTRUCTIONS
+ %%CH-FONT 1010 %%CH-CHAR 0010 ;FIELDS IN A 16-BIT CHARACTER
+ %%KBD-CHAR 0010 %%KBD-CONTROL-META 1004
+ %%KBD-CONTROL 1001 %%KBD-META 1101 %%KBD-SUPER 1201 %%KBD-HYPER 1301
+ %%KBD-MOUSE 1701 %%KBD-MOUSE-BUTTON 0003 %%KBD-MOUSE-N-CLICKS 0303))
+
+; Assign the byte pointers their values. Q-FIELDS becomes a list of just names.
+; It goes into the cold load, along with the names and their values.
+(ASSIGN-ALTERNATE Q-FIELD-VALUES)
+(cl:defvar Q-FIELDS (GET-ALTERNATE Q-FIELD-VALUES))
+
+;(cl:defvar %Q-FLAG-BIT (DPB -1 %%Q-FLAG-BIT 0)) ;USED BY QLF IN COLD MODE
+
+;;; Stuff in the REGION-BITS array, some of these bits also appear in the
+;;; map in the same orientation.
+
+(cl:defvar Q-REGION-BITS-VALUES '(
+ %%REGION-MAP-BITS 1612 ;10 bits to go into the map (access/status/meta)
+ ;2404 ;access and status bits
+ %%REGION-OLDSPACE-META-BIT 2301 ;0=old or free, 1=new or static or fixed.
+ ;0 causes transport-trap for read of ptr to here
+ %%REGION-EXTRA-PDL-META-BIT 2201 ;0=extra-pdl, 1=normal.
+ ;0 traps writing of ptr to here into "random" mem
+ %%REGION-REPRESENTATION-TYPE 2002 ;Data representation type code:
+ %REGION-REPRESENTATION-TYPE-LIST 0
+ %REGION-REPRESENTATION-TYPE-STRUCTURE 1 ;2 and 3 reserved for future
+ ;1602 spare meta bits
+ ;1501 spare (formerly unimplemented compact-cons flag)
+ %%REGION-SPACE-TYPE 1104 ;Code for type of space:
+ %REGION-SPACE-FREE 0 ;0 free region slot
+ %REGION-SPACE-OLD 1 ;1 oldspace region of dynamic area
+ %REGION-SPACE-NEW 2 ;2 permanent newspace region of dynamic area
+ %REGION-SPACE-NEW1 3 ;3 temporary space, level 1
+ %REGION-SPACE-NEW2 4 ;4 ..
+ %REGION-SPACE-NEW3 5 ;5 ..
+ %REGION-SPACE-NEW4 6 ;6 ..
+ %REGION-SPACE-NEW5 7 ;7 ..
+ %REGION-SPACE-NEW6 10 ;10 ..
+ %REGION-SPACE-STATIC 11 ;11 static area
+ %REGION-SPACE-FIXED 12 ;12 fixed, static+not growable+no consing allowed
+ %REGION-SPACE-EXTRA-PDL 13 ;13 An extra-pdl for some stack-group
+ %REGION-SPACE-COPY 14 ;14 Like newspace, stuff copied from oldspace goes
+ ; here while newly-consed stuff goes to newspace
+ ; This is for permanent data
+ ;15-17 [not used]
+
+ %%REGION-SCAVENGE-ENABLE 1001 ;If 1, scavenger touches this region
+ ;0503 spare bits.
+ %%REGION-SWAPIN-QUANTUM 0005 ;swap this +1 pages in one disk op on swapin
+ ; if possible.
+))
+
+(ASSIGN-ALTERNATE Q-REGION-BITS-VALUES)
+(cl:defvar Q-REGION-BITS (GET-ALTERNATE Q-REGION-BITS-VALUES))
+
+(cl:defvar Q-AREA-SWAP-BITS-VALUES '(
+ %%AREA-SWAP-SWAPIN-TRANSFER-SIZE 0006 ;# of pages to bring in with single disk
+ ; op if possible. 0 says always 1.
+ ; Otherwise this is a base number which
+ ; may be further increased in
+ ; context-switch mode.
+ ))
+
+(ASSIGN-ALTERNATE Q-AREA-SWAP-BITS-VALUES)
+(cl:defvar Q-AREA-SWAP-BITS (GET-ALTERNATE Q-AREA-SWAP-BITS-VALUES))
+
+(cl:defvar SYSTEM-COMMUNICATION-AREA-QS '( ;LOCATIONS RELATIVE TO 400 IN CADR
+ ;locations 400-437 are miscellaneous Qs declared below
+ ;locations 440-477 are the reverse first level map
+ ;locations 500-511 are the keyboard buffer header (buffer is 200-377)
+ ;locations 600-637 are the disk-error log
+ ;locations 700-777 are reserved for disk CCW's (only 777 used now)
+ ;In CADR, location 777 is used (for now) by the disk code for the CCW.
+ ; --actually it seems to use locations 12-377 for the CCW most of the time.
+ %SYS-COM-AREA-ORIGIN-PNTR ;ADDRESS OF AREA-ORIGIN AREA
+ %SYS-COM-VALID-SIZE ;IN A SAVED BAND, NUMBER OF WORDS USED
+ %SYS-COM-PAGE-TABLE-PNTR ;ADDRESS OF PAGE-TABLE-AREA
+ %SYS-COM-PAGE-TABLE-SIZE ;NUMBER OF QS
+ %SYS-COM-OBARRAY-PNTR ;CURRENT OBARRAY, COULD BE AN ARRAY-POINTER
+ ;BUT NOW IS USUALLY A SYMBOL WHOSE VALUE
+ ;IS THE CURRENTLY-SELECTED OBARRAY (PACKAGE)
+ ;Ether net interrupt-handler variables
+ %SYS-COM-ETHER-FREE-LIST
+ %SYS-COM-ETHER-TRANSMIT-LIST
+ %SYS-COM-ETHER-RECEIVE-LIST
+
+ %SYS-COM-BAND-FORMAT ;In a saved band, encodes format number.
+ ; 1000 -> new compressed format
+ ; otherwise old expanded format.
+ ;In old bands, this is not really initialized
+ ; but is usually 410.
+
+ %SYS-COM-GC-GENERATION-NUMBER ;reserved for value of %GC-GENERATION-NUMBER
+
+ %SYS-COM-UNIBUS-INTERRUPT-LIST ;SEE LMIO;UNIBUS (LIST OF UNIBUS CHANNELS)
+
+ %SYS-COM-TEMPORARY ;MICROCODE BASHES THIS AT EXTRA-PDL-PURGE
+
+ %SYS-COM-FREE-AREA#-LIST ;THREADED THROUGH AREA-REGION-LIST, END=0
+ %SYS-COM-FREE-REGION#-LIST ;THREADED THROUGH REGION-LIST-THREAD, END=0
+ %SYS-COM-MEMORY-SIZE ;NUMBER OF WORDS OF MAIN MEMORY
+ %SYS-COM-WIRED-SIZE ;# WORDS OF LOW MEMORY WIRED DOWN
+ ;NOT ALL OF THESE WORDS ARE WIRED, THIS
+ ;IS REALLY THE VIRTUAL ADDRESS OF THE START
+ ;OF NORMAL PAGEABLE MEMORY
+
+ ;Chaos net interrupt-handler variables
+ %SYS-COM-CHAOS-FREE-LIST
+ %SYS-COM-CHAOS-TRANSMIT-LIST
+ %SYS-COM-CHAOS-RECEIVE-LIST
+
+ ;Debugger locations (*** these seem not to be used ***)
+ %SYS-COM-DEBUGGER-REQUESTS ;REQUEST TO POWER CONTROL/DEBUGGER
+ %SYS-COM-DEBUGGER-KEEP-ALIVE ;KEEP ALIVE FLAG WORD
+ %SYS-COM-DEBUGGER-DATA-1 ;FOR INTERCOMMUNICATION
+ %SYS-COM-DEBUGGER-DATA-2
+
+ ;*** This does not appear to be initialized or used
+ %SYS-COM-MAJOR-VERSION ;MAJOR COLD LOAD VERSION AS FIXNUM. AVAILABLE TO
+ ; MICROCODE FOR DOWNWARD COMPATIBILITY.
+ %SYS-COM-DESIRED-MICROCODE-VERSION ;Microcode version this world expects
+ ;TO BE ADDED:
+ ;SWAP OUT SCHEDULER AND DISK STUFF
+ ;EVENTUALLY THIS MAY REPLACE SCRATCH-PAD-INIT-AREA
+ ;THOSE OF THESE THAT DON'T NEED TO SURVIVE WARM BOOT COULD BE IN A-MEMORY
+ %SYS-COM-HIGHEST-VIRTUAL-ADDRESS ;In new band format. You better have this amt of
+ ; room in the paging partition.
+ %SYS-COM-POINTER-WIDTH ;Either 24 or 25, as fixnum, or DTP-FREE in old sys.
+ ;; 6 left
+))
+
+;(AND (> (LENGTH SYSTEM-COMMUNICATION-AREA-QS) 40)
+; (ERROR '|SYSTEM COMMUNICATION AREA OVERFLOW|))
+
+(cl:defvar NEW-ARRAY-INDEX-ORDER cl:NIL)
+
+;;; Next three symbols are treated bletcherously, because there isnt the right kind of
+;;; LDB available
+
+;VIRTUAL ADDRESS OF 0 at A. MUST AGREE WITH VALUE IN UCADR.
+;(unfortunately called LOWEST-A-MEM-VIRTUAL-ADDRESS).
+(cl:defvar A-MEMORY-VIRTUAL-ADDRESS #o76776000) ; (%P-LDB-OFFSET 0030 76776000 1))
+
+;Virtual address of X-BUS IO space.
+;Must agree with LOWEST-IO-SPACE-VIRTUAL-ADDRESS in UCADR.
+(cl:defvar IO-SPACE-VIRTUAL-ADDRESS #o77000000) ;(%P-LDB-OFFSET 0030 77000000 1))
+
+;Virtual address of UNIBUS IO space.
+;Must agree with LOWEST-UNIBUS-VIRTUAL-ADDRESS in UCADR.
+(cl:defvar UNIBUS-VIRTUAL-ADDRESS #o77400000) ; (%P-LDB-OFFSET 0030 77400000 1))
+
+(cl:defvar %INITIALLY-DISABLE-TRAPPING cl:NIL) ;THIS NON-NIL INHIBITS LISP-REINITIALIZE FROM
+ ; DOING AN (ENABLE-TRAPPING)
+(cl:defvar INHIBIT-SCHEDULING-FLAG cl:NIL) ;THIS NON-NIL INHIBITS CLOCK & SCHEDULING
+
+(cl:defvar HEADER-FIELD-VALUES '(%%HEADER-TYPE-FIELD 2305 %%HEADER-REST-FIELD 0023))
+(cl:defvar HEADER-FIELDS (GET-ALTERNATE HEADER-FIELD-VALUES))
+
+; These are the values that go in the %%HEADER-TYPE-FIELD of a Q of
+; data type DTP-HEADER.
+(cl:defvar Q-HEADER-TYPES '(%HEADER-TYPE-ERROR %HEADER-TYPE-FEF
+ %HEADER-TYPE-ARRAY-LEADER
+ %HEADER-TYPE-unused %HEADER-TYPE-FLONUM %HEADER-TYPE-COMPLEX
+ %HEADER-TYPE-BIGNUM %HEADER-TYPE-RATIONAL-BIGNUM))
+
+; These are the header types, shifted so they can be added directly into a Q.
+; These do NOT go in the cold load.
+(cl:defvar HEADER-TYPES '(HEADER-TYPE-ERROR HEADER-TYPE-FEF
+ HEADER-TYPE-ARRAY-LEADER
+ HEADER-TYPE-unused HEADER-TYPE-FLONUM HEADER-TYPE-COMPLEX
+ HEADER-TYPE-BIGNUM HEADER-TYPE-RATIONAL-BIGNUM))
+
+; These three lists describing the possible types of "argument descriptor info"
+(cl:defvar ADI-KINDS '(ADI-ERR ADI-RETURN-INFO ADI-RESTART-PC ADI-FEXPR-CALL
+ ADI-LEXPR-CALL ADI-BIND-STACK-LEVEL ADI-UNUSED-6
+ ADI-USED-UP-RETURN-INFO))
+
+(cl:defvar ADI-STORING-OPTIONS '(ADI-ST-ERR ADI-ST-BLOCK ADI-ST-LIST
+ ADI-ST-MAKE-LIST ADI-ST-INDIRECT))
+
+(cl:defvar ADI-FIELD-VALUES '(%%ADI-TYPE 2403 %%ADI-RET-STORING-OPTION 2103
+ %%ADI-PREVIOUS-ADI-FLAG 3601 ;Overlaps cdr-code
+ %%ADI-RET-SWAP-SV 2001 %%ADI-RET-NUM-VALS-EXPECTING 0006
+ %%ADI-RPC-MICRO-STACK-LEVEL 0006))
+(ASSIGN-ALTERNATE ADI-FIELD-VALUES)
+(cl:defvar ADI-FIELDS (GET-ALTERNATE ADI-FIELD-VALUES))
+
+;;; These overlap the cdr-code field, which is not used in the special pdl.
+(cl:defvar SPECPDL-FIELD-VALUES '(
+ %%SPECPDL-BLOCK-START-FLAG 3601 ;Flag is set on first binding of each block of bindings
+ %%SPECPDL-CLOSURE-BINDING 3701 ;Flag is set on bindings made "before" entering function
+ ))
+(ASSIGN-ALTERNATE SPECPDL-FIELD-VALUES)
+(cl:defvar SPECPDL-FIELDS (GET-ALTERNATE SPECPDL-FIELD-VALUES))
+
+; LINEAR-PDL-QS and LINEAR-PDL-FIELDS, and their elements, go in the real machine.
+(cl:defvar LINEAR-PDL-QS '(%LP-FEF %LP-ENTRY-STATE %LP-EXIT-STATE %LP-CALL-STATE))
+ ;THESE ARE ASSIGNED VALUES STARTING WITH 0 AND INCREMENTING BY -1
+ (ASSIGN-VALUES-INIT-DELTA LINEAR-PDL-QS 0 0 -1)
+
+(cl:defvar %LP-CALL-BLOCK-LENGTH (cl:LENGTH LINEAR-PDL-QS))
+(cl:defvar LLPFRM 4) ;# FIXED ALLOC QS IN LINAR PDL BLOCK (OBSOLETE, USE ABOVE)
+
+(cl:defvar %LP-INITIAL-LOCAL-BLOCK-OFFSET 1)
+
+(cl:defvar LINEAR-PDL-FIELDS-VALUES '(
+ ;LPCLS (%LP-CALL-STATE). Stored when this call frame is created.
+ ;bits 27', 25' not used in LPCLS
+ %%LP-CLS-TRAP-ON-EXIT 2601 ;If set, get error before popping this frame.
+ %%LP-CLS-ADI-PRESENT 2401 ;ADI words precede this call-block
+ %%LP-CLS-DESTINATION 2004 ;Where in the caller to put this frame's value
+ %%LP-CLS-DELTA-TO-OPEN-BLOCK 1010 ;Offset back to previous open or active block
+ %%LP-CLS-DELTA-TO-ACTIVE-BLOCK 0010 ;Offset back to previous active block
+ ;An active block is one that is executing
+ ;An open block is one whose args are being made
+ ;LPEXS (%LP-EXIT-STATE). Stored when this frame calls out.
+ ;bits 22'-27' not used in LPEXS
+ %%LP-EXS-MICRO-STACK-SAVED 2101 ;A microstack frame exists on special pdl
+ %%LP-EXS-PC-STATUS 2001 ;Same as below
+ %%LP-EXS-BINDING-BLOCK-PUSHED 2001 ;M-QBBFL STORED HERE IN MACRO EXIT OPERATION
+ %%LP-EXS-EXIT-PC 0017 ;LC as offset in halfwords from FEF
+ ;Meaningless if %LP-FEF not a fef.
+ ;; Don't change %%LP-EXS-EXIT-PC, the numerical value is known by UCADR
+ ;LPENS (%LP-ENTRY-STATE). Stored when this frame entered.
+ ;bits 16'-27' not used in LPENS
+; %%LP-ENS-SPECIALS 2601 %%LP-ENS-BINDING-ARROW-DIRECTION 2501
+ %%LP-ENS-ENVIRONMENT-POINTER-POINTS-HERE 1601
+ %%LP-ENS-NUM-ARGS-SUPPLIED 1006
+ %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN 0010))
+
+(ASSIGN-ALTERNATE LINEAR-PDL-FIELDS-VALUES)
+(cl:defvar LINEAR-PDL-FIELDS (GET-ALTERNATE LINEAR-PDL-FIELDS-VALUES))
+
+;; MICRO-STACK-FIELDS and its elements go in the real machine.
+(cl:defvar MICRO-STACK-FIELDS-VALUES
+ '( %%US-RPC 1600 ;RETURN PC
+ %%US-MACRO-INSTRUCTION-RETURN 1601 ;TRIGGERS INSTRUCTION-STREAM STUFF
+ %%US-PPBMIA 1701 ;ADI ON MICRO-TO-MICRO-CALL
+ %%US-PPBSPC 2101)) ;BINDING BLOCK PUSHED
+
+
+(ASSIGN-ALTERNATE MICRO-STACK-FIELDS-VALUES)
+(cl:defvar MICRO-STACK-FIELDS (GET-ALTERNATE MICRO-STACK-FIELDS-VALUES))
+
+
+; M-FLAGS-FIELDS and M-ERROR-SUBSTATUS-FIELDS and their elements go in the real machine.
+(cl:defvar M-FLAGS-FIELDS-VALUES '( ;MUST AGREE WITH DEFS IN UCONS
+ %%M-FLAGS-QBBFL 0001 ;BIND BLOCK OPEN FLAG
+ %%M-FLAGS-CAR-SYM-MODE 0102 ;CAR OF SYMBOL GIVES: ERROR, ERROR EXCEPT
+ ; (CAR NIL) -> NIL, NIL, P-NAME POINTER
+ %%M-FLAGS-CAR-NUM-MODE 0302 ;CAR OF NUMBER GIVES: ERROR, NIL, "WHATEVER IT IS"
+ %%M-FLAGS-CDR-SYM-MODE 0502 ;CDR OF SYMBOL GIVES: ERROR, ERROR EXCEPT
+ ; (CDR NIL) -> NIL, NIL, PROPERTY-LIST
+ %%M-FLAGS-CDR-NUM-MODE 0702 ;CDR OF NUMBER GIVES: ERROR, NIL, "WHATEVER IT IS"
+ %%M-FLAGS-DONT-SWAP-IN 1101 ;MAGIC FLAG FOR CREATING FRESH PAGES
+ %%M-FLAGS-TRAP-ENABLE 1201 ;1 ENABLE ERROR TRAPPING
+ %%M-FLAGS-MAR-MODE 1302 ;1-BIT = READ-TRAP, 2-BIT = WRITE-TRAP
+ %%M-FLAGS-PGF-WRITE 1501 ;FLAG USED BY PAGE FAULT ROUTINE
+ %%M-FLAGS-INTERRUPT 1601 ;IN MICROCODE INTERRUPT
+ %%M-FLAGS-SCAVENGE 1701 ;IN SCAVENGER
+ %%M-FLAGS-TRANSPORT 2001 ;IN TRANSPORTER
+ %%M-FLAGS-STACK-GROUP-SWITCH 2101 ;SWITCHING STACK GROUPS
+ %%M-FLAGS-DEFERRED-SEQUENCE-BREAK 2201 ;SEQUENCE BREAK PENDING BUT INHIBITED
+ %%M-FLAGS-METER-ENABLE 2301 ;METERING ENABLED FOR THIS STACK GROUP
+ %%M-FLAGS-TRAP-ON-CALL 2401 ;TRAP ON ATTEMPTING TO ACTIVATE NEW FRAME.
+))
+(ASSIGN-ALTERNATE M-FLAGS-FIELDS-VALUES)
+(cl:defvar M-FLAGS-FIELDS (GET-ALTERNATE M-FLAGS-FIELDS-VALUES))
+
+(cl:defvar M-ERROR-SUBSTATUS-FIELDS-VALUES '( ;MUST AGREE WITH DEFS IN UCONS
+ %%M-ESUBS-TOO-FEW-ARGS 0001
+ %%M-ESUBS-TOO-MANY-ARGS 0101
+ %%M-ESUBS-BAD-QUOTED-ARG 0201
+ %%M-ESUBS-BAD-EVALED-ARG 0301
+ %%M-ESUBS-BAD-DT 0401
+ %%M-ESUBS-BAD-QUOTE-STATUS 0501
+))
+(ASSIGN-ALTERNATE M-ERROR-SUBSTATUS-FIELDS-VALUES)
+(cl:defvar M-ERROR-SUBSTATUS-FIELDS (GET-ALTERNATE M-ERROR-SUBSTATUS-FIELDS-VALUES))
+
+;A "Numeric Argument Description" is what %ARGS-INFO and ARGS-INFO return.
+;Such descriptors can also be hung on symbols' Q-ARGS-PROP properties.
+;The "fast option Q" of a FEF is stored in this format.
+;These symbols go in the real machine.
+(cl:defvar NUMERIC-ARG-DESC-INFO '(
+ %ARG-DESC-QUOTED-REST 10000000 ;HAS QUOTED REST ARGUMENT
+ %%ARG-DESC-QUOTED-REST 2501
+ %ARG-DESC-EVALED-REST 4000000 ;HAS EVALUATED REST ARGUMENT
+ %%ARG-DESC-EVALED-REST 2401
+ %%ARG-DESC-ANY-REST 2402 ;NON-ZERO IF HAS EITHER KIND OF REST ARG
+ %ARG-DESC-FEF-QUOTE-HAIR 2000000 ;MACRO COMPILED FCN WITH HAIRY QUOTING,
+ %%ARG-DESC-FEF-QUOTE-HAIR 2301 ; CALLER MUST CHECK A-D-L FOR FULL INFO
+ %ARG-DESC-INTERPRETED 1000000 ;THIS IS INTERPRETED FUNCTION,
+ %%ARG-DESC-INTERPRETED 2201 ; NO INFORMATION AVAILABLE (VAL=1000077)
+ %ARG-DESC-FEF-BIND-HAIR 400000 ;MACRO COMPILED FCN WITH HAIRY BINDING,
+ %%ARG-DESC-FEF-BIND-HAIR 2101 ; LINEAR ENTER MUST CHECK A-D-L
+ %%ARG-DESC-MIN-ARGS 0606 ;MINIMUM NUMBER OF REQUIRED ARGS
+ %%ARG-DESC-MAX-ARGS 0006)) ;MAXIMUM NUMBER OF REQUIRED+OPTIONAL
+ ; ARGS. REST ARGS NOT COUNTED.
+
+(ASSIGN-ALTERNATE NUMERIC-ARG-DESC-INFO)
+(cl:defvar NUMERIC-ARG-DESC-FIELDS (GET-ALTERNATE NUMERIC-ARG-DESC-INFO))
+
+(cl:defvar ARG-DESC-FIELD-VALUES '(%FEF-ARG-SYNTAX 160 %FEF-QUOTE-STATUS 600
+ %FEF-DES-DT 17000
+ %FEF-INIT-OPTION 17 %FEF-SPECIAL-BIT #.(cl:ash 1 16)
+ %FEF-NAME-PRESENT #.(cl:ash 1 20)
+;***UNFORTUNATELY, ASSIGN-COMP-VALUES KNOWS ABOUT THESE TOO****
+ %%FEF-NAME-PRESENT 2001
+ %%FEF-SPECIAL-BIT 1601 %%FEF-SPECIALNESS 1602
+ %%FEF-FUNCTIONAL 1501 %%FEF-DES-DT 1104
+ %%FEF-QUOTE-STATUS 0702 %%FEF-ARG-SYNTAX 0403 %%FEF-INIT-OPTION 0004
+))
+
+(ASSIGN-ALTERNATE ARG-DESC-FIELD-VALUES)
+(cl:defvar ARG-DESC-FIELDS (GET-ALTERNATE ARG-DESC-FIELD-VALUES))
+ ;ARG-DESC-FIELDS GETS SET TO A LIST CONSISTING OF THE ALTERNATING MEMBERS OF
+ ;ARG-DESC-FIELD-VALUES
+
+(cl:defvar FEF-NAME-PRESENT '(FEF-NM-NO FEF-NM-YES))
+(cl:defvar FEF-SPECIALNESS '(FEF-LOCAL FEF-SPECIAL FEF-SPECIALNESS-UNUSED FEF-REMOTE))
+(cl:defvar FEF-FUNCTIONAL '(FEF-FUNCTIONAL-DONTKNOW FEF-FUNCTIONAL-ARG))
+(cl:defvar FEF-DES-DT '(FEF-DT-DONTCARE FEF-DT-NUMBER FEF-DT-FIXNUM FEF-DT-SYM
+ FEF-DT-ATOM FEF-DT-LIST FEF-DT-FRAME))
+(cl:defvar FEF-QUOTE-STATUS '(FEF-QT-DONTCARE FEF-QT-EVAL FEF-QT-QT))
+(cl:defvar FEF-ARG-SYNTAX '(FEF-ARG-REQ FEF-ARG-OPT FEF-ARG-REST FEF-ARG-AUX
+ FEF-ARG-FREE FEF-ARG-INTERNAL FEF-ARG-INTERNAL-AUX))
+(cl:defvar FEF-INIT-OPTION '(FEF-INI-NONE FEF-INI-NIL FEF-INI-PNTR FEF-INI-C-PNTR
+ FEF-INI-OPT-SA FEF-INI-COMP-C FEF-INI-EFF-ADR
+ FEF-INI-SELF))
+
+
+(cl:defvar ARRAY-FIELD-VALUES '(
+ %%ARRAY-TYPE-FIELD 2305 %%ARRAY-LEADER-BIT 2101
+ %%ARRAY-DISPLACED-BIT 2001 %%ARRAY-FLAG-BIT 1701
+ %%ARRAY-NUMBER-DIMENSIONS 1403 %%ARRAY-LONG-LENGTH-FLAG 1301
+ %%ARRAY-NAMED-STRUCTURE-FLAG 1201
+ %%ARRAY-INDEX-LENGTH-IF-SHORT 0012 %ARRAY-MAX-SHORT-INDEX-LENGTH 1777))
+
+(cl:defvar ARRAY-LEADER-FIELD-VALUES '(%ARRAY-LEADER-LENGTH 777777
+ %%ARRAY-LEADER-LENGTH 0022))
+
+(cl:defvar ARRAY-MISC-VALUES
+ '(ARRAY-DIM-MULT #.(cl:ash 1 14)
+ ARRAY-DIMENSION-SHIFT -14
+ ARRAY-TYPE-SHIFT -23
+ ARRAY-LEADER-BIT #.(cl:ash 1 21)
+ ARRAY-DISPLACED-BIT #.(cl:ash 1 20)
+ ARRAY-LONG-LENGTH-FLAG #.(cl:ash 1 13)
+ ARRAY-NAMED-STRUCTURE-FLAG #.(cl:ash 1 12)))
+
+(cl:defvar ARRAY-FIELDS (GET-ALTERNATE ARRAY-FIELD-VALUES))
+
+(cl:defvar ARRAY-LEADER-FIELDS (GET-ALTERNATE ARRAY-LEADER-FIELD-VALUES))
+
+(cl:defvar ARRAY-MISCS (GET-ALTERNATE ARRAY-MISC-VALUES))
+
+(cl:defvar ARRAY-TYPES '(ART-ERROR ART-1B ART-2B ART-4B ART-8B ART-16B ART-32B
+ ART-Q ART-Q-LIST ART-STRING ART-STACK-GROUP-HEAD ART-SPECIAL-PDL ART-HALF-FIX
+ ART-REG-PDL ART-FLOAT ART-FPS-FLOAT ART-FAT-STRING))
+
+(cl:defvar ARRAY-ELEMENTS-PER-Q '((ART-Q . 1) (ART-STRING . 4) (ART-1B . 40) (ART-2B . 20)
+ (ART-4B . 10) (ART-8B . 4) (ART-16B . 2) (ART-32B . 1) (ART-Q-LIST . 1)
+ (ART-STACK-GROUP-HEAD . 1) (ART-SPECIAL-PDL . 1) (ART-HALF-FIX . 2)
+ (ART-REG-PDL . 1) (ART-FLOAT . -2) (ART-FPS-FLOAT . 1) (ART-FAT-STRING . 2)))
+
+;NIL for Q-type arrays
+(cl:defvar ARRAY-BITS-PER-ELEMENT '((ART-Q . NIL) (ART-STRING . 8) (ART-1B . 1) (ART-2B . 2)
+ (ART-4B . 4) (ART-8B . 8) (ART-16B . 16.) (ART-32B . 24.) (ART-Q-LIST . NIL)
+ (ART-STACK-GROUP-HEAD . NIL) (ART-SPECIAL-PDL . NIL) (ART-HALF-FIX . 16.)
+ (ART-REG-PDL . NIL) (ART-FLOAT . 32.) (ART-FPS-FLOAT . 32.) (ART-FAT-STRING . 16.)))
+
+;FEF HEADER FIELDS
+(cl:defvar FEFH-CONSTANT-VALUES '(%FEFH-PC 177777 ;There are 19 available bits in this word!
+ %FEFH-NO-ADL #.(cl:ash 1 18.)
+ %FEFH-FAST-ARG #.(cl:ash 1 17.) %FEFH-SV-BIND #.(cl:ash 1 16.)
+ %%FEFH-PC 0020 %%FEFH-PC-IN-WORDS 0117 %%FEFH-NO-ADL 2201
+ %%FEFH-FAST-ARG 2101 %%FEFH-SV-BIND 2001))
+
+(ASSIGN-ALTERNATE FEFH-CONSTANT-VALUES)
+
+(cl:defvar FEFH-CONSTANTS (GET-ALTERNATE FEFH-CONSTANT-VALUES))
+
+;FEF HEADER Q INDEXES
+
+(cl:defvar FEFHI-INDEXES '(%FEFHI-IPC %FEFHI-STORAGE-LENGTH %FEFHI-FCTN-NAME %FEFHI-FAST-ARG-OPT
+ %FEFHI-SV-BITMAP %FEFHI-MISC %FEFHI-SPECIAL-VALUE-CELL-PNTRS))
+
+(cl:defvar IFEFOFF (cl:1- (cl:LENGTH FEFHI-INDEXES))) ;Q'S IN FIXED ALLOC PART OF FEF
+(cl:defvar %FEF-HEADER-LENGTH IFEFOFF) ;BETTER NAME FOR ABOVE
+
+(cl:defvar FEFHI-VALUES '(%%FEFHI-FSO-MIN-ARGS 0606 %%FEFHI-FSO-MAX-ARGS 0006
+ %%FEFHI-MS-LOCAL-BLOCK-LENGTH 0007 %%FEFHI-MS-ARG-DESC-ORG 0710
+ %%FEFHI-MS-BIND-DESC-LENGTH 1710
+ %%FEFHI-MS-DEBUG-INFO-PRESENT 2701
+ %%FEFHI-SVM-ACTIVE 2601
+ %FEFHI-SVM-ACTIVE #.(cl:ash 1 26)
+ %%FEFHI-SVM-BITS 0026
+ %%FEFHI-SVM-HIGH-BIT 2501))
+
+(cl:defvar FEFHI-FIELDS (GET-ALTERNATE FEFHI-VALUES))
+
+;PAGE TABLE STUFF ETC.
+
+(cl:defvar PAGE-VALUES '(
+
+ ; DEFINITIONS OF FIELDS IN PAGE HASH TABLE
+
+ ;WORD 1
+ %%PHT1-VIRTUAL-PAGE-NUMBER 1020 ;ALIGNED SAME AS VMA
+ %PHT-DUMMY-VIRTUAL-ADDRESS 177777 ;ALL ONES MEANS THIS IS DUMMY ENTRY
+ ;WHICH JUST REMEMBERS A FREE CORE PAGE
+ %%PHT1-SWAP-STATUS-CODE 0003
+ %PHT-SWAP-STATUS-NORMAL 1 ;ORDINARY PAGE
+ %PHT-SWAP-STATUS-FLUSHABLE 2 ;SAFELY REUSABLE TO SWAP PAGES INTO
+ ;MAY NEED TO BE WRITTEN TO DISK FIRST
+ %PHT-SWAP-STATUS-PREPAGE 3 ;SAME AS FLUSHABLE, BUT CAME IN VIA PREPAGE
+ %PHT-SWAP-STATUS-AGE-TRAP 4 ;LIKE NORMAL BUT TRYING TO MAKE FLUSHABLE
+ %PHT-SWAP-STATUS-WIRED 5 ;NOT SWAPPABLE
+
+ %%PHT1-AGE 0302 ;NUMBER OF TIMES AGED
+
+ %%PHT1-MODIFIED-BIT 0501 ;1 IF PAGE MODIFIED, BUT THE FACT NOT RECORDED
+ ; IN THE MAP-STATUS, BECAUSE IT IS NOMINALLY READ-ONLY
+ ; OR NOMINALLY READ-WRITE-FIRST.
+
+ %%PHT1-VALID-BIT 0601 ;1 IF THIS HASH TABLE SLOT IS OCCUPIED.
+ %%PHT1-SCAVENGER-WS-FLAG 0701 ;IF SET, PAGE IN SCAVENGER WORKING SET.
+
+ ;PHT WORD 2. THIS IS IDENTICAL TO THE LEVEL-2 MAP
+ %%PHT2-META-BITS 1606 ;SEE %%REGION-MAP-BITS
+
+ %%PHT2-MAP-STATUS-CODE 2403
+ %PHT-MAP-STATUS-MAP-NOT-VALID 0 ;LEVEL 1 OR 2 MAP NOT SET UP
+ %PHT-MAP-STATUS-META-BITS-ONLY 1 ;HAS META BITS BUT NO PHYSICAL ADDRESS
+ %PHT-MAP-STATUS-READ-ONLY 2 ;GARBAGE COLLECTOR CAN STILL WRITE IN IT
+ %PHT-MAP-STATUS-READ-WRITE-FIRST 3 ;READ/WRITE BUT NOT MODIFIED
+ %PHT-MAP-STATUS-READ-WRITE 4 ;READ/WRITE AND MODIFIED
+ %PHT-MAP-STATUS-PDL-BUFFER 5 ;MAY RESIDE IN PDL BUFFER
+ %PHT-MAP-STATUS-MAR 6 ;MAR SET SOMEWHERE ON THIS PAGE
+
+ %%PHT2-MAP-ACCESS-CODE 2602
+ %%PHT2-ACCESS-STATUS-AND-META-BITS 1612
+ %%PHT2-ACCESS-AND-STATUS-BITS 2404
+ %%PHT2-PHYSICAL-PAGE-NUMBER 0016
+))
+
+(ASSIGN-ALTERNATE PAGE-VALUES)
+(cl:defvar PAGE-HASH-TABLE-FIELDS (GET-ALTERNATE PAGE-VALUES))
+
+;;; See LISPM2;SGDEFS
+(cl:defvar STACK-GROUP-HEAD-LEADER-QS '(SG-NAME
+ SG-REGULAR-PDL SG-REGULAR-PDL-LIMIT SG-SPECIAL-PDL SG-SPECIAL-PDL-LIMIT
+ SG-INITIAL-FUNCTION-INDEX
+ SG-UCODE
+;END STATIC SECTION, BEGIN DEBUGGING SECTION
+ SG-TRAP-TAG ;SYMBOLIC TAG CORRESPONDING TO SG-TRAP-MICRO-PC. GOTTEN VIA
+ ; MICROCODE-ERROR-TABLE, ETC. PROPERTIES OFF THIS SYMBOL
+ ; DRIVE VARIOUS STAGES IN ERROR RECOVERY, ETC.
+ SG-RECOVERY-HISTORY ;AVAILABLE FOR HAIRY SG MUNGING ROUTINES TO LEAVE TRACKS IN
+ ; FOR DEBUGGING PURPOSES.
+ SG-FOOTHOLD-DATA ;STRUCTURE WHICH SAVES DYNAMIC SECTION OF "REAL" SG WHEN
+ ; EXECUTING IN THE FOOTHOLD.
+; LOCATIONS BELOW HERE ARE ACTUALLY LOADED/STORED ON SG-ENTER/SG-LEAVE
+;END DEBUGGING SECTION, BEGIN "HIGH LEVEL" SECTION
+ SG-STATE SG-PREVIOUS-STACK-GROUP SG-CALLING-ARGS-POINTER
+ SG-CALLING-ARGS-NUMBER ;SG-FOLLOWING-STACK-GROUP
+ SG-TRAP-AP-LEVEL
+;END HIGH-LEVEL SECTION, BEGIN "DYNAMIC" SECTION --BELOW HERE IS SAVED IN
+; SG-FOOTHOLD-DATA WHEN %%SG-ST-FOOTHOLD-EXECUTING IS SET.
+ SG-REGULAR-PDL-POINTER SG-SPECIAL-PDL-POINTER
+ SG-AP SG-IPMARK
+ SG-TRAP-MICRO-PC ;PC SAVED FROM OPCS AT MICRO-LOCATION TRAP
+; SG-ERROR-HANDLING-SG SG-INTERRUPT-HANDLING-SG
+; HAVING THESE BE PART OF THE SG IS BASICALLY A GOOD IDEA, BUT IT
+; DOESNT BUY ANYTHING FOR THE TIME BEING AND COSTS A COUPLE OF MICROINSTRUCTIONS
+ SG-SAVED-QLARYH SG-SAVED-QLARYL SG-SAVED-M-FLAGS
+ SG-AC-K SG-AC-S SG-AC-J
+ SG-AC-I SG-AC-Q SG-AC-R SG-AC-T SG-AC-E SG-AC-D SG-AC-C
+ SG-AC-B SG-AC-A SG-AC-ZR SG-AC-2 SG-AC-1 SG-VMA-M1-M2-TAGS SG-SAVED-VMA SG-PDL-PHASE))
+
+;FIELDS IN SG-STATE Q
+(cl:defvar SG-STATE-FIELD-VALUES '(%%SG-ST-CURRENT-STATE 0006
+ %%SG-ST-FOOTHOLD-EXECUTING 0601
+ %%SG-ST-PROCESSING-ERROR 0701 %%SG-ST-PROCESSING-INTERRRUPT-REQUEST 1001
+ %%SG-ST-SAFE 1101
+ %%SG-ST-INST-DISP 1202
+ %%SG-ST-IN-SWAPPED-STATE 2601
+ %%SG-ST-SWAP-SV-ON-CALL-OUT 2501
+ %%SG-ST-SWAP-SV-OF-SG-THAT-CALLS-ME 2401))
+(cl:defvar SG-STATE-FIELDS (GET-ALTERNATE SG-STATE-FIELD-VALUES))
+
+(cl:defvar SG-INST-DISPATCHES '(
+ SG-MAIN-DISPATCH ;MAIN INSTRUCTION DISPATCH
+ SG-DEBUG-DISPATCH ;DEBUGGING DISPATCH
+ SG-SINGLE-STEP-DISPATCH ;DISPATCH ONCE, AND THEN BREAK
+ SG-SINGLE-STEP-TRAP ;FOR SEQUENCE BREAKS OUT OF TRAPPING INSTRUCTIONS
+ ))
+
+(cl:defvar SG-STATES '(
+ SG-STATE-ERROR ;0 SHOULD NEVER GET THIS
+ SG-STATE-ACTIVE ;ACTUALLY EXECUTING ON MACHINE.
+ SG-STATE-RESUMABLE ;REACHED BY INTERRUPT OR ERROR RECOVERY COMPLETED
+ ; JUST RESTORE STATE AND DO A UCODE POPJ TO RESUME.
+ SG-STATE-AWAITING-RETURN ;AFTER DOING A "LEGITIMATE" SG-CALL. TO RESUME THIS
+ ; RELOAD SG THEN RETURN A VALUE BY TRANSFERRING TO
+ ; QMEX1.
+ SG-STATE-INVOKE-CALL-ON-RETURN ;TO RESUME THIS, RELOAD SG, THEN SIMULATE
+ ; A STORE IN DESTINATION-LAST. THE ERROR
+ ; SYSTEM CAN PRODUCE THIS STATE WHEN IT WANTS
+ ; TO ACTIVATE THE FOOTHOLD OR PERFORM A RETRY.
+ SG-STATE-INTERRUPTED-DIRTY ;GET THIS IF FORCED TO TAKE AN INTERRUPT AT AN
+ ; INOPPORTUNE TIME.
+ SG-STATE-AWAITING-ERROR-RECOVERY ;IMMEDIATEDLY AFTER ERROR, BEFORE RECOVERY
+ SG-STATE-AWAITING-CALL
+ SG-STATE-AWAITING-INITIAL-CALL
+ SG-STATE-EXHAUSTED))
+
+(cl:defvar SPECIAL-PDL-LEADER-QS '(SPECIAL-PDL-SG-HEAD-POINTER))
+(cl:defvar REG-PDL-LEADER-QS '(REG-PDL-SG-HEAD-POINTER))
+
+(cl:defvar PAGE-SIZE 400)
+(cl:defvar SITE-NAME "FERRODAY")
+
+(cl:defvar LENGTH-OF-FASL-TABLE 37773)
+
+(cl:defvar LENGTH-OF-ATOM-HEAD 5)
+
+(cl:defvar SIZE-OF-OB-TBL 177) ;USED BY PRE-PACKAGE INTERN KLUDGE
+
+(cl:defvar SIZE-OF-AREA-ARRAYS 377)
+
+;SIZE OF VARIOUS HARDWARE MEMORIES IN "ADDRESSIBLE LOCATIONS"
+(cl:defvar SIZE-OF-HARDWARE-CONTROL-MEMORY 40000)
+(cl:defvar SIZE-OF-HARDWARE-DISPATCH-MEMORY 4000)
+(cl:defvar SIZE-OF-HARDWARE-A-MEMORY 2000)
+(cl:defvar SIZE-OF-HARDWARE-M-MEMORY 40)
+(cl:defvar SIZE-OF-HARDWARE-PDL-BUFFER 2000)
+(cl:defvar SIZE-OF-HARDWARE-MICRO-STACK 40)
+(cl:defvar SIZE-OF-HARDWARE-LEVEL-1-MAP 4000)
+(cl:defvar SIZE-OF-HARDWARE-LEVEL-2-MAP 2000)
+(cl:defvar SIZE-OF-HARDWARE-UNIBUS-MAP 20)
+
+(cl:defvar A-MEMORY-LOCATION-NAMES '( ;LIST IN ORDER OF CONTENTS OF A-MEMORY STARTING AT 40
+ %MICROCODE-VERSION-NUMBER ;SECOND FILE NAME OF MICROCODE SOURCE FILE AS A NUMBER
+ %NUMBER-OF-MICRO-ENTRIES ;NUMBER OF SLOTS USED IN MICRO-CODE-ENTRY-AREA
+ DEFAULT-CONS-AREA ;DEFAULT AREA FOR CONS, LIST, ETC.
+ NUMBER-CONS-AREA ;FOR BIGNUMS, BIG-FLOATS, ETC. CAN BE
+ ; EXTRA-PDL-AREA OR JUST REGULAR AREA.
+ %INITIAL-FEF ;POINTER TO FEF OF FUNCTION MACHINE STARTS UP IN
+ %ERROR-HANDLER-STACK-GROUP ;SG TO SWITCH TO ON TRAPS
+ %CURRENT-STACK-GROUP ;CURRENT STACK-GROUP
+ %INITIAL-STACK-GROUP ;STACK-GROUP MACHINE STARTS UP IN
+ %CURRENT-STACK-GROUP-STATE ;SG-STATE Q OF CURRENT STACK GROUP
+ %CURRENT-STACK-GROUP-PREVIOUS-STACK-GROUP ;
+ %CURRENT-STACK-GROUP-CALLING-ARGS-POINTER ;
+ %CURRENT-STACK-GROUP-CALLING-ARGS-NUMBER ;
+; %CURRENT-STACK-GROUP-FOLLOWING-STACK-GROUP ;
+ %TRAP-MICRO-PC ;PC GOTTEN OUT OF OPCS BY TRAP
+ %COUNTER-BLOCK-A-MEM-ADDRESS ;LOC OF BEGINNING OF COUNTER BLOCK RELATIVE TO
+ ; A MEMORY AS A FIXNUM.
+ %CHAOS-CSR-ADDRESS ;XBUS ADDRESS
+ %MAR-LOW ;FIXNUM MAR LOWER BOUND (INCLUSIVE)
+ %MAR-HIGH ;FIXNUM MAR UPPER BOUND (INCLUSIVE)
+ ;%%M-FLAGS-MAR-MODE CONTROLS THE ABOVE
+ SELF ;SELF POINTER FOR DTP-INSTANCE, ETC
+ %METHOD-SEARCH-POINTER ;Method list element were last method found.
+ INHIBIT-SCHEDULING-FLAG ;NON-NIL SUPPRESSES SEQUENCE BREAKS
+ INHIBIT-SCAVENGING-FLAG ;NON-NIL TURNS OFF THE SCAVENGER
+ %DISK-RUN-LIGHT ;ADDRESS OF DISK RUN LIGHT, THAT+2 IS PROC RUN LIGHT
+ %LOADED-BAND ;LOW 24 BITS (FIXNUM) OF BOOTED BAND NAME (E.G. "OD3")
+ %DISK-BLOCKS-PER-TRACK ;(FROM LABEL) BLOCKS PER TRACK, USUALLY 17.
+ %DISK-BLOCKS-PER-CYLINDER ;(FROM LABEL) 85. ON T-80, 323. ON T-300
+ ;THE GARBAGE-COLLECTOR PROCESS HANGS ON THESE VARIABLES
+ %REGION-CONS-ALARM ;COUNTS NEW REGIONS CREATED
+ %PAGE-CONS-ALARM ;COUNTS PAGES ALLOCATED TO REGIONS
+ %GC-FLIP-READY ;If non-NIL, there are no pointers to oldspace
+ %INHIBIT-READ-ONLY ;If non-NIL, you can write in read-only
+ %SCAVENGER-WS-ENABLE ;If non-NIL, scavenger working set hack enabled
+ %METHOD-SUBROUTINE-POINTER ;Continuation point for SELECT-METHOD subroutine
+ ; or NIL.
+ %QLARYH ;Header of last array ref'ed as function
+ %QLARYL ;Element # of last array ref'ed as function
+ %SCHEDULER-STACK-GROUP ;Force call to this on sequence-break. This
+ ;stack group must bind on INHIBIT-SCHEDULING-FLAG as
+ ;part of the stack-group switch for proper operation.
+ %CURRENT-SHEET ;Sheet or screen currently selected by microcode
+ %DISK-SWITCHES ;Fixnum: 1 r/c after read, 2 r/c after write
+ ; 4 enables multiple page swapouts
+ ; was called %READ-COMPARE-ENABLES
+ %MC-CODE-EXIT-VECTOR ;Exit vector used by microcompiled code to ref Q
+ ; quantities.
+ ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON ;If T, upper and lower case are not equal
+ ZUNDERFLOW ;If non-NIL, floating pointer underflow yields zero
+ %GC-GENERATION-NUMBER ;Increments whenever any new oldspace is created.
+ ; Thus if this has changed, objects' addresses
+ ; may have changed.
+ %METER-GLOBAL-ENABLE ;NIL means metering on per stack group basis
+ ;T means all stack groups
+ %METER-BUFFER-POINTER ;Pointer to the buffer as a fixnum
+ %METER-DISK-ADDRESS ;disk address to write out the meter info
+ %METER-DISK-COUNT ;count of disk blocks to write out
+ CURRENTLY-PREPARED-SHEET ;Error checking for the TV:PREPARE-SHEET macro
+ MOUSE-CURSOR-STATE ;0 disabled, 1 open, 2 off, 3 on
+ MOUSE-X ;Relative to mouse-sheet
+ MOUSE-Y
+ MOUSE-CURSOR-X-OFFSET ;From top-left of pattern
+ MOUSE-CURSOR-Y-OFFSET ;to the reference point
+ MOUSE-CURSOR-WIDTH
+ MOUSE-CURSOR-HEIGHT
+ MOUSE-X-SPEED ;100ths per second, time averaged
+ MOUSE-Y-SPEED ;with time constant of 1/6 second
+ MOUSE-BUTTONS-BUFFER-IN-INDEX
+ MOUSE-BUTTONS-BUFFER-OUT-INDEX
+ MOUSE-WAKEUP ;Set to T when move or click
+ LEXICAL-ENVIRONMENT
+ AMEM-EVCP-VECTOR ;Value is an array as long as this list plus 40,
+ ;which holds the EVCP when one of these vars
+ ;is bound by a closure.
+ BACKGROUND-CONS-AREA ;Used for conses that are not explicitly requested
+ ;and shouldn't go in a temp area.
+))
+
+(cl:defvar A-MEMORY-COUNTER-BLOCK-NAMES '(
+ %COUNT-FIRST-LEVEL-MAP-RELOADS ;# FIRST LEVEL MAP RELOADS
+ %COUNT-SECOND-LEVEL-MAP-RELOADS ;# SECOND LEVEL MAP RELOADS
+ %COUNT-PDL-BUFFER-READ-FAULTS ;# TOOK PGF AND DID READ FROM PDL-BUFFER
+ %COUNT-PDL-BUFFER-WRITE-FAULTS ;# TOOK PGF AND DID WRITE TO PDL-BUFFER
+ %COUNT-PDL-BUFFER-MEMORY-FAULTS ;# TOOK PGF FOR PDL-BUF, BUT DATA IN MAIN MEM.
+ %COUNT-DISK-PAGE-READS ;COUNT OF PAGES READ FROM DISK
+ %COUNT-DISK-PAGE-WRITES ;COUNT OF PAGES WRITTEN TO DISK
+ %COUNT-DISK-ERRORS ;COUNT OF RECOVERABLE ERRS
+ %COUNT-FRESH-PAGES ;COUNT OF FRESH PAGES
+ ; GENERATED IN CORE INSTEAD OF READ FROM DISK
+ %COUNT-AGED-PAGES ;NUMBER OF TIMES AGER SET AGE TRAP
+ %COUNT-AGE-FLUSHED-PAGES ;NUMBER OF TIMES AGE TRAP -> FLUSHABLE
+ %COUNT-DISK-READ-COMPARE-REWRITES ;COUNT OF WRITES REDONE DUE TO FAILURE TO READ-COMPARE
+ %COUNT-DISK-RECALIBRATES ;DUE TO SEEK ERRORS
+ %COUNT-META-BITS-MAP-RELOADS ;# SECOND LEVEL MAP RELOADS TO META-BITS-ONLY
+ %COUNT-CHAOS-TRANSMIT-ABORTS ;Number of transmit aborts in microcode
+ %COUNT-DISK-READ-COMPARE-DIFFERENCES ;Number of read-compare differences without
+ ; accompanying disk read error
+ %COUNT-CONS-WORK ;GC parameter
+ %COUNT-SCAVENGER-WORK ;..
+ %TV-CLOCK-RATE ;TV frame rate divided by this is seq brk clock
+ %AGING-DEPTH ;Number of laps to age a page. Don't make > 3!!
+ %COUNT-DISK-ECC-CORRECTED-ERRORS ;Number of soft ECC errors
+ %COUNT-FINDCORE-STEPS ;Number of iterations finding mem to swap out
+ %COUNT-FINDCORE-EMERGENCIES ;Number of times FINDCORE had to age all pages
+ %COUNT-DISK-READ-COMPARE-REREADS ;Reads done over due to r/c diff or error
+ %COUNT-DISK-PAGE-READ-OPERATIONS ;Read operations (count once even if multipage)
+ %COUNT-DISK-PAGE-WRITE-OPERATIONS ;Write operations (count once even if multipage)
+ %COUNT-DISK-PAGE-WRITE-WAITS ;Waiting for a page to get written, to reclaim core
+ %COUNT-DISK-PAGE-WRITE-BUSYS ;Waiting for a page to get written, to use disk
+ %COUNT-DISK-PREPAGES-USED ;Counts prepaged pages that were wanted
+ %COUNT-DISK-PREPAGES-NOT-USED ;Counts prepaged pages that were reclaimed
+ %DISK-ERROR-LOG-POINTER ;Address of next 4-word block in 600-637
+ %DISK-WAIT-TIME ;Microseconds of waiting for disk time
+ %COUNT-DISK-PAGE-WRITE-APPENDS ;Pages appended to swapout operations.
+ %COUNT-DISK-PAGE-READ-APPENDS ;Pages appended to swapin operations.
+))
+
+(cl:defvar M-MEMORY-LOCATION-NAMES ;M-MEM LOCNS ARE ASSIGNED PIECEMEAL..
+ '(%MODE-FLAGS %SEQUENCE-BREAK-SOURCE-ENABLE %METER-MICRO-ENABLES))
+(cl:setf (cl:get '%MODE-FLAGS 'FORWARDING-VIRTUAL-ADDRESS)
+ (cl:+ A-MEMORY-VIRTUAL-ADDRESS 26))
+(cl:setf (cl:get '%SEQUENCE-BREAK-SOURCE-ENABLE 'FORWARDING-VIRTUAL-ADDRESS)
+ (cl:+ A-MEMORY-VIRTUAL-ADDRESS 34))
+(cl:setf (cl:get '%METER-MICRO-ENABLES 'FORWARDING-VIRTUAL-ADDRESS)
+ (cl:+ A-MEMORY-VIRTUAL-ADDRESS 35))
+
+(cl:defvar DISK-RQ-LEADER-QS '(%DISK-RQ-LEADER-N-HWDS ;NUMBER HALFWORDS REALLY USED
+ ; ON FIRST PAGE BEFORE CCW LIST.
+ %DISK-RQ-LEADER-N-PAGES ;NUMBER OF BUFFER PAGES ALLOCATED
+ %DISK-RQ-LEADER-BUFFER ;DISPLACED ART-16B ARRAY TO BUFFER PGS
+ %DISK-RQ-LEADER-THREAD ;LINK TO NEXT FREE RQB
+ %DISK-RQ-LEADER-8-BIT-BUFFER)) ;DISPLACED ART-8B ARRAY.
+(cl:defvar DISK-RQ-HWDS '(%DISK-RQ-DONE-FLAG ;0 RQ ENTERED, -1 COMPLETED
+ %DISK-RQ-DONE-FLAG-HIGH
+ ;; These are set up by the requester
+ %DISK-RQ-COMMAND ;DISK COMMAND REGISTER
+ %DISK-RQ-COMMAND-HIGH
+ %DISK-RQ-CCW-LIST-POINTER-LOW ;CLP LOW 16
+ %DISK-RQ-CCW-LIST-POINTER-HIGH ;CLP HIGH 6
+ %DISK-RQ-SURFACE-SECTOR ;DISK ADDRESS REG LOW
+ %DISK-RQ-UNIT-CYLINDER ;DISK ADDRESS REG HIGH
+ ;; These are stored when the operation completes
+ %DISK-RQ-STATUS-LOW ;DISK STATUS REG LOW 16
+ %DISK-RQ-STATUS-HIGH ;DISK STATUS REG HIGH 16
+ %DISK-RQ-MEM-ADDRESS-LOW ;LAST MEM REF ADDR LOW 16
+ %DISK-RQ-MEM-ADDRESS-HIGH ;LAST MEM REF ADDR HIGH 6
+ %DISK-RQ-FINAL-SURFACE-SECTOR ;DISK ADDRESS REG LOW
+ %DISK-RQ-FINAL-UNIT-CYLINDER ;DISK ADDRESS REG HIGH
+ %DISK-RQ-ECC-POSITION
+ %DISK-RQ-ECC-PATTERN
+ %DISK-RQ-CCW-LIST)) ;CCW list customarily starts here
+(cl:defvar DISK-HARDWARE-VALUES '(
+ %%DISK-STATUS-HIGH-BLOCK-COUNTER 1010 %%DISK-STATUS-HIGH-INTERNAL-PARITY 0701
+ %%DISK-STATUS-HIGH-READ-COMPARE-DIFFERENCE 0601 %%DISK-STATUS-HIGH-CCW-CYCLE 0501
+ %%DISK-STATUS-HIGH-NXM 0401 %%DISK-STATUS-HIGH-MEM-PARITY 0301
+ %%DISK-STATUS-HIGH-HEADER-COMPARE 0201 %%DISK-STATUS-HIGH-HEADER-ECC 0101
+ %%DISK-STATUS-HIGH-ECC-HARD 0001
+ %DISK-STATUS-HIGH-ERROR 237 ;Mask for bits which are errors normally
+ %%DISK-STATUS-LOW-ECC-SOFT 1701 %%DISK-STATUS-LOW-OVERRUN 1601
+ %%DISK-STATUS-LOW-TRANSFER-ABORTED 1501 %%DISK-STATUS-LOW-START-BLOCK-ERROR 1401
+ %%DISK-STATUS-LOW-TIMEOUT 1301 %%DISK-STATUS-LOW-SEEK-ERROR 1201
+ %%DISK-STATUS-LOW-OFF-LINE 1101 %%DISK-STATUS-LOW-OFF-CYLINDER 1001
+ %%DISK-STATUS-LOW-READ-ONLY 0701 %%DISK-STATUS-LOW-FAULT 0601
+ %%DISK-STATUS-LOW-NO-SELECT 0501 %%DISK-STATUS-LOW-MULTIPLE-SELECT 0401
+ %%DISK-STATUS-LOW-INTERRUPT 0301 %%DISK-STATUS-LOW-SEL-UNIT-ATTENTION 0201
+ %%DISK-STATUS-LOW-ATTENTION 0101 %%DISK-STATUS-LOW-READY 0001
+ %DISK-STATUS-LOW-ERROR 177560 ;Mask for bits which are errors normally
+ %DISK-COMMAND-DONE-INTERRUPT-ENABLE #.(cl:ash 1 11.)
+ %DISK-COMMAND-ATTENTION-INTERRUPT-ENABLE #.(cl:ash 1 10.) ;Trident only
+ %DISK-COMMAND-RECALIBRATE 10001005
+ %DISK-COMMAND-FAULT-CLEAR 10000405 ;Recalibrate on Marksman
+ %DISK-COMMAND-DATA-STROBE-LATE 200 ;These are all different on Marksman
+ %DISK-COMMAND-DATA-STROBE-EARLY 100 ;..
+ %DISK-COMMAND-SERVO-OFFSET 40 ;..
+ %DISK-COMMAND-SERVO-OFFSET-FORWARD 20 ;..
+ %DISK-COMMAND-READ 0
+ %DISK-COMMAND-READ-COMPARE 10
+ %DISK-COMMAND-WRITE 11
+ %DISK-COMMAND-READ-ALL 2
+ %DISK-COMMAND-WRITE-ALL 13
+ %DISK-COMMAND-SEEK 20000004
+ %%DISK-COMMAND-SEEK-CYLINDER 3010 ;Only used by Marksman
+ %DISK-COMMAND-AT-EASE 5 ;Get status on Marksman
+ %DISK-COMMAND-OFFSET-CLEAR 6 ;NOP on marksman
+ %DISK-COMMAND-RESET-CONTROLLER 16))
+ ;Marksman also has get-status commands, not listed here.
+
+(ASSIGN-VALUES DISK-RQ-LEADER-QS 0)
+(ASSIGN-VALUES DISK-RQ-HWDS 0)
+(ASSIGN-ALTERNATE DISK-HARDWARE-VALUES)
+(cl:defvar DISK-HARDWARE-SYMBOLS (GET-ALTERNATE DISK-HARDWARE-VALUES))
+
+;;; Definitions for interrupt-driven Unibus input channels
+;;; Note that these start at 1 rather than at 0, to leave room for an array header
+
+(cl:defvar UNIBUS-CHANNEL-QS '(
+ %UNIBUS-CHANNEL-LINK ;Address of next or 0 to end list
+ %UNIBUS-CHANNEL-VECTOR-ADDRESS ;Interrupt vector address of device
+ %UNIBUS-CHANNEL-CSR-ADDRESS ;Virtual address of status register
+ %UNIBUS-CHANNEL-CSR-BITS ;Bits which must be on in CSR
+ %UNIBUS-CHANNEL-DATA-ADDRESS ;Virtual address of data register(s)
+ ;The %%Q-FLAG bit means there are 2 data regs
+ %UNIBUS-CHANNEL-BUFFER-START ;Start address of buffer
+ %UNIBUS-CHANNEL-BUFFER-END ;End address+1 of buffer
+ %UNIBUS-CHANNEL-BUFFER-IN-PTR ;Address of next word to store
+ ;The flag bit enables seq breaks per channel.
+ %UNIBUS-CHANNEL-BUFFER-OUT-PTR ;Address of next word to extract
+ ;**this last does not really exist now. It should be carried thru on the next cold load.
+ ; It is required for the non-local unibus hack to work in general, altho we can get along
+ ; without it for the time being since the keyboard is always interrupt enabled.**
+ %UNIBUS-CHANNEL-INTERRUPT-ENABLE-BITS ;Bit(s) in CSR which enable interrupts.
+ %UNIBUS-CHANNEL-OUTPUT-TURNOFF-ADDRESS ;Address to write to shut down output channel
+ %UNIBUS-CHANNEL-OUTPUT-TURNOFF-BITS)) ;Value to write into that address
+
+(ASSIGN-VALUES-INIT-DELTA UNIBUS-CHANNEL-QS 0 1 1)
+
+;;; Extra bits in the %UNIBUS-CHANNEL-CSR-BITS word.
+;;; Only the bottom 16 bits actually have to do with the device's CSR register
+;;; (which is only 16 bits long).
+(cl:defvar UNIBUS-CSR-BIT-VALUES '(
+ %%UNIBUS-CSR-OUTPUT 2001 ;This is an output device.
+ %%UNIBUS-CSR-TIMESTAMPED 2101 ;Store timestamp with each input char;
+ ; for output, delay till timestamp is reached.
+ %%UNIBUS-CSR-TWO-DATA-REGISTERS 2201 ;Device has two 16-bit data registers;
+ ; assume lower unibus addr has low bits.
+ %%UNIBUS-CSR-SB-ENABLE 2301 ;Enable sequence break (input only).
+ %%UNIBUS-CSR-SET-BITS-P 2401 ;** %UNIBUS-CHANNEL-CSR-SET-BITS is
+ ; significant.
+ %%UNIBUS-CSR-CLEAR-BITS-P 2501 ;** %UNIBUS-CHANNEL-CSR-CLEAR-BITS is
+ ; significant.
+ ))
+(ASSIGN-ALTERNATE UNIBUS-CSR-BIT-VALUES)
+
+(cl:defvar UNIBUS-CSR-BITS '(
+ %%UNIBUS-CSR-OUTPUT
+ %%UNIBUS-CSR-TIMESTAMPED
+ %%UNIBUS-CSR-TWO-DATA-REGISTERS
+ %%UNIBUS-CSR-SB-ENABLE
+ %%UNIBUS-CSR-SET-BITS-P
+ %%UNIBUS-CSR-CLEAR-BITS-P
+ ))
+
+;;; Definitions for Chaos net hardware and microcode
+
+;;; Command/Status register fields
+
+(cl:defvar CHAOS-HARDWARE-VALUES '(
+ %%CHAOS-CSR-TIMER-INTERRUPT-ENABLE 0001
+ %%CHAOS-CSR-LOOP-BACK 0101
+ %%CHAOS-CSR-RECEIVE-ALL 0201
+ %%CHAOS-CSR-RECEIVER-CLEAR 0301
+ %%CHAOS-CSR-RECEIVE-ENABLE 0401
+ %%CHAOS-CSR-TRANSMIT-ENABLE 0501
+ %%CHAOS-CSR-INTERRUPT-ENABLES 0402
+ %%CHAOS-CSR-TRANSMIT-ABORT 0601
+ %%CHAOS-CSR-TRANSMIT-DONE 0701
+ %%CHAOS-CSR-TRANSMITTER-CLEAR 1001
+ %%CHAOS-CSR-LOST-COUNT 1104
+ %%CHAOS-CSR-RESET 1501
+ %%CHAOS-CSR-CRC-ERROR 1601
+ %%CHAOS-CSR-RECEIVE-DONE 1701
+
+;;; Offsets of other registers from CSR
+;;; These are in words, not bytes
+
+ %CHAOS-MY-NUMBER-OFFSET 1
+ %CHAOS-WRITE-BUFFER-OFFSET 1
+ %CHAOS-READ-BUFFER-OFFSET 2
+ %CHAOS-BIT-COUNT-OFFSET 3
+ %CHAOS-START-TRANSMIT-OFFSET 5))
+
+;;; Leader of a wired Chaos buffer
+
+(cl:defvar CHAOS-BUFFER-LEADER-QS '(
+ %CHAOS-LEADER-WORD-COUNT ;Fill pointer for ART-16B array
+ %CHAOS-LEADER-THREAD ;Next buffer in wired list (free, rcv, xmt)
+ ;NIL for end of list
+ %CHAOS-LEADER-CSR-1 ;Receive stores CSR before reading out here
+ %CHAOS-LEADER-CSR-2 ;Receive stores CSR after reading out here
+ ;Get lost-count from here
+ %CHAOS-LEADER-BIT-COUNT)) ;Receive stores bit-count before reading out
+
+(ASSIGN-VALUES CHAOS-BUFFER-LEADER-QS 0)
+(ASSIGN-ALTERNATE CHAOS-HARDWARE-VALUES)
+(cl:defvar CHAOS-HARDWARE-SYMBOLS (GET-ALTERNATE CHAOS-HARDWARE-VALUES))
+
+;;; Ethernet
+
+;;; Offsets from the base of the ether registers to the specific registers
+(cl:defvar ether-register-offsets '(
+ %ether-mode-offset ;0
+ %ether-int-source-offset ;1
+ %ether-int-mask-offset ;2
+ %ether-ipgt-offset ;3
+ %ether-ipgr1-offset ;4
+ %ether-ipgr2-offset ;5
+ %ether-packetlen-offset ;6
+ %ether-collconf-offset ;7
+ %ether-tx-bd-num-offset ;8
+ %ether-ctrlmode-offset ;9
+ %ether-mii-mode-offset ;10
+ %ether-mii-command-offset ;11
+ %ether-mii-address-offset ;12
+ %ether-mii-tx-data-offset ;13
+ %ether-mii-rx-data-offset ;14
+ %ether-mii-status-offset ;15
+ %ether-mac-address0-offset ;16
+ %ether-mac-address1-offset ;17
+ %ether-hash0-offset ;18
+ %ether-hash1-offset ;19
+ %ether-txctrl-offset ;20
+ ))
+(assign-values ether-register-offsets 0)
+
+;;; Offsets of the leader elements
+(cl:defvar ether-buffer-leader-qs '(
+ %ether-leader-thread ;0
+ %ether-leader-active-length ;1
+ ))
+(assign-values ether-buffer-leader-qs 0)
+
+(cl:defvar ether-hardware-values '(
+ %%ether-desc-length 2020
+ %%ether-desc-tx-ready 1701
+ %%ether-desc-tx-irq 1601
+ %%ether-desc-tx-wrap 1501
+ %%ether-desc-tx-pad 1401
+ %%ether-desc-tx-crc 1301
+
+ %%ether-desc-rx-empty 1701
+ %%ether-desc-rx-irq 1601
+ %%ether-desc-rx-wrap 1501
+
+ %%ether-mode-recsmall 2001
+ %%ether-mode-pad 1701
+ %%ether-mode-hugen 1601
+ %%ether-mode-crc-enable 1501
+ %%ether-mode-fullduplex 1201
+ %%ether-mode-promiscuous 0501
+ %%ether-mode-no-preamble 0201
+ %%ether-mode-tx-enable 0101
+ %%ether-mode-rx-enable 0001
+
+ %%ether-int-rxc 0601
+ %%ether-int-txc 0501
+ %%ether-int-busy 0401
+ %%ether-int-rxe 0301
+ %%ether-int-rxb 0201
+ %%ether-int-txe 0101
+ %%ether-int-txb 0001
+ ))
+
+(assign-alternate ether-hardware-values)
+(cl:defvar ether-hardware-symbols (get-alternate ether-hardware-values))
+
+
+(cl:defvar A-MEMORY-ARRAY-LOCATIONS '(
+ MOUSE-CURSOR-PATTERN 1600
+ MOUSE-BUTTONS-BUFFER 1640
+ MOUSE-X-SCALE-ARRAY 1700
+ MOUSE-Y-SCALE-ARRAY 1720))
+
+(cl:defvar A-MEMORY-ARRAY-SYMBOLS (GET-ALTERNATE A-MEMORY-ARRAY-LOCATIONS))
+
+
+;Use of DTP-INSTANCE. Points to a structure whose header is of
+;type DTP-INSTANCE-HEADER; the pointer field of that header points
+;to a structure (generally an array) which contains the fields described
+;below. This structure is called an instance-descriptor and contains
+;the constant or shared part of the instance. The instance structure,
+;after its DTP-INSTANCE-HEADER, contains several words used as value
+;cells of instance variables, which are the variable or unshared
+;part of the instance.
+;Note that these are offsets, not indices into the array. They
+;are defined here this way because microcode uses them. This could
+;be a cdr-coded list or an instance rather than an array.
+(cl:defvar INSTANCE-DESCRIPTOR-OFFSETS '(
+ %INSTANCE-DESCRIPTOR-HEADER ;The array header.
+ %INSTANCE-DESCRIPTOR-RESERVED ;e.g. for named-structure symbol
+ %INSTANCE-DESCRIPTOR-SIZE ;The size of the instance; this is one more
+ ;than the number of instance-variable slots.
+ ;This is looked at by the garbage collector.
+ %INSTANCE-DESCRIPTOR-BINDINGS
+ ;Describes bindings to perform when the instance
+ ;is called. If this is a list, then SELF is bound
+ ;to the instance and the elements of the list are
+ ;locatives to cells which are bound to EVCP's
+ ;to successive instance-variable slots of the
+ ;instance. If this is not a list, it is something
+ ;reserved for future facilities based on the same
+ ;primitives. NIL is a list.
+ ;Note that if this is a list, it must be CDR-CODED!
+ ;The microcode depends on this for a little extra speed.
+ %INSTANCE-DESCRIPTOR-FUNCTION ;Function to be called when the instance
+ ; is called. Typically a DTP-SELECT-METHOD
+ %INSTANCE-DESCRIPTOR-TYPENAME ;A symbol which is returned by TYPEP
+)) ;Additional slots may exist, defined by the particular class system employed.
+ ;If the instance-descriptor is an array, it must not be so long as to
+ ;contain a long-length Q.
+(ASSIGN-VALUES INSTANCE-DESCRIPTOR-OFFSETS 0)
+
+(cl:defvar METER-ENABLES-VALUES '(
+ %%METER-PAGE-FAULT-ENABLE 0001 ;Page fault metering
+ %%METER-CONS-ENABLE 0101 ;Cons metering
+ %%METER-FUNCTION-ENTRY-EXIT-ENABLE 0201 ;Function call metering
+ %%METER-STACK-GROUP-SWITCH-ENABLE 0301 ;Stack group metering
+ ))
+
+(cl:defvar METER-EVENTS '(
+ %METER-PAGE-IN-EVENT
+ %METER-PAGE-OUT-EVENT
+ %METER-CONS-EVENT
+ %METER-FUNCTION-ENTRY-EVENT
+ %METER-FUNCTION-EXIT-EVENT
+ %METER-FUNCTION-UNWIND-EVENT
+ %METER-STACK-GROUP-SWITCH-EVENT
+ ))
+
+(ASSIGN-ALTERNATE METER-ENABLES-VALUES)
+(cl:defvar METER-ENABLES (GET-ALTERNATE METER-ENABLES-VALUES))
+(ASSIGN-VALUES METER-EVENTS 0 1)
+
+(cl:DEFUN ASSIGN-QCOM-VALUES ()
+ (ASSIGN-VALUES ADI-KINDS 0)
+ (ASSIGN-VALUES ADI-STORING-OPTIONS 0)
+ (ASSIGN-ALTERNATE ARG-DESC-FIELD-VALUES)
+ (ASSIGN-ALTERNATE ARRAY-FIELD-VALUES)
+ (ASSIGN-ALTERNATE ARRAY-LEADER-FIELD-VALUES)
+ (ASSIGN-ALTERNATE ARRAY-MISC-VALUES)
+ (ASSIGN-VALUES ARRAY-TYPES 19.)
+ (ASSIGN-VALUES DATA-TYPES 24.)
+ (ASSIGN-VALUES FEF-ARG-SYNTAX 4)
+ (ASSIGN-VALUES FEF-DES-DT 11)
+ (ASSIGN-VALUES FEF-FUNCTIONAL 15)
+ (ASSIGN-VALUES FEF-INIT-OPTION 0)
+ (ASSIGN-VALUES FEF-NAME-PRESENT 20)
+ (ASSIGN-VALUES FEF-QUOTE-STATUS 7)
+ (ASSIGN-VALUES FEF-SPECIALNESS 16)
+ (ASSIGN-VALUES FEFHI-INDEXES 0)
+ (ASSIGN-ALTERNATE FEFHI-VALUES)
+ (ASSIGN-ALTERNATE HEADER-FIELD-VALUES)
+ (ASSIGN-VALUES HEADER-TYPES 23)
+ (ASSIGN-VALUES Q-CDR-CODES 0)
+ (ASSIGN-VALUES Q-DATA-TYPES 0)
+ (ASSIGN-VALUES Q-HEADER-TYPES 0)
+ (ASSIGN-ALTERNATE SG-STATE-FIELD-VALUES)
+ (ASSIGN-VALUES SG-STATES 0)
+ (ASSIGN-VALUES SG-INST-DISPATCHES 0)
+ (ASSIGN-VALUES SPECIAL-PDL-LEADER-QS 0)
+ (ASSIGN-VALUES STACK-GROUP-HEAD-LEADER-QS 0)
+ (ASSIGN-VALUES SYSTEM-COMMUNICATION-AREA-QS 0)
+ (ASSIGN-VALUES REG-PDL-LEADER-QS 0)
+ )
+
+(ASSIGN-QCOM-VALUES) ;FOO. ASSIGN-VALUES, ETC HAD BETTER BE DEFINED.
Added: trunk/tools/cold/qcom90.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/qcom90.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,1186 @@
+;-*-MODE:LISP; BASE:8; PACKAGE:SYSTEM-INTERNALS -*-
+
+; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+;LOADING THIS WITH A BASE OF OTHER THAN 8 CAN REALLY CAUSE BIZARRE EFFECTS
+;(OR (= IBASE 8) (BREAK IBASE-NOT-8))
+
+(cl:defvar AREA-LIST '(
+ RESIDENT-SYMBOL-AREA ;T AND NIL
+ SYSTEM-COMMUNICATION-AREA ;USED BY PAGING, CONSOLE, PDP10 I/O, ETC.
+ SCRATCH-PAD-INIT-AREA ;LOAD MICRO CODE VARIABLES UPON STARTUP
+ MICRO-CODE-SYMBOL-AREA ;600 QS MISC DISPATCH, UCODE ENTRY DISPATCH
+ PAGE-TABLE-AREA ;PAGE HASH TABLE
+ PHYSICAL-PAGE-DATA ;GC DATA,,PHT INDEX
+ ;-1 IF OUT OF SERVICE
+ ;PHT-INDEX=-1 IF FIXED-WIRED (NO PHT ENTRY)
+ ;GC-DATA=0 IF NOT IN USE
+ REGION-ORIGIN ;FIXNUM BASE ADDRESS INDEXED BY REGION #
+ REGION-LENGTH ;FIXNUM LENGTH INDEXED BY REGION #
+ REGION-BITS ;FIXNUM, SEE %%REGION- SYMS FOR FIELDS
+ ADDRESS-SPACE-MAP ;SEE %ADDRESS-SPACE-MAP-BYTE-SIZE BELOW
+ ;END WIRED AREAS
+ REGION-FREE-POINTER ;FIXNUM, RELATIVE ALLOCATION POINT.
+ REGION-GC-POINTER ;GC USE, MAINLY RELATIVE DIRTY/CLEAN BOUNDARY
+ REGION-LIST-THREAD ;NEXT REGION# IN AREA, OR 1_23.+AREA#
+ ; THREADS FREE REGION SLOTS, TOO.
+ AREA-NAME ;ATOMIC NAME INDEXED BY AREA #
+ AREA-REGION-LIST ;FIRST REGION# IN AREA
+ AREA-REGION-SIZE ;RECOMMENDED SIZE FOR NEW REGIONS
+ AREA-MAXIMUM-SIZE ;APPROXIMATE MAXIMUM #WDS ALLOWED IN THIS AREA
+ AREA-SWAP-RECOMMENDATIONS ;FIXNUM, SEE %%AREA-SWAP- SYMS FOR FIELDS
+ GC-TABLE-AREA ;GARBAGE COLLECTOR TABLES
+ SUPPORT-ENTRY-VECTOR ;CONSTANTS NEEDED BY BASIC MICROCODE
+ CONSTANTS-AREA ;COMMON CONSTANTS USED BY MACROCODE
+ EXTRA-PDL-AREA ;SEPARATELY GC-ABLE AREA, MAINLY EXTENDED NUMS
+ ; MUST BE RIGHT BEFORE MICRO-CODE-ENTRY-AREA
+ MICRO-CODE-ENTRY-AREA ;MICRO ENTRY ADDRESS
+ ;OR LOCATIVE INDIRECT MICRO-CODE-SYMBOL-AREA
+ MICRO-CODE-ENTRY-NAME-AREA ;MICRO ENTRY NAME
+ MICRO-CODE-ENTRY-ARGS-INFO-AREA ;MICRO ENTRY %ARGS-INFO
+ MICRO-CODE-ENTRY-MAX-PDL-USAGE ;MICRO ENTRY PDL DEPTH INCL MICRO-MICRO CALLS
+ ;AREAS AFTER HERE ARE NOT "INITIAL", NOT KNOWN SPECIALLY BY MICROCODE
+ MICRO-CODE-ENTRY-ARGLIST-AREA ;VALUE FOR ARGLIST FUNCTION TO RETURN
+ MICRO-CODE-SYMBOL-NAME-AREA ;NAMES OF MICRO-CODE-SYMBOL-AREA ENTRIES
+ LINEAR-PDL-AREA ;MAIN PDL
+ LINEAR-BIND-PDL-AREA ;CORRESPONDING BIND PDL
+ INIT-LIST-AREA ;LIST CONSTANTS CREATED BY COLD LOAD
+ ;END FIXED AREAS, WHICH MUST HAVE ONLY ONE REGION
+ WORKING-STORAGE-AREA ;ORDINARY CONSING HAPPENS HERE
+ PERMANENT-STORAGE-AREA ;PUT "PERMANENT" DATA STRUCTURES HERE
+ PROPERTY-LIST-AREA ;EXISTS FOR PAGING REASONS
+ P-N-STRING ;PRINT NAMES AND STRINGS
+ CONTROL-TABLES ;OBARRAY, READTABLE (SEMI-OBSOLETE)
+ OBT-TAILS ;OBARRAY BUCKET CONSES (SEMI-OBSOLETE)
+ NR-SYM ;SYMBOLS NOT IN RESIDENT-SYMBOL-AREA
+ MACRO-COMPILED-PROGRAM ;MACRO CODE LOADED HERE
+ PDL-AREA ;PUT STACK-GROUP REGULAR-PDLS HERE
+ FASL-TABLE-AREA ;FASLOAD'S TABLE IS HERE
+ FASL-TEMP-AREA ;FASLOAD TEMPORARY CONSING
+ FASL-CONSTANTS-AREA ;FASLOAD LOADS CONSTANTS HERE
+ ))
+
+;Assuming no more than 256 regions
+(cl:defvar %ADDRESS-SPACE-MAP-BYTE-SIZE 10)
+(cl:defvar %ADDRESS-SPACE-QUANTUM-SIZE 40000)
+;Each quantum has a byte in the ADDRESS-SPACE-MAP area,
+;which is the region number, or 0 if free or fixed area.
+;INIT-LIST-AREA is the last fixed area.
+
+ ;THESE AREAS ARE ENCACHED IN THE PDL BUFFER.
+(cl:defvar PDL-BUFFER-AREA-LIST '(
+ LINEAR-PDL-AREA ;MAIN PDL
+ PDL-AREA ;PDLS FOR MISC STACK GROUPS
+))
+
+ ;NOTE THAT AT PRESENT ALL AREAS UP THROUGH ADDRESS-SPACE-MAP MUST BE WIRED.
+ ;THE REASON IS THAT WHEN THE MICROCODE STARTS UP IT STRAIGHT-MAPS THAT
+ ;AMOUNT OF VIRTUAL MEMORY, WITHOUT CHECKING SEPARATELY FOR EACH PAGE.
+ ;IT WOULD LOSE BIG IF ONE OF THOSE STRAIGHT-MAPPED PAGES GOT SWAPPED OUT.
+ ;EXCEPT, UNUSED PORTIONS OF PAGE-TABLE-AREA AND PHYSICAL-PAGE-DATA GET UNWIRED
+(cl:defvar WIRED-AREA-LIST '( ;AREAS THAT MAY NOT BE MOVED NOR SWAPPED OUT
+ RESIDENT-SYMBOL-AREA ;NO GOOD REASON
+ SYSTEM-COMMUNICATION-AREA ;FOR CONSOLE, PDP10, MICRO INTERRUPT, ETC.
+ SCRATCH-PAD-INIT-AREA ;LOAD MICRO CODE VARIABLES UPON STARTUP
+ MICRO-CODE-SYMBOL-AREA ;NO GOOD REASON, ACTUALLY
+ PAGE-TABLE-AREA ;USED BY PAGE FAULT HANDLER
+ PHYSICAL-PAGE-DATA ;USED BY PAGE FAULT HANDLER
+ REGION-ORIGIN ;USED BY PAGE FAULT HANDLER
+ REGION-LENGTH ;USED BY PAGE FAULT HANDLER
+ REGION-BITS ;USED BY PAGE FAULT HANDLER
+ ADDRESS-SPACE-MAP ;USED BY PAGE FAULT HANDLER
+))
+
+;THIS LIST ISN'T NECESSARILY UP TO DATE. FEATURE ISN'T REALLY USED YET.
+(cl:defvar READ-ONLY-AREA-LIST '( ;AREAS TO BE SET UP READ ONLY BY COLD LOAD
+ SCRATCH-PAD-INIT-AREA
+ MICRO-CODE-SYMBOL-AREA
+ SUPPORT-ENTRY-VECTOR
+ CONSTANTS-AREA
+ INIT-LIST-AREA
+ MICRO-CODE-SYMBOL-NAME-AREA
+))
+
+(cl:defvar COLD-LOAD-AREA-SIZES ;DEFAULT AREA SIZE IS ONE PAGE
+ '(P-N-STRING 600 OBT-TAILS 100 NR-SYM 500 MACRO-COMPILED-PROGRAM 1000
+ PAGE-TABLE-AREA 128. ;ENOUGH FOR 2 MEGAWORDS OF MAIN MEMORY
+ PHYSICAL-PAGE-DATA 32. ;ENOUGH FOR 2 MEGAWORDS OF MAIN MEMORY
+ ADDRESS-SPACE-MAP 1 ;ASSUMING 8-BIT BYTES
+ GC-TABLE-AREA 400 ;64K
+ LINEAR-PDL-AREA 100 LINEAR-BIND-PDL-AREA 10 PDL-AREA 300
+ WORKING-STORAGE-AREA 400 PERMANENT-STORAGE-AREA 200 PROPERTY-LIST-AREA 100
+ CONTROL-TABLES 13 INIT-LIST-AREA 64
+ MICRO-CODE-ENTRY-AREA 2 MICRO-CODE-ENTRY-NAME-AREA 2
+ MICRO-CODE-ENTRY-ARGS-INFO-AREA 2 MICRO-CODE-ENTRY-ARGLIST-AREA 2
+ MICRO-CODE-ENTRY-MAX-PDL-USAGE 2
+ MICRO-CODE-SYMBOL-NAME-AREA 2 MICRO-CODE-SYMBOL-AREA 2
+ FASL-TABLE-AREA 201 ;3 TIMES LENGTH-OF-FASL-TABLE PLUS 1 PAGE
+ FASL-CONSTANTS-AREA 600 EXTRA-PDL-AREA 10
+ FASL-TEMP-AREA 40))
+
+(cl:defvar COLD-LOAD-REGION-SIZES ;DEFAULT REGION SIZE IS 16K
+ '(WORKING-STORAGE-AREA 400000 MACRO-COMPILED-PROGRAM 200000
+ P-N-STRING 200000 NR-SYM 200000 FASL-CONSTANTS-AREA 200000
+ PROPERTY-LIST-AREA 200000))
+
+;In the cold-load, areas have only one region, so you can only use one
+;representation type per area. These are the list areas, the rest are structure areas.
+(cl:defvar LIST-STRUCTURED-AREAS '(
+ SYSTEM-COMMUNICATION-AREA SCRATCH-PAD-INIT-AREA MICRO-CODE-SYMBOL-AREA
+ PAGE-TABLE-AREA PHYSICAL-PAGE-DATA REGION-ORIGIN REGION-LENGTH
+ REGION-BITS REGION-FREE-POINTER REGION-GC-POINTER
+ REGION-LIST-THREAD AREA-NAME AREA-REGION-LIST AREA-REGION-SIZE
+ AREA-MAXIMUM-SIZE AREA-SWAP-RECOMMENDATIONS SUPPORT-ENTRY-VECTOR CONSTANTS-AREA
+ MICRO-CODE-ENTRY-AREA MICRO-CODE-ENTRY-NAME-AREA
+ MICRO-CODE-ENTRY-ARGS-INFO-AREA MICRO-CODE-ENTRY-MAX-PDL-USAGE
+ MICRO-CODE-ENTRY-ARGLIST-AREA
+ MICRO-CODE-SYMBOL-NAME-AREA INIT-LIST-AREA PROPERTY-LIST-AREA
+ OBT-TAILS FASL-CONSTANTS-AREA
+))
+
+(cl:defvar STATIC-AREAS '( ;not including Fixed areas
+ INIT-LIST-AREA PERMANENT-STORAGE-AREA P-N-STRING CONTROL-TABLES
+ NR-SYM MACRO-COMPILED-PROGRAM
+ FASL-TABLE-AREA FASL-TEMP-AREA FASL-CONSTANTS-AREA
+))
+
+; Numeric values of data types, shifted over into the data type field,
+; suitable for being added to the pointer to produce the contents of a Q.
+; These do NOT go into the cold load.
+; What are these used for nowadays? They are not used in UCADR. -- RMS
+(cl:defvar DATA-TYPES '(QZTRAP QZNULL QZFREE ;ERRORS
+ QZSYM QZSYMH QZFIX QZXNUM ;ORDINARY ATOMS
+ QZHDR
+ QZGCF QZEVCP QZ1QF QZHF QXBF ;FORWARDS
+ QZLOC ;LOCATIVES
+ QZLIST ;LISTS
+ QZUENT ;FUNCTIONS, ETC...
+ QZFEFP QZARYP QZARYH ;...
+ QZSTKG QZCLOS
+ QZSFLO QZSMTH QZINST QZINSH QZENTY QZSCLS
+ ))
+
+; Numeric values of data types, suitable for being DPB'd into the
+; data type field, or returned by (%DATA-TYPE ...).
+(cl:defvar Q-DATA-TYPES '(DTP-TRAP DTP-NULL DTP-FREE
+ DTP-SYMBOL DTP-SYMBOL-HEADER DTP-FIX DTP-EXTENDED-NUMBER DTP-HEADER
+ DTP-GC-FORWARD DTP-EXTERNAL-VALUE-CELL-POINTER DTP-ONE-Q-FORWARD
+ DTP-HEADER-FORWARD DTP-BODY-FORWARD
+ DTP-LOCATIVE
+ DTP-LIST
+ DTP-U-ENTRY
+ DTP-FEF-POINTER DTP-ARRAY-POINTER DTP-ARRAY-HEADER
+ DTP-STACK-GROUP DTP-CLOSURE DTP-SMALL-FLONUM DTP-SELECT-METHOD
+ DTP-INSTANCE DTP-INSTANCE-HEADER DTP-ENTITY
+ DTP-STACK-CLOSURE
+ ))
+
+; Numeric values of CDR codes, right-justified in word for %P-CDR-CODE, etc.
+(cl:defvar Q-CDR-CODES '(CDR-NORMAL CDR-ERROR CDR-NIL CDR-NEXT))
+
+; Byte pointers at the parts of a Q or other thing, and their values.
+; Q-FIELD-VALUES does NOT itself go into the cold load.
+(cl:defvar Q-FIELD-VALUES '(%%Q-CDR-CODE 3602
+ %%Q-DATA-TYPE 3105 %%Q-POINTER 0031 %%Q-POINTER-WITHIN-PAGE 0010
+ %%Q-TYPED-POINTER 0036 %%Q-ALL-BUT-TYPED-POINTER 3602
+ %%Q-ALL-BUT-POINTER 3107 %%Q-ALL-BUT-CDR-CODE 0036
+ %%Q-HIGH-HALF 2020 %%Q-LOW-HALF 0020 ;USE THESE FOR REFERENCING MACRO INSTRUCTIONS
+ %%CH-FONT 1010 %%CH-CHAR 0010 ;FIELDS IN A 16-BIT CHARACTER
+ %%KBD-CHAR 0010 %%KBD-CONTROL-META 1004
+ %%KBD-CONTROL 1001 %%KBD-META 1101 %%KBD-SUPER 1201 %%KBD-HYPER 1301
+ %%KBD-MOUSE 1701 %%KBD-MOUSE-BUTTON 0003 %%KBD-MOUSE-N-CLICKS 0303))
+
+; Assign the byte pointers their values. Q-FIELDS becomes a list of just names.
+; It goes into the cold load, along with the names and their values.
+(ASSIGN-ALTERNATE Q-FIELD-VALUES)
+(cl:defvar Q-FIELDS (GET-ALTERNATE Q-FIELD-VALUES))
+
+;(cl:defvar %Q-FLAG-BIT (DPB -1 %%Q-FLAG-BIT 0)) ;USED BY QLF IN COLD MODE
+
+;;; Stuff in the REGION-BITS array, some of these bits also appear in the
+;;; map in the same orientation.
+
+(cl:defvar Q-REGION-BITS-VALUES '(
+ %%REGION-MAP-BITS 1612 ;10 bits to go into the map (access/status/meta)
+ ;2404 ;access and status bits
+ %%REGION-OLDSPACE-META-BIT 2301 ;0=old or free, 1=new or static or fixed.
+ ;0 causes transport-trap for read of ptr to here
+ %%REGION-EXTRA-PDL-META-BIT 2201 ;0=extra-pdl, 1=normal.
+ ;0 traps writing of ptr to here into "random" mem
+ %%REGION-REPRESENTATION-TYPE 2002 ;Data representation type code:
+ %REGION-REPRESENTATION-TYPE-LIST 0
+ %REGION-REPRESENTATION-TYPE-STRUCTURE 1 ;2 and 3 reserved for future
+ ;1602 spare meta bits
+ ;1501 spare (formerly unimplemented compact-cons flag)
+ %%REGION-SPACE-TYPE 1104 ;Code for type of space:
+ %REGION-SPACE-FREE 0 ;0 free region slot
+ %REGION-SPACE-OLD 1 ;1 oldspace region of dynamic area
+ %REGION-SPACE-NEW 2 ;2 permanent newspace region of dynamic area
+ %REGION-SPACE-NEW1 3 ;3 temporary space, level 1
+ %REGION-SPACE-NEW2 4 ;4 ..
+ %REGION-SPACE-NEW3 5 ;5 ..
+ %REGION-SPACE-NEW4 6 ;6 ..
+ %REGION-SPACE-NEW5 7 ;7 ..
+ %REGION-SPACE-NEW6 10 ;10 ..
+ %REGION-SPACE-STATIC 11 ;11 static area
+ %REGION-SPACE-FIXED 12 ;12 fixed, static+not growable+no consing allowed
+ %REGION-SPACE-EXTRA-PDL 13 ;13 An extra-pdl for some stack-group
+ %REGION-SPACE-COPY 14 ;14 Like newspace, stuff copied from oldspace goes
+ ; here while newly-consed stuff goes to newspace
+ ; This is for permanent data
+ ;15-17 [not used]
+
+ %%REGION-SCAVENGE-ENABLE 1001 ;If 1, scavenger touches this region
+ ;0503 spare bits.
+ %%REGION-SWAPIN-QUANTUM 0005 ;swap this +1 pages in one disk op on swapin
+ ; if possible.
+))
+
+(ASSIGN-ALTERNATE Q-REGION-BITS-VALUES)
+(cl:defvar Q-REGION-BITS (GET-ALTERNATE Q-REGION-BITS-VALUES))
+
+(cl:defvar Q-AREA-SWAP-BITS-VALUES '(
+ %%AREA-SWAP-SWAPIN-TRANSFER-SIZE 0006 ;# of pages to bring in with single disk
+ ; op if possible. 0 says always 1.
+ ; Otherwise this is a base number which
+ ; may be further increased in
+ ; context-switch mode.
+ ))
+
+(ASSIGN-ALTERNATE Q-AREA-SWAP-BITS-VALUES)
+(cl:defvar Q-AREA-SWAP-BITS (GET-ALTERNATE Q-AREA-SWAP-BITS-VALUES))
+
+(cl:defvar SYSTEM-COMMUNICATION-AREA-QS '( ;LOCATIONS RELATIVE TO 400 IN CADR
+ ;locations 400-437 are miscellaneous Qs declared below
+ ;locations 440-477 are the reverse first level map
+ ;locations 500-511 are the keyboard buffer header (buffer is 200-377)
+ ;locations 600-637 are the disk-error log
+ ;locations 700-777 are reserved for disk CCW's (only 777 used now)
+ ;In CADR, location 777 is used (for now) by the disk code for the CCW.
+ ; --actually it seems to use locations 12-377 for the CCW most of the time.
+ %SYS-COM-AREA-ORIGIN-PNTR ;ADDRESS OF AREA-ORIGIN AREA
+ %SYS-COM-VALID-SIZE ;IN A SAVED BAND, NUMBER OF WORDS USED
+ %SYS-COM-PAGE-TABLE-PNTR ;ADDRESS OF PAGE-TABLE-AREA
+ %SYS-COM-PAGE-TABLE-SIZE ;NUMBER OF QS
+ %SYS-COM-OBARRAY-PNTR ;CURRENT OBARRAY, COULD BE AN ARRAY-POINTER
+ ;BUT NOW IS USUALLY A SYMBOL WHOSE VALUE
+ ;IS THE CURRENTLY-SELECTED OBARRAY (PACKAGE)
+ ;Ether net interrupt-handler variables
+ %SYS-COM-ETHER-FREE-LIST
+ %SYS-COM-ETHER-TRANSMIT-LIST
+ %SYS-COM-ETHER-RECEIVE-LIST
+
+ %SYS-COM-BAND-FORMAT ;In a saved band, encodes format number.
+ ; 1000 -> new compressed format
+ ; otherwise old expanded format.
+ ;In old bands, this is not really initialized
+ ; but is usually 410.
+
+ %SYS-COM-GC-GENERATION-NUMBER ;reserved for value of %GC-GENERATION-NUMBER
+
+ %SYS-COM-UNIBUS-INTERRUPT-LIST ;SEE LMIO;UNIBUS (LIST OF UNIBUS CHANNELS)
+
+ %SYS-COM-TEMPORARY ;MICROCODE BASHES THIS AT EXTRA-PDL-PURGE
+
+ %SYS-COM-FREE-AREA#-LIST ;THREADED THROUGH AREA-REGION-LIST, END=0
+ %SYS-COM-FREE-REGION#-LIST ;THREADED THROUGH REGION-LIST-THREAD, END=0
+ %SYS-COM-MEMORY-SIZE ;NUMBER OF WORDS OF MAIN MEMORY
+ %SYS-COM-WIRED-SIZE ;# WORDS OF LOW MEMORY WIRED DOWN
+ ;NOT ALL OF THESE WORDS ARE WIRED, THIS
+ ;IS REALLY THE VIRTUAL ADDRESS OF THE START
+ ;OF NORMAL PAGEABLE MEMORY
+
+ ;Chaos net interrupt-handler variables
+ %SYS-COM-CHAOS-FREE-LIST
+ %SYS-COM-CHAOS-TRANSMIT-LIST
+ %SYS-COM-CHAOS-RECEIVE-LIST
+
+ ;Debugger locations (*** these seem not to be used ***)
+ %SYS-COM-DEBUGGER-REQUESTS ;REQUEST TO POWER CONTROL/DEBUGGER
+ %SYS-COM-DEBUGGER-KEEP-ALIVE ;KEEP ALIVE FLAG WORD
+ %SYS-COM-DEBUGGER-DATA-1 ;FOR INTERCOMMUNICATION
+ %SYS-COM-DEBUGGER-DATA-2
+
+ ;*** This does not appear to be initialized or used
+ %SYS-COM-MAJOR-VERSION ;MAJOR COLD LOAD VERSION AS FIXNUM. AVAILABLE TO
+ ; MICROCODE FOR DOWNWARD COMPATIBILITY.
+ %SYS-COM-DESIRED-MICROCODE-VERSION ;Microcode version this world expects
+ ;TO BE ADDED:
+ ;SWAP OUT SCHEDULER AND DISK STUFF
+ ;EVENTUALLY THIS MAY REPLACE SCRATCH-PAD-INIT-AREA
+ ;THOSE OF THESE THAT DON'T NEED TO SURVIVE WARM BOOT COULD BE IN A-MEMORY
+ %SYS-COM-HIGHEST-VIRTUAL-ADDRESS ;In new band format. You better have this amt of
+ ; room in the paging partition.
+ %SYS-COM-POINTER-WIDTH ;Either 24 or 25, as fixnum, or DTP-FREE in old sys.
+ ;; 6 left
+))
+
+;(AND (> (LENGTH SYSTEM-COMMUNICATION-AREA-QS) 40)
+; (ERROR '|SYSTEM COMMUNICATION AREA OVERFLOW|))
+
+(cl:defvar NEW-ARRAY-INDEX-ORDER cl:NIL)
+
+;;; Next three symbols are treated bletcherously, because there isnt the right kind of
+;;; LDB available
+
+;VIRTUAL ADDRESS OF 0 at A. MUST AGREE WITH VALUE IN UCADR.
+;(unfortunately called LOWEST-A-MEM-VIRTUAL-ADDRESS).
+(cl:defvar A-MEMORY-VIRTUAL-ADDRESS #o76776000) ; (%P-LDB-OFFSET 0030 76776000 1))
+
+;Virtual address of X-BUS IO space.
+;Must agree with LOWEST-IO-SPACE-VIRTUAL-ADDRESS in UCADR.
+(cl:defvar IO-SPACE-VIRTUAL-ADDRESS #o77000000) ;(%P-LDB-OFFSET 0030 77000000 1))
+
+;Virtual address of UNIBUS IO space.
+;Must agree with LOWEST-UNIBUS-VIRTUAL-ADDRESS in UCADR.
+(cl:defvar UNIBUS-VIRTUAL-ADDRESS #o77400000) ; (%P-LDB-OFFSET 0030 77400000 1))
+
+(cl:defvar %INITIALLY-DISABLE-TRAPPING cl:NIL) ;THIS NON-NIL INHIBITS LISP-REINITIALIZE FROM
+ ; DOING AN (ENABLE-TRAPPING)
+(cl:defvar INHIBIT-SCHEDULING-FLAG cl:NIL) ;THIS NON-NIL INHIBITS CLOCK & SCHEDULING
+
+(cl:defvar HEADER-FIELD-VALUES '(%%HEADER-TYPE-FIELD 2305 %%HEADER-REST-FIELD 0023))
+(cl:defvar HEADER-FIELDS (GET-ALTERNATE HEADER-FIELD-VALUES))
+
+; These are the values that go in the %%HEADER-TYPE-FIELD of a Q of
+; data type DTP-HEADER.
+(cl:defvar Q-HEADER-TYPES '(%HEADER-TYPE-ERROR %HEADER-TYPE-FEF
+ %HEADER-TYPE-ARRAY-LEADER
+ %HEADER-TYPE-unused %HEADER-TYPE-FLONUM %HEADER-TYPE-COMPLEX
+ %HEADER-TYPE-BIGNUM %HEADER-TYPE-RATIONAL-BIGNUM))
+
+; These are the header types, shifted so they can be added directly into a Q.
+; These do NOT go in the cold load.
+(cl:defvar HEADER-TYPES '(HEADER-TYPE-ERROR HEADER-TYPE-FEF
+ HEADER-TYPE-ARRAY-LEADER
+ HEADER-TYPE-unused HEADER-TYPE-FLONUM HEADER-TYPE-COMPLEX
+ HEADER-TYPE-BIGNUM HEADER-TYPE-RATIONAL-BIGNUM))
+
+; These three lists describing the possible types of "argument descriptor info"
+(cl:defvar ADI-KINDS '(ADI-ERR ADI-RETURN-INFO ADI-RESTART-PC ADI-FEXPR-CALL
+ ADI-LEXPR-CALL ADI-BIND-STACK-LEVEL ADI-UNUSED-6
+ ADI-USED-UP-RETURN-INFO))
+
+(cl:defvar ADI-STORING-OPTIONS '(ADI-ST-ERR ADI-ST-BLOCK ADI-ST-LIST
+ ADI-ST-MAKE-LIST ADI-ST-INDIRECT))
+
+(cl:defvar ADI-FIELD-VALUES '(%%ADI-TYPE 2403 %%ADI-RET-STORING-OPTION 2103
+ %%ADI-PREVIOUS-ADI-FLAG 3601 ;Overlaps cdr-code
+ %%ADI-RET-SWAP-SV 2001 %%ADI-RET-NUM-VALS-EXPECTING 0006
+ %%ADI-RPC-MICRO-STACK-LEVEL 0006))
+(ASSIGN-ALTERNATE ADI-FIELD-VALUES)
+(cl:defvar ADI-FIELDS (GET-ALTERNATE ADI-FIELD-VALUES))
+
+;;; These overlap the cdr-code field, which is not used in the special pdl.
+(cl:defvar SPECPDL-FIELD-VALUES '(
+ %%SPECPDL-BLOCK-START-FLAG 3601 ;Flag is set on first binding of each block of bindings
+ %%SPECPDL-CLOSURE-BINDING 3701 ;Flag is set on bindings made "before" entering function
+ ))
+(ASSIGN-ALTERNATE SPECPDL-FIELD-VALUES)
+(cl:defvar SPECPDL-FIELDS (GET-ALTERNATE SPECPDL-FIELD-VALUES))
+
+; LINEAR-PDL-QS and LINEAR-PDL-FIELDS, and their elements, go in the real machine.
+(cl:defvar LINEAR-PDL-QS '(%LP-FEF %LP-ENTRY-STATE %LP-EXIT-STATE %LP-CALL-STATE))
+ ;THESE ARE ASSIGNED VALUES STARTING WITH 0 AND INCREMENTING BY -1
+ (ASSIGN-VALUES-INIT-DELTA LINEAR-PDL-QS 0 0 -1)
+
+(cl:defvar %LP-CALL-BLOCK-LENGTH (cl:LENGTH LINEAR-PDL-QS))
+(cl:defvar LLPFRM 4) ;# FIXED ALLOC QS IN LINAR PDL BLOCK (OBSOLETE, USE ABOVE)
+
+(cl:defvar %LP-INITIAL-LOCAL-BLOCK-OFFSET 1)
+
+(cl:defvar LINEAR-PDL-FIELDS-VALUES '(
+ ;LPCLS (%LP-CALL-STATE). Stored when this call frame is created.
+ ;bits 27', 25' not used in LPCLS
+ %%LP-CLS-TRAP-ON-EXIT 2601 ;If set, get error before popping this frame.
+ %%LP-CLS-ADI-PRESENT 2401 ;ADI words precede this call-block
+ %%LP-CLS-DESTINATION 2004 ;Where in the caller to put this frame's value
+ %%LP-CLS-DELTA-TO-OPEN-BLOCK 1010 ;Offset back to previous open or active block
+ %%LP-CLS-DELTA-TO-ACTIVE-BLOCK 0010 ;Offset back to previous active block
+ ;An active block is one that is executing
+ ;An open block is one whose args are being made
+ ;LPEXS (%LP-EXIT-STATE). Stored when this frame calls out.
+ ;bits 22'-27' not used in LPEXS
+ %%LP-EXS-MICRO-STACK-SAVED 2101 ;A microstack frame exists on special pdl
+ %%LP-EXS-PC-STATUS 2001 ;Same as below
+ %%LP-EXS-BINDING-BLOCK-PUSHED 2001 ;M-QBBFL STORED HERE IN MACRO EXIT OPERATION
+ %%LP-EXS-EXIT-PC 0017 ;LC as offset in halfwords from FEF
+ ;Meaningless if %LP-FEF not a fef.
+ ;; Don't change %%LP-EXS-EXIT-PC, the numerical value is known by UCADR
+ ;LPENS (%LP-ENTRY-STATE). Stored when this frame entered.
+ ;bits 16'-27' not used in LPENS
+; %%LP-ENS-SPECIALS 2601 %%LP-ENS-BINDING-ARROW-DIRECTION 2501
+ %%LP-ENS-ENVIRONMENT-POINTER-POINTS-HERE 1601
+ %%LP-ENS-NUM-ARGS-SUPPLIED 1006
+ %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN 0010))
+
+(ASSIGN-ALTERNATE LINEAR-PDL-FIELDS-VALUES)
+(cl:defvar LINEAR-PDL-FIELDS (GET-ALTERNATE LINEAR-PDL-FIELDS-VALUES))
+
+;; MICRO-STACK-FIELDS and its elements go in the real machine.
+(cl:defvar MICRO-STACK-FIELDS-VALUES
+ '( %%US-RPC 1600 ;RETURN PC
+ %%US-MACRO-INSTRUCTION-RETURN 1601 ;TRIGGERS INSTRUCTION-STREAM STUFF
+ %%US-PPBMIA 1701 ;ADI ON MICRO-TO-MICRO-CALL
+ %%US-PPBSPC 2101)) ;BINDING BLOCK PUSHED
+
+
+(ASSIGN-ALTERNATE MICRO-STACK-FIELDS-VALUES)
+(cl:defvar MICRO-STACK-FIELDS (GET-ALTERNATE MICRO-STACK-FIELDS-VALUES))
+
+
+; M-FLAGS-FIELDS and M-ERROR-SUBSTATUS-FIELDS and their elements go in the real machine.
+(cl:defvar M-FLAGS-FIELDS-VALUES '( ;MUST AGREE WITH DEFS IN UCONS
+ %%M-FLAGS-QBBFL 0001 ;BIND BLOCK OPEN FLAG
+ %%M-FLAGS-CAR-SYM-MODE 0102 ;CAR OF SYMBOL GIVES: ERROR, ERROR EXCEPT
+ ; (CAR NIL) -> NIL, NIL, P-NAME POINTER
+ %%M-FLAGS-CAR-NUM-MODE 0302 ;CAR OF NUMBER GIVES: ERROR, NIL, "WHATEVER IT IS"
+ %%M-FLAGS-CDR-SYM-MODE 0502 ;CDR OF SYMBOL GIVES: ERROR, ERROR EXCEPT
+ ; (CDR NIL) -> NIL, NIL, PROPERTY-LIST
+ %%M-FLAGS-CDR-NUM-MODE 0702 ;CDR OF NUMBER GIVES: ERROR, NIL, "WHATEVER IT IS"
+ %%M-FLAGS-DONT-SWAP-IN 1101 ;MAGIC FLAG FOR CREATING FRESH PAGES
+ %%M-FLAGS-TRAP-ENABLE 1201 ;1 ENABLE ERROR TRAPPING
+ %%M-FLAGS-MAR-MODE 1302 ;1-BIT = READ-TRAP, 2-BIT = WRITE-TRAP
+ %%M-FLAGS-PGF-WRITE 1501 ;FLAG USED BY PAGE FAULT ROUTINE
+ %%M-FLAGS-INTERRUPT 1601 ;IN MICROCODE INTERRUPT
+ %%M-FLAGS-SCAVENGE 1701 ;IN SCAVENGER
+ %%M-FLAGS-TRANSPORT 2001 ;IN TRANSPORTER
+ %%M-FLAGS-STACK-GROUP-SWITCH 2101 ;SWITCHING STACK GROUPS
+ %%M-FLAGS-DEFERRED-SEQUENCE-BREAK 2201 ;SEQUENCE BREAK PENDING BUT INHIBITED
+ %%M-FLAGS-METER-ENABLE 2301 ;METERING ENABLED FOR THIS STACK GROUP
+ %%M-FLAGS-TRAP-ON-CALL 2401 ;TRAP ON ATTEMPTING TO ACTIVATE NEW FRAME.
+))
+(ASSIGN-ALTERNATE M-FLAGS-FIELDS-VALUES)
+(cl:defvar M-FLAGS-FIELDS (GET-ALTERNATE M-FLAGS-FIELDS-VALUES))
+
+(cl:defvar M-ERROR-SUBSTATUS-FIELDS-VALUES '( ;MUST AGREE WITH DEFS IN UCONS
+ %%M-ESUBS-TOO-FEW-ARGS 0001
+ %%M-ESUBS-TOO-MANY-ARGS 0101
+ %%M-ESUBS-BAD-QUOTED-ARG 0201
+ %%M-ESUBS-BAD-EVALED-ARG 0301
+ %%M-ESUBS-BAD-DT 0401
+ %%M-ESUBS-BAD-QUOTE-STATUS 0501
+))
+(ASSIGN-ALTERNATE M-ERROR-SUBSTATUS-FIELDS-VALUES)
+(cl:defvar M-ERROR-SUBSTATUS-FIELDS (GET-ALTERNATE M-ERROR-SUBSTATUS-FIELDS-VALUES))
+
+;A "Numeric Argument Description" is what %ARGS-INFO and ARGS-INFO return.
+;Such descriptors can also be hung on symbols' Q-ARGS-PROP properties.
+;The "fast option Q" of a FEF is stored in this format.
+;These symbols go in the real machine.
+(cl:defvar NUMERIC-ARG-DESC-INFO '(
+ %ARG-DESC-QUOTED-REST 10000000 ;HAS QUOTED REST ARGUMENT
+ %%ARG-DESC-QUOTED-REST 2501
+ %ARG-DESC-EVALED-REST 4000000 ;HAS EVALUATED REST ARGUMENT
+ %%ARG-DESC-EVALED-REST 2401
+ %%ARG-DESC-ANY-REST 2402 ;NON-ZERO IF HAS EITHER KIND OF REST ARG
+ %ARG-DESC-FEF-QUOTE-HAIR 2000000 ;MACRO COMPILED FCN WITH HAIRY QUOTING,
+ %%ARG-DESC-FEF-QUOTE-HAIR 2301 ; CALLER MUST CHECK A-D-L FOR FULL INFO
+ %ARG-DESC-INTERPRETED 1000000 ;THIS IS INTERPRETED FUNCTION,
+ %%ARG-DESC-INTERPRETED 2201 ; NO INFORMATION AVAILABLE (VAL=1000077)
+ %ARG-DESC-FEF-BIND-HAIR 400000 ;MACRO COMPILED FCN WITH HAIRY BINDING,
+ %%ARG-DESC-FEF-BIND-HAIR 2101 ; LINEAR ENTER MUST CHECK A-D-L
+ %%ARG-DESC-MIN-ARGS 0606 ;MINIMUM NUMBER OF REQUIRED ARGS
+ %%ARG-DESC-MAX-ARGS 0006)) ;MAXIMUM NUMBER OF REQUIRED+OPTIONAL
+ ; ARGS. REST ARGS NOT COUNTED.
+
+(ASSIGN-ALTERNATE NUMERIC-ARG-DESC-INFO)
+(cl:defvar NUMERIC-ARG-DESC-FIELDS (GET-ALTERNATE NUMERIC-ARG-DESC-INFO))
+
+(cl:defvar ARG-DESC-FIELD-VALUES '(%FEF-ARG-SYNTAX 160 %FEF-QUOTE-STATUS 600
+ %FEF-DES-DT 17000
+ %FEF-INIT-OPTION 17 %FEF-SPECIAL-BIT #.(cl:ash 1 16)
+ %FEF-NAME-PRESENT #.(cl:ash 1 20)
+;***UNFORTUNATELY, ASSIGN-COMP-VALUES KNOWS ABOUT THESE TOO****
+ %%FEF-NAME-PRESENT 2001
+ %%FEF-SPECIAL-BIT 1601 %%FEF-SPECIALNESS 1602
+ %%FEF-FUNCTIONAL 1501 %%FEF-DES-DT 1104
+ %%FEF-QUOTE-STATUS 0702 %%FEF-ARG-SYNTAX 0403 %%FEF-INIT-OPTION 0004
+))
+
+(ASSIGN-ALTERNATE ARG-DESC-FIELD-VALUES)
+(cl:defvar ARG-DESC-FIELDS (GET-ALTERNATE ARG-DESC-FIELD-VALUES))
+ ;ARG-DESC-FIELDS GETS SET TO A LIST CONSISTING OF THE ALTERNATING MEMBERS OF
+ ;ARG-DESC-FIELD-VALUES
+
+(cl:defvar FEF-NAME-PRESENT '(FEF-NM-NO FEF-NM-YES))
+(cl:defvar FEF-SPECIALNESS '(FEF-LOCAL FEF-SPECIAL FEF-SPECIALNESS-UNUSED FEF-REMOTE))
+(cl:defvar FEF-FUNCTIONAL '(FEF-FUNCTIONAL-DONTKNOW FEF-FUNCTIONAL-ARG))
+(cl:defvar FEF-DES-DT '(FEF-DT-DONTCARE FEF-DT-NUMBER FEF-DT-FIXNUM FEF-DT-SYM
+ FEF-DT-ATOM FEF-DT-LIST FEF-DT-FRAME))
+(cl:defvar FEF-QUOTE-STATUS '(FEF-QT-DONTCARE FEF-QT-EVAL FEF-QT-QT))
+(cl:defvar FEF-ARG-SYNTAX '(FEF-ARG-REQ FEF-ARG-OPT FEF-ARG-REST FEF-ARG-AUX
+ FEF-ARG-FREE FEF-ARG-INTERNAL FEF-ARG-INTERNAL-AUX))
+(cl:defvar FEF-INIT-OPTION '(FEF-INI-NONE FEF-INI-NIL FEF-INI-PNTR FEF-INI-C-PNTR
+ FEF-INI-OPT-SA FEF-INI-COMP-C FEF-INI-EFF-ADR
+ FEF-INI-SELF))
+
+
+(cl:defvar ARRAY-FIELD-VALUES '(
+ %%ARRAY-TYPE-FIELD 2305 %%ARRAY-LEADER-BIT 2101
+ %%ARRAY-DISPLACED-BIT 2001 %%ARRAY-FLAG-BIT 1701
+ %%ARRAY-NUMBER-DIMENSIONS 1403 %%ARRAY-LONG-LENGTH-FLAG 1301
+ %%ARRAY-NAMED-STRUCTURE-FLAG 1201
+ %%ARRAY-INDEX-LENGTH-IF-SHORT 0012 %ARRAY-MAX-SHORT-INDEX-LENGTH 1777))
+
+(cl:defvar ARRAY-LEADER-FIELD-VALUES '(%ARRAY-LEADER-LENGTH 777777
+ %%ARRAY-LEADER-LENGTH 0022))
+
+(cl:defvar ARRAY-MISC-VALUES
+ '(ARRAY-DIM-MULT #.(cl:ash 1 14)
+ ARRAY-DIMENSION-SHIFT -14
+ ARRAY-TYPE-SHIFT -23
+ ARRAY-LEADER-BIT #.(cl:ash 1 21)
+ ARRAY-DISPLACED-BIT #.(cl:ash 1 20)
+ ARRAY-LONG-LENGTH-FLAG #.(cl:ash 1 13)
+ ARRAY-NAMED-STRUCTURE-FLAG #.(cl:ash 1 12)))
+
+(cl:defvar ARRAY-FIELDS (GET-ALTERNATE ARRAY-FIELD-VALUES))
+
+(cl:defvar ARRAY-LEADER-FIELDS (GET-ALTERNATE ARRAY-LEADER-FIELD-VALUES))
+
+(cl:defvar ARRAY-MISCS (GET-ALTERNATE ARRAY-MISC-VALUES))
+
+(cl:defvar ARRAY-TYPES '(ART-ERROR ART-1B ART-2B ART-4B ART-8B ART-16B ART-32B
+ ART-Q ART-Q-LIST ART-STRING ART-STACK-GROUP-HEAD ART-SPECIAL-PDL ART-HALF-FIX
+ ART-REG-PDL ART-FLOAT ART-FPS-FLOAT ART-FAT-STRING))
+
+(cl:defvar ARRAY-ELEMENTS-PER-Q '((ART-Q . 1) (ART-STRING . 4) (ART-1B . 40) (ART-2B . 20)
+ (ART-4B . 10) (ART-8B . 4) (ART-16B . 2) (ART-32B . 1) (ART-Q-LIST . 1)
+ (ART-STACK-GROUP-HEAD . 1) (ART-SPECIAL-PDL . 1) (ART-HALF-FIX . 2)
+ (ART-REG-PDL . 1) (ART-FLOAT . -2) (ART-FPS-FLOAT . 1) (ART-FAT-STRING . 2)))
+
+;NIL for Q-type arrays
+(cl:defvar ARRAY-BITS-PER-ELEMENT '((ART-Q . NIL) (ART-STRING . 8) (ART-1B . 1) (ART-2B . 2)
+ (ART-4B . 4) (ART-8B . 8) (ART-16B . 16.) (ART-32B . 24.) (ART-Q-LIST . NIL)
+ (ART-STACK-GROUP-HEAD . NIL) (ART-SPECIAL-PDL . NIL) (ART-HALF-FIX . 16.)
+ (ART-REG-PDL . NIL) (ART-FLOAT . 32.) (ART-FPS-FLOAT . 32.) (ART-FAT-STRING . 16.)))
+
+;FEF HEADER FIELDS
+(cl:defvar FEFH-CONSTANT-VALUES '(%FEFH-PC 177777 ;There are 19 available bits in this word!
+ %FEFH-NO-ADL #.(cl:ash 1 18.)
+ %FEFH-FAST-ARG #.(cl:ash 1 17.) %FEFH-SV-BIND #.(cl:ash 1 16.)
+ %%FEFH-PC 0020 %%FEFH-PC-IN-WORDS 0117 %%FEFH-NO-ADL 2201
+ %%FEFH-FAST-ARG 2101 %%FEFH-SV-BIND 2001))
+
+(ASSIGN-ALTERNATE FEFH-CONSTANT-VALUES)
+
+(cl:defvar FEFH-CONSTANTS (GET-ALTERNATE FEFH-CONSTANT-VALUES))
+
+;FEF HEADER Q INDEXES
+
+(cl:defvar FEFHI-INDEXES '(%FEFHI-IPC %FEFHI-STORAGE-LENGTH %FEFHI-FCTN-NAME %FEFHI-FAST-ARG-OPT
+ %FEFHI-SV-BITMAP %FEFHI-MISC %FEFHI-SPECIAL-VALUE-CELL-PNTRS))
+
+(cl:defvar IFEFOFF (cl:1- (cl:LENGTH FEFHI-INDEXES))) ;Q'S IN FIXED ALLOC PART OF FEF
+(cl:defvar %FEF-HEADER-LENGTH IFEFOFF) ;BETTER NAME FOR ABOVE
+
+(cl:defvar FEFHI-VALUES '(%%FEFHI-FSO-MIN-ARGS 0606 %%FEFHI-FSO-MAX-ARGS 0006
+ %%FEFHI-MS-LOCAL-BLOCK-LENGTH 0007 %%FEFHI-MS-ARG-DESC-ORG 0710
+ %%FEFHI-MS-BIND-DESC-LENGTH 1710
+ %%FEFHI-MS-DEBUG-INFO-PRESENT 2701
+ %%FEFHI-SVM-ACTIVE 2601
+ %FEFHI-SVM-ACTIVE #.(cl:ash 1 26)
+ %%FEFHI-SVM-BITS 0026
+ %%FEFHI-SVM-HIGH-BIT 2501))
+
+(cl:defvar FEFHI-FIELDS (GET-ALTERNATE FEFHI-VALUES))
+
+;PAGE TABLE STUFF ETC.
+
+(cl:defvar PAGE-VALUES '(
+
+ ; DEFINITIONS OF FIELDS IN PAGE HASH TABLE
+
+ ;WORD 1
+ %%PHT1-VIRTUAL-PAGE-NUMBER 1020 ;ALIGNED SAME AS VMA
+ %PHT-DUMMY-VIRTUAL-ADDRESS 177777 ;ALL ONES MEANS THIS IS DUMMY ENTRY
+ ;WHICH JUST REMEMBERS A FREE CORE PAGE
+ %%PHT1-SWAP-STATUS-CODE 0003
+ %PHT-SWAP-STATUS-NORMAL 1 ;ORDINARY PAGE
+ %PHT-SWAP-STATUS-FLUSHABLE 2 ;SAFELY REUSABLE TO SWAP PAGES INTO
+ ;MAY NEED TO BE WRITTEN TO DISK FIRST
+ %PHT-SWAP-STATUS-PREPAGE 3 ;SAME AS FLUSHABLE, BUT CAME IN VIA PREPAGE
+ %PHT-SWAP-STATUS-AGE-TRAP 4 ;LIKE NORMAL BUT TRYING TO MAKE FLUSHABLE
+ %PHT-SWAP-STATUS-WIRED 5 ;NOT SWAPPABLE
+
+ %%PHT1-AGE 0302 ;NUMBER OF TIMES AGED
+
+ %%PHT1-MODIFIED-BIT 0501 ;1 IF PAGE MODIFIED, BUT THE FACT NOT RECORDED
+ ; IN THE MAP-STATUS, BECAUSE IT IS NOMINALLY READ-ONLY
+ ; OR NOMINALLY READ-WRITE-FIRST.
+
+ %%PHT1-VALID-BIT 0601 ;1 IF THIS HASH TABLE SLOT IS OCCUPIED.
+ %%PHT1-SCAVENGER-WS-FLAG 0701 ;IF SET, PAGE IN SCAVENGER WORKING SET.
+
+ ;PHT WORD 2. THIS IS IDENTICAL TO THE LEVEL-2 MAP
+ %%PHT2-META-BITS 1606 ;SEE %%REGION-MAP-BITS
+
+ %%PHT2-MAP-STATUS-CODE 2403
+ %PHT-MAP-STATUS-MAP-NOT-VALID 0 ;LEVEL 1 OR 2 MAP NOT SET UP
+ %PHT-MAP-STATUS-META-BITS-ONLY 1 ;HAS META BITS BUT NO PHYSICAL ADDRESS
+ %PHT-MAP-STATUS-READ-ONLY 2 ;GARBAGE COLLECTOR CAN STILL WRITE IN IT
+ %PHT-MAP-STATUS-READ-WRITE-FIRST 3 ;READ/WRITE BUT NOT MODIFIED
+ %PHT-MAP-STATUS-READ-WRITE 4 ;READ/WRITE AND MODIFIED
+ %PHT-MAP-STATUS-PDL-BUFFER 5 ;MAY RESIDE IN PDL BUFFER
+ %PHT-MAP-STATUS-MAR 6 ;MAR SET SOMEWHERE ON THIS PAGE
+
+ %%PHT2-MAP-ACCESS-CODE 2602
+ %%PHT2-ACCESS-STATUS-AND-META-BITS 1612
+ %%PHT2-ACCESS-AND-STATUS-BITS 2404
+ %%PHT2-PHYSICAL-PAGE-NUMBER 0016
+))
+
+(ASSIGN-ALTERNATE PAGE-VALUES)
+(cl:defvar PAGE-HASH-TABLE-FIELDS (GET-ALTERNATE PAGE-VALUES))
+
+;;; See LISPM2;SGDEFS
+(cl:defvar STACK-GROUP-HEAD-LEADER-QS '(SG-NAME
+ SG-REGULAR-PDL SG-REGULAR-PDL-LIMIT SG-SPECIAL-PDL SG-SPECIAL-PDL-LIMIT
+ SG-INITIAL-FUNCTION-INDEX
+ SG-UCODE
+;END STATIC SECTION, BEGIN DEBUGGING SECTION
+ SG-TRAP-TAG ;SYMBOLIC TAG CORRESPONDING TO SG-TRAP-MICRO-PC. GOTTEN VIA
+ ; MICROCODE-ERROR-TABLE, ETC. PROPERTIES OFF THIS SYMBOL
+ ; DRIVE VARIOUS STAGES IN ERROR RECOVERY, ETC.
+ SG-RECOVERY-HISTORY ;AVAILABLE FOR HAIRY SG MUNGING ROUTINES TO LEAVE TRACKS IN
+ ; FOR DEBUGGING PURPOSES.
+ SG-FOOTHOLD-DATA ;STRUCTURE WHICH SAVES DYNAMIC SECTION OF "REAL" SG WHEN
+ ; EXECUTING IN THE FOOTHOLD.
+; LOCATIONS BELOW HERE ARE ACTUALLY LOADED/STORED ON SG-ENTER/SG-LEAVE
+;END DEBUGGING SECTION, BEGIN "HIGH LEVEL" SECTION
+ SG-STATE SG-PREVIOUS-STACK-GROUP SG-CALLING-ARGS-POINTER
+ SG-CALLING-ARGS-NUMBER ;SG-FOLLOWING-STACK-GROUP
+ SG-TRAP-AP-LEVEL
+;END HIGH-LEVEL SECTION, BEGIN "DYNAMIC" SECTION --BELOW HERE IS SAVED IN
+; SG-FOOTHOLD-DATA WHEN %%SG-ST-FOOTHOLD-EXECUTING IS SET.
+ SG-REGULAR-PDL-POINTER SG-SPECIAL-PDL-POINTER
+ SG-AP SG-IPMARK
+ SG-TRAP-MICRO-PC ;PC SAVED FROM OPCS AT MICRO-LOCATION TRAP
+; SG-ERROR-HANDLING-SG SG-INTERRUPT-HANDLING-SG
+; HAVING THESE BE PART OF THE SG IS BASICALLY A GOOD IDEA, BUT IT
+; DOESNT BUY ANYTHING FOR THE TIME BEING AND COSTS A COUPLE OF MICROINSTRUCTIONS
+ SG-SAVED-QLARYH SG-SAVED-QLARYL SG-SAVED-M-FLAGS
+ SG-AC-K SG-AC-S SG-AC-J
+ SG-AC-I SG-AC-Q SG-AC-R SG-AC-T SG-AC-E SG-AC-D SG-AC-C
+ SG-AC-B SG-AC-A SG-AC-ZR SG-AC-2 SG-AC-1 SG-VMA-M1-M2-TAGS SG-SAVED-VMA SG-PDL-PHASE))
+
+;FIELDS IN SG-STATE Q
+(cl:defvar SG-STATE-FIELD-VALUES '(%%SG-ST-CURRENT-STATE 0006
+ %%SG-ST-FOOTHOLD-EXECUTING 0601
+ %%SG-ST-PROCESSING-ERROR 0701 %%SG-ST-PROCESSING-INTERRRUPT-REQUEST 1001
+ %%SG-ST-SAFE 1101
+ %%SG-ST-INST-DISP 1202
+ %%SG-ST-IN-SWAPPED-STATE 2601
+ %%SG-ST-SWAP-SV-ON-CALL-OUT 2501
+ %%SG-ST-SWAP-SV-OF-SG-THAT-CALLS-ME 2401))
+(cl:defvar SG-STATE-FIELDS (GET-ALTERNATE SG-STATE-FIELD-VALUES))
+
+(cl:defvar SG-INST-DISPATCHES '(
+ SG-MAIN-DISPATCH ;MAIN INSTRUCTION DISPATCH
+ SG-DEBUG-DISPATCH ;DEBUGGING DISPATCH
+ SG-SINGLE-STEP-DISPATCH ;DISPATCH ONCE, AND THEN BREAK
+ SG-SINGLE-STEP-TRAP ;FOR SEQUENCE BREAKS OUT OF TRAPPING INSTRUCTIONS
+ ))
+
+(cl:defvar SG-STATES '(
+ SG-STATE-ERROR ;0 SHOULD NEVER GET THIS
+ SG-STATE-ACTIVE ;ACTUALLY EXECUTING ON MACHINE.
+ SG-STATE-RESUMABLE ;REACHED BY INTERRUPT OR ERROR RECOVERY COMPLETED
+ ; JUST RESTORE STATE AND DO A UCODE POPJ TO RESUME.
+ SG-STATE-AWAITING-RETURN ;AFTER DOING A "LEGITIMATE" SG-CALL. TO RESUME THIS
+ ; RELOAD SG THEN RETURN A VALUE BY TRANSFERRING TO
+ ; QMEX1.
+ SG-STATE-INVOKE-CALL-ON-RETURN ;TO RESUME THIS, RELOAD SG, THEN SIMULATE
+ ; A STORE IN DESTINATION-LAST. THE ERROR
+ ; SYSTEM CAN PRODUCE THIS STATE WHEN IT WANTS
+ ; TO ACTIVATE THE FOOTHOLD OR PERFORM A RETRY.
+ SG-STATE-INTERRUPTED-DIRTY ;GET THIS IF FORCED TO TAKE AN INTERRUPT AT AN
+ ; INOPPORTUNE TIME.
+ SG-STATE-AWAITING-ERROR-RECOVERY ;IMMEDIATEDLY AFTER ERROR, BEFORE RECOVERY
+ SG-STATE-AWAITING-CALL
+ SG-STATE-AWAITING-INITIAL-CALL
+ SG-STATE-EXHAUSTED))
+
+(cl:defvar SPECIAL-PDL-LEADER-QS '(SPECIAL-PDL-SG-HEAD-POINTER))
+(cl:defvar REG-PDL-LEADER-QS '(REG-PDL-SG-HEAD-POINTER))
+
+(cl:defvar PAGE-SIZE 400)
+(cl:defvar SITE-NAME "FERRODAY")
+
+(cl:defvar LENGTH-OF-FASL-TABLE 37773)
+
+(cl:defvar LENGTH-OF-ATOM-HEAD 5)
+
+(cl:defvar SIZE-OF-OB-TBL 177) ;USED BY PRE-PACKAGE INTERN KLUDGE
+
+(cl:defvar SIZE-OF-AREA-ARRAYS 377)
+
+;SIZE OF VARIOUS HARDWARE MEMORIES IN "ADDRESSIBLE LOCATIONS"
+(cl:defvar SIZE-OF-HARDWARE-CONTROL-MEMORY 40000)
+(cl:defvar SIZE-OF-HARDWARE-DISPATCH-MEMORY 4000)
+(cl:defvar SIZE-OF-HARDWARE-A-MEMORY 2000)
+(cl:defvar SIZE-OF-HARDWARE-M-MEMORY 40)
+(cl:defvar SIZE-OF-HARDWARE-PDL-BUFFER 2000)
+(cl:defvar SIZE-OF-HARDWARE-MICRO-STACK 40)
+(cl:defvar SIZE-OF-HARDWARE-LEVEL-1-MAP 4000)
+(cl:defvar SIZE-OF-HARDWARE-LEVEL-2-MAP 2000)
+(cl:defvar SIZE-OF-HARDWARE-UNIBUS-MAP 20)
+
+(cl:defvar A-MEMORY-LOCATION-NAMES '( ;LIST IN ORDER OF CONTENTS OF A-MEMORY STARTING AT 40
+ %MICROCODE-VERSION-NUMBER ;SECOND FILE NAME OF MICROCODE SOURCE FILE AS A NUMBER
+ %NUMBER-OF-MICRO-ENTRIES ;NUMBER OF SLOTS USED IN MICRO-CODE-ENTRY-AREA
+ DEFAULT-CONS-AREA ;DEFAULT AREA FOR CONS, LIST, ETC.
+ NUMBER-CONS-AREA ;FOR BIGNUMS, BIG-FLOATS, ETC. CAN BE
+ ; EXTRA-PDL-AREA OR JUST REGULAR AREA.
+ %INITIAL-FEF ;POINTER TO FEF OF FUNCTION MACHINE STARTS UP IN
+ %ERROR-HANDLER-STACK-GROUP ;SG TO SWITCH TO ON TRAPS
+ %CURRENT-STACK-GROUP ;CURRENT STACK-GROUP
+ %INITIAL-STACK-GROUP ;STACK-GROUP MACHINE STARTS UP IN
+ %CURRENT-STACK-GROUP-STATE ;SG-STATE Q OF CURRENT STACK GROUP
+ %CURRENT-STACK-GROUP-PREVIOUS-STACK-GROUP ;
+ %CURRENT-STACK-GROUP-CALLING-ARGS-POINTER ;
+ %CURRENT-STACK-GROUP-CALLING-ARGS-NUMBER ;
+; %CURRENT-STACK-GROUP-FOLLOWING-STACK-GROUP ;
+ %TRAP-MICRO-PC ;PC GOTTEN OUT OF OPCS BY TRAP
+ %COUNTER-BLOCK-A-MEM-ADDRESS ;LOC OF BEGINNING OF COUNTER BLOCK RELATIVE TO
+ ; A MEMORY AS A FIXNUM.
+ %CHAOS-CSR-ADDRESS ;XBUS ADDRESS
+ %MAR-LOW ;FIXNUM MAR LOWER BOUND (INCLUSIVE)
+ %MAR-HIGH ;FIXNUM MAR UPPER BOUND (INCLUSIVE)
+ ;%%M-FLAGS-MAR-MODE CONTROLS THE ABOVE
+ SELF ;SELF POINTER FOR DTP-INSTANCE, ETC
+ %METHOD-SEARCH-POINTER ;Method list element were last method found.
+ INHIBIT-SCHEDULING-FLAG ;NON-NIL SUPPRESSES SEQUENCE BREAKS
+ INHIBIT-SCAVENGING-FLAG ;NON-NIL TURNS OFF THE SCAVENGER
+ %DISK-RUN-LIGHT ;ADDRESS OF DISK RUN LIGHT, THAT+2 IS PROC RUN LIGHT
+ %LOADED-BAND ;LOW 24 BITS (FIXNUM) OF BOOTED BAND NAME (E.G. "OD3")
+ %DISK-BLOCKS-PER-TRACK ;(FROM LABEL) BLOCKS PER TRACK, USUALLY 17.
+ %DISK-BLOCKS-PER-CYLINDER ;(FROM LABEL) 85. ON T-80, 323. ON T-300
+ ;THE GARBAGE-COLLECTOR PROCESS HANGS ON THESE VARIABLES
+ %REGION-CONS-ALARM ;COUNTS NEW REGIONS CREATED
+ %PAGE-CONS-ALARM ;COUNTS PAGES ALLOCATED TO REGIONS
+ %GC-FLIP-READY ;If non-NIL, there are no pointers to oldspace
+ %INHIBIT-READ-ONLY ;If non-NIL, you can write in read-only
+ %SCAVENGER-WS-ENABLE ;If non-NIL, scavenger working set hack enabled
+ %METHOD-SUBROUTINE-POINTER ;Continuation point for SELECT-METHOD subroutine
+ ; or NIL.
+ %QLARYH ;Header of last array ref'ed as function
+ %QLARYL ;Element # of last array ref'ed as function
+ %SCHEDULER-STACK-GROUP ;Force call to this on sequence-break. This
+ ;stack group must bind on INHIBIT-SCHEDULING-FLAG as
+ ;part of the stack-group switch for proper operation.
+ %CURRENT-SHEET ;Sheet or screen currently selected by microcode
+ %DISK-SWITCHES ;Fixnum: 1 r/c after read, 2 r/c after write
+ ; 4 enables multiple page swapouts
+ ; was called %READ-COMPARE-ENABLES
+ %MC-CODE-EXIT-VECTOR ;Exit vector used by microcompiled code to ref Q
+ ; quantities.
+ ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON ;If T, upper and lower case are not equal
+ ZUNDERFLOW ;If non-NIL, floating pointer underflow yields zero
+ %GC-GENERATION-NUMBER ;Increments whenever any new oldspace is created.
+ ; Thus if this has changed, objects' addresses
+ ; may have changed.
+ %METER-GLOBAL-ENABLE ;NIL means metering on per stack group basis
+ ;T means all stack groups
+ %METER-BUFFER-POINTER ;Pointer to the buffer as a fixnum
+ %METER-DISK-ADDRESS ;disk address to write out the meter info
+ %METER-DISK-COUNT ;count of disk blocks to write out
+ CURRENTLY-PREPARED-SHEET ;Error checking for the TV:PREPARE-SHEET macro
+ MOUSE-CURSOR-STATE ;0 disabled, 1 open, 2 off, 3 on
+ MOUSE-X ;Relative to mouse-sheet
+ MOUSE-Y
+ MOUSE-CURSOR-X-OFFSET ;From top-left of pattern
+ MOUSE-CURSOR-Y-OFFSET ;to the reference point
+ MOUSE-CURSOR-WIDTH
+ MOUSE-CURSOR-HEIGHT
+ MOUSE-X-SPEED ;100ths per second, time averaged
+ MOUSE-Y-SPEED ;with time constant of 1/6 second
+ MOUSE-BUTTONS-BUFFER-IN-INDEX
+ MOUSE-BUTTONS-BUFFER-OUT-INDEX
+ MOUSE-WAKEUP ;Set to T when move or click
+ LEXICAL-ENVIRONMENT
+ AMEM-EVCP-VECTOR ;Value is an array as long as this list plus 40,
+ ;which holds the EVCP when one of these vars
+ ;is bound by a closure.
+ BACKGROUND-CONS-AREA ;Used for conses that are not explicitly requested
+ ;and shouldn't go in a temp area.
+))
+
+(cl:defvar A-MEMORY-COUNTER-BLOCK-NAMES '(
+ %COUNT-FIRST-LEVEL-MAP-RELOADS ;# FIRST LEVEL MAP RELOADS
+ %COUNT-SECOND-LEVEL-MAP-RELOADS ;# SECOND LEVEL MAP RELOADS
+ %COUNT-PDL-BUFFER-READ-FAULTS ;# TOOK PGF AND DID READ FROM PDL-BUFFER
+ %COUNT-PDL-BUFFER-WRITE-FAULTS ;# TOOK PGF AND DID WRITE TO PDL-BUFFER
+ %COUNT-PDL-BUFFER-MEMORY-FAULTS ;# TOOK PGF FOR PDL-BUF, BUT DATA IN MAIN MEM.
+ %COUNT-DISK-PAGE-READS ;COUNT OF PAGES READ FROM DISK
+ %COUNT-DISK-PAGE-WRITES ;COUNT OF PAGES WRITTEN TO DISK
+ %COUNT-DISK-ERRORS ;COUNT OF RECOVERABLE ERRS
+ %COUNT-FRESH-PAGES ;COUNT OF FRESH PAGES
+ ; GENERATED IN CORE INSTEAD OF READ FROM DISK
+ %COUNT-AGED-PAGES ;NUMBER OF TIMES AGER SET AGE TRAP
+ %COUNT-AGE-FLUSHED-PAGES ;NUMBER OF TIMES AGE TRAP -> FLUSHABLE
+ %COUNT-DISK-READ-COMPARE-REWRITES ;COUNT OF WRITES REDONE DUE TO FAILURE TO READ-COMPARE
+ %COUNT-DISK-RECALIBRATES ;DUE TO SEEK ERRORS
+ %COUNT-META-BITS-MAP-RELOADS ;# SECOND LEVEL MAP RELOADS TO META-BITS-ONLY
+ %COUNT-CHAOS-TRANSMIT-ABORTS ;Number of transmit aborts in microcode
+ %COUNT-DISK-READ-COMPARE-DIFFERENCES ;Number of read-compare differences without
+ ; accompanying disk read error
+ %COUNT-CONS-WORK ;GC parameter
+ %COUNT-SCAVENGER-WORK ;..
+ %TV-CLOCK-RATE ;TV frame rate divided by this is seq brk clock
+ %AGING-DEPTH ;Number of laps to age a page. Don't make > 3!!
+ %COUNT-DISK-ECC-CORRECTED-ERRORS ;Number of soft ECC errors
+ %COUNT-FINDCORE-STEPS ;Number of iterations finding mem to swap out
+ %COUNT-FINDCORE-EMERGENCIES ;Number of times FINDCORE had to age all pages
+ %COUNT-DISK-READ-COMPARE-REREADS ;Reads done over due to r/c diff or error
+ %COUNT-DISK-PAGE-READ-OPERATIONS ;Read operations (count once even if multipage)
+ %COUNT-DISK-PAGE-WRITE-OPERATIONS ;Write operations (count once even if multipage)
+ %COUNT-DISK-PAGE-WRITE-WAITS ;Waiting for a page to get written, to reclaim core
+ %COUNT-DISK-PAGE-WRITE-BUSYS ;Waiting for a page to get written, to use disk
+ %COUNT-DISK-PREPAGES-USED ;Counts prepaged pages that were wanted
+ %COUNT-DISK-PREPAGES-NOT-USED ;Counts prepaged pages that were reclaimed
+ %DISK-ERROR-LOG-POINTER ;Address of next 4-word block in 600-637
+ %DISK-WAIT-TIME ;Microseconds of waiting for disk time
+ %COUNT-DISK-PAGE-WRITE-APPENDS ;Pages appended to swapout operations.
+ %COUNT-DISK-PAGE-READ-APPENDS ;Pages appended to swapin operations.
+))
+
+(cl:defvar M-MEMORY-LOCATION-NAMES ;M-MEM LOCNS ARE ASSIGNED PIECEMEAL..
+ '(%MODE-FLAGS %SEQUENCE-BREAK-SOURCE-ENABLE %METER-MICRO-ENABLES))
+(cl:setf (cl:get '%MODE-FLAGS 'FORWARDING-VIRTUAL-ADDRESS)
+ (cl:+ A-MEMORY-VIRTUAL-ADDRESS 26))
+(cl:setf (cl:get '%SEQUENCE-BREAK-SOURCE-ENABLE 'FORWARDING-VIRTUAL-ADDRESS)
+ (cl:+ A-MEMORY-VIRTUAL-ADDRESS 34))
+(cl:setf (cl:get '%METER-MICRO-ENABLES 'FORWARDING-VIRTUAL-ADDRESS)
+ (cl:+ A-MEMORY-VIRTUAL-ADDRESS 35))
+
+(cl:defvar DISK-RQ-LEADER-QS '(%DISK-RQ-LEADER-N-HWDS ;NUMBER HALFWORDS REALLY USED
+ ; ON FIRST PAGE BEFORE CCW LIST.
+ %DISK-RQ-LEADER-N-PAGES ;NUMBER OF BUFFER PAGES ALLOCATED
+ %DISK-RQ-LEADER-BUFFER ;DISPLACED ART-16B ARRAY TO BUFFER PGS
+ %DISK-RQ-LEADER-THREAD ;LINK TO NEXT FREE RQB
+ %DISK-RQ-LEADER-8-BIT-BUFFER)) ;DISPLACED ART-8B ARRAY.
+(cl:defvar DISK-RQ-HWDS '(%DISK-RQ-DONE-FLAG ;0 RQ ENTERED, -1 COMPLETED
+ %DISK-RQ-DONE-FLAG-HIGH
+ ;; These are set up by the requester
+ %DISK-RQ-COMMAND ;DISK COMMAND REGISTER
+ %DISK-RQ-COMMAND-HIGH
+ %DISK-RQ-CCW-LIST-POINTER-LOW ;CLP LOW 16
+ %DISK-RQ-CCW-LIST-POINTER-HIGH ;CLP HIGH 6
+ %DISK-RQ-SURFACE-SECTOR ;DISK ADDRESS REG LOW
+ %DISK-RQ-UNIT-CYLINDER ;DISK ADDRESS REG HIGH
+ ;; These are stored when the operation completes
+ %DISK-RQ-STATUS-LOW ;DISK STATUS REG LOW 16
+ %DISK-RQ-STATUS-HIGH ;DISK STATUS REG HIGH 16
+ %DISK-RQ-MEM-ADDRESS-LOW ;LAST MEM REF ADDR LOW 16
+ %DISK-RQ-MEM-ADDRESS-HIGH ;LAST MEM REF ADDR HIGH 6
+ %DISK-RQ-FINAL-SURFACE-SECTOR ;DISK ADDRESS REG LOW
+ %DISK-RQ-FINAL-UNIT-CYLINDER ;DISK ADDRESS REG HIGH
+ %DISK-RQ-ECC-POSITION
+ %DISK-RQ-ECC-PATTERN
+ %DISK-RQ-CCW-LIST)) ;CCW list customarily starts here
+(cl:defvar DISK-HARDWARE-VALUES '(
+ %%DISK-STATUS-HIGH-BLOCK-COUNTER 1010 %%DISK-STATUS-HIGH-INTERNAL-PARITY 0701
+ %%DISK-STATUS-HIGH-READ-COMPARE-DIFFERENCE 0601 %%DISK-STATUS-HIGH-CCW-CYCLE 0501
+ %%DISK-STATUS-HIGH-NXM 0401 %%DISK-STATUS-HIGH-MEM-PARITY 0301
+ %%DISK-STATUS-HIGH-HEADER-COMPARE 0201 %%DISK-STATUS-HIGH-HEADER-ECC 0101
+ %%DISK-STATUS-HIGH-ECC-HARD 0001
+ %DISK-STATUS-HIGH-ERROR 237 ;Mask for bits which are errors normally
+ %%DISK-STATUS-LOW-ECC-SOFT 1701 %%DISK-STATUS-LOW-OVERRUN 1601
+ %%DISK-STATUS-LOW-TRANSFER-ABORTED 1501 %%DISK-STATUS-LOW-START-BLOCK-ERROR 1401
+ %%DISK-STATUS-LOW-TIMEOUT 1301 %%DISK-STATUS-LOW-SEEK-ERROR 1201
+ %%DISK-STATUS-LOW-OFF-LINE 1101 %%DISK-STATUS-LOW-OFF-CYLINDER 1001
+ %%DISK-STATUS-LOW-READ-ONLY 0701 %%DISK-STATUS-LOW-FAULT 0601
+ %%DISK-STATUS-LOW-NO-SELECT 0501 %%DISK-STATUS-LOW-MULTIPLE-SELECT 0401
+ %%DISK-STATUS-LOW-INTERRUPT 0301 %%DISK-STATUS-LOW-SEL-UNIT-ATTENTION 0201
+ %%DISK-STATUS-LOW-ATTENTION 0101 %%DISK-STATUS-LOW-READY 0001
+ %DISK-STATUS-LOW-ERROR 177560 ;Mask for bits which are errors normally
+ %DISK-COMMAND-DONE-INTERRUPT-ENABLE #.(cl:ash 1 11.)
+ %DISK-COMMAND-ATTENTION-INTERRUPT-ENABLE #.(cl:ash 1 10.) ;Trident only
+ %DISK-COMMAND-RECALIBRATE 10001005
+ %DISK-COMMAND-FAULT-CLEAR 10000405 ;Recalibrate on Marksman
+ %DISK-COMMAND-DATA-STROBE-LATE 200 ;These are all different on Marksman
+ %DISK-COMMAND-DATA-STROBE-EARLY 100 ;..
+ %DISK-COMMAND-SERVO-OFFSET 40 ;..
+ %DISK-COMMAND-SERVO-OFFSET-FORWARD 20 ;..
+ %DISK-COMMAND-READ 0
+ %DISK-COMMAND-READ-COMPARE 10
+ %DISK-COMMAND-WRITE 11
+ %DISK-COMMAND-READ-ALL 2
+ %DISK-COMMAND-WRITE-ALL 13
+ %DISK-COMMAND-SEEK 20000004
+ %%DISK-COMMAND-SEEK-CYLINDER 3010 ;Only used by Marksman
+ %DISK-COMMAND-AT-EASE 5 ;Get status on Marksman
+ %DISK-COMMAND-OFFSET-CLEAR 6 ;NOP on marksman
+ %DISK-COMMAND-RESET-CONTROLLER 16))
+ ;Marksman also has get-status commands, not listed here.
+
+(ASSIGN-VALUES DISK-RQ-LEADER-QS 0)
+(ASSIGN-VALUES DISK-RQ-HWDS 0)
+(ASSIGN-ALTERNATE DISK-HARDWARE-VALUES)
+(cl:defvar DISK-HARDWARE-SYMBOLS (GET-ALTERNATE DISK-HARDWARE-VALUES))
+
+;;; Definitions for interrupt-driven Unibus input channels
+;;; Note that these start at 1 rather than at 0, to leave room for an array header
+
+(cl:defvar UNIBUS-CHANNEL-QS '(
+ %UNIBUS-CHANNEL-LINK ;Address of next or 0 to end list
+ %UNIBUS-CHANNEL-VECTOR-ADDRESS ;Interrupt vector address of device
+ %UNIBUS-CHANNEL-CSR-ADDRESS ;Virtual address of status register
+ %UNIBUS-CHANNEL-CSR-BITS ;Bits which must be on in CSR
+ %UNIBUS-CHANNEL-DATA-ADDRESS ;Virtual address of data register(s)
+ ;The %%Q-FLAG bit means there are 2 data regs
+ %UNIBUS-CHANNEL-BUFFER-START ;Start address of buffer
+ %UNIBUS-CHANNEL-BUFFER-END ;End address+1 of buffer
+ %UNIBUS-CHANNEL-BUFFER-IN-PTR ;Address of next word to store
+ ;The flag bit enables seq breaks per channel.
+ %UNIBUS-CHANNEL-BUFFER-OUT-PTR ;Address of next word to extract
+ ;**this last does not really exist now. It should be carried thru on the next cold load.
+ ; It is required for the non-local unibus hack to work in general, altho we can get along
+ ; without it for the time being since the keyboard is always interrupt enabled.**
+ %UNIBUS-CHANNEL-INTERRUPT-ENABLE-BITS ;Bit(s) in CSR which enable interrupts.
+ %UNIBUS-CHANNEL-OUTPUT-TURNOFF-ADDRESS ;Address to write to shut down output channel
+ %UNIBUS-CHANNEL-OUTPUT-TURNOFF-BITS)) ;Value to write into that address
+
+(ASSIGN-VALUES-INIT-DELTA UNIBUS-CHANNEL-QS 0 1 1)
+
+;;; Extra bits in the %UNIBUS-CHANNEL-CSR-BITS word.
+;;; Only the bottom 16 bits actually have to do with the device's CSR register
+;;; (which is only 16 bits long).
+(cl:defvar UNIBUS-CSR-BIT-VALUES '(
+ %%UNIBUS-CSR-OUTPUT 2001 ;This is an output device.
+ %%UNIBUS-CSR-TIMESTAMPED 2101 ;Store timestamp with each input char;
+ ; for output, delay till timestamp is reached.
+ %%UNIBUS-CSR-TWO-DATA-REGISTERS 2201 ;Device has two 16-bit data registers;
+ ; assume lower unibus addr has low bits.
+ %%UNIBUS-CSR-SB-ENABLE 2301 ;Enable sequence break (input only).
+ %%UNIBUS-CSR-SET-BITS-P 2401 ;** %UNIBUS-CHANNEL-CSR-SET-BITS is
+ ; significant.
+ %%UNIBUS-CSR-CLEAR-BITS-P 2501 ;** %UNIBUS-CHANNEL-CSR-CLEAR-BITS is
+ ; significant.
+ ))
+(ASSIGN-ALTERNATE UNIBUS-CSR-BIT-VALUES)
+
+(cl:defvar UNIBUS-CSR-BITS '(
+ %%UNIBUS-CSR-OUTPUT
+ %%UNIBUS-CSR-TIMESTAMPED
+ %%UNIBUS-CSR-TWO-DATA-REGISTERS
+ %%UNIBUS-CSR-SB-ENABLE
+ %%UNIBUS-CSR-SET-BITS-P
+ %%UNIBUS-CSR-CLEAR-BITS-P
+ ))
+
+;;; Definitions for Chaos net hardware and microcode
+
+;;; Command/Status register fields
+
+(cl:defvar CHAOS-HARDWARE-VALUES '(
+ %%CHAOS-CSR-TIMER-INTERRUPT-ENABLE 0001
+ %%CHAOS-CSR-LOOP-BACK 0101
+ %%CHAOS-CSR-RECEIVE-ALL 0201
+ %%CHAOS-CSR-RECEIVER-CLEAR 0301
+ %%CHAOS-CSR-RECEIVE-ENABLE 0401
+ %%CHAOS-CSR-TRANSMIT-ENABLE 0501
+ %%CHAOS-CSR-INTERRUPT-ENABLES 0402
+ %%CHAOS-CSR-TRANSMIT-ABORT 0601
+ %%CHAOS-CSR-TRANSMIT-DONE 0701
+ %%CHAOS-CSR-TRANSMITTER-CLEAR 1001
+ %%CHAOS-CSR-LOST-COUNT 1104
+ %%CHAOS-CSR-RESET 1501
+ %%CHAOS-CSR-CRC-ERROR 1601
+ %%CHAOS-CSR-RECEIVE-DONE 1701
+
+;;; Offsets of other registers from CSR
+;;; These are in words, not bytes
+
+ %CHAOS-MY-NUMBER-OFFSET 1
+ %CHAOS-WRITE-BUFFER-OFFSET 1
+ %CHAOS-READ-BUFFER-OFFSET 2
+ %CHAOS-BIT-COUNT-OFFSET 3
+ %CHAOS-START-TRANSMIT-OFFSET 5))
+
+;;; Leader of a wired Chaos buffer
+
+(cl:defvar CHAOS-BUFFER-LEADER-QS '(
+ %CHAOS-LEADER-WORD-COUNT ;Fill pointer for ART-16B array
+ %CHAOS-LEADER-THREAD ;Next buffer in wired list (free, rcv, xmt)
+ ;NIL for end of list
+ %CHAOS-LEADER-CSR-1 ;Receive stores CSR before reading out here
+ %CHAOS-LEADER-CSR-2 ;Receive stores CSR after reading out here
+ ;Get lost-count from here
+ %CHAOS-LEADER-BIT-COUNT)) ;Receive stores bit-count before reading out
+
+(ASSIGN-VALUES CHAOS-BUFFER-LEADER-QS 0)
+(ASSIGN-ALTERNATE CHAOS-HARDWARE-VALUES)
+(cl:defvar CHAOS-HARDWARE-SYMBOLS (GET-ALTERNATE CHAOS-HARDWARE-VALUES))
+
+;;; Ethernet
+
+;;; Offsets from the base of the ether registers to the specific registers
+(cl:defvar ether-register-offsets '(
+ %ether-mode-offset ;0
+ %ether-int-source-offset ;1
+ %ether-int-mask-offset ;2
+ %ether-ipgt-offset ;3
+ %ether-ipgr1-offset ;4
+ %ether-ipgr2-offset ;5
+ %ether-packetlen-offset ;6
+ %ether-collconf-offset ;7
+ %ether-tx-bd-num-offset ;8
+ %ether-ctrlmode-offset ;9
+ %ether-mii-mode-offset ;10
+ %ether-mii-command-offset ;11
+ %ether-mii-address-offset ;12
+ %ether-mii-tx-data-offset ;13
+ %ether-mii-rx-data-offset ;14
+ %ether-mii-status-offset ;15
+ %ether-mac-address0-offset ;16
+ %ether-mac-address1-offset ;17
+ %ether-hash0-offset ;18
+ %ether-hash1-offset ;19
+ %ether-txctrl-offset ;20
+ ))
+(assign-values ether-register-offsets 0)
+
+;;; Offsets of the leader elements
+(cl:defvar ether-buffer-leader-qs '(
+ %ether-leader-thread ;0
+ %ether-leader-active-length ;1
+ ))
+(assign-values ether-buffer-leader-qs 0)
+
+(cl:defvar ether-hardware-values '(
+ %%ether-desc-length 2020
+ %%ether-desc-tx-ready 1701
+ %%ether-desc-tx-irq 1601
+ %%ether-desc-tx-wrap 1501
+ %%ether-desc-tx-pad 1401
+ %%ether-desc-tx-crc 1301
+
+ %%ether-desc-rx-empty 1701
+ %%ether-desc-rx-irq 1601
+ %%ether-desc-rx-wrap 1501
+
+ %%ether-mode-recsmall 2001
+ %%ether-mode-pad 1701
+ %%ether-mode-hugen 1601
+ %%ether-mode-crc-enable 1501
+ %%ether-mode-fullduplex 1201
+ %%ether-mode-promiscuous 0501
+ %%ether-mode-no-preamble 0201
+ %%ether-mode-tx-enable 0101
+ %%ether-mode-rx-enable 0001
+
+ %%ether-int-rxc 0601
+ %%ether-int-txc 0501
+ %%ether-int-busy 0401
+ %%ether-int-rxe 0301
+ %%ether-int-rxb 0201
+ %%ether-int-txe 0101
+ %%ether-int-txb 0001
+ ))
+
+(assign-alternate ether-hardware-values)
+(cl:defvar ether-hardware-symbols (get-alternate ether-hardware-values))
+
+
+(cl:defvar A-MEMORY-ARRAY-LOCATIONS '(
+ MOUSE-CURSOR-PATTERN 1600
+ MOUSE-BUTTONS-BUFFER 1640
+ MOUSE-X-SCALE-ARRAY 1700
+ MOUSE-Y-SCALE-ARRAY 1720))
+
+(cl:defvar A-MEMORY-ARRAY-SYMBOLS (GET-ALTERNATE A-MEMORY-ARRAY-LOCATIONS))
+
+
+;Use of DTP-INSTANCE. Points to a structure whose header is of
+;type DTP-INSTANCE-HEADER; the pointer field of that header points
+;to a structure (generally an array) which contains the fields described
+;below. This structure is called an instance-descriptor and contains
+;the constant or shared part of the instance. The instance structure,
+;after its DTP-INSTANCE-HEADER, contains several words used as value
+;cells of instance variables, which are the variable or unshared
+;part of the instance.
+;Note that these are offsets, not indices into the array. They
+;are defined here this way because microcode uses them. This could
+;be a cdr-coded list or an instance rather than an array.
+(cl:defvar INSTANCE-DESCRIPTOR-OFFSETS '(
+ %INSTANCE-DESCRIPTOR-HEADER ;The array header.
+ %INSTANCE-DESCRIPTOR-RESERVED ;e.g. for named-structure symbol
+ %INSTANCE-DESCRIPTOR-SIZE ;The size of the instance; this is one more
+ ;than the number of instance-variable slots.
+ ;This is looked at by the garbage collector.
+ %INSTANCE-DESCRIPTOR-BINDINGS
+ ;Describes bindings to perform when the instance
+ ;is called. If this is a list, then SELF is bound
+ ;to the instance and the elements of the list are
+ ;locatives to cells which are bound to EVCP's
+ ;to successive instance-variable slots of the
+ ;instance. If this is not a list, it is something
+ ;reserved for future facilities based on the same
+ ;primitives. NIL is a list.
+ ;Note that if this is a list, it must be CDR-CODED!
+ ;The microcode depends on this for a little extra speed.
+ %INSTANCE-DESCRIPTOR-FUNCTION ;Function to be called when the instance
+ ; is called. Typically a DTP-SELECT-METHOD
+ %INSTANCE-DESCRIPTOR-TYPENAME ;A symbol which is returned by TYPEP
+)) ;Additional slots may exist, defined by the particular class system employed.
+ ;If the instance-descriptor is an array, it must not be so long as to
+ ;contain a long-length Q.
+(ASSIGN-VALUES INSTANCE-DESCRIPTOR-OFFSETS 0)
+
+(cl:defvar METER-ENABLES-VALUES '(
+ %%METER-PAGE-FAULT-ENABLE 0001 ;Page fault metering
+ %%METER-CONS-ENABLE 0101 ;Cons metering
+ %%METER-FUNCTION-ENTRY-EXIT-ENABLE 0201 ;Function call metering
+ %%METER-STACK-GROUP-SWITCH-ENABLE 0301 ;Stack group metering
+ ))
+
+(cl:defvar METER-EVENTS '(
+ %METER-PAGE-IN-EVENT
+ %METER-PAGE-OUT-EVENT
+ %METER-CONS-EVENT
+ %METER-FUNCTION-ENTRY-EVENT
+ %METER-FUNCTION-EXIT-EVENT
+ %METER-FUNCTION-UNWIND-EVENT
+ %METER-STACK-GROUP-SWITCH-EVENT
+ ))
+
+(ASSIGN-ALTERNATE METER-ENABLES-VALUES)
+(cl:defvar METER-ENABLES (GET-ALTERNATE METER-ENABLES-VALUES))
+(ASSIGN-VALUES METER-EVENTS 0 1)
+
+(cl:DEFUN ASSIGN-QCOM-VALUES ()
+ (ASSIGN-VALUES ADI-KINDS 0)
+ (ASSIGN-VALUES ADI-STORING-OPTIONS 0)
+ (ASSIGN-ALTERNATE ARG-DESC-FIELD-VALUES)
+ (ASSIGN-ALTERNATE ARRAY-FIELD-VALUES)
+ (ASSIGN-ALTERNATE ARRAY-LEADER-FIELD-VALUES)
+ (ASSIGN-ALTERNATE ARRAY-MISC-VALUES)
+ (ASSIGN-VALUES ARRAY-TYPES 19.)
+ (ASSIGN-VALUES DATA-TYPES 24.)
+ (ASSIGN-VALUES FEF-ARG-SYNTAX 4)
+ (ASSIGN-VALUES FEF-DES-DT 11)
+ (ASSIGN-VALUES FEF-FUNCTIONAL 15)
+ (ASSIGN-VALUES FEF-INIT-OPTION 0)
+ (ASSIGN-VALUES FEF-NAME-PRESENT 20)
+ (ASSIGN-VALUES FEF-QUOTE-STATUS 7)
+ (ASSIGN-VALUES FEF-SPECIALNESS 16)
+ (ASSIGN-VALUES FEFHI-INDEXES 0)
+ (ASSIGN-ALTERNATE FEFHI-VALUES)
+ (ASSIGN-ALTERNATE HEADER-FIELD-VALUES)
+ (ASSIGN-VALUES HEADER-TYPES 23)
+ (ASSIGN-VALUES Q-CDR-CODES 0)
+ (ASSIGN-VALUES Q-DATA-TYPES 0)
+ (ASSIGN-VALUES Q-HEADER-TYPES 0)
+ (ASSIGN-ALTERNATE SG-STATE-FIELD-VALUES)
+ (ASSIGN-VALUES SG-STATES 0)
+ (ASSIGN-VALUES SG-INST-DISPATCHES 0)
+ (ASSIGN-VALUES SPECIAL-PDL-LEADER-QS 0)
+ (ASSIGN-VALUES STACK-GROUP-HEAD-LEADER-QS 0)
+ (ASSIGN-VALUES SYSTEM-COMMUNICATION-AREA-QS 0)
+ (ASSIGN-VALUES REG-PDL-LEADER-QS 0)
+ )
+
+(ASSIGN-QCOM-VALUES) ;FOO. ASSIGN-VALUES, ETC HAD BETTER BE DEFINED.
Added: trunk/tools/cold/qcom99.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/qcom99.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,1440 @@
+;-*- Mode:LISP; Package:SYSTEM-INTERNALS; Base:8; Readtable:ZL -*-
+
+; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+;;; Loading this with a base of other than 8 can really cause bizarre effects
+;GLOBAL:(UNLESS (= *READ-BASE* 8) (BREAK "*READ-BASE* not 8."))
+
+;;; Numeric values of data types, suitable for being DPB'd into the
+;;; data type field, or returned by (%DATA-TYPE ...).
+(cl:defvar Q-DATA-TYPES '(
+ DTP-TRAP
+ DTP-NULL
+ DTP-FREE
+ DTP-SYMBOL
+ DTP-SYMBOL-HEADER
+ DTP-FIX
+ DTP-EXTENDED-NUMBER
+ DTP-HEADER
+ DTP-GC-FORWARD
+ DTP-EXTERNAL-VALUE-CELL-POINTER
+ DTP-ONE-Q-FORWARD
+ DTP-HEADER-FORWARD
+ DTP-BODY-FORWARD
+ DTP-LOCATIVE
+ DTP-LIST
+ DTP-U-ENTRY
+ DTP-FEF-POINTER
+ DTP-ARRAY-POINTER
+ DTP-ARRAY-HEADER
+ DTP-STACK-GROUP
+ DTP-CLOSURE
+ DTP-SMALL-FLONUM
+ DTP-SELECT-METHOD
+ DTP-INSTANCE
+ DTP-INSTANCE-HEADER
+ DTP-ENTITY
+ DTP-STACK-CLOSURE
+ DTP-SELF-REF-POINTER
+ DTP-CHARACTER))
+
+;;; Numeric values of CDR codes, right-justified in word for %P-CDR-CODE, etc.
+(cl:defvar Q-CDR-CODES '(
+ CDR-NORMAL
+ CDR-ERROR
+ CDR-NIL
+ CDR-NEXT))
+
+;;; Byte pointers at the parts of a Q or other thing, and their values.
+;;; Q-FIELD-VALUES does NOT itself go into the cold load.
+(cl:defvar Q-FIELD-VALUES '(
+ %%Q-CDR-CODE 3602
+ %%Q-BOXED-SIGN-BIT 3001
+ %%Q-DATA-TYPE 3105
+ %%Q-POINTER 0031
+ %%Q-POINTER-WITHIN-PAGE 0010
+ %%Q-TYPED-POINTER 0036
+ %%Q-ALL-BUT-TYPED-POINTER 3602
+ %%Q-ALL-BUT-POINTER 3107
+ %%Q-ALL-BUT-CDR-CODE 0036
+ %%Q-HIGH-HALF 2020 ;Use these for referencing macro instructions
+ %%Q-LOW-HALF 0020
+ %%CH-FONT 1010
+ %%CH-CHAR 0010
+ %%KBD-CHAR 0010
+ %%KBD-CONTROL-META 2504
+ %%KBD-CONTROL 2501
+ %%KBD-META 2601
+ %%KBD-SUPER 2701
+ %%KBD-HYPER 3001
+ %%KBD-MOUSE 2401
+ %%KBD-MOUSE-BUTTON 0003
+ %%KBD-MOUSE-N-CLICKS 0303
+ %%BYTE-SPECIFIER-POSITION 0627
+ %%BYTE-SPECIFIER-SIZE 0006))
+
+;;; Assign the byte pointers their values. Q-FIELDS becomes a list of just names.
+;;; It goes into the cold load, along with the names and their values.
+(ASSIGN-ALTERNATE Q-FIELD-VALUES)
+(cl:defvar Q-FIELDS (GET-ALTERNATE Q-FIELD-VALUES))
+
+;;; Stuff in the REGION-BITS array, some of these bits also appear in the
+;;; map in the same orientation.
+
+(cl:defvar Q-REGION-BITS-VALUES '(
+ %%REGION-MAP-BITS 1612 ;10 bits to go into the map (access/status/meta)
+ ;; 2404 ;access and status bits
+ %%REGION-OLDSPACE-META-BIT 2301 ;0=old or free, 1=new or static or fixed.
+ ;0 causes transport-trap for read of ptr to here
+ %%REGION-EXTRA-PDL-META-BIT 2201 ;0=extra-pdl, 1=normal.
+ ;0 traps writing of ptr to here into "random" mem
+ %%REGION-REPRESENTATION-TYPE 2002 ;Data representation type code:
+ %REGION-REPRESENTATION-TYPE-LIST 0
+ %REGION-REPRESENTATION-TYPE-STRUCTURE 1 ;2 and 3 reserved for future
+ ;; 1602 spare meta bits
+ ;; 1501 spare (formerly unimplemented compact-cons flag)
+ %%REGION-SPACE-TYPE 1104 ;Code for type of space:
+ %REGION-SPACE-FREE 0 ;0 free region slot
+ %REGION-SPACE-OLD 1 ;1 oldspace region of dynamic area
+ %REGION-SPACE-NEW 2 ;2 permanent newspace region of dynamic area
+ %REGION-SPACE-NEW1 3 ;3 temporary space, level 1
+ %REGION-SPACE-NEW2 4 ;4 ..
+ %REGION-SPACE-NEW3 5 ;5 ..
+ %REGION-SPACE-NEW4 6 ;6 ..
+ %REGION-SPACE-NEW5 7 ;7 ..
+ %REGION-SPACE-NEW6 10 ;10 ..
+ %REGION-SPACE-STATIC 11 ;11 static area
+ %REGION-SPACE-FIXED 12 ;12 fixed, static
+ ; not growable
+ ; no consing allowed
+ %REGION-SPACE-EXTRA-PDL 13 ;13 An extra-pdl for some stack-group
+ %REGION-SPACE-COPY 14 ;14 Like newspace, stuff copied from oldspace
+ ; goes here while newly-consed stuff goes
+ ; to newspace. This is for permanent data
+ ;15-17 [not used]
+
+ %%REGION-SCAVENGE-ENABLE 1001 ;If 1, scavenger touches this region
+ ;; 0503 spare bits.
+ %%REGION-SWAPIN-QUANTUM 0005 ;swap this +1 pages in one disk op on swapin
+ ; if possible.
+ ))
+
+(ASSIGN-ALTERNATE Q-REGION-BITS-VALUES)
+(cl:defvar Q-REGION-BITS (GET-ALTERNATE Q-REGION-BITS-VALUES))
+
+(cl:defvar SYSTEM-COMMUNICATION-AREA-QS '(
+ ;; LOCATIONS RELATIVE TO 400 IN CADR
+ ;; locations 400-437 are miscellaneous Qs declared below
+ ;; locations 440-477 are the reverse first level map
+ ;; locations 500-511 are the keyboard buffer header (buffer is 200-377)
+ ;; locations 600-637 are the disk-error log
+ ;; locations 700-777 are reserved for disk CCW's (only 777 used now)
+ ;; In CADR, location 777 is used (for now) by the disk code for the CCW.
+ ;; --actually it seems to use locations 12-377 for the CCW most of the time.
+ ;; THE FOLLOWING ARE COMMENTS FOR THE LAMBDA
+ ;; locations 640-647 are the IOPB command block for disk control on Lambda.
+ ;; locations 650-667 are the PHYSICAL order to NUBUS-SLOT map on Lambda.
+ ;; ea word applies to next memory in sequence, bit 31 set terminates list.
+ ;; word is <quadrand,slot>,, <number of active pages>
+ ;; unfortunately, for the time being, the world still has to agree implicitly
+ ;; on a slot number for the lowest memory, which holds this data!
+ ;; locations 700-777 are reserved for disk CCW's
+ ;; locations 700-720 used for swap out.
+ ;; locations 740-760 used for swap in.
+ ;; location 777 is used during booting, etc.
+ ;; (other, higher, locations are used temporarily during band copying.)
+ ;; on CADR, CC-DISK-XFER uses locations 12-377 for the CCW.
+ ;; DCHECK, etc, use 777 for CCW.
+
+ %SYS-COM-AREA-ORIGIN-PNTR ;ADDRESS OF AREA-ORIGIN AREA
+ %SYS-COM-VALID-SIZE ;IN A SAVED BAND, NUMBER OF WORDS USED
+ ; note in a new format band, this is
+ ; no longer the highest virtual address.
+ %SYS-COM-PAGE-TABLE-PNTR ;ADDRESS OF PAGE-TABLE-AREA
+ %SYS-COM-PAGE-TABLE-SIZE ;NUMBER OF QS
+ %SYS-COM-OBARRAY-PNTR ;CURRENT OBARRAY, COULD BE AN ARRAY-POINTER
+ ;BUT NOW IS USUALLY A SYMBOL WHOSE VALUE
+ ;IS THE CURRENTLY-SELECTED OBARRAY (PACKAGE)
+ ;; Ether net interrupt-handler variables
+ %SYS-COM-ETHER-FREE-LIST
+ %SYS-COM-ETHER-TRANSMIT-LIST
+ %SYS-COM-ETHER-RECEIVE-LIST
+
+ %SYS-COM-BAND-FORMAT ;In a saved band, encodes format number.
+ ; 1000 -> new compressed format
+ ; otherwise old expanded format.
+ ;In old bands, this is not really initialized
+ ; but is usually 410.
+
+ %SYS-COM-GC-GENERATION-NUMBER ;reserved for value of %GC-GENERATION-NUMBER
+
+ %SYS-COM-UNIBUS-INTERRUPT-LIST ;SEE LMIO;UNIBUS (LIST OF UNIBUS CHANNELS)
+
+ %SYS-COM-TEMPORARY ;Microcode bashes this at EXTRA-PDL-PURGE
+
+ %SYS-COM-FREE-AREA#-LIST ;Threaded through AREA-REGION-LIST, End=0
+ %SYS-COM-FREE-REGION#-LIST ;Threaded through REGION-LIST-THREAD, End=0
+ %SYS-COM-MEMORY-SIZE ;Number of words of main memory
+ %SYS-COM-WIRED-SIZE ;Number words of low memory wired down
+ ; Not all of these words are wired; this is
+ ; really the virtual address of the start
+ ; of normal pageable memory
+
+ ;; Chaos net interrupt-handler variables
+ %SYS-COM-CHAOS-FREE-LIST
+ %SYS-COM-CHAOS-TRANSMIT-LIST
+ %SYS-COM-CHAOS-RECEIVE-LIST
+
+ ;; Debugger locations (*** these seem not to be used ***)
+ %SYS-COM-DEBUGGER-REQUESTS ;REQUEST TO POWER CONTROL/DEBUGGER
+ %SYS-COM-DEBUGGER-KEEP-ALIVE ;KEEP ALIVE FLAG WORD
+ %SYS-COM-DEBUGGER-DATA-1 ;FOR INTERCOMMUNICATION
+ %SYS-COM-DEBUGGER-DATA-2
+
+ %SYS-COM-MAJOR-VERSION ;Major version number of SYSTEM.
+ ; Was not set up before 98.9 or so.
+ %SYS-COM-DESIRED-MICROCODE-VERSION ;Microcode version this world expects
+ ; Note: this word may be stored with its data type
+ ; field starting at bit 24 even though pointer
+ ; fields are now 25 bits!
+
+ ;; To be added:
+ ;; Swap out scheduler and disk stuff
+ ;; Eventually this may replace SCRATCH-PAD-INIT-AREA
+ ;; Those of these that don't need to survive warm boot could be in A-MEMORY
+ %SYS-COM-HIGHEST-VIRTUAL-ADDRESS ;In new band format. You better have this amt of
+ ; room in the paging partition.
+ %SYS-COM-POINTER-WIDTH ;Either 24 or 25, as fixnum, or DTP-FREE in old sys.
+ ;; 6 left
+ ))
+
+;(AND (> (LENGTH SYSTEM-COMMUNICATION-AREA-QS) 40)
+; (ERROR "System Communication Area Overflow"))
+
+;;; Used by micro assembler.
+(cl:defvar MICRO-CODE-SYMBOL-AREA-SIZE 2000)
+
+;;; The value of ARRAY-INDEX-ORDER that a cold load or microassembly is being made for.
+(cl:defvar NEW-ARRAY-INDEX-ORDER T)
+
+;;; This list had better be in the same order as the corresponding variables in the UCODE.
+(cl:defvar AREA-LIST '(
+ RESIDENT-SYMBOL-AREA ;T and NIL
+ SYSTEM-COMMUNICATION-AREA ;Used by paging, console, pdp10 i/o, etc.
+ SCRATCH-PAD-INIT-AREA ;Load micro code variables upon startup
+ MICRO-CODE-SYMBOL-AREA ;600 Qs misc dispatch, ucode entry dispatch
+ ;; MICRO-CODE-SYMBOL-AREA is considered part of the microcode, not the band.
+ ;; the disk-restore microcode knows about it, and its length.
+ REGION-ORIGIN ;Fixnum base address indexed by region #
+ REGION-LENGTH ;Fixnum length indexed by region #
+ REGION-BITS ;Fixnum, see %%REGION- syms for fields
+ REGION-FREE-POINTER ;Fixnum, relative allocation point.
+ ;; Below here must not be clobbered by DISK-COPY routines in the ucode.
+ PAGE-TABLE-AREA ;Page hash table
+ PHYSICAL-PAGE-DATA ;GC-DATA,,PHT-INDEX
+ ; -1 if out of service
+ ; PHT-INDEX=-1 if fixed-wired (no PHT entry)
+ ; GC-DATA=0 if not in use
+ ADDRESS-SPACE-MAP ;See %ADDRESS-SPACE-MAP-BYTE-SIZE below
+ ;; End wired areas
+ REGION-GC-POINTER ;Gc use, mainly relative dirty/clean boundary
+ REGION-LIST-THREAD ;Next region# in area, or 1_23.+area#
+ ; Threads free region slots, too.
+ AREA-NAME ;Atomic name indexed by area #
+ AREA-REGION-LIST ;First region# in area
+ AREA-REGION-BITS ;Get region-bits of new regions from this.
+ AREA-REGION-SIZE ;Recommended size for new regions
+ AREA-MAXIMUM-SIZE ;Approximate maximum #wds allowed in this area
+ SUPPORT-ENTRY-VECTOR ;Constants needed by basic microcode
+ CONSTANTS-AREA ;Common constants used by macrocode
+ ;; NOTE!! EXTRA-PDL-AREA must end on a address space quantuum boundary!!
+ EXTRA-PDL-AREA ;Separately gc-able area, mainly extended nums
+ ; Must be right before MICRO-CODE-ENTRY-AREA
+ MICRO-CODE-ENTRY-AREA ;Micro entry address
+ ; Or locative indirect MICRO-CODE-SYMBOL-AREA
+ MICRO-CODE-ENTRY-NAME-AREA ;Micro entry name
+ MICRO-CODE-ENTRY-ARGS-INFO-AREA ;Micro entry %ARGS-INFO
+ MICRO-CODE-ENTRY-MAX-PDL-USAGE ;Micro entry pdl depth incl micro-micro calls
+ MICRO-CODE-PAGING-AREA ;Hold virtual microcode memory.
+ PAGE-GC-BITS ;Bits recording what ptrs exist in each page
+ PAGE-STRUCTURE-HANDLES ;Location of first structure on each page
+ ;; Areas after here are not "initial"; not known specially by microcode
+ MICRO-CODE-ENTRY-ARGLIST-AREA ;Value for arglist function to return
+ MICRO-CODE-SYMBOL-NAME-AREA ;Names of micro-code-symbol-area entries
+ LINEAR-PDL-AREA ;Main pdl
+ LINEAR-BIND-PDL-AREA ;Corresponding bind pdl
+ INIT-LIST-AREA ;List constants created by cold load
+ ;; End fixed areas, which must have only one region
+ WORKING-STORAGE-AREA ;Ordinary consing happens here
+ PERMANENT-STORAGE-AREA ;Put "permanent" data structures here
+ PROPERTY-LIST-AREA ;Exists for paging Reasons
+ P-N-STRING ;Print names and strings
+ CONTROL-TABLES ;Obarray, readtable (semi-obsolete)
+ NR-SYM ;Symbols not in resident-symbol-area
+ MACRO-COMPILED-PROGRAM ;Macro code loaded here
+ PDL-AREA ;Put stack-group regular-pdls here
+ FASL-TABLE-AREA ;Fasload's table is here
+ FASL-TEMP-AREA ;Fasload temporary consing
+ ))
+
+;;; Default area size is one page
+(cl:defvar COLD-LOAD-AREA-SIZES '(
+ P-N-STRING 600
+ NR-SYM 500
+ MACRO-COMPILED-PROGRAM 1000
+ PAGE-TABLE-AREA 128. ;Enough for 2 megawords of main memory
+ PHYSICAL-PAGE-DATA 32. ;Enough for 2 megawords of main memory
+ ADDRESS-SPACE-MAP 2 ;Must start on a level-2 map boundary.
+ LINEAR-PDL-AREA 100
+ LINEAR-BIND-PDL-AREA 10
+ PDL-AREA 300
+ WORKING-STORAGE-AREA 400
+ PERMANENT-STORAGE-AREA 200
+ PROPERTY-LIST-AREA 100
+ CONTROL-TABLES 13
+ INIT-LIST-AREA 340
+ MICRO-CODE-ENTRY-AREA 4
+ MICRO-CODE-ENTRY-NAME-AREA 4
+ MICRO-CODE-ENTRY-ARGS-INFO-AREA 4
+ MICRO-CODE-ENTRY-ARGLIST-AREA 4
+ MICRO-CODE-ENTRY-MAX-PDL-USAGE 4
+ MICRO-CODE-SYMBOL-NAME-AREA 4
+ MICRO-CODE-SYMBOL-AREA 5
+ MICRO-CODE-PAGING-AREA 1000
+ PAGE-GC-BITS 40
+ PAGE-STRUCTURE-HANDLES 200
+ FASL-TABLE-AREA 201 ;3 times length-of-fasl-table plus 1 page
+ EXTRA-PDL-AREA 111 ;NOTE!! this is carefully calculated to cause
+ ; EXTRA-PDL-AREA to end on a level-2 map boundary (200000)
+ FASL-TEMP-AREA 40
+ ))
+
+;;; Next three symbols are treated bletcherously, because there isnt the right kind of
+;;; LDB available
+
+;;; VIRTUAL ADDRESS OF 0 at A. MUST AGREE WITH VALUE IN UCADR.
+;;; (unfortunately called LOWEST-A-MEM-VIRTUAL-ADDRESS).
+;;; Virtual address of X-BUS IO space.
+;;; Must agree with LOWEST-IO-SPACE-VIRTUAL-ADDRESS in UCADR.
+;;; Virtual address of UNIBUS IO space.
+;;; Must agree with LOWEST-UNIBUS-VIRTUAL-ADDRESS in UCADR.
+
+; old 24-bit pointer values
+;(GLOBAL:IF (GLOBAL:NOT GLOBAL:(OR (EQ PACKAGE (FIND-PACKAGE "SYM"))
+; (> %MICROCODE-VERSION-NUMBER 309.))
+;(DEFCONST A-MEMORY-VIRTUAL-ADDRESS 76776000)
+;(DEFCONST IO-SPACE-VIRTUAL-ADDRESS 77000000)
+;(DEFCONST UNIBUS-VIRTUAL-ADDRESS 77400000)
+
+(cl:defvar A-MEMORY-VIRTUAL-ADDRESS 176776000) ; (%P-LDB-OFFSET 0031 176776000 1))
+(cl:defvar IO-SPACE-VIRTUAL-ADDRESS 177000000) ; (%P-LDB-OFFSET 0031 177000000 1))
+(cl:defvar UNIBUS-VIRTUAL-ADDRESS 177400000) ; (%P-LDB-OFFSET 0031 177400000 1))
+ ; doing an (ENABLE-TRAPPING)
+
+(cl:defvar MULTIBUS-VIRTUAL-ADDRESS 177400000) ; (%P-LDB-OFFSET 0031 177400000 1))
+
+(cl:defvar HEADER-FIELD-VALUES '(%%HEADER-TYPE-FIELD 2305 %%HEADER-REST-FIELD 0023))
+(cl:defvar HEADER-FIELDS (GET-ALTERNATE HEADER-FIELD-VALUES))
+
+;;; These are the values that go in the %%HEADER-TYPE-FIELD of a Q of
+;;; data type DTP-HEADER.
+(cl:defvar Q-HEADER-TYPES '(
+ %HEADER-TYPE-ERROR
+ %HEADER-TYPE-FEF
+ %HEADER-TYPE-ARRAY-LEADER
+ %HEADER-TYPE-unused
+ %HEADER-TYPE-FLONUM
+ %HEADER-TYPE-COMPLEX
+ %HEADER-TYPE-BIGNUM
+ %HEADER-TYPE-RATIONAL
+ %HEADER-TYPE-FAST-FEF-FIXED-ARGS-NO-LOCALS
+ %HEADER-TYPE-FAST-FEF-VAR-ARGS-NO-LOCALS
+ %HEADER-TYPE-FAST-FEF-FIXED-ARGS-WITH-LOCALS
+ %HEADER-TYPE-FAST-FEF-VAR-ARGS-WITH-LOCALS
+ ))
+
+;;; These three lists describing the possible types of "argument descriptor info"
+(cl:defvar ADI-KINDS '(
+ ADI-ERR
+ ADI-RETURN-INFO
+ ADI-RESTART-PC
+ ADI-FEXPR-CALL
+ ADI-LEXPR-CALL
+ ADI-BIND-STACK-LEVEL
+ ADI-UNUSED-6
+ ADI-USED-UP-RETURN-INFO
+ ))
+
+(cl:defvar ADI-STORING-OPTIONS '(
+ ADI-ST-ERR
+ ADI-ST-BLOCK
+ ADI-ST-LIST
+ ADI-ST-MAKE-LIST
+ ADI-ST-INDIRECT
+ ))
+
+(cl:defvar ADI-FIELD-VALUES '(
+ %%ADI-TYPE 2403
+ %%ADI-RET-STORING-OPTION 2103
+ %%ADI-PREVIOUS-ADI-FLAG 3601 ;Overlaps cdr-code which isn"t used in ADI words.
+ %%ADI-RET-SWAP-SV 2001
+ %%ADI-RET-NUM-VALS-TOTAL 0606 ;For ADI-ST-BLOCK; total number of values wanted.
+ %%ADI-RET-NUM-VALS-EXPECTING 0006 ;For ADI-ST-BLOCK; number of values still room for.
+ %%ADI-RPC-MICRO-STACK-LEVEL 0006
+ ))
+(ASSIGN-ALTERNATE ADI-FIELD-VALUES)
+(cl:defvar ADI-FIELDS (GET-ALTERNATE ADI-FIELD-VALUES))
+
+;;; These overlap the cdr-code field, which is not used in the special pdl.
+(cl:defvar SPECPDL-FIELD-VALUES '(
+ %%SPECPDL-BLOCK-START-FLAG 3601 ;Flag is set on first binding of each block of bindings
+ %%SPECPDL-CLOSURE-BINDING 3701 ;Flag is set on bindings made "before" entering function
+ ))
+(ASSIGN-ALTERNATE SPECPDL-FIELD-VALUES)
+(cl:defvar SPECPDL-FIELDS (GET-ALTERNATE SPECPDL-FIELD-VALUES))
+
+;;; LINEAR-PDL-QS and LINEAR-PDL-FIELDS, and their elements, go in the real machine.
+(cl:defvar LINEAR-PDL-QS '(
+ %LP-FEF
+ %LP-ENTRY-STATE
+ %LP-EXIT-STATE
+ %LP-CALL-STATE
+ ))
+;;; These are assigned values starting with 0 and incremented by -1
+(ASSIGN-VALUES-INIT-DELTA LINEAR-PDL-QS 0 0 -1)
+
+(cl:defvar %LP-CALL-BLOCK-LENGTH (cl:LENGTH LINEAR-PDL-QS))
+(cl:defvar LLPFRM 4) ;Number of fixed words in a linear call block. (Obsolete, use above)
+
+(cl:defvar %LP-INITIAL-LOCAL-BLOCK-OFFSET 1)
+
+(cl:defvar LINEAR-PDL-FIELDS-VALUES '(
+ ;LPCLS (%LP-CALL-STATE). Stored when this call frame is created.
+ ;; Set if any of the following bits are set (used for fast check when returning from call):
+ ;; TRAP-ON-EXIT, ADI-PRESENT, MICRO-STACK-SAVED, BINDING-BLOCK-PUSHED,
+ ;; ENVIRONMENT-POINTER-POINTS-HERE, or function exit/entry metering is enabled,
+ ;; or this frame just needs to be unwound.
+ %%LP-CLS-ATTENTION 3001
+ ;; If set, need not compute SELF-MAPPING-TABLE
+ ;; because our caller has done so.
+ %%LP-CLS-SELF-MAP-PROVIDED 2701
+ ;; If set, get error before popping this frame.
+ %%LP-CLS-TRAP-ON-EXIT 2601
+ ;; ADI words precede this call-block
+ %%LP-CLS-ADI-PRESENT 2401
+ ;; Where in the caller to put this frame's value
+ %%LP-CLS-DESTINATION 2004
+ ;; This includes the destination field and ADI bit.
+ %%LP-CLS-DESTINATION-AND-ADI 2005
+ ;; Offset back to previous open or active block
+ ;; An open block is one whose args are being made
+ %%LP-CLS-DELTA-TO-OPEN-BLOCK 1010
+ ;; Offset back to previous active block
+ ;; An active block is one that is executing
+ %%LP-CLS-DELTA-TO-ACTIVE-BLOCK 0010
+ ;LPEXS (%LP-EXIT-STATE). Stored when this frame calls out.
+ ; bits 22'-27' not used in LPEXS
+ ;; A microstack frame exists on special pdl
+ %%LP-EXS-MICRO-STACK-SAVED 2101
+ ;; Same as below
+ %%LP-EXS-PC-STATUS 2001
+ ;; M-QBBFL STORED HERE IN MACRO EXIT OPERATION
+ %%LP-EXS-BINDING-BLOCK-PUSHED 2001
+ ;; LC as offset in halfwords from FEF
+ ;; Meaningless if %LP-FEF not a fef.
+ ;; Don't change %%LP-EXS-EXIT-PC --- the numerical value is known by UCADR
+ %%LP-EXS-EXIT-PC 0017
+ ;LPENS (%LP-ENTRY-STATE). Stored when this frame entered.
+ ; bits 21'-27' not used in LPENS
+ ;; This is nonzero if an explicit rest arg is passed.
+ %%LP-ENS-LCTYP 2001
+ ;; Here are the fields that the entry state normally contains.
+ ;; This is 1 if this frame has a rest arg living on the stack.
+ ;; Means this frame cannot be flushed for tail recursion.
+ %%LP-ENS-UNSAFE-REST-ARG 1701
+ ;; This includes the number-of-args field and the unsafe field.
+ %%LP-ENS-NUM-ARGS-AND-UNSAFE-FLAG 1010
+ ;; This is a pointer to the unsafe flag, within the byte that goes
+ ;; into the %%lp-ens-num-args-and-unsafe-flag field.
+ %%LP-ENS-UNSAFE-REST-ARG-1 0701
+ %%LP-ENS-ENVIRONMENT-POINTER-POINTS-HERE 1601
+ %%LP-ENS-NUM-ARGS-SUPPLIED 1006
+ %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN 0010
+ ))
+
+(ASSIGN-ALTERNATE LINEAR-PDL-FIELDS-VALUES)
+(cl:defvar LINEAR-PDL-FIELDS (GET-ALTERNATE LINEAR-PDL-FIELDS-VALUES))
+
+;;; MICRO-STACK-FIELDS and its elements go in the real machine.
+(cl:defvar MICRO-STACK-FIELDS-VALUES '(
+ %%US-RPC 1600 ;Return PC
+ %%US-MACRO-INSTRUCTION-RETURN 1601 ;Triggers instruction-stream stuff
+ %%US-PPBMIA 1701 ;ADI on micro-to-micro-call
+ %%US-PPBSPC 2101 ;Binding block pushed
+ ))
+
+(ASSIGN-ALTERNATE MICRO-STACK-FIELDS-VALUES)
+(cl:defvar MICRO-STACK-FIELDS (GET-ALTERNATE MICRO-STACK-FIELDS-VALUES))
+
+
+;;;; M-FLAGS-FIELDS and M-ERROR-SUBSTATUS-FIELDS and their elements go in the real machine.
+(cl:defvar M-FLAGS-FIELDS-VALUES '( ;MUST AGREE WITH DEFS IN UCONS
+ %%M-FLAGS-QBBFL 0001 ;Bind block open flag
+ %%M-FLAGS-CAR-SYM-MODE 0102 ;CAR of symbol gives: error, error except
+ ; (CAR NIL) -> nil, nil, p-name pointer
+ %%M-FLAGS-CAR-NUM-MODE 0302 ;CAR of number gives: error, nil, "what it is"
+ %%M-FLAGS-CDR-SYM-MODE 0502 ;CDR of symbol gives: error, error except
+ ; (cdr NIL) -> NIL, NIL, PROPERTY-LIST
+ %%M-FLAGS-CDR-NUM-MODE 0702 ;CDR of number gives: error, nil, "what it is"
+ %%M-FLAGS-DONT-SWAP-IN 1101 ;MAGIC FLAG FOR CREATING FRESH PAGES
+ %%M-FLAGS-TRAP-ENABLE 1201 ;1 enable error trapping
+ %%M-FLAGS-MAR-MODE 1302 ;1-BIT = read-trap, 2-BIT = write-trap
+ %%M-FLAGS-PGF-WRITE 1501 ;Flag used by page fault routine
+ %%M-FLAGS-INTERRUPT 1601 ;In microcode interrupt
+ %%M-FLAGS-SCAVENGE 1701 ;In scavenger
+ %%M-FLAGS-TRANSPORT 2001 ;In transporter
+ %%M-FLAGS-STACK-GROUP-SWITCH 2101 ;Switching stack groups
+ %%M-FLAGS-DEFERRED-SEQUENCE-BREAK 2201 ;Sequence break pending but inhibited
+ %%M-FLAGS-METER-ENABLE 2301 ;Metering enabled for this stack group
+ %%M-FLAGS-TRAP-ON-CALL 2401 ;Trap on attempting to activate new frame.
+ ))
+(ASSIGN-ALTERNATE M-FLAGS-FIELDS-VALUES)
+(cl:defvar M-FLAGS-FIELDS (GET-ALTERNATE M-FLAGS-FIELDS-VALUES))
+
+(cl:defvar M-ERROR-SUBSTATUS-FIELDS-VALUES '( ;MUST AGREE WITH DEFS IN UCONS
+ %%M-ESUBS-TOO-FEW-ARGS 0001
+ %%M-ESUBS-TOO-MANY-ARGS 0101
+ %%M-ESUBS-BAD-QUOTED-ARG 0201
+ %%M-ESUBS-BAD-EVALED-ARG 0301
+ %%M-ESUBS-BAD-DT 0401
+ %%M-ESUBS-BAD-QUOTE-STATUS 0501
+ ))
+(ASSIGN-ALTERNATE M-ERROR-SUBSTATUS-FIELDS-VALUES)
+(cl:defvar M-ERROR-SUBSTATUS-FIELDS (GET-ALTERNATE M-ERROR-SUBSTATUS-FIELDS-VALUES))
+
+;;; A "Numeric Argument Description" is what %ARGS-INFO and ARGS-INFO return.
+;;; Such descriptors can also be hung on symbols' Q-ARGS-PROP properties.
+;;; The "fast option Q" of a FEF is stored in this format.
+;;; These symbols go in the real machine.
+(cl:defvar NUMERIC-ARG-DESC-INFO '(
+ %ARG-DESC-QUOTED-REST 10000000 ;HAS QUOTED REST ARGUMENT
+ %%ARG-DESC-QUOTED-REST 2501
+ %ARG-DESC-EVALED-REST 4000000 ;HAS EVALUATED REST ARGUMENT
+ %%ARG-DESC-EVALED-REST 2401
+ %%ARG-DESC-ANY-REST 2402 ;NON-ZERO IF HAS EITHER KIND OF REST ARG
+ %ARG-DESC-FEF-QUOTE-HAIR 2000000 ;MACRO COMPILED FCN WITH HAIRY QUOTING,
+ %%ARG-DESC-FEF-QUOTE-HAIR 2301 ; CALLER MUST CHECK A-D-L FOR FULL INFO
+ %ARG-DESC-INTERPRETED 1000000 ;THIS IS INTERPRETED FUNCTION,
+ %%ARG-DESC-INTERPRETED 2201 ; NO INFORMATION AVAILABLE (VAL=1000077)
+ %ARG-DESC-FEF-BIND-HAIR 400000 ;MACRO COMPILED FCN WITH HAIRY BINDING,
+ %%ARG-DESC-FEF-BIND-HAIR 2101 ; LINEAR ENTER MUST CHECK A-D-L
+ %%ARG-DESC-MIN-ARGS 0606 ;MINIMUM NUMBER OF REQUIRED ARGS
+ %%ARG-DESC-MAX-ARGS 0006 ;MAXIMUM NUMBER OF REQUIRED+OPTIONAL
+ ; ARGS. REST ARGS NOT COUNTED.
+ ))
+(ASSIGN-ALTERNATE NUMERIC-ARG-DESC-INFO)
+(cl:defvar NUMERIC-ARG-DESC-FIELDS (GET-ALTERNATE NUMERIC-ARG-DESC-INFO))
+
+(cl:defvar ARG-DESC-FIELD-VALUES '(
+ %FEF-ARG-SYNTAX 160
+ %FEF-QUOTE-STATUS 600
+ %FEF-DES-DT 17000
+ %FEF-INIT-OPTION 17
+ %FEF-SPECIAL-BIT #.(cl:ash 1 16)
+ %FEF-NAME-PRESENT #.(cl:ash 1 20)
+ ;; ***UNFORTUNATELY, ASSIGN-COMP-VALUES KNOWS ABOUT THESE TOO****
+ %%FEF-NAME-PRESENT 2001
+ %%FEF-SPECIAL-BIT 1601
+ %%FEF-SPECIALNESS 1602
+ %%FEF-FUNCTIONAL 1501
+ %%FEF-DES-DT 1104
+ %%FEF-QUOTE-STATUS 0702
+ %%FEF-ARG-SYNTAX 0403
+ %%FEF-INIT-OPTION 0004
+ ))
+(ASSIGN-ALTERNATE ARG-DESC-FIELD-VALUES)
+(cl:defvar ARG-DESC-FIELDS (GET-ALTERNATE ARG-DESC-FIELD-VALUES))
+ ;ARG-DESC-FIELDS GETS SET TO A LIST CONSISTING OF THE ALTERNATING MEMBERS OF
+ ;ARG-DESC-FIELD-VALUES
+
+(cl:defvar FEF-NAME-PRESENT '(
+ FEF-NM-NO
+ FEF-NM-YES
+ ))
+(cl:defvar FEF-SPECIALNESS '(
+ FEF-LOCAL
+ FEF-SPECIAL
+ FEF-SPECIALNESS-UNUSED
+ FEF-REMOTE
+ ))
+(cl:defvar FEF-FUNCTIONAL '(
+ FEF-FUNCTIONAL-DONTKNOW
+ FEF-FUNCTIONAL-ARG
+ ))
+(cl:defvar FEF-DES-DT '(
+ FEF-DT-DONTCARE
+ FEF-DT-NUMBER
+ FEF-DT-FIXNUM
+ FEF-DT-SYM
+ FEF-DT-ATOM
+ FEF-DT-LIST
+ FEF-DT-FRAME
+ ))
+(cl:defvar FEF-QUOTE-STATUS '(
+ FEF-QT-DONTCARE
+ FEF-QT-EVAL
+ FEF-QT-QT
+ ))
+(cl:defvar FEF-ARG-SYNTAX '(
+ FEF-ARG-REQ
+ FEF-ARG-OPT
+ FEF-ARG-REST
+ FEF-ARG-AUX
+ FEF-ARG-FREE
+ FEF-ARG-INTERNAL
+ FEF-ARG-INTERNAL-AUX
+ ))
+(cl:defvar FEF-INIT-OPTION '(
+ FEF-INI-NONE
+ FEF-INI-NIL
+ FEF-INI-PNTR
+ FEF-INI-C-PNTR
+ FEF-INI-OPT-SA
+ FEF-INI-COMP-C
+ FEF-INI-EFF-ADR
+ FEF-INI-SELF
+ ))
+
+
+(cl:defvar ARRAY-FIELD-VALUES '(
+ %%ARRAY-TYPE-FIELD 2305
+ %%ARRAY-LEADER-BIT 2101
+ %%ARRAY-DISPLACED-BIT 2001
+ %%ARRAY-FLAG-BIT 1701
+ %%ARRAY-NUMBER-DIMENSIONS 1403
+ %%ARRAY-LONG-LENGTH-FLAG 1301
+ %%ARRAY-NAMED-STRUCTURE-FLAG 1201
+ %%ARRAY-INDEX-LENGTH-IF-SHORT 0012
+ %ARRAY-MAX-SHORT-INDEX-LENGTH 1777
+ ))
+
+(cl:defvar ARRAY-LEADER-FIELD-VALUES '(
+ %ARRAY-LEADER-LENGTH 777777
+ %%ARRAY-LEADER-LENGTH 0022
+ %%ARRAY-LEADER-FUNCALL-AS-HASH-TABLE 2201
+ ))
+
+(cl:defvar ARRAY-MISC-VALUES '(
+ ARRAY-DIM-MULT #.(cl:ash 1 14)
+ ARRAY-DIMENSION-SHIFT -14
+ ARRAY-TYPE-SHIFT -23
+ ARRAY-LEADER-BIT #.(cl:ash 1 21)
+ ARRAY-DISPLACED-BIT #.(cl:ash 1 20)
+ ARRAY-LONG-LENGTH-FLAG #.(cl:ash 1 13)
+ ARRAY-NAMED-STRUCTURE-FLAG #.(cl:ash 1 12)))
+
+(cl:defvar ARRAY-FIELDS (GET-ALTERNATE ARRAY-FIELD-VALUES))
+(cl:defvar ARRAY-LEADER-FIELDS (GET-ALTERNATE ARRAY-LEADER-FIELD-VALUES))
+(cl:defvar ARRAY-MISCS (GET-ALTERNATE ARRAY-MISC-VALUES))
+
+(cl:defvar ARRAY-TYPES '(
+ ART-ERROR
+ ART-1B
+ ART-2B
+ ART-4B
+ ART-8B
+ ART-16B
+ ART-32B
+ ART-Q
+ ART-Q-LIST
+ ART-STRING
+ ART-STACK-GROUP-HEAD
+ ART-SPECIAL-PDL
+ ART-HALF-FIX
+ ART-REG-PDL
+ ART-FLOAT
+ ART-FPS-FLOAT
+ ART-FAT-STRING
+ ART-COMPLEX-FLOAT
+ ART-COMPLEX
+ ART-COMPLEX-FPS-FLOAT
+ ))
+
+(cl:defvar ARRAY-ELEMENTS-PER-Q '(
+ (ART-Q . 1)
+ (ART-STRING . 4)
+ (ART-1B . 40)
+ (ART-2B . 20)
+ (ART-4B . 10)
+ (ART-8B . 4)
+ (ART-16B . 2)
+ (ART-32B . 1)
+ (ART-Q-LIST . 1)
+ (ART-STACK-GROUP-HEAD . 1)
+ (ART-SPECIAL-PDL . 1)
+ (ART-HALF-FIX . 2)
+ (ART-REG-PDL . 1)
+ (ART-FLOAT . -2)
+ (ART-FPS-FLOAT . 1)
+ (ART-FAT-STRING . 2)
+ (ART-COMPLEX-FLOAT . -4)
+ (ART-COMPLEX . -2)
+ (ART-COMPLEX-FPS-FLOAT . -2)
+ ))
+
+;;; NIL for Q-type arrays
+(cl:defvar ARRAY-BITS-PER-ELEMENT '(
+ (ART-Q . NIL)
+ (ART-STRING . 8)
+ (ART-1B . 1)
+ (ART-2B . 2)
+ (ART-4B . 4)
+ (ART-8B . 8)
+ (ART-16B . 16.)
+ (ART-32B . 24.)
+ (ART-Q-LIST . NIL)
+ (ART-STACK-GROUP-HEAD . NIL)
+ (ART-SPECIAL-PDL . NIL)
+ (ART-HALF-FIX . 16.)
+ (ART-REG-PDL . NIL)
+ (ART-FLOAT . 32.)
+ (ART-FPS-FLOAT . 32.)
+ (ART-FAT-STRING . 16.)
+ (ART-COMPLEX-FLOAT . 32.)
+ (ART-COMPLEX . 32.)
+ (ART-COMPLEX-FPS-FLOAT . 32.)))
+
+;;; Fields in a DTP-SELF-REF-POINTER. RELOCATE-FLAG says use SELF-MAPPING-TABLE;
+;;; INDEX is slot number in self, or index in mapping table.
+;;; the WORD-INDEX is the index divided by two, to index by words in mapping table.
+;;; The map-leader-flag says to get the contents of an array leader slot
+;;; of the mapping table; in this case, the index is the leader slot number.
+
+;;; If %%SELF-REF-MONITOR-FLAG is set, this is a monitor pointer.
+;;; It acts like a one-q forward to the following word,
+;;; except that all write references get a continuable error.
+(cl:defvar SELF-REF-POINTER-FIELD-VALUES '(
+ %%SELF-REF-RELOCATE-FLAG 2301
+ %%SELF-REF-MAP-LEADER-FLAG 2201
+ %%SELF-REF-MONITOR-FLAG 2101
+ %%SELF-REF-INDEX 0014
+ %%SELF-REF-WORD-INDEX 0113
+ ))
+(ASSIGN-ALTERNATE SELF-REF-POINTER-FIELD-VALUES)
+(cl:defvar SELF-REF-POINTER-FIELDS (GET-ALTERNATE SELF-REF-POINTER-FIELD-VALUES))
+
+;;; FEF header fields
+(cl:defvar FEFH-CONSTANT-VALUES '(
+ %FEFH-PC 77777 ;There are 19 available bits in this word!
+ %FEFH-NO-ADL #.(cl:ash 1 18.)
+ %FEFH-FAST-ARG #.(cl:ash 1 17.)
+ %FEFH-SV-BIND #.(cl:ash 1 16.)
+ %%FEFH-PC 0017
+ %%FEFH-PC-IN-WORDS 0116
+ %%FEFH-NO-ADL 2201
+ %%FEFH-GET-SELF-MAPPING-TABLE 1701 ;Mapping table flavor name precedes ADL.
+ %%FEFH-FAST-ARG 2101
+ %%FEFH-SV-BIND 2001
+ ))
+(ASSIGN-ALTERNATE FEFH-CONSTANT-VALUES)
+(cl:defvar FEFH-CONSTANTS (GET-ALTERNATE FEFH-CONSTANT-VALUES))
+
+;;; Fast FEF header fields.
+(cl:defvar FAST-FEFH-CONSTANT-VALUES '(
+; Bits used for info are 3602 (cdr-code), 1704. 3101 is wasted because header-type is
+; in the old (24-bit style) position. The PC fields from the slow case apply here, but
+; the GET-SELF-MAPPING-TABLE, SV-BIND, FAST-ARG, NO-ADL, bits do not.
+ %%FEFH-ARGS-FOR-FANL 1704 ;Number of args for FIXED-ARGS-NO-LOCALS.
+ %%FEFH-MIN-ARGS-FOR-VANL 3602 ;Minimum number of args for VAR-ARGS-NO-LOCALS.
+ %%FEFH-MAX-ARGS-FOR-VANL 1704 ;Maximum number of args for VAR-ARGS-NO-LOCALS.
+ %%FEFH-ARGS-FOR-FAWL 3602 ;Number of args for FIXED-ARGS-WITH-LOCALS.
+ %%FEFH-LOCALS-FOR-FAWL 1704 ;Local block length for FIXED-ARGS-WITH-LOCALS.
+ %%FEFH-MIN-ARGS-FOR-VAWL 3602 ;Minimum number of args for VAR-ARGS-WITH-LOCALS.
+ %%FEFH-MAX-ARGS-FOR-VAWL 1702 ;Maximum number of args for VAR-ARGS-WITH-LOCALS.
+ %%FEFH-LOCALS-FOR-VAWL 2102 ;Local block length for VAR-ARGS-WITH-LOCALS.
+ %%FEFSL-NO-ADL 3701 ;New NO-ADL field.
+ ))
+(ASSIGN-ALTERNATE FAST-FEFH-CONSTANT-VALUES)
+(cl:defvar FAST-FEFH-CONSTANTS (GET-ALTERNATE FAST-FEFH-CONSTANT-VALUES))
+
+;;; FEF header q indexes
+(cl:defvar FEFHI-INDEXES '(
+ %FEFHI-IPC
+ %FEFHI-STORAGE-LENGTH
+ %FEFHI-FCTN-NAME
+ %FEFHI-FAST-ARG-OPT
+ %FEFHI-SV-BITMAP
+ %FEFHI-MISC
+ %FEFHI-SPECIAL-VALUE-CELL-PNTRS
+ ))
+
+(cl:defvar IFEFOFF (cl:1- (cl:length FEFHI-INDEXES))) ;Q'S IN FIXED ALLOC PART OF FEF
+(cl:defvar %FEF-HEADER-LENGTH IFEFOFF) ;BETTER NAME FOR ABOVE
+
+(cl:defvar FEFHI-VALUES '(
+ %%FEFHI-FSO-MIN-ARGS 0606
+ %%FEFHI-FSO-MAX-ARGS 0006
+ %%FEFHI-MS-LOCAL-BLOCK-LENGTH 0007
+ %%FEFHI-MS-ARG-DESC-ORG 0710
+ %%FEFHI-MS-BIND-DESC-LENGTH 1710
+ %%FEFHI-MS-DEBUG-INFO-PRESENT 2701
+ %%FEFHI-SVM-ACTIVE 2601
+ %FEFHI-SVM-ACTIVE #.(cl:ash 1 26)
+ %%FEFHI-SVM-BITS 0026
+ %%FEFHI-SVM-HIGH-BIT 2501
+ ))
+(cl:defvar FEFHI-FIELDS (GET-ALTERNATE FEFHI-VALUES))
+
+
+(cl:defvar PAGE-SIZE 400)
+
+(cl:defvar SIZE-OF-AREA-ARRAYS 377)
+
+;;; Assuming no more than 256 regions
+(cl:defvar %ADDRESS-SPACE-MAP-BYTE-SIZE 8.)
+(cl:defvar %ADDRESS-SPACE-QUANTUM-SIZE #o40000)
+;;; Each quantum has a byte in the ADDRESS-SPACE-MAP area,
+;;; which is the region number, or 0 if free or fixed area.
+;;; INIT-LIST-AREA is the last fixed area.
+
+;;;; Page table stuff etc.
+
+;;; Definitions of fields in page hash table
+(cl:defvar PAGE-VALUES '(
+ ;; WORD 1
+ %%PHT1-VIRTUAL-PAGE-NUMBER 1021 ;ALIGNED SAME AS VMA
+ %PHT-DUMMY-VIRTUAL-ADDRESS 377777 ;ALL ONES MEANS THIS IS DUMMY ENTRY
+ ;WHICH JUST REMEMBERS A FREE CORE PAGE
+ %%PHT1-SWAP-STATUS-CODE 0003
+ %PHT-SWAP-STATUS-NORMAL 1 ;ORDINARY PAGE
+ %PHT-SWAP-STATUS-FLUSHABLE 2 ;SAFELY REUSABLE TO SWAP PAGES INTO
+ ;MAY NEED TO BE WRITTEN TO DISK FIRST
+ %PHT-SWAP-STATUS-PREPAGE 3 ;SAME AS FLUSHABLE, BUT CAME IN VIA PREPAGE
+ %PHT-SWAP-STATUS-AGE-TRAP 4 ;LIKE NORMAL BUT TRYING TO MAKE FLUSHABLE
+ %PHT-SWAP-STATUS-WIRED 5 ;NOT SWAPPABLE
+ %%PHT1-AGE 0302 ;NUMBER OF TIMES AGED
+ %%PHT1-MODIFIED-BIT 0501 ;1 IF PAGE MODIFIED, BUT THE FACT NOT RECORDED
+ ; IN THE MAP-STATUS, BECAUSE IT IS NOMINALLY
+ ; READ-ONLY OR NOMINALLY READ-WRITE-FIRST.
+ %%PHT1-VALID-BIT 0601 ;1 IF THIS HASH TABLE SLOT IS OCCUPIED.
+ %%PHT1-SCAVENGER-WS-FLAG 0701 ;IF SET, PAGE IN SCAVENGER WORKING SET.
+
+ ;; Pht word 2. This is identical to the level-2 map
+
+ %%PHT2-META-BITS 1606 ;SEE %%REGION-MAP-BITS
+ %%PHT2-MAP-STATUS-CODE 2403
+ %PHT-MAP-STATUS-MAP-NOT-VALID 0 ;LEVEL 1 OR 2 MAP NOT SET UP
+ %PHT-MAP-STATUS-META-BITS-ONLY 1 ;HAS META BITS BUT NO PHYSICAL ADDRESS
+ %PHT-MAP-STATUS-READ-ONLY 2 ;GARBAGE COLLECTOR CAN STILL WRITE IN IT
+ %PHT-MAP-STATUS-READ-WRITE-FIRST 3 ;READ/WRITE BUT NOT MODIFIED
+ %PHT-MAP-STATUS-READ-WRITE 4 ;READ/WRITE AND MODIFIED
+ %PHT-MAP-STATUS-PDL-BUFFER 5 ;MAY RESIDE IN PDL BUFFER
+ %PHT-MAP-STATUS-MAR 6 ;MAR SET SOMEWHERE ON THIS PAGE
+ %%PHT2-MAP-ACCESS-CODE 2602
+ %%PHT2-ACCESS-STATUS-AND-META-BITS 1612
+ %%PHT2-ACCESS-AND-STATUS-BITS 2404
+ %%PHT2-PHYSICAL-PAGE-NUMBER 0016
+ ))
+(ASSIGN-ALTERNATE PAGE-VALUES)
+(cl:defvar PAGE-HASH-TABLE-FIELDS (GET-ALTERNATE PAGE-VALUES))
+
+;;; See SYS2;SGDEFS
+(cl:defvar STACK-GROUP-HEAD-LEADER-QS '(
+ SG-NAME
+ SG-REGULAR-PDL
+ SG-REGULAR-PDL-LIMIT
+ SG-SPECIAL-PDL
+ SG-SPECIAL-PDL-LIMIT
+ SG-INITIAL-FUNCTION-INDEX
+ SG-PLIST
+ ;; End static section, begin debugging section
+ SG-TRAP-TAG ;Symbolic tag corresponding to
+ ; SG-TRAP-MICRO-PC. Gotten via
+ ; MICROCODE-ERROR-TABLE, etc. Properties of
+ ; this symbol drive various stages in error
+ ; recovery, etc.
+ SG-RECOVERY-HISTORY ;Available for hairy SG munging routines to
+ ; leave tracks in for debugging purposes.
+ SG-FOOTHOLD-DATA ;Structure which saves dynamic section of
+ ; "real" SG when executing in the foothold.
+ ;; Locations below here are actually loaded/stored on sg-enter/sg-leave
+ ;; End debugging section, begin "high level" section
+ SG-STATE
+ SG-PREVIOUS-STACK-GROUP
+ SG-CALLING-ARGS-POINTER
+ SG-CALLING-ARGS-NUMBER
+ ;SG-FOLLOWING-STACK-GROUP
+ SG-TRAP-AP-LEVEL
+ ;; End high-level section, begin "dynamic" section
+ ;; --Below here is saved in SG-FOOTHOLD-DATA when
+ ;; %%SG-ST-FOOTHOLD-EXECUTING is set.
+ SG-REGULAR-PDL-POINTER
+ SG-SPECIAL-PDL-POINTER
+ SG-AP SG-IPMARK
+ SG-TRAP-MICRO-PC ;PC saved from OPCS at micro-location TRAP
+ ;SG-ERROR-HANDLING-SG
+ ;SG-INTERRUPT-HANDLING-SG
+ ; HAVING THESE BE PART OF THE SG IS BASICALLY A GOOD IDEA, BUT IT
+ ; DOESNT BUY ANYTHING FOR THE TIME BEING AND COSTS A COUPLE OF MICROINSTRUCTIONS
+ SG-SAVED-QLARYH
+ SG-SAVED-QLARYL
+ SG-SAVED-M-FLAGS
+ SG-AC-K
+ SG-AC-S
+ SG-AC-J
+ SG-AC-I
+ SG-AC-Q
+ SG-AC-R
+ SG-AC-T
+ SG-AC-E
+ SG-AC-D
+ SG-AC-C
+ SG-AC-B
+ SG-AC-A
+ SG-AC-ZR
+ SG-AC-2
+ SG-AC-1
+ SG-VMA-M1-M2-TAGS
+ SG-SAVED-VMA
+ SG-PDL-PHASE
+ ))
+
+;;; Fields in sg-state Q
+(cl:defvar SG-STATE-FIELD-VALUES '(
+ %%SG-ST-CURRENT-STATE 0006
+ %%SG-ST-FOOTHOLD-EXECUTING 0601
+ %%SG-ST-PROCESSING-ERROR 0701
+ %%SG-ST-PROCESSING-INTERRRUPT-REQUEST 1001
+ %%SG-ST-SAFE 1101
+ %%SG-ST-INST-DISP 1202
+ %%SG-ST-IN-SWAPPED-STATE 2601
+ %%SG-ST-SWAP-SV-ON-CALL-OUT 2501
+ %%SG-ST-SWAP-SV-OF-SG-THAT-CALLS-ME 2401
+; Set if swapped out sg has saved microstack on special-pdl. Can't use %LP-EXS-MICRO-STACK-SAVED
+; because that bit can already be in use by running frame.
+ %%SG-ST-MICRO-STACK-SAVED 2301
+ ))
+(cl:defvar SG-STATE-FIELDS (GET-ALTERNATE SG-STATE-FIELD-VALUES))
+
+(cl:defvar SG-INST-DISPATCHES '(
+ SG-MAIN-DISPATCH ;Main instruction dispatch
+ SG-DEBUG-DISPATCH ;Debugging dispatch
+ SG-SINGLE-STEP-DISPATCH ;Dispatch once, and then break
+ SG-SINGLE-STEP-TRAP ;For sequence breaks out of trapping
+ ; instructions
+ ))
+
+(cl:defvar SG-STATES '(
+ SG-STATE-ERROR ;0 should never get this
+ SG-STATE-ACTIVE ;Actually executing on machine.
+ SG-STATE-RESUMABLE ;Reached by interrupt or error recovery
+ ; completed. Just restore state and do a
+ ; ucode popj to resume.
+ SG-STATE-AWAITING-RETURN ;After doing a "legitimate" sg-call.
+ ; To resume this, reload SG then return a
+ ; value by transferring to QMEX1.
+ SG-STATE-INVOKE-CALL-ON-RETURN ;To resume this, reload SG, then simulate
+ ; a store in destination-last. The error
+ ; system can produce this state when it wants
+ ; to activate the foothold or perform a retry.
+ SG-STATE-INTERRUPTED-DIRTY ;Get this if forced to take an interrupt at an
+ ; inopportune time.
+ SG-STATE-AWAITING-ERROR-RECOVERY ;Immediatedly after error, before recovery
+ SG-STATE-AWAITING-CALL
+ SG-STATE-AWAITING-INITIAL-CALL
+ SG-STATE-EXHAUSTED
+ ))
+
+(cl:defvar SPECIAL-PDL-LEADER-QS '(SPECIAL-PDL-SG-HEAD-POINTER))
+(cl:defvar REG-PDL-LEADER-QS '(REG-PDL-SG-HEAD-POINTER))
+
+(cl:defvar LENGTH-OF-FASL-TABLE 37773)
+
+(cl:defvar LENGTH-OF-ATOM-HEAD 5)
+
+(cl:defvar SIZE-OF-OB-TBL 177) ;USED BY PRE-PACKAGE INTERN KLUDGE
+
+;;; Size of various hardware memories in "addressible locations"
+(cl:defvar SIZE-OF-HARDWARE-CONTROL-MEMORY 40000)
+(cl:defvar SIZE-OF-HARDWARE-DISPATCH-MEMORY 4000)
+(cl:defvar SIZE-OF-HARDWARE-A-MEMORY 2000)
+(cl:defvar SIZE-OF-HARDWARE-M-MEMORY 40) ; #+cadr 40 #+lambda 100 #+explorer 100)
+(cl:defvar SIZE-OF-HARDWARE-PDL-BUFFER 2000)
+(cl:defvar SIZE-OF-HARDWARE-MICRO-STACK 40)
+(cl:defvar SIZE-OF-HARDWARE-LEVEL-1-MAP 4000)
+(cl:defvar SIZE-OF-HARDWARE-LEVEL-2-MAP 2000)
+(cl:defvar SIZE-OF-HARDWARE-UNIBUS-MAP 20)
+
+(cl:defvar A-MEMORY-LOCATION-NAMES '( ;LIST IN ORDER OF CONTENTS OF A-MEMORY STARTING AT 40
+ ; or 100 on lambdas and explorers.
+ %MICROCODE-VERSION-NUMBER ;SECOND FILE NAME OF MICROCODE SOURCE FILE AS A NUMBER
+ %NUMBER-OF-MICRO-ENTRIES ;NUMBER OF SLOTS USED IN MICRO-CODE-ENTRY-AREA
+ DEFAULT-CONS-AREA ;DEFAULT AREA FOR CONS, LIST, ETC.
+ NUMBER-CONS-AREA ;FOR BIGNUMS, BIG-FLOATS, ETC. CAN BE
+ ; EXTRA-PDL-AREA OR JUST REGULAR AREA.
+ %INITIAL-FEF ;POINTER TO FEF OF FUNCTION MACHINE STARTS UP IN
+ %ERROR-HANDLER-STACK-GROUP ;SG TO SWITCH TO ON TRAPS
+ %CURRENT-STACK-GROUP ;CURRENT STACK-GROUP
+ %INITIAL-STACK-GROUP ;STACK-GROUP MACHINE STARTS UP IN
+ %CURRENT-STACK-GROUP-STATE ;SG-STATE Q OF CURRENT STACK GROUP
+ %CURRENT-STACK-GROUP-PREVIOUS-STACK-GROUP ;
+ %CURRENT-STACK-GROUP-CALLING-ARGS-POINTER ;
+ %CURRENT-STACK-GROUP-CALLING-ARGS-NUMBER ;
+; %CURRENT-STACK-GROUP-FOLLOWING-STACK-GROUP ;
+ %TRAP-MICRO-PC ;PC GOTTEN OUT OF OPCS BY TRAP
+ %COUNTER-BLOCK-A-MEM-ADDRESS ;LOC OF BEGINNING OF COUNTER BLOCK RELATIVE TO
+ ; A MEMORY AS A FIXNUM.
+ %CHAOS-CSR-ADDRESS ;XBUS ADDRESS
+ %MAR-LOW ;FIXNUM MAR LOWER BOUND (INCLUSIVE)
+ %MAR-HIGH ;FIXNUM MAR UPPER BOUND (INCLUSIVE)
+ ;%%M-FLAGS-MAR-MODE CONTROLS THE ABOVE
+ SELF ;SELF POINTER FOR DTP-INSTANCE, ETC
+ %METHOD-SEARCH-POINTER ;Method list element were last method found.
+ INHIBIT-SCHEDULING-FLAG ;NON-NIL SUPPRESSES SEQUENCE BREAKS
+ INHIBIT-SCAVENGING-FLAG ;NON-NIL TURNS OFF THE SCAVENGER
+ %DISK-RUN-LIGHT ;ADDRESS OF DISK RUN LIGHT, THAT+2 IS PROC RUN LIGHT
+ %LOADED-BAND ;LOW 24 BITS (FIXNUM) OF BOOTED BAND NAME (E.G. "OD3")
+ %DISK-BLOCKS-PER-TRACK ;(FROM LABEL) BLOCKS PER TRACK, USUALLY 17.
+ %DISK-BLOCKS-PER-CYLINDER ;(FROM LABEL) 85. ON T-80, 323. ON T-300
+ ;THE GARBAGE-COLLECTOR PROCESS HANGS ON THESE VARIABLES
+ %REGION-CONS-ALARM ;COUNTS NEW REGIONS CREATED
+ %PAGE-CONS-ALARM ;COUNTS PAGES ALLOCATED TO REGIONS
+ %GC-FLIP-READY ;If non-NIL, there are no pointers to oldspace
+ %INHIBIT-READ-ONLY ;If non-NIL, you can write in read-only
+ %SCAVENGER-WS-ENABLE ;If non-NIL, scavenger working set hack enabled
+ %METHOD-SUBROUTINE-POINTER ;Continuation point for SELECT-METHOD subroutine
+ ; or NIL.
+ %QLARYH ;Header of last array ref'ed as function
+ %QLARYL ;Element # of last array ref'ed as function
+ %SCHEDULER-STACK-GROUP ;Force call to this on sequence-break. This
+ ;stack group must bind on INHIBIT-SCHEDULING-FLAG as
+ ;part of the stack-group switch for proper operation.
+ %CURRENT-SHEET ;Sheet or screen currently selected by microcode
+ %DISK-SWITCHES ;Fixnum: 1 r/c after read, 2 r/c after write
+ ; 4 enables multiple page swapouts
+ ; was called %READ-COMPARE-ENABLES
+ %MC-CODE-EXIT-VECTOR ;Exit vector used by microcompiled code to ref Q
+ ; quantities.
+ ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON ;If T, upper and lower case are not equal
+ ZUNDERFLOW ;If non-NIL, floating pointer underflow yields zero
+ TAIL-RECURSION-FLAG ;Non-NIL says don't save stack frames on tail recursion.
+ %METER-GLOBAL-ENABLE ;NIL means metering on per stack group basis
+ ;T means all stack groups
+ %METER-BUFFER-POINTER ;Pointer to the buffer as a fixnum
+ %METER-DISK-ADDRESS ;disk address to write out the meter info
+ %METER-DISK-COUNT ;count of disk blocks to write out
+ CURRENTLY-PREPARED-SHEET ;Error checking for the TV:PREPARE-SHEET macro
+ MOUSE-CURSOR-STATE ;0 disabled, 1 open, 2 off, 3 on
+ MOUSE-X ;Relative to mouse-sheet
+ MOUSE-Y
+ MOUSE-CURSOR-X-OFFSET ;From top-left of pattern
+ MOUSE-CURSOR-Y-OFFSET ;to the reference point
+ MOUSE-CURSOR-WIDTH
+ MOUSE-CURSOR-HEIGHT
+ MOUSE-X-SPEED ;100ths per second, time averaged
+ MOUSE-Y-SPEED ;with time constant of 1/6 second
+ MOUSE-BUTTONS-BUFFER-IN-INDEX
+ MOUSE-BUTTONS-BUFFER-OUT-INDEX
+ MOUSE-WAKEUP ;Set to T when move or click
+ LEXICAL-ENVIRONMENT
+ AMEM-EVCP-VECTOR ;Value is an array as long as this list plus 40,
+ ;which holds the EVCP when one of these vars
+ ;is bound by a closure.
+ BACKGROUND-CONS-AREA ;Used for conses that are not explicitly requested
+ ;and shouldn't go in a temp area.
+ SELF-MAPPING-TABLE ;Indirection table mapping ivars of current method's
+ ;flavor into slots in SELF.
+ %GC-SWITCHES
+ ARRAY-INDEX-ORDER ;NIL => first array subscript varies fastes.
+ ;T => last subscript varies fastest.
+ PROCESSOR-TYPE-CODE ;1 => CADR, 2 => LAMBDA, 3 => EXPLORER
+ AR-1-ARRAY-POINTER-1 ;Array whose data is cached for AR-1-CACHED-1.
+ AR-1-ARRAY-POINTER-2 ;Array whose data is cached for AR-1-CACHED-2.
+ ))
+
+(cl:defvar A-MEMORY-COUNTER-BLOCK-NAMES '(
+ %COUNT-FIRST-LEVEL-MAP-RELOADS ;# FIRST LEVEL MAP RELOADS
+ %COUNT-SECOND-LEVEL-MAP-RELOADS ;# SECOND LEVEL MAP RELOADS
+ %COUNT-PDL-BUFFER-READ-FAULTS ;# TOOK PGF AND DID READ FROM PDL-BUFFER
+ %COUNT-PDL-BUFFER-WRITE-FAULTS ;# TOOK PGF AND DID WRITE TO PDL-BUFFER
+ %COUNT-PDL-BUFFER-MEMORY-FAULTS ;# TOOK PGF FOR PDL-BUF, BUT DATA IN MAIN MEM.
+ %COUNT-DISK-PAGE-READS ;COUNT OF PAGES READ FROM DISK
+ %COUNT-DISK-PAGE-WRITES ;COUNT OF PAGES WRITTEN TO DISK
+ %COUNT-DISK-ERRORS ;COUNT OF RECOVERABLE ERRS
+ %COUNT-FRESH-PAGES ;COUNT OF FRESH PAGES
+ ; GENERATED IN CORE INSTEAD OF READ FROM DISK
+ %COUNT-AGED-PAGES ;NUMBER OF TIMES AGER SET AGE TRAP
+ %COUNT-AGE-FLUSHED-PAGES ;NUMBER OF TIMES AGE TRAP -> FLUSHABLE
+ %COUNT-DISK-READ-COMPARE-REWRITES ;COUNT OF WRITES REDONE DUE TO FAILURE TO READ-COMPARE
+ %COUNT-DISK-RECALIBRATES ;DUE TO SEEK ERRORS
+ %COUNT-META-BITS-MAP-RELOADS ;# SECOND LEVEL MAP RELOADS TO META-BITS-ONLY
+ %COUNT-CHAOS-TRANSMIT-ABORTS ;Number of transmit aborts in microcode
+ %COUNT-DISK-READ-COMPARE-DIFFERENCES ;Number of read-compare differences without
+ ; accompanying disk read error
+ %COUNT-CONS-WORK ;GC parameter
+ %COUNT-SCAVENGER-WORK ;..
+ %TV-CLOCK-RATE ;TV frame rate divided by this is seq brk clock
+ %AGING-DEPTH ;Number of laps to age a page. Don't make > 3!!
+ %COUNT-DISK-ECC-CORRECTED-ERRORS ;Number of soft ECC errors
+ %COUNT-FINDCORE-STEPS ;Number of iterations finding mem to swap out
+ %COUNT-FINDCORE-EMERGENCIES ;Number of times FINDCORE had to age all pages
+ %COUNT-DISK-READ-COMPARE-REREADS ;Reads done over due to r/c diff or error
+ %COUNT-DISK-PAGE-READ-OPERATIONS ;Read operations (count once even if multipage)
+ %COUNT-DISK-PAGE-WRITE-OPERATIONS ;Write operations (count once even if multipage)
+ %COUNT-DISK-PAGE-WRITE-WAITS ;Waiting for a page to get written, to reclaim core
+ %COUNT-DISK-PAGE-WRITE-BUSYS ;Waiting for a page to get written, to use disk
+ %COUNT-DISK-PREPAGES-USED ;Counts prepaged pages that were wanted
+ %COUNT-DISK-PREPAGES-NOT-USED ;Counts prepaged pages that were reclaimed
+ %DISK-ERROR-LOG-POINTER ;Address of next 4-word block in 600-637
+ %DISK-WAIT-TIME ;Microseconds of waiting for disk time
+ %COUNT-DISK-PAGE-WRITE-APPENDS ;Pages appended to swapout operations.
+ %COUNT-DISK-PAGE-READ-APPENDS ;Pages appended to swapin operations.
+ %LOWEST-DIRECT-VIRTUAL-ADDRESS ;Not a counter (except maybe down, slowly..)
+ ; Normally equal to LOWEST-A-MEM-VIRTUAL-ADDRESS,
+ ; set this lower if you need more direct address
+ ; space, ie, for video buffer of new color display.
+ ;;These two are used to start output on the timestamped output device
+ ;;when the interval timer interrupts.
+ %UNIBUS-TIMED-OUTPUT-CSR-ADDRESS
+ %UNIBUS-TIMED-OUTPUT-CSR-BITS
+ %timestamped-output-count-1 ;See comments in ucode in UC-PARAMETERS.
+ %timestamped-output-count-2
+
+ %count-illop-debug ;Number of times got to ILLOP-DEBUG. These are ignored unless
+ ; debug-halts enabled in A-PROCESSOR-SWITCHES.
+ %COUNT-MICRO-FAULTS ;Number page-faults in pagable-microcode system.
+ %initial-watchdog ;number of 1/50's of a second the
+ ;lambda must appear dead before sdu blinks screen
+ ))
+
+;;; M-MEM LOCNS ARE ASSIGNED PIECEMEAL..
+(cl:defvar M-MEMORY-LOCATION-NAMES '(
+ %MODE-FLAGS
+ %SEQUENCE-BREAK-SOURCE-ENABLE
+ %METER-MICRO-ENABLES
+ ))
+
+(cl:setf (cl:get '%MODE-FLAGS 'FORWARDING-VIRTUAL-ADDRESS)
+ (cl:+ A-MEMORY-VIRTUAL-ADDRESS 26))
+(cl:setf (cl:get '%SEQUENCE-BREAK-SOURCE-ENABLE 'FORWARDING-VIRTUAL-ADDRESS)
+ (cl:+ A-MEMORY-VIRTUAL-ADDRESS 34))
+(cl:setf (cl:get '%METER-MICRO-ENABLES 'FORWARDING-VIRTUAL-ADDRESS)
+ (cl:+ A-MEMORY-VIRTUAL-ADDRESS 35))
+
+
+(cl:defvar DISK-RQ-LEADER-QS '(
+ %DISK-RQ-LEADER-N-HWDS ;Number halfwords really used
+ ; on first page before CCW list.
+ %DISK-RQ-LEADER-N-PAGES ;Number of buffer pages allocated
+ %DISK-RQ-LEADER-BUFFER ;Displaced ART-16B array to buffer pgs
+ %DISK-RQ-LEADER-8-BIT-BUFFER ;Displaced ART-STRING array.
+ ))
+(cl:defvar DISK-RQ-HWDS '(
+ %DISK-RQ-DONE-FLAG ;0 RQ entered, -1 completed
+ %DISK-RQ-DONE-FLAG-HIGH
+ ;; These are set up by the requester
+ %DISK-RQ-COMMAND ;Disk command register
+ %DISK-RQ-COMMAND-HIGH
+ %DISK-RQ-CCW-LIST-POINTER-LOW ;CLP low 16
+ %DISK-RQ-CCW-LIST-POINTER-HIGH ;CLP high 16
+ %DISK-RQ-SURFACE-SECTOR ;Disk address reg low
+ %DISK-RQ-UNIT-CYLINDER ;Disk address reg high
+ ;; These are stored when the operation completes
+ %DISK-RQ-STATUS-LOW ;Disk status reg low 16
+ %DISK-RQ-STATUS-HIGH ;Disk status reg high 16
+ %DISK-RQ-MEM-ADDRESS-LOW ;Last mem ref addr low 16
+ %DISK-RQ-MEM-ADDRESS-HIGH ;Last mem ref addr high 6
+ %DISK-RQ-FINAL-SURFACE-SECTOR ;Disk address reg low
+ %DISK-RQ-FINAL-UNIT-CYLINDER ;Disk address reg high
+ %DISK-RQ-ECC-POSITION
+ %DISK-RQ-ECC-PATTERN
+ %DISK-RQ-CCW-LIST ;CCW list customarily starts here
+ ))
+(cl:defvar DISK-HARDWARE-VALUES '(
+ %%DISK-STATUS-HIGH-BLOCK-COUNTER 1010
+ %%DISK-STATUS-HIGH-INTERNAL-PARITY 0701
+ %%DISK-STATUS-HIGH-READ-COMPARE-DIFFERENCE 0601
+ %%DISK-STATUS-HIGH-CCW-CYCLE 0501
+ %%DISK-STATUS-HIGH-NXM 0401
+ %%DISK-STATUS-HIGH-MEM-PARITY 0301
+ %%DISK-STATUS-HIGH-HEADER-COMPARE 0201
+ %%DISK-STATUS-HIGH-HEADER-ECC 0101
+ %%DISK-STATUS-HIGH-ECC-HARD 0001
+ ;; Mask for bits which are errors normally
+ %DISK-STATUS-HIGH-ERROR 237
+ %%DISK-STATUS-LOW-ECC-SOFT 1701
+ %%DISK-STATUS-LOW-OVERRUN 1601
+ %%DISK-STATUS-LOW-TRANSFER-ABORTED 1501
+ %%DISK-STATUS-LOW-START-BLOCK-ERROR 1401
+ %%DISK-STATUS-LOW-TIMEOUT 1301
+ %%DISK-STATUS-LOW-SEEK-ERROR 1201
+ %%DISK-STATUS-LOW-OFF-LINE 1101
+ %%DISK-STATUS-LOW-OFF-CYLINDER 1001
+ %%DISK-STATUS-LOW-READ-ONLY 0701
+ %%DISK-STATUS-LOW-FAULT 0601
+ %%DISK-STATUS-LOW-NO-SELECT 0501
+ %%DISK-STATUS-LOW-MULTIPLE-SELECT 0401
+ %%DISK-STATUS-LOW-INTERRUPT 0301
+ %%DISK-STATUS-LOW-SEL-UNIT-ATTENTION 0201
+ %%DISK-STATUS-LOW-ATTENTION 0101
+ %%DISK-STATUS-LOW-READY 0001
+ ;; Mask for bits which are errors normally
+ %DISK-STATUS-LOW-ERROR 177560
+ %DISK-COMMAND-DONE-INTERRUPT-ENABLE #.(cl:ash 1 11.)
+ %DISK-COMMAND-ATTENTION-INTERRUPT-ENABLE #.(cl:ash 1 10.) ;Trident only
+ %DISK-COMMAND-RECALIBRATE 10001005
+ %DISK-COMMAND-FAULT-CLEAR 10000405 ;Recalibrate on Marksman
+ %DISK-COMMAND-DATA-STROBE-LATE 200 ;These are all different on Marksman
+ %DISK-COMMAND-DATA-STROBE-EARLY 100 ;..
+ %DISK-COMMAND-SERVO-OFFSET 40 ;..
+ %DISK-COMMAND-SERVO-OFFSET-FORWARD 20 ;..
+ %DISK-COMMAND-READ 0 ;
+ %DISK-COMMAND-READ-COMPARE 10
+ %DISK-COMMAND-WRITE 11
+ %DISK-COMMAND-READ-ALL 2
+ %DISK-COMMAND-WRITE-ALL 13
+ %DISK-COMMAND-SEEK 20000004
+ %%DISK-COMMAND-SEEK-CYLINDER 3010 ;Only used by Marksman
+ %DISK-COMMAND-AT-EASE 5 ;Get status on Marksman
+ %DISK-COMMAND-OFFSET-CLEAR 6 ;NOP on marksman
+ %DISK-COMMAND-RESET-CONTROLLER 16
+ ;; Marksman also has get-status commands, not listed here.
+ ))
+(ASSIGN-VALUES DISK-RQ-LEADER-QS 0)
+(ASSIGN-VALUES DISK-RQ-HWDS 0)
+(ASSIGN-ALTERNATE DISK-HARDWARE-VALUES)
+(cl:defvar DISK-HARDWARE-SYMBOLS (GET-ALTERNATE DISK-HARDWARE-VALUES))
+
+;;; Definitions for interrupt-driven Unibus input channels
+;;; Note that these start at 1 rather than at 0, to leave room for an array header
+
+(cl:defvar UNIBUS-CHANNEL-QS '(
+ %UNIBUS-CHANNEL-LINK ;Address of next or 0 to end list
+ %UNIBUS-CHANNEL-VECTOR-ADDRESS ;Interrupt vector address of device
+ %UNIBUS-CHANNEL-CSR-ADDRESS ;Virtual address of status register
+ %UNIBUS-CHANNEL-CSR-BITS ;Bits which must be on in CSR
+ %UNIBUS-CHANNEL-DATA-ADDRESS ;Virtual address of data register(s)
+ %UNIBUS-CHANNEL-BUFFER-START ;Start address of buffer
+ %UNIBUS-CHANNEL-BUFFER-END ;End address+1 of buffer
+ %UNIBUS-CHANNEL-BUFFER-IN-PTR ;Address of next word to store
+ %UNIBUS-CHANNEL-BUFFER-OUT-PTR ;Address of next word to extract
+ ;**this last does not really exist now. It should be carried thru on the next cold load.
+ ; It is required for the non-local unibus hack to work in general, altho we can get along
+ ; without it for the time being since the keyboard is always interrupt enabled.**
+ %UNIBUS-CHANNEL-INTERRUPT-ENABLE-BITS ;Bit(s) in CSR which enable interrupts.
+ %UNIBUS-CHANNEL-OUTPUT-TURNOFF-ADDRESS ;Address to write to shut down output channel
+ %UNIBUS-CHANNEL-OUTPUT-TURNOFF-BITS ;Value to write into that address
+ %UNIBUS-CHANNEL-CSR-CLEAR-BITS ;** Bits to clear at start of interrupt.
+ %UNIBUS-CHANNEL-CSR-SET-BITS ;** Bits to set at start of interrupt.
+ ))
+(ASSIGN-VALUES-INIT-DELTA UNIBUS-CHANNEL-QS 0 1 1)
+
+;;; Extra bits in the %UNIBUS-CHANNEL-CSR-BITS word.
+;;; Only the bottom 16 bits actually have to do with the device's CSR register
+;;; (which is only 16 bits long).
+(cl:defvar UNIBUS-CSR-BIT-VALUES '(
+ %%UNIBUS-CSR-OUTPUT 2001 ;This is an output device.
+ %%UNIBUS-CSR-TIMESTAMPED 2101 ;Store timestamp with each input char;
+ ; for output, delay till timestamp is reached.
+ %%UNIBUS-CSR-TWO-DATA-REGISTERS 2201 ;Device has two 16-bit data registers;
+ ; assume lower unibus addr has low bits.
+ %%UNIBUS-CSR-SB-ENABLE 2301 ;Enable sequence break (input only).
+ %%UNIBUS-CSR-SET-BITS-P 2401 ;** %UNIBUS-CHANNEL-CSR-SET-BITS is
+ ; significant.
+ %%UNIBUS-CSR-CLEAR-BITS-P 2501 ;** %UNIBUS-CHANNEL-CSR-CLEAR-BITS is
+ ; significant.
+ ))
+(ASSIGN-ALTERNATE UNIBUS-CSR-BIT-VALUES)
+
+(cl:defvar UNIBUS-CSR-BITS '(
+ %%UNIBUS-CSR-OUTPUT
+ %%UNIBUS-CSR-TIMESTAMPED
+ %%UNIBUS-CSR-TWO-DATA-REGISTERS
+ %%UNIBUS-CSR-SB-ENABLE
+ %%UNIBUS-CSR-SET-BITS-P
+ %%UNIBUS-CSR-CLEAR-BITS-P
+ ))
+
+;;;; Definitions for Chaos net hardware and microcode
+
+;;; Command/Status register fields
+
+(cl:defvar CHAOS-HARDWARE-VALUES '(
+ %%CHAOS-CSR-TIMER-INTERRUPT-ENABLE 0001
+ %%CHAOS-CSR-LOOP-BACK 0101
+ %%CHAOS-CSR-RECEIVE-ALL 0201
+ %%CHAOS-CSR-RECEIVER-CLEAR 0301
+ %%CHAOS-CSR-RECEIVE-ENABLE 0401
+ %%CHAOS-CSR-TRANSMIT-ENABLE 0501
+ %%CHAOS-CSR-INTERRUPT-ENABLES 0402
+ %%CHAOS-CSR-TRANSMIT-ABORT 0601
+ %%CHAOS-CSR-TRANSMIT-DONE 0701
+ %%CHAOS-CSR-TRANSMITTER-CLEAR 1001
+ %%CHAOS-CSR-LOST-COUNT 1104
+ %%CHAOS-CSR-RESET 1501
+ %%CHAOS-CSR-CRC-ERROR 1601
+ %%CHAOS-CSR-RECEIVE-DONE 1701
+ ;; Offsets of other registers from CSR
+ ;; These are in words, not bytes
+ %CHAOS-MY-NUMBER-OFFSET 1
+ %CHAOS-WRITE-BUFFER-OFFSET 1
+ %CHAOS-READ-BUFFER-OFFSET 2
+ %CHAOS-BIT-COUNT-OFFSET 3
+ %CHAOS-START-TRANSMIT-OFFSET 5
+ ))
+
+;;; Leader of a wired Chaos buffer
+
+(cl:defvar CHAOS-BUFFER-LEADER-QS '(
+ %CHAOS-LEADER-WORD-COUNT ;Fill pointer for ART-16B array
+ %CHAOS-LEADER-THREAD ;Next buffer in wired list (free, rcv, xmt)
+ ; NIL for end of list
+ %CHAOS-LEADER-CSR-1 ;Receive stores CSR before reading out here
+ %CHAOS-LEADER-CSR-2 ;Receive stores CSR after reading out here
+ ; Get lost-count from here
+ %CHAOS-LEADER-BIT-COUNT ;Receive stores bit-count before reading out
+ ))
+(ASSIGN-VALUES CHAOS-BUFFER-LEADER-QS 0)
+(ASSIGN-ALTERNATE CHAOS-HARDWARE-VALUES)
+(cl:defvar CHAOS-HARDWARE-SYMBOLS (GET-ALTERNATE CHAOS-HARDWARE-VALUES))
+
+;;;; Ethernet
+
+;;; Offsets from the base of the ether registers to the specific registers
+(cl:defvar ether-register-offsets '(
+ %ether-output-word-count-offset ;0
+ %ether-output-buffer-pointer-offset ;1
+ %ether-output-csr-offset ;2
+ %ether-output-delay-offset ;3
+ %ether-input-word-count-offset ;4
+ %ether-input-buffer-pointer-offset ;5
+ %ether-input-csr-offset ;6
+ %ether-device-address ;7
+ ))
+(assign-values ether-register-offsets 0)
+
+;;; Offsets of the leader elements
+(cl:defvar ether-leader-offsets '(
+ %ether-leader-thread ;0
+ %ether-leader-csr ;1
+ %ether-leader-active-length ;2
+ %ether-leader-transmit-count ;3
+ ))
+(assign-values ether-leader-offsets 0)
+
+;;; Random parameters
+(cl:defvar ether-random-parameters '(
+ ether-maximum-packet-length 430 ;Max length of packet in words = (// 560. 2)
+ ether-unibus-block 0 ;Use unibus blocks 0-3
+ ))
+(assign-alternate ether-random-parameters)
+
+(cl:defvar A-MEMORY-ARRAY-LOCATIONS '(
+ MOUSE-CURSOR-PATTERN 1600
+ MOUSE-BUTTONS-BUFFER 1640
+ MOUSE-X-SCALE-ARRAY 1700
+ MOUSE-Y-SCALE-ARRAY 1720
+ ))
+(cl:defvar A-MEMORY-ARRAY-SYMBOLS (GET-ALTERNATE A-MEMORY-ARRAY-LOCATIONS))
+
+
+;;; Use of DTP-INSTANCE. Points to a structure whose header is of
+;;; type DTP-INSTANCE-HEADER; the pointer field of that header points
+;;; to a structure (generally an array) which contains the fields described
+;;; below. This structure is called an instance-descriptor and contains
+;;; the constant or shared part of the instance. The instance structure,
+;;; after its DTP-INSTANCE-HEADER, contains several words used as value
+;;; cells of instance variables, which are the variable or unshared
+;;; part of the instance.
+;;; Note that these are offsets, not indices into the array. They
+;;; are defined here this way because microcode uses them. This could
+;;; be a cdr-coded list or an instance rather than an array.
+(cl:defvar INSTANCE-DESCRIPTOR-OFFSETS '(
+ %INSTANCE-DESCRIPTOR-HEADER ;The array header.
+ %INSTANCE-DESCRIPTOR-RESERVED ;e.g. for named-structure symbol
+ %INSTANCE-DESCRIPTOR-SIZE ;The size of the instance; this is one more
+ ; than the number of instance-variable slots.
+ ; This is looked at by the garbage collector.
+ %INSTANCE-DESCRIPTOR-BINDINGS ;Describes bindings to perform when the
+ ; instance is called. If this is a list, then
+ ; SELF is bound to the instance and the
+ ; elements of the list are locatives to cells
+ ; which are bound to EVCP's to successive
+ ; instance-variable slots of the instance. If
+ ; this is not a list, it is something
+ ; reserved for future facilities based on the
+ ; same primitives. NIL is a list.
+ ; Note that if this is a list, it must be
+ ; CDR-CODED! The microcode depends on this for
+ ; a little extra speed.
+ %INSTANCE-DESCRIPTOR-FUNCTION ;Function to be called when the instance
+ ; is called. Typically a hash table.
+ %INSTANCE-DESCRIPTOR-TYPENAME ;A symbol which is returned by TYPEP
+ %INSTANCE-DESCRIPTOR-MAPPING-TABLE-ALIST ;Mapping tables to instances of this descr
+ ; for various method-flavors.
+ %INSTANCE-DESCRIPTOR-IGNORE ;Used only at higher levels
+ %INSTANCE-DESCRIPTOR-ALL-INSTANCE-VARIABLES ;List of all instance variables.
+ %INSTANCE-DESCRIPTOR-IGNORE
+ %INSTANCE-DESCRIPTOR-IGNORE
+ %INSTANCE-DESCRIPTOR-IGNORE
+ %INSTANCE-DESCRIPTOR-IGNORE
+ %INSTANCE-DESCRIPTOR-IGNORE
+ %INSTANCE-DESCRIPTOR-DEPENDS-ON-ALL ;List of all component flavors names.
+ ; For TYPEP-STRUCTURE-OR-FLAVOR.
+ ;; Additional slots may exist, defined by the particular class system employed.
+ ;; If the instance-descriptor is an array, it must not be so long as to
+ ;; contain a long-length Q.
+ ))
+(ASSIGN-VALUES INSTANCE-DESCRIPTOR-OFFSETS 0)
+
+(cl:defvar METER-ENABLES-VALUES '(
+ %%METER-PAGE-FAULT-ENABLE 0001 ;Page fault metering
+ %%METER-CONS-ENABLE 0101 ;Cons metering
+ %%METER-FUNCTION-ENTRY-EXIT-ENABLE 0201 ;Function call metering
+ %%METER-STACK-GROUP-SWITCH-ENABLE 0301 ;Stack group metering
+ %%METER-MACRO-INSTRUCTION-ENABLE 0401 ;Macro-instruction metering
+ ))
+(cl:defvar METER-EVENTS '(
+ %METER-PAGE-IN-EVENT
+ %METER-PAGE-OUT-EVENT
+ %METER-CONS-EVENT
+ %METER-FUNCTION-ENTRY-EVENT
+ %METER-FUNCTION-EXIT-EVENT
+ %METER-FUNCTION-UNWIND-EVENT
+ %METER-STACK-GROUP-SWITCH-EVENT
+ %METER-MACRO-INSTRUCTION-EVENT
+ ))
+(ASSIGN-ALTERNATE METER-ENABLES-VALUES)
+(cl:defvar METER-ENABLES (GET-ALTERNATE METER-ENABLES-VALUES))
+(ASSIGN-VALUES METER-EVENTS 0 1)
+
+(cl:DEFUN ASSIGN-QCOM-VALUES ()
+ (ASSIGN-VALUES ADI-KINDS 0)
+ (ASSIGN-VALUES ADI-STORING-OPTIONS 0)
+ (ASSIGN-ALTERNATE ARG-DESC-FIELD-VALUES)
+ (ASSIGN-ALTERNATE ARRAY-FIELD-VALUES)
+ (ASSIGN-ALTERNATE ARRAY-LEADER-FIELD-VALUES)
+ (ASSIGN-ALTERNATE ARRAY-MISC-VALUES)
+ (ASSIGN-VALUES ARRAY-TYPES 19.)
+ (ASSIGN-VALUES FEF-ARG-SYNTAX 4)
+ (ASSIGN-VALUES FEF-DES-DT 11)
+ (ASSIGN-VALUES FEF-FUNCTIONAL 15)
+ (ASSIGN-VALUES FEF-INIT-OPTION 0)
+ (ASSIGN-VALUES FEF-NAME-PRESENT 20)
+ (ASSIGN-VALUES FEF-QUOTE-STATUS 7)
+ (ASSIGN-VALUES FEF-SPECIALNESS 16)
+ (ASSIGN-VALUES FEFHI-INDEXES 0)
+ (ASSIGN-ALTERNATE FEFHI-VALUES)
+ (ASSIGN-ALTERNATE HEADER-FIELD-VALUES)
+ (ASSIGN-VALUES Q-CDR-CODES 0)
+ (ASSIGN-VALUES Q-DATA-TYPES 0)
+ (ASSIGN-VALUES Q-HEADER-TYPES 0)
+ (ASSIGN-ALTERNATE SG-STATE-FIELD-VALUES)
+ (ASSIGN-VALUES SG-STATES 0)
+ (ASSIGN-VALUES SG-INST-DISPATCHES 0)
+ (ASSIGN-VALUES SPECIAL-PDL-LEADER-QS 0)
+ (ASSIGN-VALUES STACK-GROUP-HEAD-LEADER-QS 0)
+ (ASSIGN-VALUES SYSTEM-COMMUNICATION-AREA-QS 0)
+ (ASSIGN-VALUES REG-PDL-LEADER-QS 0))
+
+(ASSIGN-QCOM-VALUES) ;Foo. ASSIGN-VALUES, etc had better be defined.
Added: trunk/tools/cold/qdefs.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/qdefs.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,246 @@
+; -*-LISP-*-
+
+; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+;ELEMENTS IN Q-CORRESPONDING-VARIABLE-LIST ARE SYMBOLS WHOSE VALUES IN MACLISP ARE LISTS
+; ALL OF WHOSE MEMBERS ARE SYSTEM CONTANTS. THESE SYSTEM CONSTANTS HAVE MACLISP VALUES
+; AND ARE MADE TO HAVE THE IDENTICAL VALUES IN LISP MACHINE LISP.
+(cl:defvar Q-CORRESPONDING-VARIABLE-LISTS '(AREA-LIST Q-CDR-CODES Q-DATA-TYPES Q-HEADER-TYPES
+ Q-LISP-CONSTANTS
+ ;RTB-RTB-BITS RTB-RTS-BITS RTB-RTO-OPS
+ ;RTB-MISC RTM-OPS READTABLE-%%-BITS
+ ARRAY-TYPES HEADER-TYPES HEADER-FIELDS MISC-Q-VARIABLES
+ ARG-DESC-FIELDS NUMERIC-ARG-DESC-FIELDS FEF-NAME-PRESENT FEF-SPECIALNESS
+ FEF-ARG-SYNTAX FEF-INIT-OPTION FEFHI-FIELDS FEF-DES-DT FEF-QUOTE-STATUS
+ FEF-FUNCTIONAL
+ ARRAY-FIELDS ARRAY-LEADER-FIELDS ARRAY-MISCS Q-REGION-BITS
+ SYSTEM-CONSTANT-LISTS SYSTEM-VARIABLE-LISTS
+ SCRATCH-PAD-VARIABLES FASL-GROUP-FIELDS FASL-OPS
+ FASL-TABLE-PARAMETERS FASL-CONSTANTS FASL-CONSTANT-LISTS FEFH-CONSTANTS
+ FEFHI-INDEXES
+ STACK-GROUP-HEAD-LEADER-QS SG-STATES SPECIAL-PDL-LEADER-QS REG-PDL-LEADER-QS
+ SG-STATE-FIELDS SG-INST-DISPATCHES
+ SYSTEM-COMMUNICATION-AREA-QS PAGE-HASH-TABLE-FIELDS
+ Q-FIELDS Q-AREA-SWAP-BITS MICRO-STACK-FIELDS M-FLAGS-FIELDS M-ERROR-SUBSTATUS-FIELDS
+ SPECPDL-FIELDS
+ LINEAR-PDL-FIELDS LINEAR-PDL-QS HARDWARE-MEMORY-SIZES
+ DISK-RQ-LEADER-QS DISK-RQ-HWDS DISK-HARDWARE-SYMBOLS UNIBUS-CHANNEL-QS
+ UNIBUS-CSR-BITS
+ CHAOS-BUFFER-LEADER-QS CHAOS-HARDWARE-SYMBOLS
+ ETHER-BUFFER-LEADER-QS ETHER-HARDWARE-SYMBOLS ETHER-REGISTER-OFFSETS
+ INSTANCE-DESCRIPTOR-OFFSETS
+ METER-EVENTS METER-ENABLES
+ ADI-KINDS ADI-STORING-OPTIONS ADI-FIELDS))
+
+;ELEMENTS IN SYSTEM-CONSTANT-LISTS ARE SYMBOLS WHOSE MACLISP AND LISP MACHINE
+;VALUES ARE LISTS OF SYMBOLS WHICH SHOULD GET SYSTEM-CONSTANT PROPERTY FOR THE COMPILER.
+;NORMALLY SHOULD BE VERY CLOSE TO Q-CORRESPONDING-VARIABLES-LISTS
+(cl:defvar SYSTEM-CONSTANT-LISTS '(AREA-LIST Q-CDR-CODES Q-DATA-TYPES Q-HEADER-TYPES
+ Q-LISP-CONSTANTS
+ ;RTB-RTB-BITS RTB-RTS-BITS RTB-RTO-OPS
+ ;RTB-MISC RTM-OPS READTABLE-%%-BITS
+ ARRAY-TYPES HEADER-FIELDS ;NOT HEADER-TYPES
+ ARG-DESC-FIELDS NUMERIC-ARG-DESC-FIELDS FEF-NAME-PRESENT FEF-SPECIALNESS
+ FEF-ARG-SYNTAX FEF-INIT-OPTION FEFHI-FIELDS FEF-DES-DT FEF-QUOTE-STATUS
+ FEF-FUNCTIONAL
+ ARRAY-FIELDS ARRAY-LEADER-FIELDS Q-REGION-BITS
+ ARRAY-MISCS ;ARRAY-MISCS SHOULD BE FLUSHED SOMEDAY
+ SYSTEM-CONSTANT-LISTS SYSTEM-VARIABLE-LISTS ;SOME THINGS LOOK AT SUBLISTS OF THESE
+ ;NOT SCRATCH-PAD-VARIABLES
+ ;NOT SCRATCH-PAD-POINTERS SCRATCH-PAD-PARAMETERS SCRATCH-PAD-TEMPS
+ FASL-GROUP-FIELDS FASL-OPS
+ FASL-TABLE-PARAMETERS FASL-CONSTANTS FASL-CONSTANT-LISTS FEFH-CONSTANTS
+ FEFHI-INDEXES
+ STACK-GROUP-HEAD-LEADER-QS SG-STATES SPECIAL-PDL-LEADER-QS REG-PDL-LEADER-QS
+ SG-STATE-FIELDS SG-INST-DISPATCHES
+ SYSTEM-COMMUNICATION-AREA-QS PAGE-HASH-TABLE-FIELDS
+ Q-FIELDS Q-AREA-SWAP-BITS MICRO-STACK-FIELDS M-FLAGS-FIELDS M-ERROR-SUBSTATUS-FIELDS
+ LINEAR-PDL-FIELDS LINEAR-PDL-QS HARDWARE-MEMORY-SIZES
+ DISK-RQ-LEADER-QS DISK-RQ-HWDS DISK-HARDWARE-SYMBOLS UNIBUS-CHANNEL-QS
+ UNIBUS-CSR-BITS
+ CHAOS-BUFFER-LEADER-QS CHAOS-HARDWARE-SYMBOLS
+ ETHER-BUFFER-LEADER-QS ETHER-HARDWARE-SYMBOLS ETHER-REGISTER-OFFSETS
+ INSTANCE-DESCRIPTOR-OFFSETS
+ METER-EVENTS METER-ENABLES A-MEMORY-ARRAY-SYMBOLS
+ ADI-KINDS ADI-STORING-OPTIONS ADI-FIELDS))
+
+;LIKE ABOVE BUT GET DECLARED SPECIAL RATHER THAN SYSTEM-CONSTANT
+(cl:defvar SYSTEM-VARIABLE-LISTS '(
+ A-MEMORY-LOCATION-NAMES M-MEMORY-LOCATION-NAMES
+ IO-STREAM-NAMES LISP-VARIABLES MISC-Q-VARIABLES
+))
+
+(cl:defvar IO-STREAM-NAMES '(
+ STANDARD-INPUT STANDARD-OUTPUT ERROR-OUTPUT QUERY-IO TERMINAL-IO TRACE-OUTPUT
+))
+
+;These get declared special, and get their Maclisp values shipped over
+(cl:defvar MISC-Q-VARIABLES '(SYSTEM-CONSTANT-LISTS SYSTEM-VARIABLE-LISTS PRIN1 FOR-CADR
+ COLD-INITIALIZATION-LIST BEFORE-COLD-INITIALIZATION-LIST
+ WARM-INITIALIZATION-LIST
+ ONCE-ONLY-INITIALIZATION-LIST SYSTEM-INITIALIZATION-LIST))
+
+;These get declared special, but don't get sent over. They get initialized
+; some other way, e.g. from a load-time-setq in some compile list, or from special
+; code in COLD, or by LISP-REINITIALIZE when the machine is first started.
+(cl:defvar LISP-VARIABLES '(BASE IBASE PRINLENGTH PRINLEVEL *NOPOINT *RSET FASLOAD
+ EVALHOOK PACKAGE READTABLE + - *
+ USER-ID LISP-CRASH-LIST SCHEDULER-STACK-GROUP
+ RUBOUT-HANDLER LOCAL-DECLARATIONS STREAM-INPUT-OPERATIONS
+ STREAM-OUTPUT-OPERATIONS %INITIALLY-DISABLE-TRAPPING))
+
+;These get declared SYSTEM-CONSTANT (which is similar to SPECIAL) and get their
+; Maclisp values shipped over.
+(cl:defvar Q-LISP-CONSTANTS '( PAGE-SIZE SIZE-OF-OB-TBL AREA-LIST Q-DATA-TYPES SITE-NAME
+ SIZE-OF-AREA-ARRAYS LENGTH-OF-ATOM-HEAD
+ %ADDRESS-SPACE-MAP-BYTE-SIZE %ADDRESS-SPACE-QUANTUM-SIZE
+ ARRAY-ELEMENTS-PER-Q ARRAY-BITS-PER-ELEMENT %FEF-HEADER-LENGTH
+ LAMBDA-LIST-KEYWORDS %LP-CALL-BLOCK-LENGTH
+ %LP-INITIAL-LOCAL-BLOCK-OFFSET
+ A-MEMORY-VIRTUAL-ADDRESS IO-SPACE-VIRTUAL-ADDRESS
+ UNIBUS-VIRTUAL-ADDRESS A-MEMORY-COUNTER-BLOCK-NAMES))
+
+(cl:defvar HARDWARE-MEMORY-SIZES '(
+ SIZE-OF-HARDWARE-CONTROL-MEMORY SIZE-OF-HARDWARE-DISPATCH-MEMORY
+ SIZE-OF-HARDWARE-A-MEMORY SIZE-OF-HARDWARE-M-MEMORY
+ SIZE-OF-HARDWARE-PDL-BUFFER SIZE-OF-HARDWARE-MICRO-STACK
+ SIZE-OF-HARDWARE-LEVEL-1-MAP SIZE-OF-HARDWARE-LEVEL-2-MAP
+ SIZE-OF-HARDWARE-UNIBUS-MAP ))
+
+(cl:defvar LAMBDA-LIST-KEYWORDS '(&OPTIONAL &REST &AUX
+ &SPECIAL &LOCAL
+ &FUNCTIONAL
+ &EVAL "E "E-DONTCARE
+ &DT-DONTCARE &DT-NUMBER &DT-FIXNUM &DT-SYMBOL &DT-ATOM
+ &DT-LIST &DT-FRAME
+ &FUNCTION-CELL
+ &LIST-OF &BODY ;for DEFMACRO
+ &KEY &ALLOW-OTHER-KEYS
+ ))
+
+;Don't put FUNCTION around the symbols in here -- that means if you
+;redefine the function the microcode does not get the new definition,
+;which is not what you normally want. Saying FUNCTION makes it a couple
+;microseconds faster to call it. Not all of these data are actually
+;used; check the microcode if you want to know.
+(cl:defvar SUPPORT-VECTOR-CONTENTS '((QUOTE PRINT) (QUOTE FEXPR) (QUOTE EXPR)
+ (QUOTE APPLY-LAMBDA) (QUOTE EQUAL) (QUOTE PACKAGE)
+ (QUOTE EXPT-HARD) (QUOTE NUMERIC-ONE-ARGUMENT)
+ (QUOTE NUMERIC-TWO-ARGUMENTS) (QUOTE "unbound")))
+
+(cl:defvar CONSTANTS-PAGE '(NIL T 0 1 2)) ;CONTENTS OF CONSTANTS PAGE
+
+(cl:defvar SCRATCH-PAD-VARIABLES '(SCRATCH-PAD-POINTERS SCRATCH-PAD-PARAMETER-OFFSET
+ SCRATCH-PAD-PARAMETERS SCRATCH-PAD-TEMP-OFFSET SCRATCH-PAD-TEMPS))
+
+(cl:defvar SCRATCH-PAD-POINTERS '(INITIAL-TOP-LEVEL-FUNCTION ERROR-HANDLER-STACK-GROUP
+ CURRENT-STACK-GROUP INITIAL-STACK-GROUP LAST-ARRAY-ELEMENT-ACCESSED))
+
+(cl:defvar SCRATCH-PAD-PARAMETER-OFFSET 20)
+
+;(COND ((> (LENGTH SCRATCH-PAD-POINTERS) SCRATCH-PAD-PARAMETER-OFFSET)
+; (BARF 'BARF 'SCRACH-PAD-PARAMETER-OFFSET 'BARF)))
+
+(cl:defvar SCRATCH-PAD-PARAMETERS '(ERROR-TRAP-IN-PROGRESS DEFAULT-CONS-AREA
+ BIND-CONS-AREA LAST-ARRAY-ACCESSED-TYPE LAST-ARRAY-ACCESSED-INDEX
+ INVOKE-MODE INVISIBLE-MODE
+ CDR-ATOM-MODE CAR-ATOM-MODE ACTIVE-MICRO-CODE-ENTRIES))
+
+(cl:defvar SCRATCH-PAD-TEMP-OFFSET 20)
+
+;(COND ((> (LENGTH SCRATCH-PAD-PARAMETERS) SCRATCH-PAD-TEMP-OFFSET)
+; (BARF 'BARF 'SCRATCH-PAD-TEMP-OFFSET 'BARF)))
+
+(cl:defvar SCRATCH-PAD-TEMPS '(LAST-INSTRUCTION TEMP-TRAP-CODE LOCAL-BLOCK-OFFSET
+ SCRATCH-/#-ARGS-LOADED TEMP-PC SPECIALS-IN-LAST-BLOCK-SLOW-ENTERED))
+
+
+;(DEFUN TTYPRINT (X)
+; (PROG (^R ^W)
+; (PRINT X)))
+
+;FUNCTIONS FOR HAND-TESTING THINGS
+;(DEFUN TML NIL (MSLAP 'MESA-CODE-AREA MS-PROG 'COLD))
+
+;(DEFUN TUL NIL (ULAP 'MICRO-COMPILED-PROGRAM MC-PROG 'COLD))
+
+;(DEFUN TL (MODE) (COND ((EQ MODE 'QFASL)
+; (FASD-INITIALIZE)
+; (SETQ LAP-DEBUG NIL)))
+; (QLAPP QCMP-OUTPUT MODE))
+
+;#M (COND ((NULL (GETL 'SPECIAL '(FEXPR FSUBR)))
+;(DEFUN SPECIAL FEXPR (L)
+; (MAPCAR (FUNCTION (LAMBDA (X) (PUTPROP X T 'SPECIAL)))
+; L))
+;))
+
+;(DEFUN SPECIAL-LIST (X) (EVAL (CONS 'SPECIAL (SYMEVAL X))))
+
+;; No initial initializations
+(cl:defvar COLD-INITIALIZATION-LIST cl:NIL)
+(cl:defvar BEFORE-COLD-INITIALIZATION-LIST cl:NIL)
+(cl:defvar WARM-INITIALIZATION-LIST cl:NIL)
+(cl:defvar ONCE-ONLY-INITIALIZATION-LIST cl:NIL)
+(cl:defvar SYSTEM-INITIALIZATION-LIST cl:NIL)
+
+;--Q--
+;Q FCTN SPECIALS
+;(cl:defun LOADUP-FINALIZE NIL
+; (MAPC (FUNCTION SPECIAL-LIST) SYSTEM-CONSTANT-LISTS)
+; (MAPC (FUNCTION SPECIAL-LIST) SYSTEM-VARIABLE-LISTS))
+
+;;; The documentation that used to be here has been moved to LMDOC;FASLD >
+
+(cl:declaim (cl:SPECIAL FASL-TABLE FASL-GROUP-LENGTH FASL-GROUP-FLAG FASL-RETURN-FLAG))
+
+(cl:defvar FASL-GROUP-FIELD-VALUES '(%FASL-GROUP-CHECK 100000
+ %FASL-GROUP-FLAG 40000 %FASL-GROUP-LENGTH 37700
+ FASL-GROUP-LENGTH-SHIFT -6 %FASL-GROUP-TYPE 77
+ %%FASL-GROUP-CHECK 2001 %%FASL-GROUP-FLAG 1701 %%FASL-GROUP-LENGTH 0610
+ %%FASL-GROUP-TYPE 0006))
+
+(cl:defvar FASL-GROUP-FIELDS (GET-ALTERNATE FASL-GROUP-FIELD-VALUES))
+(ASSIGN-ALTERNATE FASL-GROUP-FIELD-VALUES)
+
+(cl:defvar FASL-OPS '(FASL-OP-ERR FASL-OP-NOOP FASL-OP-INDEX FASL-OP-SYMBOL FASL-OP-LIST
+ FASL-OP-TEMP-LIST FASL-OP-FIXED FASL-OP-FLOAT
+ FASL-OP-ARRAY FASL-OP-EVAL FASL-OP-MOVE
+ FASL-OP-FRAME FASL-OP-LIST-COMPONENT FASL-OP-ARRAY-PUSH FASL-OP-STOREIN-SYMBOL-VALUE
+ FASL-OP-STOREIN-FUNCTION-CELL FASL-OP-STOREIN-PROPERTY-CELL
+ FASL-OP-FETCH-SYMBOL-VALUE FASL-OP-FETCH-FUNCTION-CELL
+ FASL-OP-FETCH-PROPERTY-CELL FASL-OP-APPLY FASL-OP-END-OF-WHACK
+ FASL-OP-END-OF-FILE FASL-OP-SOAK FASL-OP-FUNCTION-HEADER FASL-OP-FUNCTION-END
+ FASL-OP-UNUSED8 FASL-OP-UNUSED9 FASL-OP-UNUSED10
+ FASL-OP-UNUSED11 FASL-OP-UNUSED12 FASL-OP-QUOTE-POINTER FASL-OP-S-V-CELL
+ FASL-OP-FUNCELL FASL-OP-CONST-PAGE FASL-OP-SET-PARAMETER FASL-OP-INITIALIZE-ARRAY
+ FASL-OP-UNUSED FASL-OP-UNUSED1 FASL-OP-UNUSED2
+ FASL-OP-UNUSED3 FASL-OP-UNUSED4 FASL-OP-UNUSED5
+ FASL-OP-UNUSED6 FASL-OP-STRING FASL-OP-STOREIN-ARRAY-LEADER
+ FASL-OP-INITIALIZE-NUMERIC-ARRAY FASL-OP-REMOTE-VARIABLE FASL-OP-PACKAGE-SYMBOL
+ FASL-OP-EVAL1 FASL-OP-FILE-PROPERTY-LIST FASL-OP-REL-FILE FASL-OP-RATIONAL
+))
+(ASSIGN-VALUES FASL-OPS 0)
+
+(cl:defvar FASL-TABLE-PARAMETERS '(FASL-NIL FASL-EVALED-VALUE FASL-TEM1 FASL-TEM2 FASL-TEM3
+ FASL-SYMBOL-HEAD-AREA
+ FASL-SYMBOL-STRING-AREA FASL-OBARRAY-POINTER FASL-ARRAY-AREA
+ FASL-FRAME-AREA FASL-LIST-AREA FASL-TEMP-LIST-AREA
+ FASL-UNUSED FASL-UNUSED2 FASL-UNUSED3
+ FASL-UNUSED6 FASL-UNUSED4 FASL-UNUSED5))
+(ASSIGN-VALUES FASL-TABLE-PARAMETERS 0)
+
+(cl:defvar FASL-CONSTANTS '(LENGTH-OF-FASL-TABLE FASL-TABLE-WORKING-OFFSET))
+
+(cl:defvar FASL-CONSTANT-LISTS '(FASL-GROUP-FIELDS FASL-OPS FASL-TABLE-PARAMETERS
+ FASL-CONSTANTS))
+
+(cl:defvar FASL-TABLE-WORKING-OFFSET 40)
+
+;(COND ((> (LENGTH FASL-TABLE-PARAMETERS) FASL-TABLE-WORKING-OFFSET)
+; (IOC V)
+; (PRINT 'FASL-TABLE-PARAMETER-OVERFLOW)))
+
+;PEOPLE CALL THIS YOU KNOW, DON'T GO RANDOMLY DELETING IT!
+(cl:defun FASL-ASSIGN-VARIABLE-VALUES ()
+ ()) ;I GUESS WHAT THIS USED TO DO IS DONE AT TOP LEVEL IN THIS FILE
Added: trunk/tools/cold/qdefs99.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/qdefs99.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,481 @@
+; -*- Mode:LISP; Base:8; Readtable:T -*-
+
+; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+;;; Elements in Q-CORRESPONDING-VARIABLE-LIST are symbols whose values in maclisp are lists
+;;; all of whose members are system contants. These system constants have maclisp values
+;;; and are made to have the identical values in lisp machine lisp.
+(cl:defvar Q-CORRESPONDING-VARIABLE-LISTS '(
+ AREA-LIST
+ Q-CDR-CODES
+ Q-DATA-TYPES
+ Q-HEADER-TYPES
+ Q-LISP-CONSTANTS
+ ;RTB-RTB-BITS
+ ;RTB-RTS-BITS
+ ;RTB-RTO-OPS
+ ;RTB-MISC
+ ;RTM-OPS
+ ;READTABLE-%%-BITS
+ ARRAY-TYPES
+ HEADER-FIELDS
+ ARG-DESC-FIELDS
+ NUMERIC-ARG-DESC-FIELDS
+ FEF-NAME-PRESENT
+ FEF-SPECIALNESS
+ FEF-ARG-SYNTAX
+ FEF-INIT-OPTION
+ FEFHI-FIELDS
+ FEF-QUOTE-STATUS
+ FEF-FUNCTIONAL
+ ARRAY-FIELDS
+ ARRAY-LEADER-FIELDS
+ ARRAY-MISCS
+ Q-REGION-BITS
+ SELF-REF-POINTER-FIELDS
+ SYSTEM-CONSTANT-LISTS
+ SYSTEM-VARIABLE-LISTS
+ SCRATCH-PAD-VARIABLES
+ FASL-GROUP-FIELDS
+ FASL-OPS
+ FASL-TABLE-PARAMETERS
+ FASL-CONSTANTS
+ FASL-CONSTANT-LISTS
+ FEFH-CONSTANTS
+ FEFHI-INDEXES
+ STACK-GROUP-HEAD-LEADER-QS
+ SG-STATES
+ SPECIAL-PDL-LEADER-QS
+ REG-PDL-LEADER-QS
+ SG-STATE-FIELDS
+ SG-INST-DISPATCHES
+ SYSTEM-COMMUNICATION-AREA-QS
+ PAGE-HASH-TABLE-FIELDS
+ Q-FIELDS MICRO-STACK-FIELDS
+ M-FLAGS-FIELDS
+ M-ERROR-SUBSTATUS-FIELDS
+ SPECPDL-FIELDS
+ LINEAR-PDL-FIELDS
+ LINEAR-PDL-QS
+ HARDWARE-MEMORY-SIZES
+ DISK-RQ-LEADER-QS
+ DISK-RQ-HWDS
+ DISK-HARDWARE-SYMBOLS
+ UNIBUS-CHANNEL-QS
+ UNIBUS-CSR-BITS
+ CHAOS-BUFFER-LEADER-QS
+ CHAOS-HARDWARE-SYMBOLS
+ INSTANCE-DESCRIPTOR-OFFSETS
+ METER-EVENTS
+ METER-ENABLES
+ ADI-KINDS
+ ADI-STORING-OPTIONS
+ ADI-FIELDS
+ ))
+
+;;; Elements in SYSTEM-CONSTANT-LISTS are symbols whose maclisp and lisp machine
+;;; values are lists of symbols which should get system-constant property for the compiler.
+;;; Normally should be very close to Q-CORRESPONDING-VARIABLES-LISTS
+(cl:defvar SYSTEM-CONSTANT-LISTS '(
+ AREA-LIST
+ Q-CDR-CODES
+ Q-DATA-TYPES
+ Q-HEADER-TYPES
+ Q-LISP-CONSTANTS
+ ;RTB-RTB-BITS
+ ;RTB-RTS-BITS
+ ;RTB-RTO-OPS
+ ;RTB-MISC
+ ;RTM-OPS
+ ;READTABLE-%%-BITS
+ ARRAY-TYPES
+ HEADER-FIELDS ;Not HEADER-TYPES
+ ARG-DESC-FIELDS
+ NUMERIC-ARG-DESC-FIELDS
+ FEF-NAME-PRESENT
+ FEF-SPECIALNESS
+ FEF-ARG-SYNTAX
+ FEF-INIT-OPTION
+ FEFHI-FIELDS
+ FEF-DES-DT
+ FEF-QUOTE-STATUS
+ FEF-FUNCTIONAL
+ ARRAY-FIELDS
+ ARRAY-LEADER-FIELDS
+ Q-REGION-BITS
+ SELF-REF-POINTER-FIELDS
+ ARRAY-MISCS ;ARRAY-MISCS should be flushed someday
+ SYSTEM-CONSTANT-LISTS ;Some things look at sublists of these
+ SYSTEM-VARIABLE-LISTS ; two
+ ;SCRATCH-PAD-VARIABLES
+ ;SCRATCH-PAD-POINTERS
+ ;SCRATCH-PAD-PARAMETERS
+ ;SCRATCH-PAD-TEMPS
+ FASL-GROUP-FIELDS
+ FASL-OPS
+ FASL-TABLE-PARAMETERS
+ FASL-CONSTANTS
+ FASL-CONSTANT-LISTS
+ FEFH-CONSTANTS
+ FEFHI-INDEXES
+ STACK-GROUP-HEAD-LEADER-QS
+ SG-STATES
+ SPECIAL-PDL-LEADER-QS
+ REG-PDL-LEADER-QS
+ SG-STATE-FIELDS
+ SG-INST-DISPATCHES
+ SYSTEM-COMMUNICATION-AREA-QS
+ PAGE-HASH-TABLE-FIELDS
+ Q-FIELDS MICRO-STACK-FIELDS
+ M-FLAGS-FIELDS
+ M-ERROR-SUBSTATUS-FIELDS
+ SPECPDL-FIELDS
+ LINEAR-PDL-FIELDS
+ LINEAR-PDL-QS
+ HARDWARE-MEMORY-SIZES
+ DISK-RQ-LEADER-QS
+ DISK-RQ-HWDS
+ DISK-HARDWARE-SYMBOLS
+ UNIBUS-CHANNEL-QS
+ UNIBUS-CSR-BITS
+ CHAOS-BUFFER-LEADER-QS
+ CHAOS-HARDWARE-SYMBOLS
+ INSTANCE-DESCRIPTOR-OFFSETS
+ METER-EVENTS
+ METER-ENABLES
+ A-MEMORY-ARRAY-SYMBOLS
+ ADI-KINDS
+ ADI-STORING-OPTIONS
+ ADI-FIELDS
+ ))
+
+;;; Like above but get declared SPECIAL rather than SYSTEM-CONSTANT
+(cl:defvar SYSTEM-VARIABLE-LISTS '(
+ A-MEMORY-LOCATION-NAMES
+ M-MEMORY-LOCATION-NAMES
+ ))
+
+;;; These get declared SYSTEM-CONSTANT and get their Maclisp values shipped over.
+(cl:defvar Q-LISP-CONSTANTS '(
+ PAGE-SIZE
+ AREA-LIST
+ Q-DATA-TYPES
+ SIZE-OF-AREA-ARRAYS
+ LENGTH-OF-ATOM-HEAD
+ %ADDRESS-SPACE-MAP-BYTE-SIZE
+ %ADDRESS-SPACE-QUANTUM-SIZE
+ A-MEMORY-VIRTUAL-ADDRESS
+ IO-SPACE-VIRTUAL-ADDRESS
+ UNIBUS-VIRTUAL-ADDRESS
+ ARRAY-ELEMENTS-PER-Q
+ ARRAY-BITS-PER-ELEMENT
+ %FEF-HEADER-LENGTH
+ %LP-CALL-BLOCK-LENGTH
+ %LP-INITIAL-LOCAL-BLOCK-OFFSET
+ A-MEMORY-COUNTER-BLOCK-NAMES
+ SYSTEM-CONSTANT-LISTS
+ SYSTEM-VARIABLE-LISTS
+ ))
+
+(cl:defvar HARDWARE-MEMORY-SIZES '(
+ SIZE-OF-HARDWARE-CONTROL-MEMORY
+ SIZE-OF-HARDWARE-DISPATCH-MEMORY
+ SIZE-OF-HARDWARE-A-MEMORY
+ SIZE-OF-HARDWARE-M-MEMORY
+ SIZE-OF-HARDWARE-PDL-BUFFER
+ SIZE-OF-HARDWARE-MICRO-STACK
+ SIZE-OF-HARDWARE-LEVEL-1-MAP
+ SIZE-OF-HARDWARE-LEVEL-2-MAP
+ SIZE-OF-HARDWARE-UNIBUS-MAP
+ ))
+
+;;;; Data on how to set up the initial areas in the cold load.
+
+;;; See also AREA-LIST, which is in QCOM because microassembly refers to it.
+
+;;; These areas are encached in the pdl buffer.
+(cl:defvar PDL-BUFFER-AREA-LIST '(
+ LINEAR-PDL-AREA ;Main pdl
+ PDL-AREA ;Pdls for misc stack groups
+ ))
+
+;;; Note that at present all areas up through address-space-map must be wired.
+;;; The reason is that when the microcode starts up it straight-maps that
+;;; amount of virtual memory, without checking separately for each page.
+;;; It would lose big if one of those straight-mapped pages got swapped out.
+;;; Exceptions: unused portions of page-table-area and physical-page-data get unwired
+(cl:defvar WIRED-AREA-LIST '(
+ RESIDENT-SYMBOL-AREA ;No good reason
+ SYSTEM-COMMUNICATION-AREA ;For console, micro interrupt, etc.
+ SCRATCH-PAD-INIT-AREA ;Load micro code variables upon startup
+ MICRO-CODE-SYMBOL-AREA ;No good reason, actually
+ REGION-ORIGIN ;Used by page fault handler
+ REGION-LENGTH ;Used by page fault handler
+ REGION-BITS ;Used by page fault handler
+ REGION-FREE-POINTER ;Used by DISK-SAVE, etc.
+ ; Not likely to be swapped out!
+ PAGE-TABLE-AREA ;Used by page fault handler
+ PHYSICAL-PAGE-DATA ;Used by page fault handler
+ ADDRESS-SPACE-MAP ;Used by page fault handler
+ ))
+
+;;; Areas to be set up read only by cold load
+(cl:defvar READ-ONLY-AREA-LIST '(
+ SCRATCH-PAD-INIT-AREA
+ MICRO-CODE-SYMBOL-AREA
+ SUPPORT-ENTRY-VECTOR
+ CONSTANTS-AREA
+ INIT-LIST-AREA
+ P-N-STRING
+ MICRO-CODE-SYMBOL-NAME-AREA
+ MACRO-COMPILED-PROGRAM
+ ))
+
+;;; COLD-LOAD-AREA-SIZES is in QCOM, since writing out a microassembly refers to it.
+
+;;; Default region size is 16K
+(cl:defvar COLD-LOAD-REGION-SIZES '(
+ WORKING-STORAGE-AREA #o1000000
+ MACRO-COMPILED-PROGRAM #o400000
+ P-N-STRING #o400000
+ NR-SYM #o200000
+ PDL-AREA #o200000
+ PROPERTY-LIST-AREA #o200000
+ PERMANENT-STORAGE-AREA #o400000
+ ))
+
+;;; In the cold-load, areas have only one region, so you can only use one
+;;; representation type per area. These are the list areas, the rest are structure areas.
+(cl:defvar LIST-STRUCTURED-AREAS '(
+ SYSTEM-COMMUNICATION-AREA
+ SCRATCH-PAD-INIT-AREA
+ MICRO-CODE-SYMBOL-AREA
+ PAGE-TABLE-AREA
+ PHYSICAL-PAGE-DATA
+ REGION-ORIGIN
+ REGION-LENGTH
+ REGION-BITS
+ REGION-FREE-POINTER
+ REGION-GC-POINTER
+ REGION-LIST-THREAD
+ AREA-NAME
+ AREA-REGION-LIST
+ AREA-REGION-SIZE
+ AREA-REGION-BITS
+ AREA-MAXIMUM-SIZE
+ SUPPORT-ENTRY-VECTOR
+ CONSTANTS-AREA
+ MICRO-CODE-ENTRY-AREA
+ MICRO-CODE-ENTRY-NAME-AREA
+ MICRO-CODE-ENTRY-ARGS-INFO-AREA
+ MICRO-CODE-ENTRY-MAX-PDL-USAGE
+ MICRO-CODE-ENTRY-ARGLIST-AREA
+ MICRO-CODE-SYMBOL-NAME-AREA
+ INIT-LIST-AREA PROPERTY-LIST-AREA
+; OBT-TAILS
+ ))
+
+;;; not including fixed areas
+(cl:defvar STATIC-AREAS '(
+ INIT-LIST-AREA
+ PERMANENT-STORAGE-AREA
+ P-N-STRING CONTROL-TABLES
+ NR-SYM
+ MACRO-COMPILED-PROGRAM
+ ))
+
+;;; Don't put FUNCTION around the symbols in here -- that means if you
+;;; redefine the function the microcode does not get the new definition,
+;;; which is not what you normally want. Saying FUNCTION makes it a couple
+;;; microseconds faster to call it. Not all of these data are actually
+;;; used; check the microcode if you want to know.
+(cl:defvar SUPPORT-VECTOR-CONTENTS '(
+ 'PRINT
+ 'CALL-NAMED-STRUCTURE
+ 'DEFSTRUCT-DESCRIPTION
+ 'APPLY-LAMBDA
+ 'EQUAL
+ 'PACKAGE
+ 'EXPT-HARD
+ 'NUMERIC-ONE-ARGUMENT
+ 'NUMERIC-TWO-ARGUMENTS
+ '"unbound"
+ 'INSTANCE-HASH-FAILURE
+ 'INSTANCE-INVOKE-VECTOR
+ 'EQUALP
+ 'EQUALP-ARRAY
+ ))
+
+;;; Contents of constants page
+(cl:defvar CONSTANTS-PAGE '(NIL T 0 1 2 3 4 5 6 7 8 9 10. -1 -2 -3 -4))
+
+(cl:defvar SCRATCH-PAD-VARIABLES '(
+ SCRATCH-PAD-POINTERS
+ SCRATCH-PAD-PARAMETER-OFFSET
+ SCRATCH-PAD-PARAMETERS
+ SCRATCH-PAD-TEMP-OFFSET
+ SCRATCH-PAD-TEMPS
+ ))
+
+(cl:defvar SCRATCH-PAD-POINTERS '(
+ INITIAL-TOP-LEVEL-FUNCTION
+ ERROR-HANDLER-STACK-GROUP
+ CURRENT-STACK-GROUP
+ INITIAL-STACK-GROUP
+ LAST-ARRAY-ELEMENT-ACCESSED
+ ))
+
+(cl:defvar SCRATCH-PAD-PARAMETER-OFFSET #o20)
+
+;(GLOBAL:WHEN (GLOBAL:> (GLOBAL:LENGTH SCRATCH-PAD-POINTERS) SCRATCH-PAD-PARAMETER-OFFSET)
+; (BARF 'BARF 'SCRACH-PAD-PARAMETER-OFFSET 'BARF))
+
+(cl:defvar SCRATCH-PAD-PARAMETERS '(
+ ERROR-TRAP-IN-PROGRESS
+ DEFAULT-CONS-AREA
+ BIND-CONS-AREA
+ LAST-ARRAY-ACCESSED-TYPE
+ LAST-ARRAY-ACCESSED-INDEX
+ INVOKE-MODE
+ INVISIBLE-MODE
+ CDR-ATOM-MODE
+ CAR-ATOM-MODE
+ ACTIVE-MICRO-CODE-ENTRIES
+ ))
+
+(cl:defvar SCRATCH-PAD-TEMP-OFFSET #o20)
+
+;(GLOBAL:WHEN (GLOBAL:> (GLOBAL:LENGTH SCRATCH-PAD-PARAMETERS) SCRATCH-PAD-TEMP-OFFSET)
+; (BARF 'BARF 'SCRATCH-PAD-TEMP-OFFSET 'BARF))
+
+(cl:defvar SCRATCH-PAD-TEMPS '(
+ LAST-INSTRUCTION
+ TEMP-TRAP-CODE
+ LOCAL-BLOCK-OFFSET
+ SCRATCH-/#-ARGS-LOADED
+ TEMP-PC
+ SPECIALS-IN-LAST-BLOCK-SLOW-ENTERED
+ ))
+
+;;; The documentation that used to be here has been moved to LMDOC;FASLD >
+
+(cl:declaim (cl:SPECIAL FASL-TABLE FASL-GROUP-LENGTH FASL-GROUP-FLAG FASL-RETURN-FLAG))
+
+(cl:defvar FASL-GROUP-FIELD-VALUES '(
+ %FASL-GROUP-CHECK #o100000
+ %FASL-GROUP-FLAG #o40000
+ %FASL-GROUP-LENGTH #o37700
+ FASL-GROUP-LENGTH-SHIFT -6
+ %FASL-GROUP-TYPE #o77
+ %%FASL-GROUP-CHECK #o2001
+ %%FASL-GROUP-FLAG #o1701
+ %%FASL-GROUP-LENGTH #o0610
+ %%FASL-GROUP-TYPE #o0006
+ ))
+
+(cl:defvar FASL-GROUP-FIELDS (GET-ALTERNATE FASL-GROUP-FIELD-VALUES))
+(ASSIGN-ALTERNATE FASL-GROUP-FIELD-VALUES)
+
+(cl:defvar FASL-OPS '(
+ FASL-OP-ERR
+ FASL-OP-NOOP
+ FASL-OP-INDEX
+ FASL-OP-SYMBOL
+ FASL-OP-LIST
+ FASL-OP-TEMP-LIST
+ FASL-OP-FIXED
+ FASL-OP-FLOAT
+ FASL-OP-ARRAY
+ FASL-OP-EVAL
+ FASL-OP-MOVE
+ FASL-OP-FRAME
+ FASL-OP-LIST-COMPONENT
+ FASL-OP-ARRAY-PUSH
+ FASL-OP-STOREIN-SYMBOL-VALUE
+ FASL-OP-STOREIN-FUNCTION-CELL
+ FASL-OP-STOREIN-PROPERTY-CELL
+ FASL-OP-FETCH-SYMBOL-VALUE
+ FASL-OP-FETCH-FUNCTION-CELL
+ FASL-OP-FETCH-PROPERTY-CELL
+ FASL-OP-APPLY
+ FASL-OP-END-OF-WHACK
+ FASL-OP-END-OF-FILE
+ FASL-OP-SOAK
+ FASL-OP-FUNCTION-HEADER
+ FASL-OP-FUNCTION-END
+ FASL-OP-NULL-ARRAY-ELEMENT
+ FASL-OP-NEW-FLOAT
+ FASL-OP-UNUSED10
+ FASL-OP-UNUSED11
+ FASL-OP-UNUSED12
+ FASL-OP-QUOTE-POINTER
+ FASL-OP-S-V-CELL
+ FASL-OP-FUNCELL
+ FASL-OP-CONST-PAGE
+ FASL-OP-SET-PARAMETER
+ FASL-OP-INITIALIZE-ARRAY
+ FASL-OP-CHARACTER
+ FASL-OP-UNUSED1
+ FASL-OP-UNUSED2
+ FASL-OP-UNUSED3
+ FASL-OP-UNUSED4
+ FASL-OP-UNUSED5
+ FASL-OP-UNUSED6
+ FASL-OP-STRING
+ FASL-OP-STOREIN-ARRAY-LEADER
+ FASL-OP-INITIALIZE-NUMERIC-ARRAY
+ FASL-OP-REMOTE-VARIABLE
+ FASL-OP-PACKAGE-SYMBOL
+ FASL-OP-EVAL1
+ FASL-OP-FILE-PROPERTY-LIST
+ FASL-OP-REL-FILE
+ FASL-OP-RATIONAL
+ FASL-OP-COMPLEX
+ FASL-OP-LARGE-INDEX
+ FASL-OP-STOREIN-SYMBOL-CELL
+ ))
+(ASSIGN-VALUES FASL-OPS 0)
+
+(cl:defvar FASL-TABLE-PARAMETERS '(
+ FASL-NIL
+ FASL-EVALED-VALUE
+ FASL-TEM1
+ FASL-TEM2
+ FASL-TEM3
+ FASL-SYMBOL-HEAD-AREA
+ FASL-SYMBOL-STRING-AREA
+ FASL-OBARRAY-POINTER
+ FASL-ARRAY-AREA
+ FASL-FRAME-AREA
+ FASL-LIST-AREA
+ FASL-TEMP-LIST-AREA
+ FASL-UNUSED
+ FASL-UNUSED2
+ FASL-UNUSED3
+ FASL-UNUSED6
+ FASL-UNUSED4
+ FASL-UNUSED5
+ ))
+(ASSIGN-VALUES FASL-TABLE-PARAMETERS 0)
+
+(cl:defvar FASL-CONSTANTS '(
+ LENGTH-OF-FASL-TABLE
+ FASL-TABLE-WORKING-OFFSET
+ ))
+
+(cl:defvar FASL-CONSTANT-LISTS '(
+ FASL-GROUP-FIELDS
+ FASL-OPS
+ FASL-TABLE-PARAMETERS
+ FASL-CONSTANTS
+ ))
+
+(cl:defvar FASL-TABLE-WORKING-OFFSET #o40)
+
+;(GLOBAL:COND ((GLOBAL:> (GLOBAL:LENGTH FASL-TABLE-PARAMETERS) FASL-TABLE-WORKING-OFFSET)
+; (IOC V)
+; (GLOBAL:PRINT 'FASL-TABLE-PARAMETER-OVERFLOW)))
+
+;;; People call this you know, don't go randomly deleting it!
+(cl:DEFUN FASL-ASSIGN-VARIABLE-VALUES ()
+ ()) ;I guess what this used to do is done at top level in this file
Added: trunk/tools/cold/sysdcl.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/sysdcl.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,91 @@
+;;;-*- Mode:LISP; Package:SYSTEM-INTERNALS -*-
+;;; Declarations for SYSTEM's initally loaded
+;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+;; Cut down version for Common Lisp
+;;
+;; Only contains the cold load files.
+
+(in-package :cold)
+
+;;; These are the files in the cold load
+(defparameter +cold-load-file-list+
+ '("sys:fonts;cptfont.qfasl"
+ "sys:sys;qrand.qfasl"
+ "sys:io;qio.qfasl"
+; "sys:io;rdtbl.qfasl" ;done specially
+ "sys:io;read.qfasl"
+ "sys:io;print.qfasl"
+ "sys:window;cold.qfasl"
+ "sys:io;debug.qfasl"
+ "sys:sys;sgfctn.qfasl"
+ "sys:sys;qev.qfasl"
+ "sys:sys;ltop.qfasl"
+ "sys:sys;qfasl.qfasl"
+; "sys:io;mini.qfasl"
+ "sys:network;tftp-mini.qfasl"
+ "sys:sys;qfctns.qfasl"
+ "sys:sys2;string.qfasl"
+ ))
+
+;;; These variables are looked at by the cold load generator, who takes
+;;; the translated pathnames and dumps out prototype values into the new
+;;; world with those strings suitable for use with MINI.
+;;; They are then used before this file gets loaded.
+(defparameter mini-file-alist-list
+ '(load-packages-file-alist-1 load-packages-file-alist-2
+ global-package-file-alist
+ inner-system-file-alist
+ chaos-file-alist
+ site-file-alist host-table-file-alist))
+
+(defparameter load-packages-file-alist-1
+ '(("sys:sys;pack4.qfasl" "")))
+
+(defparameter load-packages-file-alist-2
+ '(("sys:sys;pkgdcl.lisp" "")
+ ))
+
+(defparameter global-package-file-alist
+ '(("sys:cold;global.lisp" "GLOBAL")
+ ("sys:cold;system.lisp" "SYSTEM")))
+
+(defparameter inner-system-file-alist
+ '(("sys:sys;qmisc.qfasl" "SI")
+ ("sys:sys;sort.qfasl" "SI") ;Needed by FLAVOR
+ ("sys:sys2;defsel.qfasl" "SI") ;Needed by FQUERY
+ ("sys:io;format.qfasl" "FORMAT") ;ditto
+ ("sys:io1;fquery.qfasl" "FORMAT") ;Needed by everything in sight
+ ("sys:sys2;flavor.qfasl" "SI") ;Needed by PROCES
+ ("sys:sys2;prodef.qfasl" "SI") ;Definitions for PROCES
+ ("sys:sys2;proces.qfasl" "SI")
+ ("sys:window;eh.qfasl" "EH")
+ ("sys:window;ehr.qfasl" "EH")
+ ("sys:window;ehc.qfasl" "EH")
+ ("sys:sys2;disass.qfasl" "COMPILER") ;EH calls subroutines in DISASS
+ ("sys:io;disk.qfasl" "SI")
+ ("sys:sys2;login.qfasl" "SI") ;ditto
+ ("sys:io;rddefs.qfasl" "SI") ;Load this before trying to read any #\'s
+ ("sys:sys2;host.qfasl" "SI")
+ ("sys:sys2;hash.qfasl" "SI") ;Needed by PATHNM
+ ("sys:io;stream.qfasl" "SI") ;Probably needed by any file system
+ ;; PATHNM must be the last file in this list. It breaks things while cold loading
+ ;; that QLD knows how to fix after this alist is loaded.
+ ("sys:io;pathnm.qfasl" "FS")
+ ))
+
+(defparameter chaos-file-alist
+ '(("sys:io;chsncp.qfasl" "CHAOS")
+ ("sys:io;chsaux.qfasl" "CHAOS")
+ ("sys:io;qfile.qfasl" "FS")
+ ))
+
+(defparameter site-file-alist
+ '(("sys:site;site.qfasl" "SI")
+ ))
+
+(defparameter host-table-file-alist
+ '(
+ ("sys:site;hsttbl.qfasl" "CHAOS")
+ ("sys:site;lmlocs.qfasl" "SI")
+ ))
Added: trunk/tools/cold/sysdcl99.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/sysdcl99.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,91 @@
+;;;-*- Mode:LISP; Package:SYSTEM-INTERNALS; Readtable:ZL; Base:10 -*-
+
+;;; Declarations for SYSTEM's initally loaded
+;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+(in-package :cold)
+
+;;;; These are the files in the cold load
+(defparameter +cold-load-file-list+
+ '("sys:fonts;cptfon.qfasl"
+ "sys:sys;qrand.qfasl"
+; "sys:sys;fspec.qfasl"
+ "sys:io;qio.qfasl"
+; "sys:io;rdtbl.qfasl" ;done specially
+; "sys:io;crdtbl.qfasl" ;done specially
+ "sys:io;read.qfasl"
+ "sys:io;print.qfasl"
+ "sys:window;cold.qfasl"
+ "sys:sys;sgfctn.qfasl"
+ "sys:sys;eval.qfasl"
+ "sys:sys;types.qfasl"
+ "sys:sys;ltop.qfasl"
+ "sys:sys;qfasl.qfasl"
+; "sys:io;mini.qfasl"
+ "sys:network;tftp-mini.qfasl"
+ "sys:sys;qfctns.qfasl"
+ "sys:sys2;string.qfasl"
+ "sys:sys2;character.qfasl"
+ "sys:sys;clpack.qfasl"
+ "sys:cold;global.qfasl"
+ "sys:cold;system.qfasl"
+ "sys:cold;lisp.qfasl"))
+
+;;; These variables are looked at by the cold load generator, which takes
+;;; the translated pathnames and dumps out prototype values into the new
+;;; world with those strings suitable for use with MINI.
+;;; They are then used before this file gets loaded.
+(defparameter mini-file-alist-list
+ '(inner-system-file-alist rest-of-pathnames-file-alist
+ ethernet-file-alist site-file-alist host-table-file-alist))
+
+(defparameter inner-system-file-alist
+ '(("sys:sys2;defsel.qfasl" "SI") ;By (resource named-structure-invoke)
+ ("sys:sys2;resour.qfasl" "SI") ;By FILLARRAY
+ ("sys:sys;qmisc.qfasl" "SI")
+ ("sys:sys;sort.qfasl" "SI") ;Needed by FLAVOR
+ ("sys:io;format.qfasl" "FORMAT") ;ditto
+ ("sys:io1;fquery.qfasl" "FORMAT") ;Needed by everything in sight
+ ("sys:sys2;hash.qfasl" "SI") ;Needed by FLAVOR,PATHNM
+ ("sys:sys2;flavor.qfasl" "SI") ;Needed by PROCES
+ ("sys:sys2;hashfl.qfasl" "SI") ;Make flavors really work.
+ ("sys:sys2;prodef.qfasl" "SI") ;Definitions for PROCES
+ ("sys:sys2;proces.qfasl" "SI")
+ ("sys:sys2;numer.qfasl" "SI") ;SI:EXPT-HARD needed by PROCES
+ ("sys:eh;eh.qfasl" "EH")
+ ("sys:eh;ehf.qfasl" "EH")
+ ("sys:eh;ehc.qfasl" "EH")
+ ("sys:eh;ehbpt.qfasl" "EH")
+ ("sys:sys2;disass.qfasl" "COMPILER") ;EH calls subroutines in DISASS
+ ("sys:sys2;describe.qfasl" "SI") ;For hack value
+ ("sys:io;disk.qfasl" "SI")
+ ("sys:sys2;login.qfasl" "SI") ;ditto
+ ("sys:io;rddefs.qfasl" "SI") ;Load this before trying to read any #\'s
+ ("sys:network;host.qfasl" "SI")
+ ("sys:network;package.qfasl" "SI")
+ ("sys:io;file;access.qfasl" "FS")
+ ("sys:io;stream.qfasl" "SI") ;Probably needed by any file system
+ ;; PATHNM must be the last file in this list. It breaks things while cold loading
+ ;; that QLD knows how to fix after this alist is loaded.
+ ("sys:io;file;pathnm.qfasl" "FS")))
+
+(defparameter rest-of-pathnames-file-alist
+ '(("sys:io;file;pathst.qfasl" "FS")
+ ("sys:io;file;logical.qfasl" "FS")
+ ("sys:file2;pathnm.qfasl" "FS")
+ ("sys:file;lmpars.qfasl" "FS")
+ ("sys:io;file;open.qfasl" "FS")
+ ("sys:network;chaos;chsncp.qfasl" "CHAOS")
+ ("sys:network;chaos;chuse.qfasl" "CHAOS")
+ ("sys:network;chaos;qfile.qfasl" "FS")))
+
+(defparameter ethernet-file-alist
+ '(("sys:io;simple-ether.qfasl" "ETHERNET")
+ ("sys:io;addr-res.qfasl" "ETHERNET")))
+
+(defparameter site-file-alist
+ '(("sys:site;site.qfasl" "SI")))
+
+(defparameter host-table-file-alist
+ '(("sys:site;hsttbl.qfasl" "CHAOS")
+ ("sys:site;lmlocs.qfasl" "SI")))
Added: trunk/tools/cold/system.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/cold/system.lisp Tue May 24 15:43:51 2016 (r450)
@@ -0,0 +1,110 @@
+;; These symbols are put onto the SYSTEM package, which is a subpackage
+;; of GLOBAL and has SYSTEM-INTERNALS and COMPILER as subpackages.
+;; All of the symbols from SYSTEM-CONSTANT-LISTS and SYSTEM-VARIABLE-LISTS
+;; are on it as well.
+;; Also, any symbol in MICRO-CODE-SYMBOL-NAME-AREA that doesn't go on
+;; GLOBAL gets put on SYSTEM.
+
+; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+;; Be SURE to leave a SPACE before all symbols, because the Maclisp reader b.d.g.
+ GET-MACRO-ARG-DESC-POINTER ;These used by compiler.
+ HEADER-TYPE-FEF
+ CONSTANTS-PAGE
+ *LOGIOR
+ *LOGXOR
+ *LOGAND
+ *BOOLE
+ *MAX
+ *MIN
+ M-EQ
+ RESET-TEMPORARY-AREA ;Used by COMPILER, SI, but shouldn't be GLOBAL really
+ DECLARED-DEFINITION ;More COMPILER vs SI problems
+ UNDO-DECLARATIONS-FLAG ;Used by MACRO to communicate with QC-FILE.
+ FILE-LOCAL-DECLARATIONS ;Used by COMPILER and SI
+ FDEFINE-FILE-PATHNAME
+ TYPEP-ALIST ;Used by TYPEP and by its optimizers.
+ ACTIVE-PROCESSES
+ ALL-PROCESSES
+ CLOCK-FUNCTION-LIST
+ LISP-ERROR-HANDLER
+ COMMAND-LEVEL ;for ABORT key
+ *BREAK-BINDINGS*
+ DEFUN-COMPATIBILITY ;If you expect DEFUN to work
+ DECODE-KEYWORD-ARGLIST
+ STORE-KEYWORD-ARG-VALUES
+ READ-AREA
+ FUNCTION-SPEC-HANDLER
+ VALIDATE-FUNCTION-SPEC
+ STANDARDIZE-FUNCTION-SPEC
+ FDEFINITION-LOCATION ;not in GLOBAL, I guess you're supposed to use LOCF
+ FUNCTION-PARENT
+ *DEBUG-INFO-LOCAL-DECLARATION-TYPES*
+ LAMBDA-MACRO-CALL-P
+ LAMBDA-MACRO-EXPAND
+
+
+;; Shared between LFL which is in COMPILER and stuff in SI
+ GET-FILE-LOADED-ID
+ SET-FILE-LOADED-ID
+
+;; "Entries" to DISK
+ GET-DISK-RQB
+ RETURN-DISK-RQB
+ FIND-DISK-PARTITION
+ FIND-DISK-PARTITION-FOR-READ
+ FIND-DISK-PARTITION-FOR-WRITE
+ PARTITION-COMMENT
+ UPDATE-PARTITION-COMMENT
+ MEASURED-SIZE-OF-PARTITION
+ GET-DISK-STRING
+ PUT-DISK-STRING
+ GET-DISK-FIXNUM
+ PUT-DISK-FIXNUM
+ DISK-READ
+ DISK-WRITE
+ DISK-READ-COMPARE
+ POWER-UP-DISK
+ CLEAR-DISK-FAULT
+ RQB-8-BIT-BUFFER
+ RQB-BUFFER
+ RQB-NPAGES
+ PAGE-IN-STRUCTURE
+ PAGE-IN-WORDS
+ PAGE-IN-REGION
+ PAGE-IN-AREA
+ PAGE-IN-ARRAY
+ PAGE-OUT-STRUCTURE
+ PAGE-OUT-WORDS
+ PAGE-OUT-REGION
+ PAGE-OUT-AREA
+ PAGE-OUT-ARRAY
+
+;Symbols defined by LISPM2;SGDEFS. These should be in SYSTEM just like those
+;symbols defined by QCOM.
+ SG-NAME SG-REGULAR-PDL SG-REGULAR-PDL-LIMIT SG-SPECIAL-PDL SG-SPECIAL-PDL-LIMIT
+ SG-INITIAL-FUNCTION-INDEX
+ SG-UCODE SG-TRAP-TAG SG-RECOVERY-HISTORY SG-FOOTHOLD-DATA
+ SG-STATE SG-CURRENT-STATE SG-FOOTHOLD-EXECUTING-FLAG SG-PROCESSING-ERROR-FLAG
+ SG-PROCESSING-INTERRUPT-FLAG SG-SAFE SG-INST-DISP SG-IN-SWAPPED-STATE
+ SG-SWAP-SV-ON-CALL-OUT SG-SWAP-SV-OF-SG-THAT-CALLS-ME
+ SG-PREVIOUS-STACK-GROUP SG-CALLING-ARGS-POINTER SG-CALLING-ARGS-NUMBER
+ SG-TRAP-AP-LEVEL SG-REGULAR-PDL-POINTER SG-SPECIAL-PDL-POINTER SG-AP SG-IPMARK
+ SG-TRAP-MICRO-PC
+;SG-ERROR-HANDLING-SG
+;SG-INTERRUPT-HANDLING-SG
+ SG-SAVED-QLARYH SG-SAVED-QLARYL SG-SAVED-M-FLAGS SG-FLAGS-QBBFL
+ SG-FLAGS-CAR-SYM-MODE SG-FLAGS-CAR-NUM-MODE SG-FLAGS-CDR-SYM-MODE SG-FLAGS-CDR-NUM-MODE
+ SG-FLAGS-DONT-SWAP-IN SG-FLAGS-TRAP-ENABLE SG-FLAGS-MAR-MODE SG-FLAGS-PGF-WRITE
+ SG-FLAGS-METER-ENABLE SG-FLAGS-TRAP-ON-CALL
+ SG-AC-K SG-AC-S SG-AC-J SG-AC-I SG-AC-Q SG-AC-R SG-AC-T SG-AC-E SG-AC-D
+ SG-AC-C SG-AC-B SG-AC-A SG-AC-ZR SG-AC-2 SG-AC-1 SG-VMA-M1-M2-TAGS SG-SAVED-VMA SG-PDL-PHASE
+ REGULAR-PDL-SG SPECIAL-PDL-SG
+ RP-CALL-WORD RP-EXIT-WORD RP-ENTRY-WORD RP-FUNCTION-WORD
+ RP-DOWNWARD-CLOSURE-PUSHED RP-ADI-PRESENT RP-DESTINATION RP-DELTA-TO-OPEN-BLOCK
+ RP-DELTA-TO-ACTIVE-BLOCK RP-MICRO-STACK-SAVED RP-PC-STATUS RP-BINDING-BLOCK-PUSHED RP-EXIT-PC
+ RP-NUMBER-ARGS-SUPPLIED RP-LOCAL-BLOCK-ORIGIN RP-TRAP-ON-EXIT
+ FEF-INITIAL-PC FEF-NO-ADL-P FEF-FAST-ARGUMENT-OPTION-P FEF-SPECIALS-BOUND-P
+ FEF-LENGTH FEF-FAST-ARGUMENT-OPTION-WORD FEF-BIT-MAP-P FEF-BIT-MAP
+ FEF-NUMBER-OF-LOCALS FEF-ADL-ORIGIN FEF-ADL-LENGTH FEF-NAME
+
More information about the mit-cadr-cvs
mailing list