mirror of
https://github.com/PDP-10/its.git
synced 2026-03-10 04:44:26 +00:00
cc8e6c1964
the lisp interpreter is first booted. Redumps lisp compiler with updated FASL files built from source.
211 lines
7.2 KiB
Common Lisp
Executable File
211 lines
7.2 KiB
Common Lisp
Executable File
;;; ERRCK -*-Mode:Lisp;Package:SI;Lowercase:T-*-
|
||
;;; **************************************************************************
|
||
;;; *** NIL ******** ERRor ChecKing and correcting ***************************
|
||
;;; **************************************************************************
|
||
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **************
|
||
;;; **************************************************************************
|
||
|
||
(herald ERRCK /30)
|
||
|
||
#-NIL (include ((lisp) subload lsp))
|
||
|
||
#-NIL
|
||
(eval-when (eval compile)
|
||
(subload SHARPCONDITIONALS)
|
||
)
|
||
|
||
#+(or LISPM (and NIL (not MacLISP)))
|
||
(globalize "ERROR-RESTART"
|
||
"CHECK-ARG"
|
||
"CHECK-ARG-CONTROL-STRING"
|
||
"CHECK-TYPE"
|
||
"CHECK-SUBSEQUENCE"
|
||
)
|
||
|
||
#-For-NIL
|
||
(eval-when (eval compile)
|
||
(subload UMLMAC)
|
||
)
|
||
|
||
|
||
|
||
#M (declare (own-symbol ERROR-RESTART CHECK-ARG
|
||
CHECK-TYPE CHECK-SUBSEQUENCE
|
||
SI:CHECK-TYPER SI:CHECK-SUBSEQUENCER)
|
||
(*lexpr SEND))
|
||
|
||
#+(and MacLISP (not NIL))
|
||
(eval-when (eval load compile)
|
||
(cond ((status feature COMPLR)
|
||
(*lexpr SI:CHECK-SUBSEQUENCER SI:LOST-MESSAGE-HANDLER)
|
||
(*expr SI:CHECK-TYPER)))
|
||
)
|
||
|
||
|
||
|
||
;;;; CHECK-ARG and ERROR-RESTART are LISPM compatible
|
||
;;;; CHECK-TYPE and CHECK-SUBSEQUENCE
|
||
|
||
|
||
(defmacro CHECK-ARG (var pred string &optional type complainant)
|
||
(if (and (null type) (symbolp pred))
|
||
(setq type pred))
|
||
(if complainant (setq complainant `',complainant))
|
||
(let ((termin (cond ((symbolp pred) `(,pred ,var))
|
||
('T pred))))
|
||
`(DO ()
|
||
(,termin ,var)
|
||
(SETQ ,var (CERROR 'T () ':WRONG-TYPE-ARGUMENT
|
||
CHECK-ARG-CONTROL-STRING
|
||
',type ,var ',var ,string ,complainant)))))
|
||
|
||
(defvar CHECK-ARG-CONTROL-STRING
|
||
'|The ~2G~S argument ~4G~:[~;to ~4G~S ~]was ~1G~S, which is not ~3G~A|)
|
||
|
||
|
||
(defmacro ERROR-RESTART (&rest forms)
|
||
`(DO () (()) (*CATCH 'ERROR-RESTART (RETURN (PROGN ,.forms)))))
|
||
|
||
|
||
|
||
(defmacro CHECK-TYPE (var type-test-predicate using-function)
|
||
(cond ((and var (symbolp var)) () )
|
||
((fboundp 'si:check-typer)
|
||
(setq var (si:check-typer var #'SYMBOLP '|CHECK-TYPE MACRO|)))
|
||
('T (error '|Not a SYMBOL| var)))
|
||
`(SETQ ,var (SI:CHECK-TYPER ,var ,type-test-predicate ,using-function)))
|
||
|
||
|
||
(defmacro CHECK-SUBSEQUENCE ((seq start cnt) requisite-type using-function
|
||
&optional (startp 'T) (cntp 'T)
|
||
&rest rest)
|
||
(or (and seq (symbolp seq))
|
||
(setq seq (si:check-typer seq #'SYMBOLP '|CHECK-SUBSEQUENCE MACRO|)))
|
||
(or (and start (symbolp start))
|
||
(setq start (si:check-typer start #'SYMBOLP '|CHECK-SUBSEQUENCE MACRO|)))
|
||
(cond
|
||
((null cnt) (setq cntp () ))
|
||
((not (symbolp cnt))
|
||
(setq cnt (si:check-typer cnt #'SYMBOLP '|CHECK-SUBSEQUENCE MACRO|))))
|
||
`(MULTIPLE-VALUE (,seq ,start ,cnt)
|
||
(SI:CHECK-SUBSEQUENCER ,seq ,start ,cnt
|
||
,requisite-type ,using-function
|
||
,startp ,cntp ,. rest)))
|
||
|
||
|
||
|
||
;;;; SI:CHECK-TYPER and SI:CHECK-SUBSEQUENCER
|
||
|
||
;; Someday, pleas put in a 4th arg here, which is paralle to the
|
||
;; 'complainant' arg of CHECK-ARG. 11/26/80 JonL and RLB
|
||
|
||
|
||
(defun SI:CHECK-TYPER (argument type-test-predicate using-function)
|
||
(do ()
|
||
;; Basically, a funcall follows, but "beat-out-the-funcall" if possible
|
||
((cond ((eq type-test-predicate #'SI:NON-NEG-FIXNUMP)
|
||
(and (fixnump argument) (>= argument 0)))
|
||
((eq type-test-predicate #'SI:MAX-EXTEND-SIZEP)
|
||
(and (fixnump argument)
|
||
(>= argument 0)
|
||
(< argument #M 510. #-MacLISP 1_18.)))
|
||
((eq type-test-predicate #'PAIRP)
|
||
(pairp argument))
|
||
((eq type-test-predicate #'SYMBOLP)
|
||
(symbolp argument))
|
||
((eq type-test-predicate #'FIXNUMP)
|
||
(fixnump argument))
|
||
(T (funcall type-test-predicate argument))))
|
||
(setq argument
|
||
(cerror 'T () ':WRONG-TYPE-ARGUMENT
|
||
"~1G~S does not pass the ~0G~S test, for function ~2G~S"
|
||
type-test-predicate argument using-function)))
|
||
argument)
|
||
|
||
|
||
(defun SI:CHECK-SUBSEQUENCER (seq start cnt requisite-type using-function
|
||
&optional (startp 'T)
|
||
(cntp 'T)
|
||
(forwardp 'T)
|
||
lispmp )
|
||
;;The 'lispm' argument only matters when 'forwardp' is null -- then
|
||
;; we need to know whether the 'start' index signifies the last index,
|
||
;; or (as on the LISPM) the last index plus one.
|
||
(let ((floating-type (null requisite-type))
|
||
len)
|
||
(do ()
|
||
((prog2 (cond (requisite-type)
|
||
;; Let the requisite-type "float" if it isn't supplied
|
||
((null seq) (setq requisite-type 'LIST))
|
||
('T (setq requisite-type (ptr-typep seq))
|
||
(if (eq requisite-type 'PAIR)
|
||
(setq requisite-type 'LIST))))
|
||
(memq requisite-type '(STRING VECTOR BITS LIST EXTEND))))
|
||
(if floating-type
|
||
(setq seq (cerror 'T () ':WRONG-TYPE-ARGUMENT
|
||
"~1G~S (of ptr-TYPEP ~S) is not a sequence -- ~S"
|
||
'T seq requisite-type 'CHECK-SUBSEQUENCE)
|
||
requisite-type () )
|
||
(setq requisite-type
|
||
(cerror 'T () ':WRONG-TYPE-ARGUMENT
|
||
"~1G~S is not a sequence type-name -- ~S"
|
||
'T requisite-type 'CHECK-SUBSEQUENCE))))
|
||
;; Loop while checking type of sequence argument
|
||
(do ()
|
||
((caseq requisite-type
|
||
(STRING (when (stringp seq)
|
||
(setq len (string-length seq))
|
||
'T))
|
||
(VECTOR (when (vectorp seq)
|
||
(setq len (vector-length seq))
|
||
'T))
|
||
(BITS (when (bitsp seq)
|
||
(setq len (bits-length seq))
|
||
'T))
|
||
(LIST (when (listp seq)
|
||
(setq len (length seq))
|
||
'T))
|
||
(EXTEND (when (extendp seq)
|
||
(setq len (extend-length seq))
|
||
'T))
|
||
(T (error 'CHECK-SUBSEQUENCE))))
|
||
(setq seq (cerror 'T () ':WRONG-TYPE-ARGUMENT
|
||
"~1G~S must be a ~0G~S for function ~2G~S"
|
||
requisite-type seq using-function)))
|
||
;; Do defaulting on the start-index argument, if necessary, or
|
||
;; loop while checking it for being withing range
|
||
(if (or (not startp) (null start))
|
||
(setq start (if forwardp 0 (if lispmp len (1- len))))
|
||
(do ()
|
||
((and (fixnump start)
|
||
(or (and (>= start 0) ;Normal accessible element index
|
||
(< start len))
|
||
(and (>= start -1)
|
||
(<= start len)
|
||
;;For backwards searching, permit index to be one
|
||
;; greater than maximum legal for access.
|
||
(or (not forwardp)
|
||
;;Or a 0 cnt permits this kind of index too.
|
||
(or (and (fixnump cnt)
|
||
(= cnt 0))
|
||
(and (not cntp)
|
||
(= len 0))
|
||
))))))
|
||
(setq start (cerror 'T () ':INCONSISTENT-ARGUMENTS
|
||
"The 'start' index ~1G~S is not within ~2G~S, for function ~3G~S"
|
||
(list start seq) start seq using-function))))
|
||
;; Do defaulting on the number-of-items argument, if necessary, or
|
||
;; loop while checking start number-of-items argument
|
||
(if (or (not cntp) (null cnt))
|
||
(setq cnt (if forwardp (- len start) (if lispmp start (1+ start))))
|
||
(do ()
|
||
((cond ((or (not (fixnump cnt)) (< cnt 0)) () )
|
||
(forwardp (<= (+ start cnt) len))
|
||
('T (if lispmp (> start cnt) (>= start cnt)))))
|
||
(setq cnt (cerror 'T () ':INCONSISTENT-ARGUMENTS
|
||
"The 'count' value ~1G~S is out of range for ~2G~S,~% ~4G~:[bounded above by~;starting at~] index ~3G~S, and going in the ~4G~:[backward~;forward~] direction,~% from function ~5G~S"
|
||
(list seq start cnt (if forwardp '+ '-))
|
||
cnt seq start forwardp using-function))))
|
||
(values seq start cnt)))
|
||
|