mirror of
https://github.com/PDP-10/its.git
synced 2026-03-10 12:48:25 +00:00
Update UMLMAC and MLMAC lisp libraries. Fix DBG and FASLRO to conform
to new DOTIMES and DOLIST macro definitions (in the case of FASLRO, update to use DO rather than DOLIST since DOLIST no longer (as of latest UMLMAC) binds a parameter to the loop count. Resolves #1054.
This commit is contained in:
Eric Swenson
@@ -67,7 +67,7 @@ respond "_" "\032"
|
||||
type ":kill\r"
|
||||
|
||||
respond "*" "complr\013"
|
||||
respond "_" "liblsp;_libdoc;dbg rwk1\r"
|
||||
respond "_" "liblsp;_libdoc;dbg ejs2\r"
|
||||
respond "_" "liblsp;_libdoc;comrd kmp1\r"
|
||||
respond "_" "\032"
|
||||
type ":kill\r"
|
||||
|
||||
@@ -478,7 +478,7 @@ The X command works only with SIGNAL to continue or restart from errors.
|
||||
(debug-frame-printer frame sprinter-p))
|
||||
|
||||
(defun debug-n-spaces (n)
|
||||
(dotimes (\\ n debug-indent-max)
|
||||
(dotimes (() (\\ n debug-indent-max))
|
||||
(tyo #\SPACE error-io)))
|
||||
|
||||
|
||||
38
src/lspsrc/mlmac.92 → src/lspsrc/mlmac.93
Executable file → Normal file
38
src/lspsrc/mlmac.92 → src/lspsrc/mlmac.93
Executable file → Normal file
@@ -6,7 +6,7 @@
|
||||
;;; *************************************************************************
|
||||
|
||||
;; Herald is on next page, since it is defined in this file
|
||||
;; (herald MLMAC /92)
|
||||
;; (herald MLMAC /93)
|
||||
|
||||
(eval-when (eval compile)
|
||||
(or (get 'SUBLOAD 'VERSION)
|
||||
@@ -94,6 +94,8 @@
|
||||
|
||||
|
||||
|
||||
;;;; Random Macros
|
||||
|
||||
;; Basically, most of these "FSUBR" macros only need to be "un-cached"
|
||||
;; if they are redefined.
|
||||
(eval-when (eval compile)
|
||||
@@ -142,6 +144,7 @@
|
||||
(princ '| instead.| msgfiles))
|
||||
|
||||
|
||||
;;;; Variable Definers
|
||||
|
||||
;; (DEFVAR sym value documentation)
|
||||
;; SETQ-IF-UNBOUND so can initialize a var before loading the file which
|
||||
@@ -156,13 +159,34 @@
|
||||
,.(if valp `((SETQ-IF-UNBOUND ,var ,val)))
|
||||
',var))
|
||||
|
||||
(defmacro DEFCONST (var &optional (val () valp) () ) ;3rd = documentation
|
||||
|
||||
;DEFPARAMETER is similar to DEFVAR, but ALWAYS initializes the variable,
|
||||
; in spite of anything else.
|
||||
(defmacro DEFPARAMETER (var val &optional () ) ;3rd = documentation
|
||||
`(PROGN 'COMPILE
|
||||
(EVAL-WHEN (EVAL LOAD COMPILE)
|
||||
(AND (STATUS FEATURE COMPLR) (SPECIAL ,var)))
|
||||
,.(if valp `((SETQ ,var ,val)))
|
||||
(SETQ ,var ,val)
|
||||
',var))
|
||||
|
||||
;This name is being flushed to avoid confusion with DEFCONSTANT, which
|
||||
; has a trivially different name so that code will continue to work.
|
||||
(macro DEFCONST (form)
|
||||
(cons 'DEFPARAMETER (cdr form)))
|
||||
|
||||
|
||||
;This is supposed to be a "manifest constant", i.e. something the compiler
|
||||
; could hardwire into your code (if the implementation so warrants).
|
||||
;The code is in error if there is a variable binding in effect when the
|
||||
; variable is being initialized. The code is in error (and this should
|
||||
; be checked but isn't) if the variable has a global value which is
|
||||
; not EQUAL to the value being assigned.
|
||||
(macro DEFCONSTANT (form)
|
||||
(cons 'DEFPARAMETER (cdr form)))
|
||||
|
||||
|
||||
|
||||
;;;; More random macros
|
||||
|
||||
;; PSETQ looks like SETQ but does its work in parallel.
|
||||
(defmacro PSETQ (&rest rest)
|
||||
@@ -322,8 +346,8 @@
|
||||
|
||||
|
||||
|
||||
;;;; MULTIPLE-VALUE-LIST, MULTIPLE-VALUE, MULTIPLE-VALUE-BIND, VALUES,
|
||||
;;;; RETURN-LIST, MULTIPLE-VALUE-RETURN
|
||||
;;; MULTIPLE-VALUE-LIST, MULTIPLE-VALUE, MULTIPLE-VALUE-BIND, VALUES,
|
||||
;;; RETURN-LIST, MULTIPLE-VALUE-RETURN
|
||||
|
||||
|
||||
(defmacro MULTIPLE-VALUE-LIST (form)
|
||||
@@ -388,7 +412,3 @@
|
||||
`(RETURN (VALUES-LIST ,l)))
|
||||
|
||||
(defmacro MULTIPLE-VALUE-RETURN (form) `(RETURN ,form))
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -1,240 +0,0 @@
|
||||
;;; UMLMAC -*-Mode:Lisp;Package:SI;Lowercase:T-*-
|
||||
;;; *************************************************************************
|
||||
;;; ***** MacLISP ******* Utility MacLisp MACros ****************************
|
||||
;;; *************************************************************************
|
||||
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *************
|
||||
;;; *************************************************************************
|
||||
|
||||
(herald UMLMAC /35)
|
||||
|
||||
(include ((lisp) subload lsp))
|
||||
|
||||
|
||||
(eval-when (eval compile)
|
||||
(setq defmacro-for-compiling 'T defmacro-displace-call MACROEXPANDED)
|
||||
(mapc #'(lambda (x) (putprop x 'T 'SKIP-WARNING))
|
||||
'(SELECTQ STRUCT-LET STRUCT-SETF))
|
||||
(subload LOOP)
|
||||
)
|
||||
|
||||
;;;; MSETQ-..., for backwards compatibility
|
||||
;;;; BIT-<TEST,SET,CLEAR>, WHEN, UNLESS,
|
||||
|
||||
|
||||
(defmacro MSETQ-CALL (&rest w) `(MULTIPLE-VALUE ,.w))
|
||||
(defmacro MSETQ-RETURN (&rest w) `(VALUES ,.w))
|
||||
|
||||
|
||||
(DEFBOTHMACRO BIT-TEST (X Y) `(NOT (= (BOOLE 1 ,X ,Y) 0)))
|
||||
(DEFBOTHMACRO BIT-SET (X Y) `(BOOLE 7 ,X ,Y))
|
||||
(DEFBOTHMACRO BIT-CLEAR (X Y) `(BOOLE 2 ,X ,Y))
|
||||
|
||||
|
||||
(DEFMACRO WHEN (P . C) `(COND (,P . ,C)))
|
||||
(DEFMACRO UNLESS (P . C) `(COND ((NOT ,P) . ,C)))
|
||||
|
||||
(def-or-autoloadable GENTEMP MACAID)
|
||||
(def-or-autoloadable SYMBOLCONC MACAID)
|
||||
|
||||
|
||||
;;;; SELECTQ
|
||||
|
||||
(defvar SI:SELECTQ-TYPE-TESTERS '((FIXNUM . =) (BIGNUM . EQUAL)) )
|
||||
|
||||
(defvar SI:SELECTQ-PREDICATES '((FIXNUM . FIXNUMP) (BIGNUM . BIGP) ))
|
||||
|
||||
;;; We could all (FLONUM . =$) to SI:SELECTQ-TYPE-TESTERS, and
|
||||
;;; (FLONUM . FLONUMP) to SI:SELECTQ-PREDICATES
|
||||
|
||||
(defvar SI:SELECTQ-OTHERWISE-KEYWORDS '(T OTHERWISE :OTHERWISE))
|
||||
|
||||
(defvar SI:SELECTQ-TYPEP-ALIST)
|
||||
|
||||
(defvar SI:SELECTQ-VAR)
|
||||
|
||||
|
||||
(defmacro SELECTQ (key-form &rest clauses &aux types-used tem newclauses)
|
||||
(cond
|
||||
((or (null clauses) (memq (caar clauses) si:selectq-otherwise-keywords))
|
||||
`(PROGN ,key-form () ,@(cdar clauses)))
|
||||
('T (loop as clause = (car clauses)
|
||||
as test = (car clause)
|
||||
until (memq test si:selectq-otherwise-keywords)
|
||||
as typed-alist = ()
|
||||
do (loop for key in (cond ((atom test) (list test)) (test))
|
||||
as type = (car (assq (typep key)
|
||||
si:selectq-type-testers))
|
||||
unless (memq type types-used)
|
||||
do (push type types-used)
|
||||
unless (setq tem (assq type typed-alist))
|
||||
do (push (setq tem (ncons type)) typed-alist)
|
||||
do (nconc tem (list key)))
|
||||
(push (cons typed-alist (cdr clause)) newclauses)
|
||||
while (setq clauses (cdr clauses)))
|
||||
(let* ((si:selectq-var (cond ((atom key-form) key-form)
|
||||
('T (si:gen-local-var () "Selector"))))
|
||||
(q (selectq-compile-1 newclauses types-used (cdar clauses))))
|
||||
(cond ((eq key-form si:selectq-var) q)
|
||||
('T `((LAMBDA (,si:selectq-var) ,q) ,key-form)))))))
|
||||
|
||||
(defun SELECTQ-COMPILE-1 (clauses types-used otherwisep)
|
||||
(and (equal otherwisep '(())) (setq otherwisep ()))
|
||||
(let ((si:selectq-typep-alist ())
|
||||
(pre-test ())
|
||||
(final-form ())
|
||||
(type-vars ())
|
||||
(type-vals ())
|
||||
(type-inits ()))
|
||||
(cond ((and (null (cdr types-used))
|
||||
(or (null (car types-used)) (not otherwisep)))
|
||||
(or (null (car types-used))
|
||||
(setq pre-test `(,(cdr (assq (car types-used)
|
||||
si:selectq-predicates))
|
||||
,si:selectq-var))))
|
||||
('T (loop with var = ()
|
||||
for type in types-used
|
||||
when type
|
||||
do (si:gen-local-var var type)
|
||||
(push (cons type var) si:selectq-typep-alist)
|
||||
(push () type-vals)
|
||||
(push var type-vars)
|
||||
(push `(SETQ ,var
|
||||
(,(cdr (assq type si:selectq-predicates))
|
||||
,si:selectq-var))
|
||||
type-inits))))
|
||||
(loop with nclauses = ()
|
||||
for xclause in clauses
|
||||
do (push (cons (cond ((not si:selectq-typep-alist)
|
||||
(selectq-one-hairy-predicate (caar xclause)))
|
||||
('T (selectq-hairy-predicate (car xclause))))
|
||||
(or (cdr xclause) '(())))
|
||||
nclauses)
|
||||
finally (and otherwisep (nconc nclauses (list `('T ,@otherwisep))))
|
||||
(setq final-form (cons 'cond nclauses)))
|
||||
(and pre-test (setq final-form `(and ,pre-test ,final-form)))
|
||||
(cond ((not (null (cdr type-inits))) (push 'OR type-inits))
|
||||
('T (setq type-inits (car type-inits))))
|
||||
`((LAMBDA ,type-vars ,type-inits ,final-form) ,@type-vals)))
|
||||
|
||||
|
||||
(defun SELECTQ-HAIRY-PREDICATE (type-alist &aux untyped)
|
||||
(loop with clauses = ()
|
||||
for entry in type-alist
|
||||
do (cond ((not (null (car entry)))
|
||||
(push `(,(cdr (assq (car entry) si:selectq-typep-alist))
|
||||
,(selectq-one-hairy-predicate entry))
|
||||
clauses))
|
||||
('T (setq untyped entry)))
|
||||
finally (and untyped
|
||||
(push (ncons (selectq-one-hairy-predicate untyped))
|
||||
clauses))
|
||||
(return (cond ((cdr clauses) `(COND ,.(nreverse clauses)))
|
||||
((cdar clauses) `(AND ,.(car clauses)))
|
||||
('T (caar clauses))))))
|
||||
|
||||
(defun SELECTQ-ONE-HAIRY-PREDICATE (entry)
|
||||
; Consider optimizing MEMQ.
|
||||
(loop with fn = (or (cdr (assq (car entry) si:selectq-type-testers)) 'eq)
|
||||
for k in (cdr entry)
|
||||
collect `(,fn ,si:selectq-var ',k) into preds
|
||||
finally (return (cond ((cdr preds) `(OR ,.preds))
|
||||
('T (car preds))))))
|
||||
|
||||
|
||||
;;;; DOLIST, DOTIMES
|
||||
|
||||
(defmacro DOLIST ((var form index) &rest body &aux dummy decls)
|
||||
(setq decls (cond ((and body
|
||||
(not (atom (car body)))
|
||||
(eq (caar body) 'DECLARE))
|
||||
(prog2 () (cdar body) (pop body)))))
|
||||
(cond (index (push `(FIXNUM ,INDEX) decls)
|
||||
(setq index (ncons `(,INDEX 0 (1+ ,INDEX)) ))))
|
||||
(and decls (setq decls (ncons `(DECLARE ,.decls))))
|
||||
(si:gen-local-var dummy)
|
||||
`(DO ((,DUMMY ,FORM (CDR ,DUMMY)) (,VAR) ,.index )
|
||||
((NULL ,DUMMY))
|
||||
,@decls
|
||||
(SETQ ,VAR (CAR ,DUMMY)) ,.BODY))
|
||||
|
||||
(eval-when (eval compile)
|
||||
(setq defmacro-for-compiling 'T defmacro-displace-call 'T)
|
||||
)
|
||||
|
||||
|
||||
;Repeat a number of times. <count> evaluates to the number of times,
|
||||
;and <body> is executed with <var> bound to 0, 1, ...
|
||||
;Don't generate dummy variable if <count> is an integer. We could also do this
|
||||
;if <count> were a symbol, but the symbol may get clobbered inside the body,
|
||||
;so the behavior of the macro would change.
|
||||
|
||||
(defmacro DOTIMES ((var count) &rest body &aux dummy decls)
|
||||
(or var (si:gen-local-var var))
|
||||
(and *RSET
|
||||
(do ()
|
||||
((symbolp var))
|
||||
(setq var (error '|Must be a variable -- DOTIMES|
|
||||
var
|
||||
'WRNG-TYPE-ARG))))
|
||||
(setq count (macroexpand count))
|
||||
(cond ((|constant-p/|| count)
|
||||
(do ()
|
||||
((fixnump count))
|
||||
(setq count (error '|Must be FIXNUM -- DOTIMES|
|
||||
count
|
||||
'WRNG-TYPE-ARG))))
|
||||
('T (si:gen-local-var dummy)
|
||||
(psetq dummy `((,dummy ,count))
|
||||
count dummy)))
|
||||
(setq decls `(DECLARE
|
||||
(FIXNUM ,var ,.(and dummy (list count)))
|
||||
,.(cond ((and body
|
||||
(not (atom (car body)))
|
||||
(eq (caar body) 'DECLARE))
|
||||
(prog2 () (cdar body) (pop body))))))
|
||||
`(DO ((,var 0 (1+ ,var)) ,.dummy)
|
||||
((NOT (< ,var ,count)))
|
||||
,decls
|
||||
,.body))
|
||||
|
||||
|
||||
;;;; STRUCT-LET and STRUCT-SETF
|
||||
|
||||
|
||||
(eval-when (eval compile)
|
||||
(setq defmacro-displace-call '|defvst-construction/||)
|
||||
)
|
||||
|
||||
|
||||
;;; E.g. (STRUCT-LET (<structure-name> <struct-object-to-be-destructured>)
|
||||
;; ((var slot-name) ; or,
|
||||
;; (var-named-same-as-slot) ; or,
|
||||
;; var-named-same-as-slot
|
||||
;; ...)
|
||||
;; . body)
|
||||
|
||||
(defmacro STRUCT-LET ((struct-name str-obj) bvl &rest body)
|
||||
(let (var slot-name accessor)
|
||||
(setq bvl (mapcar
|
||||
#'(lambda (e)
|
||||
(if (atom e) (setq e `(,e ,e)))
|
||||
(desetq (var slot-name) e)
|
||||
(or slot-name (setq slot-name var))
|
||||
(setq accessor (symbolconc struct-name '/- slot-name))
|
||||
`(,var (,accessor ,str-obj)))
|
||||
bvl))
|
||||
`(LET ,bvl ,.body)))
|
||||
|
||||
|
||||
;;; E.g. (STRUCT-SETF (structure-name object) (slot-name value) ...)
|
||||
(defmacro STRUCT-SETF ((str-name str-obj) &rest l &aux slot-name accessor val)
|
||||
`(PROGN ,. (mapcar
|
||||
#'(lambda (x)
|
||||
(if (atom x) (setq x `(,x ,x)))
|
||||
(desetq (slot-name val) x)
|
||||
(setq accessor (symbolconc str-name '/- slot-name))
|
||||
`(SETF (,accessor ,str-obj) ,val))
|
||||
l)))
|
||||
|
||||
|
||||
|
||||
352
src/lspsrc/umlmac.42
Normal file
352
src/lspsrc/umlmac.42
Normal file
@@ -0,0 +1,352 @@
|
||||
;;; UMLMAC -*-Mode:Lisp;Package:SI;Lowercase:T-*-
|
||||
;;; *************************************************************************
|
||||
;;; ***** MacLISP ******* Utility MacLisp MACros ****************************
|
||||
;;; *************************************************************************
|
||||
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *************
|
||||
;;; *************************************************************************
|
||||
|
||||
(herald UMLMAC /40)
|
||||
|
||||
|
||||
(include ((lisp) subload lsp))
|
||||
|
||||
|
||||
(eval-when (eval compile)
|
||||
(mapc #'(lambda (x) (putprop x 'T 'SKIP-WARNING))
|
||||
'(SELECTQ STRUCT-LET STRUCT-SETF))
|
||||
(subload LOOP)
|
||||
)
|
||||
|
||||
|
||||
(declare (*expr si:obsolete-form-msg))
|
||||
|
||||
(def-or-autoloadable GENTEMP MACAID)
|
||||
(def-or-autoloadable SYMBOLCONC MACAID)
|
||||
(def-or-autoloadable si:obsolete-form-msg MLMAC)
|
||||
|
||||
;;;; Random B.S.
|
||||
|
||||
;;; MSETQ-..., for backwards compatibility
|
||||
;;; BIT-<TEST,SET,CLEAR>, WHEN, UNLESS,
|
||||
|
||||
|
||||
(defmacro MSETQ-CALL (&rest w)
|
||||
(si:obsolete-form-msg 'msetq-call 'multiple-value)
|
||||
`(MULTIPLE-VALUE ,.w))
|
||||
(defmacro MSETQ-RETURN (&rest w)
|
||||
(si:obsolete-form-msg 'msetq-return 'values)
|
||||
`(VALUES ,.w))
|
||||
|
||||
|
||||
;This is good.
|
||||
(DEFBOTHMACRO BIT-TEST (X Y)
|
||||
`(NOT (= (BOOLE 1 ,X ,Y) 0)))
|
||||
;This should be dyked out. (-> LOGIOR)
|
||||
(DEFBOTHMACRO BIT-SET (X Y)
|
||||
`(BOOLE 7 ,X ,Y))
|
||||
;This too. (-> LOGANDC1)
|
||||
(DEFBOTHMACRO BIT-CLEAR (X Y)
|
||||
`(BOOLE 2 ,X ,Y))
|
||||
|
||||
|
||||
(DEFMACRO WHEN (P . C)
|
||||
`(COND (,P . ,C)))
|
||||
(DEFMACRO UNLESS (P . C)
|
||||
`(COND ((NOT ,P) . ,C)))
|
||||
|
||||
;;;; SELECTQ
|
||||
|
||||
(defvar SI:SELECTQ-TYPE-TESTERS '((FIXNUM . =) (BIGNUM . EQUAL)) )
|
||||
|
||||
(defvar SI:SELECTQ-PREDICATES '((FIXNUM . FIXNUMP) (BIGNUM . BIGP) ))
|
||||
|
||||
;;; We could all (FLONUM . =$) to SI:SELECTQ-TYPE-TESTERS, and
|
||||
;;; (FLONUM . FLONUMP) to SI:SELECTQ-PREDICATES
|
||||
|
||||
(defvar SI:SELECTQ-OTHERWISE-KEYWORDS '(T OTHERWISE :OTHERWISE))
|
||||
|
||||
(defvar SI:SELECTQ-TYPEP-ALIST)
|
||||
|
||||
(defvar SI:SELECTQ-VAR)
|
||||
|
||||
|
||||
(defmacro SELECTQ (key-form &rest clauses &aux types-used tem newclauses)
|
||||
(cond
|
||||
((or (null clauses) (memq (caar clauses) si:selectq-otherwise-keywords))
|
||||
`(PROGN ,key-form () ,@(cdar clauses)))
|
||||
('T (loop as clause = (car clauses)
|
||||
as test = (car clause)
|
||||
until (memq test si:selectq-otherwise-keywords)
|
||||
as typed-alist = ()
|
||||
do (loop for key in (cond ((atom test) (list test)) (test))
|
||||
as type = (car (assq (typep key)
|
||||
si:selectq-type-testers))
|
||||
unless (memq type types-used)
|
||||
do (push type types-used)
|
||||
unless (setq tem (assq type typed-alist))
|
||||
do (push (setq tem (ncons type)) typed-alist)
|
||||
do (nconc tem (list key)))
|
||||
(push (cons typed-alist (cdr clause)) newclauses)
|
||||
while (setq clauses (cdr clauses)))
|
||||
(let* ((si:selectq-var (cond ((atom key-form) key-form)
|
||||
('T (si:gen-local-var () "Selector"))))
|
||||
(q (selectq-compile-1 newclauses types-used (cdar clauses))))
|
||||
(cond ((eq key-form si:selectq-var) q)
|
||||
('T `((LAMBDA (,si:selectq-var) ,q) ,key-form)))))))
|
||||
|
||||
(defun SELECTQ-COMPILE-1 (clauses types-used otherwisep)
|
||||
(and (equal otherwisep '(())) (setq otherwisep ()))
|
||||
(let ((si:selectq-typep-alist ())
|
||||
(pre-test ())
|
||||
(final-form ())
|
||||
(type-vars ())
|
||||
(type-vals ())
|
||||
(type-inits ()))
|
||||
(cond ((and (null (cdr types-used))
|
||||
(or (null (car types-used)) (not otherwisep)))
|
||||
(or (null (car types-used))
|
||||
(setq pre-test `(,(cdr (assq (car types-used)
|
||||
si:selectq-predicates))
|
||||
,si:selectq-var))))
|
||||
('T (loop with var = ()
|
||||
for type in types-used
|
||||
when type
|
||||
do (si:gen-local-var var type)
|
||||
(push (cons type var) si:selectq-typep-alist)
|
||||
(push () type-vals)
|
||||
(push var type-vars)
|
||||
(push `(SETQ ,var
|
||||
(,(cdr (assq type si:selectq-predicates))
|
||||
,si:selectq-var))
|
||||
type-inits))))
|
||||
(loop with nclauses = ()
|
||||
for xclause in clauses
|
||||
do (push (cons (cond ((not si:selectq-typep-alist)
|
||||
(selectq-one-hairy-predicate (caar xclause)))
|
||||
('T (selectq-hairy-predicate (car xclause))))
|
||||
(or (cdr xclause) '(())))
|
||||
nclauses)
|
||||
finally (and otherwisep (nconc nclauses (list `('T ,@otherwisep))))
|
||||
(setq final-form (cons 'cond nclauses)))
|
||||
(and pre-test (setq final-form `(and ,pre-test ,final-form)))
|
||||
(cond ((not (null (cdr type-inits))) (push 'OR type-inits))
|
||||
('T (setq type-inits (car type-inits))))
|
||||
`((LAMBDA ,type-vars ,type-inits ,final-form) ,@type-vals)))
|
||||
|
||||
|
||||
(defun SELECTQ-HAIRY-PREDICATE (type-alist &aux untyped)
|
||||
(loop with clauses = ()
|
||||
for entry in type-alist
|
||||
do (cond ((not (null (car entry)))
|
||||
(push `(,(cdr (assq (car entry) si:selectq-typep-alist))
|
||||
,(selectq-one-hairy-predicate entry))
|
||||
clauses))
|
||||
('T (setq untyped entry)))
|
||||
finally (and untyped
|
||||
(push (ncons (selectq-one-hairy-predicate untyped))
|
||||
clauses))
|
||||
(return (cond ((cdr clauses) `(COND ,.(nreverse clauses)))
|
||||
((cdar clauses) `(AND ,.(car clauses)))
|
||||
('T (caar clauses))))))
|
||||
|
||||
(defun SELECTQ-ONE-HAIRY-PREDICATE (entry)
|
||||
; Consider optimizing MEMQ.
|
||||
(loop with fn = (or (cdr (assq (car entry) si:selectq-type-testers)) 'eq)
|
||||
for k in (cdr entry)
|
||||
collect `(,fn ,si:selectq-var ',k) into preds
|
||||
finally (return (cond ((cdr preds) `(OR ,.preds))
|
||||
('T (car preds))))))
|
||||
|
||||
|
||||
;;;; DOLIST, DOTIMES
|
||||
|
||||
;(dolist (var list) body...)
|
||||
;Steps <var> through the elements of <list>. <body> is a progbody;
|
||||
; tags and GO and RETURN are allowed.
|
||||
;In the future, there will be a third optional form in the iteration spec,
|
||||
; which will be evaluated to get the return value of the form. This is
|
||||
; not supported currently to catch illegal or confused uses of that syntax
|
||||
; for some other purpose.
|
||||
(defmacro dolist (spec . body)
|
||||
(cond ((or (atom spec)
|
||||
(atom (cdr spec))
|
||||
(cddr spec)
|
||||
(not (symbolp (car spec))))
|
||||
(error "Invalid binding spec for DOLIST" spec)))
|
||||
(let ((l (gentemp)) (item (car spec)) (list (cadr spec)) (decls nil))
|
||||
(setq decls (cond ((and body
|
||||
(not (atom (car body)))
|
||||
(eq (caar body) 'DECLARE))
|
||||
(prog1 (cdar body) (pop body)))))
|
||||
(cond ((not (null decls)) (setq decls (ncons `(DECLARE ,.decls)))))
|
||||
`(do ((,l ,list (cdr ,l)) (,item)) ((null ,l))
|
||||
,.decls
|
||||
(setq ,item (car ,l))
|
||||
,@body)))
|
||||
|
||||
|
||||
;(dotimes (var count) body...)
|
||||
;Repeat a number of times. <count> evaluates to the number of times,
|
||||
; and <body> is executed with <var> bound to 0, 1, ...
|
||||
;Don't generate dummy variable if <count> is an integer. We could also do
|
||||
; this if <count> were a symbol, but the symbol may get clobbered inside the
|
||||
; body, so the behavior of the macro would change.
|
||||
;In the future, there will be a third optional form in the iteration spec,
|
||||
; which will be evaluated to get the return value of the form. This is
|
||||
; not supported currently to catch illegal or confused uses of that syntax
|
||||
; for some other purpose.
|
||||
(defmacro DOTIMES (iter-spec &rest body)
|
||||
(let ((var nil)
|
||||
(count nil)
|
||||
(decls (cond ((and body
|
||||
(not (atom (car body)))
|
||||
(eq (caar body) 'DECLARE))
|
||||
(prog1 (cdar body) (pop body))))))
|
||||
(if (and (not (atom iter-spec))
|
||||
(not (atom (cdr iter-spec)))
|
||||
(null (cddr iter-spec)))
|
||||
(setq var (car iter-spec) count (cadr iter-spec))
|
||||
(error "Malformed iteration spec -- DOTIMES" iter-spec))
|
||||
(or var (setq var (gentemp)))
|
||||
(do () ((symbolp var))
|
||||
(setq var (error '|Must be a variable -- DOTIMES|
|
||||
var 'WRNG-TYPE-ARG)))
|
||||
(if (and (not (atom (setq count (macroexpand count))))
|
||||
(eq (car count) 'quote)
|
||||
(fixnump (cadr count)))
|
||||
(setq count (cadr count)))
|
||||
(let ((scrodp nil) (use-form count))
|
||||
(if (not (fixnump count))
|
||||
(setq scrodp t use-form (gentemp)))
|
||||
(let ((form `(DO ((,var 0 (1+ ,var)))
|
||||
((NOT (< ,var ,use-form)))
|
||||
(declare (fixnum ,var) ,@decls)
|
||||
,.body)))
|
||||
(if scrodp
|
||||
`((lambda (,use-form)
|
||||
(declare (fixnum ,use-form))
|
||||
,form)
|
||||
,count)
|
||||
form)))))
|
||||
|
||||
|
||||
;;;; with-open-file
|
||||
|
||||
;;; LispM Manual, 4th ed, p 365
|
||||
;;;
|
||||
;;; (WITH-OPEN-FILE ((var filename . options) . body) ...)
|
||||
;;;
|
||||
;;; Evaluates the BODY forms with the variable VAR bound to a stream which
|
||||
;;; reads or writes the file named by the value of FILENAME. OPTIONS may be
|
||||
;;; any number of keywords to be passed open. These options control whether
|
||||
;;; a stream is for input from an existing file or output to a new file,
|
||||
;;; whether the file is text or binary, etc. The options are the same as
|
||||
;;; those which may be given to the OPEN function.
|
||||
;;;
|
||||
;;; When control leaves the body, either normally or abnormally (eg, via
|
||||
;;; *THROW), the file is closed.
|
||||
;;;
|
||||
;;; NOTE: The LispM feature wherein the file is deleted if a throw is done
|
||||
;;; is not currently supported and is not likely to be in the near
|
||||
;;; future. In any case, code using this compatibility macro should
|
||||
;;; not make assumptions about its behavior one way or the other on
|
||||
;;; this point. Please contact BUG-MACLISP if you have any troubles in
|
||||
;;; this regard.
|
||||
;;;
|
||||
;;; Because it always closes the file even when an error exit is taken,
|
||||
;;; WITH-OPEN-FILE is preferred over OPEN. Opening a large number of files
|
||||
;;; and forgetting to close them is anti-social on some file systems (eg, ITS)
|
||||
;;; because there are only a finite number of disk channels available which
|
||||
;;; must be shared among the community of logged-in users.
|
||||
;;;
|
||||
;;; Because the filename will be passed to OPEN, either a namestring or a
|
||||
;;; namelist will work. However, code intended to run on the LispM should
|
||||
;;; use only namestring format for files since that's all the LispM will
|
||||
;;; accept.
|
||||
;;;
|
||||
;;; NOTE: If an error occurs during the OPEN, the friendly behavior of the
|
||||
;;; LispM (wherein a new filename is prompted for) will not occur.
|
||||
;;; Instead, the IO-LOSSAGE handler will run as for any OPEN, probably
|
||||
;;; resulting in an error breakpoint. Users are encouraged to verify
|
||||
;;; the existence of a file before invoking WITH-OPEN-FILE on it.
|
||||
|
||||
(defmacro with-open-file ((var filename . options) &body body)
|
||||
(cond ((not (symbolp var))
|
||||
(error
|
||||
"bad var. Syntax is: (with-open-file (var file . options) . body)"
|
||||
var)))
|
||||
`(with-open-stream (,var (open ,filename ,@options))
|
||||
,@body)))
|
||||
|
||||
|
||||
;;;; with-open-stream
|
||||
|
||||
;;; Not documented in LispM Manual, 4th ed
|
||||
;;;
|
||||
;;; (WITH-OPEN-STREAM (var exp) . body)
|
||||
;;;
|
||||
;;; Like WITH-OPEN-FILE but exp may be an arbitrary form to accomplish the
|
||||
;;; OPEN. The result of evaluating EXP should be a file or sfa. BODY will be
|
||||
;;; evaluated in a context where VAR is bound to that file or sfa.
|
||||
;;; Upon return, as with WITH-OPEN-FILE, the file or sfa will be closed.
|
||||
;;;
|
||||
;;; Note: This is a reasonably low-level primitive. If you don't know the
|
||||
;;; which you want of WITH-OPEN-FILE or WITH-OPEN-STREAM, you almost
|
||||
;;; surely want WITH-OPEN-FILE.
|
||||
|
||||
(defmacro with-open-stream (bindings &body body)
|
||||
(cond ((or (atom bindings)
|
||||
(not (symbolp (car bindings))) ;var to bind
|
||||
(atom (cdr bindings))
|
||||
(not (null (cddr bindings))))
|
||||
(error "bad bindings. Syntax is: (WITH-OPEN-STREAM (var form) . body)"
|
||||
bindings)))
|
||||
(let (((var val) bindings)
|
||||
(temp (gensym)))
|
||||
`((lambda (,temp)
|
||||
(unwind-protect (progn (without-interrupts (setq ,temp ,val))
|
||||
((lambda (,var) ,@body) ,temp))
|
||||
(if (or (filep ,temp)
|
||||
(sfap ,temp))
|
||||
(close ,temp))))
|
||||
nil)))
|
||||
|
||||
|
||||
|
||||
;;;; STRUCT-LET and STRUCT-SETF
|
||||
|
||||
|
||||
(eval-when (eval compile)
|
||||
(setq defmacro-displace-call '|defvst-construction/||)
|
||||
)
|
||||
|
||||
|
||||
;;; E.g. (STRUCT-LET (<structure-name> <struct-object-to-be-destructured>)
|
||||
;; ((var slot-name) ; or,
|
||||
;; (var-named-same-as-slot) ; or,
|
||||
;; var-named-same-as-slot
|
||||
;; ...)
|
||||
;; . body)
|
||||
|
||||
(defmacro STRUCT-LET ((struct-name str-obj) bvl &rest body)
|
||||
(let (var slot-name accessor)
|
||||
(setq bvl (mapcar
|
||||
#'(lambda (e)
|
||||
(if (atom e) (setq e `(,e ,e)))
|
||||
(desetq (var slot-name) e)
|
||||
(or slot-name (setq slot-name var))
|
||||
(setq accessor (symbolconc struct-name '/- slot-name))
|
||||
`(,var (,accessor ,str-obj)))
|
||||
bvl))
|
||||
`(LET ,bvl ,.body)))
|
||||
|
||||
|
||||
;;; E.g. (STRUCT-SETF (structure-name object) (slot-name value) ...)
|
||||
(defmacro STRUCT-SETF ((str-name str-obj) &rest l &aux slot-name accessor val)
|
||||
`(PROGN ,. (mapcar
|
||||
#'(lambda (x)
|
||||
(if (atom x) (setq x `(,x ,x)))
|
||||
(desetq (slot-name val) x)
|
||||
(setq accessor (symbolconc str-name '/- slot-name))
|
||||
`(SETF (,accessor ,str-obj) ,val))
|
||||
l)))
|
||||
@@ -1,294 +0,0 @@
|
||||
(eval-when (eval compile)
|
||||
(or (get 'when 'macro) (load '((lisp)umlmac)))
|
||||
(or (get 'bitmac 'version) (load '((RLB) BITMAC)))
|
||||
)
|
||||
|
||||
(declare (array* (notype faslist-opcodes 1 faslist-acs 1 faslist-bits 1))
|
||||
(*lexpr faslreadopen)
|
||||
(*lexpr faslist faslist-loop)
|
||||
(special faslread-type faslist-bits-size faslist/. linel))
|
||||
|
||||
(setq faslist-bits-size #o36000) ;big enough for 15 blocks!
|
||||
|
||||
(prog1 'loadup
|
||||
(or (fboundp 'sort) (load (get 'sort 'autoload)))
|
||||
(or (fboundp 'sprinter) (load (get 'sprinter 'autoload)))
|
||||
(or (fboundp 'format) (load (get 'format 'autoload)))
|
||||
(or (fboundp 'faslreadopen) (get 'faslread 'version)
|
||||
(load '|MC:RLB%;FASLRE FASL|))
|
||||
(lapfivify 0))
|
||||
|
||||
(defun dump (filespec)
|
||||
(sstatus flush (status feature its)) ; Use (SSTATUS FLUSH T) on ITS
|
||||
(sstatus toplevel '(faslist-loop))
|
||||
(princ '|GC'ing...| tyo)
|
||||
(gc) ; Garbage collect
|
||||
(princ '|Dumping...| tyo)
|
||||
(suspend '|/î/
|
||||
| filespec) ; Suspend
|
||||
(defaultf `((dsk ,(status udir)) ,(status userid) fasl))
|
||||
(endpagefn tyo #'faslist--More--fun)
|
||||
(setq gc-overflow #'gc-overflow-foo)
|
||||
(faslist-loop (do ((l '(0 #^@ #^C #^M #^_) (cdr l))
|
||||
(jcl (status jcl) (delete (ascii (car l)) jcl)))
|
||||
((null l) jcl))))
|
||||
|
||||
(defun faslist-loop (&optional (jcl () jcl?))
|
||||
(do ((jcl jcl
|
||||
(progn (terpri)
|
||||
(princ '|FASList: | tyo)
|
||||
(explodec (readline tyi '||)))))
|
||||
(nil)
|
||||
(cond (JCL
|
||||
(let ((filename ()) options)
|
||||
(do ((l jcl (cdr l)))
|
||||
((or (eq (car l) '/) ;Alt?
|
||||
(null l))
|
||||
(setq filename (maknam (nreverse filename)))
|
||||
(setq options (cons '/(
|
||||
(nreverse (cons '/)
|
||||
(nreverse (cdr l)))))))
|
||||
(push (car l) filename))
|
||||
(if (errset (setq options (readlist options)) nil)
|
||||
(progn (defaultf filename)
|
||||
(if (probef filename)
|
||||
(errset (*catch 'flush--More--
|
||||
(faslist filename
|
||||
(or options 'all)))
|
||||
t)
|
||||
(format tyo '|/~
|
||||
;File not found: /"~a/"|
|
||||
(namestring (mergef filename defaultf)))))
|
||||
(format tyo '|
|
||||
;Syntax error. Use format /"filename{esc}flag1 flag2.../"/
|
||||
;Possible flags are ABS, CALL, REL, SPEC, QATOM, QLIST, GLBL,/
|
||||
; GETDDT, ARRAY, UNUSED, ATOMTB, ENTRY, LOC, PUTDDT, EVAL, and EOF/
|
||||
|)
|
||||
))))
|
||||
(if (and jcl? jcl) (quit))
|
||||
(setq jcl? nil)))
|
||||
|
||||
(defun faslist--More--fun (tty-file-obj)
|
||||
(declare (special catching--More--))
|
||||
(if (not (and (boundp 'catching--More--) catching--More--))
|
||||
(+internal-tty-endpagefn tty-file-obj)
|
||||
(let ((tyic (status ttycons tty-file-obj)))
|
||||
(nointerrupt ())
|
||||
(format tyo '|--More--|)
|
||||
(if (equal (tyipeek -1 tyic) #\space)
|
||||
(progn (tyi tyic) (terpri tyo))
|
||||
(*throw 'catching--More-- tty-file-obj)))))
|
||||
|
||||
(defun gc-overflow-foo (space)
|
||||
(let* ((mumble (get (cons () (alloc 'T)) space))
|
||||
((a b c) mumble)
|
||||
(morelist '(() list 1024.))
|
||||
(more (get morelist space)))
|
||||
(and more (alloc `(space (,a ,(+ b more) ,c))))
|
||||
'T))
|
||||
|
||||
(defun faslist (&OPTIONAL (file () filep) (options 'all))
|
||||
(if (not filep) '(ABS REL SPEC CALL QATOM QLIST GLBL GETDDT
|
||||
ARRAY UNUSED ATOMTB ENTRY LOC PUTDDT EVAL EOF)
|
||||
(let (f faslread-type (base 8.))
|
||||
(*catch 'catching--More--
|
||||
(let ((catching--More-- 'T))
|
||||
(declare (special catching--More--))
|
||||
(cursorpos 'C tyo)
|
||||
(unwind-protect (progn (setq f (faslreadopen file options))
|
||||
(faslist1 f))
|
||||
(faslreadclose f))))
|
||||
'T)))
|
||||
|
||||
(defun faslist1 (f)
|
||||
(fillarray 'faslist-bits '(0))
|
||||
(do ((r (faslread f) (faslread f)) (prev-r) (word 0) (faslist/. 0)
|
||||
(linel (cdr (status ttysize))))
|
||||
((eq faslread-type 'eof)
|
||||
(when prev-r (faslist-sprint prev-r linel))
|
||||
() )
|
||||
(setq word (faslreadnum f))
|
||||
(cond ((and prev-r (not (atom prev-r)) (eq faslread-type 'glbl))
|
||||
(let (/@ ((op ac e i rest) prev-r))
|
||||
(when (eq e '/@) (setq /@ '(/@) e i i rest))
|
||||
(unless ac (setq ac '0))
|
||||
(faslist-sprint
|
||||
`(,op ,ac ,@/@ ,(cond ((and e (zerop e) (eq r 'R70))
|
||||
'(% 0 0 '()))
|
||||
((or (null e) (zerop e)) r)
|
||||
((and (eq r 'R70) (symbolp e))
|
||||
(get e 'faslist-r70))
|
||||
(`(+ ,r ,e)))
|
||||
,@(and i (ncons i)))
|
||||
linel)
|
||||
(setq prev-r () faslread-type 'foo)))
|
||||
(prev-r (faslist-sprint prev-r linel) (setq prev-r ())))
|
||||
(caseq faslread-type
|
||||
(abs (setq prev-r (faslist-insn word (rh-bits word) 'T)
|
||||
faslist/. (1+ faslist/.)))
|
||||
(foo ())
|
||||
(T
|
||||
(faslist-sprint
|
||||
(caseq faslread-type
|
||||
; (abs (setq faslist/. (1+ faslist/.))
|
||||
; (faslist-insn word (rh-bits word) 'T))
|
||||
(rel (let* ((w (rh-bits word)))
|
||||
(faslist-setbit w)
|
||||
(setq faslist/. (1+ faslist/.))
|
||||
(faslist-insn word (faslist-gentag w) 'T)))
|
||||
(call (unless (atom r) (setq r (car (last r))))
|
||||
(setq faslist/. (1+ faslist/.))
|
||||
(faslist-insn word (list 'function r) ()))
|
||||
((spec qatom array)
|
||||
(unless (atom r) (setq r (car (last r))))
|
||||
(setq faslist/. (1+ faslist/.))
|
||||
(faslist-insn word (list (get faslread-type 'lapop) r)
|
||||
'T))
|
||||
(qlist (setq faslist/. (1+ faslist/.))
|
||||
(faslist-insn word `',r 'T))
|
||||
(entry (cons 'entry r))
|
||||
(eval r)
|
||||
(loc (list faslread-type
|
||||
(setq faslist/. (faslreadnum f))
|
||||
r))
|
||||
(T (list faslread-type (faslreadnum f) r)))
|
||||
linel)))))
|
||||
|
||||
|
||||
(defun faslist-insn (word rh acp)
|
||||
(let* ((op* (faslist-opcodes (bit-range word |4.9-4.1|)))
|
||||
(op (cond ((atom op*) op*) ((car op*)))))
|
||||
`(,op
|
||||
,(let ((ac (bit-range word |3.9-3.6|)))
|
||||
(cond (acp (faslist-acs ac)) (ac)))
|
||||
,@(and (bitp word #o20_22) (list '/@))
|
||||
,@(cond ((not (eq (typep rh) 'fixnum)) (list rh))
|
||||
((and (= rh 0) (= 0 (bit-range word |3.4-3.1|))) ())
|
||||
((and (< rh #o20) (atom op*))
|
||||
(ncons (faslist-acs rh)))
|
||||
((and (not (atom op*)) (cdr op*))
|
||||
(ncons (fsc (rplac-lh 0 rh) #o1_22)))
|
||||
((< rh #o700000) (list rh))
|
||||
((list (rplac-lh rh #o777777))))
|
||||
,@(and (not (= 0 (setq word (bit-range word |3.4-3.1|))))
|
||||
(list (faslist-acs word))))))
|
||||
|
||||
(defun faslist-setbit (n)
|
||||
(declare (fixnum n bitpos wordpos))
|
||||
(let ((bitpos (bit-and #.(1- 32.) n))
|
||||
(wordpos (lsh n #.(- (haulong 32.)))))
|
||||
(and (< n faslist-bits-size)
|
||||
(store (faslist-bits wordpos)
|
||||
(bit-or (lsh 1 bitpos) (faslist-bits wordpos)))
|
||||
'T)))
|
||||
|
||||
(defun faslist-testbit (n)
|
||||
(declare (fixnum n bitpos wordpos))
|
||||
(let ((bitpos (bit-and #.(1- 32.) n))
|
||||
(wordpos (lsh n #.(- (haulong 32.)))))
|
||||
(and (< n faslist-bits-size)
|
||||
(not (zerop (bit-and (lsh 1 bitpos) (faslist-bits wordpos)))))))
|
||||
|
||||
|
||||
(defun faslist-sprint (x linel)
|
||||
(terpri)
|
||||
(princ (cond ((not (> faslist/. 0)) '| |)
|
||||
((faslist-testbit (1- faslist/.))
|
||||
(faslist-gentag (1- faslist/.)))
|
||||
((1- faslist/.))))
|
||||
(sprint1 x (- linel 8) 0))
|
||||
|
||||
|
||||
(defun faslist-gentag (n) (format () '|G~4,48o| n))
|
||||
|
||||
(mapc #'(lambda (item op) (putprop item op 'lapop))
|
||||
'(spec qatom array qlist)
|
||||
'(special quote array quote))
|
||||
|
||||
(array faslist-bits fixnum (// faslist-bits-size 32.))
|
||||
|
||||
(array faslist-acs T #o20)
|
||||
#%(let ((acs '(0 A B C AR1 AR2A T TT D R F FREEAC P FLP FXP SP)))
|
||||
(fillarray 'faslist-acs acs)
|
||||
(dolist (ac acs i)
|
||||
(or (equal ac 0)
|
||||
(putprop ac `(% 0 0 ,i ,i) 'faslist-r70))))
|
||||
|
||||
(array faslist-opcodes T #o1000)
|
||||
(prog1 'faslist-opcodes
|
||||
(fillarray 'faslist-opcodes
|
||||
'(0 LERR ACALL AJCALL LER3 %UDF PP STRT ;000
|
||||
SERINT TP IOJRST STRT7 CALL JCALL CALLF JCALLF ;010
|
||||
NCALL NJCALL NCALLF NJCALF
|
||||
|024_33| |025_33| |026_33| |027_33| ;020
|
||||
|030_33| |031_33| |032_33| |033_33|
|
||||
|034_33| |035_33| |036_33| |037_33| ;030
|
||||
*IOT *OPEN *OPER *CALL *USET *BREAK *STATU *ACCES ;040
|
||||
|050_33| |051_33| |052_33| |053_33|
|
||||
|054_33| |055_33| |056_33| |057_33| ;050
|
||||
|060_33| |061_33| |062_33| |063_33|
|
||||
|064_33| |065_33| |066_33| |067_33| ;060
|
||||
|070_33| |071_33| |072_33| |073_33|
|
||||
|074_33| |075_33| |076_33| |077_33| ;070
|
||||
|100_33| |101_33| |102_33| |103_33|
|
||||
|104_33| ADJSP |106_33| |107_33| ;100
|
||||
DFAD DFSB DFMP DFDV DADD DSUB DMUL DDIV ;110
|
||||
DMOVE DMOVN FIX EXTEND DMOVEM DMOVNM FIXR FLTR ;120
|
||||
UFA DFN (FSC) IBP ILDB LDB IDPB DPB ;130
|
||||
FAD FADL FADM FADB FADR (FADRI s) FADRM FADRB ;140
|
||||
FSB FSBL FSBM FSBB FSBR (FSBRI s) FSBRM FSBRB ;150
|
||||
FMP FMPL FMPM FMPB FMPR (FMPRI s) FMPRM FMPRB ;160
|
||||
FDV FDVL FDVM FDVB FDVR (FDVRI s) FDVRM FDVRB ;170
|
||||
MOVE (MOVEI) MOVEM MOVES MOVS (MOVSI) MOVSM MOVSS ;200
|
||||
MOVN (MOVNI) MOVNM MOVNS MOVM (MOVMI) MOVMM MOVMS ;210
|
||||
IMUL (IMULI) IMULM IMULB MUL (MULI) MULM MULB ;220
|
||||
IDIV (IDIVI) IDIVM IDIVB DIV (DIVI) DIVM DIVB ;230
|
||||
(ASH)(ROT)(LSH)(JFFO)(ASHC)(ROTC)(LSHC)(CIRC) ;240
|
||||
EXCH BLT AOBJP AOBJN JRST JFCL XCT |257_33| ;250
|
||||
PUSHJ PUSH POP POPJ JSR JSP JSA JRA ;260
|
||||
ADD (ADDI) ADDM ADDB SUB (SUBI) SUBM SUBB ;270
|
||||
(CAI)(CAIL)(CAIE)(CAILE)(CAIA)(CAIGE)(CAIN)(CAIG) ;300
|
||||
CAM CAML CAME CAMLE CAMA CAMGE CAMN CAMG ;310
|
||||
JUMP JUMPL JUMPE JUMPLE JUMPA JUMPGE JUMPN JUMPG ;320
|
||||
SKIP SKIPL SKIPE SKIPLE SKIPA SKIPGE SKIPN SKIPG ;330
|
||||
AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN AOJG ;340
|
||||
AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG ;350
|
||||
SOJ SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG ;360
|
||||
SOS SOSL SOSE SOSLE SOSA SOSGE SOSN SOSG ;370
|
||||
SETZ (SETZI) SETZM SETZB AND (ANDI) ANDM ANDB ;400
|
||||
ANDCA(ANDCAI)ANDCAM ANDCAB SETM(SETMI)SETMM SETMB ;410
|
||||
ANDCM(ANDCMI)ANDCMM ANDCMB SETA(SETAI)SETAM SETAB ;420
|
||||
XOR (XORI) XORM XORB IOR (IORI) IORM IORB ;430
|
||||
ANDCB (ANDCBI) ANDCBM ANDCBB EQV (EQVI) EQVM EQVB ;440
|
||||
SETCA(SETCAI)SETCAM SETCAB ORCA(ORCAI)ORCAM ORCAB ;450
|
||||
SETCM(SETCMI)SETCMM SETCMB ORCM(ORCMI)ORCMM ORCMB ;460
|
||||
ORCB (ORCBI) ORCBM ORCBB SETO (SETOI) SETOM SETOB ;470
|
||||
HLL (HLLI) HLLM HLLS HRL (HRLI) HRLM HRLS ;500
|
||||
HLLZ (HLLZI) HLLZM HLLZS HRLZ (HRLZI) HRLZM HRLZS ;510
|
||||
HLLO (HLLOI) HLLOM HLLOS HRLO (HRLOI) HRLOM HRLOS ;520
|
||||
HLLE (HLLEI) HLLEM HLLES HRLE (HRLEI) HRLEM HRLES ;530
|
||||
HRR (HRRI) HRRM HRRS HLR (HLRI) HLRM HLRS ;540
|
||||
HRRZ (HRRZI) HRRZM HRRZS HLRZ (HLRZI) HLRZM HLRZS ;550
|
||||
HRRO (HRROI) HRROM HRROS HLRO (HLROI) HLROM HLROS ;560
|
||||
HRRE (HRREI) HRREM HRRES HLRE (HLREI) HLREM HLRES ;570
|
||||
(TRN)(TLN)(TRNE)(TLNE)(TRNA)(TLNA)(TRNN)(TLNN) ;600
|
||||
TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN ;610
|
||||
(TRZ)(TLZ)(TRZE)(TLZE)(TRZA)(TLZA)(TRZN)(TLZN) ;620
|
||||
TDZ TSZ TDZE TSZE TDZA TSZA TDZN TSZN ;630
|
||||
(TRC)(TLC)(TRCE)(TLCE)(TRCA)(TLCA)(TRCN)(TLCN) ;640
|
||||
TDC TSC TDCE TSCE TDCA TSCA TDCN TSCN ;650
|
||||
(TRO)(TLO)(TROE)(TLOE)(TROA)(TLOA)(TRON)(TLON) ;660
|
||||
TDO TSO TDOE TSOE TDOA TSOA TDON TSON ;670
|
||||
nil))
|
||||
;Fill in 700 thru 777
|
||||
(do ((8s 0 (+ 8s #o10)) (ch8s #/0 (1+ ch8s)))
|
||||
((> 8s #o70))
|
||||
(do ((1s 0 (1+ 1s)) (ch1s #/0 (1+ ch1s)) (n (+ 8s #o700) (1+ n)))
|
||||
((> 1s 7))
|
||||
(store (faslist-opcodes n)
|
||||
(implode `(/7 ,ch8s ,ch1s /_ /3 /3))))))
|
||||
|
||||
;; Local Modes:
|
||||
;; Mode:LISP
|
||||
;; Comment Column:40
|
||||
;; Atom Word Mode:1
|
||||
@@ -209,9 +209,15 @@
|
||||
(array faslist-acs T #o20)
|
||||
#%(let ((acs '(0 A B C AR1 AR2A T TT D R F FREEAC P FLP FXP SP)))
|
||||
(fillarray 'faslist-acs acs)
|
||||
(dolist (ac acs i)
|
||||
(or (equal ac 0)
|
||||
(putprop ac `(% 0 0 ,i ,i) 'faslist-r70))))
|
||||
(do ((i 0 (1+ i))
|
||||
(ac acs (cdr ac)))
|
||||
((null ac))
|
||||
(or (equal (car ac) 0)
|
||||
(putprop (car ac) `(% 0 0 ,i ,i) 'faslist-r70)))
|
||||
; (dolist (ac acs i)
|
||||
; (or (equal ac 0)
|
||||
; (putprop ac `(% 0 0 ,i ,i) 'faslist-r70)))
|
||||
)
|
||||
|
||||
(array faslist-opcodes T #o1000)
|
||||
(prog1 'faslist-opcodes
|
||||
Reference in New Issue
Block a user