mirror of
https://github.com/PDP-10/its.git
synced 2026-03-02 01:50:24 +00:00
cc8e6c1964
the lisp interpreter is first booted. Redumps lisp compiler with updated FASL files built from source.
368 lines
12 KiB
Common Lisp
Executable File
368 lines
12 KiB
Common Lisp
Executable File
;;; SUBSEQ -*-Mode:Lisp;Package:SI;Lowercase:T-*-
|
||
;;; ************************************************************************
|
||
;;; *** NIL ******* SUBSEQuencing and coercion functions *******************
|
||
;;; ************************************************************************
|
||
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ************
|
||
;;; ************************************************************************
|
||
|
||
;;; SUBSEQ and REPLACE are seen as a specific usage of the "coercion"
|
||
;;; functions.
|
||
;;; General coercion routines TO-<mumble>, which take in any kind of
|
||
;;; sequence, and give out a corresponding sequence of type <mumble>.
|
||
;;; Additionally, in this file is TO-CHARACTER, TO-CHARACTER-N, TO-BIT,
|
||
;;; and TO-UPCASE .
|
||
|
||
|
||
(herald SUBSEQ /39)
|
||
|
||
|
||
#+(or LISPM (and NIL (not MacLISP)))
|
||
(progn 'compile
|
||
(globalize "SUBSEQ")
|
||
(globalize "REPLACE")
|
||
(globalize "TO-LIST")
|
||
(globalize "TO-VECTOR")
|
||
(globalize "TO-STRING")
|
||
(globalize "TO-BITS")
|
||
(globalize "TO-CHARACTER")
|
||
(globalize "TO-CHARACTER-N")
|
||
(globalize "TO-CHARACTER-N?")
|
||
(globalize "TO-SYMBOL")
|
||
(globalize "TO-BIT")
|
||
(globalize "TO-UPCASE")
|
||
)
|
||
|
||
#-NIL
|
||
(eval-when (eval compile)
|
||
(or (get 'SUBLOAD 'VERSION)
|
||
(load '((lisp) subload)))
|
||
(subload SHARPCONDITIONALS)
|
||
(subload EXTMAC) ;also gets MACAID, ERRCK,
|
||
(subload EXTHUK)
|
||
(setq-if-unbound *:bits-per-character #Q 8 #-LISPM 7)
|
||
)
|
||
|
||
#-NIL
|
||
(eval-when (eval compile load)
|
||
(subload EXTEND)
|
||
)
|
||
|
||
|
||
|
||
#+(local MacLISP)
|
||
(declare (own-symbol LENGTH *:FIXNUM-TO-CHARACTER GET-PNAME)
|
||
(own-symbol SUBSEQ REPLACE TO-LIST TO-VECTOR TO-STRING TO-BITS))
|
||
|
||
;;; Here's some particular macro definitions and declaractions,
|
||
;;; knowing that the intended target is with the other maclisp
|
||
;;; NILCOM software.
|
||
#+(local MacLISP)
|
||
(declare (*expr LENGTH *:FIXNUM-TO-CHARACTER TO-CHARACTER-N?
|
||
GET-PNAME MAKE-BITS STRING-PNGET)
|
||
(*LEXPR MAKE-STRING STRING-REPLACE STRING-SUBSEQ STRING-MISMATCHQ
|
||
STRING-POSQ STRING-POSQ-N STRING-BPOSQ STRING-BPOSQ-N )
|
||
(FIXNUM (+INTERNAL-CHAR-N () FIXNUM))
|
||
(NOTYPE (+INTERNAL-RPLACHAR-N () FIXNUM FIXNUM)))
|
||
|
||
|
||
#-NIL
|
||
(eval-when (eval compile)
|
||
(setq defmacro-for-compiling () defmacro-displace-call () )
|
||
(defmacro STRING-LENGTH (x) `(SI:XREF ,x 1))
|
||
(defmacro BITS-LENGTH (x) `(SI:XREF ,x 1))
|
||
(defmacro VECTOR-LENGTH (&rest w) `(SI:EXTEND-LENGTH ,.w))
|
||
(defmacro EXTEND-LENGTH (&rest w) `(SI:EXTEND-LENGTH ,.w))
|
||
(defmacro SI:EXTEND-LENGTH (x) `(- (HUNKSIZE ,x) 2))
|
||
(defmacro MAKE-VECTOR (n) `(SI:MAKE-EXTEND ,n VECTOR-CLASS))
|
||
(defmacro VREF (&rest w) `(SI:XREF ,.w))
|
||
(defmacro VSET (&rest w) `(SI:XSET ,.w))
|
||
#M (progn 'compile
|
||
(defmacro *:CHARACTER-TO-FIXNUM (c) `(MAKNUM (SI:XREF ,c 0)))
|
||
(defmacro SI:SYMBOL-CONS (x)
|
||
`(PNPUT (STRING-PNGET ,x 7) () ))
|
||
(and (status feature COMPLR)
|
||
(SPECIAL |+internal-CHARACTER-table/||))
|
||
)
|
||
#Q (progn 'compile
|
||
(defmacro *:CHARACTER-TO-FIXNUM (VAL) `(AR-1 ,val 1))
|
||
)
|
||
#-(local PDP10) (progn 'compile
|
||
(defmacro +INTERNAL-CHAR-N (&rest w) `(CHAR-N ,.w))
|
||
(defmacro +INTERNAL-RPLACHAR-N (&rest w) `(RPLACHAR-N ,.w)) )
|
||
(setq defmacro-for-compiling 'T defmacro-displace-call 'T )
|
||
)
|
||
|
||
|
||
#M (eval-when (eval load compile)
|
||
(and (status feature complr)
|
||
(*lexpr SUBSEQ REPLACE TO-LIST TO-VECTOR TO-STRING TO-BITS)))
|
||
|
||
|
||
|
||
;;;; SUBSEQ, REPLACE, and coercions TO-<mumble>
|
||
|
||
|
||
(defun SUBSEQ (str &OPTIONAL (i 0) (cnt () cntp))
|
||
(SI:replacer () str 0 i cnt cntp () ))
|
||
|
||
(defun REPLACE (v1 v2 &optional (i1 0) (i2 0) (cnt () cntp))
|
||
(SI:replacer v1 v2 i1 i2 cnt cntp () ))
|
||
|
||
|
||
(defun TO-LIST (str &OPTIONAL (i 0) (cnt () cntp))
|
||
(SI:replacer () str 0 i cnt cntp 'LIST))
|
||
|
||
(defun TO-VECTOR (str &OPTIONAL (i 0) (cnt () cntp))
|
||
(SI:replacer () str 0 i cnt cntp 'VECTOR))
|
||
|
||
(defun TO-STRING (ob &OPTIONAL (i 0) (cnt () cntp))
|
||
(cond
|
||
((and (= i 0)
|
||
(null cntp)
|
||
(typecaseq ob
|
||
(STRING 'T)
|
||
(SYMBOL (setq ob (get-pname ob)) 'T)
|
||
(FIXNUM (setq ob (+internal-rplachar-n (make-string 1) 0 ob))
|
||
'T)
|
||
(CHARACTER (setq ob (+internal-rplachar-n
|
||
(make-string 1)
|
||
0
|
||
(*:character-to-fixnum ob)))
|
||
'T)))
|
||
ob)
|
||
('T (SI:replacer () ob 0 i cnt cntp 'STRING))))
|
||
|
||
(defun TO-BITS (ob &OPTIONAL (i 0) (cnt () cntp))
|
||
(cond ((and (= i 0)
|
||
(null cntp)
|
||
(typecaseq ob
|
||
(BITS
|
||
'T)
|
||
((FIXNUM CHARACTER)
|
||
(setq ob (rplacbit (make-bits 1) 1 (to-bit ob)))
|
||
'T)))
|
||
ob)
|
||
('T (if (symbolp ob) (setq ob (get-pname ob)))
|
||
(SI:replacer () ob 0 i cnt cntp 'BITS))))
|
||
|
||
|
||
|
||
;;;; TO-CHARACTER
|
||
|
||
(defvar SI:COERCION-ERROR-STRING "~1G~S is not coercible to a ~0G~A")
|
||
|
||
|
||
(defbothmacro TO-CHARACTER (c)
|
||
`(*:FIXNUM-TO-CHARACTER (TO-CHARACTER-N? ,c () )))
|
||
|
||
(defbothmacro TO-CHARACTER-N (c) `(TO-CHARACTER-N? ,c () ))
|
||
|
||
|
||
(defun TO-CHARACTER-N? (char no-error?)
|
||
#+(and (not NIL) (local PDP10))
|
||
(subload STRING)
|
||
(prog (nc)
|
||
A (setq nc (typecaseq char
|
||
(CHARACTER (*:character-to-fixnum char))
|
||
(FIXNUM (if (and (>= char 0)
|
||
(< char #.(^ 2 *:bits-per-character)))
|
||
char))
|
||
(STRING (cond ((= (string-length char) 0) 0)
|
||
((+internal-char-n char 0))))
|
||
(SYMBOL (cond ((= (flatc char) 0) 0) ;More efficient
|
||
((getcharn char 1)))) ; than get-pname
|
||
(T () )))
|
||
(if (or nc no-error?) (return nc))
|
||
(setq char (cerror 'T () ':WRONG-TYPE-ARGUMENT
|
||
SI:COERCION-ERROR-STRING 'CHARACTER char))
|
||
(go A)))
|
||
|
||
|
||
;;;; SI:replacer
|
||
|
||
|
||
(defun SI:replacer (new str i1 i2 cnt cntp coercion?
|
||
#N &optional #N (rset 'T))
|
||
(let ((cnt1 cnt) (cnt2 cnt)
|
||
(l1 0) (l2 0)
|
||
(ty1p) (ty2p)
|
||
(*RSET #-NIL *RSET
|
||
#+NIL rset)
|
||
)
|
||
(declare (fixnum l1 l2))
|
||
(cond
|
||
(*RSET
|
||
(check-subsequence (str i2 cnt2) () 'SI:replacer 'T cntp)
|
||
(cond (new
|
||
(if (and cntp (fixnump cnt1) (not (= cnt1 cnt2)))
|
||
(setq cnt1 cnt2))
|
||
(check-subsequence (new i1 cnt1) () 'SI:replacer 'T cntp)
|
||
(if (or (null cntp) (not (= cnt cnt1)) (not (= cnt cnt2)))
|
||
(setq cnt (if (< cnt1 cnt2) cnt1 cnt2))))
|
||
('T (setq cnt cnt2)))
|
||
(setq cntp 'T)))
|
||
(prog () ;; PROG-ification only for use by RETURN
|
||
;; First, calculate type and lengths of primary "sequence" argument
|
||
;; The types will be encoded as 0 - LIST 1 - VECTOR 2 - EXTEND
|
||
;; 3 - STRING 4 - BITS 5 - Other
|
||
(typecaseq str
|
||
(PAIR (setq ty2p 0 l2 (length str)))
|
||
(STRING (setq ty2p 3 l2 (string-length str)) )
|
||
(VECTOR (setq ty2p 1 l2 (vector-length str)))
|
||
(EXTEND (setq ty2p 2 l2 (extend-length str)))
|
||
(BITS (setq ty2p 4 l2 (bits-length str)))
|
||
(T (cond ((null str) (setq ty2p 0 l2 0))
|
||
((or (null coercion?) (sequencep str))
|
||
(+internal-lossage '|Not yet coded| 'SI:REPLACER str))
|
||
('T (setq str (list str) ty2p 0 l2 1)))))
|
||
(if (and cntp (< l2 cnt)) (setq cnt l2))
|
||
;; Calculate type and length of output sequence, if supplied by caller
|
||
(cond (new
|
||
(typecaseq new
|
||
(PAIR (setq ty1p 0 l1 (length new)))
|
||
(STRING (setq ty1p 3 l1 (string-length new)) )
|
||
(VECTOR (setq ty1p 1 l1 (vector-length new)))
|
||
(EXTEND (setq ty1p 2 l1 (extend-length new)))
|
||
(BITS (setq ty1p 4 l1 (bits-length new)))
|
||
(T (+internal-lossage '|Not yet coded| 'SI:REPLACER new)))
|
||
(cond ((null cntp)
|
||
(let ((n1 (- l1 i1))
|
||
(n2 (- l2 i2)))
|
||
(declare (fixnum n1 n2))
|
||
(if (< n1 n2)
|
||
(setq cnt n1)
|
||
(setq cnt n2))
|
||
(setq cntp 'T)))
|
||
((< l1 cnt) (setq cnt l1))))
|
||
('T ;;Create output sequence, if not supplied; default type
|
||
;; of output to that of primary "sequence" argument.
|
||
(if (null cntp) (setq cnt (- l2 i2)))
|
||
(setq ty1p (cond ((null coercion?) ty2p)
|
||
((cdr (assq coercion? '((LIST . 0)
|
||
(STRING . 3)
|
||
(VECTOR . 1)
|
||
(EXTEND . 2)
|
||
(BITS . 4)))))
|
||
(5)))
|
||
(if (and (= ty1p ty2p) (= i2 0) (= cnt l2) )
|
||
(return str))
|
||
(setq new (caseq ty1p
|
||
(0 (make-list cnt)) ;LIST
|
||
(3 (make-string cnt)) ;STRING
|
||
(1 (make-vector cnt)) ;VECTOR
|
||
(4 (make-bits cnt)) ;BITS
|
||
(2 (si:make-extend cnt (si:extend-class-of str)))
|
||
(T (+internal-lossage '|Not yet coded| 'SI:REPLACER () ))))))
|
||
;; Use fast code on string-to-string movement; also for bits-to-bits
|
||
(cond ((and (= ty1p ty2p)
|
||
(or (= ty1p 4) ;BITS
|
||
#-Lispm (= ty1p 3) ) ;STRING
|
||
)
|
||
(return
|
||
(let (*RSET)
|
||
(caseq ty2p
|
||
(3 (string-replace new str i1 i2 cnt))
|
||
;(1 (vector-replace new str i1 i2 cnt)) ??
|
||
(4 (bits-replace new str i1 i2 cnt)) )))))
|
||
(and (= ty2p 0) (setq str (nthcdr i2 str))) ;LIST case
|
||
;; Loop to move from one to the other, coercing each item as you go
|
||
(let ((fwp 1) (ix1 i1) (ix2 i2) item
|
||
(newl (and (= ty1p 0) (nthcdr i1 new))))
|
||
(declare (fixnum ix1 ix2 fwp))
|
||
;;May have to move in the backwards direction, from the top,
|
||
;; if the fields overlap.
|
||
(cond ((and (eq new str)
|
||
(< ix2 ix1)
|
||
(>= (+ ix2 cnt) ix1))
|
||
(if (= ty2p 0) ;LIST case
|
||
(+internal-lossage "LIST-REPLACEing over self" 'SI:REPLACER () ))
|
||
(setq ix1 (+ ix1 cnt -1) ix2 (+ ix2 cnt -1))
|
||
(setq fwp -1)))
|
||
(do ((n 0 (1+ n)))
|
||
((>= n cnt))
|
||
(declare (fixnum n))
|
||
(setq item (caseq ty2p
|
||
(3 (+internal-char-n str ix2))
|
||
(1 (vref str ix2))
|
||
(2 (si:xref str ix2))
|
||
(0 (pop str))
|
||
(4 (bit str ix2))
|
||
(T (elt str ix2))))
|
||
(caseq ty1p
|
||
(3 (+internal-rplachar-n new
|
||
ix1
|
||
(to-character-n item)))
|
||
(1 (vset new ix1 item))
|
||
(0 (rplaca newl item) (pop newl))
|
||
(4 (rplacbit new ix1 (to-bit item)))
|
||
(2 (si:xset new ix1 item))
|
||
(T (setelt str ix1)))
|
||
(setq ix1 (+ ix1 fwp) ix2 (+ ix2 fwp))))
|
||
(return new))))
|
||
|
||
|
||
;;;; TO-SYMBOL, TO-BIT, TO-UPCASE
|
||
|
||
(defun TO-SYMBOL (x)
|
||
(cond ((symbolp x) x)
|
||
((si:symbol-cons (to-string x)))))
|
||
|
||
(defun TO-BIT (x)
|
||
(prog (y)
|
||
B (setq y x)
|
||
A (typecaseq y
|
||
(FIXNUM (and (>= y 0) (return (boole 1 1 y))))
|
||
(STRING (and (= 1 (string-length y))
|
||
(setq y (+internal-char-n y 0))
|
||
(go A)))
|
||
(CHARACTER (setq y (*:character-to-fixnum y))
|
||
(and (and (<= #/0 y) (<= y #/1))
|
||
(return (boole 1 1 y))))
|
||
(SYMBOL (setq y (*:fixnum-to-character (getcharn y 1)))
|
||
(go A))
|
||
(T () ))
|
||
(setq x (cerror 'T () ':WRONG-TYPE-ARGUMENT
|
||
SI:COERCION-ERROR-STRING 'BIT y))
|
||
(go B)))
|
||
|
||
|
||
|
||
(defun TO-UPCASE (x)
|
||
(typecaseq x
|
||
(FIXNUM (char-upcase x))
|
||
(CHARACTER
|
||
(*:fixnum-to-character (char-upcase (*:character-to-fixnum x))))
|
||
(STRING (string-upcase x))
|
||
(SYMBOL (to-symbol (string-upcase (to-string x))))
|
||
(PAIR (mapcar #'TO-UPCASE x))
|
||
(VECTOR (let ((ln (vector-length x)))
|
||
(do ((i (1- ln) (1- i))
|
||
(new (make-vector ln)))
|
||
((< i 0) new)
|
||
(vset new i (to-upcase (vref x i))))))
|
||
(T (to-upcase
|
||
(cerror 'T () ':WRONG-TYPE-ARGUMENT SI:COERCION-ERROR-STRING
|
||
'UPPER-CASE-OBJECT x)))))
|
||
|
||
|
||
#M
|
||
(progn 'compile
|
||
(and (not (fboundp 'MAKE-LIST))
|
||
(putprop 'MAKE-LIST
|
||
'(lambda (n) (do ((i n (1- i)) (z () (cons () z)))
|
||
((< i 1) z)))
|
||
'EXPR))
|
||
(mapc '(lambda (x) (or (fboundp (car x))
|
||
(get (car x) 'AUTOLOAD)
|
||
(putprop (car x) (cadr x) 'AUTOLOAD)))
|
||
'((PTR-TYPEP #.(autoload-filename EXTEND))
|
||
(MAKE-VECTOR #.(autoload-filename VECTOR))
|
||
(MAKE-STRING #.(autoload-filename STRING))
|
||
(GET-PNAME #.(autoload-filename STRING))
|
||
(STRING-REPLACE #.(autoload-filename STRING))
|
||
(+INTERNAL-RPLACHAR-N #.(autoload-filename STRING))
|
||
(MAKE-BITS #.(autoload-filename BITS))
|
||
(RPLACBIT #.(autoload-filename BITS))
|
||
(BITS-REPLACE #.(autoload-filename BITS))))
|
||
)
|