mirror of
https://github.com/PDP-10/its.git
synced 2026-03-28 10:52:52 +00:00
357 lines
11 KiB
Common Lisp
357 lines
11 KiB
Common Lisp
;;; VSAID -*-MODE:LISP;PACKAGE:SI-*- -*-LISP-*-
|
||
;;; **************************************************************
|
||
;;; *** MACLISP ******* Aid to MACLISP for VECTORs ***************
|
||
;;; **************************************************************
|
||
;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
|
||
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
|
||
;;; **************************************************************
|
||
|
||
;;; See second page for commentary
|
||
|
||
(eval-when (eval compile)
|
||
(or (status nofeature MACLISP)
|
||
(status macro /#)
|
||
(setsyntax '/# 'SPLICING '+INTERNAL-/#-MACRO))
|
||
(and (status feature MACLISP)
|
||
(status nofeature MULTICS)
|
||
(sstatus feature PDP10))
|
||
)
|
||
|
||
(eval-when (eval compile)
|
||
(and (status nofeature MACAID) (load '((LISP) MACAID)))
|
||
)
|
||
#Q (globalize "PTR-TYPEP" "PAIRP" "LISTP" "SEQUENCEP" "MAKE-LIST"
|
||
"TYPECASEQ" "MAKE-VECTOR" "VECTOR" "VECTORP" "VREF"
|
||
"VSET" "VECTOR-LENGTH" "REPLACE" "SUBSEQ" "ELT"
|
||
"SETELT" "SYMBOLCONC" "NIL-INTERN"
|
||
)
|
||
|
||
(herald VSAID /57)
|
||
|
||
(eval-when (load)
|
||
(and #-LISPM
|
||
(status feature COMPLR)
|
||
(special |+internal-VECTOR-class-object/||
|
||
|+internal-EXTEND-class-object/||
|
||
|+internal-CLASS-class-object/|| ))
|
||
)
|
||
|
||
(eval-when (compile)
|
||
(and (status nofeature VSAID) (load '((LISP) VSAID)))
|
||
)
|
||
|
||
(declare (/@define defsimplemac defbothmacro))
|
||
|
||
|
||
|
||
;;; VECTOR primitive support routines which help NILAID and DEFVST
|
||
;;; A sequence of length "n" is translated into a hunk of size "n+2"
|
||
;;; where the 1st element is the symbolic data type. (0th for CLASSes).
|
||
;;; On LISPM, they translate into ART-Qs of 1 dimension.
|
||
;;; Primitive data-type support:
|
||
;;; PTR-TYPEP, PAIRP, LISTP, SEQUENCEP, MAKE-LIST, TYPECASEQ (as a macro)
|
||
;;; VECTOR support macros:
|
||
;;; MAKE-VECTOR, VECTOR, VECTORP, VREF, VSET, VECTOR-LENGTH,
|
||
;;; Misc support functions:
|
||
;;; REPLACE, SUBSEQ, ELT, SETELT, SYMBOLCONC,
|
||
;;; Also, all the MACAID file is loaded in, for some macro-expansion support:
|
||
;;; DEFSIMPLEMAC, DEFBOTHMACRO, |constant-p/||, |no-funp/||,
|
||
;;; |carcdrp/|| |side-effectsp/||
|
||
|
||
|
||
;;; Here's some particular macro definitions and declaractions,
|
||
;;; knowing that the intended target is with the other maclisp
|
||
;;; NILCOM software.
|
||
#M (declare (*LEXPR STRING-REPLACE STRING-SUBSEQ STRING-MISMATCHQ
|
||
SYMBOLCONC )
|
||
(*EXPR PTR-TYPEP MAKE-STRING STRING-PNGET
|
||
CHAR CHAR-N RPLACHAR RPLACHAR-N STRING-LENGTH)
|
||
(FIXNUM (CHAR-N () FIXNUM))
|
||
(NOTYPE (RPLACHAR-N () FIXNUM FIXNUM)))
|
||
|
||
|
||
#M (defun |index+2-examine/|| (H N)
|
||
(cond ((|constant-p/|| N)
|
||
(cond ((fixp N) (+ 2 N))
|
||
((and (not (atom N)) (eq (car N) 'QUOTE) (fixp (cadr N)))
|
||
(+ 2 (cadr N)))
|
||
('t `(+ 2 ,n))))
|
||
((OR (|constant-p/|| H)
|
||
(AND (NOT (|side-effectsp/|| N))
|
||
(NOT (|side-effectsp/|| H))))
|
||
`(+ 2 ,n))))
|
||
|
||
|
||
;;; What a gross shaft ensues if you try to uses the MACROEXPANDED
|
||
;;; memoizing feature with this macro, **SELF-EVAL**!
|
||
|
||
#M (macro **SELF-EVAL** (x) `(QUOTE ,x))
|
||
|
||
|
||
|
||
(comment initial CLASS stuff)
|
||
|
||
; This is merely an internal helper function
|
||
#+PDP10
|
||
(progn 'compile
|
||
(declare (setq defmacro-check-args () ))
|
||
(defmacro *:EXTEND (class &rest data)
|
||
`(HUNK '**SELF-EVAL** ,@data ,class))
|
||
(defcomplrmac |cons-a-NEWdtp| (type &rest data)
|
||
(or (memq type '(STRING CLASS VECTOR CHARACTER BITS))
|
||
(error '|what the heck? - cons-a-NEWdtp| type))
|
||
(cond ((eq type 'CLASS)
|
||
(setq data `(,(car data) () () () () ()))))
|
||
`(*:EXTEND ,(intern (symbolconc '|+internal-| type '|-class-object/||))
|
||
,.data))
|
||
(defmacro *:CLASS-OF (ob) `(CDR ,ob))
|
||
(defun CLASS-OF (ob) ;; Called by SENDI. Must be fast.
|
||
(declare (special *:PRIMITIVE-TYPES-CLASS-TABLE))
|
||
(cond ((hunkp ob) (*:class-of ob))
|
||
('t (error '|CLASS-OF doesn't work on non-EXTENDs!| ob 'fail-act))))
|
||
(defmacro *:CLASS-TYPEP (class) `(CXR 2 ,class))
|
||
(defmacro *:CLASS-SUPRS (class) `(CXR 3 ,class))
|
||
(defmacro *:CLASS-SENDI (class) `(CXR 4 ,class))
|
||
(defmacro *:CLASS-CALLI (class) `(CXR 5 ,class))
|
||
(defmacro *:CLASS-METHODS (class) `(CXR 6 ,class))
|
||
(defmacro *:CLASS-DESCR (class) `(CXR 7 ,class))
|
||
;CLASSES have 6 significant components [the car and cdr are respectively
|
||
; forced to be **SELF-EVAL** and the super-class marker]
|
||
(defcomplrmac *:CLASSP (item &aux (y (gensym)))
|
||
`(LET ((,y ,item))
|
||
(COND ((OR (NOT (HUNKP ,y))
|
||
(NOT (EQ (CAR ,y) '**SELF-EVAL**))
|
||
(< (VECTOR-LENGTH ,y) 6))
|
||
() )
|
||
((OR (EQ (SETQ ,y (*:CLASS-OF ,y))
|
||
|+internal-CLASS-class-object/||)
|
||
(EQ ,y '|CLASS-of-CLASSES: The BUCK stops here!/||))
|
||
'T)
|
||
;The following several lines constitute an open-coding of
|
||
; (EQUAL (cddr item) |+internal-CLASS-class-object/||)
|
||
((OR (NOT (HUNKP ,y))
|
||
(NOT (EQ (CAR ,y) '**SELF-EVAL**))
|
||
(< (VECTOR-LENGTH ,y) 6))
|
||
() )
|
||
((AND (EQ (*:CLASS-TYPEP ,y) 'CLASS)
|
||
(EQ (*:CLASS-OF ,y)
|
||
'|CLASS-of-CLASSES: The BUCK stops here!/||))
|
||
'T))))
|
||
)
|
||
;;; ########## MULTICS NEWdtp ?
|
||
#-PDP10
|
||
(progn 'compile
|
||
#+MULTICS
|
||
(progn 'compile
|
||
(defcomplrmac AR-1 (&rest w) `(ARRAYCALL T ,.w))
|
||
(defcomplrmac AS-1 (val &rest w) `(STORE (ARRAYCALL T ,.w) ,val))
|
||
)
|
||
(defmacro |cons-a-NEWdtp| (type &rest data)
|
||
(or (memq type '(STRING CLASS VECTOR CHARACTER BITS))
|
||
(error '|what the heck? - cons-a-NEWdtp| type))
|
||
`(|Fill-NEWdtp| ,(intern (string-append "+internal-"
|
||
(string type)
|
||
"-class-object/|"))
|
||
,. data))
|
||
(defun |Fill-NEWdtp| (type &rest data)
|
||
(do ((h (make-array () 'ART-Q (1+ (length data))))
|
||
(i 1 (1+ i)))
|
||
((null x)
|
||
(as-1 type h 0)
|
||
h)
|
||
(as-1 (car x) h i)))
|
||
)
|
||
|
||
; Here comes the original bootstrap for the CLASS system!
|
||
(SETQ |+internal-CLASS-class-object/|| ()
|
||
|+internal-CLASS-class-object/|| (|cons-a-NEWdtp| CLASS 'CLASS))
|
||
|
||
#+PDP10 (rplacx 0
|
||
|+internal-CLASS-class-object/||
|
||
'|CLASS-of-CLASSES: The BUCK stops here!/||)
|
||
|
||
#-PDP10 (as-1 '|CLASS-of-CLASSES: The BUCK stops here!/||
|
||
|+internal-CLASS-class-object/||
|
||
0)
|
||
|
||
(SETQ |+internal-VECTOR-class-object/|| (|cons-a-NEWdtp| CLASS 'VECTOR))
|
||
|
||
|
||
|
||
(comment PTR-TYPEP and type macros)
|
||
|
||
(defun PTR-TYPEP (x)
|
||
(cond ((null x) 'CONSTANT)
|
||
#+PDP10 ((hunkp x)
|
||
(cond ((and (eq (car x) '**SELF-EVAL**)
|
||
(*:classp (*:class-of x)))
|
||
(or (car (memq (*:class-typep (*:class-of x))
|
||
'(STRING CHARACTER VECTOR BITS
|
||
CONSTANT SUBR SMALL-FLONUM)))
|
||
'EXTEND))
|
||
((and (eq (car x) '**SELF-EVAL**)
|
||
(eq (cdr x) '|CLASS-of-CLASSES: The BUCK stops here!/||))
|
||
'EXTEND)
|
||
('t 'HUNK)))
|
||
((let ((typ (typep x)))
|
||
(cond ((eq typ 'LIST) 'PAIR)
|
||
#Q ((and (eq typ 'ARRAY)
|
||
(eq (array-type x) 'ART-Q)
|
||
(= (array-/#-dims x) 1))
|
||
(setq typ (ar-1 x 0))
|
||
(cond ((and (arrayp typ)
|
||
(eq (array-type typ) 'ART-Q)
|
||
(= (array-/#-dims typ) 1)
|
||
(cond ((eq (ar-1 typ 0) |+internal-CLASS-class-object/||))
|
||
((eq (ar-1 typ 0) '|CLASS-of-CLASSES: The BUCK stops here!/||))
|
||
;The following is an open-coding of
|
||
; (EQUAL (ar-1 typ 0) |+internal-CLASS-class-object/||)
|
||
((and (arrayp (ar-1 typ 0))
|
||
(eq (array-tyep (ar-1 typ 0)) 'ART-Q)
|
||
(= (array-/#-dims (ar-1 typ 0)) 1)
|
||
(eq (ar-1 (ar-1 typ 0) 0)
|
||
'|CLASS-of-CLASSES: The BUCK stops here!/||)
|
||
(eq (ar-1 (ar-1 typ 0) 1) 'CLASS)))))
|
||
(ar-1 typ 1))
|
||
('ARRAY)))
|
||
#+MULTICS ((eq typ 'ARRAY) (error '|not yet coded - PTR-TYPEP|))
|
||
((eq typ 'BIGNUM) 'EXTEND)
|
||
('t typ))))))
|
||
|
||
|
||
(defmacro TYPECASEQ (x &rest y) `(CASEQ (PTR-TYPEP ,x) ,@y))
|
||
|
||
(defbothmacro PAIRP (x) `(EQ (TYPEP ,x) 'LIST))
|
||
(defbothmacro VECTORP (x) `(EQ (PTR-TYPEP ,x) 'VECTOR))
|
||
|
||
(defbothmacro LISTP simple (x)
|
||
`(OR (NULL ,x)
|
||
(EQ (TYPEP ,x) 'LIST)))
|
||
(defbothmacro SEQUENCEP simple (x)
|
||
`(OR (NULL ,x)
|
||
(AND (MEMQ (PTR-TYPEP ,x)
|
||
'(PAIR STRING VECTOR VECTOR-S EXTEND BITS)) 'T)))
|
||
|
||
(comment VECTOR primitives)
|
||
|
||
#+PDP10
|
||
(progn 'compile
|
||
(defbothmacro VECTOR-LENGTH (x) `(- (HUNKSIZE ,x) 2))
|
||
(defbothmacro VREF (h n)
|
||
(let ((tmp (|index+2-examine/|| h n)) htem)
|
||
(cond (tmp `(CXR ,tmp ,h))
|
||
('T (setq htem (gensym) tmp (gensym))
|
||
`((LAMBDA (,htem ,tmp)
|
||
(CXR (+ 2 ,tmp) ,htem))
|
||
,h ,n)))))
|
||
(defbothmacro VSET (h n val)
|
||
(let ((tmp (|index+2-examine/|| h n)) htem)
|
||
(cond (tmp `(RPLACX ,tmp ,h ,val))
|
||
('T (setq htem (gensym) tmp (gensym))
|
||
`((LAMBDA (,htem ,tmp)
|
||
(RPLACX (+ 2 ,tmp) ,htem ,val))
|
||
,h ,n)))))
|
||
(defbothmacro *:MAKE-EXTEND (n cl)
|
||
(let ((v (gensym)))
|
||
`(LET ((,v (MAKHUNK (+ ,n 2))))
|
||
(RPLACX 0 ,v ,cl)
|
||
(RPLACX 1 ,v '**SELF-EVAL** ))))
|
||
) ;end of #M
|
||
|
||
|
||
#-PDP10
|
||
(progn 'compile
|
||
(defbothmacro VECTOR-LENGTH (x) `(- (ARRAY-DIMENSION-N 1 ,x) 1))
|
||
(defbothmacro VREF (h n) `(AR-1 ,h (1+ ,n)))
|
||
(defbothmacro VSET (h n val)
|
||
(cond ((or (|side-effectsp/|| h)
|
||
(|side-effectsp/|| n)
|
||
(|side-effectsp/|| val))
|
||
(let ((htem (gensym)) (tmp (gensym)))
|
||
`((LAMBDA (,htem ,tmp) (AS-1 ,val ,htem (1+ ,tmp)))
|
||
,h ,n)))
|
||
(`(AS-1 ,val ,h (1+ ,n)))))
|
||
(defbothmacro *:MAKE-EXTEND (n cl)
|
||
(let ((v (gensym)))
|
||
`(LET ((,v (MAKE-ARRAY () 'ART-Q (1+ ,n))))
|
||
(AS-1 ,cl ,v 0)
|
||
,v)))
|
||
) ;end of #Q
|
||
|
||
|
||
(defbothmacro MAKE-VECTOR (n)
|
||
`(*:MAKE-EXTEND ,n |+internal-VECTOR-class-object/||))
|
||
|
||
(defun VECTOR #M n #Q (&rest x &aux (n (length x)))
|
||
(declare (fixnum n))
|
||
(cond ((= n 0) () )
|
||
('t (do ((v (make-vector n))
|
||
#Q (l x (cdr l))
|
||
(i 0 (1+ i)))
|
||
((not (< i n)) v)
|
||
(vset v i #M (arg (1+ i)) #Q (car l))))))
|
||
|
||
|
||
(comment MAKE-LIST ELT SYMBOLCONC)
|
||
|
||
|
||
(defun MAKE-LIST (count)
|
||
(do ((l () (cons () l)) (n count (1- n)))
|
||
((< n 1) l)
|
||
(declare (fixnum n))))
|
||
|
||
|
||
(DEFUN ELT (V I)
|
||
(DECLARE (FIXNUM I))
|
||
(TYPECASEQ V
|
||
(PAIR (NTH I V))
|
||
(VECTOR (VREF V I))
|
||
(STRING (CHAR V I))
|
||
(BITS (BIT V I))
|
||
(T (ELT (ERROR V '|Sequence is required - ELT| 'WRNG-TYPE-ARG) I))))
|
||
|
||
(DEFUN SETELT (V I X)
|
||
(DECLARE (FIXNUM I))
|
||
(TYPECASEQ V
|
||
(PAIR (RPLACA (NTHCDR I V) X))
|
||
(VECTOR (VSET V I X))
|
||
(STRING (RPLACHAR V I X))
|
||
(BITS (RPLACBIT V I X))
|
||
(T (SETELT (ERROR V '|Sequence is required - SETELT| 'WRNG-TYPE-ARG)
|
||
I
|
||
X))))
|
||
|
||
|
||
(DEFUN SYMBOLCONC N
|
||
(DECLARE (FIXNUM I J LN N))
|
||
(DO ((I 1 (1+ I)) (LN 0) (ANS) (TYP) (A))
|
||
((> I N) (IMPLODE (NREVERSE ANS)))
|
||
(COND ((COND ((EQ (SETQ TYP (TYPEP (SETQ A (ARG I)))) 'SYMBOL)
|
||
(SETQ A (EXPLODEN A))
|
||
'T)
|
||
((EQ TYP 'LIST) (SETQ A (APPEND A () )) 'T))
|
||
(SETQ ANS (NRECONC A ANS)))
|
||
((HUNKP A)
|
||
(COND ((COND ((EQ (SETQ TYP (PTR-TYPEP A)) 'STRING)
|
||
(SETQ LN (STRING-LENGTH A))
|
||
'T)
|
||
((MEMQ TYP '(VECTOR VECTOR-S))
|
||
(SETQ LN (VECTOR-LENGTH A))
|
||
'T))
|
||
(DO ((J 0 (1+ J)))
|
||
((NOT (< J LN)))
|
||
(PUSH (COND ((EQ TYP 'VECTOR) (VREF A J))
|
||
('T (CHAR-N A J)))
|
||
ANS)))
|
||
('T (ERROR '|BAD ARG - SYMBOLCONC| A)))))))
|
||
|
||
|
||
|
||
#M (progn 'compile
|
||
(DEFPROP STRING-PNGET ((LISP) STRING FASL) AUTOLOAD)
|
||
(mapc '(lambda (x) (putprop x '((LISP) SUBSEQ FASL) 'AUTOLOAD))
|
||
'(REPLACE SUBSEQ TO-LIST TO-VECTOR))
|
||
)
|
||
|
||
(SSTATUS FEATURE VSAID)
|