diff --git a/Makefile b/Makefile index 55fd429a..2fbc2395 100644 --- a/Makefile +++ b/Makefile @@ -9,9 +9,9 @@ SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ inquir acount gz sys decsys ecc alan sail kcc kcc_sy c games archy dcp \ spcwar rwg libmax rat z emaxim rz maxtul aljabr cffk das ell ellen \ jim jm jpg macrak maxdoc maxsrc mrg munfas paulw reh rlb rlb% share \ - tensor transl wgd zz + tensor transl wgd zz graphs lmlib pratt DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc chprog -BIN = sys2 emacs _teco_ lisp liblsp alan inquir sail comlap c decsys moon +BIN = sys2 emacs _teco_ lisp liblsp alan inquir sail comlap c decsys moon graphs # These files are used to create bootable tape images. RAM = bin/ks10/boot/ram.262 diff --git a/bin/graphs/closem.fasl b/bin/graphs/closem.fasl new file mode 100644 index 00000000..88bcc5f5 Binary files /dev/null and b/bin/graphs/closem.fasl differ diff --git a/bin/graphs/macros.fasl b/bin/graphs/macros.fasl new file mode 100644 index 00000000..1633aa96 Binary files /dev/null and b/bin/graphs/macros.fasl differ diff --git a/bin/liblsp/dprint.fasl b/bin/liblsp/dprint.fasl deleted file mode 100755 index 04f759e4..00000000 Binary files a/bin/liblsp/dprint.fasl and /dev/null differ diff --git a/build/build.tcl b/build/build.tcl index 3b647338..a1fef919 100644 --- a/build/build.tcl +++ b/build/build.tcl @@ -749,12 +749,12 @@ respond "*" ":link lisp;subloa lsp,nilcom;subloa >\r" 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" -respond "_" "lisp;_nilcom;subloa\r" respond "_" "lisp;_lspsrc;umlmac\r" respond "_" "inquir;fake-s\r" respond "_" "rwk;debmac\r" @@ -864,7 +864,6 @@ 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" @@ -888,11 +887,12 @@ type ":kill\r" respond "*" "complr\013" respond "_" "liblsp;_libdoc;sharab\r" -respond "_" "lisp;_libdoc;bs\r" +respond "_" "liblsp;_libdoc;bs\r" respond "_" "\032" type ":kill\r" respond "*" ":link lisp;sharab fasl,liblsp;\r" +respond "*" ":link lisp;bs fasl,liblsp\r" respond "*" "complr\013" respond "_" "\007" @@ -929,12 +929,15 @@ respond "*" ":link lisp;struct fasl,liblsp;struct fasl\r" respond "*" ":midas liblsp;_alan;macits\r" expect ":KILL" +respond "*" "complr\013" +respond "_" "liblsp;_alan;dprint\r" +respond "_" "\032" +type ":kill\r" + #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" @@ -1646,7 +1649,7 @@ respond "_" "\032" type ":kill\r" respond "*" ":link rlb%;faslre fasl,rlb;\r" - +respond "*" ":copy rlb;faslre fasl,liblsp;\r" respond "*" "l\013" respond "Alloc?" "n" respond "*" "(setq pure t)" @@ -1776,6 +1779,237 @@ respond "(C1)" "quit();" respond "*" ":link sys3;ts macsym,maxdmp;loser >\r" +### more lisplib stuff +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;%print\r" +respond "_" "liblsp;_libdoc;6bit\r" +respond "_" "liblsp;_libdoc;apropo\r" +respond "_" "liblsp;_libdoc;arith\r" +respond "_" "liblsp;_libdoc;aryfil\r" +respond "_" "liblsp;_libdoc;atan\r" +respond "_" "liblsp;_libdoc;autodf\r" +respond "_" "liblsp;_libdoc;bboole\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;bench\r" +respond "_" "liblsp;_libdoc;binprt\r" +respond "_" "liblsp;_lmlib;gprint\r" +respond "_" "liblsp;_libdoc;carcdr\r" +respond "_" "liblsp;_libdoc;char\r" +respond "_" "liblsp;_libdoc;debug*\r" +respond "_" "liblsp;_libdoc;defsta\r" +respond "_" "lisp;_libdoc;defvst\r" +respond "_" "liblsp;_libdoc;doctor\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;dow\r" +respond "_" "liblsp;_libdoc;dribbl\r" +respond "_" "liblsp;_libdoc;dumpgc\r" +respond "_" "liblsp;_libdoc;fake-s\r" +respond "_" "liblsp;_libdoc;fforma\r" +respond "_" "liblsp;_libdoc;filbit\r" +respond "_" "liblsp;_libdoc;fload\r" +respond "_" "liblsp;_libdoc;fontrd\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;for\r" +respond "_" "liblsp;_libdoc;gcdemn\r" +respond "_" "liblsp;_libdoc;genfns\r" +respond "_" "liblsp;_libdoc;graphs\r" +respond "_" "liblsp;_libdoc;graphm\r" +respond "_" "liblsp;_libdoc;graph$\r" +respond "_" "liblsp;_libdoc;grapha\r" +respond "_" "liblsp;_libdoc;grapht\r" +respond "_" "liblsp;_libdoc;impdef\r" +respond "_" "liblsp;_libdoc;laugh\r" +respond "_" "liblsp;_libdoc;lchstr\r" +respond "_" "liblsp;_nilcom;let\r" +respond "_" "liblsp;_libdoc;lets\r" +respond "_" "liblsp;_libdoc;linere\r" +respond "_" "liblsp;_libdoc;lspmac\r" +respond "_" "liblsp;_libdoc;lispt\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;loop\r" +respond "_" "liblsp;_libdoc;more\r" +respond "_" "liblsp;_libdoc;nshare\r" +respond "_" "liblsp;_libdoc;octal\r" +respond "_" "liblsp;_libdoc;optdef\r" +respond "_" "liblsp;_libdoc;phsprt\r" +respond "_" "liblsp;_libdoc;privob\r" +respond "_" "liblsp;_libdoc;prompt\r" +respond "_" "liblsp;_libdoc;qtrace\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;reads\r" +respond "_" "liblsp;_libdoc;redo\r" +respond "_" "liblsp;_libdoc;save\r" +respond "_" "liblsp;_libdoc;sets\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;share\r" +respond "_" "liblsp;_libdoc;sixbit\r" +respond "_" "liblsp;_libdoc;split\r" +respond "_" "liblsp;_libdoc;stack\r" +respond "_" "liblsp;_libdoc;statty\r" +respond "_" "liblsp;_libdoc;stepmm\r" +respond "_" "liblsp;_libdoc;stepr\r" +respond "_" "liblsp;_libdoc;string\r" +respond "_" "liblsp;_libdoc;sun\r" +respond "_" "liblsp;_libdoc;trap\r" +respond "_" "liblsp;_libdoc;ttyhak\r" +respond "_" "liblsp;_libdoc;wifs\r" +respond "_" "liblsp;_libdoc;window\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":link liblsp;defvst fasl,lisp;\r" +respond "*" ":link liblsp;format fasl,liblsp;fforma fasl\r" +respond "*" ":link libdoc;lispt info,info;lispt >\r" +respond "*" ":link liblsp;sharpm fasl,lisp;\r" +respond "*" ":copy nilcom;sharpm >,libdoc;sharpm nil\r" +respond "*" ":link libdoc;step info,.info.;\r" +respond "*" ":link libdoc;stepmm info,.info.;lisp stepmm\r" +respond "*" ":copy nilcom;string >,libdoc;string nil\r" + +# can't build any more LIBLSP FASLs because directory is full +respond "*" ":delete liblsp;%print unfasl\r" +respond "*" ":delete liblsp;6bit unfasl\r" +respond "*" ":delete liblsp;apropo unfasl\r" +respond "*" ":delete liblsp;arith unfasl\r" +respond "*" ":delete liblsp;aryfil unfasl\r" +respond "*" ":delete liblsp;atan unfasl\r" +respond "*" ":delete liblsp;autodf unfasl\r" +respond "*" ":delete liblsp;bboole unfasl\r" +respond "*" ":delete liblsp;bench unfasl\r" +respond "*" ":delete liblsp;binprt unfasl\r" +respond "*" ":delete liblsp;break unfasl\r" +respond "*" ":delete liblsp;bs unfasl\r" +respond "*" ":delete liblsp;carcdr unfasl\r" +respond "*" ":delete liblsp;char unfasl\r" +respond "*" ":delete liblsp;comrd unfasl\r" +respond "*" ":delete liblsp;comred unfasl\r" +respond "*" ":delete liblsp;dbg unfasl\r" +respond "*" ":delete liblsp;debug* unfasl\r" +respond "*" ":delete liblsp;defsta unfasl\r" +respond "*" ":delete liblsp;doctor unfasl\r" +respond "*" ":delete liblsp;dow unfasl\r" +respond "*" ":delete liblsp;dprint unfasl\r" +respond "*" ":delete liblsp;dribbl unfasl\r" +respond "*" ":delete liblsp;dumpgc unfasl\r" +respond "*" ":delete liblsp;fake-s unfasl\r" +respond "*" ":delete liblsp;fasdmp unfasl\r" +respond "*" ":delete liblsp;fforma unfasl\r" +respond "*" ":delete liblsp;filbit unfasl\r" +respond "*" ":delete liblsp;fload unfasl\r" +respond "*" ":delete liblsp;fontrd unfasl\r" +respond "*" ":delete liblsp;for unfasl\r" +respond "*" ":delete liblsp;gcdemn unfasl\r" +respond "*" ":delete liblsp;genfns unfasl\r" +respond "*" ":delete liblsp;gprint unfasl\r" +respond "*" ":delete liblsp;graph$ unfasl\r" +respond "*" ":delete liblsp;grapha unfasl\r" +respond "*" ":delete liblsp;graphm unfasl\r" +respond "*" ":delete liblsp;graphs unfasl\r" +respond "*" ":delete liblsp;grapht unfasl\r" +respond "*" ":delete liblsp;impdef unfasl\r" +respond "*" ":delete liblsp;iota unfasl\r" +respond "*" ":delete liblsp;laugh unfasl\r" +respond "*" ":delete liblsp;lchstr unfasl\r" +respond "*" ":delete liblsp;let unfasl\r" +respond "*" ":delete liblsp;letfex unfasl\r" +respond "*" ":delete liblsp;lets unfasl\r" +respond "*" ":delete liblsp;linere unfasl\r" +respond "*" ":delete liblsp;lispm unfasl\r" +respond "*" ":delete liblsp;lispt unfasl\r" +respond "*" ":delete liblsp;loop unfasl\r" +respond "*" ":delete liblsp;lspmac unfasl\r" +respond "*" ":delete liblsp;lusets unfasl\r" +respond "*" ":delete liblsp;more unfasl\r" +respond "*" ":delete liblsp;nshare unfasl\r" +respond "*" ":delete liblsp;octal unfasl\r" +respond "*" ":delete liblsp;od unfasl\r" +respond "*" ":delete liblsp;optdef unfasl\r" +respond "*" ":delete liblsp;phsprt unfasl\r" +respond "*" ":delete liblsp;privob unfasl\r" +respond "*" ":delete liblsp;prompt unfasl\r" +respond "*" ":delete liblsp;qtrace unfasl\r" +respond "*" ":delete liblsp;reads unfasl\r" +respond "*" ":delete liblsp;redo unfasl\r" +respond "*" ":delete liblsp;save unfasl\r" +respond "*" ":delete liblsp;sets unfasl\r" +respond "*" ":delete liblsp;sharab unfasl\r" +respond "*" ":delete liblsp;share unfasl\r" +respond "*" ":delete liblsp;sixbit unfasl\r" +respond "*" ":delete liblsp;smurf unfasl\r" +respond "*" ":delete liblsp;split unfasl\r" +respond "*" ":delete liblsp;stack unfasl\r" +respond "*" ":delete liblsp;statty unfasl\r" +respond "*" ":delete liblsp;stepmm unfasl\r" +respond "*" ":delete liblsp;stepr unfasl\r" +respond "*" ":delete liblsp;string unfasl\r" +respond "*" ":delete liblsp;sun unfasl\r" +respond "*" ":delete liblsp;time unfasl\r" +respond "*" ":delete liblsp;trap unfasl\r" +respond "*" ":delete liblsp;tty unfasl\r" +respond "*" ":delete liblsp;ttyhak unfasl\r" +respond "*" ":delete liblsp;wifs unfasl\r" +respond "*" ":delete liblsp;window unfasl\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((libdoc) set ira1))" +respond "T" "(maklap)" +respond "_" "liblsp;_libdoc;askusr\r" +respond "_" "liblsp;_pratt;cgrub\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((lisp) cgol fasl))" +respond "312654" "(maklap)" +respond "_" "liblsp;_pratt;cgprin\r" +respond "_" "\032" +type ":kill\r" + +# clean up remaining unfasl files in liblsp +respond "*" ":delete liblsp;askusr unfasl\r" +respond "*" ":delete liblsp;cgprin unfasl\r" +respond "*" ":delete liblsp;cgrub unfasl\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(sstatus features Compile-Subload)" +respond "COMPILE-SUBLOAD" "(maklap)" +respond "_" "lisp;_nilcom;subloa\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":midas liblsp;_libdoc;bssq\r" +respond "*" ":midas liblsp;_libdoc;aryadr\r" +respond "*" ":midas lisp;_l;humble\r" +respond "*" ":midas liblsp;_libdoc;link\r" +respond "*" ":midas liblsp;_libdoc;lscall\r" +respond "*" ":link sys;fasdfs 1,lisp;.fasl defs\r" +respond "*" ":midas liblsp;_libdoc;cpyhnk\r" + +respond "*" ":link lisp;defns mid,l;defns >\r" +respond "*" ":midas liblsp;_libdoc;fft\r" +respond "*" ":midas liblsp;_libdoc;phase\r" + bootable_tapes # make output.tape diff --git a/src/alan/dprint.142 b/src/alan/dprint.142 index 68583dc2..fa71f6ab 100755 Binary files a/src/alan/dprint.142 and b/src/alan/dprint.142 differ diff --git a/src/graphs/close.42 b/src/graphs/close.42 new file mode 100644 index 00000000..cf5e852d --- /dev/null +++ b/src/graphs/close.42 @@ -0,0 +1,71 @@ +;;;-*-lisp-*- + +(herald closure) + +(eval-when (eval compile load) + (cond ((status feature complr) + (or (get 'closure-macros 'version) + (load '((graphs)closem))) + (*lexpr GCALL) + (*expr make-closure)) + (t + (mapc '(lambda (u) (putprop u '((graphs)closem) 'autoload)) + '(open-GCALL self-GCALL defclosure make-closure-1))))) + +(DEFUN CLOSURE-SUBR-HOOK (X1 X2 X3 X4 X5) + ; this function MUST be compiled in order for the + ; system to work. + (FUNCALL (CLOSURE-NAME *SELF*) X1 X2 X3 X4 X5)) + +(defun make-closure (name full-instance-vars full-instance-vals + pre-instance-vars pre-instance-vals) + (let ((c + (make-closure-1 name name + subr-pointer (OR (get name 'subr) + (GET 'CLOSURE-SUBR-HOOK 'SUBR) + (ERROR "Can't hook" NAME)) + full-instance-vars full-instance-vars + full-instance-vals full-instance-vals + pre-instance-vars `(*self* ,@pre-instance-vars) + pre-instance-vals pre-instance-vals))) + (push c (closure-pre-instance-vals c)) + c)) + +(defun GCALL (f &optional x1 x2 x3 x4 x5) + (open-GCALL f x1 x2 x3 x4 x5)) + +(defvar traced-closure-msgfile tyo) +(defvar traced-closure-linefeedp nil) + +(defclosure traced-closure (x1 x2 x3 x4 x5) + ((level 0)) + (sub-closure) + + (setq level (1+ level)) + (setq traced-closure-linefeedp t) + (format traced-closure-msgfile + "~%~A ~A :~A ~:[~;<~A~:[>~;,~A~:[>~;,~A~:[>~;,~A>~]~]~]~]" + (closure-name sub-closure) + level + x1 x2 x2 x3 x3 x4 x4 x5 x5) + (let ((traced-closure-linefeedp nil)) + (setq x1 (GCALL sub-closure x1 x2 x3 x4 x5)) + (format traced-closure-msgfile + "~:[~2*~;~%~A ~A~] =>~A" + traced-closure-linefeedp + (closure-name sub-closure) + level + x1)) + (setq level (1- level)) + x1) + +(defun make-traced-closure (sub-closure) + (make-traced-closure-closure () (sub-closure sub-closure))) + +(mapc '(lambda (u) (putprop u '((alan)dprint) 'autoload)) + '(describe dprint)) + +(defmap-self-GCALL fixnum 2) +(defmap-self-GCALL fixnum 4) +(defmap-self-GCALL flonum 2) +(defmap-self-GCALL flonum 4) diff --git a/src/graphs/graphs.102 b/src/graphs/graphs.102 new file mode 100644 index 00000000..5440f850 --- /dev/null +++ b/src/graphs/graphs.102 @@ -0,0 +1,132 @@ +;;;-*-LISP-*- +;;; a package for graphics. +;;; 'graphics-stream' takes floating point coordinates, can do +;;; Scaling and clipping, and sends the resulting fixnums to +;;; a stream which presumably translates those into hardware commands. +;;; an example is the 'ards-stream' which of course can be used +;;; directly also. Other possible sub-streams include Tektronics, +;;; and pseudo-graphics (e.g. character display hacking) +;;; a possible super-stream to the 'graphics-stream' is one +;;; which takes 3 dimensional set-point and move-point messages +;;; and translates them to. + +(herald graphs) + +(eval-when (eval compile load) + (or (get 'closure 'version) + (load '((graphs)close)))) + +(defprop make-ards-stream ((dsk graphs) grapha fasl) autoload) +(defprop make-graphics-stream ((dsk graphs)graph$ fasl) autoload) +(mapc '(lambda (u) (putprop u '((dsk graphs)circle fasl) 'autoload)) + '(draw-circle draw-spiral)) +(defprop make-clipping-stream ((dsk graphs) clip fasl) autoload) + +(eval-when (compile load) + (cond ((status feature complr) + (*expr set-pen move-pen vector-pen draw-point + set-viewport get-viewport set-window get-window) + (*lexpr graphics-stream-close graphics-stream-open)))) + + +;;; the generic graphics functions. these all take a closure argument +;;; and map over cannonical uniform structures. + +(defun set-pen (f x y) + (GCALL f 'set-pen x y)) + +(eval-when (compile eval) + (defmacro gen-maptest (u) + `(in-closure-env + f + (cond ((fixnum-configurationp x) + (fixnum-map-self-GCALL-2 ',u x y)) + (t + (flonum-map-self-GCALL-2 ',u x y)))))) + +(defun move-pen (f x y) (gen-maptest move-pen)) + +(defun vector-pen (f x y)(gen-maptest vector-pen)) + +(defun draw-point (f x y)(gen-maptest draw-point)) + +(defun draw-line (f x1 y1 x2 y2) + (in-closure-env + f + (cond ((fixnum-configurationp x1) + (fixnum-map-self-GCALL-4 'draw-line x1 y1 x2 y2)) + (t + (flonum-map-self-GCALL-4 'draw-line x1 y1 x2 y2))))) + +(defun fixnum-configurationp (x) + (cond ((numberp x) (fixp x)) + ((and x (atom x) (eq (typep x) 'array)) + (eq (car (arraydims x)) 'fixnum)) + (t + (or (null x) (fixp (car x)))))) + +(defun graphics-stream-close (f &optional mode)(GCALL f 'close mode)) + +(defun graphics-stream-tyo (f arg) (GCALL f 'tyo arg)) + +(defun graphics-stream-open (f &optional (mode 'tty) (name nil)) + (GCALL f 'open mode name)) + +(defun set-viewport (f x0 x1 y0 y1) + (GCALL f 'set-viewport x0 x1 y0 y1)) + +(defun get-viewport (f) + (GCALL f 'viewport)) + +(defun set-window (f x0 x1 y0 y1) + (GCALL f 'set-window x0 x1 y0 y1)) + +(defun get-window (f) + (GCALL f 'window)) + +(defun set-invisiblep (f flag) + (GCALL f 'set-invisiblep flag)) + +(defun set-dottep (f flag) + (GCALL f 'set-dottep flag)) + +(defun draw-frame (s) + (let (((x0 x1 y0 y1) (get-window s))) + (set-pen s x0 y0) + (move-pen s x1 y0) + (move-pen s x1 y1) + (move-pen s x0 y1) + (move-pen s x0 y0))) + + + +(eval-when (compile eval) + (defstruct (graphics-sfa sfa conc-name + (constructor make-graphics-sfa-1)) + out-stream)) + +(defun make-graphics-sfa (out-stream) + (make-graphics-sfa-1 out-stream out-stream)) + +(defun graphics-sfa (sfa com arg) + (caseq com + (tyo + (GCALL (graphics-sfa-out-stream sfa) 'tyo arg)) + (open + (graphics-stream-open (graphics-sfa-out-stream sfa) + (cond ((atom arg) arg) + (t (car arg))) + (cond ((atom arg) nil) + (t (cadr arg))))) + (close + (graphics-stream-close (graphics-sfa-out-stream sfa))) + (which-operations + '(tyo open close)))) + + +(defun operations-union (s1 s2) + (do () + ((null s1) s2) + (let ((elem (pop s1))) + (or (memq elem s2) + (push elem s2))))) \ No newline at end of file diff --git a/src/graphs/graphs.demo b/src/graphs/graphs.demo new file mode 100644 index 00000000..b33e31e2 --- /dev/null +++ b/src/graphs/graphs.demo @@ -0,0 +1,64 @@ +;;;-*-lisp-*- +(comment) + +(progn + (load '((gjc)gjc lisp)) + (defaultf '((dsk graphs))) + + (load 'demo) + (setq prinlength 7) + (setq read-pause-time 0.1) + + (cursorpos 'c tyo) + (format tyo +"This is a very short demo of graphics. +To get the demo type (DEMO) which invokes the +lisp function DEMO defined by this file. +What you will see is a sequence of lisp forms +which if you typed would have the effect that +you see. +") + (defun pause () (format tyo "~&-pause-") (cursorpos 'n)) + (defun hpause () (cursorpos 'top) (pause)) + (setq demo-forms + '((or (get 'plot 'version) (load 'plot)) + (comment "Set the input and output numeric radix to TEN.") + (setq base 10. ibase 10.) + (gcall graphic-stream 'open 'dsk '((graphs) demo ards)) + (comment "set the number of points.") + (setq plotnum 200) + (plot (times 3 x (cos (times 4 x)) (sin x)) x -5 5) + (hpause) + (plot sin -3.1416 3.1416) + (pause) + (comment "Or you can define a function.") + (defun f1 (x) (*$ x x)) + (pause) + (plot f1 -3 3) + (pause) + (comment "there is a nice function for making spirals") + (defun sp (n m) + (draw-spiral graphic-stream 1.5 0.0 0.0 n m)) + (comment "use the auto-scaling of PLOT to set up the window.") + (pause) + (progn (plot x x -1 1) (sp 33 33)) + (hpause) + (gcall graphic-stream 'cursorpos 'c) + (sp 75. 3.) + (hpause) + (sp 75. 5.) + (hpause) + (comment " how about some 3d-graphics? ") + (or (get 'plot3 'version) (load 'plot3)) + (gcall graphic-stream 'set-window -0.8 0.8 -0.8 0.8) + (comment "set the euler angles. ") + (gcall 3d-stream 'Set-theta -1.0) + (gcall 3d-stream 'set-phi 0.1) + (gcall 3d-stream 'set-psi 0.4) + (gcall graphic-stream 'cursorpos 'c) + (mobius 100 2) + (hpause) + (torus 100 10) + (gcall graphic-stream 'close 'dsk) + (comment "that is all. enjoy!"))) + '*) diff --git a/src/graphs/graphs.usage b/src/graphs/graphs.usage new file mode 100644 index 00000000..af8b4eed --- /dev/null +++ b/src/graphs/graphs.usage @@ -0,0 +1,100 @@ +Date: 1 July 1980 14:57-EDT +From: George J. Carrette +To: "(FILE [GJC;GRAPHS USAGE])" at MIT-MC + + Date: 1 July 1980 14:53-EDT + From: George J. Carrette + To: MEM at MIT-MC, JGA at MIT-MC + cc: "(FILE [FILE GJC;GRAPHS USAGE])" at MIT-MC + + + The generic functions are + + set-pen, move-pen, vector-pen, draw-point, draw-line. + + set-window, set-viewport, get-window, get-viewport. + + The first argument to these functions is always a graphic object. + The rest of the arguments are always paired X,Y. e.g. + (set-pen foo x y) and (draw-line foo x1 y1 x2 y2). + The coordinate arguments can either be numbers, arrays of numbers, + or lists of numbers. + + (make-ards-stream) makes you an ards-object. + (make-graphics-stream ) takes an ards-object and returns + a flonum-scaling graphics stream. + + Other operations are conviently accessed with the CALL function. + + (call 'cursorpos 'c) + (call 'which-operations) + (call 'open 'tty) + (call 'open 'dsk '((foo) bar >)) + (call 'close) + + No compile-time considerations are needed when using the generic operators. + However, users of call should do (or (get 'closure 'version) (load '((gjc)close))) + at eval and compile times. + + + + A graphics stream is a special object which these generic functions + can operate on. These objects keep an internal state, such as + the position of the last point plotted, and the values of the + scaling factors. + + Loading GJC;GRAPHS FASL will make the the relevant functions + autoloading. Functions for hardware specific objects are in + different files. + + See GRAPHZ DEMO for example usage. + + (MAKE-ARDS-STREAM) returns an object which takes fixnum arguments + and outputs ARDs graphics codes to file or TTY objects which it + stores internaly. This is a primitive stream. + + (MAKE-TEK-STREAM) is not yet implemented. + + (MAKE-GRAPHICS-STREAM ) takes a primitive stream + as argument and returns a stream which can do floating point + scaling and clipping, and setting of windows and viewports. + + (GRAPHICS-STREAM-OPEN &OPTIONAL ) + is 'TTY or 'DSK. is the file name when opened + in 'DSK mode. + + (GRAPHICS-STREAM-CLOSE ) closes any DSK file. + + (SET-PEN X Y) + + (MOVE-PEN X Y) + draws a line from the last point the new point. + + (VECTOR-PEN X Y) does a relative move of the pen. + + (DRAW-POINT X Y) draws a line of length 0. + + (GRAPHICS-STREAM-TYO ) presently does a character + TYO. Does not try and enforce clipping. #\CR may cause lossage. + Line-drawing of characters and scaling may be supported in the + future. + + The following are not supported in primitive graphic streams. + + (SET-WINDOW X0 X1 Y0 Y1) + the window is the apparent flonum size. + + (SET-VIEWPORT X0 X1 Y0 Y1) + The viewport is set in "hardware" or rather, primitive stream + dependant, fixnums. + The default values for these are usually reasonable, by definition. + + (MAKE-GRAPHICS-SFA ) takes a graphics stream + and returns and SFA which may be used as an argument to + PRINT, FORMAT, etc. + + (MAKE-TRACED-FUNCTOR ) takes a functor (a graphics stream is + a functor) and returns a functor which is traced. Trace information + is output to the value of TRACED-FUNCTOR-MSGFILE which should NOT be + a stream which calls any traced functors! The returned functor is + not equal to the argument, i.e. the argument is not side effected. diff --git a/src/l/defns.240 b/src/l/defns.240 new file mode 100755 index 00000000..9e85b238 --- /dev/null +++ b/src/l/defns.240 @@ -0,0 +1,1214 @@ +;;; -*-MIDAS-*- +;;; ************************************************************** +;;; ***** MACLISP ****** STANDARD AC, UUO, AND MACRO DEFINITIONS * +;;; ************************************************************** +;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** +;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* +;;; ************************************************************** + + +;;; THIS FILE CONTAINS: +;;; STANDARD SYMBOLIC ACCUMULATOR DEFINITIONS. +;;; UUO DEFINITIONS: +;;; ERROR CALLS AND STRING TYPEOUT. +;;; COMPILED CODE TO INTERPRETER INTERFACES. +;;; VARIOUS UUOS USEFUL FROM DDT. +;;; .GLOBAL DECLARATIONS. +;;; .FORMAT DECLARATIONS. +;;; TYPE BIT DEFINITIONS FOR USE WITH SEGMENT TABLE +;;; MACROS FOR CONDITIONALIZING SINGLE LINES OF CODE. +;;; GENERAL MACRO DEFINITIONS [THAT ANY LOSER MIGHT WANT]. +;;; SYMBOL BLOCK-STRUCTURE DEFINITIONS +;;; SYMBOLIC NAMES RELATED TO ARRAYS. +;;; SYMBOLIC NAMES RELATED TO FILES. + +;;; THE DEFINITIONS FOR MACLISP CONTAINED HEREIN +;;; ARE RELATIVELY STABLE. THIS FILE MAY BE .INSRT'D BY MIDAS +;;; FILES ASSEMBLED IN .FASL MODE TO DEFINE THESE THINGS. +;;; THE .GLOBAL DECLARATIONS IN PARTICULAR ARE FOR THE +;;; BENEFIT OF THESE .FASL FILES. +;;; IT IS A GOOD IDEA FOR .FASL FILES TO USE THE FASEND MACRO +;;; IN PLACE OF THE USUAL END STATEMENT. + +;;; SYMBOLS FOR COMPILED CODE + +IFNDEF ITS, ITS==:1 +IFNDEF TOPS10, TOPS10==:0 +IFNDEF TOPS20, TOPS20==:0 +IFNDEF SAIL, SAIL==:0 +IFNDEF TENEX, TENEX==:0 +IFNDEF CMU, CMU==:0 + +IFNDEF D10, D10==:TOPS10\SAIL\CMU +IFNDEF D20, D20==:TOPS20\TENEX + +IFNDEF PAGING, PAGING==:ITS\D20 + +IFNDEF BIGNUM, BIGNUM==:1 +IFNDEF JOBQIO, JOBQIO==:1 +IFNDEF SFA, SFA==:1 + + + +SUBTTL ACCUMULATOR USAGE + +NIL=:0 ;ATOM HEADER FOR NIL +A=:1 ;ARG 1; VALUE; MARKED FROM BY GC +B=:2 ;ARG 2; MARKED FROM BY GC +C=:3 ;ARG 3; MARKED FROM BY GC +AR1=:4 ;ARG 4; MARKED FROM BY GC +AR2A=:5 ;ARG 5; MARKED FROM BY GC +NACS==:5 ;NUMBER OF ACS MARKED FROM BY GC - NO OTHER ACS MARKED +T=:6 ;- FOR LSUBR CALL; ALSO USED FOR JSP T, +TT=:7 ;TEMP; OFTEN USED FOR ARGS TO INTERNAL ROUTINES +D=:10 ;SOMEWHAT LESS TEMPORARY THAN TT +R=:11 ;DITTO; SOMETIMES USED FOR JSP R, +F=:12 ;SOMEWHAT LESS TEMPORARY THAN D AND R +FREEAC=:13 ;UNUSED BY LISP, EXCEPT SAVED-USED-RESTORED BY GC +P=:14 ;SUBROUTINE AND SYSTEM PDL POINTER ("REGULAR PDL") +FLP=:15 ;FLONUM PDL POINTER ("FLOPDL") +FXP=:16 ;FIXNUM PDL POINTER ("FIXPDL") +SP=:17 ;LAMBDA-BINDINGS PDL POINTER ("SPECIAL PDL") +;;; PDL POINTERS ARE ALWAYS KEPT IN ACS. PDL POINTERS ARE NOT +;;; MARKED FROM, BUT PDL DATA ON REGULAR AND SPECIAL PDLS ARE +;;; PROTECTED FROM GARBAGE COLLECTION. +;;; FLP IS NOT USED BY LISP, EXCEPT AT LDATFL AND ERRIOJ, +;;; BUT PRIMARILY BY COMPILED NUMERICAL CODE. +;;; DO NOT DO RANDOM PUSH/POPS ON SP - USE BIND AND UNBIND ROUTINES. + +SUBTTL DEFINITIONS OF UUO'S + +;;; NOTE: LERR < LER3 < ERINT < SERINT -- SEE ERRFRAME. + +LERR=:1_33 ;LISP ERROR; AC FIELD=0 => MSG IS SIXBIT, ELSE S-EXP +ACALL=:2_33 ;KLUDGY FAST UUO FOR NCALLS TO ARRAYS +AJCALL=:3_33 ;AJCALL:ACALL :: JCALL:CALL +LER3=:4_33 ;EPRINT, THEN LERR +ERINT=:5_33 ;A CORRECTABLE ERROR +PP=:6_33 ;SEXP TYPE OUT FROM DDT +STRT=:7_33 ;STRING TYPEOUT (sixbit format - stops on unquoted "!") +SERINT=:10_33 ;LIKE ERINT, BUT S-EXPRESSION MESSAGE. +TP=:11_33 ;PRINTS ST ENTRY FOR A GIVEN LOCATION +IOJRST=:12_33 ;JRST TO ADR AFTER PUTTING I/O ERROR MSG IN C +STRT7=:13_33 ;STRING TYPEOUT (ascii format - stops on 0 byte) +UUOMAX==:13 ;NO OF ERROR-TYPE UUO'S + + +CALL=:14_33 ;BASIC CALL FROM COMPILED CODE TO INTERFACE TO INTERPRETER +JCALL=:CALL+1_33 ;4.1 BIT ON MEANS JRST TO FUNCTION RATHER THAN PUSHJ +CALLF=:CALL+2_33 ;4.2 BIT ON MEANS NEVER CONVERT UUO INTO PUSHJ [OR JRST] +JCALLF=:CALL+3_33 +NCALL=:20_33 ;4.5 BIT MEANS NUMBER FUNCTION CALL +NJCALL=:NCALL+1_33 +NCALLF=:NCALL+2_33 +NJCALF=:NCALL+3_33 +NUUOCLS==:NJCALF_-33-CALL_-33 + +;;; SPECIAL INTERPRETATION OF STRT AC FIELD: +;;; AC FIELD OUTPUT TO +;;; 0 OUTFILES IF ^R SET; TTY IF ^W SET +;;; 17 MSGFILES +;;; X FILE(S) IN ACCUMULATOR X + +;;; ERINT AND SERINT ARE DECODED BY THEIR ACCUMULATOR FIELDS. +;;; HERE ARE SOME SYMBOLS FOR REFERENCING THEM. + +NERINT==0 +IRPS X,,[UDF,UBV,WTA,UGT,WNA,GCL,FAC,IOL] + %!X=:ERINT .IRPCNT, + %%!X=:SERINT .IRPCNT, + DEFINE X CRUFT + %!X [SIXBIT CRUFT] + TERMIN + NERINT==NERINT+1 +TERMIN + +;;; SHORT FORM ATOM WHAT IS IT? +;;; +;;; 0) UDF UNDEF-FNCTN UNDEFINED FUNCTION (FUNCTION IN A) +;;; 1) UBV UNBND-VRBL UNBOUND VARIABLE BEING EVAL'ED (ATOM IN A) +;;; 2) WTA WRNG-TYPE-ARGS WRONG TYPE OF ARGUMENTS FOR A FUNCTION (ARG IN A) +;;; 3) UGT UNSEEN-GO-TAG GO TO A TAG THAT'S NOT THERE (TAG IN A) +;;; 4) WNA WRNG-NO-ARGS WRONG NUMBER OF ARGS TO A FUNCTION (FORM IN A) +;;; 5) GCL GC-LOSSAGE GC LOST (A = NAME OF SPACE: LIST...) +;;; 6) FAC FAIL-ACT RANDOM LOSSAGE (ARG IS UP TO CALLER) +;;; 7) IOL IO-LOSSAGE ;I/O LOSSAGE + +SUBTTL TABLE OF GLOBAL SYMBOLS USED BY COMPILED FUNCTIONS + +;;; THE RELATIVE POSITIONS OF THESE SYMBOLS GET BUILT INTO FASL FILES, +;;; SO BE VERY CAREFUL ABOUT DISTURBING THE ORDER OF EXISTING SYMBOLS! +;;; GLBSYM AND SIXSYM MUST ALWAYS HAVE CORRESPONDING ENTRIES. + +DEFINE GLBSYM B +IRP A,,[.SET,.MAP,PRINTA,SPECBIND,UNBIND,IOGBND,.LCALL +.UDT,ARGLOC,INUM,ST,FXNV1,PDLNMK,PDLNKJ,FIX1A +FIX1,FLOAT1,IFIX,IFLOAT,FXCONS,FLCONS,ERSETUP,ERUNDO +GOBRK,CARCDR,.STORE,NPUSH,PA3,QUNBOUND,FLTSKP,FXNV2 +FXNV3,FXNV4,FIX2,FLOAT2,AREGET] + B +TERMIN +IRP A,,[%HUNK1,%HUNK2,INTREL,INHIBIT,NOQUIT,CHECKI,0PUSH,0.0PUSH,NILPROPS,VBIND +%CXR,%RPX,%CONS,%NCONS,%XCONS,%C2NS,%HUNK3,%HUNK4,%PDLC,%PDLXC,%PDLNC +PTNTRY,PTEXIT,SFCALI,UNWPUS] + B +TERMIN +TERMIN + +DEFINE SIXSYM B ;SIXBIT NAMES -- MUST MATCH GLBSYM +IRP A,,[*SET,*MAP,PRINTA,SPECBIND,UNBIND,IOGBND,*LCALL +*UDT,ARGLOC,INUM,NUMVAL,FXNV1,PDLNMK,PDLNKJ,FIX1A +FIX1,FLOAT1,IFIX,IFLOAT,FXCONS,FLCONS,ERSETUP,ERUNDO +GOBRK,CARCDR,*STORE,NPUSH,PA3,MAKUNBOUND,FLTSKP,FXNV2 +FXNV3,FXNV4,FIX2,FLOAT2,AREGET] + B +TERMIN +IRP A,,[%HUNK1,%HUNK2,INTREL,INHIBIT,NOQUIT,CHECKI,0PUSH,0*0PUSH,NILPROPS,VBIND +%CXR,%RPX,%CONS,%NCONS,%XCONS,%C2NS,%HUNK3,%HUNK4,%PDLC,%PDLXC,%PDLNC +PTNTRY,PTEXIT,SFCALI,UNWPUS] + B +TERMIN +TERMIN + +;;; ADDITIONAL SYMBOLS FOR LAP AND .FASL HACKERS. +;;; THE ORDER OF THESE IS NOT CRITICAL. + +DEFINE XTRSYM B +IRP A,,[CPOPJ,CCPOPJ,POPAJ,POP1J,CINTREL,LWNACK,SIXMAK,SQUEEZE,MKFXAR,FWCONS +SACONS,CFIX1,1DIMF,2DIMF,SEGLOG,R70,ARGLOC,ARGNUM,TTSAR,Q..MIS,MAKVC,SUNBOUND +IN0,TYIMAN,READ6C,READ0A,GCMKL,DEDSAR,BRGEN,RINTERN,LPNF,PNBUF,ALFILE,ALCHAN +XFILEP,FIL6BT,6BTNML,SIXATM,CHNTB,%HNK4R,GRBPSG,HNKLOG,IAPPLY,ALHUNK,ARYSIZ +.REA3,IFORCE,XOFLOK,XIFLOK,GCST,FWNACK] + B +TERMIN +IFN PAGING,[ + IRP A,,[FLSTBL] + TERMIN +] ;END of IFN PAGING +IFN ITS,[ + IRP A,,[GETCOR,IOCINS,J.STADR,J.CRUFT] + B + TERMIN +] ;END OF IFN ITS +IFN D10,[ + IRP A,,[PPNATM,CMUP] + B + TERMIN +] ;END OF IFN D10 +IFN D20,[ + IRP A,,[TENEXP] + B + TERMIN +] ;END OF IFN D20 +IFN BIGNUM,[ + IRP A,,[BNCONS,NVSKIP] + B + TERMIN +] ;END OF IFN BIGNUM +IFN JOBQIO,[ +IRP A,,[JOBTB,LOJOBA] + B +TERMIN +] ;END OF IFN JOBQIO +IFN SFA,[ +IRP A,,[AFOSP,XFOSP] + B +TERMIN +] ;END IFN SFA +TERMIN + +GLBSYM [.GLOBAL A] +XTRSYM [.GLOBAL A] + +SUBTTL SYMBOLS FOR NUMBER-OF-ARGS CHECKING, AND .FORMAT + + +;;; SYMBOLS TO BE USED WITH FWNACK AND LWNACK. +;;; ORDINARILY ONE WRITES +;;; JSP TT,FWNACK +;;; FAXXX,,QZZZZZ +;;; IN EACH SYMBOL, THE 3.1 BIT (THESE ARE LEFT-HALF SYMBOLS) +;;; MEANS FSUBR. THE 3.2 BIT MEANS 0 ARGS IS OKAY; 3.3, 1 ARG; +;;; 3.4, 2 ARGS; ... ; 4.8, 15. ARGS; 4.9, > 15. ARGS. + +;;; ITEMS IN THIS IRP MUST HAVE FIRST FOUR CHARS UNIQUE!!! +;;; IF YOU ADD STUFF HERE, ALSO FIX UP FASEND. +.SEE FASEND + +IRP X,,[02,1N,12,23,2N,0,1,2,4,01,012,01234,0234,3456,1234567 +13456,234,345,234567,76543,45] +LA!X==0 +IRPC Q,,[X] +IFSN Q,N, LA!X==LA!X+2_Q +.ALSO ZZ==Q +.ELSE LA!X==LA!X+<<777774_ZZ>&7777777> +TERMIN +FA!X==LA!X+1 +TERMIN + + +;;; THE FOLLOWING FORMATS ARE HEREBY DECLARED ILLEGAL AS +;;; BEING REDUNDANT AND/OR GROSSLY CONFUSING. +;;; SEE THE MIDAS MANUAL FOR DETAILS. +;;; ,A +;;; ,A C +;;; ,A, +;;; ,A,C +;;; A B C +;;; A, +;;; A,B +;;; A,B C +;;; A,B, +;;; A,B,C + +IRP X,,[14,15,16,17,25,30,34,35,36,37] +.FORMAT X,0 +TERMIN + +;;; FLAG BITS FOR SQUOZE SYMBOLS IN DDT + +%SY==1,,537777 +%SYHKL==:400000 ;HALF KILLED +%SYKIL==:200000 ;FULLY KILLED +%SYLCL==:100000 ;LOCAL +%SYGBL==:40000 ;GLOBAL + +;;; A FEW RANDOMLY USEFUL DEFINITIONS TO KEEP THINGS SYMBOLIC +;;; BUT WATCH OUT! DONT JUST RANDOMLY THINK YOU CAN CHANGE NASCII +;;; AND HAVE THINGS WIN, ESPECIALLY THE PACKING OF CHARS FOR +;;; PNAMES, AND THE SPECIAL OBARRAY ENTRIES FOR SCOS. + +IFN SAIL, NASCII==:1000 ;NUMBER OF ASCII CHARS +.ELSE NASCII==:200 ;NUMBER OF ASCII CHARS +BYTSWD==:5 ;NUMBER OF ASCII BYTES PER WORD + + +SUBTTL DEFINITIONS OF BIBOP TYPE BITS FOR USE IN THE SEGMENT TABLE + +.SEE ST + +LS==:400000 ;4.9 1=LIST STRUCTURE, 0=ATOMIC +ST.LS==:400000 +$FS==:200000 ;4.8 FREE STORAGE (BIT 4.9 SHOULD BE ON ALSO) +ST.$FS==:200000 +FX==:100000 ;4.7 FIXNUM STORAGE +ST.FX==:100000 +FL==:40000 ;4.6 FLONUM STORAGE +ST.FL==:40000 +BN==:20000 ;4.5 BIGNUM HEADER STORAGE +ST.BGN==:20000 +SY==:10000 ;4.4 SYMBOL HEADER STORAGE +ST.SY==:10000 +SA==:4000 ;4.3 SAR STORAGE (BIT 3.8 SHOULD BE ON ALSO) +ST.SA==:4000 +VC==:2000 ;4.2 VALUE CELL STORAGE (BIT 4.9 SHOULD BE ON ALSO) +ST.VAC==:2000 +$PDLNM==:1000 ;4.1 NUMBER PDL AREA + ; (ONE OF THE NUMBER TYPE BITS SHOULD BE ON ALSO) +ST.$PDLNM==:1000 + ;3.9 400 RESERVED - AVOID USING (FORMERLY $FLP) +$XM==:200 ;3.8 EXISTENT (RANDOM) AREA +ST.$XM==:200 +$NXM==:100 ;3.7 NONEXISTENT (RANDOM) AREA +ST.$NXM==:100 +PUR==:40 ;3.6 PURE SPACE + ; (ONE OF BITS 4.8-4.5, 3.8, OR 3.4-3.2 ALSO ON) +ST.PUR==:40 +HNK==:20 ;3.5 HUNK OF ONE KIND OR ANOTHER (BIT 4.9 ON ALSO) +ST.HNK==:20 +DB==:10 ;3.4 DOUBLE-PRECISION FLONUMS +ST.DB==:10 +CX==:4 ;3.3 COMPLEX NUMBERS +ST.CX==:10 +DX==:2 ;3.2 DOUBLE-PRECISION COMPLEX NUMBERS +ST.DX==:2 + ;3.1 1 UNUSED (USE THIS BEFORE BIT 3.9) + +RN==:$XM+$NXM ;RANDOMNESS! +NUM==:FX+FL+BN+DB+CX+DX ;NUMBERNESS! + +ST.==:1,, + +SUBTTL ONE-LINE CONDITIONAL MACROS + +;;; THESE HELP MAKE SOME CODE LESS MESSY TO READ. +;;; PREFACING A LINE OF CODE WITH ONE OF THESE SYMBOLS TELLS MIDAS +;;; TO ASSEMBLE THAT LINE ONLY UNDER THE SPECIFIED CONDITION. +;;; EXAMPLE: +;;; +;;; FOO: MOVE A,(P) +;;; 10$ PUSHJ P,10HACK ;THIS LINE IS FOR DEC-10 ONLY +;;; MOVE A,-1(P) +;;; Q% PUSHJ P,OLDHAK ;THIS LINE IS FOR OLD I/O ONLY +;;; POPJ P, + +DEFINE 10$ +IFN D10,TERMIN + +DEFINE 10% +IFE D10,TERMIN + +DEFINE IT$ +IFN ITS,TERMIN + +DEFINE IT% +IFE ITS,TERMIN + +DEFINE 20$ +IFN D20,TERMIN + +DEFINE 20% +IFE D20,TERMIN + +DEFINE 10X +IFN TENEX,TERMIN + +DEFINE SA$ +IFN SAIL, TERMIN + +DEFINE SA% +IFE SAIL,TERMIN + +DEFINE CMU$ +IFN CMU,TERMIN + +DEFINE CMU% +IFE CMU,TERMIN + +DEFINE T10$ +IFN TOPS10,TERMIN + +DEFINE T10% +IFE TOPS10,TERMIN + +DEFINE 20X +IFN TOPS20,TERMIN + +;;; NEWRD IS FOOLISH NEW READER FLAG (HISTORICAL ARTIFACT -- FLUSH EVENTUALLY) + +DEFINE NW$ +IFN NEWRD,TERMIN + +DEFINE NW% +IFE NEWRD,TERMIN + +DEFINE BG$ +IFN BIGNUM,TERMIN + +DEFINE BG% +IFE BIGNUM,TERMIN + +DEFINE DB$ +IFN DBFLAG,TERMIN + +DEFINE DB% +IFE DBFLAG,TERMIN + +DEFINE CX$ +IFN CXFLAG,TERMIN + +DEFINE CX% +IFE CXFLAG,TERMIN + +DEFINE DX$ +IFN DXFLAG,TERMIN + +DEFINE DX% +IFE DXFLAG,TERMIN + +DEFINE HN$ +IFN HNKLOG,TERMIN + +DEFINE HN% +IFE HNKLOG,TERMIN + +DEFINE KA +IFN KA10,TERMIN + +DEFINE KAKI +IFN KA10+KI10,TERMIN + +DEFINE KI +IFN KI10,TERMIN + +DEFINE KIKL +IFN KI10+KL10,TERMIN + +DEFINE KL +IFN KL10,TERMIN + +DEFINE PG$ +IFN PAGING,TERMIN + +DEFINE PG% +IFE PAGING,TERMIN + +DEFINE SFA$ +IFN SFA,TERMIN + +DEFINE SFA% +IFE SFA,TERMIN + +DEFINE HS$ +IFN HISEGMENT,TERMIN + +DEFINE HS% +IFE HISEGMENT,TERMIN + +DEFINE REL$ +IFE D20\,TERMIN + +DEFINE REL% +IFN D20\,TERMIN + + +SUBTTL GENERAL MACROS + +DEFINE CONC A,B ;HAIRY CONCATENATOR MACRO +A!B!TERMIN + +DEFINE LOCKI ;LOCK OUT USER INTERRUPTS UNTIL UNLOCKI'D + PUSH FXP,INHIBIT + SETOM INHIBIT +TERMIN + +DEFINE UNLOCKI ;RELEASE THE USER-INTERRUPT LOCK, AND CHECK TO SEE + PUSHJ P,INTREL ;IF ANY INTERRUPTS WERE STACKED UP WHILE IN LOCKED STATE +TERMIN + +DEFINE LOCKTOPOPJ ;LOCK ALL THE ENSUING CODE UNTIL THE + PUSH P,CINTREL ;EXITING POPJ P, + LOCKI +TERMIN + +DEFINE UNLKPOPJ ;UNLOCK, THEN POPJ P, + JRST INTREL +TERMIN + + .SEE CHNINT +DEFINE .5LOCKI ;HALF-LOCK INHIBIT + PUSH FXP,INHIBIT + HRROS INHIBIT +TERMIN + +DEFINE .5LKTOPOPJ + PUSH P,CINTREL + .5LOCKI +TERMIN + +IRP PL,,[,FX] +DEFINE SOVE!PL AL/ ;CALLED LIKE SOVE A B C +IRPS AC,,AL + PUSH PL!P,AC +TERMIN +TERMIN +DEFINE RSTR!PL AL/ ;CALLED LIKE RSTR C B A +IRPS AC,,AL + POP PL!P,AC +TERMIN +TERMIN +TERMIN + + +DEFINE MACROLOOP COUNT,NAME,C ;FOR EXPANDING MANY MACROS +IFSN C,, .CRFOFF +REPEAT COUNT,[ CONC NAME,\.RPCNT +] +IFSN C,, .CRFON +TERMIN + + + +;SKIP IF TYPE, USING TT AS TEMP, ACCORDING TO BIBOP TYPE BITS +DEFINE SKOTT /Z + SKOTT% N,L,Z +TERMIN +;SKIP IF NOT TYPE, USING TT AS TEMP, ACCORDING TO BIBOP TYPE BITS +DEFINE SKOTTN /Z + SKOTT% E,GE,Z +TERMIN + +DEFINE SKOTT% N,L,X,TYP +IFN TT-, HRRZ TT,X + LSH TT,-SEGLOG +IFN -LS,[ + MOVE TT,ST(TT) + TLN!N TT, +] +.ELSE SKIP!L TT,ST(TT) +TERMIN + + +;; STRING HACKERS, ASSUMING ENCODINGS IN HUNKS +STWIWO==1 ;STRING-WORD-INDEX, WORD-OFFSET - A RH QUANTITIY +STLNWO==1 ;STRING-LENGTH, WORD-OFFSET - A LH QUANTITIY +DEFINE STRWDNO AC,IX + HRRZ AC,STWIWO(IX) + SKIPGE AC,(AC) +TERMIN +DEFINE STRLEN AC,IX + HLRZ AC,STLNWO(IX) + MOVE AC,(AC) +TERMIN + + + +DEFINE % ;THIS IS GOOD FOR LIST STRUCTURE +,,.+1!TERMIN + + +DEFINE INFORM R,S,T,U,V,W,X,Y,Z,$,% +PRINTX  R!S!T!U!V!W!X!Y!Z!$!% + +TERMIN + +DEFINE WARN R,S,T,U,V,W,X,Y,Z,$,% +WARN1 [R!S!T!U!V!W!X!Y!Z!$!%] +TERMIN + +DEFINE WARN1 CRUFT +IFL 40-.LENGTH CRUFT,[ .ERR ###### +PRINTX  ###### CRUFT + +] +.ELSE .ERR ###### CRUFT +TERMIN + +;;; USEFUL MACRO FOR .FASL FILES. CAUSES LOADING TO PRINT MESSAGE. + +DEFINE VERPRT NAME,VRS=[???] +IFN .FNAM2-SIXBIT /MID/,[ +%%%==.fnam2 +.SXEVAL ((LAMBDA (X) + (COND ((STATUS NOFEATURE NOLDMSG) + (TERPRI MSGFILES) + (TYO #73 MSGFILES) + (PRINC (QUOTE L/o/a/d/i/n/g/ NAME/ ) MSGFILES) + (PRINC X MSGFILES) + (TYO #40 MSGFILES))) + (PUTPROP (QUOTE NAME) X (QUOTE VERSION))) + (MAKNAM (DELQ #40 + (QUOTE (#<<<%%%&<770000,,0>>_-36>+40> + #<<<%%%&<7700,,0>>_-30>+40> + #<<<%%%&<77,,0>>_-22>+40> + #<<<%%%&770000>_-14>+40> + #<<<%%%&7700>_-6>+40> + #<<%%%&77>+40> ))))) +] +.ELSE [ +.SXEVAL (COND ((STATUS NOFEATURE NOLDMSG) + (TERPRI MSGFILES) + (TYO #73 MSGFILES) + (PRINC (QUOTE L/o/a/d/i/n/g/ NAME/ VRS/ ) MSGFILES))) +.SXEVAL (DEFPROP NAME VRS VERSION) +] +TERMIN + +;; Silent VERPRT, which doesn't print the message, just does the DEFPROP +;; of the version property + +DEFINE SVERPRT NAME,VRS=[???] +IFN .FNAM2-SIXBIT /MID/,[ +%%%==.fnam2 +.SXEVAL (PUTPROP (QUOTE NAME) + (MAKNAM (DELQ #40 + (QUOTE (#<<<%%%&<770000,,0>>_-36>+40> + #<<<%%%&<7700,,0>>_-30>+40> + #<<<%%%&<77,,0>>_-22>+40> + #<<<%%%&770000>_-14>+40> + #<<<%%%&7700>_-6>+40> + #<<%%%&77>+40> )))) + (QUOTE VERSION)) +] +.ELSE [ +.SXEVAL (DEFPROP NAME VRS VERSION) +] +TERMIN + +;MACRO TO HANDLE UNWIND-PROTECT +; UNWINDPROTECT CODE,CONTINUATION-CODE +;CAUSES CONTINUATION TO BE INVOKED AFTER CODE IS EXECUTED +;THE STATE OF THE PDLS MUST BE THE SAME BEFORE AND AFTER CODE EXECUTES. +; CODE SHOULD BE THOUGHT OF AS A FUNCTION CALL. +; CODE IS THE CODE TO BE INVOKED AND PROTECTED. +; CONT IS THE "CONTINUATION" TO BE RUN WHEN UNWINDING THE STACK, OR AFTER +; CODE IS RUN +DEFINE UNWINDPROTECT CODE,CONT,\LABEL + JSP TT,PTNTRY ;SETUP AN UNWIND PROTECT + JRST LABEL + CONT + POPJ P, +LABEL: + CODE +;ASSUMPTION IS THAT FOLLOWING JSP CLOBBERS THE WORLD + JSP TT,PTEXIT ;RUN CONTINUATION, PRESERVES A +TERMIN + +;;; HERE COME THE RANDOM "RPG" MACROS FOR IN-LINING THE PDL-FIXUP CODE + +DEFINE PFIXPDL AC + HRRZ AC,P + MOVE P,C2 + SUBI AC,(P) + HRLS AC + ADD P,AC +TERMIN + +DEFINE FXPFIXPDL AC + HRRZ AC,FXP + MOVE FXP,FXC2 + SUBI AC,(FXP) + HRLS AC + ADD FXP,AC +TERMIN + +DEFINE FLPFIXPDL AC + HRRZ AC,FLP + MOVE FLP,FLC2 + SUBI AC,(FLP) + HRLS AC + ADD FLP,AC +TERMIN + +DEFINE SPFIXPDL AC + HRRZ AC,SP + MOVE SP,SC2 + SUBI AC,(SP) + HRLS AC + ADD SP,AC +TERMIN + + + + +IF1,[ + +;;; FEATURE SO THAT HAIRY SUMS OF BITS MAY BE WRITTEN NICELY. +;;; BITMAC FOO,FOO. +;;; CAUSES THE FORM +;;; FOO +;;; TO EXPAND INTO THE FORM +;;; FOO.A+FOO.B+FOO.C + +NBITMACS==0 + +DEFINE BITMAC XX,YY,ZZ=[1,,525252] +DEFINE XX +IRPS J,K,[BITS] +YY!!J!K!TERMIN TERMIN +BITMA1 XX,YY,[ZZ]\NBITMACS +NBITMACS==NBITMACS+1 +TERMIN + +DEFINE BITMA1 XX,YY,ZZ,NN +DEFINE BTMC!NN +EXPUNGE XX,YY +XX==ZZ +YY==ZZ +IFSN [ZZ], IFGE <.TYPE ZZ>, EXPUNGE ZZ +TERMIN +TERMIN + +IRP FOO,,[%TB,%TI,%TJ,%TX,%TO,%TS,%TC,%TG,%TT,%PI,%PJ] +IFDEF FOO, SV$!FOO==FOO .SEE BITMAC +.ELSE SV$!FOO==1,,525252 +EXPUNGE FOO +TERMIN + +BITMAC AS,AS. ;LH ASARS +BITMAC TTS,TTS.,[1,,725252] ;LH TTSARS +BITMAC FBT,FBT. ;LH F.MODE WORD IN FILE ARRAYS +BITMAC RS.,RS. ;FOR READER SYNTAX BITS +BITMAC RS%,RS%,525252 ;READER SYNTAX BITS, LH SHIFTED INTO RH +BITMAC IB,IB.,[525252,,525252] ;WORD 1 INTERRUPT BITS +BITMAC %TB,%TB,SV$%TB ;LH .TTY USER VARIABLE +BITMAC %TI,%TI,SV$%TI ;LH TTY IOCHNM BITS (SOME PER-IOT) +BITMAC %TJ,%TJ,SV$%TJ +BITMAC %TX,%TX,SV$%TX ;RH TTY CHARACTER BITS +BITMAC %TO,%TO,SV$%TO ;LH TTYOPT VARIABLE +BITMAC %TS,%TS,SV$%TS ;LH TTYSTS VARIABLE +BITMAC %TC,%TC,SV$%TC ;LH TTYCOM VARIABLE +BITMAC %TG,%TG,SV$%TG ;6-BIT BYTE TTYST1,TTYST2 GROUPS +BITMAC %TT,%TT,SV$%TT ;LH TTYTYP VARIABLE +BITMAC %PI,%PI,SV$%PI ;FULL WORD .PIRQC VARIABLE +BITMAC %PJ,%PJ,SV$%PJ ;LH .PIRQC VARIABLE +] ;END OF IF1 + + + +;;; MACRO FOR .FASL LOSERS WHO .INSRT THIS FILE TO USE +;;; IN PLACE OF THE "END" PSEUDO. THIS GENERATES AN "END" +;;; AFTER PERFORMING SOME CLEANUP. MANY SYMBOLS ARE EXPUNGED +;;; SO THAT .FASL FILES WILL NOT SPEND INFINITE TIME TRYING TO +;;; PASS THEM TO DDT. + +DEFINE FASEND +IF2,[ +EXPUNGE NIL A B C AR1 AR2A NACS T TT D R F FREEAC P FLP FXP SP +EXPUNGE LERR ACALL AJCALL LER3 ERINT PP STRT SERINT TP IOJRST UUOMAX +EXPUNGE CALL JCALL CALLF JCALLF NCALL NJCALL NCALLF NJCALF NUUOCLS +EXPUNGE NERINT NASCII +EXPUNGE %UDF %UBV %WTA %UGT %WNA %GCL %FAC %IOL +EXPUNGE %%UDF %%UBV %%WTA %%UGT %%WNA %%GCL %%FAC %%IOL +EXPUNGE ASAR TTSAR +EXPUNGE AS.SFA AS.JOB AS.FIL AS.RDT AS.OBA AS.SX AS.FX AS.FL AS.DB AS.CX +EXPUNGE AS.DX AS.GCP +EXPUNGE TTS.CL TTS.IM TTS.BN TTS.TY TTS.IO TTS.CN TTS.GC +EXPUNGE TTSDIM TTS.1D TTS.2D TTS.3D TTS.4D TTS.5D +EXPUNGE FI.EOF FO.EOF FI.BBC FI.BBF TI.BFN FT.CNS F.GC +EXPUNGE F.MODE FBT.CM FBT.SA FBT.CP FBT.LN FBT.AP FBT.CC FBT.ND +EXPUNGE F.CHAN F.JFN F.FLEN F.FPOS F.DEV F.SNM F.PPN F.FN1 F.FN2 +EXPUNGE F.RDEV F.RSNM F.RFN1 F.RFN2 +EXPUNGE F.DIR F.FNM F.EXT F.VRS +EXPUNGE L.6DEV L.6DIR L.6FNM L.6EXT L.6VRS L.D6BT L.N6BT L.F6BT +EXPUNGE LOPOFA +EXPUNGE TI.ST1 TI.ST2 TI.ST3 TI.ST4 TI.ST5 TI.ST6 ATO.LC +EXPUNGE AT.CHS AT.LNN AT.PGN FO.LNL FO.PGL FO.RPL LONBFA +EXPUNGE FB.BFL FB.BVC FB.BYT FB.IBP FB.BP FB.CNT FB.HED FB.NBF +EXPUNGE FB.BWS FB.ROF FB.BUF +EXPUNGE J.INTF J.LFNM J.GC J.INTB J.STAD J.UIND LOJOBA J.SYMS J.CRUF +EXPUNGE SR.CAL SFCALI SR.WOM SR.UDL SR.FML SR.FUN SR.PNA SR.FUS SR.LEN +EXPUNGE SO.OPN SO.CLO SO.REN SO.DEL SO.TRP SO.PR1 SO.TYI SO.UNT SO.TIP +EXPUNGE SO.IN SO.EOF SO.TYO SO.OUT SO.FOU SO.RED SO.RDL SO.PRT SO.PRC +EXPUNGE SO.MOD SO.POS +EXPUNGE ST.LS ST.$FS ST.FX ST.FL ST.BGN ST.SY ST.SA ST.VAC ST.$PDLNM +EXPUNGE ST.$XM ST.$NXM ST.PUR ST.HNK ST.DB ST.CX ST.DX ST. + +IRP X,,[02,1N,12,23,2N,0,1,2,4,01,012,01234,0234,3456,1234567 +13456,234,345,234567,76543,45] +EXPUNGE LA!X FA!X +TERMIN +MACROLOOP NBITMACS,BTMC,* +] ;END OF IF2 +END +TERMIN + + +SUBTTL SYMBOL BLOCK-STRUCTURE DEFINITIONS + + +;;; FORMAT OF SYMBOL HEADER FOR BIBOP: +;;; THE MAIN HEADER OF A SYMBOL IS A SINGLE WORD IN SYMBOL SPACE. +;;; THE RIGHT HALF CONTAINS THE PROPERTY LIST, AND THE LEFT HALF +;;; POINTS TO THE REST OF THE HEADER, WHICH IS IN THE IS2 OR SY2 AREA. +;;; SINCE THE REST OF THE HEADER (ALSO CALLED A "SYMBOL BLOCK") MUST +;;; LIE ON AN EVEN WORD BOUNDARY, THE LOW BIT OF THE LEFT HALF OF +;;; THE MAIN HEADER IS NORMALLY ZERO. THIS BIT IS USED BY THE +;;; GARBAGE COLLECTOR FOR MARKING PURPOSES, AND THEN RESET TO ZERO. +;;; THE SYMBOL BLOCK IS 2 WORDS LONG: +;;; ,, +;;; ,, +;;; THE "VARIOUS BITS" ARE: +;;; 4.9-3.9 ONES (FOR NO PARTICULARLY GOOD REASON) +;;; 3.9 ZERO (RESERVED FOR SPECIAL VALUE CELL/LAP HACK) +;;; 3.8 1 => SYMBOL BLOCK MAY BE PURE (SEE GCMARK) +;;; 3.7 ONE IFF COMPILED CODE NEEDS THE SYMBOL +;;; 3.6 ONE IFF COMPILED CODE REFERENCES BY OTHER THAN CALL UUO +;;; (IMPLIES 3.7 WHICH *MUST* ALSO BE ON) +;;; 3.5-3.1 ZERO (SO CAN INDIRECT THROUGH THE WORD TO GET VALUE) +;;; THE ARGS PROPERTY IS IN THE SAME FORMAT FASLOAD USES, +;;; TWO NINE-BIT BYTES DECODED AS FOLLOWS: +;;; 0 => NIL +;;; 777 => 777 (EFFECTIVELY INFINITY) +;;; N => N-1, N NOT 0 OR 777 +;;; THUS 000006 = (NIL . 5), 004005 = (3 . 4), AND 002777 = (1 . 777) +SYMVC==0 ;BITS,,VC +SYMARGS==1 ;ARGS PROP,,PNAME +SYMPNAME==1 + +SY.ONE==:777000 ;ONES (NO GOOD REASON!!) +SY.LAP==:400 +SY.PUR==:200 +SY.CCN==:100 +SY.OTC==:040 +SY.ZER==:037 + +SY.==:1,, + +SUBTTL FORMAT OF ARRAYS + +;;; ARRAYS ARE POINTED TO BY A TWO-WORD SAR (SPECIAL ARRAY CELL). +;;; SARS RESIDE IN A SPECIAL SPACE CALLED SAR SPACE. +ASAR==:0 ;SAR POINTER POINTS TO ASAR (CODE DEPENDS ON THIS) +TTSAR==:1 ;TTSAR COMES JUST AFTER IT +;;; THE FIRST WORD OF THE SAR, CALLED THE ASAR, POINTS TO THE ARRAY +;;; HEADER; PUSHJ'ING INDIRECTLY THOUGH IT GETS TO THE ARRAY +;;; SUBSCRIPT EVALUATION CODE. THE LEFT HALF, EXCLUDING THE +;;; INDIRECT AND INDEX BITS, CONTAINS VARIOUS BITS DESCRIBING +;;; THE TYPE OF THE ARRAY: + + +AS.SFA==:200000 ;SFA ARRAY +AS.JOB==:100000 ;JOB ARRAY +AS.FIL==:40000 ;FILE ARRAY +AS.RDT==:20000 ;READTABLE +AS.OBA==:10000 ;OBARRAY +AS.DX==:4000 ;DUPLEX ;THESE ARE +AS.CX==:2000 ;COMPLEX ; THE ACCESS +AS.DB==:1000 ;DOUBLE ; METHODS - +AS.SX==:400 ;S-EXPRESSION ; EXACTLY ONE +AS.FX==:200 ;FIXNUM ; SHOULD BE SET +AS.FL==:100 ;FLONUM ; IN EACH ASAR +AS.GCP==:40 ;GC SHOULD USE AOBJN PTR TO MARK ARRAY + +;;; THE SECOND WORD, CALLED THE TTSAR, POINTS TO THE ARRAY DATA +;;; AND IS INDEXED BY ACCUMULATOR TT. ITS LEFT HALF, EXCLUDING +;;; AGAIN THE INDIRECT AND INDEX BITS, CONTAIN MORE INFORMATION +;;; ABOUT THE ARRAY: + +TTS.CL==:40000 ;CLOSED FILE +TTS.BM==:20000 ;TOPS-10 I/O BUFFER HAS BEEN MOVED +TTS.IM==:2000 ;1 => IMAGE ;BOTH 0 +TTS.BN==:1000 ;1 => BINARY (FIXNUM) ; => ASCII +TTS.TY==:400 ;0 => DSK-TYPE, 1 => TTY +TTS.IO==:200 ;0 => IN, 1 => OUT +TTS.CN==:100 ;COMPILED CODE NEEDS THIS SAR +TTS.GC==:40 ;USED AS MARK BIT BY GC +TTSDIM==:410300 ;BYTE POINTER FOR # OF DIMENSIONS (1-5) +TTS.1D==:100000 ;DEFINITIONS +TTS.2D==:200000 ; FOR SPECIFYING +TTS.3D==:300000 ; NUMBER OF +TTS.4D==:400000 ; ARRAY +TTS.5D==:500000 ; DIMENSIONS + +;;; S-EXPRESSION ARRAYS HAVE THE FOLLOWING FORM: +;;; -<# WDS FOR GC MARK>,,<1ST WD OF DATA TO MARK> +;;; HEADER: JSP TT,DIMS ;ASAR POINTS HERE; N=# OF DIMS +;;;
;LH USED BY FLASH +;;; +;;; ... +;;; +;;; DATA: ,, ;TTSAR POINTS HERE +;;; ... ;DATA PACKED 2/WD +;;; ,, +;;; +;;; THE FORMAT OF A NUMBER ARRAY IS AS FOLLOWS: +;;; ;PROBABLY MEANINGLESS +;;; HEADER: PUSH P,CFIX1 ;CFLOAT1 FOR A FLONUM ARRAY +;;; JSP TT,DIMF ;N=# OF DIMS +;;;
;LH USED BY FLASH +;;; +;;; ... +;;; +;;; DATA: ;TTSAR POINTS HERE +;;; ;FULL-WORD DATA 1/WD +;;; ... +;;; + +;;; THE AOBJN POINTER AT THE TOP OF EACH ARRAY IS MEANINGFUL ONLY +;;; IF THE AS.GCP BIT IS 1 IN THE ARRAY'S ASAR; IT INDICATES +;;; WHAT ENTRIES IN THE ARRAY GC SHOULD MARK. FOR S-EXPRESSION +;;; ARRAYS, THIS IS GENERALLY THE ENTIRE ARRAY; FOR OBARRAYS, +;;; IT INCLUDES THE BUCKETS BUT NOT THE SCO TABLE. FOR +;;; READTABLES, WHICH ARE OTHERWISE FIXNUM ARRAYS, UNDER NEWRD +;;; THE GC AOBJN POINTER INDICATES THAT THE LIST OF CHARACTER +;;; MACRO FUNCTIONS SHOULD BE MARKED. +;;; NOTE THAT IF SUCH AN AOBJN POINTER IS OF THE FORM <-N>,,, +;;; THEN 2*N ENTRIES ARE MARKED; THE LEFT HALF IS THE NUMBER +;;; OF WORDS TO BE MARKED, WITH TWO ENTRIES PER WORD. +;;; CORRESPONDS TO ARRAY TYPE BITS IN ASAR'S. + +SUBTTL FORMAT OF FILE ARRAYS + +;;; FILE ARRAYS ARE ARRAYS WHICH HAVE THE AS.FIL BIT SET +;;; IN THE ASAR AND SOME EXTRA BITS IN THE TTSAR DESCRIBING +;;; THE TYPE OF ARRAY. +;;; A FILE ARRAY CONTAINS A NUMBER OF VARIABLES RELATED TO +;;; THE FILE, AND POSSIBLY A BUFFER FOR DATA. +;;; THE PREFIX OF EACH NAME OF A FILE ARRAY COMPONENT INDICATES THE +;;; TYPES OF FILE ARRAYS TO WHICH IT IS APPLICABLE. THUS TI.ST1 +;;; IS ONLY FOR TTY INPUT FILE ARRAYS. + +;;; NOTE: COMPONENTS MARKED (RELOC) MUST HAVE THEIR RIGHT +;;; HALVES RELOCATED WHEN THE ARRAY IS MOVED. +.SEE GT3D + +;;; THE FOLLOWING ARE INDICES INTO THE FILE ARRAY'S DATA AREA +;;; (I.E. THEY ARE USED TO INDEX THROUGH THE TTSAR). + + FI.EOF==:0 ;EOF FUNCTION + FO.EOP==:0 ;END OF PAGE FUNCTION + FJ.INT==:0 ;INTERRUPT FUNCTION FOR USR DEVICE + + FI.BBC==:1 ;BUFFERED BACK CHARS FOR ASCII FILES + ; LEFT HALF: SINGLE CHAR (3.8=1 IF ANY, + ; SO CAN DISTINGUISH ^@ FROM NONE) + ; RIGHT HALF: LIST OF CHARS FOLLOWING THE ONE + ; IN THE LEFT HALF + .SEE $DEVICE + + FI.BBF==:2 ;LIST OF BUFFERED BACK FORMS (NOT IMPLEMENTED) + + TI.BFN==:3 ;BUFFER-FORWARD (PRESCAN) FUNCTION FOR READ + + FT.CNS==:4 ;ASSOCIATED TTY FILE FOR OTHER DIRECTION + .SEE STTYCONS + +;;; SLOTS 5, 6, AND 7 ARE RESERVED FOR EXPANSION. + +F.GC==:10 ;NUMBER OF SLOTS GC SHOULD EXAMINE + + F.MODE==:10 ;MODE BITS +FBT.CM==:400000 ;4.9 0=BUFFERED, 1=CHARMODE +FBT.SA==:200000 ;4.8 SAIL CHARACTER SET (OUTPUT ONLY) +FBT.CP==:100000 ;4.7 CURSORPOS WILL SUCCEED (?) + ; ON ITS, REFLECTS %TOMVU (CAN MOVE UP) + .SEE OPNTO1 +FBT.LN==:40000 ;4.6 HANDLE TTY IN LINE MODE +SA$ FBT.AP==:20000 ;4.5 OPENED IN APPEND MODE +SA% 10% FBT.AP==:20000 ;4.5 OPENED IN APPEND MODE +SA% 10$ FBT.AP==:0 ;4.5 NOT YET HACKED FOR VANILLA TOPS-10 +FBT.EC==:10000 ;4.4 OUTPUT TTY IN ECHO AREA (ITS ONLY) +FBT.SE==:2000 ;4.2 TTY CAN SELECTIVELY ERASE +FBT.FU==:1000 ;4.1 TTY SHOULD READ/PRINT FULL 12.-BIT + ; CHARACTERS (FIXNUM MODE) +FBT.ND==:400 ;3.9 DON'T MEREGEF WITH DEFAULTF (NEVER LEFT ON + ; IN OPTIONS WORD) +IT% FBT.CA==:0 ;THIS SHOULD WORK CORRECTLY +IT$ FBT.CA==:40 ;3.6 CLA DEVICE (ITS ONLY) +FBT.SC==:20 ;3.5 SCROLL MODE + ;THE RIGHT HALF IS USED TO INDEX VARIOUS TABLES. + ;1.4-1.3 0=ASCII, 1=FIXNUM, 2=IMAGE + ;1.2 0=DSK, 1=TTY + ;1.1 0=INPUT, 1=OUTPUT + + F.CHAN==:11 ;I/O CHANNEL NUMBER + ;FOR ALL IMPLEMENTATIONS, THIS IS THE INDEX INTO + .SEE CHNTB ; THE CHANNEL TABLE. + ;FOR THE ITS AND D10 IMPLEMENTATIONS, IT IS + ; ALSO THE I/O CHANNEL NUMBER. + + F.JFN==:12 ;THE JOB-FILE NUMBER FOR THIS FILE + + F.FLEN==:13 ;THE LENGTH OF THE FILE, OR -1 IF RANDOM ACCESS IS IMPOSSIBLE. + ; MAY NOT BE UP-TO-DATE ON AN OUTPUT FILE, BUT FILEPOS + .SEE FPOS5 ; UPDATES IT FIRST IN THIS CASE. + + F.FPOS==:14 ;FILE POSITION + ;FOR SINGLE MODE FILES, THIS IS THE ACTUAL FILE POSITION. + ;FOR BLOCK MODE, THIS IS THAT OF THE BEGINNING OF + .SEE FB.BUF ; THE BUFFER IN THE FILE ARRAY, AND ONE + .SEE FB.B ; MUST LOOK AT FB.BVC AND FB.CNT + .SEE FB.CNT ; (OR WHATEVER) TO CALCULATE THE EXACT FILEPOS. + ;THE POSITION IS MEASURED IN CHARACTERS FOR ASCII FILES, + ; AND WORDS FOR FIXNUM FILES. + ;THIS VALUE MAY BE GARBAGE IF F.FLEN IS NEGATIVE. + +;;; SLOTS 15-17 ARE RESERVED. + +IFN ITS+D10,[ +;;; FROM F.DEV TO F.RFN2 ARE USED BY JOB ARRAYS ALSO. +;;; MUST HAVE (F.DEV, F.SNM/F.PPN, F.FN1, F.FN2) IN THAT ORDER. +;;; DITTO FOR (F.RDEV, F.RSNM/F.RPPN, F.RFN1, F.RFN2). +L.6DEV==:1 ;LENGTH OF DEVICE NAME IN "SIXBIT" FORM +L.6DIR==:1 ;LENGTH OF DIRECTORY NAME +L.6FNM==:1 ;LENGTH OF FILE NAME +L.6EXT==:1 ;LENGTH OF EXTENSION (TYPE) +L.6VRS==:0 ;LENGTH OF VERSION (GENERATION) +] ;END OF IFN ITS+D10 +IFN D20,[ +;;; FOR D20, "SIXBIT" FORM IS REALLY AN ASCIZ STRING. +L.6DEV==:8 ;LENGTH OF DEVICE NAME IN "SIXBIT" FORM +L.6DIR==:8 ;LENGTH OF DIRECTORY NAME +L.6FNM==:8 ;LENGTH OF FILE NAME +L.6EXT==:8 ;LENGTH OF EXTENSION (TYPE) +L.6VRS==:2 ;LENGTH OF VERSION (GENERATION) +] ;END OF IFN D20 + +L.D6BT==:L.6DEV+L.6DIR ;LENGTH OF DEVICE/DIRECTORY "SIXBIT" FORM +L.N6BT==:L.6FNM+L.6EXT+L.6VRS ;LENGTH OF FILE NAMES IN "SIXBIT" FORM +L.F6BT==:L.D6BT+L.N6BT ;LENGTH OF TOTAL FILE SPEC IN "SIXBIT" FORM + +;;; THESE ARE THE NAME WHICH WERE GIVEN TO OPEN. + F.DEV==:20 ;DEVICE NAME +IFE D20,[ + IT$ F.SNM==:F.DEV+L.6DEV ;SYSTEM NAME (SNAME) + 10$ F.PPN==:F.DEV+L.6DEV ;PROJECT-PROGRAMMER NUMBER + F.FN1==:F.DEV+L.D6BT ;FILE NAME 1 + F.FN2==:F.FN1+L.6FNM ;FILE NAME 2 (D10: EXTENSION) +;;; THESE ARE THE NAMES RETURNED BY THE TRUENAME FUNCTION. + F.RDEV==:F.DEV+L.F6BT ;"REAL" DEVICE NAME + IT$ F.RSNM==:F.RDEV+L.6DEV ;"REAL" SYSTEM NAME + 10$ F.RPPN==:F.RDEV+L.6DEV ;"REAL" PPN + F.RFN1==:F.RDEV+L.D6BT ;"REAL" FILE NAME 1 + F.RFN2==:F.RFN1+L.6FNM ;"REAL" FILE NAME 2 +] ;END OF IFE D20 +IFN D20,[ + F.DIR==:F.DEV+L.6DEV ;DIRECTORY + F.FNM==:F.DIR+L.6DIR ;FILE NAME + F.EXT==:F.FNM+L.6FNM ;EXTENSION + F.VRS==:F.EXT+L.6EXT ;VERSION +;;; THE "REAL" FILE NAMES ARE NOT STORED, BUT FETCHED BY JSYS EACH TIME. +; F.RDEV +; F.RDIR +; F.RFNM +; F.REXT +; F.RVRS +] ;END OF IFN D20 + + +LOPOFA==:70 .SEE ALFILE ;LENGTH OF PLAIN OLD FILE ARRAY + +IFL LOPOFA-, WARN [DEFINITION OF LOPOFA IS TOO SMALL] + +IFN ITS+D20+SAIL,[ +;;; FOR ITS, THESE ARE TTYST1 AND TTYST2 FOR GIVING TO TTYSET. +;;; FOR D20, THESE ARE THE CCOC WORDS FOR GIVING TO SFCOC. +;;; FOR SAIL, THESE ARE THE ACTIVATION WORDS FOR SETACT. + TI.ST1==:LOPOFA+0 ;TTY STATUS WORD 1 + TI.ST2==:LOPOFA+1 ;TTY STATUS WORD 2 +IT% TI.ST3==:LOPOFA+2 ;TTY STATUS WORD 3 +IT% TI.ST4==:LOPOFA+3 ;TTY STATUS WORD 4 + TI.ST5==:LOPOFA+4 ;TTY CHARACTERISTICS (TTYOPT) WORD +IT% TI.ST6==:LOPOFA+5 ;TTY MODE WORD +] ;END OF ITS+D20+SAIL + + ATO.LC==:LOPOFA+6 ;LAST CHARACTER FLAG FOR ASCII OUTPUT: + ;ZERO: NORMAL STATE. + ;POSITIVE: LAST CHARACTER OUTPUT WAS A SLASH, + ; SO THE AUTOMATIC TERPRI SHOULD BE INHIBITED. + ;NEGATIVE: LAST CHARACTER OUTPUT WAS A , + ; SO IT MAY BE NECESSSARY TO SUPPLY A . + + AT.CHS==:LOPOFA+7 ;CHARPOS + + AT.LNN==:LOPOFA+10 ;LINENUM + + AT.PGN==:LOPOFA+11 ;PAGENUM + + FO.LNL==:LOPOFA+12 ;LINE LENGTH + ;NORMALLY INITIALIZED TO 1 LESS THAN THE ACTUAL WIDTH + ; OF THE DEVICE TO ALLOW FOR SLASH OVERRUN. + .SEE STERPRI ;MAY BE NEGATIVE, IN WHICH CASE THE + ; MAGNITUDE IS THE ACTUAL VALUE. + + FO.PGL==:LOPOFA+13 ;PAGE LENGTH + + FO.RPL==:LOPOFA+14 ;"REAL" PAGEL FOR TTYS + +;;; SLOTS 15-17 ARE RESERVED FOR EXPANSION. + +LONBFA==:LOPOFA+20 ;LENGTH OF NON-BUFFERED FILE ARRAY + +;;; EVERYTHING AFTER THIS IS ONLY FOR FILES WITH BUFFERS + + FB.BYT==:LONBFA+0 ;NUMBER OF DATA BYTES PER WORD + + FB.BFL==:LONBFA+1 ;LENGTH OF BUFFER IN BYTES + + FB.BVC==:LONBFA+2 ;# VALID CHAARS IN BUFFER (ONLY INPUT FILES) + +IFN ITS+D20,[ + FB.IBP==:LONBFA+3 ;INITIAL BUFFER BYTE POINTER (RELOC) + FB.BP==:LONBFA+4 ;CURRENT BUFFER BYTE POINTER (RELOC) + FB.CNT==:LONBFA+5 ;COUNT OF REMAINING BYTES IN BUFFER +] ;END OF ITS+D20 +IFN D10,[ + FB.HED==:LONBFA+3 ;ADDRESS OF 3-WORD BUFFER RING HEADER + FB.NBF==:LONBFA+4 ;NUMBER OF BUFFERS + FB.BWS==:LONBFA+5 ;SIZE OF BUFFER IN WORDS (NOT COUNTING BUFFER HEADER) +SA$ FB.ROF==:LONBFA+6 ;(NEGATIVE) RECORD OFFSET IN BYTES, I.E. FILEPOS + ; OF THE PHYSICAL BEGINNING OF THE FILE +] ;END OF IFN D10 + + FB.BUF==:LONBFA+10 ;BEGINNING OF BUFFER + ;FOR ITS AND D20, THE DATA BUFFER BEGINS HERE. + ;FOR D10, THE BUFFER RING STRUCTURE BEGINS HERE. + ;FOR TTY INPUT FILES, THE "BUFFER" IS AN ARRAY + ; OF INTERRUPT FUNCTIONS FOR EACH ASCII CHARACTER. + +SUBTTL FORMAT OF JOB ARRAYS + +IFN ITS,[ + +;;; JOB ARRAYS ARE ARRAYS WHICH HAVE THE AS.JOB BIT SET +;;; IN THE ASAR. THE TTS.CL BIT IS RELEVANT HERE ALSO, +;;; INDICATING A CLOSED JOB ARRAY. +;;; THE ARRAY CONTAINS VARIOUS DATA ASSOCIATED WITH THE JOB. + +;;; NOTE: COMPONENTS MARKED (RELOC) MUST HAVE THEIR RIGHT +;;; HALVES RELOCATED WHEN THE ARRAY IS MOVED. + +;;; THE FOLLOWING ARE INDICES INTO THE FILE ARRAY'S DATA AREA +;;; (I.E. THEY ARE USED TO INDEX THROUGH THE TTSAR). + + J.INTF==:0 ;INTERRUPT FUNCTION (NEEDED BY INT SYSTEM) + J.CINT==:1 ;CHANNEL INTERRUPT FUNCTION + J.LFNM==:2 ;LOAD FILE NAMELIST? + J.CRUFT==:3 ;RANDOM CRUFT (USUALLY PROPERTY LIST) + +J.GC==:4 ;NUMBER OF SLOTS GC SHOULD EXAMINE + +;SLOTS 3-12 RESERVED + +;;; F.DEV THROUGH F.RFN2 (12 TO 21) APPLY TO JOB ARRAYS ALSO. + + J.INTB==:LOPOFA+0 ;INTERRUPT BIT, OR ZERO FOR FOREIGN JOB + J.STAD==:LOPOFA+1 ;START ADDRESS + J.UIND==:LOPOFA+2 + +LOJOBA==:FB.BUF + + J.SYMS==:FB.BUF ;START OF SYMBOL TABLE, IF ANY + +] ;END OF IFN ITS + +IFE SFA, SFCALI==-1 +IFN SFA,[ +SUBTTL FORMAT OF SFA OBJECTS + +;;; AN SFA OBJECT HAS THE AS.SFA BIT SET IN THE ASAR. TTS.CL IS IGNORED. + +;;; THE FOLLOWING ARE INDICIES INTO THE SFA ARRAY AND ARE UNMARKED FROM: +SR.CAL==:0 ;THE LISP CALL UUO XCT'ED TO INVOKE THE SFA FUNCTION +SFCALI==:SR.CAL ;FOR COMPILED CODE +SR.WOM==:1 ;WHICH-OPERATIONS MASK: ENCODED MASK OF THE OPERATIONS THAT + ; THE SFA CAN PERFORM. USED FOR QUICK TESTING IN CERTAIN + ; DISPATCH CASES. BITS AS FOLLOWS: +SR.UDL==:2 ;USER DATA LENGTH + +;;; ***NOTE: THE HALVNESS OF THE BITS MUST NOT CHANGE *** +;LH BITS + SO.OPN==:400000 ;OPEN + SO.CLO==:200000 ;CLOSE + SO.REN==:100000 ;RENAMEF + SO.DEL==:040000 ;DELETEF + SO.TRP==:020000 ;TERPRI + SO.PR1==:010000 ;PRIN1 + SO.TYI==:004000 ;TYI + SO.UNT==:002000 ;UNTYI + SO.TIP==:001000 ;TYIPEEK + SO.IN==:000400 ;IN + SO.EOF==:000200 ;EOFFN + SO.TYO==:000100 ;TYO + SO.PRO==:000040 ;PRINT-OBJECT + SO.FOU==:000020 ;FORCE-OUTPUT + SO.RED==:000010 ;READ + SO.RDL==:000004 ;READLINE + SO.PRT==:000002 ;PRINT + SO.PRC==:000001 ;PRINC +;RH BITS + SO.MOD==:400000 ;FILEMODE + SO.POS==:200000 ;FILEPOS + SO.ICL==:100000 ;CLEAR-INPUT + SO.OCL==:040000 ;CLEAR-OUTPUT + SO.OUT==:020000 ;OUT + SO.CUR==:010000 ;CURSORPOS + SO.RUB==:004000 ;RUBOUT + + +SR.FML==:3 ;FIRST MARKED LOCATION + +SR.FUN==:3 ;RH IS SFA FUNCTION +SR.CNS==:3 ;LH IS ASSOCIATE FOR BI-DIRECTIONALITY (TTYCONS) +SR.PNA==:4 ;RH IS PRINTNAME +SR.PLI==:4 ;LH IS GENERAL PLIST +SR.FUS==:5 ;LH IS FIRST USER SLOT + +SR.LEN==:5 ;NUMBER OF WORDS NEEDED BY THE SYSTEM +] ;END IFN SFA + + +;;; Size of hunks +IFDEF SEGLOG, HNKLOG==SEGLOG-1 +IFNDEF SEGLOG, HNKLOG==11 \ No newline at end of file diff --git a/src/l/humble.42 b/src/l/humble.42 new file mode 100755 index 00000000..4d15de83 --- /dev/null +++ b/src/l/humble.42 @@ -0,0 +1,474 @@ + +;;; ************************************************************** +TITLE ***** MACLISP ****** HUMBLE INFERIOR PACKAGE FOR ITS NEWIO *** +;;; ************************************************************** +;;; ** (C) COPYRIGHT 1977 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** +;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* +;;; ************************************************************** + + +.MLLIT==1 +.FASL +IF1, .INSRT SYS:.FASL DEFS + +VERPRT HUMBLE + +UBPFJ==10 ;FOREIGN JOB REQUIRED BIT FOR USR OPENS +TMPC==0 ;TEMP I/O CHANNEL + +.SXEVAL (SETQ CURRENT-JOB NIL + THE-JOB-INPUT-CHANNEL NIL + THE-JOB-OUTPUT-CHANNEL NIL + THE-JOB-INPUT-CHANNEL-FILE-OBJECT NIL + THE-JOB-OUTPUT-CHANNEL-FILE-OBJECT NIL) + +DEFINE CURJOB +.SPECIAL CURRENT-JOB TERMIN + +DEFINE USRI +.SPECIAL THE-JOB-INPUT-CHANNEL TERMIN + +DEFINE USRO +.SPECIAL THE-JOB-OUTPUT-CHANNEL TERMIN + +DEFINE USRIAR +.SPECIAL THE-JOB-INPUT-CHANNEL-FILE-OBJECT TERMIN + +DEFINE USROAR +.SPECIAL THE-JOB-OUTPUT-CHANNEL-FILE-OBJECT TERMIN + +;;; (CREATE-JOB ) +;;; CREATES A JOB OBJECT, AND MAKES IT CURRENT. +;;; = NIL (DEFAULT) MEANS YOUR UNAME. +;;; = T (NON-DEFAULT) MEANS REQUIRE FOREIGN JOB. +;;; RETURNS LIST OF TWO THINGS: +;;; (1) ONE OF THE FOLLOWING ATOMS: +;;; INFERIOR +;;; REOWNED +;;; FOREIGN +;;; (2) THE JOB OBJECT +;;; IF WAS NON-NIL AND THE JOB WAS NOT FOUND, NIL IS RETURNED. + +;;; (SELECT-JOB ) MAKES THE SPECIFIED JOB CURRENT IN THE +;;; EXPECTED MODE (FOREIGN OR NOT), RETURNING VALUES AS FOR CREATE-JOB. + +HACKJ0: WTA [BAD JOB OBJECT - SELECT-JOB!] +.ENTRY SELECT-JOB SUBR 0002 ;SUBR 1 + PUSHJ P,JOBP + JRST HACKJ0 + JSP T,NPUSH-5 + MOVEI TT,J.INTB + SKIPN @TTSAR(A) + HLLOS (P) + HLLOS NOQUIT + MOVEI TT,J.CINT + MOVE B,@TTSAR(A) + MOVE TT,TTSAR(A) + JRST CRJOB5 + +.ENTRY CREATE-JOB LSUBR 004006 ;LSUBR (3 . 5) + JSP TT,LWNACK + LA345,,.ATOM CREATE-JOB ;LA345 MEANS 3-5 ARGS. + CAML T,[-4] + PUSH P,[NIL] + CAML T,[-3] + PUSH P,[NIL] + SKIPN A,-1(P) + TDZA TT,TT + PUSHJ P,SIXMAK + PUSH FXP,TT + MOVE A,-2(P) + PUSHJ P,SIXMAK + PUSH FXP,TT + PUSH FXP,[-1] + HLLOS NOQUIT + .CALL [ SETZ + SIXBIT \OPEN\ ;OPEN FILE (JOB) + 5000,,UBPFJ+6 ;INSIST ALREADY EXIST, PLUS IMAGE BLOCK INPUT + 1000,,TMPC ;CHANNEL NUMBER + ,,[SIXBIT \USR\] ;DEVICE NAME + ,,-2(FXP) ;UNAME + 400000,,-1(FXP) ] ;JNAME + SETZM (FXP) + .CLOSE TMPC, + HLLZS NOQUIT + PUSHJ P,CHECKI + SKIPN (FXP) + SKIPN (P) + CAIA + JRST CRJOB8 ;RETURN NIL IF LOSE + PUSHJ P,GTJCHN ;GET JOB CHANNELS + PUSH P,[CRJOB2] + PUSH P,[NIL] + PUSH P,[.ATOM FIXNUM ] + PUSH P,[.ATOM #LOJOBA ] + MOVNI T,3 + JCALL 16,.FUNCTION *ARRAY +CRJOB2: HLLOS NOQUIT + MOVE TT,TTSAR(A) + POP FXP,F + POP FXP,F.FN2(TT) + POP FXP,T + SKIPN T + .SUSET [.RUNAME,,T] + MOVEM T,F.FN1(TT) + MOVSI T,(SIXBIT \USR\) + MOVEM T,F.DEV(TT) + MOVSI D,AS + IORB D,ASAR(A) + MOVSI T,-J.GC + HLLM T,-1(D) + MOVE B,-4(P) + MOVEM B,J.INTF(TT) + MOVE B,-3(P) + MOVEM B,J.CINT(TT) +CRJOB5: MOVEM A,CURJOB ;SELECT-JOB JOINS HERE + MOVE C,USRIAR + MOVE T,TTSAR(C) + MOVEM B,FJ.INT(T) + MOVE C,USROAR + MOVE T,TTSAR(C) + MOVEM B,FJ.INT(T) + SKIPN (P) + TDZA T,T + MOVEI T,UBPFJ + .CALL [ SETZ + SIXBIT \OPEN\ ;OPEN FILE (JOB) + 5000,,6(T) ;IMAGE BLOCK INPUT MODE + ,,@USRI ;CHANNEL NUMBER + ,,F.DEV(TT) ;DEVICE NAME (USR) + ,,F.FN1(TT) ;UNAME + 400000,,F.FN2(TT) ] ;JNAME + JRST CRJOB7 + .CALL [SETZ + SIXBIT \USRVAR\ + ,,@USRI + 1000,,.ROPTION + 1000,,0 ;IGNORED FOR IMMEDIATE-INST MODE + SETZ [TLO %OPLSP]] ;TURN ON "LISP IS SUPERIOR" BIT + JFCL ;IGNORE FAILURE, MIGHT NOT BE OUR JOB + ;; Don't put these .calls together, the OPTION is allowed to + ;; fail, but the uind shouldn't. + .CALL [SETZ ? SIXBIT \USRVAR\ + ,,@USRI + 1000,,.RUIND + SETZM J.UIND(TT)] + .LOSE %LSFIL ; ??? + MOVE T,@USRI ;PICK UP CHANNEL NUMBER + MOVEM T,F.CHAN(TT) ;FORCE IT TO BE CHAN # OF JOB ARRAY + .CALL [ SETZ + SIXBIT \RCHST\ ;READ CHANNEL STATUS + ,,@USRI ;CHANNEL NUMBER OF JOB + 2000,,F.RDEV(TT) ;DEVICE NAME + 2000,,F.RFN1(TT) ;FILE NAME 1 + 2000,,F.RFN2(TT) ;FILE NAME 2 + 2000,,R ;SNAME (ZERO) (IGNORE) + 2000,,R ;ACCESS POINTER (ZERO) (IGNORE) + 402000,,R ] ;MODE BITS (1.4 => FOREIGN JOB) + .VALUE + SETZM J.INTB(TT) + MOVEI B,.ATOM FOREIGN + TRNE R,UBPFJ + JRST CRJOB4 + MOVE D,@USRI + LSH D,27 + IOR D,[.USET 0,[.RINTB,,T]] + XCT D + MOVEM T,J.INTB(TT) + .CALL [ SETZ + SIXBIT \OPEN\ ;OPEN JOB + 5000,,7 ;IMAGE BLOCK OUTPUT + ,,@USRO ;CHANNEL NUMBER + ,,F.DEV(TT) ;DEVICE NAME (USR) + ,,F.FN1(TT) ;UNAME + 400000,,F.FN2(TT) ] ;JNAME + .VALUE + .CALL [ SETZ + SIXBIT \RCHST\ ;READ CHANNEL STATUS + ,,@USRO ;CHANNEL NUMBER OF JOB + 2000,,F.RDEV(TT) ;DEVICE NAME + 2000,,F.RFN1(TT) ;FILE NAME 1 + 402000,,F.RFN2(TT) ] ;FILE NAME 2 + .VALUE + JFFO T,.+1 + MOVNS TT + MOVEM A,JOBTB+21(TT) + MOVEI B,.ATOM INFERIOR + SKIPE F + MOVEI B,.ATOM REOWNED +CRJOB4: HLLZS NOQUIT + PUSHJ P,CHECKI + PUSH P,B + CALL 1,.FUNCTION NCONS + POP P,B + CALL 2,.FUNCTION XCONS +CRJOB9: SUB P,[5,,5] + POPJ P, + +CRJOB7: HLLZS NOQUIT + PUSHJ P,CHECKI +CRJB7A: SETZB A,CURJOB + JRST CRJOB9 + +CRJOB8: SUB FXP,[3,,3] + JRST CRJB7A + +GTJCH0: SUB P,[1,,1] + MOVEI A,.SX (?) + IOL [NOT ENOUGH I/O CHANNELS!] +GTJCHN: SKIPE USRIAR + POPJ P, + PUSH P,[NIL] + MOVSI TT,(SIXBIT \USR\) + PUSHJ P,ALFILE + JRST GTJCH0 + MOVEM A,(P) + MOVSI TT,(SIXBIT \USR\) + PUSHJ P,ALFILE + JRST GTJCH0 + MOVEI AR1,(A) + POP P,AR2A + MOVSI TT,TTS ;THIS ONE IS OUTPUT + IORM TT,TTSAR(AR2A) + MOVEI TT,F.CHAN + MOVE F,@TTSAR(AR1) + MOVE TT,@TTSAR(AR2A) + JSP T,FXCONS + MOVEI B,(A) + MOVE TT,F + JSP T,FXCONS + HLLOS NOQUIT + MOVE T,TTSAR(AR1) + MOVE TT,TTSAR(AR2A) + MOVE D,[SIXBIT \ USRI \] + MOVEM D,F.FN1(T) + MOVEM D,F.RFN1(T) + MOVE D,[SIXBIT \ USRO \] + MOVEM D,F.FN1(TT) + MOVEM D,F.RFN1(TT) + MOVE D,[SIXBIT \ CHNL \] + MOVEM D,F.FN2(T) + MOVEM D,F.FN2(TT) + MOVEM D,F.RFN2(T) + MOVEM D,F.RFN2(TT) + MOVEM A,USRI + MOVEM B,USRO + MOVEM AR1,USRIAR + MOVEM AR2A,USROAR + HLLZS NOQUIT + JRST CHECKI + +DEFINE JOBLOK FN ;LOCK USER INTS, CHECK OUT CURRENT-JOB + LOCKI + SKIPN A,CURJOB + JRST UNLKNIL + PUSHJ P,JOBP + JRST [ SETZM CURJOB + UNLOCKI + FAC [CURRENT-JOB CONTAINED BAD JOB OBJECT - FN!!] + ] +TERMIN + +DEFINE INFLOK FN ;INSIST ON INFERIOR + JOBLOK FN + MOVE T,TTSAR(A) + SKIPN T,J.INTB(T) + JRST UNLKNIL +TERMIN + + +;;; (JOB-USET-READ ) RETURNS VALUE OF USET VAR , +;;; OR NIL IF NO CURRENT JOB. + +.ENTRY JOB-USET-READ SUBR 0002 ;SUBR 1 + JSP T,FXNV1 + JOBLOK JOB-USET-READ + MOVE D,@USRI + LSH D,27 + IOR D,[.USET 0,T] + HRLI T,(TT) + HRRI T,TT + XCT D + UNLOCKI + JRST FIX1 + +;;; (JOB-USET-WRITE ) WRITES USET VAR , +;;; OR NIL IF NO CURRENT JOB OR FOREIGN JOB. +;;; SHOULD HAVE THE 400000 BIT SET. + +.ENTRY JOB-USET-WRITE SUBR 0003 ;SUBR 2 + JSP T,FXNV1 + JSP T,FXNV2 + INFLOK JOB-USET-WRITE + MOVE R,@USRI + LSH R,27 + IOR R,[.USET 0,T] + HRLI T,(TT) + HRRI T,D + XCT R + UNLOCKI + MOVEI A,.ATOM T + POPJ P, + +;;; (KILL-JOB) KILLS THE CURRENT JOB. + +.ENTRY KILL-JOB SUBR 0001 ;SUBR 0 + JOBLOK KILL-JOB + HLLOS NOQUIT + SETZM CURJOB + MOVE TT,TTSAR(A) + TLNE TT,TTS ;IN CASE OF ASYNCHRONOUS LOSSES + JRST KILLJ9 + MOVSI T,TTS + IORM T,TTSAR(A) + SKIPN T,J.INTB(TT) + JRST KILLJ2 + JFFO T,.+1 + MOVNS TT + SETZM JOBTB+21(TT) + MOVE T,@USRI + LSH T,27 + IOR T,[.UCLOSE 0,] + XCT T + JRST KILLJ8 + +KILLJ2: .CALL [ SETZ + SIXBIT \CLOSE\ ;CLOSE CHANNEL + 400000,,@USRI ] ;CHANNEL NUMBER + .VALUE + .CALL [ SETZ + SIXBIT \CLOSE\ ;CLOSE CHANNEL + 400000,,@USRO ] ;CHANNEL NUMBER + .VALUE +KILLJ8: MOVEI A,.ATOM T +KILJ8A: HLLZS NOQUIT + UNLKPOPJ + +KILLJ9: MOVEI A,NIL + JRST KILJ8A + +;;; SKIPS IF VALID JOB OBJECT IN A. +;;; USES ONLY A, B, T. + +JOBP: MOVEI B,(A) + CALL 1,.FUNCTION TYPEP + EXCH A,B + CAIE B,.ATOM ARRAY + POPJ P, + MOVE T,ASAR(A) + TLNN T,AS + POPJ P, + MOVE T,TTSAR(A) + TLNN T,TTS + AOS (P) + POPJ P, + +;;; (LOAD-JOB ) OPENS UP FILE +;;; AND LOADS IT INTO THE CURRENT JOB. +;;; RETURNS: +;;; NIL WON! +;;; BIN? FILE NOT BIN +;;; FILE? FILE NOT FOUND + +.ENTRY LOAD-JOB SUBR 0002 ;SUBR 1 + MOVEI C,(A) + INFLOK LOAD-JOB + MOVEI A,(C) + CALL 2,.FUNCTION MERGEF + PUSHJ P,FIL6BT + HLLOS NOQUIT + MOVEI A,.ATOM FILE? + .CALL [ SETZ + SIXBIT \OPEN\ ;OPEN FILE + 5000,,6 ;IMAGE BLOCK INPUT + 1000,,TMPC ;CHANNEL NUMBER + ,,-3(FXP) ;DEVICE + ,,-1(FXP) ;FILE NAME 1 + ,,0(FXP) ;FILE NAME 2 + 400000,,-2(FXP) ] ;SNAME + JRST LDJB9 + .CALL [ SETZ + SIXBIT \RESET\ ;RESET THE JOB + 400000,,@USRI ] ;CHANNEL NUMBER + .VALUE + MOVEI A,.ATOM BIN? + .CALL [ SETZ + SIXBIT \LOAD\ ;LOAD JOB + ,,@USRO ;JOB SPEC + 400000,,TMPC ] ;DISK CHANNEL + JRST LDJB9 + HRROI T,TT + .IOT TMPC,T + .CLOSE TMPC, + HRRZ C,CURJOB + MOVE T,TTSAR(C) + MOVEM TT,J.STAD(T) + MOVEI A,NIL +LDJB9: SUB FXP,[4,,4] + HLLZS NOQUIT + UNLKPOPJ + +;;; (EXAMINE-JOB ) EXAMINES LOCATION OF CURRENT JOB. +;;; RETURNS NIL ON FAILURE (INDICATES BAD ERROR). + +.ENTRY EXAMINE-JOB SUBR 0002 ;SUBR 1 NCALLABLE + PUSH P,[FIX1] + JSP T,FXNV1 + JOBLOK EXAMINE-JOB + JSP F,JOBED + @USRI + JRST UNLKNIL + MOVE TT,D + UNLOCKI + POPJ P, + +;;; (DEPOSIT-JOB ) DEPOSITS IN OF CURRENT JOB. +;;; RETURNS NIL ON FAILURE (INDICATES BAD ERROR). + +.ENTRY DEPOSIT-JOB SUBR 0003 ;SUBR 2 + JSP T,FXNV1 + JSP T,FXNV2 + INFLOK DEPOSIT-JOB + JSP F,JOBED + @USRO +UNLKNIL: TDZA A,A +UNLKT: MOVEI A,.ATOM T + UNLKPOPJ + +JOBED: MOVEI A,NIL + .CALL [ SETZ + SIXBIT \ACCESS\ ;SET ACCESS POINTER + ,,@(F) ;CHANNEL NUMBER + 400000,,TT ] ;NEW ACCESS POINTER + JRST 1(F) + HRROI TT,D + .CALL [ SETZ + SIXBIT \IOT\ ;IOT + ,,@(F) ;CHANNEL NUMBER + 400000,,TT ] ;IOT POINTER + JRST 1(F) + JRST 2(F) + +;;; (*ATTY) DOES A .ATTY TO THE CURRENT JOB. + +.ENTRY *ATTY SUBR 0001 ;SUBR 0 + INFLOK *ATTY + MOVE TT,TTSAR(A) + SKIPN J.INTB(TT) + JRST UNLKNIL + MOVE D,@USRI + LSH D,27 + IOR D,[.ATTY 0,] + XCT D + JRST UNLKNIL + JRST UNLKT + +;;; (*DTTY) DOES A .DTTY. + +.ENTRY *DTTY SUBR 0001 ;SUBR 0 + .DTTY + TDZA A,A + MOVEI A,.ATOM T + POPJ P, + +FASEND diff --git a/src/libdoc/%print.gross3 b/src/libdoc/%print.gross3 new file mode 100644 index 00000000..558ee305 --- /dev/null +++ b/src/libdoc/%print.gross3 @@ -0,0 +1,198 @@ + +;;; Circular-list hackers: + +;;; The functions %PRINT and %PRIN1 herein +;;; can print (or prin1) any arbitrarily involuted +;;; list structure in a moderately readable form. + +;;; There is a CPRINT-like facility available for doing +;;; arbitrary formatting of things. +;;; Currently, this file contains code for the +;;; /' and /@ readmacros. + +;;; Please direct comments regarding bugs/features to +;;; Rick Grossman (AI:GROSS;), 825 Tech Square, 3-5848. + + +;;; Note: +;;; We avoid the overhead of a hash table by actually smashing +;;; the cells to indicate that they have been traversed. +;;; Thus we lose on pure list structure. + + +;;; Output format: +;;; (setq x '(foo bar)) (rplacd (cdr x) x) (%print x) +;;; would print as: %:G0012 (foo bar . %-G0012) +;;; where %: