From 4871f2a8b722536d3f01f54797cf88b1a0f88c18 Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Thu, 22 Dec 2016 17:32:56 -0800 Subject: [PATCH] Added lots of lisp libraries, most of them built from source. This partially completes #251. --- Makefile | 2 +- build/build.tcl | 87 +- src/alan/binda.46 | 221 +++++ src/alan/binda.fasl | Bin 0 -> 7547 bytes src/alan/crawl.18 | 152 +++ src/alan/crawl.fasl | Bin 0 -> 3695 bytes src/alan/dprint.142 | Bin 0 -> 19168 bytes src/alan/ljob.74 | 291 ++++++ src/alan/ljob.fasl | Bin 0 -> 8341 bytes src/alan/lspcom.20 | 60 ++ src/alan/lspcom.fasl | Bin 0 -> 4714 bytes src/alan/lspenv.259 | 895 +++++++++++++++++ src/alan/lspenv.fasl | Bin 0 -> 42311 bytes src/alan/lspenv.init | 68 ++ src/alan/lspgub.71 | 458 +++++++++ src/alan/lspgub.fasl | Bin 0 -> 23728 bytes src/alan/lspint.46 | 205 ++++ src/alan/lspint.fasl | Bin 0 -> 6206 bytes src/alan/macits.13 | 110 +++ src/alan/nstruc.280 | 1875 ++++++++++++++++++++++++++++++++++++ src/alan/nstruc.294 | 1969 ++++++++++++++++++++++++++++++++++++++ src/alan/setf.23 | 156 +++ src/alan/setf.fasl | Bin 0 -> 10747 bytes src/alan/struct.doc | 1422 +++++++++++++++++++++++++++ src/l/lchnsp.35 | 328 +++++++ src/l/purep.5 | 27 + src/libdoc/bs.jonl9 | 105 ++ src/libdoc/gprint.rcw3 | 1700 ++++++++++++++++++++++++++++++++ src/libdoc/sharab.jonl47 | 747 +++++++++++++++ src/liblsp/dprint.fasl | Bin 0 -> 21174 bytes src/liblsp/gprint.fasl | Bin 0 -> 70022 bytes src/liblsp/struct.fasl | Bin 0 -> 45629 bytes src/lspsrc/bits.46 | 379 ++++++++ src/lspsrc/funcel.3 | 65 ++ src/lspsrc/ldbhlp.1 | 61 ++ src/lspsrc/lexprf.1 | 13 + src/lspsrc/nilaid.173 | 813 ++++++++++++++++ src/lspsrc/reap.12 | 86 ++ src/nilcom/drammp.19 | 243 +++++ src/nilcom/lsets.7 | 77 ++ src/nilcom/sharpa.40 | 117 +++ src/nilcom/sharpc.74 | 338 +++++++ src/nilcom/thread.8 | 301 ++++++ 43 files changed, 13369 insertions(+), 2 deletions(-) create mode 100755 src/alan/binda.46 create mode 100755 src/alan/binda.fasl create mode 100755 src/alan/crawl.18 create mode 100755 src/alan/crawl.fasl create mode 100755 src/alan/dprint.142 create mode 100755 src/alan/ljob.74 create mode 100755 src/alan/ljob.fasl create mode 100755 src/alan/lspcom.20 create mode 100755 src/alan/lspcom.fasl create mode 100755 src/alan/lspenv.259 create mode 100755 src/alan/lspenv.fasl create mode 100755 src/alan/lspenv.init create mode 100755 src/alan/lspgub.71 create mode 100755 src/alan/lspgub.fasl create mode 100755 src/alan/lspint.46 create mode 100755 src/alan/lspint.fasl create mode 100755 src/alan/macits.13 create mode 100755 src/alan/nstruc.280 create mode 100755 src/alan/nstruc.294 create mode 100755 src/alan/setf.23 create mode 100755 src/alan/setf.fasl create mode 100755 src/alan/struct.doc create mode 100755 src/l/lchnsp.35 create mode 100755 src/l/purep.5 create mode 100755 src/libdoc/bs.jonl9 create mode 100755 src/libdoc/gprint.rcw3 create mode 100755 src/libdoc/sharab.jonl47 create mode 100755 src/liblsp/dprint.fasl create mode 100755 src/liblsp/gprint.fasl create mode 100755 src/liblsp/struct.fasl create mode 100755 src/lspsrc/bits.46 create mode 100755 src/lspsrc/funcel.3 create mode 100755 src/lspsrc/ldbhlp.1 create mode 100755 src/lspsrc/lexprf.1 create mode 100755 src/lspsrc/nilaid.173 create mode 100755 src/lspsrc/reap.12 create mode 100755 src/nilcom/drammp.19 create mode 100755 src/nilcom/lsets.7 create mode 100755 src/nilcom/sharpa.40 create mode 100755 src/nilcom/sharpc.74 create mode 100755 src/nilcom/thread.8 diff --git a/Makefile b/Makefile index b30d87d9..929fa5d3 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ EMULATOR ?= simh SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ midas _teco_ emacs emacs1 rms klh syshst sra mrc ksc eak gren \ bawden _mail_ l lisp liblsp libdoc comlap lspsrc nilcom rwk \ - inquir acount gz sys decsys ecc + inquir acount gz sys decsys ecc alan DOC = info _info_ sysdoc kshack _teco_ emacs emacs1 BIN = sysbin device emacs _teco_ inquir diff --git a/build/build.tcl b/build/build.tcl index 9579be62..0e8d4fb5 100644 --- a/build/build.tcl +++ b/build/build.tcl @@ -656,6 +656,7 @@ respond "*" ":link sys;atsign lisp,sys;purqio >\r" respond "*" ":link sys;ts l,sys;ts lisp\r" respond "*" ":link .info.;lisp step,.info.;step info\r" +respond "*" ":link libdoc;struct 280,alan;struct >\r" respond "*" ":link libdoc;struct doc,alan;struct doc\r" respond "*" ":link .info.;lisp struct,libdoc;struct doc\r" respond "*" ":link l;-read- -this-,lisp;-read- -this-\r" @@ -690,6 +691,7 @@ respond "*" ":link sys;.fasl defs,lisp;.fasl defs\r" respond "*" ":midas inquir;_lsrrtn\r" expect ":KILL" respond "*" ":link liblsp;debug fasl,liblsp;dbg fasl\r" +respond "*" ":link lisp;debug fasl,liblsp;debug fasl\r" respond "*" "complr\013" respond "_" "liblsp;_libdoc;tty\r" respond "_" "inquir;reader\r" @@ -702,11 +704,13 @@ respond "_" "lisp;_nilcom;evonce\r" respond "_" "inquir;inquir\r" respond "_" "\032" type ":kill\r" + respond "*" "complr\013" respond "_" "liblsp;_libdoc;dbg rwk1\r" respond "_" "liblsp;_libdoc;comrd kmp1\r" respond "_" "\032" type ":kill\r" + respond "*" ":lisp inquir;inquir (dump)\r" respond "*" ":link inquir;ts inquir,inquir;inqbin >\r" respond "*" ":link sys;ts inquir,inquir;ts inquir\r" @@ -759,8 +763,89 @@ respond "*" ":link sys1;ts s,sys;ts send\r" respond "*" ":link sys3;ts snd,sys;ts send\r" respond "*" ":link sys3;ts sned,sys;ts send\r" -# NICNAM +# more lisp packages +respond "*" ":link lisp;tty fasl,liblsp;tty fasl\r" +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((lisp) subloa lsp))" +respond "T" "(maklap)" +respond "_" "lisp;_lspsrc;funcel\r" +respond "_" "lisp;_lspsrc;bits\r" +respond "_" "lisp;_lspsrc;reap\r" +respond "_" "lisp;_lspsrc;lexprf\r" +respond "_" "lisp;_lspsrc;ldbhlp\r" +respond "_" "lisp;_nilcom;subloa\r" +respond "_" "\032" +type ":kill\r" +respond "*" "complr\013" +respond "_" "lisp;_nilcom;sharpa\r" +respond "_" "lisp;_nilcom;sharpc\r" +respond "_" "lisp;_nilcom;lsets\r" +respond "_" "lisp;_nilcom;drammp\r" +respond "(Y or N)" "Y" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((lisp) subloa lsp))" +respond "T" "(maklap)" +respond "_" "lisp;_lspsrc;nilaid\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_libdoc;sharab\r" +respond "_" "lisp;_libdoc;bs\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((lisp) subloa lsp))" +respond "T" "(maklap)" +respond "_" "lisp;_nilcom;thread\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":midas lisp;_l;lchnsp\r" +expect ":KILL" +respond "*" ":midas lisp;_l;purep\r" +expect ":KILL" + +# struct + +respond "*" ":link alan;dprint fasl,liblsp;dprint fasl\r" +respond "*" ":link alan;struct 9,alan;nstruc 280\r" +respond "*" ":copy liblsp;struct fasl,alan;struct boot\r" +respond "*" ":link alan;struct fasl,liblsp;struct fasl\r" +respond "*" "complr\013" +respond "_" "alan;lspcom\r" +respond "_" "alan;lspenv\r" +respond "_" "alan;lspint\r" +respond "_" "alan;setf\r" +respond "_" "alan;binda\r" +respond "_" "alan;crawl\r" +respond "_" "alan;nstruc 280\r" +respond "_" "\032" +type ":kill\r" +respond "*" ":copy alan;nstruc fasl,liblsp;struct fasl\r" +respond "*" ":link lisp;struct fasl,liblsp;struct fasl\r" + +respond "*" ":midas liblsp;_alan;macits\r" +expect ":KILL" + +#respond "*" "complr\013" +#respond "_" "alan;ljob\r" +#respond "_" "liblsp;_libdoc;gprint rcw3\r" +#respond "_" "alan;lspgub\r" +##source file is damaged +##respond "_" "alan;dprint\r" +#respond "_" "\032" +#type ":kill\r" + +# NICNAM respond "*" ":midas sys2;ts nicnam_sysen3;nicnam\r" expect ":KILL" diff --git a/src/alan/binda.46 b/src/alan/binda.46 new file mode 100755 index 00000000..56b8507d --- /dev/null +++ b/src/alan/binda.46 @@ -0,0 +1,221 @@ +;;;-*- Mode:Lisp; Package:SI -*- + +(declare (and (status feature maclisp) + (load '((alan) lspenv init)))) + +(declare (special *rest* *normal* *optional*)) + +(defun bind-arguments-&parse (pattern body) + (prog (pat x) + (setq pat pattern) + norm (cond ((atom pat) + (setq *rest* pat) + (return body))) + (setq x (car pat)) + (cond ((eq x '&optional) + (go opt)) + ((memq x '(&rest &body)) + (go rst)) + ((eq x '&aux) + (go ax))) + (push x *normal*) + (setq pat (cdr pat)) + (go norm) + opt (cond ((atom (setq pat (cdr pat))) + (setq *rest* pat) + (return body))) + (setq x (car pat)) + (cond ((eq x '&optional) + (go barf)) + ((memq x '(&rest &body)) + (go rst)) + ((eq x '&aux) + (go ax))) + (push (if (atom x) (list x) x) *optional*) + (go opt) + rst (if (atom (setq pat (cdr pat))) + (go barf)) + (setq *rest* (car pat)) + (if (null (setq pat (cdr pat))) + (return body)) + (if (or (atom pat) + (not (eq (car pat) '&aux))) + (go barf)) + ax (return + (do ((l (reverse (cdr pat)) (cdr l)) + (var) (val) + (body body `(((lambda (,var) ,@body) ,val)))) + ((null l) body) + (if (atom (car l)) + (setq var (car l) val nil) + (setq var (caar l) val (cadar l))))) + barf (ferror "Bad pattern: ~S" pattern))) + +(eval-when (eval compile) +(defmacro bind-arguments-ignorable (x) + `(memq ,x '(ignore ignored)))) + +(defun bind-arguments/ macro (x) + (bind-arguments (((pattern form &optional barf) &body body) (cdr x) + (error '|-- bad format.| x)) + (let ((body (bind-arguments-internal pattern form barf body))) + (if (null (cdr body)) + (car body) + `(progn ,@body))))) + +(defun bind-arguments-internal (pattern form barf body) + (cond + ((bind-arguments-ignorable pattern) `(,form ,@body)) + ((null pattern) `((or (null ,form) ,barf) ,@body)) + ((atom pattern) `(((lambda (,pattern) ,@body) ,form))) + (t + (let* ((*normal* nil) + (*optional* nil) + (*rest* nil) + (body (bind-arguments-&parse pattern body)) + (lst? (if (null *normal*) + (or (null *optional*) + (and (atom form) + (null *rest*) + (null (cdr *optional*)))) + (and (null *optional*) + (atom form) + (null *rest*) + (null (cdr *normal*))))) + (lst (if lst? form (gensym))) + (len? (or (null *optional*) + (and (null (cdr *optional*)) + (null *normal*) + (not (null *rest*))))) + (len (if len? `(length ,lst) (gensym))) + (barf (or barf `(ferror '|~S doesn't match pattern ~S| + ,lst ',pattern)))) + (setq body `(,@(bind-arguments-error-check len barf) + ,@(bind-arguments-internal-1 barf body lst len + #'bind-arguments-nth + #'bind-arguments-nthcdr))) + (or len? + (setq body `(((lambda (,len) ,@body) (length ,lst))))) + (if lst? + body + `(((lambda (,lst) ,@body) ,form))))))) + +(defun bind-arguments-internal-1 (barf body lst len ref-one ref-rest) + (let ((n (+ (length *normal*) (length *optional*)))) + (or (null *rest*) + (setq body + (bind-arguments-internal *rest* (funcall ref-rest n lst) + barf body))) + (dolist (opt *optional*) + (setq n (1- n)) + (cond ((cddr opt) + (setq body + `(((lambda (,(caddr opt)) + ,@(if (bind-arguments-ignorable (car opt)) + body + (bind-arguments-internal + (car opt) + `(cond (,(caddr opt) ,(funcall ref-one n lst)) + (t ,(cadr opt))) + barf + body))) + (> ,len ,n))))) + ((not (bind-arguments-ignorable (car opt))) + (setq body + (bind-arguments-internal + (car opt) + `(cond ((> ,len ,n) ,(funcall ref-one n lst)) + (t ,(cadr opt))) + barf + body))))) + (dolist (pat *normal*) + (setq n (1- n)) + (or (bind-arguments-ignorable pat) + (setq body + (bind-arguments-internal pat (funcall ref-one n lst) + barf body)))) + body)) + +(defun bind-arguments-error-check (len barf) + (let ((nlen (length *normal*)) + (olen (length *optional*))) + (if (null *rest*) + (if (null *optional*) + `((or (= ,len ,nlen) + ,barf)) + (if (null *normal*) + `((and (> ,len ,olen) + ,barf)) + `((and (or (< ,len ,nlen) + (> ,len ,(+ olen nlen))) + ,barf)))) + (if (null *normal*) + `() + `((and (< ,len ,nlen) + ,barf)))))) + +(defun bind-arguments-nth (n v) + (caseq n + (0 `(car ,v)) + (1 `(cadr ,v)) + (2 `(caddr ,v)) + (3 `(cadddr ,v)) + (t (bind-arguments-nth (- n 4) `(cddddr ,v))))) + +(defun bind-arguments-nthcdr (n v) + (caseq n + (0 v) + (1 `(cdr ,v)) + (2 `(cddr ,v)) + (3 `(cdddr ,v)) + (t (bind-arguments-nthcdr (- n 4) `(cddddr ,v))))) + +#+maclisp +(defun (defun& macro) (x) + (let ((name (cadr x)) + (pattern (caddr x)) + (body (cdddr x))) + (cond ((memq pattern '(fexpr macro)) + (ferror "Cannot mix &-keywords and ~S definitions: ~S" + pattern x)) + ((eq pattern 'expr) + (setq pattern (pop body))) + ((not (symbolp pattern))) + ((memq name '(fexpr macro)) + (ferror "Cannot mix &-keywords and ~S definitions: ~S" + pattern x)) + ((eq name 'expr) + (setq name pattern) + (setq pattern (pop body)))) + (if (bind-arguments-ignorable pattern) + (let ((n (gensym))) + `(defun ,name ,n ,n ,@body)) + (let* ((*normal* nil) + (*optional* nil) + (*rest* nil) + (body (bind-arguments-&parse pattern body)) + (len (gensym)) + (barf `(ferror '|~S doesn't match pattern ~S| + (listify ,len) ',pattern))) + `(defun ,name ,len + ,@(bind-arguments-error-check len barf) + ,@(bind-arguments-internal-1 barf body len len + #'bind-arguments-arg + #'bind-arguments-listify)))))) + +#+maclisp +(defun bind-arguments-arg (n v) + v ;ignored + `(arg ,(1+ n))) + +#+maclisp +(defun bind-arguments-listify (n v) + (if (zerop n) + `(listify ,v) + `(listify (- ,n ,v)))) + +#+maclisp +(defprop bind-arguments bind-arguments/ macro macro) + +#+lispm +(fdefine 'bind-arguments '(macro . bind-arguments/ macro) t) diff --git a/src/alan/binda.fasl b/src/alan/binda.fasl new file mode 100755 index 0000000000000000000000000000000000000000..7c4541e7ff46959fc549f1ee41f4155a1f68b815 GIT binary patch literal 7547 zcmbtZ-EUmQ6`#3xcfF}Ua-D>-2B%B{3Bkn4ZcH2qrP^J46DQbfXKfc^HX9W8FJP_ z`N`3<7Rt>&Zx;^~CrcB#@dmaYXyVETT`GLHP?|2tQcxbxP2@*&9L)}7Rhp#y{Nj>X zUA%Vf!YeDs&CO{}>Jx=hX|hC+OXB%c#nHiB>E!H0p*S-=xPL0wpeeje&*n>N<1L^a zd=jt0gT%v=kZ-5^Z8%h#kP}KZP!dtE3AvQ&Qfc2)Dkl1`s$2EVQ2f>=XeZVj1WLy|sD##0 z`)H`XNy_KQ3W3+T#ikPy5LG;>K%TP~WHy@xD4L@LhUMG5hjZUsyjtI!i-}OX)RB2Y zvd)YG!^zgfT8u4K-KNwwnC*hIn!fNTb%%8j9_XySud<+mMK??9+BEs)by}F5>FnVY ztW(Y@_MD8VC;V!sQg2WSK3^jnZw=M&?S%*F%4MZG&0ZYHq4_(0FfdD8am#K3@rp_- zKp@RWj~9w3XT}K9YW%@La~}Tv;^kLfUc7clzG?Ao&PM(ERB@(IV%V|krb?41i&HA0 z#e%%{AYdkPBc(|Z%N#{55cH@zYMn4FD(4-Z?HxJW=PJD*2RzRMZps1uZ!48Nh!=K) z>gRo+I4a;T=rzSvrOW_coQRvA18{^xI3>xyTYI{!d_wPWqxV!cp_J^##lLfsl#Rqv zh5Veqye`%O(yCiNneEH#nUx0J_i4qOawu6wd7l+U08lAG;F5b5^#BfE)rcB2A~E*L zd8K+~Qe_V${J9ub)ZSO>w?d8#e_$SgiHWU{X5YrA*juFF>utwpH~xZI86LcjX{u^_ z<2A0jD=MkhiKb7TMC@{Ca4ygck@@J8h2r$t34$_lW_EH$ z$oV&?&C=xyS63drW?(lje7~6>8u&8oE)nYO|2JKKMADS56VFV=l5LB=8jEq+XKveqyB3r1nek!pu9QJKwVUFPt zvvA4EQbO670CK92k>&nyNuTT}L$@1}UqVH~9WC&+_Bh(_aF6IlCLfZ(<;aU@B4`q` ze4S4OZe7ShM$Q`!5dtAm8D{jTN|8x~>1Of?hgx`%jr>?M?FVBA0yPW`(L?q2+Q&9O zX-!Y+;nb&rKd9hysEqoXI3?i+>=_}sj&_DNZa7@hLsD)8Oeh&$vscp^_(A&c77 z!^8BOlu0YvpREJ%|ugdyaPTUB&7gPQ$9NJ^0_34DE z03#EoM~;q>$Y+Ee4Dh0NnH|0Hhx;8m?a(?#Eunl(gceDeN9b{stsIIb(_@F7O3#CE zuXr(D%j@{ReS?wwE}=E}xkie_rpzEdQ{+RaHUi(${3&RXT)-TEZ#XLzgudcrN3Juf zPc0x~BhQ8$+ms&;ZMGME%Qtw~f;fZ7sYT>6D?}r;fUms3dXCHrKgY7LA1diMUs>^& zaLfL$%N5b?2wECkr77F~$mWhKRt~nXItWOmQ(XzfF+^q=Mj%&agjr|zzDu(v!*$3% zqbxHHs26x5Ju->tE6{g1Ezm?^;*5pHc_rBRrC;CVr93pRcPgSfoxiDXR=+Zfz!+DlC`CDto=mkKhHB#_^LZ- zsT##-Sz^{nr#<0hCE?WGR{GcT34?@_#4CLQM3Oo$2}i%*?t=-Q^pa#URw%Ci0PO`| z_M!ythy*HEuGa55Jx2@x0XCbq+_99AvcoNA*yxfWC^sB4t;Z6gx=e%=U3rgNT=l?# zNi5%f9d5VO;&vkSEpS_k9N2uq*mJa936RQ~L5gN{jQsV=mg$tT7H*>lXQTYNV^QUI zyR+w28iGVb#nY}5BPtPLR2G$b7@I#t5Hn?h%%-`VASUTLk z3Dax@T;Z1VT-a{lQYUox^w&^~JG0|T*!W7tw77%LYF`wCYY4(9s!CgAx?3M@Zi*!Skif(J~<#Zf!x0T>U=EyzXKGAp6k#FCGb0QVM zuaf?UYyC*F)DmtXsPZ(x(R7yTdLA6oUo)8k0oX zRPf#$&O+hTaGF)F7w*x*L0DsM=?#%oCLF+A6UmTNADw!q8w%t&u*T4S4!Ta{_>VdQ zrpJJP=H)}%7aHY6NYrj5BVf3nAY5wzOQvbFo?LW~x!xY6Sg zjKhb(n=F>{g&{c=E|ERH84h9c;MnY4MN~n$*)4bcbn5Ou+M6>^0=%Mlt4@g61C2$ zm=lHPr%L?3ZDes}n57FZUR=3&?c(K?tI}O3 zh9;_T@ju`S-ynik->K=DQzy<6#uM$fpk1%j6lb_)wB_P(#iDGr$wt+jzknAzdh?04 zVMWDu^~!|vYeIhJgi;Ssv#-^9%hEIP*3gji?p6Yo$w@VVb^b+JEZ4Z|vp|#nCj8ak zod$si326|~D3!T+H(q88b^dAaBg;$=pxQfSze9Qkrsqji)M&C}AEqgxEA}{gq5U9?4s}ZN1OM{wJ1Bl7j|}=ZtO_uU6|V@chPleQnDn$FBM2n ztan^lMLyaqAKP|9x7t^=x6A%v*LylL2GS6kzun!~k*n54w#ew}Nazx&Xj*EoDVb^d z{aBaDgcyB1^Rf)dy;&_jzXP=)?KSMQ^HcU&WZM#E({p{FbA z4-9aDcZEYOE-rC<9Z#mW)3Fogg)-L~LAvFjzTiU7^N(;(M zH?y|CwnbELQG1dXJKFL{bX_Pl?jaTIGr~riw;%4 ") + (setq frame (crawl-find-numbered-frame frame top (read)))) + ((#\form #/l #/L) + (print-crawl-frame frame)) + ((#/q #/Q) + (return 'done)) + ((#/i #/I) + (cond (flag (inspect (frame-stuff))) + (t + (terpri) + (princ "Form to evaluate and inspect: ") + (errset (inspect (eval (read) (frame-env))))))) + ((#/p #/P) + (cond (flag (describe (frame-stuff))) + (t + (terpri) + (princ "Form to evaluate and describe: ") + (errset (describe (eval (read) (frame-env))))))) + ((#\alt) (setq flag t) (go next-char)) + ((#/? #//) + (princ " +CRAWL Commands: + +U - Up a frame +D - Down a frame +T - go to Top frame +B - go to Bottom frame +J - Jump to a numbered frame +E - Evaluate a form in current frame +R - Return from current frame +C - Continue current frame (start over) +G - Grind stuff in current frame +I - Inspect +I - Inspect contents of current frame +P - describe (Print cute) +P - describe contents of current frame +Q - Quit")) + ((#\space #\cr #\lf) + (go forgive)) + (t + (princ " ???")))))) + +(defun crawl-new-frame (old new) + (cond ((null new) + (princ " No more.") + old) + (t + (print-crawl-frame new) + new))) + +(defun print-crawl-frame (frame) + (let ((prinlength 4) + (prinlevel 3)) + (caseq (frame-type) + (eval + (terpri) + (princ (frame-n)) + (princ " Evaluating ") + (prin1 (frame-stuff))) + (apply + (terpri) + (princ (frame-n)) + (princ " Applying ") + (prin1 (car (frame-stuff))) + (terpri) + (princ "To ") + (prin1 (cadr (frame-stuff)))) + (t (error "-- wierd evalframe." (frame-type)))))) + +(defun crawl-find-numbered-frame (old top n) + (do ((frame top (frame-down))) + ((null frame) + (princ " Not found.") + old) + (and (= n (frame-n)) + (return (crawl-new-frame old frame))))) \ No newline at end of file diff --git a/src/alan/crawl.fasl b/src/alan/crawl.fasl new file mode 100755 index 0000000000000000000000000000000000000000..5e6023d4ede2cde975abb53d91e8d4522b79513a GIT binary patch literal 3695 zcma)9&2L*(7C+Z7F-~H)FHK85s(?$TElG%5r%?-2p!L^l#>F_!i`_yx3%iM9JZk(h zj!hYaAd8WrSuffdwgoJbH==KRic{G0%zd6A-f z&i$S5bMC!<^w+JIM%s%-TKN8>kNipEPg%F(nHzTeHH%Epy-y|W`0Y$2Ge4heG1Dbw zwOB~lH2pF&TV!-PdK|0bCaFM}iqYv8iJrticX#*CEbEcp>PoD#6`;EmeV(CD=z$_p zoBq-1v`R$AE>n}*S9$neWSY0}`SnDANK=pk`aIKZHQRa2kS#&LvCBG9B-;Cw`Ox`o z+hlbtV-VCm1?`V@h?n1A`U9yYqq23!$J^q%KF+pw|II@{hhlr|? z3%nEMo(LnGr}m3Go$V#`t2C|aJkQ1@glj-SNO&zjMU6W~<>CEaZi2Eg&R}Km)IOol zvX(XYM_CrM3_6f)adtgy?~U zhj<<%9+3)CIOsPd)m{hw?^UZA91$J}cV z-}`ZI0zU)5-+K6GA->c*GY|JN@RtGj4W)_{hW>LPi>UES(p&mG_e`I;P5K2!VOuGM z!&*h4!w;cltggrkiq6B2f5Ar?P8NujL;wTyJ8b?31zLc>n<)RcI9c7J6u65N)1w4% z6_DQooW|;%z1D1}gO!7leD0ORApcm%tBaHb8CA&W88I%E^s)M9#0EL*JK`q~iY_vmL%v=_9Pc7u6TDJEiEZ1Yq5)E|FG?E4IMQ>T z4NUg2A)3C zL_srvIF9QnoNg!hT0T@{K47@M*8v%Y#KrAV?kkWdP@{7a5z=IWcM9N;tdOulte!Lm zbjk3PGLOz6{J(fS)*YqXUc0Kv z+Z72H!hF(^YyG=@venwgdU?44(81?v>BFs*H~G zSw1YSCpH=-5vVt`^H#Y&IXuVUxq6k;ztL!}uKw5{9!bc&PP-`{ez|n7aV_mJ^fKFG z2RF2{D&|DM^Ek)QgS6|39NTIztWlnHHRZJ6`!GlKd8!sz)k3pM(==){Af~Thzs}E` zAl`*RipY3is?_BaDI1+!z^Npkp9imqr?1LS@ztW_aMX+;4}xCpe^XxICz;MVdd;bq zFR-C$ye`9PUhYZUS%$2jpH;Ff-fbBxJD2};A9>5lfa<;hld|rSc;r!GA`qK_J{8a9 zGV(0+MI!oswOn73A(2jm2Mn=nd){_Wg5gbiN>A{MLP8LSTI|R(k7!`bpb(F*T-4tC zC7R%C4#WLVIgj^aJN*3TN7}R7w0v?5p1DcCgzP6G+nV8v z$5Vi0*Lt#ibsfmMVAlLa%WsS-f$Vg$(Xr^_1ef{3=y980*0h7NIEq)|%K}~gw#fr*nAFK>LZua+v z>|Ti#`60)lezQ#_ZWRt|Uw-9yJ%ruwmX0${ALCZsTjX?tw@X3I&#i-BU618KAYf_2 x{UZNDlAlxHeT~?B(J+m?Ek~yWh}c5hj(iq4&DzQZCb=V4(EO(Q@)3S%{s6wkV#5Fc literal 0 HcmV?d00001 diff --git a/src/alan/dprint.142 b/src/alan/dprint.142 new file mode 100755 index 0000000000000000000000000000000000000000..68583dc23075386ca37e5e25eaddd285eaf4aaa0 GIT binary patch literal 19168 zcmeHPYjYb%cFk9+@*{eoDr3ksDB?u`q}E<}t&NpcWJjXnY}ww_5EzhS0W%OVkVrrH z+jGvn-90_P0F+!wDj&>pLBMq1_p=}47tfxX&al@Rb%y4S-e^#T1;eL(@Cly#r^8_#-EY78`uVdL4b$z9 zIwA0Bw>uo2P>{|L-$$pz4Z@b+M!VNA{cbma9rWA7ez)IN!rgAae_Dlo{Uro#oSuT^ z_G!rSpxtYaPP!uzw~KFEkk3TXebDTjw4u>b%l-b~w9{(?U1xYQfC)Ajer-Vq1f^0! z&|&*@G!j|+qyEVj=!<7xJ^340Zueo_A-MCfaE!sAGdhLt=p+LGZ^-Ikzo3@;qfrI8 z-Rlj&_%2`?mSh`7Ch zg)_8!U4~5+a@Y}OPdlgWQN3!1RFL?11+qO<1?_&{$p(DVCi3#(WAbO&t9z1c=@4x-}<(DA)38ok_E_I6OR*dDB_E zFf#n;e6m=kS?9~?yU{9Tfo*fb0NTI7o#&0;s~D#<1(=#;>jDGDR7 z*UOoFFAfh5&Mz*`%;PLxUada+^i%r<_~Qw{3v&V*oOEUuIao@TrpOH^TZX_-2S_pH z$(ebR+~V;#PBXHZyj{mLuxg?omn&kz19Fb>gyWCSRLWH{o60l?D3AHXLoSxWx0?V} z6|3~8Bt*_<7Q0Y?bapk(m-D!2dHj}*tLfa$w0yk3PRG}+e32~UBF(c^g`2uT&zKB` zWRrIrGQZ;}OqZ!P3)T6VX_cz}aU9QPrhRIfbdJ*c*_$kXpS9-6Y878W*auMHL9|MW zpWp^W3*(vvEXnWIA28`12HvEL7&>m#-piyoff2m>oa_Xp4iz|oxw_&kUR0v7vQTY; zTAk8dnw~lqX_&F;>#vYKm9cA@*0r4pTi5IC4Md|+EH;mO8@}z~opCL=*x_T~x2^gB zPPU0b!@rFjqHstbHh-)$W0gySCb~A5k;HQ|OWq|jvzo=L>vVeCS{yzg zE>Mr6EP1b^QTvZN57-W(BAMe~p*ha82`0w;T;0wu^BJ<#I9{4-&J=fiYcOBsu_LCb z5|ELWgmbbapOhn-t}}6X0y!Ra?BmJQs!tiK9rBu0356fk#AUon%+T@(E{ogTJbd)f z>d>2j!nB%;PuN8X_OMaVIpLAzLE_aH5#Qkpmx(jki%bY&EI$zH|6! z4$diB`Q?wv81^0CED^|{=y8-@5JF9Im^ejD(+yJ5AB_)-Bg?{*U`F`{n}f7?V-)?# zq(-u^K2nW+zgooOB)|u%eL6LfXgdd< zO>b5LjLJGMwh2ckWrWAfSvfV@_IOk4g2Jz87wtf`N|~@EiZ>L-B}!J$cxJS|l;Emc zmbg9hw-pqoPp2G>18C?z6#$($hfNKl4DsJ7y@PJ!LVT)O0#Bf?fBCEV<>z+uyXMg^ zrDrMtCe*s%F8@Q~q6Hp%4|HgNh-5x>BL+Vm@Jd!5^mFI zwajZR%ElIDc0-Jg;|4Nnx+;)gP3CdGLz+C=EO_I5ofStV_04gcw4>EDHu-|R7S)Yk z2j}TkmM@bDe&T8P6Arsd-eS5Mh7rO(;q5N!66d=(bLQO&q9#MnjY9pUR@T`npQYop zNG4#ywo%lL_uf~3eF7cjXjq-%Yn7wIA5rI!xHU%oDiU8v9k!O$(aEk6N24r>9@N#w zJw5ElZ4eMTwu~c;X0aGQa*@U&p%2l}*@v)uv?}6a zy)v?1INWR_xrjh~pj3y`OqQ}aFQ4jyVe=^~bt-ddxPvJAFmf{0*R?8t7?b=(R20TE z(fB0qi5`+vc-&}+tt90v<+(abo>g!KGO)LSUS(l`)lK8>le-64vi&_@oB0}xlr@@w z;yN*}{_^tax5^!A#w~{5r>kpvwD8I&OD5ev5IVX5#Oqftzk2=RZ)OUQU1PzQu1q|G z`%Z4L$`ibow`P^k6O)6$(m>=Q&5jQn)GNHgnIF!BZV>rU+QG}DC9AG1p0$_|5P=I+ z*D2e7{22o$7)w*bViT`tMa!*IAk+ zGx?U>V7+H4%Yz_k)pJ+RbeYBK@)W&fo@VQn&2`o}{=^(-9)7QDL#a2c-tO_3OJewo zrwCS23xfxt-ddq3BD#r)?J=V0I$kdF)h<9)jB2YSR>3U_Q>4NsvoCqyF+ISjVQ^Gj zFZ1_Y3UC1ci__3p5E1^F;wkt*JQ0tG8tcBZLI!Uoh@)54sAG@ zcEMFI3o(?w!v?V}ZiJe8G>(h$b=B2GiSR^e)7u-KOPrxas(1^B*9&T+(EkR!`tbe4 z^DCq%;r3o082LWbdM6vI+T_;;5mApF!}ls;d@mFGgHyWkw(ZG$^0#{S8^Yiyh^rA2!dhLl;-OKgW>e%|aql!X@9oI`F|M6sL*Rl?W&QY1|9EhXq zT|b94L_+#Aqcb&3oqw{x=yRS5QDk;F?8`0Q#WKHY8`W~ilngW0@TVr%#hEiHGnvW~ zZJDvv1{u|eFY5VzB&x(^y{Q$ZQ<*Vi$ zv^TaohUir}+u-4xYV9xa1gXj6<}+xV8+B8zPy9fdO_B^vHa6$54A2Q|)E!e>-G{|) z%rJGqJP7>_psqIf(>KXU7E+=Dvl(eJtAq50Tn39DX1jvZFSA2 z-brA?6}uVG84}B*N2Qa5PBc8k8oVWw@J&rc2+A%ST-3S8s+t5+*Hr%)^_B7vTq~K!Xx&5w-_Af)*i8`}uou0xA#*)3)8ACI29{^4 zPF*D}nj7+M^{SF|ONOOqr%83b+L!)^Z>!QZklIfSE?;1xgi7FpEpejg20IlKqOooG zO=&C36vt?FY4XZp?_!Pzv5DJXzfqmz>;qM2VeC)oiA}?ppO1cRY!UK^?1IT_Ok=wG zQ{z}|W8JqpLAE=qkJJ}SC5E{LhmsWjNN*+0AEhP>OUz$gh=G4zg7!$f;7jEwhWOzvD_>pau1L$SX zu_TZ&dz5%;XNyoOEhans*cfn_A-V9OjEk%LS+Ywjib2)V&HlK^=hRhzOI8VZ#5qpf zn{a|YBowE_%Vm5^4F)LWnVsONmsW*N-EN^D)mWfLxqbLbcKR}7kKFPpk|eh1?p_@? zIOT>PvTH}eq7%OY^BBEO!eZb@>odI9s1H7y-+jG+$R3B|8J6(JJTAW@uM14Kn%{q0 zdiNB428RNEYjXeS)LzqCmO9v0T_VGBw?Liz&u8W)(A?-APV+U+ehAsALl#__t z77Mv4gLpYK9-<%tKKonnGGd4dq9up1aYBVYn-ow>s zdI@6Fve+i@+m7fZQrzgV*K}y1>OC9{gAWRm4HrvmoGOLU_q!836IYB<_EgqK>=He! zHPWV4df8nDst*l@M0EEFQjl;{@7OM;vF4JX_9VEqEBm{){o3lYWkTpadKrr)Ygb|? zM?AS@SIK~|y=hq$?twk_((DlCM#b1+$bdWodLNTkXFI6aG-zq<)Yx{zYWr$yQ|&0z zq9v#K+eZSjK<9lOyKHPm+;L>F#kFC+XTtT$1&fur%yCL{<$SKL2#a-LP`Q@qSq=l8 zDSfvi*@oSy2cS5*Mz!B00$MTPkESaL=*R=!o;-b~fH7-{&3Lbtv7z~&z z73m&6&c3^Qb$9-(xch-A<;B+*SakBdJ(RGa5;0s|rC&|h=h zJ&GYi%@tW%fu~EXdSMFic4ksm)n(yZ9QcDle1bc|veCuX zrhK|b3oXKOISi#%f3k5IPY~8TdlJr&_M&XYjcon~Dt2gMEpc(V=%N#w5%vMo_;Q9L z>U_Lrk0rbM0tXrKS9z`!bRe_XIf)L)b0hskb)J!_SeY^zI4gO>0+ttdI3ru)E-r44 zlry9b6BKC#Wpjoi+~mb>V3g0Pd?q)GC9am>Qw1aoayJ-JgGFsnAFVFmK?-fFfv;X< zJ2RZPAv&~6Lctar?WM-5_iQl-J4N;GyCdh{F#--J40E?IJ}AALBYcrzlNP!IC51gk zeAj6puq(QE(grZP8{0|Sg?UJyggp658enpFQ7EojnW{M`So_d*RjX9m9t~l*K^1*+ zcW%tx4^~^Es{*$tRxaXH^`5fl#byKy)6w;2sMI*&z&y+cgH!76U=I@qjkv&iB1V&o zzS`t9KL@ zd0j|N*GsuF<_IT~Gj>86FTq}x8&}4Jh@ED)&?F6o#CMRUeJD>E$lHqh4XPq#r;;s8 z3&lzfK*!*9Ue<* zejWGrwMx;UnfSeF_=1IIe*a8eTw8p6)-2(b*lnuWvlV7`YQy5dqCig1Fm5A-C$?l(+QvVh@T#d zH&^5upr2J9TdT!K;u^=cAhr=iu2A-6mn)r1GlS|p;aBNs zU`=!}^bkat(Apl;#^V+bv$fc?s=enUK{qDbmLBAw-0pMqBolG;BjdeqN z2TO28lR;y-Bp4qcFQZ2?ZGlZ{x}mrQE$HI=k?8 z)y;7uD>~8zVJ_#S^IKuZD`ke3Qsrx^jd#Rqj?31GEb`2A+eFIEKFO&#)h6hkjzF2^ zhAVcmw(FjfR`}Y*EogNe1<8A%+HvU=H`yi$*kG1qeT}Yi^BnSsKw(4hN4$Yov->BV zI4gqu!7Q+2O`ZW6M+(Zr-4-cFWg?bVB(-*>hPf|O&#IKDlo_5a4KN9-t~BFb7G4t+ zu7J*t0iR9%cwjs^lGE(W={&j{F?l+0hPEHj{)#S)J32_i2h2 zHe-u?d24mSyzE9mLi7_pgX;ON#)~AGpzF79X{^rp%tt8CT7aX7GrYnGe~mF>50qq{ zC=0t)>e1c?mh7H9?-`SuK?jlhZAGA`L*m*@tqVNfya_t}x}!{=YrR3dT)Zx-*Q{*J z*dXzl$&c4vx6w;K)^9Xmae_j=YHlgvO;cWeLU$rxFwa^GcbWWm=^e->Hv-|MU*doK z0hjUD0h@o(Vf$%2LutWk|M$fUZ;l(pgfqE~2DKRE0A;RRH6dE<4z9cd TjsFo7FIlirlfcu=>B#;!YiB96 literal 0 HcmV?d00001 diff --git a/src/alan/ljob.74 b/src/alan/ljob.74 new file mode 100755 index 00000000..0fbc8541 --- /dev/null +++ b/src/alan/ljob.74 @@ -0,0 +1,291 @@ +; -*- Lisp -*- + +(declare (load '((alan) lspenv init))) + +(declare ;; HUMBLE + (*expr select-job kill-job load-job + deposit-job examine-job + job-uset-write job-uset-read + *atty *dtty) + (*lexpr create-job) + (special current-job) + ;; MACITS + (*expr %getsys %sixbit %unsixbit %squoze %unsquoze) + (fixnum (%sixbit notype) (%squoze notype)) + ) + +(eval-when (eval compile load) + +(or (fboundp '%getsys) (fasload (liblsp) macits)) + +(defvar *uset-vars* + (do ((l (%getsys 'usyms) (cddr l)) + (a nil (cons (cons (logand #o37777777777 (car l)) (cadr l)) a))) + ((null l) a))) + +(defmacro *uset (var &optional (val nil write?)) + (let ((num (cdr (or (assoc (%squoze var) *uset-vars*) + (error "-- unknown .USET variable" var))))) + (if write? + `(job-uset-write ,(+ #o400000 num) ,val) + `(job-uset-read ,num)))) + +) ;end (eval-when (eval compile load) ...) + +(eval-when (eval compile) + +(defun convert-flonum-to-bit (f) + (or (floatp f) (error "-- non flonum argument to BIT or BITS." f)) + (do ((x (-$ f .05)) + (y 1.1 (+$ y .1)) + (n 1 (1+ n)) + (i 1 (lsh i 1))) + ((zerop i) (error "-- bad flonum to BIT or BITS." f)) + (and (zerop (\ n 10.)) + (setq y (+$ y .1)) + (setq n (1+ n))) + (and (< x y) (return i)))) + +(defmacro bit (x) + `',(convert-flonum-to-bit x)) + +(defmacro bits l + `',(do ((l l (cdr l)) + (x 0 (logior x (convert-flonum-to-bit (car l))))) + ((null l) x))) + +) ;end (eval-when (eval compile) ...) + +(defvar *value-handler '*value-handler) +(defvar *break-handler '*break-handler) +(defvar ljob-job-jcl nil) +(defvar ljob-debug-p nil) +(defvar ljob-search-rules + (let ((sr (cons (status homedir) '(sys sys1 sys2 sys3))) + (udir (status udir))) + (if (eq udir (car sr)) + sr + (cons udir sr)))) +(defvar ljob-hang 'finished) +(defconst ljob-start-addr-addr + (or (getddtsym 'j*stadr) #o71)) ;educated guess! + +(defun ljob-interrupt-handler (job) + (*dtty) + (select-job job) + (let* ((pirqc (*uset *pirqc)) + (xpirqc (logand pirqc (bits 1.2 1.8 2.2 3.1 4.4))) + (npirqc (logxor pirqc xpirqc))) + (cond ((= xpirqc (bit 1.2)) ;%pic.z (call) + (*uset *pirqc npirqc) + (stop-job "^Z")) + ((= xpirqc (bit 1.8)) ;%pival (.value) + (*uset *pirqc npirqc) + (funcall *value-handler + (logand #o777777 (*uset *sv40)))) + ((= xpirqc (bit 2.2)) ;%pibrk (.break) + (*uset *pirqc npirqc) + (let ((x (*uset *sv40))) + (funcall *break-handler + (lsh x -27.) ;not necessarily .break! + (logand #o17 (lsh x -23.)) + (logand #o777777 x)))) + ((= xpirqc (bit 3.1)) ;%pilos (.lose) + (*uset *pirqc npirqc) + (error-job ".lose")) + ((= xpirqc (bit 4.4)) ;%pidcl (defered call) + (*uset *pirqc npirqc) + (stop-job "^_D")) + (t + (error-job pirqc))))) + +(defun ljob-channel-interrupt-handler n + n ;ignored (what is it anyway?) + (*dtty) + (error-job "channel interrupt")) + +(defun J (name) + (create-job #'ljob-interrupt-handler + #'ljob-channel-interrupt-handler + name)) + +(defun L (file) + (let ((v (load-job file))) + (and ljob-job-jcl + (*uset *option (logior (bit 4.6) (*uset *option)))) + (*uset *sname (%sixbit (status udir))) + v)) + +(defun gzp () + (*uset *upc (+ (boole 2 #o777777 (*uset *upc)) + (logand #o777777 (arraycall fixnum current-job + ljob-start-addr-addr)))) + (^P)) + +(defun ^P () + (*uset *ustp 0)) + +(defun P () + (^P) + (pass-tty)) + +(defun G () + (gzp) + (pass-tty)) + +(defun pass-tty () + (setq ljob-hang nil) + (terpri) + (*atty) + (ljob-hang) + (*dtty) ;doesn't work to .dtty while interrupting sometimes? + '*) + +(defun ljob-set-jcl (jcl) + (cond ((null jcl) + (setq ljob-job-jcl nil) + (*uset *option (boole 2 (bit 4.6) (*uset *option)))) + (t + (setq ljob-job-jcl (maknam (nconc (explodec jcl) '(#\cr)))) + (*uset *option (logior (bit 4.6) (*uset *option)))))) + +(defun *value-handler (loc) + (cond ((zerop loc) + (error-job ".value")) + (t + (stop-job ".value")))) + +(defun get-valret-string () + (let ((loc (logand #o777777 (*uset *sv40))) + l) + (do ((loc (1+ loc) (1+ loc)) + (cs (examine-job loc) (examine-job loc)) + (c) + (i 5 5)) + (()) + L (setq cs (rot cs 7)) + (and (zerop (setq c (logand #o177 cs))) + (return t)) + (push c l) + (or (zerop (setq i (1- i))) + (go L))) + (implode (nreverse l)))) + +(defun finish-job (why) + (terpri) + (princ ";finished") + (cond (ljob-debug-p + (princ " (") + (princ why) + (tyo #/)))) + (princ ": ") + (print-job) + (terpri) + (kill-job) + (setq ljob-hang 'finished)) + +(defun stop-job (why) + (terpri) + (princ ";stopped") + (cond (ljob-debug-p + (princ " (") + (princ why) + (tyo #/)))) + (princ ": ") + (print-job) + (terpri) + (setq ljob-hang 'stopped)) + +(defun error-job (why) + (terpri) + (princ ";error (") + (princ why) + (princ "): ") + (print-job) + (terpri) + (setq ljob-hang 'error)) + +(defun print-job () + (princ (shortnamestring current-job))) + +(defun *break-handler (op ac loc) + (cond ((not (= op #o45)) ;.break + (cond ((and (= op #o42) (= loc #o33)) ;.logout + (finish-job ".logout")) + (t + (error-job ".break???")))) + ((= ac #o16) + (if (zerop (logand (bits 2.5 2.6) loc)) + (stop-job ".break") + (finish-job ".break"))) + ((= ac #o12) + (let ((req (examine-job loc)) + type) + (cond ((not (zerop (logand req (bit 4.8)))) + (do ((aobjn (examine-job (logand #o777777 req)) + (+ (bits 1.1 3.1) aobjn))) + ((> aobjn 0)) + (*break-handler op ac (logand #o777777 aobjn)))) + ((or (not (zerop (logand req (bit 4.9)))) + (not (= (setq type (logand #o177777 + (lsh req -18.))) 5))) + (error-job ".break 12,??")) + (t + (or (null ljob-job-jcl) + (do ((l (pnget ljob-job-jcl 7) (cdr l)) + (loc (logand #o777777 req) (1+ loc))) + ((not (zerop (examine-job loc)))) + (and (null l) + (return (deposit-job loc 0))) + (deposit-job loc (car l)))) + (^P) + (*atty))))) + (t + (error-job ".break ??,")))) + +;;;(ljob-hang) hangs until the value of ljob-hang is non-null. +(deflap (ljob-hang subr 0) + (skipn 0 (special ljob-hang)) + (*hang) + (popj p)) + +(defun ljob-run-job (xname file jcl) + (do ((name xname) + (x (J xname) (J name))) + ((cond ((null x) (error "-- couldn't create job." xname)) + ((eq (car x) 'inferior) + (let ((file (or file (ljob-search-for xname)))) + (cond ((null (L file)) + (*uset *xjname (%sixbit xname)) + (ljob-set-jcl jcl) + (G) + t) + (t (error "-- can't load file." file))))) + ((eq (car x) 'reowned) + (P) + t) + (t nil))) + (let ((l (exploden name))) + (cond ((> (length l) 5) + (setf (caddr (cdddr l)) + (1+ (caddr (cdddr l))))) + (t (rplacd (last l) (list #/')))) + (setq name (implode l)))) + '*) + +(defun ljob-search-for (name) + (do ((l ljob-search-rules (cdr l)) + (rest (list 'ts name)) + (file)) + ((null l) + (error "-- can't find file to load." name)) + (and (probef (setq file (cons (if (symbolp (car l)) + (list 'dsk (car l)) + (car l)) + rest))) + (return file)))) + +(defun ljob-expand-run-macro (x) + (bind-arguments ((name &optional (jcl `nil)) x + (error "-- wrong format." x)) + `(ljob-run-job ',name ',(get name 'ljob-filename) ,jcl))) diff --git a/src/alan/ljob.fasl b/src/alan/ljob.fasl new file mode 100755 index 0000000000000000000000000000000000000000..615a5aff3e7dbad74e9e8a2f67f05e558eddabd7 GIT binary patch literal 8341 zcmb7KO>A7(b-wq#nc*m;q@ieAL(7SuB+`;c9Eu~7l5JYm{5_H*4QEF4V^I)K&p1>#wqez^ffP*fIwpnDMplAW_noYMs7YWerx@b0O5fqKb){rrx3e)d9 zclaJT6&iN{KAn5dx#ygF?)kg#>5HFiO!c-Zb#<{8tHsuvN-13|o=atNRiPCwoYaJDLRN%Bd2lYs zIr|IFao9shhW5t09W7D?2&%mXeSuTDQgSo7R30D~*s)s0t;XL-l`Ao#`3vx2B$8xL zghP4Akl3IMMHuDqr@g(K&4cYlgUF}m(%BSYuGbW8Ab+k@F3u=gv?e4oV`F2J0%eNO zUZ6rPFDsQUyVY8`;Bn#FQ-(O3EgNDis~9Lh8lk=#7B_Wy@YxQ?f0-@&WVhE0(*!ZAk^cL?Dbd3oQDw3 z!tYtGkY6vK{@ReN<>R0{i0vaZNa(kO4iPddB7iIo_wixorUg)N}%9UEiNcb1ajd2Wtv}I@*F~@Nb(}*BZLkU z5`8R>ao#P=RA-40cJa8gxNyUHYxVBi3-?EjFt=PTmWkC>(($Kji4`y)G|++z z45%cWW8@W>pN}IWuPlG|{*e)oG*^`xeq4XlZVUUC4QOi$TrA~i_20h&0W*#*63--;Hz@x_XB2az`=CxseG0}D8wXD@W}+EN))$;1 zXyMJBafXz7R)(NbgT4qVm9is!A=@KPwDw@1PbL0$2$H>62i8|EjdYTmI?x2umlf>u z98Rg@U$Hk*`I;M_MTX70Ws3bnxszPtSgy1e5uB1_Yf_6(A!I-*iS9TN;&MCI?_y%d z((tzn{~vY8{h-M4IIU0BRxVN24xM~5UniLpoqVh?@i+-G&-jqPjLF_#$wVhb&Mr&^mSrQ%jB(<#=__)bN<7x zBlK8=^$dA@m6)CqErgTDWI9*KRc766$I8^nH=$V|t0+SJcZwuZNWbB;+r_ivMAcNe z8c(6wkq6g*1t&V|^Ym0iSDMYDF`Xk1rO(IUGU$Lhm6r>|8^n~N;#sOF{mzSo#N_9M zu{^lI*=sC^45SR6$THRd-}YDK^bI3d80nU|?J5C!{W)>QnWwSL!A&}ziK2~V5eENO(j3RW-7ELm3*uKX`crs z5}H*m;S4#TJA%^9YWgfiy42+;v2!F&5_;9@n;lbK#FQ52iWyO|)%#()ouY85l}%M& zK#7NNJ5$FT%37yHd&PQNMnJJbeq{X?y+oG`pS^5rbKt}Fubl{GJY%ftrn@q54$utoIMhFo)#M7 zE^|V>RcWZdBJp2z5tD8>n(qrK--xn|+c(lqzOZcwDeaaD2U5-6hkt!tDQFMV;}@7W zMgAxU*7chUD=SNPoLejRm+szOU%Ss){7hBJAWIb7eEfeonRsHJU0;06EPw`eI9zM$ zp_bqm(AJHfUtaD!<2 zivCH<2Fc|DA9If%K745NzW5x&i9wF57%rhZ0*rIdMfhY!0Ubz&E4le}j=i#nKz{_p zp*)@p#H)pGlV;aJWici`9mrDmZ3LFyGk_ z5R_AQUq8Cw^R=s*Gq?2s^iya+);Z7 zX+s4|>bWLP>|aTyOSr$pCEtp=hoG%gm3Z?eOrU~m+<8eCY)egzK zhGY#mT+fg`OXVCuSrJQtw}FWMGNRNJwI3scg~8H6+~EODiL+D5glVFKHx1KwK#P<; zU&7cJifI!FFmFB;AC2f?yO6Vqf*)*%AO@BPZpHMg-odl zD$fL|!xVli8pTOS9_$jSEIEmYmU3&m^QpO9K~fHdz=YZ}2iy z1#Zw>emDQAfw)dKRFLKNNi?8BHn%m&n)?KFx+d0;6~0`b6@@Ej|MJFWZvz2DCao|Y zPI`Hxg{cpuYMN@zf~kU*vcZmKN=qAVMLumm z=0*F-=6^zCY-+>Dp=Pm4YyUuqysH& zx{e{xP4v}bRa@>N67?@PVHaeA%SHSPh-6--RQf_LpEq?xu%`3ngq)0x$uU?=Pn=2P zTJ?EkA~8-smAOf=B{f~8kzXP7PIF%A+g$dltbIP*2e+szb&n+9VE9dSIrY?Aw^nZ5 zySa2jImfZC`49Gi{?{Bpcv~UqUK%dmiHfBXdva5&ggvFbC#q4aDGoo-rN!~XPg9Ni zNcyTV)Ye5I&dqmgb?^S_+8UHHS{a1`rvB*DVw`9afTZb8E$sHu8? zJT50Vg@$DHE;szLunx>h2GQT;Y1x(8V!4Xs>6)l?;1(nFjVbmWtEh!|A>0#@%Ar5T z0_2xFtIMnF+YOE$UA()raQoc3b3_6wLxFb>MVi4niBls&A0ZtPrdcQzkR^mJ>z0a@ zoaZ~gN7JcE+hOmVJ2&D7u~>+atO=Q*+!}AFVIEXjC6OoDB=<8Q{>Iq{Pv077s6#U3 z$vohGUjwlfr02XIO*) zicgvq`|H@&&l>s{(nbi0Qj2h@m)7tI;FTZ4{;>^99z@BrdPcdz%RgxhnhSVe=J!V2 zZJh>r>b(Hgvw|uMtf%aL=B|H};qgMxXAizS(LgHlGbwdf!O(%dOmuCY5Urx$p$Weu z_7hCc9FF$!Q z664H43;vv3V#Z4K`q=hO#tL%FADAtBmk!_Z61K{^p{_aLhX4sk1q5hG9(HtY3t=+# zIUMttA+}8uXyH~0L&W3G_0{z|H&%|_cdjEm?=LyuT3sB)2Of!Mkmy`t+AZh!QHm?J zyCr$=G+iu%F%gzJOTZ$(1v0y{$~Wb=?ks^9e)z~zyi|}xDZ@^`27f10oljM&eyecI z7gVklyh6~YqH=`UAF`-T;FEQCrl8j3_IGUa1MIOk4~?yN+U zf7h`3LKE=UHPiEdDD9lE=OHiCBjlbl;2&~0>DV^6kl_|GvIWSn-o_R-{2lnUB3ybY z5|s_fUbu}v6^Ks9tCTfCiEZkb5pB^0)s=iS;9LD5ge|-Ltcli=1;_P5m z56hl;SOd-wLbhwg#VqD1Eg{hojr6gpZzvOo%okaYL1I2r-<3W-fmcNPtdPSMZ%ZDK zla;8Veuwzz?Ts#y&3ti{X01W3Jfl+AZBQbk4S+}5)uFV1>ObW zy^*gC&%q@b8_u@OZ`qNECZnhrm4^P_)(;xi59PSH;QSRVV8ciu>$Zk*X?4>kN;;u| z{!E2Y_R;EFXUL5?;KAM1m1XZk874_*Qpa=-U)9h>bc~BSZXok=4S4}yKk!1k5cfXY zsc4^VZ0%QaZ(}C%#dZBpT}^!Wk`lk;dl&apPORV*3Dxla!>W0q^mAtRaMxF*r+x3@ z+RL;G-mioli3!@~Q&atL;#wk0)Z?Dz%aHj{bV}84FaXscOUuWbNk(8msoAFy3!RGM zt6+?k#wQt>hYWA`gIz->+846O{v)5nPb3l|yQ5>~%_K$b2}`GE{pbt+e}w-5u$s03 literal 0 HcmV?d00001 diff --git a/src/alan/lspcom.20 b/src/alan/lspcom.20 new file mode 100755 index 00000000..1ea337d4 --- /dev/null +++ b/src/alan/lspcom.20 @@ -0,0 +1,60 @@ +;;;-*-lisp-*- + +(declare (load '((alan) lspenv init))) + +(*expr *make-array *rem *del ass mem listp copyalist copytree apropos + defstruct-examine defstruct-deposit y-or-n-p + macroexpand macroexpand-1) + +(*lexpr format ?format ferror cerror describe inspect + gprint gprint1 gprinc pl gexplode gexplodec) + +(unspecial args symbols car cdr) + +(setq use-strt7 t) + +(defmacro xcar (x) `(car ,x)) +(defmacro xrplaca (x v) `(rplaca ,x ,v)) +(defmacro xcdr (x) `(cdr ,x)) +(defmacro xrplacd (x v) `(rplacd ,x ,v)) +(defmacro xcxr (n x) `(cxr ,n ,x)) +(defmacro xrplacx (n x v) `(rplacx ,n ,x ,v)) +(defmacro vcell (sym) `(cdar ,sym)) +(defmacro pname (sym) `(cxr 2 (car ,sym))) + +(defmacro ldb (ppss x) + (setq ppss (macroexpand ppss)) + (setq x (macroexpand x)) + (if (not (fixp ppss)) + `(*ldb (lsh ,ppss #o30) ,x) ;ugh! + (let ((mask (1- (lsh 1 (boole 1 #o77 ppss)))) + (shift (- (lsh ppss -6)))) + (cond ((fixp x) + (boole 1 mask (lsh x shift))) + ((zerop shift) + `(boole 1 ,mask ,x)) + (t + `(boole 1 ,mask (lsh ,x ,shift))))))) + +(defmacro dpb (v ppss x) + (setq v (macroexpand v)) + (setq ppss (macroexpand ppss)) + (setq x (macroexpand x)) + (if (not (fixp ppss)) + `(*dpb ,v (lsh ,ppss #o30) ,x) ;ugh! + (let* ((shift (lsh ppss -6)) + (mask (lsh (1- (lsh 1 (boole 1 #o77 ppss))) shift))) + (let ((vp (cond ((fixp v) + (boole 1 mask (lsh v shift))) + ((zerop shift) + `(boole 1 ,mask ,v)) + (t + `(boole 1 ,mask (lsh ,v ,shift))))) + (xp (if (fixp x) + (boole 4 x mask) + `(boole 4 ,x ,mask)))) + (if (and (fixp vp) (fixp xp)) + (boole 7 vp xp) + `(boole 7 ,vp ,xp)))))) + +(sstatus feature alan/;lspcom) diff --git a/src/alan/lspcom.fasl b/src/alan/lspcom.fasl new file mode 100755 index 0000000000000000000000000000000000000000..48526e62c03072905795c424b66d83d44cd3229b GIT binary patch literal 4714 zcmb7I-EUM?5TCQBU)a(vR&-asO3P zHoBHB`{`1eKPZkD-JD-$7;Y(#jlE;(`OryBDw%~8gER<9LmGxO0BHxLK}e&Jh9K>P zGz@9t4qlB9Fu>+g1;o!Ntez_SMOXZk2+NX_b`U#GdA?t^J91mqycgvBm8CESYNZrZ zyj%o)x#F*sIvOdXGCX;Vnu82SRi(i1+VNWI4GgJecC=8=cPw{QSx+O_u?y>VK$?WK z6Vh%-qmZ70GzKXN=?_THKpICxc197YiOVZ)r&|1FlW7&K6_?5dDA=lUE(gI#`A~Y6 z$7up%Q;_12_QLugtk(`Q6xk4X)w5VYsup-@E}rT!V<`&FF09*!C68mjj=bYyL-p~P zSXvb?SW}Q3sU(?*r2RZelNdVy>4`YMVla2_=GP>lR|T)MTs@6hEYs<<^X8??&Xue0 zy>sdPL*_e@WHB7nmV9b`#$P-a8zCcYZfwvCe|@n*qay>9(M_(q(Ycq{6xQu(eRiaM ze|nC0Y+fZgcwX0u(yWT*c_%S8aKV}3Xvr84Q}S>Ei%GZJbL^-*yD9b(J;|$#s#g6< z!Ogj>-TRHSVMRD*qF~JLhtFy3k@Q>i7*dgqzJTUSyyPISn*b_u*yV``)eF6-2J1xU zG{4RxER>+j8jF=hI=9+Ud7hF@=ILRJS*xc~*ZKp$W`Ij&bDmLc{D@>TE_qG>t|ZkW zm0Z!-w4y!?tj1o43T+KwNf-Y3t56Pg~ny_tibvIkDpMeKS z6zS9bfOlg~7|hSrj%P`-!D(8J61Lh!Q7O%%uq<83!bJp>Y_dpuK#pV`O(@L_kY*yJ zZ(F22AW3D194XChk-`Wo2}!nQEGT;Sc=U40)=#6To~zFpp532vUAq;OB?fxDZpyA8{}g?TLdklL*@q97tNS zZY_XkA65XTO;}#M_dT~)N#*M~uTX%bMd}2lt3fT|lh5I0!(yr+&xcIEDmcNt={0G# z2*zs?47`fHanSV#nk@+Y%EMsP>B&tRp-;t)O35vH=(BPxX;FJ%!1*aGJ_*Ufh(pDr zwu2D>K|q|A1%ZKeKRg5mjtk8V%CRs+f&=s5Y1ahcK3YY8U@(6vm<#zO@tYJ&Ay`ZZ zZE^0Aj^N5gLluJ4Ce3`$VtXYq1hyY#eq*(3f z7aK~9g{+x7!CslOGm`$v{@HE|`Q>X(y47wcm^xa=_*U4Av+Bg^T%b^$C6=0+$6Ax0 zwEuF(xvcOEQkBoN`n$@ZR-Nc4K*-^8q8cB@oC7mgXh;l4DM=s^(~+8#7Gxc;3A0>d zYo-NxGMmX_fS)9PQB5>QH|XTw`xr};(W==Bd)E4$rKaYw+0yXsk7c#9!2h*=-e71? zEb`*Veq?<9HLi+Tej$)CxG~s@Gd@iYPmD_k;;~D>hc5GxGqK)q;ygK9$`ZNbvmuc( zS%;4hUNOnb)UY$oOYYv~RJ{!~9Wm40T0SmSw;N_{7EE`7G4!znDpk4RN;Fo;|=1?_oevIvC^M7h5i17x?e!kuQzZLNXVIBnSm6BBv@}qHCu*kX853b1eyp#kjs6uoE52* z|3wqa5H15+ko+P#^F1_quqyWJ0p>+iH$s~4ENIJ;<|H#hXrWb>84)!KD{ad)_5^(4 zDii)WmFo>>_Iksz${An3eZ#hn%z*6ZqLx}(re5}=R(5qMF zGvL-$PR#8aHWbbb?}*f6PLeLs!^!n(E4x91vJHgMa17)MEkl({UN5^O`uwZ$vhMxv zfAX1sZHBi~bkqAbB>0eNG$`o?@^U|qHbOw|l&*1rr}>51&r{6OSd`N}O~pT^A~ng# z>x4dX#*X#06;n@9Ki{m!xs0QxF8vN4`bxTCPa~8GQcIMP;#r=kcZGctv)>3KqK}Jz zZ5{9QFN98-(DTs}xng#;J?S;lj-=tVe&zlbNv0jOe&K-iwxiSq4$%N#xA>l- a +;;; NIL: [a] => a ;the NIL flag is used only when a is NIL +;;; T: [a] => a ;the T flag is used when a is self-evaluating +;;; QUOTE: [a] => (QUOTE a) +;;; APPEND: [a] => (APPEND . a) +;;; NCONC: [a] => (NCONC . a) +;;; LIST: [a] => (LIST . a) +;;; LIST*: [a] => (LIST* . a) +;;; +;;; The flags are combined according to the following set of rules: +;;; ([a] means that a should be converted according to the previous table) +;;; +;;; \ car || otherwise | QUOTE or | |`,@| | |`,.| | +;;; cdr \ || | T or NIL | | | +;;;==================================================================================== +;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d]) | +;;; NIL || LIST ([a]) | QUOTE (a) | a | a | +;;; QUOTE or T || LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d]) | +;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d]) | +;;; NCONC || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d) | +;;; LIST || LIST ([a] . d) | LIST ([a] . d) | APPEND (a [d]) | NCONC (a [d]) | +;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d]) | +;;; +;;; involves starting over again pretending you had read ".,a)" instead of ",@a)" + +(setsyntax '/` 'macro 'xr-backquote-macro) + +(setsyntax '/, 'macro 'xr-comma-macro) + +(declare (special **backquote-count** **backquote-flag** + **backquote-/,-flag** **backquote-/,/@-flag** **backquote-/,/.-flag**)) + +(setq **backquote-count** 0 + **backquote-/,-flag** (copysymbol '|`,| nil) + **backquote-/,/@-flag** (copysymbol '|`,@| nil) + **backquote-/,/.-flag** (copysymbol '|`,.| nil) + ) + +(defun xr-backquote-macro () + ((lambda (**backquote-count** **backquote-flag** thing) + (setq thing (backquotify (read))) + (cond ((eq **backquote-flag** **backquote-/,/@-flag**) + (error '|-- ",@" right after a "`".| thing)) + ((eq **backquote-flag** **backquote-/,/.-flag**) + (error '|-- ",." right after a "`".| thing)) + (t + (backquotify-1 **backquote-flag** thing)))) + (1+ **backquote-count**) + nil + nil)) + +(defun xr-comma-macro () + (or (> **backquote-count** 0) + (error "Comma not inside a backquote.")) + ((lambda (c **backquote-count**) + (cond ((= c #/@) + (tyi) + (cons **backquote-/,/@-flag** (read))) + ((= c #/.) + (tyi) + (cons **backquote-/,/.-flag** (read))) + (t (cons **backquote-/,-flag** (read))))) + (tyipeek) + (1- **backquote-count**))) + +(defun backquotify (code) + (prog (aflag a dflag d) + (cond ((atom code) + (cond ((null code) + (setq **backquote-flag** nil) + (return nil)) + ((or (numberp code) + (eq code t)) + (setq **backquote-flag** t) + (return code)) + (t (setq **backquote-flag** 'quote) + (return code)))) + ((eq (car code) **backquote-/,-flag**) + (setq code (cdr code)) + (go comma)) + ((eq (car code) **backquote-/,/@-flag**) + (setq **backquote-flag** **backquote-/,/@-flag**) + (return (cdr code))) + ((eq (car code) **backquote-/,/.-flag**) + (setq **backquote-flag** **backquote-/,/.-flag**) + (return (cdr code)))) + (setq a (backquotify (car code))) + (setq aflag **backquote-flag**) + (setq d (backquotify (cdr code))) + (setq dflag **backquote-flag**) + (and (eq dflag **backquote-/,/@-flag**) + (error '|-- ",@" after a ".".| code)) + (and (eq dflag **backquote-/,/.-flag**) + (error '|-- ",." after a ".".| code)) + (cond ((eq aflag **backquote-/,/@-flag**) + (cond ((null dflag) + (setq code a) + (go comma))) + (setq **backquote-flag** 'append) + (return (cond ((eq dflag 'append) + (cons a d)) + (t (list a (backquotify-1 dflag d)))))) + ((eq aflag **backquote-/,/.-flag**) + (cond ((null dflag) + (setq code a) + (go comma))) + (setq **backquote-flag** 'nconc) + (return (cond ((eq dflag 'nconc) + (cons a d)) + (t (list a (backquotify-1 dflag d)))))) + ((null dflag) + (cond ((memq aflag '(quote t nil)) + (setq **backquote-flag** 'quote) + (return (list a))) + (t (setq **backquote-flag** 'list) + (return (list (backquotify-1 aflag a)))))) + ((memq dflag '(quote t)) + (cond ((memq aflag '(quote t nil)) + (setq **backquote-flag** 'quote) + (return (cons a d))) + (t (setq **backquote-flag** 'list*) + (return (list (backquotify-1 aflag a) + (backquotify-1 dflag d))))))) + (setq a (backquotify-1 aflag a)) + (and (memq dflag '(list list*)) + (setq **backquote-flag** dflag) + (return (cons a d))) + (setq **backquote-flag** 'list*) + (return (list a (backquotify-1 dflag d))) + + comma (cond ((atom code) + (cond ((null code) + (setq **backquote-flag** nil) + (return nil)) + ((or (numberp code) + (eq code 't)) + (setq **backquote-flag** t) + (return code)) + (t (setq **backquote-flag** + **backquote-/,-flag**) + (return code)))) + ((eq (car code) 'quote) + (setq **backquote-flag** 'quote) + (return (cadr code))) + ((memq (car code) '(append list list* nconc)) + (setq **backquote-flag** (car code)) + (return (cdr code))) + ((eq (car code) 'cons) + (setq **backquote-flag** 'list*) + (return (cdr code))) + (t (setq **backquote-flag** **backquote-/,-flag**) + (return code))))) + +(defun backquotify-1 (flag thing) + (cond ((or (eq flag **backquote-/,-flag**) + (memq flag '(t nil))) + thing) + ((eq flag 'quote) + (list 'quote thing)) + ((eq flag 'list*) + (cond ((null (cddr thing)) + (cons 'cons thing)) + (t (cons 'list* thing)))) + (t (cons flag thing)))) + +(setsyntax '/: (ascii #^J) nil) + +(setsyntax '/" 'macro 'hack-strings) + +(defun hack-strings () + (do ((l nil (cons c l)) + (c (tyi) (tyi))) + ((= c #/") + (list 'quote (maknam (nreverse l)))) + (declare (fixnum c)) + (cond ((= c #//) + (setq c (tyi)))))) + +(setsyntax '/# 'splicing '/#-macro) + +(declare (special /#-macro-arg)) + +(defun /#-macro () + (do ((c (tyi) (tyi)) + (n nil (cond ((null n) (- c #/0)) + (t (+ (* 10. n) + (- c #/0)))))) + ((or (< c #/0) + (> c #/9)) + (or (< c #/a) + (> c #/z) + (setq c (- c #.(- #/a #/A)))) + ((lambda (ch /#-macro-arg) + ((lambda (chf) + (cond (chf (if (eq (car chf) '/#-macro) + (list (funcall (cadr chf))) + (list (subrcall t (cadr chf))))) + ((setq chf (getl ch '(/#-splicing /#-splicing-subr))) + (if (eq (car chf) '/#-splicing) + (funcall (cadr chf)) + (subrcall t (cadr chf)))) + (t (error "-- unknown character to #" ch)))) + (getl ch '(/#-macro /#-macro-subr)))) + (ascii c) + n)) + (declare (fixnum c)))) + +(defun (// /#-macro /#-macro-subr) () + (tyi)) + +(defun (/\ /#-macro /#-macro-subr) () + (let ((frob (read))) + (cdr (or (assq frob /#/\-alist) + (error "-- unknown frob to #\" frob))))) + +(defconst /#/\-alist + #O '((sp . 40) (cr . 15) (lf . 12) (line . 12) + (bs . 10) (alt . 33) (altmode . 33) + (vt . 13) (newline . 15) (help . 4110) + (return . 15) (space . 40) (tab . 11) + (form . 14) (ff . 14) (rubout . 177))) + +(defun (/' /#-macro /#-macro-subr) () + (list 'function (read))) + +(declare (special squid)) + +(defun (/, /#-macro /#-macro-subr) () + (cond ((status feature complr) + (list squid (read))) + (t (eval (read))))) + +(defun (/. /#-macro /#-macro-subr) () (eval (read))) + +(defun (/_ /#-macro /#-macro-subr) () (munkam (read))) + +(defun (/B /#-macro /#-macro-subr) () ((lambda (ibase) (read)) 2.)) + +(defun (/O /#-macro /#-macro-subr) () ((lambda (ibase) (read)) 8.)) + +(defun (/D /#-macro /#-macro-subr) () ((lambda (ibase) (read)) 10.)) + +(defun (/X /#-macro /#-macro-subr) () + ((lambda (old ibase) + (prog2 (sstatus + t) + (read) + (sstatus + old))) + (status +) + 16.)) + +(defun (/R /#-macro /#-macro-subr) () + (cond ((fixp /#-macro-arg) + ((lambda (ibase) (read)) /#-macro-arg)) + (t + (error "-- #r please!" /#-macro-arg)))) + +(defun (/^ /#-macro /#-macro-subr) () + ((lambda (c) + (declare (fixnum c)) + (or (< c #/a) + (> c #/z) + (setq c (- c 40))) + (logxor #o100 c)) + (tyi))) + +(defun (/| /#-splicing /#-splicing-subr) () + (prog (n) + (setq n 0) + (go home) + sharp (caseq (tyi) + (#/# (go sharp)) + (#/| (setq n (1+ n))) + (#// (tyi)) + (-1 (go eof))) + home (caseq (tyi) + (#/| (go bar)) + (#/# (go sharp)) + (#// (tyi) (go home)) + (-1 (go eof)) + (t (go home))) + bar (caseq (tyi) + (#/# (cond ((zerop n) + (return nil)) + (t + (setq n (1- n)) + (go home)))) + (#/| (go bar)) + (#// (tyi) (go home)) + (-1 (go eof)) + (t (go home))) + eof (error "End of file while parsing /#/| comment."))) + +(defun (/Q /#-splicing /#-splicing-subr) () (read) nil) + +(defun (/M /#-splicing /#-splicing-subr) () (list (read))) + +(defun (/N /#-splicing /#-splicing-subr) () (read) nil) + +(defun (/+ /#-splicing /#-splicing-subr) () + ((lambda (test form) + (cond ((feature-test test (status features)) (list form)) + (t nil))) + (read) + (read))) + +(defun (/- /#-splicing /#-splicing-subr) () + ((lambda (test form) + (cond ((feature-test test (status features)) nil) + (t (list form)))) + (read) + (read))) + +(defun (defmacro macro) (x) + (bind-arguments ((name pattern &body body) (cdr x) + (error '|-- bad format.| x)) + (let ((x (gensym))) + `(defun (,name macro) (,x) + (bind-arguments (,pattern (cdr ,x) + (error '|-- bad format.| ,x)) + ,@body))))) + +(defmacro let (pairs &body body) + (do ((pairs pairs (cdr pairs)) + (vars nil) + (vals nil)) + ((atom pairs) + `((lambda ,(nreverse vars) ,@body) ,@(nreverse vals))) + (cond ((atom (car pairs)) + (push (car pairs) vars) + (push nil vals)) + (t + (bind-arguments ((var &optional (init `nil)) + (car pairs) + (error "-- bad variable spec in LET." (car pairs))) + (push var vars) + (push init vals)))))) + +(defmacro let* (pairs &body body) + (cond ((atom pairs) `(progn ,@body)) + ((atom (car pairs)) + `((lambda (,(car pairs)) + (let* ,(cdr pairs) ,@body)) + nil)) + (t + (bind-arguments ((var &optional (init `nil)) + (car pairs) + (error "-- bad variable spec in LET*." (car pairs))) + `((lambda (,var) + (let* ,(cdr pairs) ,@body)) + ,init))))) + +(defmacro push (item list) + `(setf ,list (cons ,item ,list))) + +(defmacro pop (x) + `(prog1 (car ,x) (setf ,x (cdr ,x)))) + +(defmacro if (a b &optional (c nil c?)) + (cond (c? `(cond (,a ,b) (t ,c))) + (t `(and ,a ,b)))) + +(defmacro defvar (var &optional (init nil init?) (doc nil doc?)) + `(progn 'compile + (comment **special** ,var) + (eval-when (eval load compile) + (and (fboundp 'special) (special ,var))) + ,@(and doc? `((putprop ',var ,doc 'variable-documentation))) + ,@(and init? `((or (boundp ',var) (setq ,var ,init)))) + ',var)) + +(defmacro defconst (var &optional (init nil init?) (doc nil doc?)) + `(progn 'compile + (comment **special** ,var) + (eval-when (eval load compile) + (and (fboundp 'special) (special ,var))) + ,@(and doc? `((putprop ',var ,doc 'variable-documentation))) + ,@(and init? `((setq ,var ,init))) + ',var)) + +(defmacro defparameter (var init &optional (doc nil doc?)) + `(progn 'compile + (comment **special** ,var) + (eval-when (eval load compile) + (and (fboundp 'special) (special ,var))) + ,@(and doc? `((putprop ',var ,doc 'variable-documentation))) + (setq ,var ,init) + ',var)) + +(defmacro defconstant (var init &optional (doc nil doc?)) + `(progn 'compile + (comment **special** ,var) + (eval-when (eval load compile) + (and (fboundp 'special) (special ,var)) + (defprop ,var t defconstant)) + ,@(and doc? `((putprop ',var ,doc 'variable-documentation))) + (setq ,var ,init) + ',var)) + +(defmacro lambda (bvl &body body) + `(function (lambda ,bvl ,@body))) + +(defmacro selectq (op &rest stuff) + (do ((arg (cond ((atom op) op) + (t (gensym)))) + (l stuff (cdr l)) + (r nil (cons `(,(cond ((memq (caar l) '(otherwise t)) 't) + ((atom (caar l)) `(eq ,arg ',(caar l))) + ((null (cdaar l)) `(eq ,arg ',(caaar l))) + (t `(memq ,arg ',(caar l)))) + ,@(cdar l)) + r))) + ((null l) ((lambda (l) (cond ((atom op) l) + (t `((lambda (,arg) ,l) ,op)))) + `(cond ,@(nreverse r)))))) + +(defmacro select (op &rest stuff) + (do ((arg (cond ((atom op) op) + (t (gensym)))) + (l stuff (cdr l)) + (r nil (cons `(,(cond ((memq (caar l) '(otherwise t)) 't) + (t `(equal ,arg ,(caar l)))) + ,@(cdar l)) + r))) + ((null l) ((lambda (l) (cond ((atom op) l) + (t `((lambda (,arg) ,l) ,op)))) + `(cond ,@(nreverse r)))))) + +(defmacro grindef (&rest args) + `(plp ,@args)) + +(defmacro first (x) `(car ,x)) +(defmacro second (x) `(cadr ,x)) +(defmacro third (x) `(caddr ,x)) +(defmacro fourth (x) `(cadddr ,x)) +(defmacro fifth (x) `(car (cddddr ,x))) +(defmacro sixth (x) `(cadr (cddddr ,x))) +(defmacro seventh (x) `(caddr (cddddr ,x))) +(defmacro eighth (x) `(cadddr (cddddr ,x))) + +(defmacro rest (x) `(cdr ,x)) + +(defmacro <= (a b) `(not (> ,a ,b))) +(defmacro >= (a b) `(not (< ,a ,b))) +(defmacro / (a b) `(not (> ,a ,b))) +(defmacro / (a b) `(not (< ,a ,b))) +(defmacro / (a b) `(not (= ,a ,b))) + +(defmacro neq (x y) `(not (eq ,x ,y))) + +(defmacro logand x `(boole #b0001 . ,x)) +(defmacro logior x `(boole #b0111 . ,x)) +(defmacro logxor x `(boole #b0110 . ,x)) +(defmacro logeqv x `(boole #b1001 . ,x)) + +(defmacro lognand (x y) `(boole #b1110 ,x ,y)) +(defmacro lognor (x y) `(boole #b1000 ,x ,y)) +(defmacro logandc1 (x y) `(boole #b0010 ,x ,y)) +(defmacro logandc2 (x y) `(boole #b0100 ,x ,y)) +(defmacro logorc1 (x y) `(boole #b1011 ,x ,y)) +(defmacro logorc2 (x y) `(boole #b1101 ,x ,y)) + +(defmacro lognot (x) `(boole #b0110 -1 ,x)) + +(defmacro logtest (x y) `(not (zerop (boole #b0001 ,x ,y)))) + +(defmacro logbitp (i x) `(not (zerop (boole #b0001 (lsh 1 ,i) ,x)))) + +(defmacro dotimes ((var form) &body body) + (let ((dum (gensym))) + `(do ((,var 0 (1+ ,var)) + (,dum ,form)) + ((not (< ,var ,dum))) + (declare (fixnum ,var ,dum)) + . ,body))) + +(defmacro dolist ((var form) &body body) + (let ((dum (gensym))) + `(do ((,dum ,form (cdr ,dum)) + (,var)) + ((null ,dum)) + (setq ,var (car ,dum)) + . ,body))) + +(defmacro arrayp (object) `(eq (typep ,object) 'array)) + +(defmacro rem (pred item list &optional (n #.(lognot (rot 1 -1)))) + `(*rem ,pred ,item ,list ,n)) + +(defmacro remove (item list &optional (n #.(lognot (rot 1 -1)))) + `(*rem #'equal ,item ,list ,n)) + +(defmacro remq (item list &optional (n #.(lognot (rot 1 -1)))) + `(*rem #'eq ,item ,list ,n)) + +(defmacro del (pred item list &optional (n #.(lognot (rot 1 -1)))) + `(*del ,pred ,item ,list ,n)) + +(defmacro aref (array &rest coords) + `(arraycall t ,array ,@coords)) + +(defmacro aset (data array &rest coords) + (let ((g (gensym))) + `((lambda (,g) + (store (arraycall t ,array ,@coords) ,g)) + ,data))) + +(defmacro byte (size &optional (position 0)) + (setq size (macroexpand size)) + (setq position (macroexpand position)) + (if (fixp size) + (if (fixp position) + (dpb position #o0606 (logand size #o77)) + `(dpb ,position #o0606 ,(logand size #o77))) + (if (fixp position) + (let ((pp00 (dpb position #o0606 0))) + (if (zerop pp00) + `(logand ,size #o77) + `(dpb ,size #o0006 ,pp00))) + `(dpb ,position #o0606 (logand ,size #o77))))) + +(defmacro byte-size (byte-spec) + `(logand ,byte-spec #o77)) + +(defmacro byte-position (byte-spec) + `(ldb #o0606 ,byte-spec)) + +;;;In incf and decf we assume that the user is not using bignums. Also we +;;;promote the use of 1+ and 1- for no good reason... +(defmacro incf (ref &optional (inc 1)) + (if (equal inc 1) + `(setf ,ref (1+ ,ref)) + `(setf ,ref (+ ,ref ,inc)))) + +(defmacro decf (ref &optional (dec 1)) + (if (equal dec 1) + `(setf ,ref (1- ,ref)) + `(setf ,ref (- ,ref ,dec)))) + +(defmacro copylist (l) + `(append ,l nil)) + +(defmacro copylist* (l) + `(append ,l nil)) + +(defmacro when (test &body body) + `(cond (,test (progn ,@body)))) + +(defmacro unless (test &body body) + `(cond ((not ,test) (progn ,@body)))) + +(defmacro with-open-stream ((var stream) &body body) + `((lambda (,var) + (unwind-protect (progn ,@body) + (close ,var))) + ,stream)) + +(defmacro with-open-file ((var &rest openargs) &body body) + `((lambda (,var) + (unwind-protect (progn ,@body) + (close ,var))) + (open ,@openargs))) + +(defmacro deflap ((name type &optional (arg1 nil args-p) (arg2 arg1 arg2-p)) + &body lap) + `(progn 'compile + (lap-a-list + '((lap ,name ,type) + ,@(and args-p + `((args ,name + ,(cond ((or (not (atom arg1)) (eq type 'subr)) + (when arg2-p + (error "-- self-contradictory deflap." + name)) + (if (atom arg1) + `(nil . ,arg1) + arg1)) + (t `(,arg1 . ,arg2)))))) + ,@lap + ())) + ',name)) + +(defmacro make-array (dims &rest rest) + (do ((l rest (cddr l)) + (type t)) + ((null l) + (cond ((fixp dims) + `(array nil ,type ,dims)) + ((or (atom dims) + (not (memq (car dims) '(quote list)))) + `(*make-array ,dims '(type ,type))) + ((eq (car dims) 'list) + `(array nil ,type ,@(cdr dims))) + ((fixp (cadr dims)) + `(array nil ,type ,(cadr dims))) + (t + `(array nil ,type ,@(cadr dims))))) + (let ((i (car l)) + (p (cadr l))) + (and (or (fixp p) + (memq p '(t nil))) + (setq p (list 'quote p))) + (if (or (atom i) + (not (eq (car i) 'quote)) + (caseq (cadr i) + ((type /:type) + (or (atom p) + (not (eq (car p) 'quote)) + (progn + (setq type + (caseq (cadr p) + ((art-q t) t) + ((art-32b art-16b art-8b art-4b + art-2b art-1b fixnum) + 'fixnum) + ((art-float flonum) 'flonum) + ((nil) nil) + (t (error "-- unsupported make-array type." + (cadr p))))) + nil))) + ((area /:area named-structure /:named-structure) nil) + ((initial-value /:initial-value) t) + (t (error "-- unsupported make-array option." (cadr i))))) + (return `(*make-array ,dims (list ,@rest))))))) + +(defmacro feature-case (&body clauses) + (let ((name (if (atom (car clauses)) + (pop clauses) + 'feature-case))) + (do ((clauses clauses (cdr clauses)) + (features (status features))) + ((null clauses) + (error "-- no matching features found." name)) + (when (feature-test (caar clauses) features) + (return (if (null (cddar clauses)) + (cadar clauses) + `(progn 'compile + ,@(cdar clauses)))))))) + +(defun feature-test (feature features) + (cond ((atom feature) + (memq feature features)) + ((eq (car feature) 'not) + (not (feature-test (cadr feature) features))) + ((eq (car feature) 'and) + (loop for feature in (cdr feature) + always (feature-test feature features))) + ((eq (car feature) 'or) + (loop for feature in (cdr feature) + thereis (feature-test feature features))) + (t (error "-- unknown feature form." feature)))) + +(defmacro append-symbols args + (do ((l (reverse args) (cdr l)) + (x) + (a nil (if (or (atom x) + (not (eq (car x) 'quote))) + (if (null a) + `(exploden ,x) + `(nconc (exploden ,x) ,a)) + (let ((l (exploden (cadr x)))) + (cond ((null a) `',l) + ((= 1 (length l)) `(cons ,(car l) ,a)) + (t `(append ',l ,a))))))) + ((null l) `(implode ,a)) + (setq x (car l)))) + +;;;first arg is ALWAYS a symbol or a quoted symbol: +(defmacro transgression (message &rest args) + (let* ((chars (nconc (exploden (if (atom message) + message + (cadr message))) + '(#/.))) ;"Bad frob" => "Bad frob." + (new-message + (maknam (if (null args) + chars + (let ((c (car chars))) ;"Bad frob." => "-- bad frob." + (or (< c #/A) + (> c #/Z) + (rplaca chars (+ c #o40))) + (append '(#/- #/- #\space) chars)))))) + `(error ',new-message + ,@(cond ((null args) `()) + ((null (cdr args)) `(,(car args))) + (t `((list ,@args))))))) + +(defvar *val2*) +(defvar *val3*) +(defvar *val4*) +(defvar *val5*) +(defvar *val6*) +(defvar *val7*) +(defvar *val8*) +(defvar *val9*) +(defconst *values-vars* '(*val2* *val3* *val4* *val5* + *val6* *val7* *val8* *val9*)) + +(defmacro values (first &rest rest) + (unless (<= (length rest) (length *values-vars*)) + (error "-- too many values." rest)) + `(prog1 ,first + ,@(loop for var in *values-vars* + for val in rest + collecting `(setq ,var ,val)))) + +(defmacro with-values (((first &rest rest) form) &body body) + (unless (<= (length rest) (length *values-vars*)) + (error "-- too many values." rest)) + `((lambda (,first ,@rest) ,@body) + ,form + ,@(loop for foo in rest + for var in *values-vars* + collecting var))) + +;;;third arg is ALWAYS a symbol or a quoted symbol: +(defmacro check-arg (place predicate description) + (let ((test (if (symbolp predicate) + `(,predicate ,place) + predicate)) + (msg (append-symbols "-- is not " + (if (atom description) + description + (cadr description)) + "."))) + `(do () + (,test) + (setf ,place (error ',msg ,place 'wrng-type-arg))))) + +(declare (or (get 'defstruct-description-predicate 'macro) + (load '((alan) struct)))) + +;;;second arg is ALWAYS a symbol +;;;third arg, if given, is ALWAYS a symbol or a quoted symbol: +(defmacro check-arg-type (place type-name &optional description) + (let ((description (or description + (get type-name 'check-arg-type-description) + (append-symbols "a " type-name))) + (predicate (or (get type-name 'check-arg-type-predicate) + (let ((desc (get type-name 'defstruct-description))) + (and (not (null desc)) + (defstruct-description-predicate desc))) + (append-symbols type-name "?")))) + `(check-arg ,place ,predicate ,description))) + +(defprop :symbol symbolp check-arg-type-predicate) +(defprop :list |a cons| check-arg-type-description) +(defprop :list list-check-arg-type check-arg-type-predicate) +(defmacro list-check-arg-type (x) `(eq 'list (typep ,x))) +(defprop :array |an array| check-arg-type-description) +(defprop :array arrayp check-arg-type-predicate) +(defprop :atom |an atom| check-arg-type-description) +(defprop :atom atom check-arg-type-predicate) +(defprop :hunk hunkp check-arg-type-predicate) +(defprop :file filep check-arg-type-predicate) +(defprop :sfa |an SFA| check-arg-type-description) +(defprop :sfa sfap check-arg-type-predicate) +(defprop :list-or-nil |a cons or nil| check-arg-type-description) +(defprop :list-or-nil list-or-nil-check-arg-type check-arg-type-predicate) +(defmacro list-or-nil-check-arg-type (x) `(or (null ,x) (eq 'list (typep ,x)))) +(defprop :number numberp check-arg-type-predicate) +(defprop :fix |an integer| check-arg-type-description) +(defprop :fix fixp check-arg-type-predicate) +(defprop :fixnum fixnum-check-arg-type check-arg-type-predicate) +(defmacro fixnum-check-arg-type (x) `(and (fixp ,x) (not (bigp ,x)))) +(defprop :bignum bigp check-arg-type-predicate) +(defprop :float floatp check-arg-type-predicate) +(defprop :float |a floating point number| check-arg-type-description) +(defprop :flonum floatp check-arg-type-predicate) + +; So who needs a code walker? + +(defun macrolet-process-body (defs body) + (if (atom body) + body + (cons (macrolet-process-expr defs (car body)) + (macrolet-process-body defs (cdr body))))) + +(defun macrolet-process-expr (defs expr) + (if (atom expr) + expr + (let ((def (assq (car expr) defs))) + (if (null def) + (macrolet-process-body defs expr) + (macrolet-process-expr defs (funcall (cdr def) (cdr expr))))))) + +(defmacro macrolet (defs &body body) + (let ((var (gensym))) + `(progn + ,@(macrolet-process-body + (loop for def in defs + collecting (cons (car def) + `(lambda (,var) + (bind-arguments (,(cadr def) ,var) + ,@(cddr def))))) + body)))) + +(defmacro defsubst (name vars expr) + `(progn 'compile + (defun ,name ,vars ,expr) + (defprop ,name (,vars . ,expr) defsubst) + (defprop ,name expand-defsubst macro))) + +(declare (special dumper-info-list)) + +(defun lspenv-dumper (dump-name init-name) + (let ((f #'(lambda (x) (list (+ #/0 (// x 10.)) (+ #/0 (\ x 10.))))) + (ti (status daytime)) + (d (status date)) + (*nopoint t) + (base 10.)) + (setq dumper-info-list + (list + (status xuname) + (implode (nconc (exploden (cadr d)) + (cons #// + (nconc (exploden (caddr d)) + (cons #// (exploden (car d))))))) + (implode (nconc (exploden (car ti)) + (cons #/: + (nconc (funcall f (cadr ti)) + (cons #/: (funcall f (caddr ti))))))) + dump-name + init-name))) + (sstatus flush t) + (gc) + (cond ((status feature ITS) + (suspend #o160000 dump-name)) + ((status feature TOPS-20) + (suspend dump-name)) + (t + (error "Unknown site for dumping."))) + (sstatus gctime 0) + (defaultf (list (list (status udir)))) + (cond ((status feature ITS) + (let ((init (let ((jcl (status jcl))) + (if (not (null jcl)) + (implode (nreverse (cdr (nreverse jcl)))) + `((DSK ,(status hsname)) + ,(status xuname) + ,init-name))))) + (if (probef init) + (load init)))) + ((status feature TOPS-20) + (let ((init `((PS ,(status hsname)) ,init-name INI))) + (if (probef init) + (load init))))) + '*) + +(sstatus feature alan/;lspenv) diff --git a/src/alan/lspenv.fasl b/src/alan/lspenv.fasl new file mode 100755 index 0000000000000000000000000000000000000000..1c54c530f22514609dbe66f21b40f06fc18804e1 GIT binary patch literal 42311 zcmb__32N7#q&HfF*v!yQ)*~r zYGSKWJEq1a2T|ymfx)5e#a&FQps(1!ZHH1LgOhw(tI|I{R?Uu#4fO3+nd)sH*$FI6T0t>h*6K8&R2=nChDt+!5BBm>eG- z-4bR8cTJ)tvkn408yrF<GtXaC=o?`-=mXBW8SXduiPAjXf8qCdWp`inU(0P*&N?tsE!I z)GDTy5O||3e^x8Yf~Cyf&eSp$WRWuZVfIcIEO!OWS~~FAUCb_FN*r5}Maq^kl@PsH zdN=+pUeC3#W=|ZNnd?3}ec;6G(V3&OC!eoU334{>1)b=5Em>0W zzU*}aV-AI}rQqGri19HHaZFr_R{ld)&Ut1$accEGwxHgPj|~k@_HT{W`y<;p7YxVN%AOT??9v$qi@k~%%{4ER~bOP}1 zwXB4{w4SZKAIXa6&(B|~Y?z-vpY-yElx(?Neq(+nv6R-cR18U5#2$!{sZ4v`24uV&*xyE=?U}RhOJtAlI(&GIe~ahc zcuya+Gf0%H1j(C1mRxR36=M2pBFKg2Gv0jx7;%#+BntV($g)HfS)U^)q%CP<^6RE< zv!t#P=x;57RuabM?(Sgv)ZFZm+3AB;4ujK&=boHBH5Wb(j-Qx4K67I3*>xg;k)aj6 zq?#9CvhEX4_a-vH+}oeckPded+!cHMGWd+_-5Y`VtpTLqR+7qRi{je*51ln5-obsH zcy21Qp10YDG~ROYcabIb8nKOun=9VWthfR@lwyjR*gZOlIc;jw)Khi}EVG1viCyE} zn&LSBRoSPm-bJ{j&$o&>%JS#F`s~BX@+U!!Wep<%X39tJ5TxzJh+w#m12t7W{=_;i zs+2$K82|SYU0n{={;{di$*!)NsxRWNMHZ{z= zpvrK4mD^)g*j00FUaF&mr9u_5uJOU*z*N_OmuGi=jiAFr;oR;+(mU4{I)f934?PL# zeqwIsL@*t6mOFu+{j*ipEmkGob9WC6BBtb37r%eTGcs_jvP`KD&=CQ|Y)IJ0D&9X+%QALi_4{X!9-R)3&CUgf zkDWYxa0Ue1KYifo_nexYo3Ugwle>pYgM-`9xRmRI>LX#g@X%ZPAd(tLMA~@F^X?^j z_lD?gy?|yW*IIx9r|z@VOWs7=0sm&z#s7oSVDvbs+>Ymtz?F31EepC(5I(b1CRtNK z`x=mG6s?G0p;Gp|iP!V#>@t>a5f9exLeFZ88s19Q8)A#=nHo@wC56_dIkp&Hv<30# zbfvy2l=H4rN9VOUj)K3$#h+tbH&@;M6m*yb+fgw|OZHyT4{nbAOLSL-HWb%&R$OfX zL^WPuiltK3FIHEh{bQs3N{tM|VGmPXB~wUSZlT76CyDG{+w|It9QoYE>`U`+-WR~2 z^DjjK{rtU!L$AGfewCM&Y2Nx6@*kvqtv{#%Jd~N7p^L+Lq0AwDD#&v@lk8PL`I2DI|E7n~kn@YsTSOaOjD75<4@ocHpp z3{s}QL5nLg6&&OAr9a<*$sKL~+Dj#qnV=1x(jztGNw}TD$BvUlmaXPw2)ta7&x7b^ zL#pQ3(LXsWp#sWD4?QqH*=L;dwi0#COEnW@5+NWLLm1jJnJfuwwvowe9U$cXS_1M( z8l(_}e4$*X5_yEf_=~|2g1a)4N)+2H93%sJG%c6%5Eedb>8Z+?X@SFGtQ5WOP4`(* z3P%-w>V)LlEhsIzw3Erq@{A*cttOt;hPkmO%4P$Jd?hG#_IV)?t3n`FUHbAFbEgw! zVMieRRMK~373wdMUfuPOsJ>Lw6rrwaNlWg4iT{v%Fcb$@EiFW$x{o0Em7}l@^a3woMVOMZIxjZl; zn+(e((86bb_d2dg|K;6U@|M;tZzi*;R%R1ZqUa{FT@>9US!d1!C#IwGebdUpT=aQUEs}V0d2d(sDv;eErBVyt`uVp|79uUX~2e z#+VHNvXg*sk(6c%t;;jYQdD1#t<_jC9+G6FD}lV9MT-!io9O@hVU}~L8JB1g(ogS6 zW0vqrt;_vAX-tC~hdfidkOBH?K`q>%7F@V=yJwkPYs-`h+%vbVvFjL9&^pGPWiMtE ze(da4oai4O-r2RUE61Vrr+|uc(bus6^DsOo7Oz*9DY@Ow<0qBXr@s~PvThrc;$n|Y zZFfvPuJ%kRm=p2%@yN@ols}=zZ$`%l9~~T@aBJ;tqs8s4EZ1Z0gP3;V(D*qr41(&jVX17J)db?I(!ku3Ug{urc6Df)QXb;phawt`pg2|AG?xA%!1vbkawp-+cw zlMlRMO=}`4zix)e9LnN{F^C{LyyKqtN^WSb?@>=Q_wU`CgeY8s!#%^Xf4+xV&-8iT z-Xt3P1^k3V^gx0VMpab0mO7@={AAiBDrjk|Fm)LJTo5F9`?<{QFF5pM@^c1t3!|Z8h*DK4^gD%Sso@Mr3VddwTeJISn;Id3T%ogtt zyDIRR8|c@WErxAha-~dx08t=+gW3MD@>ymF!t4iJmMIbOgDTA;i**Q4trwR&Sx@rr zY#IZVS!=}BO-{g_K}f&~aw2c_?0O<(CU#5>4=B|&_^6fJtHpT}w@{@%^hVm7-Vhrx z=Csr3+^Q;^&9|hUJhUli0f0Il!ib3t8Wx793cTNmdX>b3wp8>skB6mFN*`fgI-ncY_nF4yPTFzrR9gWQV#JvXd~#uZWVcZO6ov0iKH+(9 z6!xb!C=^djKk7!*U^0U2WE+3F*s+>!VNr0ElQXMWQFznBd0A6f>N7UB zA+|=EK4t>?8Hx9BF|i?p1?=q0HaoILB2%b*8i9z!X_Xy89q zNjzy8VP*5(1jugV`s7Ck`K(2~I!B-{aFKP98pXC|Lb`Z~*bjnPYS4)RO6WLgluOFwqOhZmseubcZdQCG_BV9n`I>{5T3 zV&5{xUmCT852fAOL{nw2`M9?crHQ}XQ7mqfu{T<$sa~j7 zJ=Mz3*#3^GKL|;*zsfg0?Wb%#sH8gmYu2dkP)=Bh^{X3}-IIelUZH_xm0XJ5e=4+U zM{av+YQ-B~50--5U<_`95e&WT9hZLROyaem-cpfculb3&d~Q7)V(XJuG00mCLyZtONX8=->^L&H719;1hY+ABL3tHi)a=CP_tQ ze{*bQ!oj?~sj}zo@$s`a4b~~;I%QkKfqZR_+)(h)?Mr19Q7TeL=OJElEsf!mB0MN#Jm2{HDcsp zv&$-lJ#M>xRy^4iUNBgu)n_j&+l#OSg$?mSOr4QgQ>B76=0I^i&c~h+l+U~FDP-`1 zYYVIk-}ndX6u(kQV3ma!nQu5GBxN!xT6`v09_6@BwDi2&iqU(gPaK}!kBR8y@tFhI zC=1XBBtRr~oRnmE0|_s8spX7Tx&Ce7sefC|kontU;-S5BEG5&nE1iH)r)&W^Braj< zf{!q?+yFnB_Im3gtp0kbo#I7x!Py*%w5kGXPdiG5qM`aRs=`kDk1#sm^IXD}h1*2_ z(+VG}H0(3yWm}C;hRa*B*CJs6J84Hyq8;(j&B7}0KP3>_LYC!~HV*rbWlu;lP!|r5H?8Jkr-b&X>QeHWjE=BY}x)HY3K{_35klovK8V|z4 zoZ$4mbkx~&g0-mddWBBog%bS3P_aeKxETkY#CgP5}G3tePHWc1A9EIXi z!2fGWu#-_yOR^j?sFC?yoLnLHD}$U@_G9FV4HPpYP>XVBBemc&tb}T2nm|hWzq0S{ z0#2bN?2$F!9&{<;oGTfLJq4s#SS<&$A7F^Mw+ zP)=tt+++>A?DbmnK-)oHxg#JwF?30ry}&sgIHD;fCd4XJ1#D0^pKIQn;$-t zycOO|(w^R;#`l7n$&GOW`Q@tmIsAywUf=T$Mz)E>3Fnv)vbY1{(^+x7X!daAb5ugp zsw(Hr*0dsBjp+Y1*Om(l>kA~-O+8gRVo6C${DnxGY$HHsc!+)D52*-6ElD3^m9N*6 zRIPBFV!&D;yWFI4ltjl!+GsZ8E`d2uM-nQV?B_0lQo|(uaLphjPx5%ci%u*FV{m!; z8*R=baaPi?6QYgO;Q!lARwZNz!f zvep&WWh16NF_y%5DmPB`$g3_#e#g_epa5!_AN^1hC(8(q_w^r=8Ytij4eOXWW%6j-2pUio$W z`0S*k^uAm~W{Jh0x;`zUn2zSegGx4Cn1MR#5L5CyREf9TIBXj+uN)f|*Yl>c_)!d8 zZp+&pE5ES;UhD!gvTiP}jv$Zqk@C4UI7EQIh|5I9JRqM!fbtmkTYNT4-aL;(0@cY* zWQc)R5BIl~1*^PXjS;dciXYYvZ#vqrKl7_hsQc|0z(Zt-;6X!ceIt!~vG8hjAORla zTCodQPh1DRg>)Ne&G6Gs(GSyBsnG>gz5PWvVx%FXCOp;$)1wh<*@!(;)Z{y?e1KJ)H4{>e%!u4r)Xgqw zGfSq;5t6j$V!BYCVd`IPM%c-s76iH$J)%cxjhhiN zVy}203z7jUYasZk!GDDrv1H8Ekr7~C#f-3YrJuqI#;FiYMrw7;j1aON->XTg2HEZj38O6x$7C^*oG?2`zF+s&{q8cAZG4 z>ER!jIyY2oKW7#Ded^u5b`??KYUpznOTWvXm=b%fiEPHX0n%Ts-$~$;lnFSJ02|n* zUXUYi3Lu>GE8TL(!A-)ga#FqAJhqAjkM#J*H|uHo0|heCIGuRI$+LO+xX|Vei7TwGc*X5R1LkU}&07 z$JR3FDV=d7P=Bm!E-vwTI6BLrA!MZHhXcmgGp(&&hS`sxXAqWwTDAaG@ITc7Pnld{ zl~<{H^EZIvz75R5?nnGyRdzu=7th0iJ*^2+pJp%iK#ilnZN{G6GX_Gu*gO>DqMA8t zh>-2Hji* zdT}tv)Kdkt1M;P8kVnrzTW=*Rf8S-<>EEbRFNt%JayumlIN_N3OE;PdVnZ(KQz)+F z#&ARCsWJk?joYYa*EY7WZP4?bt}<73SG4%rlZ3#91-bggSI&kKdD=+v#0*0R1n8qw zLA%&p`-~)!9s}O#ACuG`-)dh}`Rt1K36}nVKhDl5l*mWWxvAoaaYh3A(8%JbE2nPQS@C_Rb1?4dgmjK6yEzh5H!qonfH62DonyVF z(z!*|4a=&m-$>`!wv9ha)Pa~lq|GjZ-(exp_3Lu1K8DslQk=saqZ=xe${GVK9QYPjtwo`YJo2zM=ez32uYSg3z>B&;F*B`F%sTW4S@Gr5loKh z9x+%?4AzGjAZ%CDxEwuNZJcYX$%!>FSne=zz{lfde#v5>BP(Wd>+rY^Ncl?D!ES;7 z?*#todf=Hu2y$Rx-0`5&!w?vCS0;pL+)p&_57Ah#m&z@`7#h^NpEN>4vV%xaAX0-7 zyDSgh)|IT6+?su9A6wu z8hBSn7e$DmymI+-+}QLFT7*uExI@E3lUtdBS|C-2isj2+5n7#Fa5~6G*alw&7onlB zIhpeaad||zfNSYbG{Qx2BVczBvk^=une$VJi&84McJ(=Kk^F#=oEY9!MN+94l0;^f z_5PYa4oS&aBh5j;JN;QqSn1D(9NO)$T2ylu$12yF+_$J+Sz`vsAdAmyYEF+KN2Bm4 z0*Kt@z(#-#*TXXCSrkJ_+i{}yzZ&4@Brp`d$H}nAg&L3cGOCvTuEWnspyP`}El*t| zc#$y5)phN{H@-+GMELz1%e7b8ff*d$vNfV>HXFsvx*l3U|IIt2CV?dDeoWT=IAq*NDZ4K!)zoFSfwLtm8;5P z*8K-7 zm2y?gLm>$sswV+a{RM}_4t>;&hy)L^pyK71=)jJNX`M&_AFZhcoNQ{TiDuJMcobZM z*XVE!B;bOsH|8o5)5t-bdbPbB%bIPGgEWmv@CTCKrj(Gu($)T%n?fNtUOP7+QFt%w z{Zl<1oB%B3eNzv3--K7%fv)_23c$nHint2`#So`WZOD6sZj<|B0?-)o|0>=$-7ds$ zCfaZR3~Xe=+#F)htPt0vDnW_OBa3mIK4jA!b#c(9?rT6iwor^A-iYIu3WysM4Nb2R z$#0DKA6bqEQ=7QCPIPY|mi#j}EJXYnRyoffhqzivT^8lNj53tJ=@13Lz8g*6pIVdz zT2^Thy{PgNM(O>t67|KVq{T@Pos#~{3cy|=Gg`Zc3h#65h!8>EH@4C|PvJO6f<}nz zpjW8!boH7-SFdSnBgA!}z@7uVs?`(XAsiNK7%fZDSVAT zw*s)4otlxcExNI(x&X1+2mz`Kkc+IWGY5_YSw0i>^wT#sHZmw}2w{(Z0V*$Y3I8Wik zCZ1KH_}>jISSZ1qN5ZI{qe3`z|J8@JYlbA&u!zVueVTo8>`^NXwXvBE2d@rm zxTrQ**e)PGo_I}H*9@A3uhJxZHJl8m|9@zP@!hhCU_|(>tkVal3ifyrUVRh^KFfL{ zK|T9N8?aw*JsM4#j`EEVcL$A#_z#Kr4@1NkIH;iy^sCsycZtuM1cYf!#u_1BNiMfI ze;b>JwKK3X1pPfu?!fx~o(S_f4;ni3rm3Fyiy}^(e^EPD(DaKC@#h+G+?hd-p{%P< z0#t7M#*)Rkw$O^0n8t|TWD)-vKMnd7SNJtS{yx#BaRJN&otK~o@Fom<6Dwm zL+1}9$oMr9WWpC1GPon;YR=y^kN|u(sfdnWGYJp|rpmubz)6C!adO?dKg5qD;Ijw? zWNu6g8>H(=a8<-_hP-EPuJeI1E3S^X*iIkFZl`mwMhCmzA3>Zm%eDBr$-EHHSRcp7C86TaCTlVATZck{FQ`0a~~1EPx4-idS^PX0dZkPuUE5Q9C2#)<{09(#nsOY zChxb1VgzUW(~{i4%XGqi?eWVGoqShm3jU(;ysqFnKkfyGHYtup6R}Z z@G11!EQz4TU<1+p0=Lxo_YU?va>6TFu-NjT70yJAO%87#oIsMI^oBFm8wPzcQ#kRSUlJD# zzg%5ayJa+>$UH!@KH#(oh;I4*JzS>v*&e|BN+mgB<#;bqfE?Sm{i9QreHN8vtyK*#fi)`$b4-{=r$$C1 z@fxvSGFICi&pd|vB&QAAy`$xrJMO3CC3+KSfs7Sj0 zVp2v!X7`5j^lSu`s~nR-;$|aXss~4)jQg>o*8#ngl%>ToO$%^FMiGwXr?$mUff+`J67>+wqD9mU~WXAX=jy~luhm~4VL)a_9XIYRicz+ zrWUeoHV~I)*(F-2=9WgLP-yg;N2-$|QM=ipCKx$bN0z^@^M@zw-uis|fBJ4%O~?7{ zae;R@V4uVW0|{ae*yCXbeyFkCz8*gQr?jMeO9^F87LtO)MfBHb7Q5E9<=0#9$|nvnYJcpyf2a`^)ye5IWBW@JQ&a{S$g*gSz6_I~p3M+iTZ zJ;li@60&Qg0HN$#!pC>qlmA|>K(mf7!1Em8P#`c;j_%fN=Upd8_nSMh7rVOH%&{Qv zl^gS6v17h|?G2UYPluL>d!@~GuarjUJ24gzMjbGzzM)cYi5eLpoZXrZ>MhY@&JwXZ z8KJK`t-!3^@I_-;qR{+DjF5YKgcHeKu1fuR>xdDGoEb=d(yD>N?U>$l)jtT%l;ea} z6e~b=b2mxv7(oQ=q}X3v=!q>ntk`^*f__*Qh6Mhr*z~A(Bb>|caG}Q$dHIGS_iHMB zr^)X>Tl@}4WQw?Nn;-*bq$2ncHB6G8xxOAhcQ9;Xa%_B1(iT(m{5mwF(s6II+3s!D zmdI_mCVsJ?Nd0T_T+-NMUTy+If0z!ig*B;hg)YI9)?UH(8IJIT3llu|^k!&7DzS7W zCX0i9SEB4i9M71>Q-bXMHEQ7|K8?Gua`X(XdPa-rLE2agdTkLoWT&t2img&5`G=NI z_SOk}vP1JBjpm7D`l&{U zI+g|u561Zly@)IeW6}THpL)#86Beu{{#LfLZHqt~9_=5(V*tsN!$@8%w@8g{UWoC_ zStN0eK0h!0zJ@C+uKSX8`uXlT#hZI!*M)mwZAYCYj2S_=M#~fR_U~J?f1&AnoTl$h zYx)pFcr#Z(6pzTkoZBICzA>MpvV?lV&owZ-MW~;uPj;2=Ae`4)vxYSdp4VrBe z*VIfYcci01W%~xa9pmSqrZi9IcN!^T1zR%kLb7c;#7P8XtDIyi#z`JlFt@Uvk z(2v1X|Np!$)GKhDFXqD8?KHL4-l+z5v@8=(AtTpti9_3SAy3P7S|w;;uUNYgxx(YkdMhV2brDUc~0KFoe=_D;AKca7V6X!L<)Q z=%BxFCX8JG5*{|%>1YwNI|S#IN-8NqZLyO@4S}x6@y_s>!%C}&RYXc2nUmW_NMXik zSqZUgSt%O|kGjOG8d@G`WJs@y6y(R-c`e&%saA2S{kb>WHFBLBc$%jI#*SC>!!-UFF?(I)v+l-G)|HzoV$rR+@$xGXCo5>_zD{Sa) zgrZd-aSIF}>AH2so?AX2C$3*!unku`)zO2O`_-26@pH#x5C9AFS?tDJMmM3CtFsq( zpv{w{+G{Hcb(*Ka}V9DVZ9i)t39B7cXx1d=ExJ> z2WF4WotQp&_`uxkiD!d@Gfy0uK3@G+9jZ3%xbt30nP3+%~CvWiv7dE~?yF`uZErwft& zTXioovC|zIQbd$|A=Nr-3YdBqy?4NMK;^a0dZRE0=Y&Ww6E}HQnWDijq_L6VIv^gA zr9q5?Y@sMhIg6BbkaS=y&g zS(M7JuA~Zfs+eOLzRS4{-xcLnG_whp4Q&UX+f5Hzq94`P+w&T-_fiF*O9Cq zEFu_9-TdIl$y3LV&z_i@IT#$BetM>R`oxLpXM?$CkJ}IMRlyxBR#CwAgBCtMz9=&| zKo@JOzxD;x#HI!h*?~ViipWlJq#M`TPa%FB`c(d=`jU5mYWDct;n`z|CrYeiHnujI zwsOm^wSLR4tr)Yh&ZxS{G~*$V3ZrpumAb#TP{u&er0=^|w%zyV6rIg5kV++&E=Nvz z#3oKU{nkX`BRW>z6^`r(Edp<%Y@Klf-5Y+vDwD;{2L$8edNW%e0b}LK+IOK^CuuaI z2S#|NiUuOGR&1o&fT^mPjFhyI_I3lqK}Ahp>#_opMshcASLkJSx4jr3gn*rDwPnlTcJkoOoA#qY=)gvlF@~oxrd_=V9t&d(9;3$babwU6Tzy+cRKuN| zh3T+LL%_pQhMn6UCW3kAbX({-=Wx0)vB)^SQW)Sn5uFx~BN|el#UlDga9>30Ph-rJ z;eBu5o*fkcCqaX zx*34oue{WYkEgL&61R3NZ)4?k%CcaeQhdg*MV(9X+2i4}{CSRH3zp(+98)Roz^({; zp60VAjH~mK=Q6<{k4!Bf&xGewwNP7DH{9!Pc@^SofxMFP zT%PQE9G+j+-Y$m1wr6A02+4gqNMdMw+|S0xb99mk<_SoYU-85_Hd;?hpPL8ljVc1uCHFu?Ce@S-SLSXOgsGc_MMq*pzCeV?X$)M zGsNvA;gBX*aZePv^ylD;T^N)CEC)NS@i@1S7mP@wN@~F&A#mK5qh-CXP{wo5k4gfqGM&!_6cJDa)7S_(lE$Aog0%)aGF8zH0*w+_GnlHH;i~4 z8QX!P56QFVuLwy_B=ca=l0e_S#3kGF)YL12LfVE;T%Fs^-Y2X*f=K%L0bJ1_%me^D zm2>v%${6R|yJONNX!A=?t;1C%HBAL!u&tN)O{!+@oUSGD?I(G=?I*hJdNfi0%;}}H z65#~T+)v)uYo)3CZXiNo_?o@_CRM4mdNR*o8=ucctGA}$vK#XrMTj}eirr2fR3oNsXm ze{#GyIC$JYnN$JC>DCD$J~Cb5 zH>-tmqjdvWw*m&geFcR#e1E*X;Wrc1i!6px^xEeuY2GM9_sqor*l9Jifz&Ez3?&qI z6%qp0Y_82j!37+DxE>bO;Q9r?E$tyUm-FXF=W1F-Moq{bZi# z?#9PB>0=*z7GK~va%$$}RX(|)?IxO!weU&W*UAdwr+rJzC$Zi&ty9Gh^2S*~y=)QS z3|#TzZzHs%?Aph0Ds2PIQIb9Pa*Qlf8#%^CjR8Z~{@aMBo^=Z&JU2xadY2GNv{Q|; z)(c{RQbA|A8VRaJYuo!#mZdNL+Kcdnv9jXY4*u|KFVcIv%(43~ProsL`7#!?2+HQD z&WM&cD?>-EpY~@fd@IpycQtBT3+%P;=D52Viw{?1 z?Qd}K$exCiPbZqd+s`s@UnXq6sEU0c4kB@HYW^~?u)mw~+yNMgl;MLZ$ z*I{a}*ms04lXWZzFQ>}2E2emw9Dlev(JxomOwN%bvkgb{FTH%GqvPTdMM1$A90M+c z;R=Ow=)V}63!4yPOPOfhUj zr&QnmV`0R9tRVYAJ{!W1Cs+ML%x+-;CIUPoty6R{ak|&MM=oZLfpeaaen4l_9a6C@ zt)%rhd#PaTPA{7>Wwx?o_ZHs8FKxN*M;7gH<;DgJK08o5Ru*wA9RSo^M^rBG()E$K z$X-@V={44Yy*Rb0`uS)-lzRy!vG5Z0&teMkGHS$6 zuCP_Cr|yBliT?57Qtg;6DJY$pt{{=B9|GrF1_y@wi#YMGQtYSO?Vd$@(OX!?-Y594 zIOkY<|E*)J_WoPP6sC=iDH&a`xZ^`Lqx-AB|JFtwwmS+g2uCgGu~8bjHi+DG+y~h+ zAFlNHsSTVV80WfM&z0k9tB z%{^1S^U3_QkM&f?bM|YSh+BRXVI?y{@v;68AyEMCid{>NKs&&s_~~pyak`P7#YA@z z55;^SBDz1XjZI(0XIN@y+`gx`%1!B5MS>U`k7AO4)ojV;>}Kl6_?$;>%tx|F>Z6)0 zH`4(QU7Tc+e>C~tZdUs^e?A=6efuANhC7n+m*ByR?t1a%^J-Hh%qW|>VUY7u4O&I? zDs1%$R(76~codr*aJsxBJYC*lPnSblJ8z_B%0sMiV{71><9&CMQV8h@_SMI zB9O$|I~lKa@>wK|yt1o{InMre?2`WjC%9u*Xpg_sNX(@tl1ul(5zXB>C#wsm`>H17 zS0Z)_prS`dL`(i$T^(HSv87$i=5e~VpY72&Qkz(?or7V1{sYa=9iL%6gYy%8gA(#c zw!}34Bt4%;!ti^p3&nMpYDw@8ADf#wG;`to@@Lgn8t)9x>=uKG%#@&ma??#j&XpJ2}k+13lqhW;^^iP zd|Yny(V%zZ#>Y9KD!_aP0yilJlXF4VE@I00JMw(ii)V`RT=36$%^@3>g(;leJr0?| zcew41gc#eq&z;&@`wa4xwB7^rI{pqBtOSd@d3_QKY_|5IY1imjX>6EZxpU{N`fB^n zX4e$Y9I=Nif7o`tQq1Y>d}3f~duedIdw6tcOb0YsqA|Ag*HXjy@V4y$kd#>g27ih) z89>sVu9_SxO?3C>@r)g$rj9**Z1(iA;N;=C8E%;d2TvV64hDf{=wM5K6(Kv?)WEPc z8$734oEn+Lib-HR(yyrkEw)b7kWs0-QAOvoC<-dw!{$N=w}7QwnFOswu@U z`OLQr?Y6jAmxEM2!|on?oxk)|4-Y=SajDz;zH3J!y#(#e*TWk3Z@h6yV86VM-q#0f zu%Qaep8a^pY#-llGy5uuGv=F#5fAU0(S_y!?+!aTwr6E&gBwPn8Lfid_84DA!q(J1 z_Cm{8Ap;xM)1|ZYEe(wkuo(0UxU+`eq`&yP7*YOitV*mDFKd82TzU#l#R?r1gzT~g z_xlk+siKleWA%2qN(g#F#bD9c+R zmG6s9UwDyhzaM)R%U;NyF@MZ81Dr_gA6I5JOe|Ro=Usn@Zdo>YU0J3m4ckvYch3p3 zX#{hx)q@)-4SyQecyUk5iWOocPB&!lfJM)4t7QEZ_S$6#Sa#Hzby#%sZ7i*_FqWQo z14r2(_B51y>Jd*pVWpFuI*;9b1E(U}Rh=LZK!fx%m{{$Dh21Iy#j>9;lTYRIwJP3b zc76b`di~)DhfeKXDxu@oe9d=5VSI4vnR^NvIV5h6QkORNOkjD1DTnfL5DD+9=ribU zz8CiUz$u&`Rli~>(K?!I-9KT!za-g#pyAL3g^y(6o#tjHZ2#2m-Bl%Va0R(Gd?*t# zZ!Z)gNOsGOO&8TK7kWf|E)8Dd{pgr%#IkN>i4||!9^)pQPms+;MU;^BZgKU9fb3Qy zzUC&&2mMe?SnVC~B#J)}+5~px8d!onTOF!VCwO4j{XsRVRd?9%#yBRlKDh$NC;a5X zM;pP<(?CCTvwLF6_3NIo^Ag&Bjbk$=V!l&pD$xCF?RbNd;YVgmWc6pMz{)=&wAw*@ K{rAsqZu!5{t~9y; literal 0 HcmV?d00001 diff --git a/src/alan/lspenv.init b/src/alan/lspenv.init new file mode 100755 index 00000000..e50be634 --- /dev/null +++ b/src/alan/lspenv.init @@ -0,0 +1,68 @@ +;;;-*-Lisp-*- + +(cond ((and (status feature complr) + (not (boundp 'alan/;flushed))) + (own-symbol let let* defmacro setf defsetf push pop incf decf if + defvar defconst selectq first second third fourth fifth + sixth seventh eighth rest <= >= / / / logand + logior logxor lognot dotimes dolist arrayp rem + remove remq del ass mem listp create-array aref aset + make-array ldb dpb y-or-n-p yes-or-no-p + ferror cerror describe inspect byte byte-size byte-position + macroexpand macroexpand-1) + (setq alan/;flushed t))) + +(cond ((status feature ITS) + (defprop lspenv (dsk alan) ppn)) + ((status feature OZ) + (defprop lspenv (ps alan/.maclisp) ppn)) + ((status feature EE) + (defprop liblsp (ps maclisp) ppn) + (defprop lspenv (ps alan) ppn)) + ((status feature SCRC-TENEX) + (defprop liblsp (dsk maclisp) ppn) + (defprop lspenv (dsk alan) ppn)) + (t (error '|Unknown site for lisp environment.|))) + +((lambda (fasload noldmsg) + (sstatus feature noldmsg) + (or (status feature alan/;lspint) + (load '((lspenv) lspint))) + (cond ((status feature complr) + (or (status feature alan/;lspcom) + (load '((lspenv) lspcom))))) + (or (status feature alan/;binda) + (load '((lspenv) binda))) + (or (status feature alan/;lspenv) + (load '((lspenv) lspenv))) + (or (status feature alan/;setf) + (load '((lspenv) setf))) + (cond ((not (status feature complr)) + (or (get 'gcdemn 'version) + (load '((lisp) gcdemn))) + (or (status feature alan/;dprint) + (load '((lspenv) dprint))) + (or (status usrhu) + (dprint t)))) + (defprop step ((liblsp) step fasl) autoload) + (defprop dribble ((liblsp) dribbl fasl) autoload) + (defprop apropos ((liblsp) apropo fasl) autoload) + (defprop crawl ((lspenv) crawl fasl) autoload) + (putprop '?format (get 'format 'autoload) 'autoload) + (defprop faslist ((lspenv) faslro fasl) autoload) + (cond ((not (status feature defstruct)) + (define-autoload-macros '((lspenv) struct fasl) + '(defstruct defstruct-define-type)) + (define-autoloads '((lspenv) struct fasl) + '(defstruct-expand-ref-macro defstruct-expand-cons-macro + defstruct-expand-alter-macro defstruct-expand-size-macro)))) + (cond ((not (get 'gprint 'version)) + (define-autoload-macros '((liblsp) gprint fasl) + '(gformat gf)) + (define-autoloads '((liblsp) gprint fasl) + '(gprint gprint1 gprinc pl gexplode gexplodec + plp gset-up-printer)))) + (or noldmsg + (sstatus nofeature noldmsg))) + nil + (status feature nodlmsg)) diff --git a/src/alan/lspgub.71 b/src/alan/lspgub.71 new file mode 100755 index 00000000..3f4f436d --- /dev/null +++ b/src/alan/lspgub.71 @@ -0,0 +1,458 @@ +;;;-*-Lisp-*- + +(declare (load '((alan) lspenv init))) + +(setq base 8) +(setq ibase 8) +(setq *nopoint t) + +(setq pure 1) +(setq fasload nil) + +(sstatus _ nil) + +(sstatus feature noldmsg) + +(setq gc-daemon-print nil) + +(cond ((status feature ITS) + +(defprop ljob-expand-run-macro ((alan) ljob fasl) autoload) +(setq ljob-search-rules '(alan sys sys1 sys2 sys3 bawden)) +(let ((udir (status udir)) + (homedir (status homedir))) + (or (memq homedir ljob-search-rules) + (push homedir ljob-search-rules)) + (or (memq udir ljob-search-rules) + (push udir ljob-search-rules))) +(mapc '(lambda (x) (putprop x 'ljob-expand-run-macro 'macro)) + '(peek p os sn chater vv vj tty fretty dskuse + oldjob probe pb % who% + what j k ddt spell tags + lisp l q ol xlisp xl xq + complr c oc xc qc xqc faslis faslist fl + finger f name whois who whoj w lookup u inquir + mail bug qsend send s lmsend reply + supdup ai ml mc oz ee xx + pty sty telnet tn chtn mul mult multic multics + midas m find dover /@ ftp cftp + macsym macsyma a srccom ttloc ttyloc lsc info tctyp tctype + e emacs + memo %tiful chat cli clu conkil its jade prime rfc + )) + +(sstatus who1 #o52 #/% #o166 0) +(sstatus who3 0) +(sstatus gcwho 3) + +(defprop *uset ((liblsp) lusets fasl) autoload) + +)) ;;end (cond ((status feature ITS) ...)) + +(defun y-or-n-p () + (do ((ch (tyi t) (tyi t))) + (nil) + (declare (fixnum ch)) + (cond ((or (= ch #/Y) (= ch #/y)) + (princ "es" t) (return t)) + ((or (= ch #/N) (= ch #/n)) + (princ "o" t) (return nil)) + ((= ch #\sp) + (princ "Yes" t) (return t)) + ((= ch #\rubout) + (princ "No" t) (return nil)) + (t (tyo 7 t))))) + +(declare (special load-file)) + +(defun loadf n + (do ((ar (and (> n 0) (arg 1))) + (to-load) + (default (namelist nil))) + (()) + (terpri t) + (and (null ar) (cond ((boundp 'load-file) + (setq ar load-file) + (go l)) + (t (go r)))) + (or (eq ar 't) (go l)) + R (princ ";File to load: " t) + (setq ar (readline t)) + L (setq ar (mergef ar default)) + (cond ((setq to-load (probef ar)) + (princ ";Loading " t) + (princ (namestring to-load) t) + (setq load-file ar) + (load to-load) + (return t)) + (t + (princ ";No such file as " t) + (princ (namestring ar) t) + (princ " Try again? " t) + (cond ((y-or-n-p) + (terpri t) + (setq default ar) + (go r))) + (return nil))))) + +(defun dbug (x) + (cond (x (nouuo t) + (sstatus uuolinks)) + (t (nouuo nil)))) + +(defun base (n) + (setq base n) + (setq ibase n) + *) + +(defmacro bind-nointerrupt-nil (&body body) + (let ((old (gensym))) + `((lambda (,old) + (unwind-protect (progn (nointerrupt nil) + ,@body) + (nointerrupt ,old))) + (status nointerrupt)))) + +(defun 20X-^f-function (() ()) + (bind-nointerrupt-nil + (loadf) + (princ " Done." t) + (terpri t))) + +(defun ITS-^f-function (f ()) + (syscall #o1_22 'ttyfls f) + (bind-nointerrupt-nil + (loadf) + (princ " Done." t) + (terpri t))) + +(defvar *elisp-^e-valret* + (cond ((status feature ITS) "E") + (t "EMACSî/ "))) + +(defun elisp-20X-^e-function (() ()) + (valret *elisp-^e-valret*) + (elisp-tty-return '^e)) + +(defun elisp-20X-^z-function (() ()) + (valret) + (elisp-tty-return '^z)) + +(defun elisp-ITS-^e-function (f ()) + (syscall #o1_22 'ttyfls f) + (valret *elisp-^e-valret*) + (elisp-welcome-back)) + +(defun elisp-ITS-^z-function (f ()) + (syscall #o1_22 'ttyfls f) + (valret 0) + (elisp-welcome-back)) + +(defun elisp-tty-return (state) + (check-for-elisp-turds) + (unless (null state) + (elisp-welcome-back))) + +(defun elisp-welcome-back () + (cursorpos 'A t) + (princ ";Back to Lispî/ " t)) + +(defvar *elisp-filename* nil) + +(defun check-for-elisp-turds () + (let ((name (probef (or *elisp-filename* + (setq *elisp-filename* + (cond ((status feature ITS) + `((DSK ,(status hsname)) + _ELISP ,(status uname))) + (t + `((TEMP) ELISP TMP)))))))) + (unless (null name) + (cursorpos 'A t) + (princ ";Reading... " t) + (let ((f (open name))) + (unwind-protect (progn (deletef name) + (bind-nointerrupt-nil (elisp-load f))) + (close f))) + (sstatus uuolinks) + (princ "î/ ;Done.î/ " t)) + name)) + +(defun elisp-load (f) + (loop for form = (read f f) + until (eq form f) + for value = (eval form) + do (when (atom value) + (prin1 value t) + (princ " " t)))) + +(defun print-runtimes (f) + (terpri f) + (princ "R=" f) + (princ-time (runtime) f) + (princ " GC=" f) + (princ-time (status gctime) f)) + +(defun princ-time (r f) + (declare (fixnum r)) + (let ((base 10.) + (*nopoint t)) + (prog (m s d) + (declare (fixnum m s d)) + (setq r (// r 100000.)) + (setq d (\ r 10.)) + (setq r (// r 10.)) + (setq s (\ r 60.)) + (setq r (// r 60.)) + (if (zerop r) (go S)) + (setq m (\ r 60.)) + (setq r (// r 60.)) + (if (zerop r) (go M)) + (princ r f) + (princ ":" f) + (if (< m 10.) + (princ "0" f)) + M (princ m f) + (princ ":" f) + (if (< s 10.) + (princ "0" f)) + S (princ s f) + (princ "." f) + (princ d f)))) + +(push '(print-runtimes t) errlist) + +(defun 20X-^t-function (() ()) + (print-runtimes t) + (terpri t) + (check-for-elisp-turds)) + +(defun ITS-^t-function (f ()) + (syscall #o1_22 'ttyfls f) + (print-runtimes t) + (terpri t) + (check-for-elisp-turds)) + +(declare (special gc-daemon-print)) + +(defun 20X-^d-function (() ()) + (if (setq gc-daemon-print (not gc-daemon-print)) + (princ "î/ ;GC Printing On.î/ " t) + (princ "î/ ;GC Printing Off.î/ " t))) + +(defun ITS-^d-function (f ()) + (syscall #o1_22 'ttyfls f) + (if (setq gc-daemon-print (not gc-daemon-print)) + (princ "î/ ;GC Printing On.î/ " t) + (princ "î/ ;GC Printing Off.î/ " t))) + +(cond ((status feature ITS) + (setq tty-return 'elisp-tty-return) + (sstatus ttyint #^e 'elisp-ITS-^e-function) + (sstatus ttyint #^z 'elisp-ITS-^z-function) + (sstatus ttyint #^t #'ITS-^t-function) + (sstatus ttyint #^d #'ITS-^d-function) + (sstatus ttyint #^f #'ITS-^f-function)) + (t + (sstatus ttyint #^e 'elisp-20X-^e-function) + (sstatus ttyint #^z 'elisp-20X-^z-function) + (sstatus ttyint #^t #'20X-^t-function) + (sstatus ttyint #^d #'20X-^d-function) + (sstatus ttyint #^f #'20X-^f-function))) + +(defvar **-manager nil) +(defvar ** nil) +(defvar *** nil) + +(defun **-manager (val) + (setq *** **) + (setq ** **-manager) + (setq **-manager val) + val) + +(setq read-eval-*-print '**-manager) + +(defvar ++-manager nil) +(defvar -- nil) +(defvar ++ nil) +(defvar +++ nil) + +(defun ++-manager (form) + (unless (eq form '+) + (setq +++ ++) + (setq ++ --) + (setq -- ++-manager) + (setq ++-manager form)) + form) + +(setq read-*-eval-print '++-manager) + +(setq miser-width 20) +(setq major-width 20) +(setq plp-properties + '(convert xmacro defstruct-name defstruct-slot /:function /:value)) +(setq gprint-array-contents nil) +(setq gsymbol-car-format '/:G1block) +(setq gnon-symbol-car-format '/:G1block) + +(defun (bind-arguments /:gformat) (x) + (GF |(2*_(1%gformat-bvl -*!*))| x)) + +(defprop caseq gformat-caseq /:gformat) +(defprop selectq gformat-caseq /:gformat) +(defun gformat-caseq (x) + (GF |(2*_*)<-*>)>)| x)) + +(defprop block gformat-catch /:gformat) +(defprop catch gformat-catch /:gformat) +(defprop *catch gformat-catch /:gformat) +(defun gformat-catch (x) + (GF |(2*_<*->)| x)) + +(defun (defun /:gformat) (x) + (GF |(2*_*_%gformat-bvl )| x)) + +;;;Do this even better someday: +(defun gformat-bvl (x) + (cond ((null x) (GF |'()'|)) + ((atom x) (GF |*| x)) + (t (GF |(1<*,>)| x)))) + +(defun (feature-case /:gformat) (x) + (GF |{2'('*| (car x)) + (when (atom (cadr x)) + (setq x (cdr x)) + (GF |_*| (car x))) + (GF |[)<-*>)>]')'}| (cdr x))) + +(defun (iterate /:gformat) (x) + (GF |(2*_*_(1<*->))| x)) + +(defvar *gformat-loop-keywords* ;Use these if LOOP isn't loaded: + '((for) (as) (repeat) (initially) (finally) (do) (doing) (return) (collect) + (collecting) (append) (appending) (nconc) (nconcing) (count) (counting) + (sum) (summing) (maximize) (minimize) (always) (never) (thereis) (while) + (until) (when) (if) (unless) (with))) + +(defun (loop /:gformat) (x) + (let ((*gformat-loop-keywords* + (if (and (boundp 'loop-keyword-alist) + (boundp 'loop-iteration-keyword-alist)) + (append loop-iteration-keyword-alist loop-keyword-alist) + *gformat-loop-keywords*))) + (GF |(+2*_*<%gformat-loop-element >)| x))) + +(defun gformat-loop-element (x) + (if (assq x *gformat-loop-keywords*) + (GF |!~-2*| x) + (GF |,*| x))) + +(defprop kappa gformat-lambda /:gformat) +(defprop lambda gformat-lambda /:gformat) +(defun gformat-lambda (x) + (GF |(2*_%gformat-bvl <-*>)| x)) + +(defprop named-kappa gformat-named-lambda /:gformat) +(defprop named-lambda gformat-named-lambda /:gformat) +(defun gformat-named-lambda (x) + (GF |(2*_*_%gformat-bvl <-*>)| x)) + +(defun (labels /:gformat) (x) + (GF |(2*_(1<$gformat-definition !>))| x)) + +(defun (perform /:gformat) (x) + (GF |(2*_*)| x)) + +(defun gformat-definition (def) + (GF |{2'('*| (car def)) + (if (symbolp (car def)) ;should call gformat-bvl sometimes. + (GF |_*| (cadr def)) + (GF |-*| (cadr def))) + (GF |[<-*>]')'}| (cddr def))) + +;;;Disarming this kludge once again. +(defun (macroexpanded /:gformat) (x) + (GF |(2*)| x)) + +;;;Can't make PROGN (PROG1, PROG2) choose between: +;;; (progn foo +;;; bar +;;; baz) +;;;and: +;;; (progn +;;; foo +;;; bar +;;; baz) + +;;;TAGBODY? Ugh! + +(defprop unwind-protect gformat-when /:gformat) +(defprop when gformat-when /:gformat) +(defprop unless gformat-when /:gformat) +(defun gformat-when (x) + (GF |(2*_*)| x)) + +(defun (with-open-file /:gformat) (x) + (GF |(2*_(*_*-*))| x)) + +(defun (with-values /:gformat) (x) + (GF |(2*_(1%gformat-bvl -*))| x)) + +(defmacro try (f) + (let ((g (gensym))) + (or (get 'gprint1 'lsubr) + (load '((liblsp) gprint fasl))) + `(do ((,g '* (,f (read)))) + (nil) + (terpri) + (gprint1 ,g nil nil nil nil nil nil) + (terpri)))) + +(declare (special ++)) + +(defun unbound-variable-break (args) + (declare (special args)) + (errprint nil msgfiles) + (let ((obarray (get 'obarray 'array)) + (readtable (get 'readtable 'array))) + (setq ++ (car args)) + (bind-nointerrupt-nil (break unbound-variable)) + args)) + +(defun undefined-function-break (args) + (declare (special args)) + (errprint nil msgfiles) + (let ((obarray (get 'obarray 'array)) + (readtable (get 'readtable 'array))) + (setq ++ (car args)) + (bind-nointerrupt-nil (break undefined-function)) + args)) + +(defun wrong-type-argument-break (args) + (declare (special args)) + (errprint nil msgfiles) + (let ((obarray (get 'obarray 'array)) + (readtable (get 'readtable 'array))) + (setq ++ (car args)) + (rplaca args + (bind-nointerrupt-nil (break wrong-type-argument))) + args)) + +(declare (special flush)) +(or (boundp 'flush) (setq flush t)) + +(defun autoload-warn (x) + (cond ((or (eq flush 't) + (atom (cdr x)) + (memq (caddr x) flush)) + (terpri t) + (princ ";AutoLoading " t) + (prin1 x t) + (terpri t))) + (+internal-autoload x)) + +(setq unbnd-vrbl 'unbound-variable-break + undf-fnctn 'undefined-function-break + wrng-type-arg 'wrong-type-argument-break + autoload 'autoload-warn + ) diff --git a/src/alan/lspgub.fasl b/src/alan/lspgub.fasl new file mode 100755 index 0000000000000000000000000000000000000000..6b1f6097cc87e5055da6cf579f4b8d319a085690 GIT binary patch literal 23728 zcmcJ14{V&rmEX+w?JlW^l$I1Jt>k|nDan#4t+W&=$s+BT%iZN4ak;zNKcXmAHYr*E zZOOLG*gjtz9fCqAg48Y2UU~=)*Whq1>fq`gf+9!`MOqYv5gdx52!fypg0?u^1wn8! zB~c2_uB*P^Z+5@=_R~_5i+BNkeDmhb%$qmw&AfRt-*@X@T_0V$Qdv+(YP)I|=a!XH zx{|9NQG~|Rm7IzTj=ufs+H?JFzG+qP$1&-fRvs{SMtSlRzRO@4Kh?SS*218Y|bQ@Q3RUMY;Lx$iz1v#9hWX;0<9fm z74p!fS~VaXO<}N>QZ6@R%9cQE+VJ~UX)vfWQ|W4sERp2sQ6aXHJbJiMwpyJ>J<{Yv zIp-%NnXSy!#ANC}Eh++;%g?Y;E{+=^mVhK~yPrEZRootEZBBSGBxu$^Gd`5fHq59} z%H{K{s+yjxODI2GDVY)+X67D2S=*T+a+q-p)OEFEZ^tS|OiUuwnUjochmCm=tlHft_H;S4Xn>Q!_3Le5U2RcJ9uGE)K* znypE54Tz*l3$8kiwoO9->NwvZW~Z}hBjQY*1YBW9pP<}AK z$~-Gzj{-Q%0IYyh0W&J)jA$A_W>l+r>X*`DU3HKd`HHYkXu2>_tP^Ld^Ci|&1w`|+ zLS&L9a^Q%N%qpBEmEK;Ro`8@V-1|nC$;+6LIFqldjo3nAM)agXd^nxW1x8Ee_gQ1z z<%tH9qLYJm0qu=9%5Eow)Tj@c)}+LcfhIEo*9J}w)cj)ZvXsyRGR1H(b$)t0FP2{a z={z#1ouFF}bUPkgm%45VR+di{x68Aa_$-9$dpUGCF|U45$;28%RC| zXdR#@0If#}7Z2^%@)R=SAn9WUl3hq{B@W3BpV%}6Tz4p!Bzz#(Q~(Hdwyq$QYb!tz z2f36>97(p@&L)}k8QKoqW<1!B4alIZb_k$0__-Tcj7enlFo}o5s%$Puo&iZOpk07A z0!jkf1ZXdy1fW4cY+dJND(K#v1D1n3Dsqkx_S^gN)a0KEXn14K*f14PsB z2Sm%@P|%Cn1{@|T#h!Dmc^WvH)Q~+#sOSfc618184})IY7gJE&$pO=n|j=uq z0gV7!0yGNfEkMr!dI!++fZhf4Wk6pA^a7x-0U87J2Y}Lmz7A*{&_4u}0dyUYE+n~N z{3Ad)jQ;7kJd8mA7X{rn08Ie;CZI_`?}LuU83k^NII0hlEcQ+2n zpCcJIV&twt_1bsUtMf9k#*IYDcBOH9;pQ`jksQBS(X9Fm1PA1 zHGbl`q_fG1>3nd7sff?Q4T7w#Gqu8av1axQx|~aA^V0B`~jHe0AOSa2gc4_hv;{GDnXnLr-aJwjCk<`@xFF^3!|Q5qhRUV zexoIC{M_|r*VXA2J#_CL>R6V^>AOI?j!b;sxHK><)jsEIW4^t^acLf}vqtpvPyL?G z`l?n&ZAocZ-SvihIA6q8;^5nnI#KG+sM6^3l+WsSz-oHg)oz-#uc+_e`^+|hcK#&L zM8nWZiL5ZSEEWIJ-G6dTy$?};!|(8)`W-I#Or@e~!IP$yF!lX=_aLx&j^W+}oq;B$ zADy`H${ATa#X{b^;=OWZ@#PVgMS10p<^^%#@;QTYM+;ZHt4pWPduL_ZiJX*@-r`l0 zC&Zpted8T(@!aBt%P-WC?y~bQ)W3%Pa1NKvcCA+YDeCeJ0=oxhbj14i9hf}O@y84PF< zsMtN!m_vtDEUvTONl%nO-}%F)4B(s-g!(T%qo8gTf88gKYLirh>@=b8Ce;Fe8X+ zE>ksj#ZE%oR6>tMUH5TW$!*6`Y>-Al9FiZ(pIJ#X1YCacg|mykkP==(z3h71lse|) zHs2W&&0^A2Cq4Sm=DMn5EEULw1=`#dA^r=SB$U!qv7M}H_p#tWYzFaDmKc1tljXQT zT#>=DcXnxb_FYp`V$*ifbLl(Oy-6L;n=w3r^6tLWvE+*r$%$GaQ=KkSm>>Eo_CiO; z*+r;WJ7wfXVv$60j}$}ELr}ZRFyFt2`F=7<*e=gVSLjppVo(PR;zmkO-oP8g;$L|wWO3f~-4)u2+(Gpw(l|U0* za!V#9QMyttGo6N%#E37_{dESgrk9d0=8{L#c?k|-_CPH^K%svCh+h2<;{s_ufcv5R zsgq1Xml#zAO4|lOrZ?rl278^F#YhT$)!o< ze3Jr+XqWEwb^fG3q%WXyv_q-K$h?kY@k6dmv3`5}Hebphhf>GdBHkz5rWoD8SvV*7(e65`2w8D0m z7nJ(w;FvsjiIVi+?uo7aE_OYq#QJrPQ=x6rETA3Sf5tWU;5t()SBm9Qu|frzRoPhD z^BF&a4nE_%LN7NwC|#jP!1`p!*K#cu|58+ZbbRsjB{(qo3s+yOTT_Pz2}d+H#SMFg zCl1G%&Hy_85PJs6PvY`0n?Kme5<>EVF%b-7t(J_mNK(K*0i8J=Xr2$IDvX3mCTS(! zT!(56yncz2M|qM|bF=kWF!2T_D3e<(NqGK~5Be&-%*f=6CVVXi4f$Nv-!*76n%Eb> zx%tWdaitHS2{Vtx1)>M=-to1)y($MYL*g}OATy@dvAlB-? zvTHR}1x3&LMSuU;fuTW`T7EgEjE~_L{jauY$O(X2UAnVXi*?HH9IHdI|AypwBU$lV zUWpxA_a+?ipU}f+``|wh!&stzLA7QjLw{#^xJ$VqC37yyb`I9|<+?J8-$E;bdHwh0 zSUhDmO?J71{-?Rzp~(xz6>!dd{0G z0dzj#EEq3h^V4bIgBg%iEAQF2t3RRhOWs$;#IR7lZdc_q^#Awl+2aZFOQZBf8V2^P zF|fH$K2QsbXoVYCqmTnRSxSh*#?;KI5US*2|KURzn(qltZSY0@+3si0ef%DW26F!y zcQHetHrqH4(?9;>-TS=H?(t0C%T7dXf!3#GUky|n>>jcHab~GkkOmW$iExMFr4lBKgCfM ze$m~}iCifvZ>PAtZu^)-Id@AAdj$_fFUx+N!6b&?}4U|Rh-EUoU^i2`4hBQCr zkgu$f3`mnfBJEpv*^4a*?tt!%A=PCszMFSk|oK;S@n7$KXE#81Mgj%F;5;;i4 zbyuLKcGPrSIosI-RwBCTv^nRMvq4yKFbk);3_o9zPWm;qsALCPT`yf9CdaP#^jp_K z&y*7=AWSQ}th#zkVzUXs;pgmqTpo5@M}SP>VWH@yYNlN}EWaC!U?ub`NNCx_)&p3= zwpqA-i3|qt={f!aNpmU?7l>=yFFEg;$yb&|6g8Wws_&<9y~a%V3kYQ|<#E#;{*e~Q zNmy-PJ}>?Rn@~4iqZ{J%us*tIwmygjL+u<|?oz{ptPfT7Nrsa#xii8By&>B;1nkM? z!a8bBzir%#lx(0~;}>l|KQ`W3=jv^GYYrpZrk4`ct8X0-j7iw^|NO6OO0!9X4%%ed zadyyhI-|}QEZKR6xlpzv%n++}=7{6W`=!yzj8}T&!eub9_Duv`ikJ78sn*Xk=(A_* z_;un`$^OR4eWG=oe!feIS>7lU^naf(tV0mi)sV1mMf%d|RvnQ@jPok_MIT1UFLeD` zPok=x-;sAr=b8gBR+Q*~bW5xbJ$$6j$$6Q$SrVOuSL#r0vAYdyKak`#6cf6j21es- zMjkhOh-0W5qg5vcnd6hVOQW^Ryfp(uY`L}KQt&#u#7))$%7#t^{u*W9APFA-g(P@5 z$YAvUuaWULc(4|8t`H&t@l}xg3XlJZT-}1?O`qg{w<1CAuSp_+I$=p*v2DP)co?n# zS;n~ngquWFhH*gu+17`$wid%Ua936%F^q%cwN@mk-ZDOKNdVcKMJTTa2IQ(tAuV?e zQ0gJRJW4FFI)BmviU*N)(`_h7hB`UyOP~w6@yr~+J_67~ng+>l;_|TD2uTE+wiF~o zlC$h@K-aoyX&Yn@X&S}9!aDt4zuulT2a}<$8#3EIi{cS#A2Ishc!#B4_+3jY-O@SE zC%yw8!z8$*wk%zIi@v4I7>3zSwXQ@r%Hf%&gAsA}bRhxEjhwvr*0P{=GAU0$4;clJe9VgdQ4mb9eM>}9579FqQ>F$=p9Kq(>T6*d!_rDy163L?Z@7fB)yoN5yul_v6CxZ*VM<&>UqCr zit8Z`uyY+v8_gUrx=H_CkV|s6(gdi$=xscxo*~Tw-kqJU1?2UW z2k4I9JyR-uSYj@IDWCS;7PO^&332~Yu3Vj#T?Kx)+9J1ls!T}on1Adb7f|+)byuz) z%CTWBBc~P;2;ndWaB}g|l-475#YD{`Vx%?hcgPeTzr}+B_1tZm(%k};kueD*efrbbgxNCqXCWRq%$e!BICt;GLtSNHZ?0Z>-f_n zlY`@Oy=X>;XryNPNj16$9>AfNV<35kcqqtq&Q?{T6v}H>vRZj_(337t)@I2(N=142 zY9$O zWU|81+Y1jz`K5_!^Vkc={UE4Hw%mrAAi$H`-G; zztd}hYbmhM>F4sP!L5S<(P0!Qy1W1Gn)7SQ!1kOt8KZq1BMyocodg@2L?>Z?-D{-L zli4;zX|MwD#}RBPI?~;Q{4m$Q_9*hZAX;)#=IfG*%b|cwz|JC7FC*96k2F~TF-DxU z$PUTXH2RQ5RwS01kvsJP+8e9Uj@0KPLmO7}A)qPX!LC?#3)!Kr`wFnSn)gk0Yz^r8 zgVfxOajg3CJ2U+<5Mq2meRX4KEi_<{aljJksZ2jrP~`0f!VIhGYhufrvF=8RdZ$&_ zg3(tA58Q9+`+y878N1(iB$mbXB5Udo&|G$3^mW@%psJv$yIUGItJm4?H|*Wr(n1C; z?R|5$Lk7y1ALP>WU_D$(T^h@vAI6x2c6^?4aXZ=HFVtM!)AyUJd-_q$)hf;Hpt-uI zh4K5$6}J6^l~BW6-QHVu$-*Mb zgs*5aJG$?q@sObgX4dYGQ(0fjgGRnu+4Uam8-j0_c$E9~M;M^nKl-<0nPrTU>XKlX z%%|>tN?F{=S^*H8$XcP<xXg6BATtG~m6slAICOT<3`e(F-rN}u$4)p|6s&k8?nSiQ zje$0f5k~tnmGCm1_n(`%zu+l@<%+}{D9p%m=n$BZAK-j>&VqD8*z2aA3p*;-O5?%b zyN$V-{!~!yncG6xW_^NrwD}Xv(jy3rC0u7|Pszr68Fy82E>dy#9F@5KikNIMcz_CA zG>B`~Z^`9^v0VVY0S~Lo@L$kQ`ya-(ZX!F7D8MCyJ4?=WhnkK-JTvRcJOjwRjKvs$&opV1anNMHPHG5 zCpS|hE)$ti^3&6D=ThG811vwMo@{NFmN30eABG_>_R0A#4AK2u?L{C0L< zY%AxK(AINRcl_qIp`Hwc_D6QkvjSp<87C1zeRMJ+NK_xtOQ_#BR~KZ*jbX><`98O^ z`B zMIKTXe$Zy$>UY`3$q@Rsnyv<&Cg|#!)kVB+>0*uYqpsF9RASoD(C>1&7-)E^^44N0 zIg^{8E6U}mM~>F(jd2ldbEry7*hqK;K3##_x+C3Q?7r` zOBTy!ix!gi23W#g=VLNc%wv-aSbh>uWU@h=F3CNktjPl}Od`|9qzV$u%djjVmSp1@ zdCh_KN~O37f%chEsUfH#KY879cDCLWlC$Y!)3ejZ>$a{XE12|SOKhBnce;?1=qIbH zPUXruzN*SL=BDK07a=rlE~d;)JK5o#*ZT4|PK5mPT+wbEZ^Kl1#+~Yp(kdJ%9$Bp{9Cw<)W zKJFMpynN9m@@o&Z$R#{I z>k703v(A#|h-%p-s9WacemOkW8~q8#u0srlhJ$&x)xxPkE=zWqZmYx+B; zh7g7bPWyHawo@pH!A4|dSORyL{95`Dt;(+HI2G$>1>7IWg%DkY578;Iigvb|YPZA} zF4fo%zvuU@W<9c+$u>0dDs?7ZsT^U9UtPcc2OT>z{bqR+(Qbr%cglr~Xb<`sSOT!N z9$`-saoIte_96>G7YiH?vfIr)erzR`iE-C&;+5g8)8C3}+S@p)=WX&Dy-^#TiZI-# zXGGi5VBL?z+pj8^z{WFBa?C{`CC83~?}dglDJ#3IH{_?+irc4fkMNO#ztq3Mj%`Do zDVA%!o2T9#cCC-?i+S=B``EvgGgGRlw6RhNcGCmh`3>hDxYQUJSXAPxgT%GyRuv0C-@mCp2&A30TgCCE2m4%K z7~xr);tOpYy0S7a%jHV#AG}0=z>&pe$9VMc|FM?elykm8kuWO=E~c%NQ-m8^yZmw{JNl>+R=pC9gB|~!2j^#1 z;b2U{W|W98$R$Wb219|26YhfCt`(j)F+{>wo@EeJR3Wapcv<`gaC!)>tsZ4Rj^K*} z*Wv`+KH;FgYeZQDZo*~FI+oBexsVF3SV5>PV=R0b+D;(1cmSXprVn8ctXe&5mW^+$ zzmgg9rCIbxT1)u;^DYUuN=h4P{jC(lFOSU<`Y%9tl7Cmn{Yvue?!Zu zCPd5`7Oyqxy?EF#44ZA`tAs{&B^8Tp1+E^z{zIwd!Hb}Ho7v3}+H)<`{yAy)eyy!X ztm@;*$pM3UrIq9;wElHVm*23Gt2-F4(aDSL;hNLfK5&-_Q5a#UzkpltlB5E{U?xyo zAC$SRMJ9Rp;!dR?#tOw4ipDSljjwJmHX371r7^+BDxYT@{`f)Tu%~q2IEb?iz5N=; zVNSO2NxU9qzQO=pv>6vvT*;;LmV&GoF(g)HC8fdv{lSzVsgDm2=!bV~pW`4uc4@Ui zxb*NrXn8b<0c=$k?pbOd3~u#{7@^@1S2lLsnrL7+Fu%wYWPXm4sEG`Wiv2lBzBsKF zpQtU`N?^=*xWG&d5k2Bw+FbBylzpVx1M}{CAu(AA$?S2z)^2P!v&R)^s7npyjk}63 zzW}aDWjV*f@74S8c!3ug$`%zQK%?gTW<^b2X=h7GO3r% z$&JV>I3cet%?Ag)H_FC9Dr)0pmw+q#1q8j@=0ht^Bk0{W-=foDR~C-_8J-vPEMiOa*@QEYjg z>ss3-dC8~k5?@)7j5c{6YUti)dQ3i@)p#FD@26L1JP7RG_>~KA@H566`M{SUa!kRY#kVR(==!|^L0Eaul89IaLp0;9wf`}S;V$%Uh1+Gq4!~-5u4=&u$h`A*(+=W zLQYbrzMwWfYsMGLnS|@h@?lB*w0!UsZ$e87f%_71GD!7%&UIqBnahmgIB)3+%#2C% z(K@LGm-nmbarw3peop;MM)JXg^0beY3_UO|lrx|~1<^2FvXRZs-0f4RT+q3Qd>)W@ zm)fQp?=GPNd2>-lPQU6a!omIK)0?=Cm$C8@ea;pcxCnHVwCND4ZUga(PQ#Hv8~EPfzMyl?}ABp zG`;lZm8S1=DR=wDn$&|_waElh+IR;?&Nav7D^W+wEM_k+`=YE}VaA?zD(|r-3sc!o&)yzf2s4Z4KV!xP?!Z|3B00 B_FDh| literal 0 HcmV?d00001 diff --git a/src/alan/lspint.46 b/src/alan/lspint.46 new file mode 100755 index 00000000..4bcee100 --- /dev/null +++ b/src/alan/lspint.46 @@ -0,0 +1,205 @@ +;;;-*-Lisp-*- + +(declare (load '((alan) lspenv init))) + +(defun *make-array (dims opts) + (do ((opts opts (cddr opts)) + (type t) + (ival nil) + (ival-p nil)) + ((null opts) + (let ((a (cond ((fixp dims) + (*array nil type dims)) + ((atom dims) + (error '|-- bad dimension list to make-array.| dims)) + (t + (lexpr-funcall '*array nil type dims))))) + (if ival-p + (fillarray a (list ival))) + a)) + (caseq (car opts) + ((type /:type) + (setq type + (caseq (cadr opts) + ((art-q t) t) + ((art-32b art-16b art-8b art-4b art-2b art-1b fixnum) 'fixnum) + ((art-float flonum) 'flonum) + ((nil) nil) + (t (error '|-- unsupported make-array type.| opts))))) + ((area /:area named-structure /:named-structure)) + ((initial-value /:initial-value) + (setq ival (cadr opts)) + (setq ival-p t)) + (t (error '|-- unsupported make-array option.| opts))))) + +(defun expand-defsubst (form) + (let ((def (get (car form) 'defsubst))) + (do ((vars (car def) (cdr vars)) + (exprs (cdr form) (cdr exprs)) + (alist '() (cons (cons (car vars) (car exprs)) alist))) + ((null vars) + (unless (null exprs) + (error "-- too many arguments." form)) + (sublis alist (cdr def))) + (when (null exprs) + (error "-- too few arguments." form))))) + +(defun copyalist (l) + (do ((l l (cdr l)) + (a nil (cons (if (atom (car l)) + (car l) + (cons (caar l) (cdar l))) + a))) + ((atom l) (nreconc a l)))) + +(defun copytree (l) + (do ((l l (cdr l)) + (a nil (cons (copytree (car l)) a))) + ((atom l) (nreconc a l)))) + +(defun *rem (pred item list n) + (declare (fixnum n)) + (do ((list list (cdr list)) + (l nil)) + ((or (null list) + (not (plusp n))) + (nreconc l list)) + (cond ((funcall pred item (car list)) + (setq n (1- n))) + (t + (setq l (cons (car list) l)))))) + +(defun *del (pred item list n) + (declare (fixnum n)) + (do ((l list) + (last nil)) + ((or (null l) + (not (plusp n))) + list) + (cond ((funcall pred item (car l)) + (setq n (1- n)) + (setq l (cdr l)) + (cond ((null last) + (setq list l)) + (t (rplacd last l)))) + (t (setq last l) + (setq l (cdr l)))))) + +(defun ass (pred item list) + (do ((list list (cdr list))) + ((null list) nil) + (and (funcall pred item (caar list)) + (return (car list))))) + +(defun mem (pred item list) + (do ((list list (cdr list))) + ((null list) nil) + (and (funcall pred item (car list)) + (return list)))) + +(defun listp (x) + (or (not (atom x)) + (null x))) + +(defun ferror n + (ferror-cerror-hack nil nil (arg 1) (listify (- 1 n)))) + +(args 'ferror '(1 . 776)) + +(defun cerror n + (ferror-cerror-hack (arg 1) (arg 2) (arg 3) (listify (- 3 n)))) + +(args 'cerror '(4 . 776)) + +(defun ferror-cerror-hack + (proceedable restartable format-string-or-nil format-args) + (format msgfiles "~2&Error: ") + (if (null format-string-or-nil) + (lexpr-funcall #'format msgfiles format-args) + (lexpr-funcall #'format msgfiles format-string-or-nil format-args)) + (or (null *rset) + (let ((bl (cdddr (baklist))) + (prinlevel 2)) + (cond ((not (null bl)) + (format msgfiles "~&While in the function ~S" + (caar bl)) + (do ((i 0 (1+ i)) + (bl (cdr bl) (cdr bl))) + ((or (null bl) + (= i 3))) + (declare (fixnum i)) + (format msgfiles " <- ~S" (caar bl))))))) + (cond (proceedable (format msgfiles "~&(proceedable)")) + (restartable (format msgfiles "~&(restartable)"))) + (terpri msgfiles) + (let ((v (break error))) + (cond (proceedable v) + (restartable (*throw 'error-restart v)) + (t (error "Can't proceed or restart."))))) + +(defun get-macro-definition (sym) + (let ((p (or (getl sym '(macro subr lsubr expr + fsubr fexpr array)) + (let ((f (get sym 'autoload))) + (cond ((null f) nil) + (t + (load f) + (or (getl sym '(macro subr lsubr expr + fsubr fexpr array)) + (ferror "Autoloading failed to define: ~S" + sym)))))))) + (if (eq (car p) 'macro) + (cadr p) + nil))) + +(defun macroexpand (form) + (do () + ((or (atom form) + (not (symbolp (car form)))) + form) + (let ((f (get-macro-definition (car form)))) + (when (null f) + (return form)) + (setq form (funcall f form))))) + +(defun macroexpand-1 (form) + (if (or (atom form) + (not (symbolp (car form)))) + form + (let ((f (get-macro-definition (car form)))) + (if (null f) + form + (funcall f form))))) + +(defun mexp () + (or (get 'gprint1 'lsubr) + (load '((liblsp) gprint fasl))) + (terpri) + (princ '|>|) + (do ((x (read) (read))) + ((eq x t)) + (do () + ((or (atom x) + (not (symbolp (car x))))) + (let ((f (get-macro-definition (car x)))) + (when (null f) + (return nil)) + (terpri) + (princ '|==> |) + (gprint1 (setq x (funcall f x)) nil nil nil nil nil nil))) + (terpri) + (princ '|>|)) + 'done) + +(defun r-p () (do x '(r-p) (read) (eq x t) (print x) (terpri)) 'done) + +(defun xcar (x) (car x)) +(defun xrplaca (x v) (rplaca x v)) +(defun xcdr (x) (cdr x)) +(defun xrplacd (x v) (rplacd x v)) +(defun xcxr (n x) (cxr n x)) +(defun xrplacx (n x v) (rplacx n x v)) +(defun vcell (sym) (cdar sym)) +(defun pname (sym) (cxr 2 (car sym))) + +(sstatus feature alan/;lspint) diff --git a/src/alan/lspint.fasl b/src/alan/lspint.fasl new file mode 100755 index 0000000000000000000000000000000000000000..2cc80c8faa56c93cbea7772365ca518da7feed67 GIT binary patch literal 6206 zcmb7JUu;`v6+hp-w(F9#b=GusI<|dHw>2|y<1}m2rOW0U+i63b#Py%mZ3(;X;-;Zp zk|rs11FE2b^2Fc)_A((fA+bj$RXp)LAv7U);}vNV2q95-b37na;rz~bb8j-TN!&Cy z-`{i2@BI7Dcl+@#*Uq*zOD1O6M5@d$c~rtF7M)95-B2>AuhwSt%-n1B`Q^EV zd3|$kc}1@*=+|mD>dD&DQtkB#o|;EEjyp97K+Ky%4EjL=M6D6I+o8H;)dm= zLe6X(DsxlDoMJg?q{1GB?!d_rv)^?4Pw(iS+3K0u=XQ4et=`^Xc66*dS()$%o7vI) zlw;JOxarOM8rs8(xIMpodvS4LX{A214ZdD^eX$W)^sQPTs@a%O zrOHT=*5Be*?-_pS?if+BmuK)qFqX!Pso0yFHd$l`UDF4g9hrgfL-ux83_Ah3hVz~)Bpnc4f_X^!(mJWaKz{Q}DZqK5*agL;c7 zCOVpJL`Q{Gl&;32kmY;pZw+kztDAW!5U_**SRV3OIwF0FA`}%w;QL){`xM)(#sbSM zuv(3Q&4(b+rLEaDn`Sc<-iwx_3q76tn$cAQJk_6tC_FKR#ck5USi~RO_rT%D zpV;G19FSIu7e~>$pu4#R2~y3@&JG9kIxtbe5)tDfmh6=!r+6%ht{62H4N+TF6Gz>i)k`^Y~{ISFSSUXyS%~*&!TCr8?LU$<8Qu9l! zjAqBc=BEDY?3(O?B*TrEZQND7Xk@22mu;8mvIPT;a0|Oa4L6$|?~AjkjM4A#pm;xC zHvf`B>mXYHAXTOPM7+A9;M@GD$zm=uHJOnPcQaFkOHO{QRQ^n;m?#nd(feH@2?lnN ze%k50=XHo@n{;n;vr!{@9L9K8d}lqz;bVs^R*Pl`c*1}%Zf0Ggcdo#TF2jpt>JPQcwva=g97bN=Plz{su+q2hst`axus0M-ch+ zBr8ygQ^>A(1E_%Ys{krTcFGpKkl<@#D51RJe!_}ySLsO|nqBkx#3|I?R?s7}YwK?_ z9#DI4{VzL=Na~J}_!qFBN)&Sw)cbd5b&~&(%Oy=!r+kZ zRlR?a=+rz>Jpka_>Q7<=Vl&w=;zK((d;czuo$D_WZv%mEhz-O-K1*h=-IN$Y!21qb z1FW!-<*z$TGR>rrb>WdcG;L63b9saEivjXJMUw9Vls>>^0oeM@D*X)!PGn4_DaQP~ z9J3)HcjEiD;1homS7N2bsP#v-4luu=vnEV$ZFDS~p<8;N%iao?H5;5XYv7T4-fZB2 zzLFw=iPxcv)QPlr`WPQ&cNbl}Cc1D+CC@!~vvZ5_C>D&9=37i^3%uGZ&?FNBeB;*g z=EK&HSJeSZTj|tRsHuZHtfbh1m=r{|f|!AUQe?#-lvXCIOt2SjJ5zUaKF{SS=DVCa zC_?R!=a|MB!;Y_xizrl(fbhm1+f5#_;)sZtIwbl*k}4Qx@t&9^>E*PaSwOjO>&Q`E za+Lq)&#RntaSYkk?L-0A*q$OREdi&VW!$7der$BBP_#y+_Dg2WpYu*;9IJSpnLyJ> zg{mW&;%+PAC16|c!!$pk4d*8;K^sfZx1V#{`j5EI(cO#4a;x+-wYRrbbPrGbvx_O) z+&CzX64->SGt|kH)Dhw46wj3m-wTzga;`FzcI_BA$*i=n_&&M{CLUC*|pL>~;86NxY zGZ(MV-K^`mdA)MIuCLvme-#z1zUy&i%KC+**99Zq(X+U;@M^t2Q@eVz{_NJ+Qhj-) zwzMK+psdQdBJ)BMk4lViNiLo#JB+gybEPuhG>HC96g!HEaHckYd_{X4^um(%2%iwk z2Kfdpi_1~<3R+_KK3<}JtJ2*nCWR8}%6`d{2)Q|~V$^f8m|toJ^mqpsoGPmyAt{4R zCCZC$f%2^_%IbHr7-j2Sd8zX{buy@32l)`{0*{}gQliEz(Ew6w7|7dog3I*ARTVob z=~m!3tW`QCh>!t)2GO{p+QI?(>YP6*C3S|pWU((~zhtIfuD3a!xRQ|BMvQq#x`iz7 zn6qYJm6d}o5dAdZ!8_E4;6W$^9`43N2&{j&%E4p1oM=b*ML0_IU3uW_PvbL&wRfa6@1+oC|wZLQ#u!BQiRR_~@w5ci-R1G#j_}>Q`qR~h;4w}CX zmOxc^I?CM$)+-l=4rns743DNHEb z;Z68TcND4Hv@jzrxmHT+T&`@QSvi&R6yK$@UY6wvuO)+6yvMn{vT$>uHZwOrtFP5K z^k?u%VWxgK<%T0#Q{m`_;1$^Y2{<**HUv;}FIZcIUaCf>aMhX+g=x zQdwcy`-vjA2F*QXwE6z36&95Qivzr}jZ`|8k|lP=R@c{^lsP!L?%*01-Ng_;vC3;&*5Y&BUW*2qUc1WHIgqC(8S{{K@*Bl zqfW_-yM%w($pqhsoUF96QD1Q`8syo z6gzKNvDUl8^BWQv4VS-6uzsu)$f!M{YtdITMm2@2KfY>Mmp;eUtc2*0?@ZPcjfmn{ z#>F=yOm|pyZlV`j=VhS>hn}h0$ zTeeEu+dfhSi*bGX6ghVfj_C0~ioIDkb`qj=`MT*7-H0PY8GXTGX#N6MU5ThTz>6#t z4G+JlNm>-<`$U89mrsl7ipc`z*(3?^3^ZBc)(ug(&R+e6gQ^lDLBJdnserkD zbcLox0$~mwC9yc_*|UpBxF42VM96wY1gK`5B1!%+?i%hf?s^)MsA{p0cQOt)8|2ar z;|kre?V)oao3ZxQ@u2Bb3CqWO5^F*;)y4PlqZ2)S%G z9;7a6s%G3>7;#nvqq825s`tfHK6dH@yu((`P!Q>d166rqaGC)DF^(rjH4uYq3)Z!p z3R1;7YeNZT83W&K#uuW~q!?9L0$*E>i1u(6%d1vx0rx(sTn8q0HwbX~! RD<=BcHTWOV$M}zf{{msaJ%a!M literal 0 HcmV?d00001 diff --git a/src/alan/macits.13 b/src/alan/macits.13 new file mode 100755 index 00000000..02e39c06 --- /dev/null +++ b/src/alan/macits.13 @@ -0,0 +1,110 @@ +; -*- Midas -*- + +title MacITS - Library of MacLisp/ITS interface routines + +.fasl + +if1, .insrt sys:.fasl defs + +maxpush==10 ; Largest n for which 0PUSH-n will work. + +; (%GETSYS name) returns a list of fixnums representing the data returned by +; .GETSYS for SIXBIT /name/. +.entry %GETSYS SUBR 2 ; 1 arg + pushj p,sixmak ; TT: sixbit argument + move r,tt ; R=D+1: area name + setzi a, ; A: accumulate list of answers + jsp t,0push-maxpush ; Make room for data area on FXPDL + hrrzi d,1-maxpush(fxp) + hrli d,-maxpush ; D: aobjn to data area + .getsys d, + jrst getsy2 + subi d,1-maxpush(fxp) ; RH(D): # of words of data + hlre tt,d + imul tt,[-<1,,1>] + sub fxp,tt ; Discard extra words from FXPDL + hrrzi f,(d) ; F: # of words of data + jumple f,cpopj ; No words => all done +getsy1: movei b,(a) + pop fxp,tt + jsp t,fxcons + jsp t,%cons + sojg f,getsy1 + popj p, + +getsy2: sub fxp,r70+maxpush + jumpe r,cpopj + hlre tt,d ; TT: -# words needed + movn f,tt ; F: # words delivered + push fxp,[0] ; allocate that many on FXPDL + aojl tt,.-1 + .getsys d, + .lose ; Can't happen. + jrst getsy1 + +; (%EVAL name) looks up the name in Exec DDT's symbol table. Returns NIL +; if the symbol isn't found. +.entry %EVAL SUBR 2 ; 1 arg + pushj p,squeeze + .eval tt, + tdza a,a + jrst fix1 + popj p, + +; (%GETLOC addr) return the contents addr in the system. +.entry %GETLOC SUBR 2 ; 1 arg + push p,cfix1 ; NCALLable + jsp t,fxnv1 + hrlzi t,(tt) + hrri t,tt + .getloc t, + popj p, + +; (%SIXBIT name) returns a number. +.entry %SIXBIT SUBR 2 ; 1 arg + push p,cfix1 ; NCALLable + jrst sixmak + +; (%UNSIXBIT num) returns a symbol. +.entry %UNSIXBIT SUBR 2 ; 1 arg + jsp t,fxnv1 + jrst sixatm + +; SQUOZE SIXBIT +; 0 +; 1 - 12 "0" - "9" 20 - 31 +; 13 - 44 "A" - "Z" 41 - 72 +; 45 "*" 12 +; 46 "$" 04 +; 47 "%" 05 + +; (%SQUOZE name) returns a number. +.entry %SQUOZE SUBR 2 ; 1 arg + push p,cfix1 ; NCALLable + jrst squeeze + +; (%UNSQUOZE num) returns a symbol. +; Works by converting to SIXBIT because MacLisp lacks a built-in routine to +; do this properly. +.entry %UNSQUOZE SUBR 2 ; 1 arg + jsp t,fxnv1 + ldb d,[004000,,tt] ; D: squoze number less flags + setzi f, +unsqu1: idivi d,50 + jumpe r,unsqu3 + cail r,45 + jrst unsqu2 + addi r,'A-13 + caige r,'A + subi r,<'A-1>-'9 +unsqu3: lshc r,-6 + jumpn d,unsqu1 + move tt,f + jrst sixatm + +unsqu2: subi r,45-'* + caie r,'* + subi r,<'*+1>-'$ + jrst unsqu3 + +fasend diff --git a/src/alan/nstruc.280 b/src/alan/nstruc.280 new file mode 100755 index 00000000..d7acbe3d --- /dev/null +++ b/src/alan/nstruc.280 @@ -0,0 +1,1875 @@ +;;; -*- Mode:Lisp; Package:SI; Lowercase:True -*- +;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** +;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ** + +;The master copy of this file is in MC:ALAN;NSTRUCT > +;The current PDP10 MacLisp copy is in MC:ALAN;STRUCT > +;The current Lisp machine copy is in AI:LISPM2;STRUCT > +;The current Multics MacLisp copy is in >udd>Mathlab>Bawden>defstruct.lisp +; on MIT-Multics +;The current VMS-NIL copy is in [NIL.SRC.SPEC]STRUCT.LSP on HTJR + +;***** READ THIS PLEASE! ***** +;If you are thinking of munging anything in this file you might want to +;consider finding me (ALAN) and asking me to mung it for you. There is more +;than one copy of this file in the world (it runs in PDP10 and Multics MacLisp, +;NIL, Franz, PSL and on LispMachines) and whatever amazing features you are +;considering adding might be usefull to those people as well. If you still +;cannot contain yourself long enough to find me, AT LEAST send me a piece of +;mail describing what you did and why. Thanks for reading this flame. +; Alan Bawden (ALAN@MC) + +(eval-when (eval compile) + (cond ((and (status feature MacLisp) (status feature PDP10)) + (sstatus feature MacLisp-10)) + (t (sstatus nofeature MacLisp-10)))) + +(eval-when (compile) + (cond ((status feature ITS) + (load '|alan;lspenv init|)) + ((status feature Multics) + (load '|>udd>Mathlab>Bawden>lspenv.lisp|)))) + +#+MacLisp-10 +(cond ((status nofeature noldmsg) + (terpri msgfiles) + (princ '#.(and (status feature MacLisp-10) + (maknam (nconc (exploden ";Loading DEFSTRUCT ") + (exploden (caddr (truename infile)))))) + msgfiles))) + +#+NIL +(herald defstruct) + +#+Multics +(declare (genprefix defstruct-internal-) + (macros t)) + +#+MacLisp +(eval-when (eval compile) + (setsyntax #/: (ascii #\space) nil)) + +(eval-when (eval) + ;;So we may run the thing interpreted we need the simple + ;;defstruct that lives here: + (cond ((status feature ITS) + (load '|alan;struct initial|)) + ((status feature Multics) + (load '|>udd>Mathlab>Bawden>initial_defstruct|)))) + +(eval-when (compile) + ;;To compile the thing this probably is an old fasl: (!) + (cond ((status feature ITS) + (load '|alan;struct boot|)) + ((status feature Multics) + (load '|>udd>Mathlab>Bawden>boot_defstruct|)))) + +#+Multics +(defun nth (n l) + (do ((n n (1- n)) + (l l (cdr l))) + ((zerop n) (car l)))) + +#+Multics +(defun nthcdr (n l) + (do ((n n (1- n)) + (l l (cdr l))) + ((zerop n) l))) + +#+Multics +(defun displace (x y) + (cond ((atom y) + (rplaca x 'progn) + (rplacd x (list y))) + (t + (rplaca x (car y)) + (rplacd x (cdr y)))) + x) + +(eval-when (eval compile load) + +#+MacLisp +(defun defstruct-retry-keyword (x) + (let ((l (exploden x))) + (if (= (car l) #/:) + (implode (cdr l)) + x))) + +#+LispM +(defun defstruct-retry-keyword (x) + (intern (get-pname x) si:pkg-user-package)) + +#+NIL +(defmacro defstruct-retry-keyword (x) + `(to-keyword ,x)) + +);End of eval-when (eval compile load) + +;;; Eval this before attempting incremental compilation +(eval-when (eval compile) + +#+MacLisp-10 +(defmacro append-symbols args + (do ((l (reverse args) (cdr l)) + (x) + (a nil (if (or (atom x) + (not (eq (car x) 'quote))) + (if (null a) + `(exploden ,x) + `(nconc (exploden ,x) ,a)) + (let ((l (exploden (cadr x)))) + (cond ((null a) `',l) + ((= 1 (length l)) `(cons ,(car l) ,a)) + (t `(append ',l ,a))))))) + ((null l) `(implode ,a)) + (setq x (car l)))) + +#+Multics +(defmacro append-symbols args + `(make_atom (catenate ,@args))) + +#+LispM +(defmacro append-symbols args + `(intern (string-append ,@args))) + +#+NIL +(defmacro append-symbols args + `(symbolconc ,@args)) + +(defmacro defstruct-putprop (sym val ind) + `(push `(defprop ,,sym ,,val ,,ind) returns)) + +#+Multics +;;;lcp gobbles (defprop ... macro) at compile time, so we have to use +;;;putprop to be certain macro definitions make it into the object: +(defmacro defstruct-put-macro (sym fcn) + `(push `(putprop ',,sym ',,fcn 'macro) returns)) + +#+MacLisp-10 +(defmacro defstruct-put-macro (sym fcn) + `(push `(defprop ,,sym ,,fcn macro) returns)) + +#+LispM +(defmacro defstruct-put-macro (sym fcn) + (setq fcn (if (and (not (atom fcn)) + (eq (car fcn) 'quote)) + `'(macro . ,(cadr fcn)) + `(cons 'macro ,fcn))) + `(push `(fdefine ',,sym ',,fcn t) returns)) + +#+NIL +(defmacro defstruct-put-macro (sym fcn) + `(push `(add-macro-definition ',,sym ',,fcn) returns)) + +(defmacro make-empty () `'%%defstruct-empty%%) + +(defmacro emptyp (x) `(eq ,x '%%defstruct-empty%%)) + +;;;Here we must deal with the fact that error reporting works +;;;differently everywhere! + +#+MacLisp-10 +;;;first arg is ALWAYS a symbol or a quoted symbol: +(defmacro defstruct-error (message &rest args) + (let* ((chars (nconc (exploden (if (atom message) + message + (cadr message))) + '(#/.))) ;"Bad frob" => "Bad frob." + (new-message + (maknam (if (null args) + chars + (let ((c (car chars))) ;"Bad frob." => "-- bad frob." + (or (< c #/A) + (> c #/Z) + (rplaca chars (+ c #o40))) + (append '(#/- #/- #\space) chars)))))) + `(error ',new-message + ,@(cond ((null args) `()) + ((null (cdr args)) `(,(car args))) + (t `((list ,@args))))))) + +#+Multics +;;;first arg is ALWAYS a string: +(defmacro defstruct-error (message &rest args) + `(error ,(catenate "defstruct: " + message + (if (null args) + "." + ": ")) + ,@(cond ((null args) `()) + ((null (cdr args)) `(,(car args))) + (t `((list ,@args)))))) + +#+(or LispM NIL) +;;;first arg is ALWAYS a string: +(defmacro defstruct-error (message &rest args) + (do ((l args (cdr l)) + (fs "") + (na nil)) + ((null l) + `(ferror nil + ,(string-append message + (if (null args) + "." + (string-append ":" fs))) + ,.(nreverse na))) + (cond ((and (not (atom (car l))) + (eq (caar l) 'quote) + (symbolp (cadar l))) + (setq fs (string-append fs " " (string-downcase (cadar l))))) + (t + (push (car l) na) + (setq fs (string-append fs " ~S")))))) + +);End of eval-when (eval compile) + +;;;If you mung the the ordering af any of the slots in this structure, +;;;be sure to change the version slot and the definition of the function +;;;get-defstruct-description. Munging the defstruct-slot-description +;;;structure should also cause you to change the version "number" in this +;;;manner. +(defstruct (defstruct-description + (:type :list) + (:default-pointer description) + (:conc-name defstruct-description-) + (:alterant ()) + #+stingy-defstruct + (:eval-when (eval compile))) + (version 'one) + type + dummy ;used to be the displace function + slot-alist + named-p + constructors + (default-pointer nil) + (but-first nil) + size + (property-alist nil) + ;;end of "expand-time" slots + name + include + (initial-offset 0) + (eval-when '(eval compile load)) + alterant + (conc-name nil) + (callable-accessors #-(or LispM NIL) nil #+(or LispM NIL) t) + (size-macro nil) + (size-symbol nil) + (predicate nil) + (copier nil) + (print nil) + ) + +(defun get-defstruct-description (name) + (let ((description (get name 'defstruct-description))) + (cond ((null description) + (defstruct-error + "A structure with this name has not been defined" name)) + ((not (eq (defstruct-description-version) 'one)) + (defstruct-error "The internal description of this structure is +incompatible with the currently loaded version of defstruct, +you will need to recompile its definition" + name)) + (t description)))) + +;;;See note above defstruct-description structure before munging this one. +(defstruct (defstruct-slot-description + (:type :list) + (:default-pointer slot-description) + (:conc-name defstruct-slot-description-) + (:alterant ()) + #+stingy-defstruct + (:eval-when (eval compile))) + number + (ppss nil) + init-code + (type 'notype) + (property-alist nil) + ref-macro-name + ) + +;;;Perhaps this structure wants a version slot too? +(defstruct (defstruct-type-description + (:type :list) + (:default-pointer type-description) + (:conc-name defstruct-type-description-) + (:alterant ()) + #+stingy-defstruct + (:eval-when (eval compile))) + ref-expander + ref-no-args + cons-expander + cons-flavor + (cons-keywords nil) + (named-type nil) + (overhead 0) + (defstruct-expander nil) + (predicate nil) + (copier nil) + ) + +;; (DEFSTRUCT ( . ) . ) or (DEFSTRUCT . ) +;; +;; is of the form (