mirror of
https://github.com/PDP-10/its.git
synced 2026-03-01 17:47:32 +00:00
302 lines
9.0 KiB
Common Lisp
Executable File
302 lines
9.0 KiB
Common Lisp
Executable File
;;; THREAD -*-Mode:Lisp;Package:SI;Lowercase:T-*-
|
||
;;; **************************************************************************
|
||
;;; ***** MACLISP ****** THREADed list structure functions *******************
|
||
;;; **************************************************************************
|
||
;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
|
||
;;; **************************************************************************
|
||
|
||
(herald THREAD /8)
|
||
|
||
;;;THREADs are two-way lists; each cell has a 'car', 'cdr', and 'uncdr'.
|
||
;;;Accessing functions are respectively called THREAD-car, THREAD-cdr, and
|
||
;;; THREAD-uncdr. THREAD-cons takes three args: the 'car', the 'cdr', and
|
||
;;; the 'uncdr'.
|
||
;;;Normal case is to implement them as DEFVST structures, and use the
|
||
;;; pre-defined printing methods; otherwise, then each THREAD cell is a
|
||
;;; list like `(,car (,uncdr . ,cdr) ,. SI:THREAD-MARKER), which of course
|
||
;;; could cause circularity when printed.
|
||
|
||
|
||
(eval-when (eval compile)
|
||
(or (get 'SUBLOAD 'VERSION)
|
||
(load '((lisp) subload)))
|
||
)
|
||
(eval-when (eval compile)
|
||
(subload SHARPCONDITIONALS)
|
||
)
|
||
|
||
|
||
#+(local MacLISP)
|
||
(eval-when (eval compile)
|
||
(subload MACAID)
|
||
(subload UMLMAC)
|
||
)
|
||
|
||
#+(or LISPM (and NIL (not MacLISP)))
|
||
(progn (globalize "THREADP")
|
||
(globalize "THREAD-CONS")
|
||
(globalize "THREAD-CAR")
|
||
(globalize "THREAD-CDR")
|
||
(globalize "THREAD-UNCDR")
|
||
(globalize "THREAD-RPLACA")
|
||
(globalize "THREAD-RPLACD")
|
||
(globalize "THREAD-RPLACU")
|
||
|
||
(globalize "THREAD-LAST")
|
||
(globalize "THREAD-FIRST")
|
||
|
||
(globalize "THREAD-LENGTH")
|
||
(globalize "THREAD-LENGTH-CDRING")
|
||
(globalize "THREAD-LENGTH-UNCDRING")
|
||
|
||
(globalize "THREAD-RECLAIM")
|
||
(globalize "THREAD-RECLAIM-CDRING")
|
||
(globalize "THREAD-RECLAIM-UNCDRING")
|
||
(globalize "THREAD-RECLAIM-1")
|
||
)
|
||
|
||
|
||
|
||
|
||
;;;; Structures, Vars, etc.
|
||
|
||
(eval-when (eval compile)
|
||
(set-feature-query-mode 'TARGET () )
|
||
(if (featurep 'Minimal) (setq defmacro-for-compiling () ))
|
||
(if (and (or (featurep 'Minimal)
|
||
(and (fboundp 'DEFSTRUCT) (not (get 'DEFVST 'VERSION))))
|
||
(nofeaturep 'Using-DEFVST))
|
||
(set-nofeature 'Using-DEFVST)
|
||
(set-feature 'Using-DEFVST))
|
||
)
|
||
|
||
|
||
;; DEFVST will just ignore the ":type" option in the namelist
|
||
|
||
;; THREAD is a 'Two-WAy List structure', for moving forwards and backwards
|
||
|
||
#+Using-DEFVST (progn 'compile
|
||
(defvst THREAD CAR LINKS)
|
||
(defbothmacro THREADP (x) `(EQ (STRUCT-TYPEP ,x) 'THREAD))
|
||
(defun THREAD-rplaca (x y)
|
||
(and *RSET (not (threadp x)) (check-type x #'THREAD 'THREAD-rplaca))
|
||
(setf (THREAD-car x) y)
|
||
x)
|
||
)
|
||
|
||
|
||
#-Using-DEFVST (progn 'compile
|
||
|
||
(eval-when (eval load compile)
|
||
(defconst SI:THREAD-MARKER (list 'THREAD))
|
||
)
|
||
|
||
(defmacro cons-a-THREAD (&whole form)
|
||
(let ((acar (get form 'CAR))
|
||
(links (get form 'LINKS)))
|
||
`(LIST* ,acar ,links SI:THREAD-MARKER)))
|
||
(defmacro THREAD-links (x) `(CADR ,x))
|
||
(defbothmacro THREAD-car (x) `(CAR ,x))
|
||
(defbothmacro THREAD-rplaca (x y) `(RPLACA ,x ,y))
|
||
(defun THREADP (x)
|
||
(and (not (atom x))
|
||
(not (atom (cdr x)))
|
||
(eq (cddr x) SI:THREAD-MARKER)))
|
||
)
|
||
|
||
|
||
(defmacro THREAD-linkscdr (links)
|
||
`(CDR ,links))
|
||
(defmacro THREAD-linksuncdr (links)
|
||
`(CAR ,links))
|
||
|
||
(defmacro cons-a-THREAD-links (&whole form)
|
||
(let ((acdr (get form 'CDR))
|
||
(uncdr (get form 'UNCDR)))
|
||
`(CONS ,uncdr ,acdr)))
|
||
|
||
|
||
(defbothmacro THREAD-cdr (th)
|
||
`(THREAD-linkscdr (THREAD-links ,th)))
|
||
(defbothmacro THREAD-uncdr (th)
|
||
`(THREAD-linksuncdr (THREAD-links ,th)))
|
||
|
||
|
||
(defun THREAD-rplacd (x y)
|
||
(and *RSET (not (threadp x)) (check-type x #'THREAD 'THREAD-rplacd))
|
||
(setf (THREAD-cdr x) y)
|
||
x)
|
||
|
||
(defun THREAD-rplacu (x y)
|
||
(and *RSET (not (threadp x)) (check-type x #'THREAD 'THREAD-rplacu))
|
||
(setf (THREAD-uncdr x) y)
|
||
x)
|
||
|
||
|
||
(defvar SI:THREAD-FREELIST ()
|
||
"Chained thru CAR link of free struct cells.")
|
||
|
||
|
||
|
||
(defun THREAD-cons (tcar tcdr tuncdr &aux cell)
|
||
(without-interrupts
|
||
(cond ((setq cell SI:THREAD-FREELIST)
|
||
(setq SI:THREAD-FREELIST (thread-car cell))
|
||
(setf (thread-car cell) tcar))))
|
||
(cond (cell
|
||
(let ((links (THREAD-links cell)))
|
||
(setf (THREAD-linkscdr links) tcdr)
|
||
(setf (THREAD-linksuncdr links) tuncdr))
|
||
cell)
|
||
('T (cons-a-THREAD CAR tcar
|
||
LINKS (cons-a-THREAD-links CDR tcdr
|
||
UNCDR tuncdr)))))
|
||
|
||
|
||
(defun THREAD-first (cell)
|
||
(si:THREAD-move cell 1_20. '(() T () ) 'THREAD-first *RSET))
|
||
(defun THREAD-last (cell)
|
||
(si:THREAD-move cell 1_20. '(T T () ) 'THREAD-last *RSET))
|
||
(defun THREAD-LENGTH-cdring (cell)
|
||
(si:THREAD-move cell 1_20. '(T () T) 'THREAD-cdring *RSET))
|
||
(defun THREAD-LENGTH-uncdring (cell)
|
||
(si:THREAD-move cell 1_20. '(() () T) 'THREAD-uncdring *RSET))
|
||
(defun THREAD-LENGTH (cell)
|
||
(if (null cell)
|
||
0
|
||
(+ (thread-length-uncdring cell)
|
||
;; Following is basically 'thread-length-cdring', but no errors
|
||
(si:THREAD-move cell 1_20. '(T () T) 'THREAD-cdring () )
|
||
-1)))
|
||
|
||
|
||
(defun si:THREAD-move (original-cell no-moves foo fun checkp)
|
||
"Do either CDRing or UNCDRing until either 'no-moves' moves are made,
|
||
or until hitting the end of the thread. Then return either the last
|
||
(or first) cell, or return the total number of moves made."
|
||
(let (((cdrp previousp countp) foo)
|
||
(circularity-limit #.(if (boundp 'SI:NON-CIRCULAR-DEPTH-LIMIT)
|
||
SI:NON-CIRCULAR-DEPTH-LIMIT
|
||
100000.)))
|
||
(cond (checkp (or (null original-cell)
|
||
(threadp original-cell)
|
||
(check-type original-cell #'THREADP fun))
|
||
(check-type no-moves #'FIXNUMP fun)))
|
||
(do ((i 0 (1+ i))
|
||
(cell original-cell (if cdrp (THREAD-cdr cell) (THREAD-uncdr cell)))
|
||
(previous original-cell cell)
|
||
(n no-moves))
|
||
((or (null cell) (>= i n))
|
||
(if (and (not (threadp previous))
|
||
(or previous (not (= i 0))))
|
||
(+internal-lossage 'NULL 'THREAD-move (maknum original-cell)))
|
||
(if countp i (if previousp previous cell)))
|
||
(declare (fixnum n))
|
||
(if (> i circularity-limit)
|
||
#+NIL (setq circularity-limit
|
||
(si:circularity-error fun (list original-cell)))
|
||
#-NIL (error "Circular THREAD at this address" (maknum original-cell))
|
||
))))
|
||
|
||
|
||
;;;; THREAD reclaimers and LENGTHers
|
||
|
||
(defsimplemac si:THREAD-reclaim-1-f (cell)
|
||
(let ((tmp (si:gen-local-var () )))
|
||
`((LAMBDA (,tmp)
|
||
(SETF (THREAD-linkscdr ,tmp) () )
|
||
(SETF (THREAD-linksuncdr ,tmp) () )
|
||
(SETF (THREAD-car ,cell) SI:THREAD-FREELIST)
|
||
(SETQ SI:THREAD-FREELIST ,cell)
|
||
() )
|
||
(THREAD-links ,cell))))
|
||
|
||
(defun THREAD-reclaim-1 (cell)
|
||
"User-level fun to reclaim one cell. Probably seldom used."
|
||
(and *RSET
|
||
(not (threadp cell))
|
||
(check-type cell #'THREADP 'THREAD-reclaim-1))
|
||
(without-interrupts
|
||
(let ((prev (thread-uncdr cell))
|
||
(next (thread-cdr cell)))
|
||
(si:THREAD-reclaim-1-f cell)
|
||
(if prev (setf (thread-cdr prev) () ))
|
||
(if next (setf (thread-cdr next) () ))))
|
||
() )
|
||
|
||
|
||
(defun THREAD-reclaim-cdring (cell)
|
||
"Reclaim all cells in the CDR-chain of this thread."
|
||
(si:THREAD-reclaim-moving cell 'T 'THREAD-reclaim-cdring))
|
||
|
||
(defun THREAD-reclaim-uncdring (cell)
|
||
"Reclaim all cells in the UNCDR-chain of this thread."
|
||
(si:THREAD-reclaim-moving cell () 'THREAD-reclaim-uncdring))
|
||
|
||
|
||
(defun THREAD-reclaim (cell)
|
||
"Reclaim all cells of this thread."
|
||
(let ((more (and (threadp cell) (thread-uncdr cell))))
|
||
(si:THREAD-reclaim-moving cell 'T 'THREAD-reclaim)
|
||
(and more
|
||
(si:THREAD-reclaim-moving more () 'THREAD-reclaim))))
|
||
|
||
|
||
(defun si:THREAD-reclaim-moving (cell cdrp fun)
|
||
(and *RSET
|
||
(not (threadp cell))
|
||
(check-type cell #'THREADP fun))
|
||
(let (tem)
|
||
;First, disconnect any cell which may point to this one which
|
||
; is the firstt in a chain to be reclaimed.
|
||
(cond (cdrp
|
||
(if (setq tem (thread-uncdr cell))
|
||
(setf (thread-uncdr tem) () )))
|
||
((if (setq tem (thread-cdr cell))
|
||
(setf (thread-cdr tem) () )))))
|
||
(do ()
|
||
((null cell) )
|
||
;; Interrupts locked out, but permit them 'every once in a while'.
|
||
(without-interrupts
|
||
(do ((i 256. (1- i)))
|
||
((or (null cell) (<= i 0)) )
|
||
(setq cell (prog1 (if cdrp (THREAD-cdr cell) (THREAD-uncdr cell))
|
||
(si:THREAD-reclaim-1-f cell))))))
|
||
() )
|
||
|
||
|
||
|
||
|
||
;;;; :PRINT-SELF method
|
||
|
||
#+Using-DEFVST
|
||
(defmethod* (:PRINT-SELF THREAD-CLASS) (ob stream depth slashifyp)
|
||
(declare (fixnum depth))
|
||
(setq depth (1+ depth))
|
||
(if (and PRINLEVEL (not (< depth PRINLEVEL)))
|
||
(princ SI:PRINLEVEL-EXCESS stream)
|
||
(let ((printer (if slashifyp #'PRIN1 #'PRINC)))
|
||
(princ "#{THREAD" stream)
|
||
(do ((curr (THREAD-first ob) (THREAD-cdr curr))
|
||
(n (or PRINLENGTH 100000.) (1- n)))
|
||
((cond ((or (eq curr ob) (null curr)))
|
||
((<= n 0)
|
||
(princ " " stream)
|
||
(princ SI:PRINLENGTH-EXCESS stream)
|
||
'T)) )
|
||
(declare (fixnum n))
|
||
(princ " " stream)
|
||
(funcall printer (THREAD-car curr) stream))
|
||
(princ " $$" stream)
|
||
(do ((curr ob (THREAD-cdr curr))
|
||
(n (or PRINLENGTH 100000.) (1- n)))
|
||
((cond ((null curr))
|
||
((<= n 0)
|
||
(princ " " stream)
|
||
(princ SI:PRINLENGTH-EXCESS stream)
|
||
'T)) )
|
||
(declare (fixnum n))
|
||
(princ " " stream)
|
||
(funcall printer (THREAD-car curr) stream))
|
||
(princ "}" stream))))
|