mirror of
https://github.com/PDP-10/its.git
synced 2026-01-22 02:26:05 +00:00
cc8e6c1964
the lisp interpreter is first booted. Redumps lisp compiler with updated FASL files built from source.
86 lines
2.8 KiB
Common Lisp
Executable File
86 lines
2.8 KiB
Common Lisp
Executable File
;;; EXTBAS -*-Mode:Lisp;Package:SI;Lowercase:T-*-
|
||
;;; ****************************************************************
|
||
;;; *** MacLISP **** EXTended datatype scheme, BASic functions *****
|
||
;;; ****************************************************************
|
||
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ****
|
||
;;; ****************************************************************
|
||
|
||
(herald EXTBAS /39)
|
||
|
||
|
||
(eval-when (eval compile)
|
||
(or (get 'SUBLOAD 'VERSION)
|
||
(load '((lisp) subload)))
|
||
(subload EXTMAC)
|
||
(subload DEFSETF)
|
||
)
|
||
|
||
|
||
;; Be careful about circular dependencies! Luckily this one is minor,
|
||
;; and can be patched, if necessary. (EXTEND has some SETFs in it.)
|
||
;; DEFSETF -> DEFVST -> EXTEND -> EXTMAC -> DEFSETF
|
||
|
||
(defsetf SI:XREF ((() h n) val) () `(SI:XSET ,h ,n ,val))
|
||
|
||
|
||
;; Used by typical NIL-compatibility functions
|
||
(defun SI:NON-NEG-FIXNUMP (n) (and (fixnump n) (>= N 0)))
|
||
;; Used by extend conser error checking
|
||
(defun SI:MAX-EXTEND-SIZEP (n) (and (fixnump n) (>= N 0) (< n 510.)))
|
||
|
||
|
||
|
||
|
||
;;;; Regular DEFUNitions of XREF, XSET, MAKE-EXTEND, EXTEND-LENGTH etc.
|
||
|
||
;;; SOURCE-TRAN's for XREF, XSET, MAKE-EXTEND, EXTEND-LENGTH etc.
|
||
;;; come in from exthuk file
|
||
(eval-when (eval compile load)
|
||
(if (status feature COMPLR)
|
||
(subload EXTHUK))
|
||
)
|
||
|
||
;; Pass the buck to the CXR function on error checking for these guys.
|
||
(defun SI:XREF (h n)
|
||
(subrcall T #,(get 'CXR 'SUBR) (+ #.si:extend-q-overhead n) h))
|
||
(defun SI:XSET (h n val)
|
||
(subrcall T #,(get 'RPLACX 'SUBR) (+ #.si:extend-q-overhead n) h val))
|
||
|
||
(defun SI:MAKE-EXTEND (n clss)
|
||
(if (or (or (not (fixnump n)) (< n 0) (> n 510.))
|
||
(not (classp clss)))
|
||
(cond ((fboundp 'SI:CHECK-TYPER)
|
||
(check-type n #'SI:MAX-EXTEND-SIZEP 'SI:MAKE-EXTEND)
|
||
(check-type clss #'CLASSP 'SI:MAKE-EXTEND))
|
||
('T (error '|Bad args to SI:MAKE-EXTEND| (list n clss)))))
|
||
;;Note that this must be open-compiled, either because it has a
|
||
;; MACRO definition, or a SOURCE-TRANS property (from EXTHUK file).
|
||
(si:make-extend n clss))
|
||
|
||
(defun SI:make-random-extend (n &optional clss)
|
||
(si:make-extend n clss))
|
||
|
||
|
||
(defun SI:EXTEND-LENGTH (x)
|
||
(if (and *RSET (not (extendp x)))
|
||
(cond ((fboundp 'SI:CHECK-TYPER)
|
||
(check-type x #'EXTENDP 'SI:EXTEND-LENGTH))
|
||
('T (error '|Not an EXTEND| x))))
|
||
;;Note that this must be open-compiled, either because it has a
|
||
;; MACRO definition, or a SOURCE-TRANS property (from EXTHUK file).
|
||
(si:extend-length x))
|
||
|
||
(let ((x (getl 'SI:EXTEND-LENGTH '(EXPR SUBR))))
|
||
(putprop 'EXTEND-LENGTH (cadr x) (car x)))
|
||
|
||
(defun SI:EXTEND n
|
||
(let ((size (1- n))
|
||
(clss (if (>= n 1) (arg 1))))
|
||
(declare (fixnum size))
|
||
(do ((obj (si:make-extend size clss))
|
||
(i 0 (1+ i)))
|
||
((>= i size) obj)
|
||
(declare (fixnum i))
|
||
;;(ARG 1) is class obj, (ARG 2) is first elt
|
||
(si:xset obj i (arg (+ i 2))))))
|