github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-04-28 12:57:56 +00:00
Code Issues Releases Wiki Activity

Added lots of lisp libraries, most of them built from source.

Browse Source 
This partially completes #251.
This commit is contained in:
Eric Swenson
2016-12-22 17:32:56 -08:00
parent 98b16d595b
commit 4871f2a8b7
43 changed files with 13369 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

243
src/nilcom/drammp.19 Executable file
View File

@@ -0,0 +1,243 @@
;;; DRAMMP -*-LISP-*-
;;; **************************************************************
;;; *** NIL *** Del, Rem, Ass, Mem, and Pos type functions *******
;;; **************************************************************
;;; ** (C) Copyright 1981 Massachusetts Institute of Technology **
;;; ****** This is a Read-Only file! (All writes reserved) *******
;;; **************************************************************
(herald DRAMMP /19)
#-NIL (include ((lisp) subload lsp))
#-NIL (eval-when (eval compile)
(subload SHARPCONDITIONALS))
#+(local MacLISP)
(eval-when (eval compile)
(subload MACAID)
;; Remember, EXTMAC down-loads CERROR
(subload EXTMAC)
(subload EXTEND)
(subload VECTOR)
(subload SUBSEQ)
(if (fboundp 'OWN-SYMBOL) (own-symbol LENGTH NREVERSE))
)
(defun si:GET-PRIMITIVE-SEQUENCE (z fun &optional Q-seq-p &aux type)
"Ascertain whether the 1st arg is a primitive sequence, [or Q-sequence,
if 'Q-seq-p' is non-()], and signal a correctable error if not. Returns
the possibly-corrected value, and the general type."
(do ()
((setq type (typecaseq z
(PAIR 'LIST)
(VECTOR 'VECTOR)
(STRING (if (null Q-seq-p) 'STRING))
(BITS (if (null Q-seq-p) 'BITS))
(T (if (null z) 'LIST)))))
(setq z (cerror #T () ':WRONG-TYPE-ARGUMENT
"~1G~S is not a ~:[~;Q-~]sequence -- ~S"
() z Q-seq-p fun)))
(values z type))
(defvar SI:NON-CIRCULAR-DEPTH-LIMIT 100000.)
;;;; SI:DRAMMP
(defun SI:DRAMMP (x oseq funname vecp pred access ret-type
&optional (starti 0) (cntr SI:NON-CIRCULAR-DEPTH-LIMIT cntrp))
(if (null oseq)
()
(let ((seq oseq)
(typx (ptr-typep x))
(typs (typecaseq oseq
(PAIR 'PAIR)
((VECTOR VECTOR-S) (and vecp 'VECTOR)))))
(if (null typs)
(multiple-value
(seq typs)
(si:get-primitive-sequence seq (car funname) #T)))
(cond
((and (null cntrp)
(eq pred 'EQUAL)
#-NIL (eq typs 'PAIR)
(eq-for-equal? x))
(caseq (cdr funname)
(MEM (memq x seq))
(ASS (assq x seq))
(DEL (delq x seq))
(RASS (rassq x seq))
(DELASS (delassq x seq))
(MEMASS (memassq x seq))
(POSASS (posassq x seq))
(POSMEM (posq x seq))))
( (prog (item i n lvec slot delp back-slot del-scanner posp pairp)
(declare (fixnum i n))
(setq i (1- starti) n (1+ cntr))
(caseq ret-type
(DEL (setq delp #T del-scanner seq))
(POS (setq posp #T)))
(cond ((eq typs 'PAIR) (setq pairp #T))
(#T (setq lvec (vector-length seq))))
A (cond
((not (< (setq n (1- n)) 0)))
((null cntrp)
(setq n (si:circularity-error (car funname) (list seq))))
(#T (setq seq () lvec (- SI:NON-CIRCULAR-DEPTH-LIMIT))))
(cond ((eq typs 'PAIR)
(cond (delp
(if (null seq)
(return del-scanner)))
(#T (or seq (return () ))
(and posp (setq i (1+ i)))))
(setq slot (car seq)))
(#T (setq i (1+ i))
(or (< i lvec) (return () ))
(setq slot (vref seq i))))
;Access the relevant item from the sequence
(cond ((eq access 'CAR) (setq item slot))
((atom slot) (go b))
((setq item (if (eq access 'CDAR)
(cdr slot)
(car slot)))))
;Calculate the "equivalence"
(cond ((cond ((eq x item))
((not (eq pred 'EQUAL))
(if (eq pred 'EQ)
()
(funcall pred x item)))
((not (eq (ptr-typep item) typx)) () )
((caseq typx
(STRING (null (string-mismatchq x item)))
(FIXNUM (= x item))
(FLONUM (=$ x item))
(T (EQUAL x item)))))
(cond (delp
(if (null back-slot)
(setq del-scanner (cdr del-scanner))
;;'seq' should be eq to (cdr back-slot)
(rplacd back-slot (cdr seq)))
(setq seq (cdr seq))
(go A))
(#T (return (caseq ret-type
(ASS slot)
(MEM seq)
(POS i)))))))
B (if delp (setq back-slot seq))
(if pairp (setq seq (cdr seq)))
(go A)))))))
(eval-when (eval compile)
(setq defmacro-for-compiling () )
)
(defmacro GEN-DRAMMP/| (&rest form &aux name vecp access ret-type ans stnnm)
`(PROGN
'COMPILE
,.(mapcan
#'(lambda (x)
(desetq (funname vecp access ret-type) x)
;; First comes the generalized function, like ASS and MEM.
(setq
ans
`((DEFUN ,(cdr funname)
(PRED ITEM SEQ &OPTIONAL (START 0)
(CNT SI:NON-CIRCULAR-DEPTH-LIMIT))
(SI:DRAMMP ITEM
SEQ
'(,(cdr funname) . ,(cdr funname))
',vecp
PRED
',access
',ret-type
START
CNT))))
;;Then if permitted comes the one with EQUAL testing
(cond
((car funname)
(setq stnnm (gentemp))
(setq ans
(nconc
`((DEFUN ,(car funname)
(ITEM SEQ &OPTIONAL (START 0)
(CNT SI:NON-CIRCULAR-DEPTH-LIMIT))
(SI:DRAMMP ITEM
SEQ
',funname
',vecp
'EQUAL
',access
',ret-type
START
CNT))
(DEFUN ,stnnm (X)
(LET (((() ITEM SEQ . MORE) X))
(VALUES
`(SI:DRAMMP ,ITEM ;"item"
,SEQ ;"sequence"
',',funname
',',vecp
'EQUAL
',',access
',',ret-type
,.MORE ;possibly &optinals
)
#T)))
(PUSH ',stnnm (GET ',(car funname) 'SOURCE-TRANS)))
ans)))))
form)))
(eval-when (eval compile)
(setq defmacro-for-compiling #T defmacro-displace-call MACROEXPANDED)
)
(gen-drammp/| (( RASSOC . RASS) T CDAR ASS)
((#-MacLISP ASSOC #M () . ASS) T CAAR ASS)
((#-MacLISP DELETE #M () . DEL) () CAR DEL)
((#-MacLISP MEMBER #M () . MEM) () CAR MEM)
(( DELASSOC . DELASS) () CAAR DEL)
(( MEMASSOC . MEMASS) () CAAR MEM)
(( POSASSOC . POSASS) T CAAR POS)
(( POSMEMBER . POSMEM) T CAR POS) )
#M (progn 'compile
(defun RASSQ (x ll)
(if *RSET (check-type ll #'LISTP 'RASSQ))
(do ((l ll (cdr l)) (e))
((null l) () )
(and (pairp (setq e (car l)))
(eq x (cdr e))
(return e))))
(defun POSASSQ (x seq)
(if (null seq)
()
(typecaseq seq
(PAIR (do ((l seq (cdr l)) (e) (i 0 (1+ i)))
((null l) () )
(declare (fixnum i))
(and (pairp (setq e (car l)))
(eq x (car e))
(return i))))
;; VECTOR-POSASSQ comes in the VECTOR file for MacLISP
((VECTOR VECTOR-S) (VECTOR-POSASSQ x seq))
(T (multiple-value (seq) (si:get-primitive-sequence seq 'POSASSQ #T))
(posassq x seq)))))
(defun MEMASSQ (x ll)
(if *RSET (check-type ll #'LISTP 'MEMASSQ))
(cond ((null ll) () )
((null (setq x (assq x ll))) () )
((memq x ll))))
)

77
src/nilcom/lsets.7 Executable file
View File

@@ -0,0 +1,77 @@
;;; LSETS -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; *************************************************************************
;;; ***** NIL/MACLISP ****** SET Operations on Lists ************************
;;; *************************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *************
;;; *************************************************************************
(herald LSETS /7)
;;; Utility operations on sets:
;;; ADJOIN, UNION, INTERSECTION, SETDIFF, SETREMQ
;;; Where possible, preserve the ordering of elements.
#-NIL (include ((lisp) subload lsp))
#-NIL
(eval-when (eval compile)
(subload SHARPCONDITIONALS)
(subload LOOP)
(subload UMLMAC)
)
#+(or LISPM (and NIL (not MacLISP)))
(progn (globalize "ADJOIN")
(globalize "SETDIFF")
(globalize "UNION")
(globalize "INTERSECTION")
(globalize "SETREMQ")
)
(defun ADJOIN (x s)
"Add an element X to a set S."
(if (memq x s)
s
(cons x s)))
(defun SI:Y-X+Z (y x z &aux y-x)
"Append the set-difference Y-X to Z"
(mapc #'(lambda (xx) (or (memq xx x) (push xx y-x))) y)
(nreconc y-x z))
(defun SETDIFF (x y)
"Set difference: all in X but not in Y."
(if (LOOP FOR xx IN y THEREIS (memq xx x))
(SI:Y-X+Z x y () )
x))
(defun UNION (x y)
"Union of two sets."
(if (< (length x) (length y)) ;Interchange X and Y if that will
(psetq x y y x)) ; lead to less CONSing
(si:y-x+z y x x))
(defun INTERSECTION (x y)
"Intersection of two sets."
(LOOP FOR xx IN x
WHEN (memq xx y) COLLECT xx))
(defun SETREMQ (x s)
"Remove an element X from a set S, non-destructively."
(when (LOOP UNTIL (null s)
WHEN (eq x (car s)) DO (return 'T)
DO (pop s))
;;Strip off any leading losers; Fall thru to return () if
;; whole list is "leading losers"
(if (not (memq x s))
s
;; If there are 'interior' losers, the copy remainder of list
;; but omitting elements EQ to the element X.
(LOOP FOR y IN s
UNLESS (eq y x) COLLECT y))))

117
src/nilcom/sharpa.40 Executable file
View File

@@ -0,0 +1,117 @@
;;; SHARPA -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; **************************************************************************
;;; **** NIL ** NIL/MACLISP/LISPM Compatible # Macro Auxiliary **************
;;; **************************************************************************
;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
;;; ************ this is a read-only file! (all writes reserved) *************
;;; **************************************************************************
#-LISPM
(herald SHARPAUX /40)
;; temporary, this MUST be usuable in the LISPM for MACSYMA! -gjc
#Q (defprop SHARPAUX (macro) mc:macsyma-module)
(eval-when (eval compile)
(if (and (fboundp 'DEFSTRUCT)
(not (get 'DEFVST 'VERSION)))
()
(defmacro DEFSTRUCT (&rest w) `(DEFVST ,.w)))
)
(defstruct (FEATURE-SET :conc-name (:constructor cons-a-feature-set) :named)
target features nofeatures query-mode superiors)
(defprop FEATURE-SET
(FEATURES NOFEATURES QUERY-MODE)
SUPPRESSED-COMPONENT-NAMES)
(defmacro DEF-FEATURE-SET (target &rest options)
(do ((l options (cddr l)))
((null l))
(or (memq (car l) '(:QUERY-MODE :FEATURES :NOFEATURES :SUPERIORS))
(error "Bad option in options list - DEF-FEATURE-SET" (car l))))
(setq options (cons 'DEF-FEATURE-SET options))
(let ((query-mode (if (getl options '(:QUERY-MODE))
(get options ':QUERY-MODE)
':QUERY))
(features (get options ':FEATURES))
(nofeatures (get options ':NOFEATURES))
(superiors (get options ':SUPERIORS)))
(check-type query-mode
#'si:query-mode-keyword
'DEF-FEATURE-SET)
(check-type target #'SYMBOLP 'DEF-FEATURE-SET)
(check-type features #'LISTP 'DEF-FEATURE-SET)
(check-type nofeatures #'LISTP 'DEF-FEATURE-SET)
(check-type superiors #'LISTP 'DEF-FEATURE-SET)
`(PROGN 'COMPILE
(PUTPROP ',target
(cons-a-FEATURE-SET TARGET ',target
FEATURES ',features
NOFEATURES ',nofeatures
QUERY-MODE ',query-mode
SUPERIORS ',superiors )
'FEATURE-SET)
(SETQ FEATURE-NAMES (CONS ',target (DELQ ',target FEATURE-NAMES)))
',target)))
(defun SI:QUERY-MODE-KEYWORD (query-mode)
(memq query-mode '(:QUERY :ERROR T () )))
(defmacro DEF-EQUIVALENCE-FEATURE-SET (name to)
"Define a feature set name to be equivalent to an existing name"
(check-type name #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
(check-type to #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
(let ((equiv-var (symbolconc 'FEATURE-SET '- name '= to)))
`(PROGN
(SETQ ,equiv-var ',to)
(DEF-INDIRECT-FEATURE-SET ,name ,equiv-var))))
(defmacro DEF-INDIRECT-FEATURE-SET (name to)
"Define a feature set name to indirect through the value of a variable"
(check-type name #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
(check-type to #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
`(PROGN (PUTPROP ',name
',to
'FEATURE-SET)
(SETQ FEATURE-NAMES (CONS ',name (DELQ ',name FEATURE-NAMES)))
',name))
;;; (WHEN-FEATURE ;; (WHEN-FEATURES
;;; (featurespec1 . clause1) ;; (featurespec1 . clause1)
;;; (featurespec2 . clause2) ;; (featurespec2 . clause2)
;;; (featurespec3 . clause3) ...) ;; (featurespec3 . clause3) ...)
;;; ;;
;;; Executes the first clause which ;; Executes all clauses which
;;; corresponds to a feature match. ;; corresponds to a feature match.
;;;
;;; Feature match specs are designated by the following types of forms:
;;;
;;; T - always
;;; symbol - feature name
;;; (OR spec1 spec2 ...) - spec disjunction
;;; (AND spec1 spec2 ...) - spec conjunction
;;; (NOT spec) - spec negation
(defmacro WHEN-FEATURE (&rest clauses)
`(COND ,@(mapcar #'(lambda (x)
`(,(if (eq (car x) 'T)
'T
`(FEATUREP ',(car x)))
,@(cdr x)))
clauses)))
(defmacro WHEN-FEATURES (&rest clauses)
`(PROGN ,@(mapcar #'(lambda (x)
`(COND (,(if (eq (car x) 'T)
'T
`(FEATUREP ',(car x)))
,@(cdr x))))
clauses)))

338
src/nilcom/sharpc.74 Executable file
View File

@@ -0,0 +1,338 @@
;;; SHARPC -*-mode:lisp;package:si;lowercase:T-*- -*-LISP-*-
;;; **************************************************************************
;;; ***** NIL ****** NIL/MACLISP/LISPM # Conditionalizations ****************
;;; **************************************************************************
;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
;;; ************ this is a read-only file! (all writes reserved) *************
;;; **************************************************************************
;;;; FEATUREP and Sharpsign conditionalization.
#M (include ((lisp) subload lsp))
(herald SHARPCONDITIONALS /74)
(defvar FEATURE-NAMES ()
"A list of all names representing feature sets currently defined.")
(defvar TARGET-FEATURES 'LOCAL
"Features to assume objects read are for.")
(defvar MACROEXPAND-FEATURES 'TARGET
"Features to assume when macroexpanding.")
(defvar SI:FEATUREP? ()
"Used to communicate caller's function name to function SI:FEATUREP?")
#M (progn 'compile
(eval-when (eval compile load)
(if (fboundp '*LEXPR) (*lexpr FEATUREP SET-FEATURE))
(if (fboundp '*EXPR) (*expr SI:FEATUREP?))
)
(eval-when (eval compile)
(subload ERRCK)
(subload LOOP)
(subload UMLMAC)
(subload DEFVST)
(subload SHARPAUX))
(def-or-autoloadable DEF-FEATURE-SET SHARPA)
(def-or-autoloadable DEF-EQUIVALENCE-FEATURE-SET SHARPA)
(def-or-autoloadable DEF-INDIRECT-FEATURE-SET SHARPA)
(def-or-autoloadable WHEN-FEATURE SHARPA)
(def-or-autoloadable WHEN-FEATURES SHARPA)
(let ((x (get 'SHARPM 'VERSION))
(FASLOAD))
(cond ((or (null x) ;Not yet loaded, or
(alphalessp x '/75)) ;Obsolete version alread loaded
(LOAD (autoload-filename SHARPM)))))
#+(and PDP10 (not NIL))
(SSTATUS UUOLI)
(defvar QUERY-IO 'T
"Make sure this isn't unbound in MacLISP.")
) ;end of #M
(defun SI:FEATURE-SET-NAME-P (arg)
"Return the (non-null) feature set if arg is a feature set name."
(and (symbolp arg)
(get arg 'FEATURE-SET)))
(defun SI:GET-FEATURE-SET (feature-set-name using-fun)
"Returns the FEATURE-SET struct that this name refers to, following
indirections."
(do ((set (SI:feature-set-name-p feature-set-name)
(SI:feature-set-name-p feature-set-name)))
((not (null set))
(if (symbolp set)
(si:get-feature-set (symeval set) using-fun) ;Indirect set
set))
(setq feature-set-name
(cerror t () ':WRONG-TYPE-ARGUMENT
"~*~S, an arg to ~S, is not the name of a feature set."
'FEATURE-SET feature-set-name using-fun))))
(defun FEATUREP (feature &optional (feature-set-name TARGET-FEATURES)
&aux (SI:FEATUREP? 'FEATUREP))
"Returns non-() if the feature is known to be a feature in the
feature-set. Otherwise returns ()."
(SI:FEATUREP? feature
(si:get-feature-set feature-set-name 'FEATUREP)
'T))
(defun NOFEATUREP (feature &optional (feature-set-name TARGET-FEATURES)
&aux (SI:FEATUREP? 'NOFEATUREP))
"Returns non-() if the feature is known NOT to be a feature in the
feature-set. Otherwise returns ()."
(SI:FEATUREP? feature
(si:get-feature-set feature-set-name 'NOFEATUREP)
() ))
(defun SI:FEATUREP? (feature feature-set featurep)
"Return non-() if the feature is known to be a feature in the feature set.
Return () if it is known NOT to be a feature. Otherwise query, error, or
assume, depending on the query-mode of the feature-set. The 'featurep'
argument being () inverts the sense of the return value."
(cond ((atom feature) (si:featurep-symbol feature feature-set featurep))
((eq (car feature) 'NOT)
(si:featurep? (cadr feature) feature-set (not featurep)))
((eq (car feature) 'AND)
(si:feature-and (cdr feature) feature-set featurep))
((eq (car feature) 'OR)
(si:feature-or (cdr feature) feature-set featurep))
((SI:feature-set-name-p (car feature))
;; Programmable case -- a "feature" like (MUMBLE HOT) means
;; that "MUMBLE" should be the name of a feature set, and the
;; "HOT" feature should be in it. (MUMBLE HOT COLD) means that
;; both "HOT" and "COLD" should be in it, namely it is synonymous
;; with (MUMBLE (AND HOT COLD))
(si:feature-and (cdr feature)
(si:get-feature-set (car feature) 'SI:FEATUPREP?)
featurep))
('T (setq feature (cerror 'T () ':INCONSISTENT-ARGS
"~S is not a legal feature specification -- ~S"
(list feature)
SI:FEATUREP?))
(si:featurep? feature feature-set featurep))))
(defun SI:FEATURE-AND (feature-list feature-set featurep)
"FEATUREP for the (AND f1 f2 f3 ... fn) case of a feature-spec"
(if (loop for feature in feature-list
always (si:featurep? feature feature-set 'T))
featurep
(not featurep)))
(defun SI:FEATURE-OR (feature-list feature-set featurep)
"FEATUREP for the (OR f1 f2 ... fn) case of a feature-spec"
(if (loop for feature in feature-list
thereis (si:featurep? feature feature-set 'T))
featurep
(not featurep)))
(defun SI:FEATUREP-SYMBOL (feature feature-set featurep)
"FEATUREP for the symbol case of a feature-spec"
(struct-let (FEATURE-SET feature-set) (features nofeatures)
(or (and featurep
(memq feature features)
'T)
(and (not featurep)
(memq feature nofeatures)
'T)
;; A MACLISP compatibility crock
#M (when (and (eq (feature-set-target feature-set) 'LOCAL)
(memq feature (status FEATURES))
featurep)
(set-feature feature 'LOCAL) ;Uncrockify
'T)
(if (and (not (memq feature nofeatures))
(not (and (not featurep)
(memq feature features))))
(caseq (FEATURE-SET-query-mode feature-set)
(:QUERY
(if (y-or-n-p query-io
"~&Is ~A a feature in ~A"
feature
(FEATURE-SET-target feature-set))
(push feature (FEATURE-SET-features feature-set))
(push feature
(FEATURE-SET-nofeatures feature-set)))
(si:featurep? feature feature-set featurep))
(:ERROR
(FERROR ()
"~S is not a known feature in ~S"
feature
(FEATURE-SET-target feature-set)))
((T) featurep)
(T (not featurep) ))) ;Else assume nofeature
)))
(defun SET-FEATURE (feature &optional (feature-set-name TARGET-FEATURES))
"Say that a feature is a feature in the feature-set. FEATUREP will then
return non-() when called with that feature on that feature-set."
(si:feature-set-update feature feature-set-name 'T () 'SET-FEATURE))
(defun SET-NOFEATURE (feature &optional (feature-set-name TARGET-FEATURES))
"Say that a feature is NOT a feature in the feature set. FEATUREP will
return ()."
(si:feature-set-update feature feature-set-name () 'T 'SET-NOFEATURE))
(defun SET-FEATURE-UNKNOWN
(feature &optional (feature-set-name TARGET-FEATURES))
"Make a feature-name be unknown in a feature set."
(si:feature-set-update feature feature-set-name () () 'SET-FEATURE-UNKNOWN))
(defun SI:FEATURE-SET-UPDATE (feature feature-set-name featurep nofeaturep fun)
"Update the lists of known features and known non-features in a
'feature-set'."
(let ((feature-set (si:get-feature-set feature-set-name fun))
(noclobberp 'T))
(or (symbolp feature) (check-type feature #'SYMBOLP fun))
(struct-let (FEATURE-SET feature-set) (features nofeatures)
;; A MACLISP compatibility crock
#M (when (eq feature-set-name 'LOCAL)
(if featurep
(apply 'SSTATUS `(FEATURE ,feature))
(apply 'SSTATUS `(NOFEATURE ,feature))))
(when (not featurep)
(setq features (delq feature features) noclobberp () ))
(when (not nofeaturep)
(setq nofeatures (delq feature nofeatures) noclobberp () ))
(when (and featurep (not (memq feature features)))
(push feature features)
(setq noclobberp () ))
(when (and nofeaturep (not (memq feature nofeatures)))
(push feature nofeatures)
(setq noclobberp () ))
(when (not noclobberp)
(struct-setf (FEATURE-SET feature-set)
(features features)
(nofeatures nofeatures)))))
feature)
(defun SET-FEATURE-QUERY-MODE (feature-set-name mode)
"Set the feature-set's query-mode. :QUERY (the mode they're created in by
DEF-FEATURE-SET) means to ask about unknown features, :ERROR means signal
an error, T means assume it's a feature, () means to assume it's not."
(let ((feature-set (si:get-feature-set feature-set-name 'SET-FEATURE-QUERY-MODE)))
(or (si:feature-modep mode)
(check-type mode #'SI:FEATURE-MODEP 'SET-FEATURE-QUERY-MODE))
(setf (FEATURE-SET-query-mode feature-set) mode)))
(defun SI:FEATURE-MODEP (mode)
(memq mode '(:QUERY :ERROR T () )))
(defun COPY-FEATURE-SET (feature-set-name new)
"Build a new feature-set from a previously existing one, with same
features and non-features"
(let ((feature-set (si:get-feature-set feature-set-name 'COPY-FEATURE-SET)))
(or (symbolp new)
(check-type new #'SYMBOLP 'COPY-FEATURE-SET))
(putprop new
(cons-a-FEATURE-SET
TARGET new
FEATURES (append (FEATURE-SET-features feature-set) () )
NOFEATURES (append (FEATURE-SET-nofeatures feature-set) () )
QUERY-MODE (FEATURE-SET-query-mode feature-set))
'FEATURE-SET)
(setq FEATURE-NAMES (cons new (delq new FEATURE-NAMES)))
new))
(def-feature-set MACLISP
:FEATURES (MACLISP FOR-MACLISP HUNK SENDI BIGNUM FASLOAD PAGING ROMAN)
:NOFEATURES (NIL FOR-NIL LISPM FOR-LISPM FRANZ VAX UNIX VMS )
)
(def-feature-set LISPM
:FEATURES (LISPM FOR-LISPM BIGNUM PAGING STRING)
:NOFEATURES (MACLISP FOR-MACLISP NIL FOR-NIL FRANZ SFA NOLDMSG VECTOR
VAX UNIX VMS MULTICS PDP10 ITS TOPS-20 TOPS-10 )
)
(def-feature-set NIL
:FEATURES (NIL FOR-NIL BIGNUM PAGING SFA STRING VECTOR)
:NOFEATURES (MACLISP FOR-MACLISP LISPM FOR-LISPM FRANZ NOLDMSG )
)
;; The following must be done first, because STATUS FEATURE requires FEATUREP
;; in NIL.
(copy-feature-set
(cond ((or (fboundp 'LAPSETUP/|) (fboundp '|ItoC|))
;; or something MacLISP-specific
'MACLISP)
((fboundp 'SI:COMPARE-BAND) 'LISPM) ;or something LISPM-specific
('T 'NIL ))
'LOCAL)
;;Remember TARGET-FEATURES was set to 'LOCAL
#-NIL (progn 'COMPILE
;;The NILAID feature set is for any MacLISP with a sufficiently large
;; subset of NIL features to be usable for cross-compilation.
(copy-feature-set #-LISPM 'MACLISP #+LISPM 'LISPM 'NILAID)
(mapc #'(lambda (x) (set-nofeature x 'NILAID))
'(For-MacLISP For-LISPM))
(mapc #'(lambda (x) (set-feature x 'NILAID))
'(NILAID NIL FOR-NIL SFA STRING VECTOR #+PDP10 PDP10 ))
)
;;TARGET-FEATURES now back to 'LOCAL
(progn (set-feature (status OPSYSTEM))
(set-feature (status FILESYSTEM))
)
;; A MACLISP compatibility crock
#M (let ((y (status features)))
;; Set the features that are present in our environment now, in LOCAL
(mapc #'SET-FEATURE y)
;; The following are either present or not initially
(mapc #'(lambda (x) (or (memq x y) (set-nofeature x)))
'(SFA STRING VECTOR COMPLR NOLDMSG
VAX UNIX VMS MULTICS PDP10 ITS TOPS-20 TOPS-10))
)
;; INITIAL-LOCAL is useful for creating, by COPY-FEATURE-SET, other targets
;; which are variations of the default environment, where initial environment
;; is whatever is present at the time LISP is started.
(COPY-FEATURE-SET 'LOCAL 'INITIAL-LOCAL)
(DEF-EQUIVALENCE-FEATURE-SET LOCAL-FEATURES LOCAL)
(DEF-EQUIVALENCE-FEATURE-SET MACLISP-FEATURES MACLISP)
(DEF-EQUIVALENCE-FEATURE-SET NIL-FEATURES NIL)
(DEF-INDIRECT-FEATURE-SET TARGET TARGET-FEATURES)
(DEF-INDIRECT-FEATURE-SET MACROEXPAND MACROEXPAND-FEATURES)

301
src/nilcom/thread.8 Executable file
View File

@@ -0,0 +1,301 @@
;;; 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))))