github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-27 10:30:50 +00:00
Code Issues Releases Wiki Activity

Added lots of new LSPLIB packages (and their sources).

Browse Source
This commit is contained in:
Eric Swenson
2018-03-16 13:50:36 -07:00
parent 13244c1d61
commit 92db560d8f
118 changed files with 35842 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/alan/dprint.142
View File

Binary file not shown.

71
src/graphs/close.42 Normal file
View File

@@ -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)

132
src/graphs/graphs.102 Normal file
View File

@@ -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)))))

64
src/graphs/graphs.demo Normal file
View File

@@ -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!")))
'*)

100
src/graphs/graphs.usage Normal file
View File

@@ -0,0 +1,100 @@
Date: 1 July 1980 14:57-EDT
From: George J. Carrette <GJC at MIT-MC>
To: "(FILE [GJC;GRAPHS USAGE])" at MIT-MC
Date: 1 July 1980 14:53-EDT
From: George J. Carrette <GJC at MIT-MC>
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 <ards-object>) takes an ards-object and returns
a flonum-scaling graphics stream.
Other operations are conviently accessed with the CALL function.
(call <stream> 'cursorpos 'c)
(call <stream> 'which-operations)
(call <stream> 'open 'tty)
(call <stream> 'open 'dsk '((foo) bar >))
(call <stream> '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 <OUTPUT-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 <STREAM> <MODE> &OPTIONAL <ARG>)
<mode> is 'TTY or 'DSK. <arg> is the file name when opened
in 'DSK mode.
(GRAPHICS-STREAM-CLOSE <STREAM>) closes any DSK file.
(SET-PEN <GRAPHICS-STREAM> X Y)
(MOVE-PEN <GRAPHICS-STREAM> X Y)
draws a line from the last point the new point.
(VECTOR-PEN <GRAPHICS-STREAM> X Y) does a relative move of the pen.
(DRAW-POINT <GRAPHICS-STREAM> X Y) draws a line of length 0.
(GRAPHICS-STREAM-TYO <STREAM> <ARG>) 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 <GRAPHIC-STREAM> X0 X1 Y0 Y1)
the window is the apparent flonum size.
(SET-VIEWPORT <GRAPHIC-STREAM> 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 <GRAPHICS-STREAM>) takes a graphics stream
and returns and SFA which may be used as an argument to
PRINT, FORMAT, etc.
(MAKE-TRACED-FUNCTOR <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.

1214
src/l/defns.240 Executable file
View File

File diff suppressed because it is too large Load Diff

474
src/l/humble.42 Executable file
View File

@@ -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 <JOBINTFUN> <CHNINTFUN> <JNAME> <UNAME> <FOREIGN>)
;;; CREATES A JOB OBJECT, AND MAKES IT CURRENT.
;;; <UNAME> = NIL (DEFAULT) MEANS YOUR UNAME.
;;; <FOREIGN> = 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 <FOREIGN> WAS NON-NIL AND THE JOB WAS NOT FOUND, NIL IS RETURNED.
;;; (SELECT-JOB <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<JOB>
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<IO> ;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 <NUM>) RETURNS VALUE OF USET VAR <NUM>,
;;; 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 <NUM> <VAL>) WRITES USET VAR <NUM>,
;;; OR NIL IF NO CURRENT JOB OR FOREIGN JOB.
;;; <NUM> 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<CL> ;IN CASE OF ASYNCHRONOUS LOSSES
JRST KILLJ9
MOVSI T,TTS<CL>
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<JOB>
POPJ P,
MOVE T,TTSAR(A)
TLNN T,TTS<CL>
AOS (P)
POPJ P,
;;; (LOAD-JOB <FILENAME>) OPENS UP FILE <FILENAME>
;;; 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 <LOC>) EXAMINES LOCATION <LOC> 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 <LOC> <VAL>) DEPOSITS <VAL> IN <LOC> 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

198
src/libdoc/%print.gross3 Normal file
View File

@@ -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 %:<label> defines a piece of list structure,
;;; and %-<label> denotes a back-reference.
;;;
;;; The file %READ FASL DSK: LIBLSP; contains a readmacro
;;; for "%" which allows reading this stuff back in.
;;; Note that the functions %MUNGE and %UNMUNGE
;;; in this package can be used for other kinds of
;;; circular list hacking (such as a circular sxhash).
;;; Revision:
;;; 21 Re-do the whole thing (clean it up).
;;; 22 Add test for ^W and ^R.
;;; Run in (nointerrupt t) mode.
;;; 23 (7/2/75) Adapt to the fact that PRINC always returns T.
;;; Do automatic %UNMUNGE if pure-page trap.
;;; 24 (8/13/75) Flush :MAIL kludge.
(declare (setq nfunvars t) (macros t) (genprefix /%p\))
(defun /%print (x) (princ '/n/î) (/%prin1 x) (princ '/ ) t)
(defun /%prin1 (x)
(cond
((and ^w (not ^r)))
(t
((lambda (nointerrupt errset)
(errset (/%prin1* (/%munge x)) t)
(/%unmunge x)
(nointerrupt nointerrupt) )
(nointerrupt t)
nil
) ) )
t )
;; Munged format:
;; (A . B) becomes ((/%flag A . <marker>) . B).
;; The <marker> is non-nil if this cell is multiply referenced.
(declare (special /%flag /%unmunge))
(setq /%flag (copysymbol '/%flag nil))
(defun /%munge (x)
;; Munge from top to bottom.
(cond
((atom x))
((eq (caar x) /%flag)
;; Indicate this cell is multiply referenced.
(rplacd (cdar x) t) )
(t
(rplaca x (list /%flag (car x)))
(/%munge (cadar x))
(/%munge (cdr x)) ) )
x )
(defun /%unmunge (x)
;; Unmunge from bottom to top.
(cond
((atom x))
((not (eq (caar x) /%flag)))
(t
(prog (y)
(setq y (car x))
(rplaca y nil) ;Prevent infinite recursion.
(/%unmunge (cadr y)) (/%unmunge (cdr x))
(rplaca x (cadr y))
;...(reclaim y nil)
) ) ) )
;; ejs 2018-03-13: replaced with defmacro
;;(defun macro /%atom (x)
;; A munged cell with a non-nil marker should be
;; printed as an atom (because of the label).
;; (subst (cadr x) 'x
;; '(or (atom x) (cddar x)) ) )
(defmacro /%atom (x)
`(or (atom ,x) (cddar ,x))))
;; ejs 2018-03-13: replaced with defmacro
;;(defun macro /%cdr (x) (cons 'cdr (cdr x)))
(defmacro /%cdr (x) `(cdr ,x))
;; ejs 2018-03-13: replaced with defmacro
;;(defun macro /%car (x) (cons 'cadar (cdr x)))
(defmacro /%car (x) `(cadar ,x))
(defun /%prin1* (x) (prog (y z)
(cond
((and ^w (not ^r)))
((atom x)
(cond
((and (setq y (get x 'print0)) (funcall y x)))
((prin1 x)) ) )
((not (eq (caar x) /%flag))
(error '/%print x 'fail-act) )
((setq y (cddar x))
;; The marker is set, thus we use a label.
(cond
((eq y t)
;; First time -- generate a label.
(princ '/%/:)
(princ (setq y (gensym)))
(rplacd (cdar x) y)
(princ '/ ) (/%prin/.loop x) )
(t
;; Not first time.
(princ '/%/-) (princ y) ) ) )
;; A normal cell -- do cprint hackery.
((atom (setq z (/%car x)))
(cond
((and (setq y (get z '/%print1)) (funcall y x)))
((/%prin/.loop x)) ) )
((atom (setq z (/%car z)))
(cond
((and (setq y (get z '/%print2)) (funcall y x)))
((/%prin/.loop x)) ) )
((/%prin/.loop x)) )
(return t) ))
(defun /%prin/.loop (x)
(princ '/()
(/%prin1* (/%car x))
(do ((x (/%cdr x) (/%cdr x)))
((cond
((null x))
((and ^w (not ^r)))
((or (/%atom x)
(and (atom (/%car x)) (get (/%car x) 'print-cdr)) )
(princ '/ /./ )
(/%prin1* x) ) )
(princ '/)) )
(princ '/ )
(/%prin1* (/%car x)) ) )
;; Stuff for readmacros.
(defun /%print-/' (x)
(cond
((and (not (/%atom (/%cdr x))) (null (/%cdr (/%cdr x))))
(princ '/') (/%prin1* (/%car (/%cdr x))) ) )
;; if length not 2, we return nil so /%prin1* will print
;; it as an ordinary form.
)
(defprop quote /%print-/' /%print1)
(defun /%print-/@ (e) (princ (/%car e)) (/%prin1* (/%cdr e)))
(defprop /@ /%print-/@ /%print1)
(defprop /@ t print-cdr)

106
src/libdoc/6bit.jonl3 Executable file
View File

@@ -0,0 +1,106 @@
;;; -*- Mode:Lisp; IBase:10.; -*-
;;;
;;; 6BIT: A package for conversions between sixbit or ascii representations
;;; and lisp symbols.
;;;
;;; This library was created by KMP, 22 Oct 81, and added to by JONL 23 Oct 81.
;;;
;;; (SYMBOL-TO-ASCII sym &optional (n 1))
;;; Returns the n'th PDP10 word of the ascii representation of
;;; the symbol 'sym', with 1-origin indexing of the words.
;;; (SYMBOL-TO-SIXBIT sym &optional (n 1))
;;; Returns the n'th PDP10 word of the sixbit representation.
;;; (SYMBOL->6BIT sym) Same as (SYMBOL-TO-ASCII sym 1), but marginally
;;; faster calling sequence.
;;;
;;; (ASCII-TO-SYMBOL number &optional internp)
;;; Returns a symbol [which is interned if 'internp' is non-()],
;;; whose pname is designated by the fixnum 'number'.
;;; (SIXBIT-TO-SYMBOL number &optional internp)
;;; Returns a symbol [which is interned if 'internp' is non-()],
;;; whose pname is constructed by converting the 'number' from
;;; sixbit to ascii representation.
;;; (6BIT->SYMBOL num) Same as (SIXBIT-TO-SYMBOL num 'T), but marginally
;;; faster calling sequence.
;;;
(herald /6BIT 2)
(eval-when (eval compile load)
(and (status feature COMPLR)
(fixnum (symbol->6bit) (symbol-to-sixbit) (symbol-to-ascii))))
(declare (fixnum (si:SYMBOL->6BIT-or-ASCII)
(1wd/| () fixnum)))
;;;; Conversions from symbols
(defun SYMBOL-TO-ASCII (sym &optional (nth-word 1))
(si:SYMBOL->6BIT-or-ASCII sym nth-word 'ASCII 'SYMBOL-TO-ASCII))
(defun SYMBOL-TO-SIXBIT (sym &optional (nth-word 1))
(si:SYMBOL->6BIT-or-ASCII sym nth-word () 'SYMBOL-TO-SIXBIT))
(DEFUN SYMBOL->6BIT (SYM)
(si:SYMBOL->6BIT-or-ASCII sym 1 () 'SYMBOL->6BIT))
(defun si:SYMBOL->6BIT-or-ASCII (sym nth-word asciip funname)
(if (not (symbolp sym))
(check-type sym #'SYMBOLP funname))
(if (not (fixnump nth-word))
(check-type nth-word #'FIXNUMP funname))
(if (eq asciip 'ASCII)
(let ((pnl (pnget sym 7))
(i (1- nth-word)))
(declare (fixnum i))
(if (= i 0)
(car pnl)
(nth i pnl)))
(if (and (= nth-word 1) (< (flatc sym) 7))
(car (pnget sym 6))
(1wd/| sym nth-word () ))))
(or (getl '1WD/| '(SUBR AUTOLOAD))
(putprop '1WD/| (get 'LAP 'AUTOLOAD) 'AUTOLOAD))
;;;;Conversions to symbol
(defun ASCII-TO-SYMBOL (number &optional internp)
(if (not (fixnump number))
(check-type number #'FIXNUMP 'ASCII-TO-SYMBOL))
(pnput (list number) internp))
(defun SIXBIT-TO-SYMBOL (number &optional internp)
(si:SYMBOL-from-6BIT number internp 'SIXBIT-TO-SYMBOL))
(defun 6BIT->SYMBOL (number)
(si:SYMBOL-from-6BIT number 'INTERN '6BIT->SYMBOL))
(defun si:SYMBOL-from-6BIT (number internp funname)
(if (not (fixnump number))
(check-type number #'FIXNUMP funname))
(do ((n number (lsh n 6))
(position 29. (- position 7))
(first-pname-word 0)
(extra () ))
((zerop n) ;Done when no more non-zero bits in number.
(pnput (cons first-pname-word extra) internp))
(declare (fixnum n position first-pname-word))
(cond ((> position 0)
(setq first-pname-word
(deposit-byte first-pname-word
position
7
(+ (load-byte n 30. 6) #O40))))
('T ;;Ha, must be 6 chars in the number!
(setq extra `(,(deposit-byte 0
29.
7
(+ (load-byte n 30. 6) #O40))))))))

42
src/libdoc/apropo.jonl12 Executable file
View File

@@ -0,0 +1,42 @@
; -*-LISP-*-
; Find all atoms in the current obarray whose PNAME's contain a given string.
; TWAs (truly worthless atoms) are ignored unless value of APROPOS is non-null.
; Example: (APROPOS 'CHAR) returns
; (CHARPOS GETCHAR GETCHARN)
(DECLARE (SPECIAL APROPOS))
(OR (BOUNDP 'APROPOS) (SETQ APROPOS () ))
(DEFUN APROPOS (ARG)
(DECLARE (FIXNUM I FIRSTI MAXFIRSTI NEXTFIRSTI CN))
(PROG (MATCHL LARG ANSL)
A (COND ((NOT (SYMBOLP ARG))
(SETQ ARG (ERROR '|Non-symbol - APROPOS| ARG 'WRNG-TYPE-ARG))
(GO A)))
(SETQ MATCHL (EXPLODEN ARG) LARG (LENGTH MATCHL))
(MAPATOMS
'(LAMBDA (SYM)
(COND ((OR APROPOS (BOUNDP SYM) (PLIST SYM)) ;Test if not TWA
(DO ((FIRSTI 1 NEXTFIRSTI) ;First index for scanning
(MAXFIRSTI (- (FLATC SYM) LARG -1))
(NEXTFIRSTI 0)
(CN 0))
((> FIRSTI MAXFIRSTI) () )
(SETQ NEXTFIRSTI (1+ FIRSTI))
(COND ((NOT (= (CAR MATCHL) (GETCHARN SYM FIRSTI))))
((DO ((I (1+ FIRSTI) (1+ I)) ;Found 1st char match
(NFI-FL)
(L (CDR MATCHL) (CDR L)))
((NULL L) 'T)
(SETQ CN (GETCHARN SYM I))
(AND (NULL NFI-FL) ;Accellerator for FIRSTI
(= (CAR MATCHL) CN)
(SETQ NEXTFIRSTI I NFI-FL T))
(AND (NOT (= (CAR L) CN)) (RETURN () )))
(PUSH SYM ANSL)
(RETURN 'T))))))))
(RETURN ANSL)))
(DEFUN APROPOS-SORTED (ATOM)
(SORT (APROPOS ATOM) (FUNCTION ALPHALESSP)))

71
src/libdoc/arith.cffk2 Executable file
View File

@@ -0,0 +1,71 @@
;;;Functions for *$ //$ and scaling for use with compiled code.
;;;Overflow is caught, and underflow gives 0.0 or an error depending
;;;on the setting of the ZUNDERFLOW switch
;;; Originally written by CFFK
;;; Functions +f and -f added by JONL on 7 DEC 76
;;;in file put:
;;;(and (not (get '*f 'subr))
;;; (mapc '(lambda (x) (putprop x '(arith fasl dsk liblsp) 'autoload))
;;; '(*f //f _f +f -f)))
;;;declarations needed:
;;;(declare (flonum (*f flonum flonum) (//f flonum flonum)
;;; (_f flonum fixnum) (+f flonum flonum) (-f flonum flonum))
;;; (*expr *f //f _f +f -f))
(declare (flonum (*f flonum flonum) (//f flonum flonum)
(_f flonum fixnum) (+f flonum flonum) (-f flonum flonum))
(*expr *f //f _f +f -f))
(lap *f subr)
(args *f (nil . 2))
(push p (% 0 0 float1))
(movei r 0)
(jrst 2 @ (% 0 0 nexta)) ;zero all overflow and underflow flags
(entry //f subr)
(args //f (nil . 2))
(push p (% 0 0 float1))
(movei r 1)
(jrst 2 @ (% 0 0 nexta)) ;zero all overflow and underflow flags
(entry _f subr)
(args _f (nil . 2))
(push p (% 0 0 float1))
(movei r 2)
(jrst 2 @ (% 0 0 nexta)) ;zero all overflow and underflow flags
(entry +f subr)
(args +f (nil . 2))
(push p (% 0 0 float1))
(movei r 3)
(jrst 2 @ (% 0 0 nexta)) ;zero all overflow and underflow flags
(entry -f subr)
(args -f (nil . 2))
(push p (% 0 0 float1))
(movei r 4)
(jrst 2 @ (% 0 0 nexta)) ;zero all overflow and underflow flags
nexta (move tt 0 a) ;first arg into tt
(move d 0 b) ;second arg into d
(xct 0 instbl r) ;do floating point operation
(jfcl 10 uflow) ;overflow detected?
ans (popj p) ;return with result in tt
uflow (jsp t (* 1))
(tlnn t 100)
(lerr 0 (% sixbit |floating-point overflow from f-series functions!|))
(skipn 0 (special zunderflow))
(lerr 0 (% sixbit |floating-point underflow from f-series functions!|))
(movei tt 0)
(jrst 0 ans)
instbl (fmpr tt d)
(fdvr tt d)
(fsc tt 0 d)
(fadr tt d)
(fsbr tt d)
nil

78
src/libdoc/aryadr.jonl7 Executable file
View File

@@ -0,0 +1,78 @@
;;; -*-MIDAS-*-
TITLE ARYADR
.insrt sys:.fasl defs
.fasl
VERPRT ARYADR
;Following DECLARE should be in any file which uses this function
;(declare (fixnum (ARRAY-ADDR () fixnum)))
;FILE-ARRAY-GET takes an "array" as first arg, and a symbolic name of a
; numeric file-array constituent as second arg. (FILE-ARRAY-GET foo 'CHAN)
; will get the internal channel number of the file, and on TWENEX type
; systems, (FILE-ARRAY-GET foo 'JFN) will get the JFN. Permissible
; "properties" are MODE, CHAN, JFN, and LENGTH.
;ARRAY-ADDR takes an "array" as first arg, and a fixnum (say, 'i') as second,
; and returns a fixnum, which is the address of the i'th word of the array
;WARNING! be aware that if an array-relocation occurs between the time you
; get the array address, and the time at which you use it, you will lose.
; Of course, you wouldn't want to do anything in that time interval which
; would likely force an array-space relocation (such as creating new arrays,
; or loading in files, or calling GETSP etc), but what about asynchronous
; interrupts? Well, try using the NOINTERRUPT function; e.g.
; (PROGN (SETQ OLD-NOI (NOINTERRUPT 'T))
; (SETQ ADDR (ARRAY-ADDR ARY 15.))
; (FROBULATE-A-LITTLE ON ARGS)
; (USE ADDR)
; (NOINTERRUPT OLD-NOI)
.entry ARRAY-ADDR SUBR 003
push p,cfix1
jsp t,fxnv2 ;This depends upon GET not
caml d,[-10]
caile d,1_16. ; disturbing register D
jrst IOOR
move tt,A
lsh tt,-11
hrrz tt,st(tt)
cain tt,.atom ARRAY
jrst PT1
caie tt,.atom SYMBOL
jrst BADA
movei B,.atom ARRAY
call 2,.function GET
jumpe A,BADA
PT1: hrrz tt,ttsar(A)
add tt,D
popj p,
BADA: lerr [SIXBIT |BAD ARG TO ARRAY-ADDR!|]
IOOR: lerr [SIXBIT |INDEX OUT OF RANGE - ARRAY-ADDR!|]
.entry FILE-ARRAY-GET subr 003
TG0: move ar2a,a
call 1,.function FILEP
jumpe a,NAF
skipa a,b
UFP: wta |UNRECOGNIZED FILE PROPERTY - FILE-ARRAY-GET!|
seto tt,
caie a,.atom MODE
movei tt,F.MODE
caie a,.atom CHAN
movei tt,F.CHAN
caie a,.atom JFN
movei tt,F.JFN
caie a,.atom LENGTH
movei tt,F.FLEN
jumpl tt,UFP
move tt,@ttsar(ar2a)
jrst fix1
NAF: wta |NOT A FILE - FILE-ARRAY-GET!|
jrst tg0
fasend

32
src/libdoc/aryfil.jonl2 Executable file
View File

@@ -0,0 +1,32 @@
;;; -*-LISP-*-
;;; (LIVE-ARRAYS <kind>) returns a list of all allocated arrays (not
;;; currently considered "dead" space). Its argument permits selecting
;;; only certain kinds of arrays: OBARRAY, READTABLE, FILE, T, NIL,
;;; FIXNUM, or FLONUM. An argument of ALL gets all non-dead arrays.
;;; In addition, an argument of OPEN-FILE selects only open files.
;;; (OPEN-FILES) returns a list of all open file objects
(defun (OPEN-FILES macro) (()) `(LIVE-ARRAYS 'OPEN-FILE))
(defun LIVE-ARRAYS (kind)
(or kind (setq kind 'T))
(and (not (memq kind '(OBARRAY READTABLE FILE FIXNUM FLONUM T NIL)))
(not (eq kind 'OPEN-FILE))
(setq kind 'ALL))
(let ((dedsar (getddtsym 'DEDSAR))
(gcmkl (munkam (examine (getddtsym 'GCMKL))))
(open-file-flag (cond ((eq kind 'OPEN-FILE)
(setq kind 'FILE)
'T))))
(do ((l gcmkl (cddr l)) (z) )
((null l) (nreverse z))
(and (not (eq (car l) dedsar))
(cond ((eq kind 'ALL))
((eq kind (car (arraydims (car l))))
(or (not open-file-flag)
(status filemode (car l)))))
(push (car l) z)))))

1067
src/libdoc/askusr.psz1 Executable file
View File

File diff suppressed because it is too large Load Diff

1068
src/libdoc/askusr.psz2 Normal file
View File

File diff suppressed because it is too large Load Diff

19
src/libdoc/atan.jlk Executable file
View File

@@ -0,0 +1,19 @@
; fortran-atan computes atan of one or two arguments returning a range of values
; compatible with standard fortran (particularly, IBM and MULTICS).
; These are -%pi/2 to %pi/2 for single arg atan, and -%pi to %pi for 2 arg
; atan. LISP unfortunately returns values in the range 0 to 2%pi, and only
; takes two arguments.
(declare (fixnum n) (flonum (fortran-atan)))
(defun fortran-atan n
(prog (x y fa) (declare (flonum x y fa))
(setq x (arg 1) y (cond ((= n 2)(arg 2))(t 1.0))
fa (atan x y))
(return
(cond ((= n 1)
(cond ((> fa 3.14159265) (-$ fa (*$ 2.0 3.14159265)))
(t fa)))
(t (cond ((> fa 3.14159265)
(-$ fa (*$ 2.0 3.14159265)))
(t fa)))))))

129
src/libdoc/autodf.3 Executable file
View File

@@ -0,0 +1,129 @@
;; AUTODF J. T. Galkowski 1975-09-30
;; Updated to work with NEWIO by DTS 5/28/79
;;;
;;This file contains autoload properties for major functions in most files in the LIBLSP library.
;;; NO OR INCOMPLETE AUTOLOAD PROPERTIES FOR FOLLOWING FILES
;;; name reason
;;; "MACRO contains readmacros
;;; %READ contains readmacros
;;; ERT not compiled
;;; FUNVAL not compiled
;;; GC&VAR better to load from lisp init file
;;; PRFONT many externally callable functions
;;; PROP! many independent functions
;;; SMURF better to load from your INIT file
(DEFPROP %PRINT (%PRINT FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP %PRIN1 (%PRINT FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP LAND (BBOOLE FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP LOR (BBOOLE FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP LCOM (BBOOLE FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP LNOT (BBOOLE FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP LXOR (BBOOLE FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP DEBUG (DEBUG FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP DIREAD (DIREAD FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP FILE+ (FILE+ FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP LOGG (LOG FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP XGP (PRFONT FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP GET! (PROP! FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP PUTPROP! (PROP! FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP ADDPROP! (PROP! FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP INCRPROP! (PROP! FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP SELECTQ (SELECT FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP STEP (STEPR FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP STEPMM (STEPPMM FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP SUBLOAD (SUBLOA FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP DEFVAR (PPAK FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP DV (PPAK FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP PPRIN1 (PPRINT FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP PPRINT (PPRINT FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP PFFF (FORMAT FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP PFPF (FORMAT FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP PFFX (FORMAT FASL DSK LIBLSP) AUTOLOAD)
(DEFPROP PICTURE (LFTV FASL DSK LIBLSP) AUTOLOAD)
(DEFUN LIBLSP-AUTODF-CALL-UPDATE NIL
(PROG (N TIME-LAST-ACCESS ACCESS-RATE V0 V1 OIBASE OBASE)
(SETQ OIBASE IBASE OBASE BASE)
(SETQ IBASE 10. BASE 10.)
(setq / ())
(setq tinfile (open '((dsk libdoc)usage autodf)))
(setq / ())
(SETQ N (CAR (READ tinfile))
TIME-LAST-ACCESS (READ tinfile)
ACCESS-RATE (CAR (READ tinfile)))
(setq / ())
(SETQ
V0
(+$
(*$ (FLOAT (CAR TIME-LAST-ACCESS)) (*$ 365.0 24.0))
(+$
(*$ (FLOAT (CADR TIME-LAST-ACCESS)) (*$ 31.0 24.0))
(+$
(*$ (FLOAT (CADDR TIME-LAST-ACCESS)) 24.0)
(+$ (FLOAT (CAR (CDDDR TIME-LAST-ACCESS)))
(+$ (//$ (FLOAT (CADR (CDDDR TIME-LAST-ACCESS)))
24.0)
(//$ (FLOAT (CADDR (CDDDR TIME-LAST-ACCESS)))
3600.0)))))))
(SETQ TIME-LAST-ACCESS (APPEND (STATUS DATE)
(STATUS DAYTIME)))
(SETQ
V1
(+$
(*$ (FLOAT (CAR TIME-LAST-ACCESS)) (*$ 365.0 24.0))
(+$
(*$ (FLOAT (CADR TIME-LAST-ACCESS)) (*$ 31.0 24.0))
(+$
(*$ (FLOAT (CADDR TIME-LAST-ACCESS)) 24.0)
(+$ (FLOAT (CAR (CDDDR TIME-LAST-ACCESS)))
(+$ (//$ (FLOAT (CADR (CDDDR TIME-LAST-ACCESS)))
24.0)
(//$ (FLOAT (CADDR (CDDDR TIME-LAST-ACCESS)))
3600.0)))))))
(SETQ ACCESS-RATE
(//$ (FLOAT (1+ N))
(+$ (//$ (FLOAT N) ACCESS-RATE) (-$ V1 V0))))
(setq outfile (open '((dsk libdoc)usage autodf)'(out)))
(setq / ())
(PRINT (LIST (1+ N)) outfile)
(PRINT TIME-LAST-ACCESS outfile)
(PRINT (LIST ACCESS-RATE) outfile)
(close outfile)
(close tinfile)
(setq / ())<
(REMOB 'LIBLSP-AUTODF-CALL-UPDATE)
(SETQ BASE OBASE IBASE OIBASE)
(RETURN '--NOTED--)))
((lambda (/ / /)
(clear-output (setq / t))
(liblsp-autodf-call-update))
()()())

406
src/libdoc/bboole.pratt2 Executable file
View File

@@ -0,0 +1,406 @@
;;; THIS FILE CONTAINS FUNCTIONS WHICH IMPLEMENT LOGICAL OPERATIONS
;;; ON LISP INTEGERS AS IF THEY WERE SEMI-INFINITE BIT VECTORS IN
;;; TWO'S COMPLEMENT NOTATION. THAT IS, 0 IS THE BIT VECTOR OF NO
;;; BITS; AND -1 IS THE BIT VECTOR OF ALL 1'S.
;;; THE MAIN FUNCTIONS THAT HAVE BEEN TESTED ARE:
;;; 1) (LNOT A) -- LOGICAL COMPLEMENT OF BIT VECTOR A;
;;; 2) (LAND A B) -- LOGICAL AND OF BIT VECTORS A, B;
;;; 3) (LOR A B) -- LOGICAL OR OF BIT VECTORS A, B;
;;; 4) (LCOM A B) -- LOGICAL COMPLEMENT (A-B) OF A, B;
;;; 5) (LXOR A B) -- LOGICAL XOR (EXCLUSIVE OR) OF A, B;
;;; 6) (LEFTSHIFT A N) -- (FLOOR (TIMES A (EXPT 2 N)));
;;; 7) (PINTERSECTP A B) -- (NOT (ZEROP (LAND A B))) A,B GE 0;
;;; 8) (LELEMENT N A) -- (NOT (ZEROP (LAND A (EXPT 2 N))));
;;; 9) (LREDUCE A L) -- SELECT THOSE ITEMS FROM LIST L WHOSE
;;; CORRESPONDING BIT IN A IS ON. SORT OF
;;; LIKE MAPPING LELEMENT DOWN L. LREDUCE
;;; USES CONS, NOT RPLACD.
;;;
;;; THESE FUNCTIONS ARE ALL "SUBR"S; USE THE "REDUCE" FUNCTION
;;; A LA APL TO HANDLE ARBITRARY NUMBERS OF ARGUMENTS.
;;; MAKE MACROS AVAILABLE AT RUN TIME;
;;; DON'T COMPLAIN ABOUT OPEN CODED ARITHMETIC.
(DECLARE (MACROS T) (MUZZLED T))
(DEFUN BBOOLE NIL (PRINT '(BBOOLE PACKAGE LOADED)))
(DEFUN LET MACRO (FORM)
(CONS (CONS 'LAMBDA (CONS (CADR FORM) (CDDDR FORM)))
(CADDR FORM)))
(DEFUN REDUCE (FN L)
;;; REDUCE THE LIST "L" USING THE BINARY FUNCTION "FN" A LA APL.
(COND ((NULL L) (AND (ATOM FN) (GET FN 'IDENTITY)))
((ATOM L) L)
((NULL (CDR L)) (CAR L))
((FUNCALL FN (CAR L) (REDUCE FN (CDR L))))))
(DEFPROP LAND -1 IDENTITY)
(DEFPROP LOR 0 IDENTITY)
(DEFPROP LXOR 0 IDENTITY)
(DEFPROP LCOM 0 IDENTITY)
(DEFUN & MACRO (A)
;;; "AND" FOR FIXNUMS
(APPEND '(BOOLE 1.) (CDR A)))
(DEFUN V MACRO (A)
;;; "OR" FOR FIXNUMS
(APPEND '(BOOLE 7.) (CDR A)))
(DEFUN _ MACRO (A)
;;; "COMPLEMENT" FOR FIXNUMS
(APPEND '(BOOLE 4.) (CDR A)))
(DECLARE (FIXNUM M N Q R))
(DEFUN MOD (M N)
;;; IMPLEMENTS "MOD" FUNCTION ON PAGE 38 OF "FUNDAMENTAL ALGORITHMS"
;;; BY D. E. KNUTH.
;;; LISP'S "REMAINDER" GIVES THE WRONG ANSWER IN THE 1ST
;;; & 3RD QUADRANTS.
(COND ;;; FIRST CHECK FOR N=0.
((ZEROP N) M)
;;; GET LISP'S REMAINDER AND CORRECT, IF NECESSARY.
((LET (R)((REMAINDER M N))
(COND ;;; R=0 OK.
((ZEROP R) R)
;;; NOW WE HAVE M, N, R ALL NOT 0.
((PLUSP N)
(COND ((PLUSP M)
;;; (SIGN M) = (SIGN N), OK.
R)
(;;; M<0, N>0, R<0.
(PLUS R N))))
((PLUSP M)
;;; M>0, N<0, R>0.
(PLUS R N))
(;;; M<0, N<0, R<0, (SIGN M) = (SIGN N), OK.
R))))))
(DEFUN QUOT (M N)
;;; (QUOT M N) = (FLOOR (QUOTIENT (FLOAT M) (FLOAT N)))
(COND ((MINUSP M)
(COND ((MINUSP N) (QUOTIENT M N))
((QUOTIENT (DIFFERENCE M N -1) N))))
((MINUSP N) (QUOTIENT (DIFFERENCE M N 1) N))
((QUOTIENT M N))))
'(DEFUN QUOT (M N)
;;; THIS FUNCTION FIXES LISP'S "QUOTIENT" IN THE 1ST AND
;;; 3RD QUADRANTS.
(LET (Q R)
((QUOTIENT M N) (REMAINDER M N))
(COND ((ZEROP R) Q)
((PLUSP M) (COND ((PLUSP N) Q)
((SUB1 Q))))
((PLUSP N) (SUB1 Q))
(Q))))
(DECLARE (NOTYPE M N Q R))
'(DEFUN QUOT MACRO (L)
;;; LISP'S QUOTIENT GIVES THE WRONG ANSWER IN THE 1ST
;;; AND 3RD QUADRANTS.
(SUBLIS (LIST (CONS 'X (CADR L)) (CONS 'Y (CADDR L)))
'(FIX (QUOTIENT (FLOAT X) (FLOAT Y)))))
(DEFUN CHECKLIS (NL)
;;; DELETE ZEROS FROM END OF A LIST OF FIXNUMS.
(COND ((NULL (CDR NL)) T)
((CHECKLIS (CDR NL))
(COND ((EQUAL '(0.) (CDR NL))
(RPLACD NL NIL))))))
(VALRET '// :VP/ )
;;; GET SYMBOLS FROM DDT.
(LAP CONSBIGNUM SUBR)
(JRST 0 BNCONS)
NIL
;;; GIVEN A LIST OF POSITIVE FIXNUMS, WHOSE LAST ELEMENT IS NOT ZERO,
;;; CREATE A BIGNUM WHOSE BIG DIGITS ARE THE FIXNUMS IN REVERSE ORDER.
(DEFUN LNOT (N)
;;; THE LOGICAL "NOT" OF AN INTEGER N IS -N-1.
(DIFFERENCE -1 N))
(DEFUN LNOT MACRO (A)
;;; THE LOGICAL "NOT" OF AN INTEGER N IS -N-1.
(LIST 'DIFFERENCE -1 (CADR A)))
(DECLARE (FIXNUM L N))
(DEFUN BLSH (M N)
;;; BLSH(M N) = (FLOOR (TIMES M (EXPT 2. N)))
(COND ((MINUSP N) (BRSH M (MINUS N)))
((TIMES M (EXPT 2. N)))))
(DEFUN BRSH (M N)
;;; BRSH(M N) = (FLOOR (TIMES M (EXPT 2. (MINUS N))))
(COND ((MINUSP N) (BLSH M (MINUS N)))
((MINUSP M) (LNOT (BRSH (LNOT M) N)))
((QUOTIENT M (EXPT 2. N)))))
(DEFUN LEFTSHIFT (M N)
;;; LEFTSHIFT SEMI-INFINITE BIT VECTOR BY AMOUNT N.
(COND ((MINUSP N) (RIGHTSHIFT M (MINUS N)))
((TIMES M (EXPT 2. N)))))
(DEFUN RIGHTSHIFT (M N)
;;; RIGHTSHIFT SEMI-INFINITE BIT VECTOR BY AMOUNT N.
(COND ((MINUSP N) (LEFTSHIFT M (MINUS N)))
((MINUSP M) (LNOT (RIGHTSHIFT (LNOT M) N)))
((LET (L)((HAULONG M))
(COND ((< N L) (HAIPART M (- L N)))
(0.))))))
(DECLARE (NOTYPE L N))
(DEFUN SWR MACRO (A)
;;; "SWR" = SWITCH ROWS IN "BOOLE"-TYPE 2X2 MATRIX
;;; SWR(ABCD) = BADC.
(SUBST (CADR A)
'ABCD
'(V (LSH (& 5. ABCD) 1.) (LSH (& 10. ABCD) -1.))))
(DEFUN SWC MACRO (A)
;;; "SWC" = SWITCH COLUMNS IN "BOOLE"-TYPE 2X2 MATRIX
;;; SWC(ABCD) = CDAB.
(SUBST (CADR A)
'ABCD
'(V (LSH (& 3. ABCD) 2.) (LSH (& 12. ABCD) -2.))))
(DEFUN BBOOLEAN (C A B)
;;; COMPUTES GENERAL BOOLEAN FUNCTION OF TWO LISTS OF
;;; POSITIVE FIXNUMS, NOT NECESSARILY OF THE SAME LENGTH.
;;; RETURNS EITHER A LIST OF POSITIVE FIXNUMS, OR A SINGLE FIXNUM.
(PROG (AA BB)
(COND ((NULL (OR A B)) (RETURN 0.)))
(SETQ AA (OR A (LIST 0.)) BB (OR B (LIST 0.)))
(RETURN ((LAMBDA (W Z)
(COND ((ATOM Z)
(COND ((ZEROP Z) W) ((LIST W Z))))
((CONS W Z))))
(BOOLE C (CAR AA) (CAR BB))
(BBOOLEAN C (CDR AA) (CDR BB))))))
(DEFUN PBOOLEAN (C X Y)
;;; COMPUTES A BOOLEAN FUNCTION OF TWO NON-NEGATIVE
;;; INTEGER ARGUMENTS. THE FUNCTION APPLIED TO (0, 0) MUST
;;; RETURN 0.
(COND ((BIGP X)
(COND ((BIGP Y)
(CONSBIGNUMBER (BBOOLEAN C (CDR X) (CDR Y))))
((CONSBIGNUMBER (BBOOLEAN C (CDR X) (LIST Y))))))
((COND ((BIGP Y)
(CONSBIGNUMBER (BBOOLEAN C (LIST X) (CDR Y))))
((BOOLE C X Y))))))
(DEFUN BOOLEA (C A B)
;;; computes the general boolean function of two integer arguments.
(COND ((MINUSP A)
(COND ((MINUSP B)
(COND ((ZEROP (& 1. C))
(PBOOLEAN C (LNOT A) (LNOT B)))
((LNOT (PBOOLEAN (_ 15. C)
(LNOT A)
(LNOT B))))))
((COND ((ZEROP (& 4. C))
(PBOOLEAN (SWR C) (LNOT A) B))
((LNOT (PBOOLEAN (_ 15. (SWR C))
(LNOT A)
B)))))))
((COND ((MINUSP B)
(COND ((ZEROP (& 2. C))
(PBOOLEAN (SWC C) A (LNOT B)))
((LNOT (PBOOLEAN (_ 15. (SWC C))
A
(LNOT B))))))
((COND ((ZEROP (& 8. C)) (PBOOLEAN C A B))
((LNOT (PBOOLEAN (_ 15. C) A B)))))))))
(DEFUN BAND (X Y)
;;; COMPUTES THE BOOLEAN AND OF TWO LISTS OF
;;; POSITIVE FIXNUMS; POSSIBLY OF DIFFERING LENGTHS.
(COND ((NULL X) 0.)
((NULL Y) 0.)
((LET (W Z)
((& (CAR X) (CAR Y)) (BAND (CDR X) (CDR Y)))
(COND ((ATOM Z) (COND ((ZEROP Z) W) ((LIST W Z))))
((CONS W Z)))))))
(DEFUN BINTERSECTP (L1 L2)
;;; TESTS WHETHER THE TWO LISTS OF POSITIVE FIXNUMS HAVE
;;; ANY BITS IN COMMON.
(COND ((NULL L1) NIL)
((NULL L2) NIL)
((OR (NOT (ZEROP (& (CAR L1) (CAR L2))))
(BINTERSECTP (CDR L1) (CDR L2))))))
(DEFUN BOR (X Y)
(COND ((NULL X) Y)
((NULL Y) X)
((CONS (V (CAR X) (CAR Y)) (BOR (CDR X) (CDR Y))))))
(DEFUN BLCOM (X Y)
(COND ((NULL X) 0.)
((NULL Y) X)
((LET (W Z)
((_ (CAR X) (CAR Y)) (BLCOM (CDR X) (CDR Y)))
(COND ((ATOM Z) (COND ((ZEROP Z) W) ((LIST W Z))))
((CONS W Z)))))))
(DEFUN BXOR (A B)
;;; COMPUTES THE LOGICAL XOR OF TWO LISTS OF POSITIVE FIXNUMS
(COND (A (COND (B (LET (W Z)
((BOOLE 6. (CAR A) (CAR B))
(BXOR (CDR A) (CDR B)))
(COND ((ATOM Z)
(COND ((ZEROP Z) W)
((LIST W Z))))
((CONS W Z)))))
(A)))
((OR B 0.))))
(DEFUN PLAND (X Y)
;;; COMPUTES THE LOGICAL AND OF TWO POSITIVE INTEGERS
(COND ((BIGP X)
(COND ((BIGP Y) (CONSBIGNUMBER (BAND (CDR X) (CDR Y))))
((& (CADR X) Y))))
((COND ((BIGP Y) (& X (CADR Y))) ((& X Y))))))
(DEFUN PINTERSECTP (X Y)
;;; COMPUTES WHETHER TWO POSITIVE INTEGERS HAVE ANY BITS IN COMMON.
(COND ((BIGP X)
(COND ((BIGP Y) (BINTERSECTP (CDR X) (CDR Y)))
((NOT (ZEROP (& (CADR X) Y))))))
((COND ((BIGP Y) (NOT (ZEROP (& X (CADR Y)))))
((NOT (ZEROP (& X Y))))))))
(DEFUN PLOR (X Y)
;;; COMPUTES THE LOGICAL OR OF TWO POSITIVE INTEGERS
(COND ((BIGP X)
(COND ((BIGP Y) (CONSBIGNUM (BOR (CDR X) (CDR Y))))
((CONSBIGNUM (CONS (V (CADR X) Y) (CDDR X))))))
((COND ((BIGP Y)
(CONSBIGNUM (CONS (V X (CADR Y)) (CDDR Y))))
((V X Y))))))
(DEFUN PLCOM (X Y)
;;; COMPUTES THE LOGICAL COMPLEMENT OF TWO POSITIVE INTEGERS
(COND ((BIGP X)
(COND ((BIGP Y) (CONSBIGNUMBER (BLCOM (CDR X) (CDR Y))))
((CONSBIGNUM (CONS (_ (CADR X) Y) (CDDR X))))))
((COND ((BIGP Y) (_ X (CADR Y))) ((_ X Y))))))
(DEFUN PLXOR (X Y)
;;; COMPUTES THE LOGICAL XOR OF TWO POSITIVE INTEGERS
(COND ((BIGP X)
(COND ((BIGP Y) (CONSBIGNUMBER (BXOR (CDR X) (CDR Y))))
((CONSBIGNUM (CONS (BOOLE 6. (CADR X) Y)
(CDDR X))))))
((COND ((BIGP Y)
(CONSBIGNUM (CONS (BOOLE 6. X (CADR Y))
(CDDR Y))))
((BOOLE 6. X Y))))))
(DEFUN CONSBIGNUMBER (X)
(COND ((ATOM X) X) ((NULL (CDR X)) (CAR X)) ((CONSBIGNUM X))))
(DEFUN LAND (A B)
;;; DOES LOGICAL AND OF TWO INTEGERS, POSITIVE OR NEGATIVE
(COND ((EQ A B) A)
((MINUSP A)
(COND ((MINUSP B) (LNOT (PLOR (LNOT A) (LNOT B))))
((PLCOM B (LNOT A)))))
((COND ((MINUSP B) (PLCOM A (LNOT B))) ((PLAND A B))))))
(DEFUN LOR (A B)
;;; DOES LOGICAL OR OF TWO INTEGERS, POSITIVE OR NEGATIVE
(COND ((EQ A B) A)
((MINUSP A)
(COND ((MINUSP B) (LNOT (PLAND (LNOT A) (LNOT B))))
((LNOT (PLCOM (LNOT A) B)))))
((COND ((MINUSP B) (LNOT (PLCOM (LNOT B) A)))
((PLOR A B))))))
(DEFUN LCOM (A B)
;;; DOES LOGICAL COMPLEMENT OF TWO INTEGERS, POSITIVE OR NEGATIVE
(COND ((EQ A B) 0.)
((MINUSP A)
(COND ((MINUSP B) (PLCOM (LNOT B) (LNOT A)))
((LNOT (PLOR (LNOT A) B)))))
((COND ((MINUSP B) (PLAND A (LNOT B))) ((PLCOM A B))))))
(DEFUN LXOR (A B)
(COND ((EQ A B) A)
((MINUSP A)
(COND ((MINUSP B) (PLXOR (LNOT A) (LNOT B)))
((LNOT (PLXOR (LNOT A) B)))))
((COND ((MINUSP B) (LNOT (PLXOR A (LNOT B))))
((PLXOR A B))))))
(DEFUN LREDUCE (N L)
;;; LOGICALLY REDUCE A LIST VIA A BIT VECTOR A LA APL.
(COND ((ZEROP N) NIL)
((= N -1) L)
((PLUSP N) (PREDUCE N L))
((NPREDUCE N L))))
(DEFUN PREDUCE (N L)
;;; LOGICALLY REDUCE A LIST VIA A POSITIVE BIT VECTOR.
(COND ((BIGP N) (BREDUCE (CDR N) L))
((FREDUCE N L))))
(DECLARE (SPECIAL LN) (FIXNUM C N))
(DEFUN BREDUCE (LN L)
;;; LOGICALLY REDUCE A LIST VIA A LIST OF POSITIVE FIXNUMS.
(COND ((NULL LN) NIL)
((NULL L) NIL)
((BFREDUCE 35. (CAR LN) L))))
(DEFUN BFREDUCE (C N L)
(COND ((NULL L) NIL)
((ZEROP C) (BREDUCE (CDR LN) L))
((ODDP N) (CONS (CAR L)
(BFREDUCE (1- C)
(LSH N -1)
(CDR L))))
((BFREDUCE (1- C) (LSH N -1) (CDR L)))))
(DEFUN FREDUCE (N L)
;;; LOGICALLY REDUCE A LIST VIA A POSITIVE FIXNUM BIT VECTOR.
(COND ((ZEROP N) NIL)
((ODDP N) (CONS (CAR L) (FREDUCE (LSH N -1) (CDR L))))
((FREDUCE (LSH N -1) (CDR L)))))
(DEFUN LELEMENT (N L)
;;; TEST IF THE N'TH BIT IS ON IN THE BIGNUM L.
(COND ((MINUSP N) (ERR 'N<0-LELEMENT))
;;; IF L NEG, SEE IF N MISSING IN L COMPLEMENT.
((MINUSP L) (NOT (LELEMENT N (LNOT L))))
;;; IF L A BIGNUM, RUN DOWN LIST OF FIXNUMS.
((BIGP L) (BELEMENT N (CDR L)))
;;; CHECK IF BIT ON IN SHIFTED FIXNUM.
((ODDP (LSH L (MINUS N))))))
(DEFUN BELEMENT (N L)
;;; TEST IF THE N'TH BIT IS ON IN THE LIST OF FIXNUMS L.
(COND ((NULL L) NIL)
;;; IF BIT IS IN CURRENT WORD, CHECK IT.
((< N 35.) (ODDP (LSH (CAR L) (MINUS N))))
;;; OTHERWISE, TRY NEXT WORD.
((BELEMENT (- N 35.) (CDR L)))))

110
src/libdoc/bench.gjc1 Executable file
View File

@@ -0,0 +1,110 @@
;;-*-LISP-*-
;;
;; Some code for generating BenchMark reports. I have run this
;; in Maclisp, Franz, NIL, and Lispmachine lisps.
;; This tries to provide reasonable timing information on each system,
;; in a form which can be use for indirect comparisons. No attempt
;; is made to normalize the numerical data, as this is best done
;; during a second analysis pass.
;; 2:21pm Friday, 2 October 1981 -George Carrette.
;; Summary of available timers:
;; LISPM: (TIME) with (TIME-DIFFERENCE T1 T2) gives 60'th of sec wallclock.
;; MACLISP: (RUNTIME) (STATUS GCTIME) give microseconds cpu time.
;; FRANZ: (PTIME) gives a list (RUNTIME GCTIME) in 60'th of sec cpu time.
;; NIL: (RUNTIME) gives cpu time in 100'th of sec.
;; (TIME) gives wallclock accurate to seconds.
;;
;; Notes: Page fault information is also important, as is wallclock time
;; on all systems.
;; N.B. This code must be in all lower case, as to be easily read in
;; multics maclisp and Franz.
(defprop bench 1 version)
#+(or pdp10 nil) (herald bench)
(declare (special bench-output-stream))
(defun benchmark-to-file (l filename)
#+lispm
(with-open-file (stream filename '(:out))
(benchmark-to-stream l stream))
#-lispm
(let ((stream))
(unwind-protect
(benchmark-to-stream l (setq stream #-franz (open filename 'out)
#+franz (outfile filename)))
(and stream (close stream)))))
(defun benchmark (l)
(benchmark-to-stream l
#+(or lispm nil)
terminal-io
#-(or lispm nil)
t))
(defun benchmark-to-stream (l bench-output-stream)
(let (#+(or maclisp lispm) (base 10.)
before accumulator)
(bench-print-header l)
(setq before (benchstate))
(setq accumulator (benchstate-difference before before))
(do ((l l (cdr l))
(j 0 (1+ j)))
((null l)
(bench-print "**total accumulated time for this benchmark**")
(benchstate-print accumulator)
(bench-print "**total time including printing**")
(benchstate-print (benchstate-difference (benchstate) before))
(bench-print "***end of test***"))
(bench-print `("expression number" ,j))
(bench-print (car l))
(let ((state (benchstate)))
(let ((result (eval (car l))))
(setq state (benchstate-difference (benchstate) state))
(benchstate-print state)
(setq accumulator (benchstate-accumulate accumulator state))
(bench-print result))))))
(defun benchstate ()
#+maclisp (list (runtime) (status gctime))
#+nil (list (runtime) (time))
#+franz (ptime)
#+lispm (time))
(defun benchstate-difference (x y)
#+maclisp (list (- (car x) (car y)) (- (cadr x) (cadr y)))
#+nil (list (- (car x) (car y)) (-$ (cadr x) (cadr y)))
#+franz (list (- (car x) (car y)) (- (cadr x) (cadr y)))
#+lispm (time-difference x y))
(defun benchstate-accumulate (x y)
#+maclisp (list (+ (car x) (car y)) (+ (cadr x) (cadr y)))
#+nil (list (+ (car x) (car y)) (+$ (cadr x) (cadr y)))
#+franz (list (+ (car x) (car y)) (+ (cadr x) (cadr y)))
#+lispm (+ x y))
(defun benchstate-print (x)
(bench-print
#+maclisp `(,(car x) "cpu runtime" ,(cadr x) "gctime" "in microseconds")
#+nil `(,(car x) "centiseconds cpu runtime" ,(cadr x) "seconds realtime.")
#+franz`(,(car x) "cpu runtime" ,(cadr x) "gctime" "in 60'ths of a second")
#+lispm `(,x "60'ths of a second realtime.")))
(defun bench-print (x)
(print x bench-output-stream)
#+franz
;; ah yes, winning franz.
(terpri bench-output-stream))
(defun bench-print-header (l)
(bench-print `("benchmark by run by"
#+(or maclisp nil) ,(status userid)
#+lispm ,user-id
#-(or maclisp nil lispm) "somebody"))
(bench-print #+(or maclisp nil) `(,(status dow) ,(status daytime)
,(status date))
#+lispm (time:print-current-date ())
#-(or maclisp nil lispm) "on some date")
(bench-print `("ready to benchmark" ,(length l) "expressions.")))

137
src/libdoc/binprt.12 Executable file
View File

@@ -0,0 +1,137 @@
;;; -*- Mode:Lisp; IBase:10.; -*- Package created by KMP, 1/15/80
;;;
;;; BINPRT: A package for doing octal output (PDP10 only)
;;;
;;; This package is designed primarily for use as an interactive
;;; debugging tool, though it may have other applications as well. It
;;; defines the following functions:
;;;
;;; (BINPRINT object &optional stream) -- Terpri, BINPRIN1, Space
;;; (BINPRIN1 object &optional stream) -- Like PRIN1, but integers (at
;;; toplevel or imbedded will appear as nnnnnn,,nnnnnn (for fixnums)
;;; +nnnnnn,,nnnnnn_nnnnnn,,nnnnnn_... or
;;; -nnnnnn,,nnnnnn_nnnnnn,,nnnnnn_...
;;; (for bignums). If the switch BINPRINTYPE (Default NIL) is non-NIL
;;; fixnums and bignums will show up as above but with wrappers of
;;; #<FIXNUM ...> or #<BIGNUM ...> around them as appropriate.
;;;
;;; It should be emphasized that the output from this program is far from
;;; lisp-readable due to the free use of ",," but output is still visually
;;; parsable and that makes it a valuable aid in debugging bit-intensive code.
;;;
;;; Sample usage:
;;;
;;; (SETQ PRIN1 'BINPRIN1) => BINPRIN1
;;; 3 => 000000,,000003
;;; -1 => 777777,,777777
;;; '(3 5) => (000000,,000003 000000,,000005)
;;; (SETQ BINPRINTYPE T) => T
;;; -1 => #<FIXNUM 777777,,777777>
#-PDP10 (ERROR "This package not written to work except on a PDP10.")
(DECLARE (*LEXPR BINPRIN\NUM BINPRINT BINPRIN1)
(SPECIAL BINPRINTYPE))
(COND ((NOT (BOUNDP 'BINPRINTYPE))
(SETQ BINPRINTYPE NIL)))
(DEFUN BINPRIN\NUM (N &OPTIONAL (WHERE TYO) (TYPEFLAG BINPRINTYPE))
(DECLARE (SPECIAL CAR CDR))
(LET ((CAR T) (CDR T) (BASE (COND ((= BASE 2.) 2.) (T 8.))))
(COND (TYPEFLAG
(PRINC "#<" WHERE)
(PRINC (TYPEP N) WHERE)
(PRINC " " WHERE)))
(COND ((AND (OR (FIXP N) (FLOATP N)) (NOT (BIGP N)))
(SETQ N (LSH N 0.))
(DO ((I 33. (- I 3.)))
((MINUSP I))
(COND ((= I 15.) (PRINC ",," WHERE)))
(PRINC (LSH (BOOLE 1. N (LSH 7. I)) (- I)) WHERE)))
((BIGP N)
(COND ((NULL (CAR N)) (PRINC "+" WHERE))
(T (PRINC "-" WHERE)))
(DO ((L (CDR N) (CDR L)))
((NULL L))
(BINPRIN\NUM (CAR L) WHERE NIL)
(COND ((CDR L) (PRINC "_" WHERE)))))
(T
(PRINC "#<BINPRIN1 failure>" WHERE)))
(IF TYPEFLAG (PRINC ">"))))
(DECLARE (SPECIAL BINPRIN1-/`/,-LEVEL))
(SETQ BINPRIN1-/`/,-LEVEL 0.)
(DEFUN BINPRINT (FROB &OPTIONAL (STREAM TYO))
(TERPRI STREAM)
(BINPRIN1 FROB STREAM)
(TYO #\SPACE STREAM))
(DEFUN BINPRIN1 (FROB &OPTIONAL (STREAM TYO))
(DECLARE (SPECIAL CAR CDR))
(LET ((CAR T) (CDR T))
(COND ((FIXP FROB)
(BINPRIN\NUM FROB STREAM))
((ATOM FROB)
(PRIN1 FROB STREAM))
((HUNKP FROB)
(PRINC "(" STREAM)
(DO ((I 1. (1+ I))
(END (1- (HUNKSIZE FROB))))
((> I END))
(BINPRIN1 (CXR I FROB) STREAM)
(PRINC " . " STREAM))
(PRINC (CXR 0. FROB) STREAM)
(PRINC " .)" STREAM))
((AND (EQ (CAR FROB) 'QUOTE)
(= (LENGTH FROB) 2.))
(PRINC "'" STREAM)
(BINPRIN1 (CADR FROB) STREAM))
((EQ (CAR FROB) '|`-expander/||)
(LET ((BINPRIN1-/`/,-LEVEL (1+ BINPRIN1-/`/,-LEVEL)))
(PRINC "`" STREAM)
(BINPRIN1 (CDR FROB) STREAM)))
((AND (EQ (CAR FROB) '|`,/||) (> BINPRIN1-/`/,-LEVEL 0.))
(LET ((BINPRIN1-/`/,-LEVEL (1- BINPRIN1-/`/,-LEVEL)))
(PRINC "," STREAM)
(BINPRIN1 (CDR FROB) STREAM)))
((AND (EQ (CAR FROB) '|`,@/||) (> BINPRIN1-/`/,-LEVEL 0.))
(LET ((BINPRIN1-/`/,-LEVEL (1- BINPRIN1-/`/,-LEVEL)))
(PRINC ",@" STREAM)
(BINPRIN1 (CDR FROB) STREAM)))
((AND (EQ (CAR FROB) '|`,./||) (> BINPRIN1-/`/,-LEVEL 0.))
(LET ((BINPRIN1-/`/,-LEVEL (1- BINPRIN1-/`/,-LEVEL)))
(PRINC ",." STREAM)
(BINPRIN1 (CDR FROB) STREAM)))
((AND (EQ (CAR FROB) '|`.,/||) (> BINPRIN1-/`/,-LEVEL 0.))
(LET ((BINPRIN1-/`/,-LEVEL (1- BINPRIN1-/`/,-LEVEL)))
(PRINC ".," STREAM)
(BINPRIN1 (CDR FROB) STREAM)))
((AND (EQ (CAR FROB) 'MACROEXPANDED)
(GET (CADR FROB) 'MACRO))
(BINPRIN1 (NTH 3. FROB) STREAM))
((BIN$MEM '|`,/|| FROB)
(BINPRIN1
(DO ((L FROB (CDR L))
(NL () (CONS (CAR L) NL)))
((EQ (CAR L) '|`,/||)
(NREVERSE (CONS (CONS '|`.,/|| (CDR L)) NL))))
STREAM))
(T
(PRINC "(" STREAM)
(BINPRIN1 (CAR FROB) STREAM)
(DO ((F (CDR FROB) (CDR F)))
((ATOM F)
(COND ((NULL F) (PRINC ")" STREAM))
(T (PRINC " . " STREAM)
(BINPRIN1 F STREAM)
(PRINC ")" STREAM))))
(PRINC " " STREAM)
(BINPRIN1 (CAR F) STREAM))))))
(DEFUN BIN$MEM (X Y)
(DO ((L Y (CDR L)))
((ATOM L) NIL)
(COND ((EQ (CAR L) X) (RETURN L)))))

39
src/libdoc/carcdr.kmp1 Executable file
View File

@@ -0,0 +1,39 @@
;;; -*-LISP-*-
;;; Purpose: to permit long names, like CADADADADDDR, to be easily
;;; macro-defined into appropriate sequences of CARs and CDRs.
;;; Use: (DEF-CARCDR CADADADADDDR CADADADDDDDR ... )
;;; where the names must have at least 5 A/D's.
;;; Produces a format internal to the compiler when being expanded
;;; for optimal compilation. For interpretation, produces a
;;; LAMBDA form with a composition of initial carcdr functions
;;; of up to 4 deep, which should be (already) defined primitively.
(DEFMACRO DEF-CARCDR L
`(PROGN 'COMPILE
,@(mapcar '(lambda (x) `(DEFPROP ,x C*R MACRO)) l)))
(DEFUN C*R (X)
(DECLARE (SPECIAL CARCDR)) ;Gets the complr's CARCDR variable
(LET (((NAME ARG1 . L) X))
(AND L (ERROR '|Extra args in call to C*R macro| X 'WRNG-NO-ARGS))
(AND (OR (< (LENGTH (SETQ L (EXPLODEC NAME))) 7)
(NOT (EQ (CAR L) 'C))
(NOT (EQ (CAR (SETQ L (NREVERSE (CDR L)))) 'R))
(DO L (SETQ L (NREVERSE (CDR L))) (CDR L) (NULL L)
(AND (NOT (MEMQ (CAR L) '(A D))) (RETURN 'T))))
(ERROR '|Invalid name for C*R macro| X 'WRNG-TYPE-ARG))
`(,(COND ((EQ COMPILER-STATE 'COMPILE) `(,carcdr ,@(nreverse l)))
(`(LAMBDA (X) ,(|c*r-expander/|| l 'X))))
,arg1)))
(DEFUN |c*r-expander/|| (L ARG)
(COND ((< (LENGTH L) 5) `(,(implode (nconc (list 'C) l '(R))) ,arg))
((LET* ((/3TAIL (NTHCDR 3 L)) (/4TAIL (CDR /3TAIL)))
(RPLACD /3TAIL () )
(|c*r-expander/|| L (|c*r-expander/|| /4TAIL ARG))))))

354
src/libdoc/char.gjc10 Executable file
View File

@@ -0,0 +1,354 @@
;;-*-LISP-*-
;; Practical character and string manipulation primitives for PDP-10 maclisp.
;; The readmacro #~ is set up for reading of characters.
;; This package has been tested for both robustness and speed,
;; it won't blow up on you, and is very fast. It does better than
;; certain famous and highly bumbed string packages for maclisp that
;; will remain nameless. -GJC
(HERALD CHAR)
;; Character primitives:
;; (TO-CHARACTER <any>) returns a character.
;; (CHARACTERP <any>) True if and only if a character.
;; (CHAR-CODE <char>) Returns ascii fixnum cooresponding to character.
;; (CODE-CHAR <fixnum) Returns character.
;; (CHAR-UPCASE <char>) Maps #~a to #~A etc.
;; (CHAR-DOWNCASE <char>) Maps #~A to #~a etc.
;; String primitives:
;; (TO-STRING <any>) Converts to string.
;; (STRINGP <any>) True if and only if a string.
;; (CHAR <string> <j>) Returns the <j>'th character in the string.
;; (RPLACHAR <string> <j> <char>) Replaces the <j>'th character. Caution side-effect!
;; (STRING-LENGTH <string>)
;; (STRING-SUBSEQ <string> &optional (<skip-j> 0) (<dim>))
;; (MAKE-STRING <n>) Returns a string with <n> null characters.
;; (STRING-APPEND s1 s2 ...) Returns the concatenated string.
;; (STRING-UPCASE <string>)
;; (STRING-DOWNCASE <string>)
;; (STRING-EQUAL <s1> <s2>)
;; (STRING-LESSP <s1> <s2>)
;; Notes: Characters may be compared with EQ, so it is reasonable to do
;; (IF (EQ C #~^C) (SEND-THE-MESSAGE)) or
;; (ASSOC C KEY-TABLE).
;; Strings should be compared with STRING-LESSP and STRING-EQUAL.
;; Generic equal will not work on strings in this implementation,
;; because strings are first SYMBOLS.
;; Characters will not print out using the #~A syntax, so that
;; they will not read back in as characters. Boo Hoo.
;; However, they will remain characterp in FASL files.
(eval-when (eval compile load)
(cond ((status feature complr)
(*EXPR TO-CHARACTER CHARACTERP CHAR-CODE CODE-CHAR CHAR-UPCASE
CHAR-DOWNCASE
TO-STRING STRINGP CHAR RPLACHAR STRING-LENGTH
STRING-EQUAL STRING-LESSP STRING-UPCASE STRING-DOWNCASE
STRING-TRIM STRING-LEFT-TRIM STRING-RIGHT-TRIM)
(*LEXPR STRING-SUBSEQ MAKE-STRING STRING-APPEND
STRING-SEARCH STRING-REPLACE)
(FIXNUM (STRING-SEARCH NIL NIL FIXNUM FIXNUM)
(STRING-LENGTH NIL))
(NOTYPE (CHAR NIL FIXNUM)
(RPLACHAR NIL FIXNUM NIL)
(STRING-SUBSEQ NIL FIXNUM FIXNUM)
(STRING-REPLACE NIL NIL FIXNUM FIXNUM FIXNUM))
(*LEXPR WRITE-CHAR READ-CHAR OUSTR))))
(DEFUN TO-CHARACTER (X)
(COND ((CHARACTERP X) X)
((STRINGP X) (CHAR X 0))
((FIXP X) (CODE-CHAR X))
((SYMBOLP X) (CODE-CHAR (GETCHARN X 1)))
('ELSE
(TO-CHARACTER (ERROR "can't go TO-CHARACTER" X 'WRNG-TYPE-ARG)))))
(DEFUN CHARACTERP (X)
(AND (SYMBOLP X) (GET X 'CHAR-CODE) T))
(DEFUN CHAR-ERROR (F X)
(FUNCALL F (ERROR (LIST "is not a character. --" F) X 'WRNG-TYPE-ARG)))
(DEFUN CHAR-CODE (C)
(OR (GET C 'CHAR-CODE)
(CHAR-ERROR #'CHAR-CODE C)))
(DEFVAR CODE-CHAR-ARRAY (*ARRAY NIL T #o200))
(DEFUN CODE-CHAR (J)
(IF (AND (< J #o200)
(NOT (< J 0)))
(ARRAYCALL T CODE-CHAR-ARRAY J)
(CODE-CHAR (ERROR "fixnum out of range to be a char-code" J
'WRNG-TYPE-ARG))))
(DEFUN CHAR-UPCASE (C)
(OR (GET C 'CHAR-UPCASE)
(CHAR-ERROR #'CHAR-UPCASE C)))
(DEFUN CHAR-DOWNCASE (C)
(OR (GET C 'CHAR-DOWNCASE)
(CHAR-ERROR #'CHAR-DOWNCASE C)))
;; Strings.
(DEFUN TO-STRING (X)
(COND ((STRINGP X)
X)
((CHARACTERP X)
(TO-STRING-SUB-MAKNAM (LIST (CHAR-CODE X))))
((SYMBOLP X)
(TO-STRING-SUB (PNPUT (APPEND (PNGET X 7.) NIL) NIL)))
((FIXP X)
(TO-STRING (CODE-CHAR X)))
('ELSE
(TO-STRING (ERROR "can't go to string." X 'WRNG-TYPE-ARG)))))
(DEFUN TO-STRING-SUB (S)
(SETPLIST S '(+INTERNAL-STRING-MARKER T))
(SET S S))
(DEFUN TO-STRING-SUB-MAKNAM (L)
(PROG1 (TO-STRING-SUB (MAKNAM L))
(RECLAIM L NIL)))
(DEFUN STRINGP (X)
(AND (SYMBOLP X) (GET X '+INTERNAL-STRING-MARKER) T))
(DEFUN CHAR (S J)
(CODE-CHAR (GETCHARN S (1+ J))))
(DEFUN RPLACHAR (S J C)
(LET ((L (NTHCDR (// J 5.) (PNGET S 7.)))
(K (- #.(- 36. 7.) (* 7. (\ J 5.)))))
(DECLARE (FIXNUM K))
(IF (NULL L)
(RPLACHAR (ERROR (LIST "string too small for index =" J)
S 'WRNG-TYPE-ARG) J C)
(LET ((ADDRESS (MAKNUM (CAR L)))
(VALUE (LOGIOR (BOOLE 4 (CAR L) (LSH #o177 K))
(LSH (CHAR-CODE C) K))))
(DECLARE (FIXNUM ADDRESS VALUE))
(IF (PUREP (CAR L))
;; error check now to avoid the rush!
(RPLACA L VALUE)
(DEPOSIT ADDRESS VALUE)))))
C)
(DEFUN STRING-REPLACE (S1 S2 &OPTIONAL
(INDEX1 0) (INDEX2 0)
(COUNT (MIN (- (STRING-LENGTH S1) INDEX1)
(- (STRING-LENGTH S2) INDEX2))))
(DO ((J 0 (1+ J)))
((= J COUNT) S1)
(RPLACHAR S1 (+ J INDEX1) (CHAR S2 (+ J INDEX2)))))
(DEFUN STRING-LENGTH (S)
(IF (STRINGP S)
(FLATC S)
(STRING-LENGTH (ERROR "is not a string." S 'WRNG-TYPE-ARG))))
(DEFUN STRING-SUBSEQ (S &OPTIONAL (IND 0) (DIM (- (STRING-LENGTH S) IND)))
(IF (AND (STRINGP S)
(NOT (< (STRING-LENGTH S) (+ DIM IND))))
(TO-STRING-SUB-MAKNAM (STRING-SUBSEQ-SUB S IND DIM))
(STRING-SUBSEQ (ERROR "not a string or string too short" S
'WRNG-TYPE-ARG)
IND
DIM)))
(DEFUN STRING-SUBSEQ-SUB (S IND DIM)
(DO ((L NIL (CONS (GETCHARN S (+ IND 1 J)) L))
(J 0 (1+ J)))
((= J DIM)
(NREVERSE L))))
(DEFUN MAKE-STRING (DIM &OPTIONAL (C #/@))
(SETQ C (TO-CHARACTER C))
(TO-STRING-SUB-MAKNAM (MAP #'(LAMBDA (V) (RPLACA V C))
(MAKE-LIST DIM))))
(DEFUN STRING-EXPLODEN-SUB (S) (EXPLODEN S))
(DEFUN STRING-APPEND N
(DO ((J N (1- J))
(L NIL))
((ZEROP J)
(TO-STRING-SUB-MAKNAM L))
(SETQ L (NCONC (STRING-EXPLODEN-SUB (ARG J)) L))))
(DEFUN STRING-EQUAL (S1 S2)
(SAMEPNAMEP S1 S2))
(DEFUN STRING-LESSP (S1 S2)
(ALPHALESSP S1 S2))
(DEFUN STRING-UPCASE (S)
(TO-STRING-SUB-MAKNAM
(MAP #'(LAMBDA (V)
(RPLACA V (CHAR-UPCASE (CODE-CHAR (CAR V)))))
(STRING-EXPLODEN-SUB S))))
(DEFUN STRING-DOWNCASE (S)
(TO-STRING-SUB-MAKNAM
(MAP #'(LAMBDA (V)
(RPLACA V (CHAR-DOWNCASE (CODE-CHAR (CAR V)))))
(STRING-EXPLODEN-SUB S))))
(DEFUN STRING-TRIM-SUB (CHAR-SET L)
(DO ()
((OR (NULL L) (NOT (MEMQ (CODE-CHAR (CAR L)) CHAR-SET))) L)
(SETQ L (CDR L))))
(DEFUN STRING-TRIM-MAKE-SUB (L) (TO-STRING-SUB (MAKNAM L)))
(DEFUN STRING-TRIM (CHAR-SET STRING)
(LET ((L (STRING-EXPLODEN-SUB STRING)))
(PROG1 (STRING-TRIM-MAKE-SUB
(NREVERSE (STRING-TRIM-SUB CHAR-SET
(NREVERSE (STRING-TRIM-SUB CHAR-SET
L)))))
(RECLAIM L NIL))))
(DEFUN STRING-LEFT-TRIM (CHAR-SET STRING)
(LET ((L (STRING-EXPLODEN-SUB STRING)))
(PROG1 (STRING-TRIM-MAKE-SUB (STRING-TRIM-SUB CHAR-SET L))
(RECLAIM L NIL))))
(DEFUN STRING-RIGHT-TRIM (CHAR-SET STRING)
(LET ((L (STRING-EXPLODEN-SUB STRING)))
(PROG1 (STRING-TRIM-MAKE-SUB (NREVERSE (STRING-TRIM-SUB CHAR-SET
(NREVERSE L))))
(RECLAIM L NIL))))
(DECLARE (FIXNUM (STRING-SEARCH-SUB NIL NIL FIXNUM)))
(DEFUN STRING-SEARCH (KEY STRING &OPTIONAL
(FROM 0)
(TO (STRING-LENGTH STRING)))
(IF (< (- TO FROM) (STRING-LENGTH KEY))
-1
(LET ((L1 (STRING-EXPLODEN-SUB KEY))
(L2 (STRING-EXPLODEN-SUB STRING)))
(PROG1 (LET ((N (STRING-SEARCH-SUB L1 (NTHCDR FROM L2) (- TO FROM))))
(IF (= N -1)
-1
(+ N FROM)))
(RECLAIM L1 NIL)
(RECLAIM L2 NIL)))))
(DEFUN STRING-SEARCH-SUB (SMALL LARGE DIM)
(DO ((LARGE LARGE (CDR LARGE))
(N 0 (1+ N)))
((= N DIM) -1)
(IF (DO ((SMALL SMALL (CDR SMALL))
(LARGE LARGE (CDR LARGE)))
((NULL SMALL) T)
(OR (= (CAR SMALL) (CAR LARGE))
(RETURN NIL)))
(RETURN N))))
;; Read syntax and initiatializations.
(DEFUN TILDE-READMACRO N
(SQUID-CHAR
(LET ((C (TYI)))
(COND ((= C #//)
(CODE-CHAR (TYI)))
((= C #/^)
(CODE-CHAR (LOGAND #o77
(CHAR-CODE (CHAR-UPCASE (CODE-CHAR (TYI)))))))
((= C #/\)
(LET ((S (READ)))
(OR (AND (SYMBOLP S) (GET S 'SYMBOLIC-CHARACTER))
(ERROR "undefined symbolic character" S))))
('ELSE
(CODE-CHAR C))))))
(SETSYNTAX-SHARP-MACRO '/~ 'MACRO 'TILDE-READMACRO)
(DECLARE (SPECIAL SQUID COMPILER-STATE))
(DEFUN SQUID-CHAR (C)
(IF (MEMQ COMPILER-STATE '(NIL TOPLEVEL))
C
`(,SQUID (TO-CHARACTER ',C))))
(COND ((NULL (ARRAYCALL T CODE-CHAR-ARRAY 0))
(DO ((J 0 (1+ J))
(C))
((= J #o200))
(SETQ C (MAKNAM (LIST J)))
(SET C C)
(STORE (ARRAYCALL T CODE-CHAR-ARRAY J) C))
(DO ((J 0 (1+ J))
(J-UP)(J-DOWN)(C))
((= J #o200))
(COND ((AND (NOT (< J #/A)) (NOT (> J #/Z)))
(SETQ J-UP J
J-DOWN (+ J #.(- #/a #/A))))
((AND (NOT (< J #/a)) (NOT (> J #/z)))
(SETQ J-UP (- J #.(- #/a #/A))
J-DOWN J))
(T
(SETQ J-UP J J-DOWN J)))
(SETQ C (ARRAYCALL T CODE-CHAR-ARRAY J))
(PUTPROP C
(ARRAYCALL T CODE-CHAR-ARRAY J-UP)
'CHAR-UPCASE)
(PUTPROP C
(ARRAYCALL T CODE-CHAR-ARRAY J-DOWN)
'CHAR-DOWNCASE)
(PUTPROP C J 'CHAR-CODE)
)))
(MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CODE-CHAR (CADR X)) 'SYMBOLIC-CHARACTER))
'((NULL 0.)
(ALPHA 2.)
(BETA 3.)
(EPSILON 6.)
(BELL 7.)
(BACKSPACE 8.)
(BS 8.)
(TAB 9.)
(LINEFEED 10.)
(LF 10.)
(VT 11.)
(FORM 12.)
(FORMFEED 12.)
(FF 12.)
(RETURN 13.)
(NEWLINE 13.)
(CR 13.)
(NL 13.)
(ALTMODE 27.)
(ALT 27.)
(BACK-NEXT 31.)
(SPACE 32.)
(SP 32.)
(DELETE 127.)
(RUBOUT 127.)))
;; I/O primitives.
(defvar standard-input nil)
(defvar standard-output nil)
(defun read-char (&optional (stream standard-input) (eof-char () eof-char-p))
(if eof-char-p
(let ((c (tyi stream -1)))
(if (= c -1) eof-char (code-char c)))
(code-char (tyi stream))))
(defun write-char (char &optional (stream standard-output))
(tyo (char-code char) stream))
(defun oustr (string &optional (stream standard-output))
(princ string stream))

41
src/libdoc/cpyhnk.rwk14 Executable file
View File

@@ -0,0 +1,41 @@
title COPY HUNKS QUICKLY (the quick brown hunk)
;The function COPY-HUNK takes a hunk as an argument, and returns an EQUAL
;hunk, using BLT to copy the elements of the hunk quickly.
.FASL
.insrt SYS:FASDFS
verprt CPYHNK
.sxeval (DEFPROP CPYHNK 14 VERSION)
.entry COPY-HUNK SUBR 002
retry: skott a,HNK ;Is it really a hunk?
jrst nothnk ; Not really a hunk, give an error
movei t,(tt) ;Flush left half (leaving HUNKn in rh)
subi t,.atom HUNK2 ;get log of size of hunk
movei tt,2
lsh tt,(t)
movei b,(a) ;Save past the cons
pushj p,alhunk ;CONS the right hunk
movei tt,(a) ;BLT to the new hunk
hrli tt,(b) ;from the old one
xct blttab(t) ;perform the right blt
retok: popj p, ;and return
nothnk: jumpe a,retok ;Equal time for ()
wta [NOT A HUNK -- COPY-HUNK!]
jrst retry ;If continued, A should have new value
blttab: blt tt,(a)
blt tt,1(a)
blt tt,3(a)
blt tt,7(a)
blt tt,17(a)
blt tt,37(a)
blt tt,77(a)
blt tt,177(a)
blt tt,377(a)
blt tt,777(a)
.lose ;Hunk 1024???
fasend

494
src/libdoc/debug*.rcw1 Executable file
View File

@@ -0,0 +1,494 @@
;-*- LISP -*-
(comment an improved version of DEBUG)
;this file written by Richard C. Waters Dec 1977. Send all comments to DICK@AI.
;DEBUG* is based on the function DEBUG. however, it fixes a few bugs that
;debug has, and adds a lot of new features.
;
;OLD BUGS FIXED.
;1. the function bt sometimes chokes and prints out everthing twice, this is
; because baklist has an analogous problem. debug* doesn't call
; baklist and therefore doesn't have this problem.
;2. debug's C command doesn't work if applied to an evalframe of the
; apply type. debug* does work in this case.
;3. debug isn't supposed to complain when you type a ^L but it does, debug* doesn't
;
;IMPROVEMENTS OF DEBUG* OVER DEBUG
;the major improvement in debug* is the way it looks at the stack, all of
; debug*'s commands operate with respect to an edited version of what is
; on the stack. this edited version is different from the actual stack
; in that:
; 1. every trace of the stepping package's actions are deleted (i.e. calls on
; evalhook and evalhook*).
; 2. duplicate stack entries caused by a macro expansion that displaced itself
; by doing a rplaca and rplacd are deleted.
; 3. when an R or C command is done a freturn starts an evaluation sequence which
; effectively skips over a part of the stack. if you enter debug again
; above such a point you see a lot of junk which is bypassed and does
; not have any effect on the current evaluation sequence. debug*
; deletes all this stuff so that from looking at the stack you can't
; tell whether or not Rs and Cs have been done above you.
; everything just looks normal. debug* does similar elisions for the V command
; (NOTE these elisions only work 100% when the uuos are snapped. (for instance not
; until the second time a feature is used after debug* is fasloaded) when the uuos
; are not snapped you see some extra evals and applies on the stack.)
; 4. further several of debug*'s commands look at a version of the stack which
; is further restricted in that it only contains calls on user functions
; (ie ones where (status system function-name) is nil)
;another improvement of debug* is that it knows about step (Chuck Rich's stepper)
; it allows you to:
; 1. enter debug* while stepping without the stepping intruding on anything
; you do in debug*. debug* sets evalhook* to nil when it is entered and
; restores it before it exits via Q R or C.
; 2. when you leave debug* stepping is smoothly resumed. (except for pathological cases)
; 3. a command S is provided for changing the stepping mode from inside debug,
; so that you can decide what type of stepping you want after you exit
; debug. (see the documentation for step for what kinds of things you
; can do)
; 4. as mentioned above you don't see the garbage the stepper leaves on the
; stack.
;debug* takes an argument which tells it where to set the top of the stack.
; the top of the stack is taken as the first frame below the frame
; corresponding to the function name given as the argument to debug*.
; this is useful because debug* automatically prints out the top of the
; stack when it is entered and the argument helps you avoid seeing
; irrelavent stuff. (you can see parts of the stack above the chosen top
; point by simply moving up to them with [ or {)). as an example of how
; this is usefull see the function *start*debug*
;debug* prints a lot less terpris. As a result you get to see a lot more on the screen
; basically twice as much.
;there are a lot of additional commands (see below)
;
;COMPLETE COMPATABILITY WITH DEBUG
;there are a lot of new features, and the typeout looks a bit different, but DEBUG*
;responds to all of the same commands as DEBUG, and this file contains a redefinition
;of DEBUG which calls DEBUG*. this can be used to do all the things DEBUG does. (including
;setting *rset). debug* encourages a change from using the commands U and D to [ and ] but
;doesn't force you to change.
;BASIC USE OF DEBUG*
;
;HOW TO LOAD DEBUG* IN
; a. do a (fasload debug* fasl dsk liblsp)
;
;HOW TO START DEBUG* UP
; a. you can use the redefinition of debug in this file to start up
; debug* just the way you start up debug (i.e. by doing (debug))
; b. you can do a (debug* nil) if you don't care where debug* calls the
; top point on the stack
; c. you can do a (debug* topfn) in which case debug will choose as top
; point the highest point on the stack where the stack frame is an
; evaluation of the function TOPFN. note that where the top point is
; put does not alter what parts of the stack are excessable for you
; to look at, but rather only sets the initial position on the stack,
; and the place the T command goes to. the option of specifying the
; top point exists so that you can have debug* start up showing you a convenient
; place on the stack.
; d. you can use (sstatus ttyint # '*start*debug*) in order to put the
; function *start*debug* on a control character. (this does not
; automatically happen when debug* is loaded in) if you do, then
; typing the control character (for example ^D) will start up debug*
;
;HOW TO INTERACT WITH DEBUG*
; a. debug* runs as a read eval print loop where the commands it reads
; are all one character. they can all be proceeded by an optional
; positive integer argument (though all but [, ], {, and } ignore
; it). some of the comands do input themselves. most commands cause
; some object to be printed out. if you type a character which is
; not a command, debug* goes into a mode where it ignores all input
; until a cr is typed. it then returns to reading commands.
;
;BRIEF DESCRIPTION OF COMMANDS (SEE BELOW FOR MORE DETAIL);
; a. EXAMINING THE STACK the commands -, =, and @ show you the entries
; on the stack in various amounts of detail. the commands [, ], {,
; }, and T move up and down the stack showing you the stack frame they
; go to.
; b. PRINTOUT cr redisplays the current stack frame. P prints the current
; thing without abbreviation. (the user prin1 is used if supplied as
; the value of DEBUG*PRIN1 or of PRIN1)
; c. EVALUATING things in the environment of the current stack frame. E
; reads in and evaluates a single expression and displays the result.
; B and V enter read-eval-print loops in the current environment.
; d. EXITING debug*. Q, R, and C all return to the computation in
; process. a ^G can be used to go to toplevel. in addition you can
; eval (with E) a GO or THROW if the situation is appropriate.
; e. EFFECTING THE STEPPER the S command reads in an expression and
; assigns it to evalhook*.
; f. HELP the ? command types out a summary of the commands
;COMMANDS TO DEBUG*
;[ - moves up (more recent in time) one stackframe and displays the new frame (U works too)
;] - moves down (further back in time) one stackframe and displays the new frame (D works too)
;{ - moves up to the next user function frame
;} - moves down to the next user function frame
;the four commands []{} take an optional numeric prefix arg n which
; causes them to operate n times
;cr - displays the current stack frame
;T - moves to the top stack frame. which stack frame is the top one is based on
; the value of the argument to debug*
;- - displays the functions on the stack from top to bottom. "[]" is printed
; around the function corresponding to the current stack frame.
;= - displays the user functions on the stack. "[]" is printed as in "-".
;@ - is like = except that between the first user function frame at or above
; where you are and the first user function frame below where you are it displays
; all of the functions.
;E - reads in an sexpr and evaluates it in the environment of the current
; stackframe. in addition, in this environment the variable *debug*
; is bound to the result of evalframe which corresponds to the current
; stack frame. it then displays the result. E does an errset in order to
; prevent errors from generating a break while it evaluates the sexpr.
;P - redisplays the last thing displayed with prinlevel and prinlength set to
; nil. all other printout is done with prinlevel 4 and prinlength 3. all
; printout is done by calling the value of the atom prin1 if it is not nil.
; Additionally P will use the value of DEBUG*PRIN1 if non-nil.
;S - reads in an sexpr which it sets as the value of evalhook*. this allows
; you to alter the state of stepping from in debug. (the value of evalhook* is
; not emediatly changed, rather things are set up so that it will change when
; debug is exited through Q R or C. while in debug stepping is inhibited by
; setting evalhook* to nil.)
; (note that you can't start up stepping just by changing evalhook* if
; stepping is completely disabled (ie evalhook is nil) in the environment you
; return into. if this is the case, you must do an E(setq evalhook 'evalhook*)
; in the same environment before returning to it. (note that it will not help
; to do this from inside a B or V because they both bind evalhook.) Further, if
; stepping is started up this way, it will not work 100%. it will not know what
; level it is at; already invoked forms will not print out their values, and the
; scope of stepping may be strange.)
;B - starts up a break loop in the environment of the current stack frame. in
; addition, in this environment the variable *debug* is bound to the
; result of evalframe which corresponds to the current stack frame.
; returning from the break reenters debug*
;V - creates a mini top level in the environment of the current stack frame with *debug*
; set as above. this mini top level operates basically like a break loop.
; you can exit from it by typing a $p to it at top level. this causes you
; to reenter debug*. the variables + - * are appropriately bound.
; the key difference is that the mini top level DOES NOT DO AN ERRSET.
; as a result, you can investigate any error which occures. at any time you can
; pop back up to the mini top level by doing a (*throw '*debug* nil).
; the mini top level is useful for setting up a checkpoint on the
; stack which you can repeatedly back up to while debugging a program.
;Q - causes debug* to exit returning '||.
;R - forces the current stack frame to return. before doing anything, R asks
; you to type a T to confirm that you really want to force a return. it
; then reads an sexpr which is evaluated in the evironment of the current stack
; frame and then returned as the result of the current stack frame. *debug* is
; not bound in the evaluation environment. if stepping is enabled then the
; evaluation of the sexpr will be stepped.
;C - the C command is just like the R command except the sexpr evaluated is the
; one which corresponds to the current stack frame. it allows you to
; continue execution starting with a reevaluation of that expression.
;? - prints out a short form of this page.
;^L, space - are ignored. (note that if you have tyi open in twelve bit mode, you must
; use the FORM key in order to actually type a ^L if you use the control key you
; will get L or l with some high order bits. (to fix this debug* ignores L too))
;other - any other character causes '| invalid character, type cr to continue |to be printed
; and debug* goes into a mode where all input is refused until a cr is typed. this
; is done to protect you from doing something strange if you don't realize you
; are typing to debug*.
(declare (special *debug* tyo tyi terpri prinlevel prinlength evalhook*
*debug*? debug*prin1)
(fixnum code n i j))
(herald debug*)
;the system function which forms the bases for this program is EVALFRAME.
;evalframe lets you look at what is on the stack, but only if *RSET is non
;nil. each call on evalframe returns either NIL if it doesn't find anything,
;or a 4 tuple (EVALTYPE STACKPTR EXP ENV). the argumant to evalframe is a
;stack pointer which is either nil, or one of the numbers returned as the
;second entry in the tuple returned by evalframe. each tuple corresponds to
;a function invocation. the EXP is the expression evaluated. STACKPTR is a
;number which if passed to evalframe will get you the invocation below this
;one. ENV is the environment the EXP was invoked in. EVALTYPE is either
;'EVAL or 'APPLY and says whether EXP was invoked by (EVAL EXP) or
;(APPLY (CAR EXP) (CADR EXP)).
; DEBUG* calls evalframe repeatedly and builds up a two-way linked list
;of the 4 tuples (with some of them elliminated as discussed above). all of
;the work done by the rest of debug* is with respect to this intermediate data
;structure. this makes it easy to do the elision for all commands, and avoids
;calling evalframe again and again. each entry in the intermediate structure
;is of the form (FRAME UP DOWN . USERFN). where FRAME is a result of
;evalframe, UP points to the next higher stack frame, DOWN points to the next
;lower, and USEFN is a flag which says whether of not the function
;correspanding to this frame is a user function or not. (ie. whether or not
;(STATUS SYSTEM ...) is NIL.)
;the following are just macro definitions used to make debug* more readable.
(eval-when (eval compile)
(defmacro evaltypepart (e) `(car ,e))
(defmacro evaltype (p) `(evaltypepart (car ,p)))
(defmacro stackptrpart (e) `(cadr ,e))
(defmacro stackptr (p) `(stackptrpart (car ,p)))
(defmacro exppart (e) `(caddr ,e))
(defmacro exp (p) `(exppart (car ,p)))
(defmacro envpart (e) `(cadddr ,e))
(defmacro env (p) `(envpart (car ,p)))
(defmacro frame (p) `(car ,p))
(defmacro up (p) `(cadr ,p))
(defmacro down (p) `(caddr ,p))
(defmacro userfn (p) `(cdddr ,p)))
(or (boundp 'evalhook*) (setq evalhook* nil))
(or (boundp 'debug*prin1) (setq debug*prin1 nil))
;this function is intended to be put on an interupt character such as ^D
; (i.e. (sstatus ttyint 4. '*start*debug*)) in order to make starting up
;debug* easier.
(defun *start*debug* (ignore ignore-ch)
(nointerrupt nil)
(tyi tyi)
(debug* '+internal-ttyscan-subr))
;this is used by debug* to do freturns in order to have an identifiable mark
;on the stack to know what parts of the stack to skip when displaying it.
(defun *debug*freturn* (ptr evaltype exp old-evalhook*)
(setq evalhook* old-evalhook*)
(cond ((eq evaltype 'eval) (freturn ptr (eval exp)))
(T (freturn ptr (apply (car exp) (cadr exp))))))
;this is the mini top level. it doesn't use its argument ptr but
;debug* does use it when it is deciding how to skip over pieces of the
;stack.
(defun *debug*top-level (ignore)
(let (exit evalhook ^w ^q (* *) (+ +) (- -))
(terpri)
(princ '|*debug*top-level|)
(prog ()
L (*catch '*debug*
(prog (exp)
(setq * '*)
L (terpri)
(cond (prin1 (funcall prin1 *)) (T (prin1 *)))
(terpri)
(setq exp (read))
(cond ((eq exp /p) (clear-input tyi)
(setq exit T) (return nil)))
(setq + - - exp * (eval exp))
(go L)))
(cond ((not exit)
(terpri)
(princ '|quit; reentering *debug*top-level|)
(go L))))))
;the basic logic of debug* is as follows: when entered debug* tries
;to fix everything up so that things will work ok i.e. ^w ^q evalhook
;evalhook* and nointerrupt are set to nil. further tyi is cleared.
;next debug* constructs an elided version of the stack. and decides
;what the top point is based on its argument. (this takes a bit of
;time, but it saves a lot of time in the long run). if *rset was not T
;then debug* just does a break since there is no stack to look at.
;otherwise debug* goes into a mode where it reads characters from tyi
;and interprets them as commands (see commands comment above). it
;continues reading and dispatching until a command which causes an
;exit is encountered.
(defun debug* (topfn)
(let ((ef (evalframe nil))
(old-evalhook* evalhook*) evalhook ^w ^q)
(setq evalhook* nil) (nointerrupt nil) (clear-input tyi)
(if (not (zerop (charpos tyo))) (terpri))
(prog (top bot topend ptr code item n)
;make internal copy of stack, with appropriate elisions.
(prog (ex oldex uf i n)
(setq i 1 n 100)
L (setq i (1+ i))
(cond ((> i n)
(princ '|More than |) (princ n) (princ '| stack frames. |)
(cond ((Y-or-N-p "Do you want them all viewable")
(terpri)
(setq n (* 2 n)))
(T (terpri) (return nil)))))
(setq ex (exppart ef))
(cond ((null ef) (return nil))
((and (not (atom ex))
(or (memq (car ex) '(evalhook evalhook*))
(and (not (atom oldex))
(eq (cdr ex) (cdr oldex))
(eq (car ex) (car oldex)))))
(setq ef (evalframe (cadr ef))))
((and (not (atom ex)) (eq (car ex) '*debug*freturn*))
(setq ef (evalframe (caadr ex))))
(T (setq uf (and (not (atom ex))
(eq (typep (car ex)) 'symbol)
(not (status system (car ex))))
bot (list* ef bot nil uf))
(cond ((up bot) (setf (caddr (up bot)) bot))
(T (setq topend bot)))
(cond ((and (not top) (or (eq ex topfn)
(and (not (atom ex))
(eq (car ex) topfn))))
(setq top bot)))
(setq oldex ex)
(cond ((and (not (atom ex)) (eq (car ex) '*debug*top-level))
(setq ef (evalframe (cadr ex))))
(T (setq ef (evalframe (cadr ef)))))))
(go L))
(setq top (or (down top) top (down topend) topend))
;if no stack (i.e. *rset nil) just do a break
(cond ((null bot) (princ '|No evalframes try setting *rset to T. |)
(break debug*) (return '||)))
;get set for the main operation loop
(setq ptr top item (exp top))
;print out the current thing
print
(let ((prinlevel 4) (prinlength 3))
(errset (cond (prin1 (funcall prin1 item)) (T (prin1 item)))))
(tyo #\space)
;read in a command with optional number prefix.
read
(prog (i temp)
L (setq i (boole 1 127. (tyi tyi)))
(cond ((and (< 47. i) (< i 58.)) (push i temp) (go L)))
(setq code i)
(setq n (cond (temp (readlist (nreverse temp))) (T 1))))
;dispatch on the command character to see what to do (see comments above)
process
(caseq code
((#/] #/D #/d)
(cond ((eq ptr bot) (princ '| at bottom |) (go read))
(T (prog ()
L (setq n (1- n) ptr (down ptr))
(cond ((null ptr) (setq ptr bot))
((plusp n) (go L))))))
(setq item (exp ptr)))
(#\cr (setq item (exp ptr)) (go print))
((#/[#/U #/u)
(cond ((eq ptr topend) (princ '| at top |) (go read))
(T (prog ()
L (setq n (1- n) ptr (up ptr))
(cond ((null ptr) (setq ptr topend))
((plusp n) (go L))))))
(setq item (exp ptr)))
(#/} (cond ((eq ptr bot) (princ '| at bottom |) (go read))
(T (prog ()
L (setq ptr (down ptr))
(cond ((userfn ptr) (setq n (1- n))))
(cond ((null ptr) (setq ptr bot))
((plusp n) (go L))))))
(setq item (exp ptr)))
(#/{ (cond ((eq ptr topend) (princ '| at top |) (go read))
(T (prog ()
L (setq ptr (up ptr))
(cond ((userfn ptr) (setq n (1- n))))
(cond ((null ptr) (setq ptr topend))
((plusp n) (go L))))))
(setq item (exp ptr)))
((#/T #/t) (setq item (exp (setq ptr top))))
((#/- #/= #/@ #/+)
(let ((prinlevel 1) (prinlength 1) (terpri nil) showlocal
(firstufbefore (and (member code '(#/@ #/+))
(prog (p)
(setq p ptr)
L (setq p (up p))
(cond ((null p) (return topend))
((userfn p) (return p)))
(go L)))))
(terpri)
(prog (p)
(setq p topend)
L (setq showlocal (or (and showlocal (not (userfn p)))
(eq p firstufbefore)))
(cond ((eq p ptr) (princ '/[)))
(cond ((or showlocal (userfn p) (= code #/-))
(errset (prin1 (cond ((atom (exp p)) (exp p))
(T (car (exp p))))))
(cond ((eq p ptr) (princ '/]))) (tyo #\space))
((eq p ptr) (princ '|] |)))
(cond ((not (eq p bot)) (setq p (down p)) (go L)))))
(go read))
((#/R #/r #/C #/c)
(let ((fr (evalframe (stackptr ptr))) exp evalt)
(cond ((eq (car (exppart fr)) 'evalhook)
(setq fr (evalframe (stackptrpart fr)))))
(cond ((not (eq (car (exppart fr)) 'evalhook*))
(setq fr (frame ptr))))
(setq exp (exppart fr) evalt (evaltypepart fr))
(cond ((member code '(#/R #/r))
(princ '| return form: |)
(setq exp (read tyi) evalt 'eval)
(clear-input tyi)
(cond ((not (eq fr (frame ptr)))
(setq exp (list 'evalhook* (ncons exp))
evalt 'apply)))))
(cond ((not (Y-or-N-p "confirm:"))
(terpri)
(setq code #\cr)
(go process)))
(apply '*debug*freturn*
(list (stackptrpart fr) evalt exp old-evalhook*)
(envpart fr))))
((#/S #/s) (setq old-evalhook* (read tyi)) (clear-input tyi))
((#/E #/e)
(setq item (car (errset (eval `((lambda (*debug*)
,(prog1 (read tyi)
(clear-input tyi)))
',(frame ptr))
(env ptr))
t))))
((#/B #/b)
(eval `((lambda (*debug*) (break debug* t))
',(frame ptr)) (env ptr))
(setq item (exp ptr))
(go print))
((#/V #/v)
(eval `((lambda (*debug*) (*debug*top-level ,(stackptr ptr)))
',(frame ptr)) (env ptr))
(setq item (exp ptr)))
((#/Q #/q)
(princ '| end debug |)
(setq evalhook* old-evalhook*)
(return '||))
((#/P #/p)
(let (prinlevel prinlength)
(terpri)
(errset (funcall (or debug*prin1 prin1 'prin1) item))
(tyo #\space))
(go read))
(#/? (mapc #'(lambda (x) (terpri) (princ x)) *debug*?) (go read))
((#/L #/l #\ff #\space) (go read)) ;works in 12bit read in mode too
(T (Y-or-N-p " invalid character, continue")
(terpri)
(setq code #\cr)
(go process)))
(terpri)
(go print))))
;this just holds the message printed out by ?. If you don't want to
;loose the space setq *debug*? to nil
(setq *debug*?
'(|] move down one stack frame|
|[ move up one stack frame|
|} move down to next user function stack frame|
|{ move up to next user function stack frame|
|cr show current stack frame|
|T go to top stack frame|
|- show stack|
|= show user functions on stack|
|@ (or +) show user functions on stack, and all functions near current position|
|E read and evaluate an expression in the current environment|
|P print last thing in full|
|S set evalhook*|
|B start up a break point in the current environment|
|V start up a mini top level in the current environment|
|Q quit debug*|
|R read in evaluate and freturn an expression in the current environment|
|C continue execution starting from the current stack frame expression |))
;______________________________________________________________________________
;this is a redefinition of debug which calls debug* this gives you the
;new features without having to rewrite anything.
(defun debug nargs
(cond ((= nargs 0) (debug* nil))
(T (*rset (nouuo (arg 1))))))

67
src/libdoc/defsta.gjc1 Executable file
View File

@@ -0,0 +1,67 @@
;;-*-lisp-*-
;; It is often desirable in maclisp to get the efficiency possible
;; by using non-reentrant static storage, while at the same time
;; allowing for buffer reallocations if calls are made recusively
;; or in breakpoints. Example usages are the tokenization level
;; of a parser, adaptive numerical integrators, graph calculators.
;; Here is one way to formalize,in terms of the STATE-VARIABLES
;; of a process, a need which can can otherwize lead
;; to some rather messy programs simply for the sake of efficiency.
;; Note: These macros are also usefull in any application with state
;; variables and clean-up, for example, Assemblers and Compilers,
;; in fact, any file processor.
;; Usage: (DEFSTATE <NAME> <VARIABLE-SPEC> <VARIABLE-SPEC> ...)
;; <VARIABLE-SPEC> : (<VARIABLE> <TOP-LEVEL-VAL>
;; <RECURSIVE-VAL>
;; <CLEAN-UP-CODE>)
;; Produces: (APPLY-IN-<NAME>-STATE ...) a function.
;; (<NAME>-STATE-VARS) a function.
;; (<NAME>-STATE-VALS) a function.
;; (<NAME>-STATE-RECL) a function.
;; From my private macros 1:07pm Wednesday, 25 February 1981 -GJC
(DECLARE (*LEXPR SYMBOLCONC))
;; This should be built-in
(eval-when (eval compile)
(DEFMACRO  (VARS . BODY) `#'(LAMBDA ,VARS . ,BODY)))
(HERALD DEFSTATE)
(DEFMACRO DEFSTATE (NAME . VARIABLE-SPECS)
(DO ((APPLY-FUN (SYMBOLCONC "APPLY-IN-" NAME "-STATE"))
(VAR-FUN (SYMBOLCONC NAME "-STATE-VARS"))
(VAL-FUN (SYMBOLCONC NAME "-STATE-VALS"))
(REC-FUN (SYMBOLCONC NAME "-STATE-RECL"))
(SPECS VARIABLE-SPECS (CDR SPECS))
(VARS NIL)
(VALS-TOP NIL)
(VALS-REC NIL)
(RECL NIL))
((NULL SPECS)
(SETQ VARS (NREVERSE VARS)
VALS-TOP (NREVERSE VALS-TOP)
VALS-REC (NREVERSE VALS-REC)
RECL (NREVERSE RECL))
`(PROGN
'COMPILE
,@(MAPCAR ( (A B) `(DEFVAR ,A ,B)) VARS VALS-TOP)
(DEFUN ,VAR-FUN () ',VARS)
(DEFUN ,VAL-FUN () (LIST ,@VALS-REC))
(DEFUN ,REC-FUN () ,@RECL)
(DEFUN ,APPLY-FUN (F L)
(PROGV (,VAR-FUN)
(,VAL-FUN)
(UNWIND-PROTECT (APPLY F L)
(,REC-FUN))))))
(LET ((SPEC (IF (EQ (TYPEP (CAR SPECS)) 'LIST)
(CAR SPECS)
(ERROR "Bad variable spec" (CAR SPECS)))))
(PUSH (POP SPEC) VARS)
(PUSH (POP SPEC) VALS-TOP)
(PUSH (POP SPEC) VALS-REC)
(PUSH (POP SPEC) RECL))))

404
src/libdoc/defvst.164 Executable file
View File

@@ -0,0 +1,404 @@
;;; DEFVST -*-Mode:Lisp;Package:SI-*-
;;; *************************************************************************
;;; ***** NIL ****** NIL/MACLISP/LISPM Structure Definer ********************
;;; *************************************************************************
;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology *******
;;; ************ this is a read-only file! (all writes reserved) ************
;;; *************************************************************************
;;; Acronym for "DEFine a Vector-like STructure"
;;; For documentation and examples, see the file LIBDOC;DEFVST DOC on the
;;; various ITS systems, and LISP:DEFVST.DOC on TOPS10/20 systems.
;;; For MacLISP, to compile NADEFVST (version to use in NIL-aided MacLISP),
;;; just load the SHARPC module, and set TARGET-FEATURES to 'NILAID
(herald DEFVST /164)
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
#-NIL
(subload SHARPCONDITIONALS)
)
;;Remember: a NILAID also will be a MacLISP
#+(or LISPM (and NIL (not MacLISP)))
(progn (globalize "DEFVST")
(globalize "CONSTRUCTOR-NAMESTRING-PREFIX")
(globalize "SELECTOR-NAMESTRING-STYLE")
)
;; Load DEFVSX and DEFMAX now to get their "globalizations"
;; Load EXTEND before DEFVSX so that CLASS system will be available
#-NIL
(eval-when (eval compile load)
(subload EXTEND)
(subload VECTOR)
(subload DEFVSX) ;Will subload DEFMAX and DEFVSY
)
#-(local NIL)
(eval-when (eval compile)
(subload EXTEND) ;Bring these guys in before DEFVSX,
(subload EXTMAC) ; so that the CLASS system will be
(subload VECTOR) ; alive by then.
(subload DEFVSX) ;Loading DEFVSX will also do
; (subload DEFMAX)
; (subload DEFVSY)
(subload DEFSETF)
(subload UMLMAC)
)
(declare (special DEFMACRO-DISPLACE-CALL
CONSTRUCTOR-NAMESTRING-PREFIX
SELECTOR-NAMESTRING-STYLE
STRUCT-CLASS
STRUCT=INFO-CLASS
|defvst-typchk/||
|defvst-construction/||)
#+MacLISP (*lexpr TO-VECTOR))
#+MacLISP
(eval-when (eval compile load)
(cond ((status feature COMPLR)
(*expr |defvst-construction/|| |defvst-construction-1/||
|defvst-typchk/||)
(*lexpr |defvst-initialize/||)))
)
(MAPC '(LAMBDA (X Y) (AND (NOT (BOUNDP X)) (SET X Y)))
'(SELECTOR-NAMESTRING-STYLE CONSTRUCTOR-NAMESTRING-PREFIX )
'(|-| |CONS-A-| ))
#+(and MacLISP NIL)
(include #+(local ITS) ((NILCOM) DEFVSY >)
#-(local ITS) ((LISP) DEFVSY LSP))
#+(and MacLISP NIL)
(include #+(local ITS) ((NILCOM) DEFVSX >)
#-(local ITS) ((LISP) DEFVSX LSP))
#+(local MacLISP)
(eval-when (compile)
(defprop DEFVST T SKIP-WARNING)
;; FOO! to prevent circularities when compiling
(do ((i 0 (1+ i))
(l '(VERS NAME CNSN SIZE INIS CLSS) (cdr l))
(z))
((null l))
(setq z (symbolconc 'STRUCT=INFO- (car l)))
(eval `(DEFMACRO ,z (X) `(SI:XREF ,X ,,i))))
)
;;;; DEFVST macro
(defmacro (DEFVST defmacro-displace-call () ) (sname &rest selkeys &whole form)
(LET ((NKEYS 0)
(SELECTOR-NAMESTRING-STYLE SELECTOR-NAMESTRING-STYLE)
(CONSTRUCTOR-NAMESTRING-PREFIX CONSTRUCTOR-NAMESTRING-PREFIX)
(OUTPUT-SELECTOR-MACROS 'T)
CONSTRUCTOR-NAME RESTKEY RESTSIZEFORM RESTP SELINIS MAC-ARG-NM
SNAME-CLASS-VAR TMP OPTION-LIST )
(DECLARE (FIXNUM I NKEYS))
(COND ((NOT (ATOM SNAME))
(SETQ OPTION-LIST (CDR SNAME))
(SETQ SNAME (CAR SNAME))
(IF (ASSQ 'NO-SELECTOR-MACROS OPTION-LIST)
(SETQ OUTPUT-SELECTOR-MACROS () ))))
(AND (OR (NULL SNAME) (NOT (SYMBOLP SNAME)))
(ERROR "Bad name arg - DEFVST" FORM))
(SETQ SNAME-CLASS-VAR (SYMBOLCONC SNAME '-CLASS))
(SETQ NKEYS (LENGTH SELKEYS))
(COND ((SETQ TMP (MEMQ '&REST SELKEYS))
(SETQ NKEYS (- NKEYS (LENGTH TMP))
RESTKEY (CADR TMP)
RESTSIZEFORM (CADDR TMP))
(AND (OR (NOT (SYMBOLP RESTKEY)) (NULL RESTSIZEFORM))
(ERROR "Bad &REST item - DEFVST" SELKEYS))))
(COND ((GET SNAME 'STRUCT=INFO)
(TERPRI MSGFILES)
(PRINC "Warning! Redefining the STRUCTURE " MSGFILES)
(PRIN1 SNAME MSGFILES)))
(SETQ MAC-ARG-NM (SYMBOLCONC SNAME '|-MACRO-ARG|))
(SETQ CONSTRUCTOR-NAME
(COND ((SETQ TMP (ASSQ 'CONSTRUCTOR OPTION-LIST))
(CADR TMP))
('T (SYMBOLCONC CONSTRUCTOR-NAMESTRING-PREFIX SNAME))))
;RESTP and SELINIS start out null here
(DO ( (I 1 (1+ I))
(L SELKEYS (CDR L))
INIFORM TYP /=-/:-COUNT KEYNM SELNM )
( (OR (NULL L) RESTP) )
(COND ((ATOM (SETQ KEYNM (CAR L)))
(COND ((EQ KEYNM '&REST)
(SETQ KEYNM RESTKEY RESTP 'T)
(AND (NOT (EQ RESTKEY (CADR L)))
(+INTERNAL-LOSSAGE '&REST 'DEFVST SELKEYS)))
((NOT (SYMBOLP KEYNM))
(ERROR "Key name not a symbol - DEFVST" KEYNM)))
(SETQ INIFORM () ))
('T (AND (OR (NULL (SETQ KEYNM (CAR KEYNM)))
(NOT (SYMBOLP KEYNM)))
(ERROR "Bad key-list - DEFVST" SELKEYS))
(COND ((ATOM (SETQ TMP (CDAR L))) (SETQ INIFORM () ))
('T (SETQ /=-/:-COUNT 0 )
(AND (NULL (CDR TMP)) ;Allow LISPM-
(SETQ TMP `(= ,(car tmp)))) ; style inits
(COND ((SETQ TYP (MEMQ '|:| TMP))
(SETQ /=-/:-COUNT 1)
(SETQ TYP (COND ((ATOM (CADR TYP))
(LIST (CADR TYP)))
((CADR TYP))))))
(SETQ INIFORM
(COND ((SETQ INIFORM (MEMQ '= TMP))
(SETQ /=-/:-COUNT (1+ /=-/:-COUNT))
(CADR INIFORM))
(TYP (CDR (OR (ASSQ
(CAR TYP)
'((FIXNUM . 0)
(FLONUM . 0.0)
(BIGNUM . 500000000000000000000.)
(LIST . () )
(SYMBOL . 'FOO)
(ARRAY . () )
(HUNK . () )
))
#+NIL (ASSQ (CAR TYP)
'((SMALL-FLONUM 0.0)
(PAIR . '(() ))
(VECTOR . #.(if (fboundp 'make-vector)
(make-vector 0)
() ))
(STRING . "" )))
)))))
(AND (NOT (= /=-/:-COUNT 0))
(SETQ INIFORM (CONS INIFORM TYP)))
(COND ((NOT (= (* 2 /=-/:-COUNT) (LENGTH TMP)))
(PRINT (CAR L) MSGFILES)
(PRINC "Option list has options not yet coded ")))
))
))
(COND
((NOT OUTPUT-SELECTOR-MACROS) (PUSH `(,keynm) SELINIS))
('T (SETQ SELNM (IF (NULL SELECTOR-NAMESTRING-STYLE)
KEYNM
(SYMBOLCONC SNAME
SELECTOR-NAMESTRING-STYLE
KEYNM)))
(COND ((NOT RESTP)
;; INIFORM = (<initialization-form> <restrictions>...)
(PUSH `(,keynm ,selnm ,.iniform) SELINIS))
('T (SETQ RESTP `(,keynm ,selnm ,restsizeform))
(OR (= I (1+ NKEYS))
(+INTERNAL-LOSSAGE '&REST 'DEFVST i)))))))
`(EVAL-WHEN (EVAL COMPILE LOAD)
#-NIL #%(DEF-OR-AUTOLOADABLE |defvst-initialize/|| DEFVSY)
(AND #-NIL (STATUS FEATURE COMPLR)
(SPECIAL ,sname-class-var))
;; The next line is a crock to replace the line commented out
;; below --RWK
(DEFPROP ,sname ,sname-class-var CLASS-VAR)
(|defvst-initialize/||
',sname
',constructor-name
,nkeys
',(to-vector (cons restp (nreverse selinis)))
,SI:STRUCT=INFO-VERSION ;a version number
,(and (filep infile) `',(truename infile))
;; The next line is commented out until dumped out versions of
;; |defvst-initialize/|| without an &REST IGNORE or this argument
;; are re-dumped.
;; -- RWK, Sunday the twenty-first of June, 1981; 3:12:18 am
;; ,sname-class-var
)
,.(if restp
`((DEFPROP ,(cadr restp)
(,sname ,(1+ nkeys) &REST)
SELECTOR)))
',sname)))
;;;; Structure Printer
;; Someday, hack printing of &REST stuff
(DEFVAR SI:PRINLEVEL-EXCESS '|#|)
(DEFVAR SI:PRINLENGTH-EXCESS '|...|)
(defmethod* (:PRINT-SELF STRUCT-CLASS) (ob stream depth slashifyp)
(declare (fixnum depth))
(setq depth (1+ depth))
(if (and prinlevel (not (< depth prinlevel)))
(princ SI:PRINLEVEL-EXCESS stream)
(let* ((name (si:class-name (class-of ob)))
(info (get name 'STRUCT=INFO)))
(if (null info)
(si:print-extend-maknum ob stream)
(progn
(si:verify-defvst-version name (STRUCT=INFO-vers info))
(princ '|#{| stream)
(do ((z (si:listify-struct-for-print ob name info) (cdr z))
(n 0 (1+ n))
(first 'T ()))
((null z))
(declare (fixnum n))
(or first (tyo #\SPACE stream))
(print-object (car z) depth slashifyp stream)
(cond ((and prinlength (not (< n PRINLENGTH)))
(tyo #\SPACE stream)
(princ SI:PRINLENGTH-EXCESS stream)
(return () ))))
(tyo #/} stream))))))
(defmethod* (SPRINT STRUCT-CLASS) (ob n m)
(declare (special L N M))
(let* ((name (si:class-name (class-of ob)))
(info (get name 'STRUCT=INFO)))
(if (null info)
(si:print-extend-maknum ob outfiles)
(let ((z (si:listify-struct-for-print ob name info)))
(si:verify-defvst-version name (STRUCT=INFO-vers info))
(if (> (- (grchrct) 3.) (gflatsize z))
(prin1 ob)
(progn
(princ '|#{|)
(prin1 (car z))
(cond ((cdr z)
(tyo #\SPACE)
(setq N (grchrct) M (1+ M))
(do ((l (cdr z)))
((null l))
(grindform 'LINE)
(grindform 'CODE)
(cond (l (indent-to N))))))
(tyo #/})))))))
#+(or (not NIL) MacLISP)
(eval-when (eval compile)
(defmacro (VECTOR-LENGTH defmacro-for-compiling () defmacro-displace-call () )
(&rest w)
`(SI:EXTEND-LENGTH ,.w))
(defmacro (VREF defmacro-for-compiling () defmacro-displace-call () )
(&rest w)
`(SI:XREF ,.w))
)
;; Sure, this could do less consing, if it really wanted to. But who
;; wants to trouble to write such hairy code?
(DEFUN SI:LISTIFY-STRUCT-FOR-PRINT (OB NAME INFO)
(LET* ((SUPPRESS (GET NAME 'SUPPRESSED-COMPONENT-NAMES))
(INIS (STRUCT=INFO-INIS INFO)))
(DO ((I 1 (1+ I))
(N (VECTOR-LENGTH INIS))
(THE-LIST (LIST NAME)))
((NOT (< I N)) (NREVERSE THE-LIST))
;The (1+ i)th component of INIS corresponds to the ith
;component of OB. The 0th component of INIS corresponds
;to the &REST stuff which this code doesn't address.
(LET* (((NAME SELECTOR INIT) (VREF INIS I))
(VAL (SI:XREF OB
(OR (AND SELECTOR
(CADR (GET SELECTOR 'SELECTOR)))
(1- I)))))
(COND ((MEMQ NAME SUPPRESS))
;;Incredible kludge to avoid printing defaulted vals
((OR (AND (NULL INIT) (NULL VAL))
(AND (|constant-p/|| INIT)
(EQUAL VAL (EVAL INIT)))
(AND (PAIRP INIT)
(EQ (CAR INIT) 'QUOTE)
(EQUAL VAL (CADR INIT)))))
(T (PUSH NAME THE-LIST)
(PUSH VAL THE-LIST)))))))
(defmethod* (EQUAL struct-class) (ob other)
(or (eq ob other) ;generally, this will have already been done
(let ((ty1 (struct-typep ob))
(ty2 (struct-typep other)))
(cond ((or (null ty1) (null ty2) (not (eq ty1 ty2))) () )
((si:component-equal ob other))))))
(defmethod* (SUBST struct-class) (ob a b)
(si:subst-into-extend ob a b))
(defmethod* (SXHASH struct-class) (ob)
(si:hash-Q-extend ob #.(sxhash 'STRUCT)))
(defmethod* (DESCRIBE struct-class) (ob stream level)
(declare (special SI:DESCRIBE-MAX-LEVEL))
(if (not (> level SI:DESCRIBE-MAX-LEVEL))
(let* ((name (struct-typep ob))
(info (get name 'STRUCT=INFO)))
(if (null info)
()
(let* ((inis (STRUCT=INFO-inis info))
(ninis (vector-length inis))
(suppress (get name 'SUPPRESSED-COMPONENT-NAMES)))
(si:verify-defvst-version name (STRUCT=INFO-vers info))
(format stream
"~%~vTThe named structure has STRUCT-TYPEP ~S"
level name)
(if suppress
(format stream
"~%~vtThese component names are suppressed: ~S"
level suppress))
(format stream
"~%~vtThe ~D. component names and contents are:"
level (1- ninis))
(do ((i 1 (1+ i)) (default () ()))
((not (< i ninis)))
(let* (((name selector init) (vref inis i))
(sel (get (cadr (vref inis i)) 'SELECTOR))
(val (vref ob (if sel (cadr sel) (1- i)))))
(if (or (and (null init) (null val))
(and (|constant-p/|| init)
(equal val (eval init)))
(and (pairp init)
(eq (car init) 'QUOTE)
(equal val (cadr init))))
(setq default 'T))
(format stream
"~%~vt ~S: ~S ~:[~; [default]~]"
level (car (vref inis i)) val default)))
(if (vref inis 0)
(format stream
"~%~vt&REST part hasn't been Described."
level)))))))
#+(and MacLISP (not NIL))
(or (fboundp 'STRUCT-LET)
(equal (get 'STRUCT-LET 'AUTOLOAD) #%(autoload-filename UMLMAC))
(prog2 (defun STRUCT-LET macro (x)
((lambda (n FASLOAD)
(cond ((null n))
((alphalessp n "25")
(remprop 'UMLMAC 'VERSION))
((+internal-lossage 'UMLMAC 'STRUCT-LET n)))
(load #%(autoload-filename UMLMAC))
(macroexpand x))
(get 'UMLMAC 'VERSION)
() ))
(defun STRUCT-SETF macro (x)
((lambda (n FASLOAD)
(cond ((null n))
((alphalessp n "25")
(remprop 'UMLMAC 'VERSION))
((+internal-lossage 'UMLMAC 'STRUCT-SETF n)))
(load #%(autoload-filename UMLMAC))
(macroexpand x))
(get 'UMLMAC 'VERSION)
() ))))

1070
src/libdoc/doctor.jonl1 Executable file
View File

File diff suppressed because it is too large Load Diff

1070
src/libdoc/doctor.jonl2 Normal file
View File

File diff suppressed because it is too large Load Diff

34
src/libdoc/dow.jonl3 Executable file
View File

@@ -0,0 +1,34 @@
;;; THE FOLLOWING FUNCTION, WHEN GIVEN THE DATE AS THREE NUMBERS,
;;; WILL PRODUCE THE 0-ORIGIN NUMBER OF THE DAY-OF-WEEK FOR THAT DATE.
;;; E.G., (DAY-NAME (DOW 1963. 11. 22.)) ==> FRIDAY, WHICH HAPPENED
;;; TO BE THE DAY PRESIDENT JOHN F. KENNEDY WAS ASSASINATED.
(DEFUN DOW (YEAR MONTH DAY)
(AND (AND (FIXP YEAR) (FIXP MONTH) (FIXP DAY))
((LAMBDA (A)
(DECLARE (FIXNUM A))
(\ (+ (// (1- (* 13. (+ MONTH 10. (* (// (+ MONTH 10.) -13.) 12.))))
5.)
DAY
77.
(// (* 5. (- A (* (// A 100.) 100.))) 4.)
(// A -2000.)
(// A 400.)
(* (// A -100.) 2.))
7.))
(+ YEAR (// (+ MONTH -14.) 12.)))))
(DEFUN DAY-NAME (N)
(DECLARE (FIXNUM N))
(COND ((> N 3)
(COND ((> N 5) 'SATURDAY)
((> N 4) 'FRIDAY)
('THURSDAY)))
((> N 1) (COND ((> N 2) 'WEDNESDAY) ('TUESDAY)))
((ZEROP N) 'SUNDAY)
('MONDAY)))

36
src/libdoc/dow.jonl4 Normal file
View File

@@ -0,0 +1,36 @@
;;; THE FOLLOWING FUNCTION, WHEN GIVEN THE DATE AS THREE NUMBERS,
;;; WILL PRODUCE THE 0-ORIGIN NUMBER OF THE DAY-OF-WEEK FOR THAT DATE.
;;; E.G., (DAY-NAME (DOW 1963. 11. 22.)) ==> FRIDAY, WHICH HAPPENED
;;; TO BE THE DAY PRESIDENT JOHN F. KENNEDY WAS ASSASINATED.
(DEFUN DOW (YEAR MONTH DAY)
(AND (AND (FIXP YEAR) (FIXP MONTH) (FIXP DAY))
((LAMBDA (A)
(DECLARE (FIXNUM A))
(\ (+ (// (1- (* 13. (+ MONTH 10. (* (// (+ MONTH 10.) -13.) 12.))))
5.)
DAY
77.
(// (* 5. (- A (* (// A 100.) 100.))) 4.)
;; ejs: commented out as per Alan Sampson. This is a
;; incorrect check
;; (// A -2000.)
(// A 400.)
(* (// A -100.) 2.))
7.))
(+ YEAR (// (+ MONTH -14.) 12.)))))
(DEFUN DAY-NAME (N)
(DECLARE (FIXNUM N))
(COND ((> N 3)
(COND ((> N 5) 'SATURDAY)
((> N 4) 'FRIDAY)
('THURSDAY)))
((> N 1) (COND ((> N 2) 'WEDNESDAY) ('TUESDAY)))
((ZEROP N) 'SUNDAY)
('MONDAY)))

87
src/libdoc/dribbl.rbr1 Executable file
View File

@@ -0,0 +1,87 @@
(declare (special dribblefile startdribblefn stopdribblefn
^r outfiles msgfiles echofiles defaultf)
(macros nil)
(*lexpr dribble))
(defun REMOVE-DRIBBLE macro (l)
(list '(lambda (dfile)
(or (setq outfiles (delq dfile outfiles))
(setq ^r nil))
(setq msgfiles (delq dfile msgfiles))
(setq echofiles (delq dfile echofiles))
dfile)
(cadr l)))
(defun ADD-DRIBBLE macro (l)
(list '(lambda (dfile)
(or (memq dfile outfiles)
(setq outfiles (cons dfile outfiles)))
(or (memq dfile msgfiles)
(setq msgfiles (cons dfile msgfiles)))
(or (memq dfile echofiles)
(setq echofiles (cons dfile echofiles)))
(setq ^r t)
dfile)
(cadr l)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(cond((not(status features newio))
(terpri)
(princ '|DRIBBLE in NEWIO only!|)
(^g)))
;; DRIBBLEFILE is the current open (or most recently closed) dribble file object.
(setq DRIBBLEFILE nil)
(defun DRIBBLE args
;; (DRIBBLE filename) starts dribbling into the file.
;; The filename can be a namestring or namelist.
;; (DRIBBLE NIL) stops dribbling.
;; (DRIBBLE) restarts dribbling into the old file in append mode,
;; if a dribblefile already exists, that is.
;; Otherwise, starts dribbling into the file DSK:udir;DRIBBL >.
;; Dribbling entails creating a file and adding it to MSGFILES, ECHOFILES
;; and OUTFILES. ^R is set to T. (NB In a breakpoint, for example, ^R
;; is bound to NIL, thus inhibiting the dribble.)
;; When a dribblefile is opened and closed, the functional values of
;; STARTDRIBBLEFN and STOPDRIBBLEFN respectively will be executed; they will
;; receive the dribble file object as argument.
(prog (dribbling? return)
(setq return
(and (setq dribbling? (and dribblefile (status filemode dribblefile)))
(truename dribblefile)))
(cond
((or (zerop args) (eq (arg 1) T))
;; Restart DRIBBLE.
(cond((not dribbling?)
(setq dribblefile
(add-dribble (cond(dribblefile
(open dribblefile (cond((probef dribblefile)
'append)
('out))))
((open (list (list 'DSK (STATUS UDIR))
'DRIBBL '>) 'out)))))))
(and (boundp 'startdribblefn) startdribblefn
(funcall startdribblefn dribblefile)))
((eq (arg 1) NIL)
;; UNDRIBBLE.
(cond(dribbling?
(and (boundp 'stopdribblefn) stopdribblefn
(funcall stopdribblefn dribblefile))
(close (remove-dribble dribblefile)))))
(t ;; DRIBBLE.
(dribble nil) ;close current dribble file.
(setq dribblefile
(add-dribble (open (defaultf
(mergef (namelist (arg 1))
defaultf))
'out)))
(and (boundp 'startdribblefn) startdribblefn
(funcall startdribblefn dribblefile))))
(return return)))

230
src/libdoc/dumpgc.gjc2 Executable file
View File

@@ -0,0 +1,230 @@
;;;-*-lisp-*-
;;; program to aid in the garbage collection (i.e. file deletion)
;;; of systems dumped in lisp.
;;; 3:21pm Saturday, 14 February 1981 -GJC
(HERALD DUMPGC 1)
(DECLARE (*LEXPR TYIPEEK-GOBBLE-WHITESPACE))
(DEFVAR VERBOSE? T "Set to NIL if no while-running comments are wanted.")
(DEFVAR INCLUDE-DELETED-FILES? T "NIL to keep deleted files out of listings.")
;;; Raw data file is created by lusers who MAIL to the
;;; file LISP;LOCK MAIL.
;;; PURE-SUSPEND in LIBDOC;SHARAB sends such mail, also, you can
;;; load this file and run the function
;;; (SEND-LOCK-MAIL <SYSTEM-FILENAME> &OPTIONAL <LOCK-MAILFILE>)
;;; which will send mail to keep the lispversion around as long
;;; as <SYSTEM-FILENAME> is not deleted.
;;; (GENERATE-LOCK-REPORT &OPTIONAL <INPUT-FILENAME> <OUTPUT-FILENAME>)
;;; (READ-LOCK-MAIL-FILE &optional filename) returns a list of
;;; plists of information.
;;; (FORMAT-LOCK-INFO <STREAM> <stuff from READ-LOCK-MAIL-FILE>)
;;; Gives an indented listing, with one lisp version per page.
;;; Files which no longer exist are marked with a "*"
(DEFUN READ-LOCK-MAIL-FILE (&OPTIONAL (FILENAME "") &AUX STREAM)
(SETQ FILENAME (MERGEF FILENAME "DSK:LISP;LOCK MAIL"))
(UNWIND-PROTECT (READ-LOCK-MAIL-STREAM (SETQ STREAM (OPEN FILENAME)))
(AND STREAM (CLOSE STREAM))))
(DEFUN READ-LOCK-MAIL-STREAM (STREAM)
(IF VERBOSE? (FORMAT MSGFILES "~%; Reading /"~A/"~%"
(NAMESTRING (TRUENAME STREAM))))
(DO ((L NIL (CONS ENTRY L))
(ENTRY))
((NULL (SETQ ENTRY (READ-LOCK-MAIL-ENTRY STREAM)))
(IF VERBOSE? (FORMAT MSGFILES "~&; Done.~%"))
(NREVERSE L))))
(DEFUN READ-LOCK-MAIL-ENTRY (STREAM)
(IF (= (TYIPEEK-GOBBLE-WHITESPACE STREAM) -1)
NIL
(LET ((UNAME (READ-LOCK-UNAME STREAM))
(DATE (READ-LOCK-DATE STREAM))
(DAYTIME (READ-LOCK-DAYTIME STREAM))
(SHARING (READ STREAM)))
(GOBBLE-END-OF-MAIL-MARK STREAM)
;; Sharing list is (<LISP-VERSION> <BASEFILE> . <brain-damage>)
;; so we give this a more useful ordering.
(SETQ SHARING (LIST* (CAR SHARING)
(CADR SHARING)
(NREVERSE (CDDR SHARING))))
;; Now it is ordered most primitive to least primitive, the
;; reverse of which would be just as useful of course.
(LIST (CAR (LAST SHARING))
'UNAME UNAME
'DATE DATE
'DAYTIME DAYTIME
'SHARING SHARING))))
;;; Format of a mail-header is assumed to be "FOO 02/14/81 15:15:24"
(DEFUN READ-LOCK-UNAME (STREAM)
(READ STREAM))
(DEFUN READ-LOCK-DATE (STREAM)
(LET ((MONTH (READ-INT STREAM))
(DAY (READ-INT STREAM))
(YEAR (READ-INT STREAM)))
;; compatable with (STATUS DATE)
(LIST YEAR MONTH DAY)))
(DEFUN READ-LOCK-DAYTIME (STREAM)
(LIST (READ-INT STREAM) (READ-INT STREAM) (READ-INT STREAM)))
(DEFUN GOBBLE-END-OF-MAIL-MARK (STREAM)
(IF (= (TYIPEEK-GOBBLE-WHITESPACE STREAM #'(LAMBDA (C) (NOT (= C #^_))))
#^_)
(TYI STREAM)))
(DEFUN WHITESPACEP (X)
(MEMBER X '(#\SP #\TAB #\CR #\LF #\FF)))
(DEFUN NONDIGITP (X) (OR (< X #/0) (> X #/9)))
(DEFUN TYIPEEK-GOBBLE-WHITESPACE (STREAM &OPTIONAL (F #'WHITESPACEP))
(DO ((C))
((NOT (FUNCALL F (SETQ C (TYIPEEK NIL STREAM -1)))) C)
(TYI STREAM)))
(DEFUN READ-INT (STREAM)
(DO ((C (TYIPEEK-GOBBLE-WHITESPACE STREAM #'NONDIGITP)
(TYIPEEK () STREAM))
(X 0 (+ (- C #/0) (* X 10.))))
((NONDIGITP C) X)
(TYI STREAM)))
;; A RALIST is a recursive alist.
(defun rinsert (list ralist)
(if (null list)
ralist
(let ((next-ralist (assoc (car list) ralist)))
(cond ((null next-ralist)
(cons (cons (car list) (rinsert (cdr list) nil))
ralist))
('else
(rplacd next-ralist (rinsert (cdr list) (cdr next-ralist)))
ralist)))))
(DEFUN SHARING-FILE-RALIST (PLISTS)
(DO ((RALIST NIL (RINSERT (GET (POP PLISTS) 'SHARING) RALIST)))
((NULL PLISTS)
(SORTCAR RALIST #'ALPHALESSP))))
(DEFVAR LOCK-MAIL-ALIST ())
(DEFUN FORMAT-SHARED-FILENAME (STREAM FILENAME INDENTATION-LEVEL)
(LET* ((INFO (ASSOC FILENAME LOCK-MAIL-ALIST))
(PROBEF? (LET ((L (GETL INFO '(PROBEF))))
(IF L (CADR L) (PROBEF FILENAME)))))
(IF (OR PROBEF? INCLUDE-DELETED-FILES?)
(FORMAT STREAM
"~&~VX/"~A/"~:[*~; ~] ~40T~A ~S ~S~%"
INDENTATION-LEVEL
(NAMESTRING FILENAME)
PROBEF?
(GET INFO 'UNAME)
(GET INFO 'DATE)
(GET INFO 'DAYTIME)))))
(DEFUN FORMAT-SHARING-RALIST (STREAM RALIST INDENTATION-LEVEL)
(DO ((L RALIST (CDR L)))
((NULL L))
(FORMAT-SHARED-FILENAME STREAM (CAAR L) INDENTATION-LEVEL)
(FORMAT-SHARING-RALIST STREAM (CDAR L) (1+ INDENTATION-LEVEL))))
(DEFUN GENERATE-LOCK-REPORT (&OPTIONAL (INPUT "") (OUTPUT ""))
(SETQ INPUT (MERGEF INPUT "DSK:LISP;LOCK MAIL"))
(SETQ OUTPUT (MERGEF OUTPUT (MERGEF "* REPORT" INPUT)))
(LET ((LOCK-MAIL-ALIST (REMOVE-EARLIER-LOCK-ENTRIES
(READ-LOCK-MAIL-FILE INPUT)))
(BASE 10.)
(*NOPOINT T)
(STREAM))
(IF VERBOSE? (FORMAT MSGFILES "~&; Doing PROBEF of ~D files~%"
(LENGTH LOCK-MAIL-ALIST)))
(MAPC #'(LAMBDA (U) (PUTPROP U (PROBEF (CAR U)) 'PROBEF)) LOCK-MAIL-ALIST)
(IF VERBOSE? (FORMAT MSGFILES "~&; Generating report file.~%"))
(UNWIND-PROTECT
(PROGN (SETQ STREAM (OPEN (MERGEF "* _REPO_" OUTPUT) 'OUT))
(FORMAT STREAM
"~
~&** File Dependencies given by the file /"~A/"~60T**~
~:[~;~
~%** Files marked with a /"*/" no longer exist. ~60T**~
~]~
~%** Generated by ~S on ~S ~S~60T**~%~%"
(NAMESTRING (PROBEF INPUT))
INCLUDE-DELETED-FILES?
(STATUS UNAME) (STATUS DATE) (STATUS DAYTIME))
(DO ((L (SHARING-FILE-RALIST LOCK-MAIL-ALIST) (CDR L)))
((NULL L))
(FORMAT STREAM "~&-- MacLisp version ~A --~%"
(CAAR L))
(FORMAT-SHARING-RALIST STREAM (CDAR L) 0)
(TYO #\FF STREAM)
(TERPRI STREAM))
(RENAMEF STREAM OUTPUT))
(AND STREAM (CLOSE STREAM)))
(LET ((S (NAMESTRING (TRUENAME STREAM))))
(PUTPROP S T '+INTERNAL-STRING-MARKER)
S)))
(DEFUN LOCK-DATE-GREATERP (ENTRY-A ENTRY-B)
(OR (DICT-GREATERP (GET ENTRY-A 'DATE)
(GET ENTRY-B 'DATE))
(DICT-GREATERP (GET ENTRY-A 'DAYTIME)
(GET ENTRY-B 'DAYTIME))))
(DEFUN DICT-GREATERP (L-A L-B)
(AND L-A
(OR (GREATERP (CAR L-A) (CAR L-B))
(DICT-GREATERP (CDR L-A) (CDR L-B)))))
(DEFUN REMOVE-EARLIER-LOCK-ENTRIES (L)
(IF (NULL L) NIL
(LET ((A (CAR L)))
(LET ((B (ASSOC (CAR A) (CDR L))))
(IF (OR (NULL B)
(LOCK-DATE-GREATERP A B))
(CONS (CAR L) (REMOVE-EARLIER-LOCK-ENTRIES (CDR L)))
(REMOVE-EARLIER-LOCK-ENTRIES (CDR L)))))))
(DEFUN SEND-LOCK-MAIL (SYSTEM-FILENAME &OPTIONAL (MF "DSK:LISP;LOCK MAIL"))
(LET ((FN (PROBEF SYSTEM-FILENAME)))
;; we need to do this to insure that a fully-expanded non-losing
;; filename has been given, otherwise really meaningless stuff
;; might be generated. In other words, this function is
;; meant to be used AFTER you dump a system, not before.
(OR FN (ERROR "SYSTEM-FILENAME does not exist yet!"
SYSTEM-FILENAME
'FAIL-ACT))
(SETQ SYSTEM-FILENAME (NAMELIST FN)))
(LET ((BASE 10.)
(*NOPOINT 'T)
F DATE TIME PRINLEVEL PRINLENGTH)
(unwind-protect
(DO ((I 3 (1- I)))
((OR (< I 0)
(ERRSET (SETQ F (OPEN MF '(APPEND))) NIL))
(COND ((< I 0)
(ERRSET (RENAMEF MF (MERGEF "LCKMAI >" MF)) NIL)
(SETQ F (OPEN MF '(OUT)))))
(SETQ DATE (STATUS DATE))
(SETQ TIME (STATUS DAYTIME))
(FORMAT F
"~%~A ~A//~A//~A ~A:~A:~A~
~%(~S ~S)~%"
(STATUS USERID)
(CADR DATE)(CADDR DATE)(CAR DATE)
(CAR TIME) (CADR TIME) (CADDR TIME)
(STATUS LISPV) SYSTEM-FILENAME))
(TERPRI TYO)
(PRINC "LOCK MAIL file not available -- waiting 10 seconds." TYO)
(SLEEP 10.))
(and f (close f)))))

BIN
src/libdoc/fake-s.15 Executable file
View File

Binary file not shown.

40
src/libdoc/faslre.info Executable file
View File

@@ -0,0 +1,40 @@
FASLREA is a package of functions for reading s-expressions and other
information from a FASL file (see also FASDMP). The source is MC:RLB;FASLRE >.
The three main functions are:
(FASLREADOPEN <file spec>) which opens the file, initializes, and
returns a FASL-OBJ for use by FASLREAD and FASLREADCLOSE.
(FASLREAD <FASL-obj>) which reads an item and returns it, with a type code
consed onto its front:
EVAL - the item was an "EVAL Mungeable". The CDR is the item.
ENTRY - the CDR is (<subr name> <subr type> <args prop>)
EOF - the end of the FASL file was reached.
(FASLREADCLOSE <FASL-obj>) which closes the file and flushes all
associated arrays.
An additional function (QFASLREAD <fas-obj>) reads an object and returns
it, with a code consed on its front:
ENTRY - the CDR is the subr name
EXT - the CDR is the symbol subject to the call
EOF - the end of the FASL file was reached.
DDT symbols are needed for the following LAP symbols:
BNCONS
In Lisp versions > /1567, DDT symbols won't be needed.
------------------------------------------------------------------
IMPLEMENTATION --
A FASL-OBJ is a Lisp T-type array with 6 entries:
(0) is byte-obj, a Lisp FIXNUM array with 9. entries storing the
relocation bytes
(1) is index indicating current (next) relocation type byte
(2) is Newio file object
(3) is the atom table, a Lisp T-type array
(4) is the maximum subscript for the atom table (1- size)
(5) is the greatest used subscript in the atom table.
For a discussion of FASL format, relocation bytes, and atom table,
see .INFO.FASBIN FORMAT .

514
src/libdoc/fforma.jonl13 Executable file
View File

@@ -0,0 +1,514 @@
;;; FFORMA -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ****** Fortran-style FORMAT package ************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
;;; *** Three functions for numeric print formating:
;;; PRINT-FIXED-FIELD-FLOATING
;;; PRINT-FIXED-PRECISION-FLOATING
;;; PRINT-FIXED-FIELD-FIXED
;;; **************************************************************
;;; **************************************************************
(herald FFORMA /13)
;;; Two functions for formatted printing of floating-point numbers
;;; and a simple one for fixed-point numbers. A null is returned if
;;; the number cant be printed in the requested format; and otherwise
;;; "T" (or a list of characters) is returned.
;;; PRINT-FIXED-FIELD-FLOATING - abbreviated "PFFF"
;;; A function for printing a floating point number with a specified
;;; number of integral places, and of fractional places.
;;; Total field width is specified by second arg, and should
;;; allow enough for the algebraic sign, and the decimal point.
;;; Number of places to the right of the decimal-point is
;;; specified by third arg. Similar to FORTRAN F8.3 style.
;;; Two optional args are permitted (both default to null).
;;; A list of options is fourth arg. see below under "variables".
;;; A file, or list of files, for output is fifth.
;;; PRINT-FIXED-PRECISION-FLOATING - abbreviated "PFPF"
;;; A function for printing a specified number of leading non-zero
;;; digits, using "E" format where necessary.
;;; Total field width is specified by second arg, and should
;;; be large enough to allow for sign, point, etc.
;;; Number of significant digits wanted is specified by third arg.
;;; Three optional args are permitted:
;;; A list of options is fourth arg, default to null.
;;; See below under "variables" for further description.
;;; A file, or list of files, for output is fifth, default to null.
;;; A list of "balance" numbers is sixth arg - one of these numbers
;;; (the first) specifies the number of digits printed to the left
;;; of the point when "E" format is selected; the second and third
;;; determine the exponent range wherein "E" format is not forced.
;;; For backwards-compatibility, if this argument is not a list,
;;; but is a fixnum, say <n>, that is equivalent to the list
;;; (<n> -3 8)
;;; thus for 1.0E-3 < x < 1.0E8, x will not be forced "E" format.
;;; PRINT-FIXED-FIELD-FIXED - abbreviated "PFFX"
;;; A function to print a fixnum or bignum in a field of specified size.
;;; First arg is number to be printed, second is field width,
;;; Three optional arguments:
;;; A fixnum, the radix for conversion, is third; defaults to BASE.
;;; A list of options is fourth arg, default to null.
;;; See below under "variables" for further description.
;;; A file, or list of files, for output is fifth.
;;; Applicable input domains:
;;; For "PFFF", 1.0E-9 < |CANDIDATE| < 1.0E+9 is required.
;;; For "PFPF", "E" format is used if |CANDIDATE| < 1.0E-3, or
;;; |CANDIDATE| >= 1.0E+9. Otherwise, an appropriatly
;;; selected version of PFPF is used.
;;; For "PFFX", |CANDIDATE| < 8.5E+37 is required.
;;; EXPLANATION OF ARGUMENT VARIABLES
;;; CANDIDATE - THE INPUT NUMBER
;;; WIDTH - THE WIDTH OF THE FORMAT FIELD, INCLUDING ALGEBRAIC
;;; SIGN, DECIMAL POINT, AND EXPONENT IF USED.
;;; FRAC - [THIS IS THE THIRD ARGUMENT FOR "PFFF"]
;;; NUMBER OF COLUMNS RESERVED FOR THE FRACTIONAL PART
;;; PREC - [THIS IS THE THIRD ARGUMENT FOR "PFPF"]
;;; TOTAL NUMBER OF SIGNIFICANT DIGITS REQUESTED.
;;; MUST BE IN THE RANGE 0 < PREC < 9.
;;; BASE - [THIRD ARGUMENT TO "PFFX". SAME AS IN LISP]
;;; OPTIONS - LIST OF OPTION DESIGNATORS:
;;; + - PRINT "+" FOR POSITIVE NUMBERS.
;;; SUBSTITUTING <SPACE> IS DEFAULT
;;; EXPLODE, EXPLODEC, OR EXPLODEN
;;; - IF ANY OF THESE APPEAR, THEN INSTEAD
;;; OF PRINTING THE DIGITS, THEY ARE COLLECTED
;;; IN AN OUTPUT LIST, AND RETURNED.
;;; ERROR - IF THE FORMATTING-PRINT FUNCTION CANNOT FIT
;;; THE CANDIDATE IN THE REQUESTED FORMAT, IT
;;; WILL NORMALLY RETURN A NULL. BUT IF "ERROR"
;;; IS PRESENT, IT WILL RUN A FAIL-ACT ERROR.
;;; LEFT - FOR "PFFF" AND "PFFX", PLACE SIGN IN LEFTMOST
;;; COLUMN OF FIELD. DEFAULT: PLACE SIGN
;;; ADJACENT TO LEFTMOST DIGIT.
;;; FOR "PFPF", LEFT-JUSTIFY CHARACTERS IN FIELD.
;;; RIGHT-JUSTIFICATION IS DEFAULT.
;;; 0 - FOR "PFPF", PRINT TRAILING ZEROS IN THE FRACTION
;;; PART (AND LEADING ZEROS IN THE EXPONENT PART);
;;; FOR "PFFF" AND "PFFX", PRINT LEADING ZEROS.
;;; SUPPRESSION IS DEFAULT.
;;; [THE FOLLOWING IS APPLICABLE ONLY TO "PFPF"]
;;; E - FORCE "E" FORMAT IN ALL CASES.
;;; [THE FOLLOWING IS APPLICABLE ONLY TO "PFFX"]
;;; . - *NOPOINT IS SET TO (NOT (MEMQ '/. OPTIONS))
;;; THIS HAS A DISCERNIBLE EFFECT ONLY IF BASE = 10.
;;; INT - [THIS IS THE FIFTH ARGUMENT TO "PFPF"]
;;; NUMBER OF COLUMNS RESERVED FOR THE INTEGRAL PART
;;; IF "E" FORMAT IS SELECTED; OTHERWISE IGNORED.
;;; AMOUNTS TO A SCALE FACTOR FOR THE EXPONENT, WITH 1
;;; YIELDING STANDARD SCIENTIFIC NOTATION.
;;; MUST BE IN THE RANGE -1 < INT < 9.
;;; EXPLANATION OF SOME AUXILLIARY PROG VARIALBES
;;; ROUNDED - THE INPUT NUMBER SUITABLY ROUNDED
;;; IPART - THE ACTUAL INTEGRAL PART OF "ROUNDED"
;;; NID - NUMBER OF DECIMAL DIGITS IN "IPART"
;;; FPART - FRACTIONAL PART OF "ROUNDED", AS AN INTEGER
;;; FRAC - FOR "PFPF", THIS VALUE IS COMPUTED FROM THE INPUTS
;;; EFLAG - NON-NULL IFF "E" FORMAT SELECTED
;;; EPART - EXPONENT FOR "E" FORMAT
;;; /|10S - AN ARRAY OF POWERS OF 10.0, FROM 1.0E-38 TO 1.0E+38
;;; /|/.10S - SECOND WORD OF DOUBLE-PRECISION FOR POWERS OF 10.0
;;; Some example usages. Note that spaces are printed either before
;;; or after the digit string as directed from the options list.
;;; (PRINT-FIXED-FIELD-FLOATING -385.236 8. 2 ()) -385.24
;;; (PRINT-FIXED-FIELD-FLOATING 385.236 8. 2 '(+ LEFT))+ 385.24
;;; (PRINT-FIXED-PRECISION-FLOATING 5.23759E2 10. 4 () () 1) 523.8
;;; (PRINT-FIXED-PRECISION-FLOATING .00135 10. 5 () () 0) 0.00135
;;; (PRINT-FIXED-PRECISION-FLOATING 58.2 10. 4 '(0) () 1) 58.20
;;; (PRINT-FIXED-PRECISION-FLOATING 58.2 10. 4 '(LEFT +) () 1)+58.2
;;; (PRINT-FIXED-PRECISION-FLOATING 58.2 10. 4 '(E) () 0) 0.582E+2
;;; (PRINT-FIXED-PRECISION-FLOATING .00045 12. 6 () () 2) 45.0E-5
;;; (PRINT-FIXED-PRECISION-FLOATING .00045 12. 6 () () '(2 -8 8)) 0.00045
;;; (PRINT-FIXED-PRECISION-FLOATING .00045 12. 2 () () 2) 45.0E-5
;;; (PRINT-FIXED-PRECISION-FLOATING .00045 12. 6 '(0) () 2) 45.0000E-05
;;; (PRINT-FIXED-PRECISION-FLOATING 28. 12. 4 () () 1) 28.0
;;; (PRINT-FIXED-FIELD-FIXED -8400. 10. 10. '(/. LEFT))- 8400.
;;; (PRINT-FIXED-FIELD-FIXED 8400. 10. 8. '(/. /+)) +20320
;;; (PRINT-FIXED-FIELD-FIXED 1054. 6 10. '(/0 EXPLODE)) WILL RETURN
;;; (/0 /0 /1 /0 /5 /4)
(DECLARE (SPECIAL /+OR- EXPLODE FILLER)
(*EXPR /1OUT/| NOUT/|)
(FIXNUM /+OR- FILLER (NDD/| FIXNUM) (LG10/| FLONUM))
(NOTYPE (1OUT/| FIXNUM) (REPEAT-OUT/| FIXNUM FIXNUM))
(ARRAY* (FLONUM (/|10S 79.)) (FLONUM (/|/.10S 79.))))
(DECLARE (SETQ DEFMACRO-FOR-COMPILING ()
DEFMACRO-DISPLACE-CALL ()
DEFMACRO-CHECK-ARGS () ))
(defmacro 10E (I) `(/|10S (+ 39. ,i)))
(defmacro /.10E (I) `(/|/.10S (+ 39. ,i)))
(defmacro <= (X Y) `(NOT (> ,x ,y)))
(defmacro >= (X Y) `(NOT (< ,x ,y)))
(DEFUN PRINT-FIXED-FIELD-FLOATING
(ICANDIDATE IWIDTH IFRAC &OPTIONAL OPTIONS FILE)
(DECLARE (FIXNUM IPART FPART NID FRAC WIDTH NSPCS)
(FLONUM CANDIDATE ROUNDED))
(LET ((BASE 10.) (/+OR- #\SPACE) (FILLER #\SPACE))
(PROG (*NOPOINT EXPLODE ROUNDED IPART FPART NID LJUST NSPCS
CANDIDATE WIDTH FRAC)
(SETQ CANDIDATE (COND ((FLOATP ICANDIDATE) ICANDIDATE)
((FLOAT ICANDIDATE)))
WIDTH (COND ((EQ (TYPEP IWIDTH) 'FIXNUM) IWIDTH)
((GO BARF)))
FRAC (COND ((EQ (TYPEP IFRAC) 'FIXNUM) IFRAC)
((GO BARF))))
(SETQ ROUNDED (FSC CANDIDATE 0)
NSPCS (COND ((= ROUNDED CANDIDATE) 0) (1))
ROUNDED (ABS ROUNDED)
LJUST (OUT-SET/| OPTIONS))
(SETQ *NOPOINT 'T)
(AND (MINUSP CANDIDATE) (SETQ /+OR- #/-))
(AND (OR (MINUSP FRAC) (> FRAC 18.)) (GO BARF))
(SETQ ROUNDED (+$ ROUNDED (*/$ 0.5 (10E (- FRAC)))))
(AND (NOT (LESSP 1.0E-9 ROUNDED 1.0E9)) (GO BARF))
(SETQ NID (NDD/| (SETQ IPART (FIX ROUNDED))))
(AND (MINUSP (SETQ NSPCS (- WIDTH FRAC 2 NID NSPCS))) (GO BARF))
;Algebraic sign and space-fillers
(AND LJUST (1OUT/| /+OR- file))
(REPEAT-OUT/| NSPCS FILLER file)
(AND (NOT LJUST) (1OUT/| /+OR- file))
(AND (NOT (= CANDIDATE (FSC CANDIDATE 0))) (1OUT/| #/# file))
;Integer part, decimal point
(NOUT/| IPART file)
(1OUT/| #/. file)
(COND ((NOT (ZEROP FRAC))
(SETQ FPART (FIX (*$ (10E FRAC)
(-$ ROUNDED (FLOAT IPART)))))
;Zeros at right of .
(REPEAT-OUT/| (- FRAC (NDD/| FPART)) #/0 file)
(NOUT/| FPART file)))
(RETURN (COND ((NULL EXPLODE)) ((NREVERSE (CDR EXPLODE)))))
BARF (AND (NOT (MEMQ 'ERROR OPTIONS)) (RETURN () ))
(ERROR (LIST 'PRINT-FIXED-FIELD-FLOATING CANDIDATE WIDTH FRAC OPTIONS)
'|OUT OF RANGE|
'FAIL-ACT)))
)
(DEFUN PRINT-FIXED-PRECISION-FLOATING
(ICANDIDATE IWIDTH IPREC &OPTIONAL OPTIONS FILE (BAL 1))
(DECLARE (FIXNUM IPART NID FPART INT FRAC PREC EPART WIDTH NSPCS LO HI
ELOW EHIGH )
(FLONUM CANDIDATE ROUNDED))
(LET ((BASE 10.) (/+OR- #\SPACE) (FILLER #\SPACE))
(PROG (*NOPOINT EXPLODE ROUNDED IPART NID INT ELOW EHIGH TEM EFLAG
FPART FRAC EPART NSPCS LJUST LO HI CANDIDATE WIDTH PREC)
(SETQ CANDIDATE (COND ((FLOATP ICANDIDATE) ICANDIDATE)
((FLOAT ICANDIDATE)))
WIDTH (COND ((EQ (TYPEP IWIDTH) 'FIXNUM) IWIDTH)
((GO BARF)))
PREC (COND ((EQ (TYPEP IPREC) 'FIXNUM) IPREC)
((GO BARF))))
(SETQ ROUNDED (FSC CANDIDATE 0))
(SETQ FPART -1 IPART 0 FRAC PREC NID 0
INT 1 ELOW -3 EHIGH 8
LJUST (OUT-SET/| OPTIONS)
EFLAG (MEMQ 'E OPTIONS)
*NOPOINT 'T
NSPCS (COND ((= ROUNDED CANDIDATE) 0) (1))
ROUNDED (ABS ROUNDED))
(COND ((NOT (ATOM BAL))
(AND (EQ (TYPEP (SETQ TEM (CAR BAL))) 'FIXNUM)
(SETQ INT TEM))
(AND (EQ (TYPEP (SETQ TEM (CADR BAL))) 'FIXNUM)
(AND (< (SETQ ELOW TEM) -11.)
(GO BARF)))
(AND (EQ (TYPEP (SETQ TEM (CADDR BAL))) 'FIXNUM)
(AND (> (SETQ EHIGH TEM) 11.)
(GO BARF))))
((EQ (TYPEP BAL) 'FIXNUM) (SETQ INT BAL)))
(AND (MINUSP CANDIDATE) (SETQ /+OR- #/-))
(SETQ EPART (COND ((< ROUNDED #.(FSC 4_24. 0))
(COND ((NOT (ZEROP ROUNDED)) (GO BARF))
(T (SETQ NID 1 FPART 0) (GO B))))
((AND (< ROUNDED 3.4359738E+10) (>= ROUNDED 1.0))
(1- (NDD/| (FIX ROUNDED))))
((LG10/| ROUNDED))))
(AND (NOT (LESSP 0 PREC 9.)) (GO BARF))
(SETQ LO (- EPART PREC))
(COND ((COND ((> LO 36.) (< ROUNDED 1.5E38))
((> LO -39.)))
;Round, if number not too small
(SETQ ROUNDED (+$ ROUNDED (*$ 0.5 (10E (1+ LO)))))
;Rounding may cause overflow to next power of 10.0
(AND (>= ROUNDED (+$ (10E (SETQ HI (1+ EPART)))
(/.10E HI)))
(SETQ EPART HI LO (1+ LO)))))
(COND (EFLAG)
((OR (> EPART EHIGH) (< EPART ELOW)) (SETQ EFLAG 'T))
((MINUSP EPART)
;IPART stays 0
(SETQ FRAC (1- (ABS LO)) NID 1))
(T (SETQ NID (NDD/| (SETQ IPART (FIX ROUNDED)))
FRAC (- PREC NID))
(AND (NOT (PLUSP FRAC))
(OR (NOT (= FILLER #/0)) (> (+ NID 2) WIDTH))
(SETQ EFLAG 'T))))
(COND (EFLAG
(AND (OR (MINUSP INT) (> INT 8)) (GO BARF))
(SETQ FRAC (- PREC INT) EPART (- EPART INT -1))
(SETQ ROUNDED
(COND ((= EPART 39.) (*$ 10.0 (*$ ROUNDED 1.0E38)))
('T ;Normalize into proper interval
;e.g., 1.0 <= ROUNDED < 10.0
(+$ (*$ ROUNDED (10E (- EPART)))
(*$ ROUNDED (/.10E (- EPART)))))))
(SETQ NID (NDD/| (SETQ IPART (FIX ROUNDED))))
(COND ((COND ((ZEROP INT) (< ROUNDED .1))
((< NID INT))
((ZEROP IPART) (NOT (ZEROP ROUNDED))))
;Because of truncation in /|.10S, and roundings
; in multiplication, possibly ROUNDED is a bit
; too high or too low
(SETQ ROUNDED (*$ ROUNDED 10.0)
EPART (1- EPART) NID -1))
((COND ((ZEROP INT) (>= ROUNDED 1.0))
((> NID INT)))
(SETQ ROUNDED (//$ ROUNDED 10.0)
EPART (1+ EPART) NID -1)))
(AND (MINUSP NID)
(SETQ NID (NDD/| (SETQ IPART (FIX ROUNDED)))))))
B (COND ((PLUSP FRAC)
;Maybe hafta strip out fraction part from "ROUNDED"
(AND (MINUSP FPART)
(SETQ FPART (FIX (*$ (COND ((ZEROP IPART) ROUNDED)
((-$ ROUNDED (FLOAT IPART))))
(10E FRAC)))))
(COND ((= FILLER #/0))
((ZEROP FPART) (SETQ FRAC 1))
((PROG ()
;Suppress trailing zeros
A (AND (NOT (ZEROP (\ FPART 10.))) (RETURN () ))
(SETQ FPART (// FPART 10.) FRAC (1- FRAC))
(GO A)))))
(T (AND (MINUSP FRAC) (SETQ HI (FIX (10E (- FRAC)))
IPART (* (// IPART HI) HI)))
(SETQ FRAC 1 FPART 0)))
(SETQ NSPCS (- WIDTH
NID
FRAC
NSPCS
(COND ((NOT EFLAG)
2)
((OR (= FILLER #/0) ;EXPONENT FIELD
(> EPART 9.) ; IS EITHER 5
(< EPART -9.)) ; OR 6 PLACES
6) ; xx.yyE+5
(5)))) ; xx.yyE+05
(AND (MINUSP NSPCS) (GO BARF))
;Space fillers (if necessary) and algebraic sign
(AND (NULL LJUST) (REPEAT-OUT/| NSPCS #\SPACE file))
(1OUT/| /+OR- file)
(AND (NOT (= CANDIDATE (FSC CANDIDATE 0))) (1OUT/| #/# file))
;Integer part, decimal point, zeros at right of .
(NOUT/| IPART file)
(1OUT/| #/. file)
(COND ((NOT (ZEROP FRAC))
(REPEAT-OUT/| (- FRAC (NDD/| FPART)) #/0 file)
(NOUT/| FPART file)))
(COND (EFLAG
(1OUT/| #/E file)
(1OUT/| (COND ((MINUSP EPART)
(SETQ EPART (- EPART))
#/-)
(#/+))
file)
(AND (= FILLER #/0)
(< EPART +10.)
(1OUT/| #/0 file))
(NOUT/| EPART file)))
(AND LJUST (REPEAT-OUT/| NSPCS #\SPACE file))
(RETURN (COND ((NULL EXPLODE)) ((NREVERSE (CDR EXPLODE)))))
BARF (AND (NOT (MEMQ 'ERROR OPTIONS)) (RETURN () ))
(ERROR (LIST 'PRINT-FIXED-PRECISION-FLOATING CANDIDATE WIDTH PREC OPTIONS BAL)
'|OUT OF RANGE|
'FAIL-ACT))))
(DEFUN PRINT-FIXED-FIELD-FIXED
(CANDIDATE WIDTH &OPTIONAL (FOOBASE BASE) OPTIONS FILE)
(DECLARE (FIXNUM WIDTH BASE BITS NID NSPCS))
(LET ((BASE BASE) (*NOPOINT 'T) (/+OR- #\SPACE) (FILLER #\SPACE))
(PROG (EXPLODE NID BITS NSPCS LJUST TEM)
(AND (NOT (FIXP CANDIDATE)) (SETQ CANDIDATE (FIX CANDIDATE)))
(AND (OR (NOT (EQ (TYPEP FOOBASE) 'FIXNUM))
(< FOOBASE 2)
(> FOOBASE 36.))
(GO BARF))
(SETQ BASE FOOBASE LJUST (OUT-SET/| OPTIONS))
(AND (= FILLER #/0) (SETQ LJUST T))
(AND (MINUSP CANDIDATE)
(SETQ /+OR- #/- CANDIDATE (ABS CANDIDATE)))
(SETQ BITS (HAULONG CANDIDATE)
NID (COND ((= BASE 8.) (1+ (// (1- BITS) 3)))
((AND (< BITS 127.) (= BASE 10.))
(COND ((< BITS 36.) (NDD/| CANDIDATE))
((1+ (LG10/| (FLOAT CANDIDATE))))))
('T (SETQ TEM (//$ (LOG (FLOAT CANDIDATE))
(LOG BASE)))
(COND ((= TEM
(FLOAT (SETQ TEM (IFIX TEM))))
TEM)
((1+ TEM))))))
(SETQ NSPCS (- WIDTH NID (COND ((OR *NOPOINT (NOT (= BASE 10.)))
1)
(2))))
(AND (MINUSP NSPCS) (GO BARF))
(AND LJUST (1OUT/| /+OR- file))
(REPEAT-OUT/| NSPCS FILLER file)
(AND (NOT LJUST) (1OUT/| /+OR- file))
(NOUT/| CANDIDATE file)
(RETURN (COND ((NULL EXPLODE)) ((NREVERSE (CDR EXPLODE)))))
BARF (AND (NOT (MEMQ 'ERROR OPTIONS)) (RETURN () ))
(ERROR (LIST 'PRINT-FIXED-FIELD-FIXED CANDIDATE WIDTH BASE OPTIONS)
'|OUT OF RANGE|
'FAIL-ACT))))
;COMPUTES INTEGRAL PART OF BASE-10.-LOG OF INPUT
(DEFUN LG10/| (ROUNDED)
(DECLARE (FLONUM ROUNDED) (FIXNUM LO HI EPART))
(PROG (LO MID HI)
;Approximation to exponent of 10.
(SETQ HI (FIX (+$ .5 (TIMES (- (LSH ROUNDED -27.) 128.) 0.30103)))
LO (- HI 4))
(AND (< LO -38.) (SETQ LO -39.))
A (COND ((>= ROUNDED (10E (SETQ MID (// (+ HI LO) 2))))
(SETQ LO MID))
(T (SETQ HI MID)))
(AND (> (- HI LO) 1) (GO A))
(RETURN (COND ((>= ROUNDED (+$ (10E HI) (/.10E HI))) HI)
((>= ROUNDED (+$ (10E LO) (/.10E LO))) LO)
(T (1- LO))))))
;NUMBER OF DECIMAL DIGITS IN A FIXNUM
(DEFUN NDD/| (N)
(DECLARE (FIXNUM N))
(COND ((< N 100000000.)
(COND ((< N 10000.)
(COND ((< N 100.) (COND ((< N 10.) 1) (2)))
((< N 1000.) 3)
(4)))
(T (COND ((< N 1000000.) (COND ((< N 100000.) 5) (6)))
((< N 10000000.) 7)
(8.)))))
((< N 10000000000.) (COND ((< N 1000000000.) 9.) (10.)))
(11.)))
(DEFUN OUT-SET/| (OPTIONS)
;Set up some global variables right at the outset
(DO ((Y OPTIONS (CDR Y)) (FL))
((NULL Y) FL)
(COND ((EQ (CAR Y) 'LEFT) (SETQ FL T))
((EQ (CAR Y) '/.) (SETQ *NOPOINT () ))
((MEMQ (CAR Y) '(EXPLODE EXPLODEC EXPLODEN))
(SETQ EXPLODE (LIST (EQ (CAR Y) 'EXPLODEN))))
((EQ (CAR Y) '/+) (SETQ /+OR- #/+))
((OR (EQ (CAR Y) '/0) (SIGNP E (CAR Y))) (SETQ FILLER #/0)))))
(DEFUN 1OUT/| (CHAR FILE)
(COND ((NULL EXPLODE) (TYO CHAR FILE))
((RPLACD EXPLODE (CONS (COND ((CAR EXPLODE) CHAR)
((ASCII CHAR)))
(CDR EXPLODE)))))
() )
(DEFUN NOUT/| (X FILE)
(COND ((NULL EXPLODE) (PRIN1 X FILE))
((RPLACD EXPLODE (NRECONC (COND ((CAR EXPLODE) (EXPLODEN X))
((EXPLODE X)))
(CDR EXPLODE)))))
() )
(DEFUN REPEAT-OUT/| (N CHAR FILE)
(DECLARE (FIXNUM N I))
(AND (PLUSP N) (DO I N (1- I) (ZEROP I) (1OUT/| CHAR FILE))))
;CODE TO INITIALIZE THESE TWO FOOLISH ARRAYS
(AND (OR (NULL (GET '/|10S 'ARRAY)) (NULL (ARRAYDIMS '/|10S)))
(PROGN (ARRAY /|10S FLONUM 79.)
(ARRAY /|/.10S FLONUM 79.)
;Smallest magnitude normalized, floating-point number
(STORE (/|10S 0) #.(FSC 4_24. 0))
;Largest magnitude normalized, floating-point number
(STORE (/|10S 78.) #.(FSC 377777777777 0))
;Second word of double-precision
(STORE (/|/.10S 78.) #.(FSC 344377777777 1_18.))
;A well-known constan
(STORE (/|10S 39.) 1.0)
(COND ((STATUS FEATURE BIGNUM)
(DO ((I 40. (1+ I)) (VAL 10. (TIMES VAL 10.)) (T1) (T2) (L) (INV))
((= I 78.))
(COND ((> (SETQ L (HAULONG VAL)) 53.)
(SETQ T1 (HAIPART VAL 27.) T2 (HAIPART (HAIPART VAL 54.) -27.)))
((> L 26.) (SETQ T1 (HAIPART VAL 27.) T2 (LSH (HAIPART VAL (- 27. L)) (- 54. L))))
(T (SETQ T1 (LSH VAL (- 27. L)) T2 0)))
(STORE (/|10S I) (FSC T1 (+ 128. L)))
(AND (PLUSP T2)
(STORE (/|/.10S I)
(FSC (BOOLE 7 (LSH (+ 101. L) 27.) T2) 1_18.)))
(STORE (/|10S (- 78. I))
(FSC (HAIPART (SETQ INV (*QUO #.(EXPT 2 181.) VAL)) 27.)
(- 129. L)))
(AND (< I 70.)
(STORE (/|/.10S (- 78. I))
(FSC (BOOLE 7
(LSH (- 102. L) 27.)
(HAIPART (HAIPART INV 54.) -27.))
1_18.)))))
((DO ((I 40. (1+ I)) (VAL 10.0 (*$ VAL 10.0)))
((= I 78.))
(STORE (/|10S I) VAL)
(STORE (/|10S (- 78. I)) (QUOTIENT 1.0 VAL)))))))

723
src/libdoc/fft.bwood1 Executable file
View File

@@ -0,0 +1,723 @@
;;;This file is the info and source file for the LISP FAST FOURIER TRANSFORM routines
;;;
;;;The routines are loaded via (FASLOAD FFT FASL DSK BWOOD)
;;;
;;;The two basic functions are:
;;; FFT --> Fast Fourier Transform
;;; IFT --> Inverse Fast Fourier Transform
;;;
;;;These functions perform a (complex) Fast Fourier Transform on either one
;;;or two dimensional FLONUM arrays. For the one-dimensional case, the
;;;FLONUM array must be of length a power of two. For the two-dimensional
;;;case, the FLONUM array must be square (ie. n x n) where n is a power of two.
;;;
;;;Calling format is as follows:
;;;(FFT <real-array-ptr> <complex-array-ptr>)
;;;(IFT <real-array-ptr> <complex-array-ptr>)
;;;
;;;NOTE: The arguments are array pointers not array names
;;;
;;;Needless to say, the real and complex arrays must be of the same size
;;;and dimension. The Fast Fourier Transform is performed in place. On
;;;return, the original arrays contain respectively, the real and complex
;;;part of the (Discrete) Fourier transform.
;;;
;;;Two additional functions are provided (useful for display purposes):
;;; (COMPLEX-TO-POLAR <real-array-ptr> <complex-array-ptr>)
;;; This function converts (in place) from FLONUM real/imaginery
;;; format to FLONUM polar (ie. magnitude/phase) format. On
;;; return, the real array contains the magnitude and
;;; the complex array contains the phase.
;;; (POLAR-TO-COMPLEX <magnitude-array-ptr> <phase-array-ptr>)
;;; This function converts (in place) from FLONUM polar
;;; format to FLONUM real/imaginery format. On return, the
;;; magnitude array contains the real part and the phase
;;; array contains the imaginery part.
;;;
;;;REMINDER:
;;;Recall that the FFT is really a DFT. Thus the FFT assumes periodicity of
;;;the data. In the one-dimensional case, the origin occurs at both ends
;;;of the array. In the two-dimesional case, the origin occurs at all four
;;;corners of the array. High frequency points are those furthest from the
;;;origin.
;;;
;;;
;;;To center the origin (for display purposes), say in the two-dimensional
;;;case, one can use the following accessing function (for ARRAY1):
;;;
;;;(DEFUN ARRAY1-PT (X Y)
;;; (ARRAYCALL FLONUM
;;; ARRAY1
;;; (BOOLE 1. (+ X (LSH N -1)) (1- N))
;;; (BOOLE 1. (+ Y (LSH N -1)) (1- N))))
;;;
;;;(where ARRAY1 is N x N)
;;;
;;;
;;;Everything is believed to work as advertised. Report any bugs/problems
;;;to BWOOD.
.FASL
.MLLIT==1
.INSRT LISP; DEFNS >
TITLE LISP FAST FOURIER TRANSFORM
;;;Need *MAKE-ARRAY (for creating SINE and COSINE tables)
.SXEVA (DEFPROP *MAKE-ARRAY (ARRAY FASL AI BWOOD) AUTOLOAD)
;;;Some (local) AC definitions
T1==C ;temporary ac's (not preserved)
T2==AR1
T3==AR2A
T4==T
T5==TT
P1==D ;permanent ac's (must be saved)
P2==R
P3==F
P4==FREEAC
;;;Define a few macros
DEFINE SACS PLACE
MOVEM 17,PLACE+17
MOVEI 17,PLACE
BLT 17,PLACE+16
TERMIN
DEFINE RACS PLACE
MOVSI 17,PLACE
BLT 17,16
MOVE 17,PLACE+17
TERMIN
ACS: BLOCK 20
DEFINE FLOAT AC
FSC AC,232
FADR AC,AC
TERMIN
DEFINE BARF ARG
LERR [SIXBIT \^M!ARG!!\]
TERMIN
SINE==0
COSINE==0
;;;addr's tagged `sine' and `cosine' eventually get smashed (inelegant but fast)
.ENTRY FFT SUBR 3
FFT: SKIPA TT,[MOVE B,SINE(P4)]
.ENTRY IFT SUBR 3
IFT: MOVE TT,[MOVN B,SINE(P4)]
MOVEM TT,FFTSIN
PUSH P,A
PUSH P,B
CALL 1,.FUNCTION TYPEP
CAIE 1,.ATOM ARRAY
BARF ARGUMENT NOT AN ARRAY POINTER (FFT)
MOVE A,-1(P)
CALL 1,.FUNCTION ARRAYDIMS
NCALL 1,.FUNCTION LENGTH
SKIPN TT
BARF ARGUMENT #DEAD-ARRAY (FFT)
CAIL TT,2
CAILE TT,3
BARF ARRAY HAS WRONG NUMBER OF DIMENSIONS (FFT)
PUSH FXP,TT
MOVE A,(P)
CALL 1,.FUNCTION TYPEP
CAIE 1,.ATOM ARRAY
BARF ARGUMENT NOT AN ARRAY POINTER (FFT)
MOVE A,(P)
CALL 1,.FUNCTION ARRAYDIMS
NCALL 1,.FUNCTION LENGTH
SKIPN TT
BARF ARGUMENT #DEAD-ARRAY (FFT)
CAIL TT,2
CAILE TT,3
BARF ARRAY HAS WRONG NUMBER OF DIMENSIONS (FFT)
POP FXP,D
CAIE TT,(D)
BARF REAL AND IMAGINARY ARRAY DIMENSIONS DIFFER (FFT)
CAIE TT,2
JRST 2DBEG
;;;1-dimensional FFT
BEG: MOVE A,-1(P)
MOVE B,(P)
MOVEI TT,-1
MOVE D,@1(A) ;get dimension
MOVNI R,(D)
ANDCAI R,(D)
SKIPE R
BARF ARRAY SIZE NOT POWER OF 2 (FFT)
CAME D,@1(B)
BARF REAL AND IMAGINARY ARRAY SIZES DIFFER (FFT)
MOVEM D,NN
MOVNI TT,(D)
HRLZM TT,ABJPTR
CAME D,LASTNN
PUSHJ P,FINIT
POP P,B
POP P,A
;;;When array addresses are smashed, no garbage collection can be allowed
;;;(since arrays may get relocated). Also, don't allow ^G interrupts.
;;;The code is written this way for speed.
HLLOS NOQUIT
SACS ACS
;;;Now able to smash addr's of sine & cosine arrays (with impunity)
MOVE TT,.ARRAY SINTBL
MOVEI TT,(TT)
HRRM TT,FFTSIN
MOVE TT,.ARRAY COSTBL
MOVEI TT,(TT)
HRRM TT,FFTCOS
REAL==0
IMAG==0
;;;Now able to smash addr's tagged `real' and `imag' (with impunity)
HRRZ A,1(A)
HRRZ B,1(B)
MOVSI TT,-TBLSIZ
HRRM A,@RTBL(TT)
HRRM B,@ITBL(TT)
AOBJN TT,.-2
PUSHJ P,REVBS
PUSHJ P,TRANS
JRST DONE
;;;2-dimensional FFT
2DBEG: MOVE A,-1(P)
MOVE B,(P)
MOVEI TT,-2
MOVE D,@1(A)
MOVNI R,(D)
ANDCAI R,(D)
SKIPE R
BARF ARRAY SIZE NOT POWER OF 2 (FFT)
CAME D,@1(B)
BARF REAL AND IMAGINARY ARRAY SIZES DIFFER (FFT)
MOVEI TT,-1
MOVE R,@1(A)
CAME R,@1(B)
BARF REAL AND IMAGINARY ARRAY SIZES DIFFER (FFT)
CAIE D,(R)
BARF ARRAY NOT SQUARE (FFT)
MOVEM D,NN
MOVEM D,LIMIT
SOS LIMIT
MOVNI TT,(D)
HRLZM TT,ABJPTR
CAME D,LASTNN
PUSHJ P,FINIT
POP P,B
POP P,A
;;;When array addresses are smashed, no garbage collection can be allowed
;;;(since arrays may get relocated). Also, don't allow ^G interrupts.
;;;The code is written this way for speed.
HLLOS NOQUIT
SACS ACS
;;;Now can smash addr's of sine & cosine arrays (with impunity)
MOVE TT,.ARRAY SINTBL
MOVEI TT,(TT)
HRRM TT,FFTSIN
MOVE TT,.ARRAY COSTBL
MOVEI TT,(TT)
HRRM TT,FFTCOS
SETZM COUNT
SETZM FLAG
SETZM INDEX
;;;save addr's of real & imaginary data
HRRZ A,1(A)
MOVEM A,DATA1
HRRZ B,1(B)
MOVEM B,DATA2
FFTLP:
REAL==0
IMAG==0
;;;Now can smash addr's tagged `real' and `imag' (with impunity)
MOVE A,DATA1
ADD A,INDEX
MOVE B,DATA2
ADD B,INDEX
MOVSI TT,-TBLSIZ
HRRM A,@RTBL(TT)
HRRM B,@ITBL(TT)
AOBJN TT,.-2
PUSHJ P,REVBS
PUSHJ P,TRANS
MOVE A,NN
ADDM A,INDEX
AOS A,COUNT
CAMGE A,NN
JRST FFTLP
PUSHJ P,TPOS
SKIPE FLAG
JRST DONE
SETOM FLAG
SETZM INDEX
SETZM COUNT
JRST FFTLP
;;;This restores LISP world and returns
DONE: RACS ACS
HLLZS NOQUIT
PUSHJ P,CHECKI
POPJ P,
COUNT: 0
FLAG: 0
INDEX: 0
LIMIT: 0
DATA1: 0 ;ptr to real data
DATA2: 0 ;ptr to imaginary data
X=SP
Y=FLP
;;;transpose array
TPOS: MOVE A,DATA1
HRRM A,TR1
HRRM A,TR2
HRRM A,TR3
MOVE A,DATA2
HRRM A,TI1
HRRM A,TI2
HRRM A,TI3
SETZB D,TT
SETZB X,Y
TPLOP: MOVEI T,(D)
ADDI T,(Y)
MOVEI T3,(TT)
ADDI T3,(X)
TR1: MOVE A,(T)
TI1: MOVE B,(T)
TR2: EXCH A,(T3)
TI2: EXCH B,(T3)
TR3: MOVEM A,(T)
TI3: MOVEM B,(T)
ADD TT,NN
AOJ Y,
CAIGE Y,(X)
JRST TPLOP
SETZB Y,TT
AOJ X,
ADD D,NN
CAMGE X,NN
JRST TPLOP
POPJ P,
RTBL: R1
R2
R3
R4
R5
R6
R7
R8
R9
R10
R11
TBLSIZ==.-RTBL
;;;note: rtbl and itbl must be of same length
ITBL: I1
I2
I3
I4
I5
I6
I7
I8
I9
I10
I11
SNAME: .ATOM SINTBL
CNAME: .ATOM COSTBL
TYPE: .ATOM FLONUM
FINIT: MOVEM D,LASTNN
FLOAT D
MOVEM D,FLTNN ;float<nn>
LDB TT,[330700,,D]
SOJ TT,
MOVEM TT,LN ;save log<nn>
;;;calculate required length of sintbl & costbl
MOVE TT,NN
LSH TT,-1
AOJ TT,
PUSH FXP,TT
MOVEI FREEAC,(FXP)
MOVEI TT,FINIT1
PUSH P,TT
PUSH P,SNAME
PUSH P,TYPE
PUSH P,FREEAC
MOVNI T,3
JCALL 16,.FUNCTION *MAKE-ARRAY
FINIT1: MOVEI TT,FINIT2
PUSH P,TT
PUSH P,CNAME
PUSH P,TYPE
PUSH P,FREEAC
MOVNI T,3
JCALL 16,.FUNCTION *MAKE-ARRAY
FINIT2: SUB FXP,[1,,1]
;;;fill costbl and sintbl arrays (need only 0-pi)
MOVE TT,TWPI
FDVR TT,FLTNN
MOVEM TT,STEP
MOVN TT,NN
ASH TT,-2 ;-nn/4
SOJ TT,
HRLZI FREEAC,(TT)
SETZ TT,
PUSH FLP,TT
QUAD1: MOVEI A,(FLP)
NCALL 1,.FUNCTION SIN
EXCH TT,FREEAC
MOVEM FREEAC,@ .ARRAY SINTBL
MOVE FREEAC,TT
MOVEI A,(FLP)
NCALL 1,.FUNCTION COS
EXCH TT,FREEAC
MOVEM FREEAC,@ .ARRAY COSTBL
MOVE FREEAC,TT
MOVE TT,STEP
FADRM TT,(FLP)
AOBJN FREEAC,QUAD1
SUB FLP,[1,,1]
MOVN TT,NN
ASH TT,-2
HRLI FREEAC,(TT)
MOVEI TT,1
QUAD2: MOVE T,@ .ARRAY COSTBL
EXCH FREEAC,TT
MOVEM T,@ .ARRAY SINTBL
EXCH FREEAC,TT
MOVE T,@ .ARRAY SINTBL
EXCH FREEAC,TT
MOVNM T,@ .ARRAY COSTBL
EXCH FREEAC,TT
AOJ TT,
AOBJN FREEAC,QUAD2
MOVE TT,NN
LSH TT,-2
SETZB TT,@ .ARRAY COSTBL
POPJ P,
TWPI: 6.283185307
TOPSTR: 0
LASTNN: 0 ;last value of nn
ABJPTR: 0 ;aobjn ptr for data
NN: 0 ;number of points to transform (must be power of 2)
LN: 0 ;log base 2 of nn
FLTNN: 0 ;floating pt version of nn
STEP: 0 ;step size (in floating pt. radians)
CYCLES==FLP
FPERC==FXP
ICS==SP
XX==T4
YY==T5
K==P3
TRANS: MOVEI CYCLES,1
MOVE FPERC,NN
LSH FPERC,-1
MOVEI ICS,2
MOVE K,LN ;log nn
JFCL 17,.+1 ;clear PC flags
RANK: SETZB P4,P2
SETZM TOPSTR
MOVEI P1,(CYCLES) ;bottom of first btrfly
MOVEI YY,(CYCLES) ;count cycles
RANK1: MOVEI XX,(FPERC) ;count btrflies
FFTCOS: MOVE A,COSINE(P4) ;get cosine
FFTSIN: MOVE B,SINE(P4) ;IFT --> MOVN B,SINE(P4)
RANK2:
R1: MOVE T1,REAL(P1)
FMPR T1,A
I1: MOVE T2,IMAG(P1)
FMPR T2,B
FSBR T1,T2
R2: MOVE T2,REAL(P1)
FMPR T2,B
I2: MOVE T3,IMAG(P1)
FMPR T3,A
FADR T2,T3
JFCL 10,RANK6 ;test for arithmetic underflow
RANK3:
R3: MOVNM T1,REAL(P1)
I3: MOVNM T2,IMAG(P1)
R4: EXCH T1,REAL(P2)
I4: EXCH T2,IMAG(P2)
R5: FADRM T1,REAL(P2)
JFCL 10,[ SETZM @R5
JRST I5]
I5: FADRM T2,IMAG(P2)
JFCL 10,[ SETZM @I5
JRST R6]
R6: FADRM T1,REAL(P1)
JFCL 10,[ SETZM @R6
JRST I6]
I6: FADRM T2,IMAG(P1)
JFCL 10,[ SETZM @I6
JRST RANK4]
RANK4: ADDI P2,(ICS) ;do next
ADDI P1,(ICS)
SOJG XX,RANK2
ADDI P4,(FPERC) ;do next cycle
AOS P1,TOPSTR ;start of next cycle
MOVEI P2,(P1)
ADDI P1,(CYCLES) ;bottom
SOJG YY,RANK1
LSH CYCLES,1 ;2*cycles
LSH ICS,1 ;2*ics
LSH FPERC,-1 ;fperc/2
SOJG K,RANK ;do ln ranks
MOVE T2,FFTSIN
TLNN T2,010000 ;ift?
POPJ P,
;;;ift --> normalize transform
MOVE T2,FLTNN
MOVE T4,ABJPTR
RANK5: MOVE T1,T2
R10: EXCH T1,REAL(T4)
R11: FDVRM T1,REAL(T4)
JFCL 10,[ SETZM @R11
JRST RNK51]
RNK51: MOVE T1,T2
I10: EXCH T1,IMAG(T4)
I11: FDVRM T1,IMAG(T4)
JFCL 10,[ SETZM @I11
JRST RNK52]
RNK52: AOBJN T4,RANK5
POPJ P,
;;;Overflow flag set. Make sure it really was underflow and then repeat the
;;;computation at RANK2 checking each step along the way
RANK6: PUSH P,T
JSP T,RANK7
POP P,T
JRST RANK3
RANK7: TLNN T,100
.VALUE
MOVE T1,@R1
FMPR T1,A
JFCL 10,[ MOVEI T1,
JRST RNK71]
RNK71: MOVE T2,@I1
FMPR T2,B
JFCL 10,[ MOVEI T2,
JRST RNK72]
RNK72: FSBR T1,T2
JFCL 10,[ MOVEI T1,
JRST RNK73]
RNK73: MOVE T2,@R2
FMPR T2,B
JFCL 10,[ MOVEI T2,
JRST RNK74]
RNK74: MOVE T3,@I2
FMPR T3,A
JFCL 10,[ MOVEI T3,
JRST RNK75]
RNK75: FADR T2,T3
JFCL 10,[ MOVEI T2,
JRST (T)]
JRST (T)
REVBS: MOVEI T5,2*36.
SUB T5,LN
MOVE T4,ABJPTR
REVB: MOVEI T1,(T4)
SETZ T1+1,
CIRC T1,(T5)
CAIL T1+1,(T4)
JRST CONT
R7: MOVE T1,REAL(T4)
R8: EXCH T1,REAL(T1+1)
R9: MOVEM T1,REAL(T4)
I7: MOVE T1,IMAG(T4)
I8: EXCH T1,IMAG(T1+1)
I9: MOVEM T1,IMAG(T4)
CONT: AOBJN T4,REVB
POPJ P,
ARRAY1: 0
ARRAY2: 0
.ENTRY COMPLEX-TO-POLAR SUBR 0
MOVEM A,ARRAY1
MOVEM B,ARRAY2
CALL 1,.FUNCTION ARRAYDIMS
NCALL 1,.FUNCTION LENGTH
MOVE A,ARRAY1
MOVE B,ARRAY2
CAIN TT,2
JRST 1DCTP
CAIN TT,3
JRST 2DCTP
BARF BAD ARRAY DIMENSIONS (COMPLEX-TO-POLAR)
1DCTP: MOVEI TT,-1
MOVE FREEAC,@1(A) ;dimension
JRST CTP1
2DCTP: MOVEI TT,-2
MOVE FREEAC,@1(A) ;x dimension
MOVEI TT,-1
IMUL FREEAC,@1(A) ;times y dimension
CTP1: JFCL 17,.+1 ;clear PC flags
MOVNI FREEAC,(FREEAC) ;negate it
MOVSI FREEAC,(FREEAC) ;finally... an aobjn ptr
CTP2: MOVEI TT,(FREEAC)
MOVE D,@1(A)
PUSH FLP,D
FMPR D,D
JFCL 10,[ SETZ D,
JRST CTP3]
CTP3: MOVE TT,@1(B)
PUSH FLP,TT
FMPR TT,TT
FADR TT,D
JFCL 10,[ SETZ TT,
JRST CTP4]
CTP4: CAMG TT,[0.000000000001]
JRST CTP5
PUSH FLP,TT
MOVEI A,(FLP)
NCALL 1,.FUNCTION SQRT
MOVEI B,-2(FLP)
MOVEI A,-1(FLP)
PUSH FLP,TT
NCALL 2,.FUNCTION ATAN
MOVE D,TT
MOVE A,ARRAY1
MOVE B,ARRAY2
MOVEI TT,(FREEAC)
MOVEM D,@1(B)
MOVE D,(FLP)
MOVEM D,@1(A)
SUB FLP,[4,,4]
AOBJN FREEAC,CTP2
POPJ P,
CTP5: MOVEI TT,(FREEAC)
SETZM @1(A)
SETZM @1(B)
SUB FLP,[2,,2]
AOBJN FREEAC,CTP2
POPJ P,
.ENTRY POLAR-TO-COMPLEX SUBR 0
MOVEM A,ARRAY1
MOVEM B,ARRAY2
CALL 1,.FUNCTION ARRAYDIMS
NCALL 1,.FUNCTION LENGTH
MOVE A,ARRAY1
MOVE B,ARRAY2
CAIN TT,2
JRST 1DPTC
CAIN TT,3
JRST 2DPTC
BARF BAD ARRAY DIMENSIONS (POLAR-TO-COMPLEX)
1DPTC: MOVEI TT,-1
MOVE FREEAC,@1(A) ;dimension
JRST PTC1
2DPTC: MOVEI TT,-2
MOVE FREEAC,@1(A) ;x dimension
MOVEI TT,-1
IMUL FREEAC,@1(A) ;times y dimension
PTC1: JFCL 17,.+1 ;clear PC flags
MOVNI FREEAC,(FREEAC) ;negate it
MOVSI FREEAC,(FREEAC) ;finally... an aobjn ptr
PTC2: MOVEI TT,(FREEAC)
MOVE D,@1(A)
PUSH FLP,D
MOVE TT,@1(B)
PUSH FLP,TT
MOVEI A,(FLP)
NCALL 1,.FUNCTION COS
FMPR TT,-1(FLP)
JFCL 10,[ SETZ TT,
JRST PTC3]
PTC3: PUSH FLP,TT
MOVEI A,-1(FLP)
NCALL 1,.FUNCTION SIN
FMPR TT,-2(FLP)
JFCL 10,[ SETZ TT,
JRST PTC4]
PTC4: MOVE D,TT
MOVE A,ARRAY1
MOVE B,ARRAY2
MOVEI TT,(FREEAC)
MOVEM D,@1(B)
MOVE D,(FLP)
MOVEM D,@1(A)
SUB FLP,[3,,3]
AOBJN FREEAC,PTC2
POPJ P,
FASEND

30
src/libdoc/filbit.1 Executable file
View File

@@ -0,0 +1,30 @@
;; -*-Mode:LISP; Author:RWK-*-
(herald FILBIT /1)
(or (get 'UMLMAC 'VERSION)
(load '((LISP) UMLMAC FASL)))
;; Return the modes a file was opened in (whether file is open or not).
(defun filemodes (file)
(let ((modes (arraycall fixnum file 8.))
(outlist))
(if (zerop (logand modes (lsh #o400000 18.)))
(push 'BLOCK outlist)
(push 'SINGLE outlist))
(if (not (zerop (logand modes (lsh #o20000 18.))))
(push 'APPEND outlist))
(if (not (zerop (logand modes (lsh #o40 18.))))
(push 'CLA outlist))
(if (zerop (logand modes #o2))
(push 'DSK outlist)
(push 'TTY outlist))
(if (zerop (logand modes #o1))
(push 'IN outlist)
(push 'OUT outlist))
(caseq (ldb #o0202 modes)
(0 (push 'ASCII outlist))
(1 (push 'FIXNUM outlist))
(2 (push 'IMAGE outlist)))
outlist))

45
src/libdoc/fload.rich1 Executable file
View File

@@ -0,0 +1,45 @@
(defun LET macro (s)
(cons (cons 'lambda
(cons (mapcar 'car (cadr s))
(cddr s)))
(mapcar 'cadr (cadr s))))
(declare (special defun))
(defun FLOAD fexpr (filespec)
;; given filespec of FASL file, first FASLOAD it in
;; then compare creation dates with corresponding EXPR (assuming
;; second file name >) and if it is more recent,
;; LOAD it in with DEFUN=T and snap uuolinks
;; returns name of last file loaded
(let ((faslfile (mergef (mergef filespec (cons '* 'fasl)) defaultf))
(exprfile (probef (mergef (mergef (cons '* '>) filespec) defaultf))))
(cond ((probef faslfile)
(load faslfile)
(cond ((ledit-olderp faslfile exprfile)
(let ((defun t))(load exprfile))
(sstatus uuolinks)
(and (< (cadr (status uuolinks)) 10.)
(princ '|;Warning - down to less than 10 uuolinks.|))
exprfile)
(faslfile)))
(t (load exprfile)
exprfile))))
(defun CLOAD fexpr (filespec)
;; for ease of conversion from old LEDIT
(let ((defun t))
(load (mergef (mergef filespec (cons '* '>)) defaultf))))
(defun LEDIT-AGELIST (file)
((lambda (plist)
(nconc (get plist 'credate)(get plist 'cretime)))
(car (directory (list file) '(credate cretime)))))
(defun LEDIT-OLDERP (file1 file2)
(do ((age1 (ledit-agelist file1)(cdr age1))
(age2 (ledit-agelist file2)(cdr age2)))
((null age1) nil)
(cond ((< (car age1)(car age2))(return t))
((> (car age1)(car age2))(return nil)))))

60
src/libdoc/fontrd.baker1 Executable file
View File

@@ -0,0 +1,60 @@
;;; This file contains functions for hacking Font files
;;; in KST format.
;;; Submitted by Henry G. Baker, Jr.
(defun let macro (form)
(cons (cons 'lambda (cons (cadr form) (cdddr form)))
(caddr form)))
(defun ^ macro (a)
;;; define logical "and" function.
(append '(boole 1.) (cdr a)))
(declare (fixnum n i j))
(defun readfont (font)
;;; "font" is an atom filename used by newio.
;;; For example, |fonts;30vr kst|.
;;; Readfont also returns its argument as its value.
;;; Readfont gives this atom the following properties:
;;; kstid;
;;; column-position-adjustment;
;;; base-line;
;;; height;
;;; width.
;;; "width" property is fixnum array of 128. entries
;;; giving width of each character in the font.
;;; For example, after doing (readfont '|fonts;30vr kst|),
;;; (arraycall fixnum (get '|fonts;30vr kst| 'width) 65.)
;;; returns the width of capital "A".
(let (fontfile width)
((open font '(in fixnum))
(*array nil 'fixnum 128.))
(putprop font width 'width)
(putprop font (in fontfile) 'kstid)
(let (n)((in fontfile))
(putprop font (^ (lsh n -27.) 511.) 'column-position-adjustment)
(putprop font (^ (lsh n -18.) 511.) 'base-line)
(putprop font (^ n (1- (lsh 1. 18.))) 'height))
(do ((i (in fontfile) i))
((= i -1.))
(let (char)((^ (in fontfile) 127.))
(store (arraycall fixnum width char)
(^ (in fontfile) (1- (lsh 1. 18.))))
(do ((j (in fontfile) (in fontfile)))
((oddp j) (setq i j)))))
(close fontfile))
font)
(declare (fixnum s l) (notype w))
(defun flatlength (arg font)
;;; compute the length of arg in the font "font".
(let (s w l)
((flatc arg) (get font 'width) 0.)
(do ((i 1. (1+ i)))
((> i s) l)
(setq l
(+ l (arraycall fixnum w (getcharn arg i)))))))

275
src/libdoc/for.info Executable file
View File

@@ -0,0 +1,275 @@
;;;-*-Lisp-*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ITERATION FUNCTIONS ;;;
;;; Peter Szolovits (PSZ @ MIT-ML) ;;;
;;; July 16, 1976 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; revised by PSZ & RAMESH on Mar. 22, 1979 ;;;
;;; revised by LH@MIT-ML on May 9, 1979 ;;;
;;; revised again by BYRON@MIT-ML on July 12, 1979 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;This package defines a set of functions to provide an
;;;approximation of INTERLISP's iteration statement facility
;;;within a MACRO package for MACLISP.
;;;
;;;
;;;For the simplest exposition of its use and utility, here are
;;;a few examples of how the iterations statements may be used:
;;;
;;; (FOR I FROM 1 TO 3 COLLECT I) ==> (1 2 3)
;;;
;;; (COLLECT (CONS I X) FOR X IN '(A B C D E) AS I BY 3)
;;; ==> ((1 . A) (4 . B) (7 . C) (10 . D) (13 . E))
;;;
;;; (UNLESS (ATOM X) JOIN X FOR X IN '((A B C) (D E) F (G)))
;;; ==> (A B C D E G)
;;;
;;; (FOR X ON '(A B C D) AS I FROM 1 ADJOIN (PRINT I) X)
;;; 1
;;; 2
;;; 3
;;; 4
;;; ==> (A B C D B C D C D D)
;;;
;;; (FIRST (SETQ FOO '(A B (C D) E))
;;; WHILE (ATOM (CAR FOO)) DO (SETQ FOO (CDR FOO)) (PRINT FOO))
;;; (B (C D) E)
;;; ((C D) E)
;;; ==> NIL
;;;
;;; (BIND X (FOO '(A B (C D) E))
;;; WHILE (ATOM (SETQ X (CAR FOO)))
;;; COLLECT (SETQ FOO (CDR FOO)) (CONS X X))
;;; ==> ((A . A) (B . B))
;;;
;;; (FOR X IN '(A B C D) FIRST-TIME (MEMQ X '(E F G C 1 2 3)))
;;; ==> (C 1 2 3)
;;;
;;;FOR now supports LET-type "destructuring" wherever variables are
;;; explicitly bound (by BIND, FOR, or AS) so:
;;;
;;; (FOR (X Y) IN '((1 2) (3 4)) COLLECT (+ X Y) ==> (3 7)
;;;
;;; (BIND ((X Y) '(2 4)) FOR I FROM 1 TO 2 COLLECT (+ X Y I)) ==> (7 8)
;;;
;;*page
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GENERAL DESCRIPTION ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; An ITERATION is a convenient manner of writing a complex
;;;LISP looping expression when control is desired of various
;;;aspects of the iteration which make the system-provided
;;;functions (e.g., MAPCAR, DO) too rigid or too cumbersome.
;;;
;;; An iteration statement consists of a number of clauses,
;;;described below, written in succession within a single S-EXPR.
;;;
;;; Every iteration has at most one MAIN CLAUSE, which
;;;controls what, if anything, is collected as the result of the
;;;iteration. The default provided main clauses are:
;;;
;;; DO (or DOING) -- evaluated for side-effect only; return is
;;; NIL.
;;; COLLECT -- A list of the values of every evaluation of the
;;; main clause is returned (c.f. MAPCAR).
;;; JOIN -- The values of every evaluation of the main clause
;;; are NCONCed together to form the value (c.f.
;;; MAPCAN).
;;; ADJOIN -- Like JOIN, but joining is by APPEND rather than
;;; NCONC. Every joined segment is copied exactly
;;; once, even if there is only one segment.
;;; COUNT -- The number of non-NIL values of the evaluations of
;;; the main clause is returned.
;;; SUM -- The sum of the values of the evaluations of the main
;;; clause is returned.
;;; FIRST-TIME -- The value of the iteration is the first
;;; non-NIL value of the main clause, and iteration
;;; terminates when and if this occurs.
;;; PRINT (or PRINTING) -- PRINT's the values of the evaluations
;;; of the main clause.
;;; RESULT -- Sets the RESULT variable to the value of the expression
;;; and exits.
;;;
;;;Other main clauses may be added. Each must be signalled by a
;;;keyword marked by the !FUNCTION property with an appropriate
;;;function to fill in the iteration template for it.
;;;
;;;
;;; The binding of LOOP VARIABLES and AUXILLIARY VARIABLES is
;;;controlled by the BIND, FOR and AS clauses. The BIND keyword is
;;;followed by the variables or (variable initial-val) or
;;;(variable-structure initial-val) <as in LET> forms to be
;;;bound. Those variables are bound, and the initial-vals are evaluated
;;;before any of the bindings for this iteration. The FOR and AS
;;;clauses are equivalent and provide a way to have several loop
;;;variables. The keyword is followed by the name of the variable, and
;;;optionally by FIXNUM, FLONUM, or NOTYPE. NOTYPE is the default
;;;except for numeric (FROM, TO, DOWNTO, BY) variables, for which it is
;;;FIXNUM. An appropriate declaration to the compiler is made. The rest
;;;of each variable clause has one of the following forms:
;;;
;;; FROM e1 TO e2 BY e3 -- This is the numeric iteration clause.
;;; Its terms may appear in any order. Instead of
;;; the TO, we may have a DOWNTO term to indicate
;;; that the loop is for decrementing the var. FROM
;;; defaults to 1, BY to 1 with TO and -1 with
;;; DOWNTO. Incrementing is assumed if neither is
;;; stated. (Currently, no checking is performed to
;;; see that the types of args are consistent, and
;;; the type of arithmetic used is determined by the
;;; type specified. NOTYPE implies general
;;; arithmetic, and the default is FIXNUM.)
;;; IN list -- This is iteration over a list. The var gets
;;; successive elements of the list.
;;; ON list -- This is iteration over successive tails of the
;;; list.
;;; STARTING e1 STEPPING e2 -- This is a general form for giving
;;; initial and incremental values. The terms may
;;; be in either order. STARTING defaults to NIL,
;;; and if STEPPING is omitted, no stepping action
;;; is set up.
;;; TRAILING v1, or TRAILS v1 -- The iteration variable will take on the
;;; value that v1 had on the previous iteration. V1 should
;;; be some other iteration variable of this iteration. On
;;; the first iteration, since there is no previous value of
;;; v1, we use NIL.
;;; SET-TO e1, or = e1 -- On each iteration, e1 is evaluated and
;;; assigned to the variable. This is most useful when e1
;;; is expressed in terms of some other iteration
;;; variable(s). E1 is always computed in terms of the new
;;; values of the iteration variables, not the old.
;;; BEING pathname OF e1, or
;;; BEING e1 AND ITS pathname -- These are the exclusive and
;;; inclusive forms of the PATH ITERATION.
;;; Pathnames must be explicitly marked by the
;;; !PATH-FUNCTION property with a function to
;;; process them. This is a special feature, most
;;; useful for LMS and OWL, and in this package
;;; there are no paths defined by default. The
;;; keyword ALONG is synonymous with BEING. Note
;;; that there are variants of these subclauses, not
;;; described here, that are specifically tailored
;;; for iterating through the objects in a zone of
;;; an LMS node; these variants are recognized by
;;; the fact that EACH occurs where the pathname or
;;; ITS would normally have occurred.
;;;
;;; The sub-keywords like FROM, IN, etc., are recognized by having an
;;;!ITER-FUNCTION property; thus, others may be added to the package.
;;;
;;; TERMINATION CLAUSES allow specification of additional
;;; iteration termination conditions beyond any that are
;;; implied by FOR and AS clauses. The following exist:
;;;
;;; WHILE e1 -- e1 is evaluated at the beginning of each
;;; iteration, and the iteration terminates when e1
;;; is NIL.
;;; UNTIL e1 -- like WHILE but terminates when e1 is non-NIL.
;;; REPEAT-WHILE e1 -- e1 is evaluated at the end of each
;;; iteration, and the iteration terminates when e1
;;; is NIL; this guarantees at least one
;;; iteration.
;;; REPEAT-UNTIL e1 -- like REPEAT-WHILE but terminates when e1 is
;;; non-NIL.
;;;
;;;
;;; A SELECTION-CLAUSE is a filter on which iteration the
;;;main clause should be evaluated. A conjunction is implied if more
;;; than one selection exists. The following exist:
;;; WHEN e1 -- The main clause is evaluated if e1 is non-NIL.
;;; UNLESS e1 -- The main clause is evaluated if e1 is NIL.
;;;
;;;
;;; The PERIPHERAL CLAUSES are of three kinds:
;;;
;;; FIRST e1 -- Evaluates e1 after initially binding the vars
;;; but before starting the first iteration.
;;; FINALLY e1 -- Evaluates e1 after exiting the last iteration
;;; but before returning the answer. If the main
;;; clause is a value-returning clause, the result
;;; to be returned is in the variable RESULT (see notes).
;;; EACH-TIME e1 -- Evaluates e1 on every iteration of the loop,
;;; whether or not the selection test is passed.
;;;
;;*page
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CAVEATS ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;
;;; A few notes should be made about implementation features
;;;which affect the evaluation of iteration forms:
;;;
;;; 1. Like in the LISP DO, initialization and updating of the
;;;iteration variables takes place in parallel. Only SET-TO varaibles
;;;and their internally generated equivalents (e.g., "X in Y") are done
;;;after the others, and these should never lead to trouble. This is a
;;;significant change from earlier versions of the FOR package.
;;;
;;; 2. The iteration statement is translated to a LISP DO. In
;;;particular, this means that a (RETURN val) form may be
;;;evaluated at any place to return that particular val as the
;;;value of the iteration. If it is desired that any FINALLY
;;;clauses be evaluated and the value returned, then the
;;; following may be done:
;;; (SETQ RESULT val), if appropriate and if the main clause
;;; is value-returning
;;; (TERMINATE-ITERATION)
;;;Note that the RESULT clause may be used in many cases where this is
;;;desired.
;;;
;;; 3. Wherever possible, the order of evaluation of
;;;expressions whose evaluation order is not otherwise
;;;constrained is that suggested by the order of writing them in
;;;the iteration statement. This is only of significance if
;;;significant use of side effects is made.
;;;
;;; 4. Wherever a single expression may appear, more than one
;;;may appear. They will be implicitly surrounded by a PROGN,
;;;so all but the last will be evaluated for side effect only.
;;;
;;; 5. The name RESULT, in which the value of value-collecting
;;;iterations is built up, is selected only by default. If the
;;;value of the variable !RESULT-NAME is bound, that will be
;;;used instead.
;;;
;;; 6. Almost no error checking is currently done, so it is
;;;possible to get weird errors if the iterative statement is
;;;not well-formed.
;;;
;;; 7. This code is written using (I think) only one macro,
;;;!PUSH, which is not part of the standard LISP complement.
;;;!PUSH is defined herein to be equivalent to PUSH with its
;;;arguments reversed, except that it only works for simple
;;;(atomic) variables.
;;;
;;; 8. For efficiency, translations produced by these macros
;;;are saved in the array !MACRO-EXPANSIONS and further calls on
;;;the same form are translated by retrieval rather than
;;;recomputation. This, however, may cause some problems: For
;;;efficiency considerations (i.e., SXHASH or EQUAL are slow),
;;;retrieval is done by EQ comparison on the form. Thus, if the
;;;form has been edited since its original translation, an
;;;incorrect translation will be retrieved. Further, since all
;;;translated forms are referred to from !MACRO-EXPANSIONS, many
;;;un-garbage-collectable obsolete copies of a form can be
;;;retained during debugging runs. (E.g., if one keeps
;;;redefining some function which includes macro calls. For
;;;anyone who thinks they can solve this problem by retrieval on
;;;the MAKNUM of the form or by making the array untraced by the
;;;GC, be warned that either "fix" causes mis-translations.) The
;;;function !MACRO-FLUSH is provided to flush all existing
;;;translations and guarantee that new translations of all these
;;;macro forms are made. This also releases for
;;;garbage-collection all the "old" forms which are only pointed
;;;at by this translation mechanism.

1149
src/libdoc/for.psz7 Executable file
View File

File diff suppressed because it is too large Load Diff

307
src/libdoc/gcdemn.999999 Executable file
View File

@@ -0,0 +1,307 @@
;;; GCDEMN -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ******* Standard GC-DAEMON function ************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
;; Note that "HERALD" call is below, to insure that the addition
;; to GC-DAEMON has occured before the VERSION property is put
;; (HERALD GCDEMN /14)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is a dynamic garbage collector daemon which tries to predict
;;; consing in the various spaces based on past performance and thus to
;;; set space sizes such that garbage collection is minimized.
;;;
;;; The algorithm is from Henry Baker and the program is his with minor
;;; modifications. JONL maintained Baker's code between 1978 and 1980,
;;; and PSZ made significant modifications on July 12, 1980. GSB added
;;; some type-declarations, and added a separater gc-statistics print
;;; switch on Feb 6, 1981; GSB and JONL added some efficiency hacks
;;; to do less consing on Feb 6-7, 1981, and to use HERALD
;;; GSB hacked the gc-statistics print switch to be more usable Feb. 19,
;;; 1981; the variable GC-DAEMON-PRINT should have as its value a variable
;;; which will be SYMEVALed to see if the gc-daemon should print statistics.
;;; By default its value is ^D, causing the gc-daemon to print statistics
;;; when the Lisp gc does.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; For historical purposes, the original CGOL code is reproduced
;;; here as commentary. All running code is now in LISP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (cgol)
;;
;; declare(muzzled(t)) % Shut up about closed compilation. %
;;
;; % GC-daemon for optimal allocation. %
;; % Described in AI Working Paper #142. %
;; % set "alloc-mark-ratio" to a flonum between 0.2 and 5.0. %
;;
;; sstatus(who1,42.,"%",118.,0.) % Set up "who" line on tv's. %
;; sstatus(gcwho,3.)
;; who3 := "GCDEMN"
;;
;; % Initialize property lists of space names. %
;; let gc_daemon=
;; '\spacelist;
;; (let alloct=nil.alloc(t);
;; for element in spacelist
;; do (let space = car(element),
;; freebefore = cadr(element),
;; freeafter = caddr(element),
;; sizebefore = cadddr(element),
;; sizeafter = car(cddddr(element));
;; % Initialize state of each space for gc-daemon. %
;; accessible ofq space := sizeafter-freeafter;
;; % Make sure that we don't get a gc-overflow interrupt. %
;; alloc([space,[max(512.,car(space of alloct) or sizeafter),
;; 262143.,
;; if sizeafter>0 then 32. else 0.]])))'
;; in gc()
;;
;; alloc_mark_ratio := 1.0 
;;
;; special alloc_mark_ratio
;;
;; define "GC-DAEMON" (spacelist);
;; let total_accessible = 0.0,
;; total_consed = 0.0;
;; % Go through spaces and accumulate consed and accessible
;; information. %
;; for element in spacelist % Argument is "alist" of spaces. %
;; do (let space = car(element), % Give names to parameters. %
;; freebefore = cadr(element),
;; freeafter = caddr(element),
;; sizebefore = cadddr(element),
;; sizeafter = car(cddddr(element));
;; % Compute consed since last gc and accessible now for this space. %
;; consed ofq space := sizebefore-freebefore-accessible ofq space;
;; total_consed := total_consed + consed ofq space;
;; accessible ofq space := sizeafter-freeafter;
;; total_accessible := total_accessible + accessible ofq space);
;; % Store total consed, total accessible and compute total free. %
;; consed ofq 'total_storage' := total_consed;
;; accessible ofq 'total_storage' := total_accessible;
;; let total_free = alloc_mark_ratio * total_accessible;
;; free ofq 'total_storage' := total_free;
;; % Go through spaces and re-allocate where necessary. %
;; for element in spacelist
;; do (let space = car element;
;; alloc_rate ofq space := consed ofq space / total_consed;
;; free ofq space := fix(total_free * alloc_rate ofq space);
;; let spcsize = accessible ofq space + free ofq space + 511.;
;; if spcsize>511. then alloc([space,[spcsize,262143.,32.]]))
;;
;; gc_daemon := 'gc_daemon'
;;
;; =exit
(declare (setq USE-STRT7 T)
(special GCDEMN-SETUP-1/|) )
(defvar ALLOC-MARK-RATIO 1.0)
(defvar FILL-STORAGE-FRACTION 0.5)
; We SYMEVAL this to see if we want to print statistics.
(defvar GC-DAEMON-PRINT '^D)
(eval-when (eval compile)
(defmacro fix-to-float (x)
`(float (fixnum-identity ,x)))
(defmacro float-to-fix (x)
`(ifix (flonum-identity ,x)))
(defmacro defmaxmin (max-name min-name type
&aux (v1 (gensym)) (v2 (gensym)))
`(progn 'compile
(defmacro ,max-name (arg1 arg2)
(list '(lambda (,v1 ,v2)
(declare (,type ,v1 ,v2))
(cond ((> ,v1 ,v2) ,v1) (t ,v2)))
arg1 arg2))
(defmacro ,min-name (arg1 arg2)
(list '(lambda (,v1 ,v2)
(declare (,type ,v1 ,v2))
(cond ((< ,v1 ,v2) ,v1) (t ,v2)))
arg1 arg2))))
(defmaxmin max$ min$ flonum)
(defmaxmin max% min% fixnum)
)
(defun GC-DAEMON-PRINT (space cons-rate oldgcsize marked gcsize spcsize)
;; We print for each non-empty space the following information:
;; CONS-RATE The % of conses since the last GC which were for
;; this space.
;; OLDGCSIZE Size of the space in words before GC.
;; MARKED Number of words marked as "in use" by GC.
;; GCSIZE Size in words recommended by daemon.
;; SPCSIZE (if present) Actual size of space if different from size.
((lambda (base *nopoint f)
(setq cons-rate (fix (*$ cons-rate 100.0)))
(and (< (linel f)
(+ (flatc space) (flatc cons-rate) (flatc oldgcsize)
(flatc marked) (flatc gcsize) (flatc spcsize) 10.
(charpos f)))
(princ '|
; | msgfiles))
(princ space msgfiles)
(princ '| | msgfiles)
(princ cons-rate msgfiles)
(princ '|%[| msgfiles)
(princ oldgcsize msgfiles)
(princ '|->| msgfiles)
(princ marked msgfiles)
(princ '|//| msgfiles)
(princ gcsize msgfiles)
(cond ((not (= spcsize gcsize))
(princ '|//| msgfiles) (princ spcsize msgfiles)))
(princ '|] | msgfiles))
10. t (cond ((or (memq tyo msgfiles) (and (not ^w) (memq t msgfiles)))
tyo)
((car (delq t (append msgfiles nil))))
(t tyo))))
(DEFUN BAKER-GC-DAEMON (SPACELIST)
((LAMBDA (RUNTIME TOTAL-ACCESSIBLE TOTAL-CONSED MEMFREE)
(declare (fixnum runtime) (flonum total-accessible total-consed))
(MAPC
(FUNCTION
(LAMBDA (ELEMENT)
((LAMBDA (SPACE FREEBEFORE FREEAFTER SIZEBEFORE SIZEAFTER)
; No point in declarations, they only pessimize the compiler,
; in this case.
(PUTPROP SPACE (- SIZEBEFORE FREEBEFORE (GET SPACE 'ACCESSIBLE))
'CONSED)
(SETQ TOTAL-CONSED (+$ TOTAL-CONSED (fix-to-float (GET SPACE 'CONSED))))
(PUTPROP SPACE (- SIZEAFTER FREEAFTER) 'ACCESSIBLE)
(SETQ TOTAL-ACCESSIBLE (+$ TOTAL-ACCESSIBLE
(fix-to-float (GET SPACE 'ACCESSIBLE)))))
(CAR ELEMENT) (CADR ELEMENT) (CADDR ELEMENT)
(CADDDR ELEMENT) (CAR (CDDDDR ELEMENT)))))
SPACELIST)
(PUTPROP 'TOTAL-STORAGE TOTAL-CONSED 'CONSED)
(PUTPROP 'TOTAL-STORAGE TOTAL-ACCESSIBLE 'ACCESSIBLE)
((LAMBDA (TOTAL-FREE alloct ALLOC-LIST
ALLOC-LIST-1 SPACE-HACK SPACE-HACK-1)
(declare (flonum total-free))
(PUTPROP 'TOTAL-STORAGE TOTAL-FREE 'FREE)
(and (symeval gc-daemon-print)
((lambda (base *nopoint)
; Kludge: if the GC printed, we do NOT want an extra newline; but
; if it do not, we need to print one ourselves.
(or ^d (terpri msgfiles))
(princ '|;GC-DAEMON: cons-rate%[oldgcsize->marked//gcsize//spcsize]
; Consed=|
msgfiles)
(princ (fix total-consed) msgfiles)
(princ '|, Marked=| msgfiles)
(princ (fix total-accessible) msgfiles)
(princ '|, Allocated//Marked=| msgfiles)
(princ alloc-mark-ratio msgfiles)
(princ '|, Memfree= | msgfiles)
(princ memfree msgfiles)
(princ '|
; | msgfiles))
10. t))
(MAPC
(FUNCTION
(LAMBDA (ELEMENT)
((LAMBDA (SPACE)
((lambda (alloc-rate)
(declare (flonum alloc-rate))
(putprop space alloc-rate 'alloc-rate)
(putprop space (fix (*$ total-free alloc-rate)) 'free))
(//$ (fix-to-float (get space 'consed)) total-consed))
((LAMBDA (SPCSIZE)
(declare (fixnum spcsize))
(and (symeval gc-daemon-print)
(get alloct space)
(gc-daemon-print
space
(get space 'alloc-rate)
(car (get alloct space))
(get space 'accessible)
(* 512. (// spcsize 512.))
(status spcsize space)))
(COND ((GREATERP SPCSIZE 511.)
(OR ALLOC-LIST
(SETQ ALLOC-LIST
(LIST NIL (SETQ ALLOC-LIST-1
(LIST NIL 262143. NIL)))
SPACE-HACK
(LIST 'SPCSIZE
(CONS 'QUOTE (SETQ SPACE-HACK-1
(LIST NIL))))))
(rplaca space-hack-1 space)
(RPLACA
(CDDR (RPLACA ALLOC-LIST-1
(max% SPCSIZE
(apply 'status space-hack))))
(cond ((eq space 'list) 200.) (t 32.)))
(ALLOC (RPLACA ALLOC-LIST SPACE)))))
(+ (GET SPACE 'ACCESSIBLE) (GET SPACE 'FREE) 511.)))
(CAR ELEMENT))))
SPACELIST)
(and (symeval gc-daemon-print) (terpri msgfiles)))
(min$ (*$ ALLOC-MARK-RATIO TOTAL-ACCESSIBLE)
(*$ (fix-to-float memfree) fill-storage-fraction))
(cons nil (alloc t)) NIL NIL NIL NIL)
; Finally, add our runtime into the total gc-time.
(setq runtime (- (status gctime) runtime))
(sstatus gctime (+ (runtime) runtime))
)
(runtime) 0.0 0.0 (status memfree)))
;; This function takes relatively little space, in comparison to all that
;; needed for the names of the variables used. If run as expr code,
;; these symbols would never go away.
(defun GCDEMN-SETUP-1/| (x)
(let (((space freebefore freeafter sizebefore sizeafter) x))
;;The variable GCDEMN-SETUP-1/| has been set to `(() ,.(alloc t))
(putprop space (- sizeafter freeafter) 'ACCESSIBLE)
(let ((spacesize (or (car (get GCDEMN-SETUP-1/| space))
sizeafter))
(spacemin (cond ((not (> sizeafter 0)) () )
((eq space 'LIST) 200.)
(32.))))
(if (< spacesize 512.) (setq spacesize 512.))
(alloc `(,space (,spacesize 262143. ,spacemin))))))
(cond
;;If this file is loaded more than once, then don't 'push' onto
;; the GC-DAEMON variable again.
((or (get 'GCDEMN 'VERSION) (eq gc-daemon 'baker-gc-daemon)))
(T (cond ((status SSTATUS GCWHO)
(sstatus WHO1 42. '% 118. 0.)
(sstatus GCWHO 3.)
(sstatus WHO3 'GCDEMN) ))
;;; Initially set things up
(let ((GCDEMN-SETUP-1/| `(() ,.(alloc t)))
(GC-DAEMON #'(lambda (z) (mapc #'GCDEMN-SETUP-1/| z))) )
(gc))
(setq GC-DAEMON
(cond ((null GC-DAEMON) 'BAKER-GC-DAEMON)
((let ((x (gensym)))
`(LAMBDA (,x)
(,.(cond ((or (symbolp gc-daemon)
(and (not (atom gc-daemon))
(eq (car gc-daemon) 'LAMBDA)))
`(,gc-daemon))
(`(FUNCALL ',gc-daemon)))
,x)
(BAKER-GC-DAEMON ,x)))))) ))
(herald GCDEMN /14)

285
src/libdoc/genfns.71 Executable file
View File

@@ -0,0 +1,285 @@
;;; GENFNS -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ****** LISP FUNCTIONS ENUMERATOR (GENFNS) ******
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
;;; To use this file, simply get a current LISP, load this file in,
;;; and do (GENFNS). It will then produce the summary file QIOORD
;;; Its purpose is to produce a listing of all function names and
;;; variables in the initial LISP; for output, it will make the file
;;; .INFO.;QIOORD verno on ITS systems
;;; <MACLISP>QIOORD.DOC.verno on DEC20 systems
;;; LISP:QIOORD.DOC on DEC10 systems
;;; DSK:[MAC,LSP]QIOORD.DOC on the SAIL system
;;; To write onto another file, do (GENFNS (DEV USR) FN1 FN2)
(DECLARE (SPECIAL * + - ^R ^W BASE QUUX CHRCT OUTFILES
UWRITE LINEL ALLSTATUSOPS)
(*FEXPR GENFNS)
(*EXPR *GENFNS PRINCRUFT PRINPROPS GETVALUES PRIN10 2PRIN10)
(*LEXPR LINEL)
(FIXNUM I J NL NC MX SP))
(SSTATUS FEATURE NOLDMSG)
(DEFUN GENFNS FEXPR (V)
(LET ((^R 'T) (^W 'T) (DEFAULTF DEFAULTF))
(COND (V
(SETQ V (NAMELIST V))
(APPLY 'UWRITE (CAR V))
(*GENFNS)
(APPLY 'UFILE (CDR V)))
((STATUS FEATURE ITS)
(UWRITE DSK /.INFO/.)
(*GENFNS)
(APPLY 'UFILE `(QIOORD ,(status lispversion))))
((STATUS FEATURE DEC20)
(UWRITE DSK MACLISP)
(*GENFNS)
(APPLY 'UFILE `((DSK MACLISP) QIOORD DOC ,(status lispversion))))
((COND ((STATUS FEATURE SAIL) (UWRITE DSK (MAC LSP)) 'T)
((STATUS FEATURE DEC10) (UWRITE LISP) 'T))
(*GENFNS)
(UFILE QIOORD DOC)))))
(MAPC (FUNCTION (LAMBDA (X) (PUTPROP X 'LAP 'FUNNYFN)))
'(*DELQ *DELETE *APPEND *TIMES *GREAT *LESS
*PLUS *NCONC *APPLY *EVAL *PRINT
*PRIN1 *PRINC *TERPRI *TYO GETDDTSYM
LAPSETUP/| TTSR/| LH/|
SQOZ/| PUTDDTSYM GCPROTECT
GETMIDASOP PURCOPY PURIFY
FASLAPSETUP/| PAGEBPORG))
(MAPC (FUNCTION (LAMBDA (X) (PUTPROP X 'LAP 'FUNNYVAR)))
'(*PURE PURCLOBRL PURE TTSR/| LAPSETUP/|
PUTPROP BPORG BPEND GCPROTECT))
(DEFUN INTERNAL-TEST (X)
(COND ((GETL X '(FUNNYFN FUNNYVAR)) () )
((GET X 'INTERNAL-TEST))
((OR (AND (EQ (GETCHAR X 1) '+)
(MEMQ (GETCHAR X 2) '(I /i))
(MEMQ (GETCHAR X 3) '(N /n))
(MEMQ (GETCHAR X 4) '(T /t))
(MEMQ (GETCHAR X 5) '(E /e))
(MEMQ (GETCHAR X 6) '(R /r))
(MEMQ (GETCHAR X 7) '(N /n))
(MEMQ (GETCHAR X 8) '(A /a))
(MEMQ (GETCHAR X 9) '(L /l))
(EQ (GETCHAR X 10.) '/-))
(LET ((N (FLATC X)))
(DO I 1 (1+ I) (> I N)
(AND (MEMQ (GETCHAR X I) '(/| | | |`| |,|))
(RETURN 'T)))))
(PUTPROP X 'INTERNAL-TEST 'T)
'T)))
(SETQ ALLSTATUSOPS '(
+ ABBREVIATE ARRAY BPSH BPSL BREAK CHTRAN CLI CRFIL
CRUNIT DATE DAYTIME DIVOV DOW EVALHOOK FASLOAD FEATURE
FILEMODE FLPDL FLUSH FTV FTVSIZE FTVTITLE FXPDL GCMAX
GCMIN GCSIZE GCTIME GCWHO HACTRN HOMEDIR HSNAM ITS JCL
JNAME JNUMBER LINMODE LISPVERSION LOSEF MACRO MAR MEMFREE
NEWLINE NOFEATURE OSPEED PDL PDLMAX PDLNAMES PDLROOOM
PDLSIZE PUNT PURSIZE PURSPACENAMES RANDOM SEGLOG SPCNAMES
SPCSIZE SPDL SSTATUS STATUS SUBSYS SYNTAX SYSTEM TABSIZE
TERPRI TOPLEVEL TTY TTYCONS TTYINT TTYREAD TTYSCAN TTYSIZE
TTYTYPE UDIR UNAME UREAD USERI UUOLINKS UWRITE WHO1 WHO2
WHO3 XUNAM _
))
(MAPC '(LAMBDA (X) ((LAMBDA (Y) (COND ((CDDDDR Y) ;PDP-10 ONLY
(RPLACD (CDDDDR Y) NIL)
(PUTPROP (IMPLODE Y) X 'STATUSOP))))
(EXPLODEN X)))
ALLSTATUSOPS)
(DEFUN PRIN10 (X) ((LAMBDA (BASE *NOPOINT) (PRINC X)) 10. T))
(DEFUN 2PRIN10 (X)
((LAMBDA (BASE *NOPOINT)
(PRINC (// X 10.))
(PRINC (\ X 10.)))
10. T))
(DEFUN PHLATC (F X)
(COND (F (FLATC X))
((+ 2 (FLATC (CAR X))))))
(DEFUN PRINCRUFT (M L)
(PROG (MX NL NC AT LL)
(COND (L (SETQ L (COND ((SETQ AT (ATOM (CAR L)))
(SORT L (FUNCTION ALPHALESSP)))
((SORTCAR L (FUNCTION ALPHALESSP)))))
(TERPRI)
(TERPRI)
(PRINC M)
(TERPRI)
(TERPRI)
(SETQ MX (DO ((X L (CDR X))
(I 0 (MAX I (PHLATC AT (CAR X)))))
((NULL X) I)))
(SETQ NL (// LINEL (+ MX 4)))
(SETQ NC (// (+ (LENGTH L) (1- NL)) NL))
(DO ((I NL (1- I)))
((PROG2 (SETQ LL (CONS L LL)) (= I 1)))
(DO ((J NC (1- J)))
((OR (NULL L) (ZEROP J)))
(SETQ L (CDR L))))
(SETQ LL (NREVERSE LL))
(DO ((I NC (1- I)) (SP 0 0))
((ZEROP I))
(MAP (FUNCTION (LAMBDA (X)
(COND ((CAR X)
(PRINC '| |)
(DO ((J SP (1- J)))
((ZEROP J))
(PRINC '| |))
(COND (AT (PRINC (CAAR X)))
(T (PRINC (CDAAR X))
(PRINC '| |)
(PRINC (CAAAR X))))
(SETQ SP (- MX (PHLATC AT (CAAR X))))
(RPLACA X (CDAR X))))))
LL)
(TERPRI))))))
(DEFUN *GENFNS NIL
(PROG (DATE TIME USRSUBRS USRLSUBRS USRFSUBRS LAPFNS INTFNS STATUSOPS
SYSVARS LAPVARS SYSARRAYS USERAUTOS SYSAUTOS PMFLAG)
(TERPRI)
(COND ((STATUS FEATURE ITS) (PRINC '|ITS |))
((STATUS FEATURE DEC20) (PRINC '|TOPS-20//TENEX |))
((STATUS FEATURE SAIL) (PRINC '|SAIL |))
((STATUS FEATURE CMU) (PRINC '|CMU |))
((STATUS FEATURE TOPS-10) (PRINC '|TOPS-10 |)))
(PRINC '|MacLISP |)
(PRINC (STATUS LISPVERSION))
(PRINC '| Functions and Other Features|)
(TERPRI)
(PRINC '|This file was created by |)
(PRINC (STATUS USERID))
(PRINC '| on |)
(DO ((X (EXPLODEN (STATUS DOW)) (CDR X))
(N 0 40))
((NULL X))
(TYO (+ (CAR X) N)))
(PRINC '|, |)
(SETQ DATE (STATUS DATE))
(PRINC (DO ((I (CADR DATE) (1- I))
(L '(|January| |February| |March| |April| |May| |June|
|July| |August| |September| |October|
|November| |December|)
(CDR L)))
((= I 1) (CAR L))))
(PRINC '| |)
(PRIN10 (CADDR DATE))
(PRINC '|, 19|)
(PRIN10 (CAR DATE))
(SETQ TIME (STATUS DAYTIME))
(PRINC '| at |)
(AND (> (CAR TIME) 11.)
(RPLACA TIME (- (CAR TIME) 12.))
(SETQ PMFLAG T))
(AND (ZEROP (CAR TIME)) (RPLACA TIME '0))
(PRIN10 (CAR TIME))
(PRINC '|:|)
(2PRIN10 (CADR TIME))
(COND (PMFLAG (PRINC '| PM|))
((PRINC '| AM|)))
(TERPRI)
(SETQ LINEL (LINEL (OR UWRITE TYO)))
(MAPATOMS (FUNCTION
(LAMBDA (QUUX)
((LAMBDA (F V)
(MAPCAR (FUNCTION (LAMBDA (P)
(COND ((MEMQ P '(SUBR FSUBR LSUBR))
(COND ((EQ F 'LAP) (PUSH QUUX LAPFNS))
((INTERNAL-TEST QUUX) (PUSH QUUX INTFNS))
((EQ P 'SUBR) (PUSH QUUX USRSUBRS))
((EQ P 'FSUBR) (PUSH QUUX USRFSUBRS))
((EQ P 'LSUBR) (PUSH QUUX USRLSUBRS)) ))
((EQ P 'VALUE)
(COND ((EQ V 'LAP) (PUSH QUUX LAPVARS))
(T (PUSH QUUX SYSVARS))))
((EQ P 'ARRAY) (PUSH QUUX SYSARRAYS))
((EQ P 'AUTOLOAD)
(COND ((INTERNAL-TEST QUUX)
(PUSH QUUX SYSAUTOS))
((PUSH QUUX USERAUTOS))) ))))
(STATUS SYSTEM QUUX)))
(GET QUUX 'FUNNYFN)
(GET QUUX 'FUNNYVAR)))))
(MAPC (FUNCTION (LAMBDA (X)
(AND (APPLY 'STATUS (LIST 'STATUS X))
(PUSH (CONS (OR (GET X 'STATUSOP)
((LAMBDA (Y)
(COND ((CDDDDR Y) ;PDP-10 ONLY
(IMPLODE (APPEND Y '(/ ?))))
(T X)))
(EXPLODEN X)))
(COND ((APPLY 'STATUS
(LIST 'SSTATUS X))
'*)
(T '/ )))
STATUSOPS))))
(STATUS STATUS))
(PRINCRUFT '|User SUBRs:| USRSUBRS)
(PRINCRUFT '|User FSUBRs:| USRFSUBRS)
(PRINCRUFT '|User LSUBRs:| USRLSUBRS)
(PRINCRUFT '|STATUS options (* = can use with SSTATUS too):| STATUSOPS)
(PRINCRUFT '|Initial arrays:| SYSARRAYS)
(PRINPROPS '|Initial User AUTOLOAD properties:|
(MAPCAR (FUNCTION (LAMBDA (X)
(CONS X (GET X 'AUTOLOAD))))
USERAUTOS))
(PRINCRUFT '|LAP and FASLOAD functions:| LAPFNS)
(PRINCRUFT '|Internal system functions:| INTFNS)
(PRINPROPS '|Internal system AUTOLOAD properties:|
(MAPCAR (FUNCTION (LAMBDA (X)
(CONS X (GET X 'AUTOLOAD))))
SYSAUTOS))
(PRINPROPS '|System variables:| (GETVALUES SYSVARS))
(PRINPROPS '|LAP and FASLOAD variables:| (GETVALUES LAPVARS))
))
(DEFUN GETVALUES (X)
((LAMBDA (^R ^W * + - OUTFILES DEFAULTF UREAD UWRITE)
(MAPCAR (FUNCTION (LAMBDA (Y)
(CONS Y
(COND ((BOUNDP Y)
(SYMEVAL Y))
(T 'UNBOUND)))))
X))
NIL NIL '* '+ '- NIL '((DSK LOSER) @ @) NIL NIL))
(DEFUN PRINPROPS (M L)
(COND (L (SETQ L (SORTCAR L (FUNCTION ALPHALESSP)))
(TERPRI)
(TERPRI)
(PRINC M)
(TERPRI)
(TERPRI)
(PRINC '| NAME OF ATOM INITIAL VALUE|)
(TERPRI)
(TERPRI)
(DO ((X L (CDR X)))
((NULL X))
(PRINC '| |)
(PRIN1 (CAAR X))
(DO ((I (- 32. (CHARPOS (OR UWRITE T))) (1- I)))
((NOT (PLUSP I)))
(DECLARE (FIXNUM I))
(PRINC '| |))
(PRINC '| |)
(PRIN1 (CDAR X))
(TERPRI)))))

40
src/libdoc/getsyn.rlb3 Executable file
View File

@@ -0,0 +1,40 @@
;-*-LISP-*-
; getsyntax SUBR 2 args
;
; (getsyntax c s) returns information about the syntax of the character
; c in the readtable. c can be a fixnum which is the Ascii code for a char,
; or it can be a character object. s is a symbol selecting which information is
; required.
; SYNTAX - the syntax bits are returned as a fixnum.
; SINGLE - if the syntax of c is that for single character objects,
; T is returned; otherwise, NIL.
; MACRO - if c is a macro character, the function is returned.
; SPLICING - if c is a splicing macro character, the function is
; returned.
; CHTRAN - returns a character object which is the chtran of c .
;;;This really should be in MacLISP!
(declare (eval (read)))
(setsyntax '/ 'macro '(lambda () ((lambda (ibase) (read)) 8.)))
(defun getsyntax (c s)
((lambda (c syn mac)
(setq syn (status syntax (+ c 0)) mac (status macro (+ c 0)))
(caseq s
(syntax syn)
(single (= syn 600500))
(macro (and (= 0 (boole 1 40 syn)) mac))
(splicing (and (= 40 (boole 1 40 syn)) mac))
(chtran (ascii (status chtran (+ c 0))))
(T (getsyntax c (error '|Bad option - GETSYNTAX| s
'wrng-type-arg)))))
(do c c c nil
(caseq (typep c)
(fixnum (return c))
(symbol (return (getcharn c 1)))
(T (setq c (error '|Bad character type - GETSYNTAX|
c 'wrng-type-arg)))))
nil nil))
(declare (eval (read))) (setsyntax '/ 'macro nil)

190
src/libdoc/graph$.gjc1 Executable file
View File

@@ -0,0 +1,190 @@
;;;-*-LISP-*-
;;; A graphics utility package. - George Carrette.
;; Floating-point graphics window.
(eval-when (eval compile)
(or (get 'graphm 'version)
(load (list (car (namelist infile)) 'graphm))))
(graphs-module graph$)
;;; This is general code for dealing with floating point windows.
;;; It will handle scaling and clipping.
;;; ________
;;; y1 - | |
;;; | |
;;; | |
;;; y0 - --------
;;; ' '
;;; x0 x1
(defun graphics-stream NARGS
(COMMENT (ARG 1) = GRAPHICS-STREAM
(ARG 2) = COMMAND
(ARG 3) = X1
(ARG 4) = Y1
(ARG 5) = X2
(ARG 6) = Y2)
(LET ((GRAPHICS-STREAM (ARG 1)))
(LET ((WINDOW (GRAPHICS-STREAM-WINDOW))
(VIEWPORT (GRAPHICS-STREAM-VIEWPORT))
(SCALING-COEF (GRAPHICS-STREAM-SCALING-COEF))
(WLAST-POS (GRAPHICS-STREAM-WLAST-POS))
(OUT-STREAM (GRAPHICS-STREAM-OUT-STREAM)))
(caseq (ARG 2)
((move-pen)
(NARG-CHECK NARGS 4 'GRAPHICS-STREAM)
(CALL GRAPHICS-STREAM
'draw-line
(wlast-pos-x wlast-pos)
(wlast-pos-y wlast-pos)
(ARG 3) (ARG 4)))
((draw-point)
(NARG-CHECK NARGS 4 'GRAPHICS-STREAM)
(UNLESS (out-of-windowp (ARG 3) (ARG 4))
(CALL out-stream
'draw-point
(scale-x (ARG 3))
(scale-y (ARG 4))))
(update-wlast-pos (ARG 3) (ARG 4)))
((draw-line)
(NARG-CHECK NARGS 6 'GRAPHICS-STREAM)
(draw-line-clip-X0 (ARG 3) (ARG 4) (ARG 5) (ARG 6))
(update-wlast-pos (ARG 5) (ARG 6)))
((set-pen)
(NARG-CHECK NARGS 4 'GRAPHICS-STREAM)
(update-wlast-pos (ARG 3) (ARG 4)))
((tyo)
(NARG-CHECK NARGS 3 'GRAPHICS-STREAM)
(graphics-stream-tyo out-stream (ARG 3)))
((init-scaling)
(NARG-CHECK NARGS 2 'GRAPHICS-STREAM)
(graph$-set-scaling))
((set-window)
(NARG-CHECK NARGS 6 'GRAPHICS-STREAM)
(setf (window-x0 window) (float (or (ARG 3) (window-x0 window))))
(setf (window-x1 window) (float (or (ARG 4) (window-x1 window))))
(setf (window-y0 window) (float (or (ARG 5) (window-y0 window))))
(setf (window-y1 window) (float (or (ARG 6) (window-y1 window))))
(CALL GRAPHICS-STREAM 'init-scaling))
((window)
(NARG-CHECK NARGS 2 'GRAPHICS-STREAM)
(list (window-x0 window)
(window-x1 window)
(window-y0 window)
(window-y1 window)))
((viewport)
(NARG-CHECK NARGS 2 'GRAPHICS-STREAM)
(list (viewport-x0 viewport)
(viewport-x1 viewport)
(viewport-y0 viewport)
(viewport-y1 viewport)))
((set-viewport)
(NARG-CHECK NARGS 6 'GRAPHICS-STREAM)
(setf (viewport-x0 viewport) (ifix (or (ARG 3) (viewport-x0 viewport))))
(setf (viewport-x1 viewport) (ifix (or (ARG 4) (viewport-x1 viewport))))
(setf (viewport-y0 viewport) (ifix (or (ARG 5) (viewport-y0 viewport))))
(setf (viewport-y1 viewport) (ifix (or (ARG 6) (viewport-y1 viewport)))))
((which-operations)
(NARG-CHECK NARGS 2 'GRAPHICS-STREAM)
'(tyo set-pen move-pen init-scaling window
viewport set-window set-viewport set-clippingp break))
((break)
(*break t "graphics"))
(t
(UNKNOWN-COMMAND (ARG 2) 'GRAPHICS-STREAM))))))
(defun out-of-windowp (x y)
(or (< x (window-x0 window))
(> y (window-x1 window))
(< x (window-y0 window))
(> y (window-y1 window))))
(defun update-wlast-pos (x y)
(setf (wlast-pos-x wlast-pos) x)
(setf (wlast-pos-y wlast-pos) y)
nil)
(declare (flonum (y-intercept flonum flonum flonum flonum flonum)))
;;; Y - YB YB - YA (XA - X) YB + (X - XB) YA
;;; ------ = ------- [Y = - -------------------------]
;;; X - XB XB - XA XB - XA
(defun y-intercept (XA YA XB YB X)
(//$ (+$ (*$ (-$ XA X) YB)
(*$ (-$ X XB) YA))
(-$ XA XB)))
(DEFUN DRAW-LINE-CLIP-X0 (XA YA XB YB &AUX (V (WINDOW-X0 WINDOW)))
(COND ((< XA V)
(COND ((< XB V))
(T
(DRAW-LINE-CLIP-X1 V (Y-INTERCEPT XA YA XB YB V) XB YB))))
((< XB V)
(DRAW-LINE-CLIP-X1 XA YA V (Y-INTERCEPT XA YA XB YB V)))
(T
(DRAW-LINE-CLIP-X1 XA YA XB YB))))
(DEFUN DRAW-LINE-CLIP-X1 (XA YA XB YB &AUX (V (WINDOW-X1 WINDOW)))
(COND ((> XA V)
(COND ((> XB V))
(T
(DRAW-LINE-CLIP-Y0 V (Y-INTERCEPT XA YA XB YB V) xb yb))))
((> XB V)
(DRAW-LINE-CLIP-Y0 XA YA V (Y-INTERCEPT XA YA XB YB V)))
(T
(DRAW-LINE-CLIP-Y0 XA YA XB YB))))
(DEFUN DRAW-LINE-CLIP-Y0 (XA YA XB YB &AUX (V (WINDOW-Y0 WINDOW)))
(COND ((< YA V)
(COND ((< YB V))
(T
(DRAW-LINE-CLIP-Y1 (X-INTERCEPT XA YA XB YB V) V XB YB))))
((< YB V)
(DRAW-LINE-CLIP-Y1 XA YA (X-INTERCEPT XA YA XB YB V) V))
(T
(DRAW-LINE-CLIP-Y1 XA YA XB YB))))
(DEFUN DRAW-LINE-CLIP-Y1 (XA YA XB YB &AUX (V (WINDOW-Y1 WINDOW)))
(COND ((> YA V)
(COND ((> YB V))
(T
(DRAW-LINE-GO (X-INTERCEPT XA YA XB YB V) V XB YB))))
((> YB V)
(DRAW-LINE-GO XA YA (X-INTERCEPT XA YA XB YB V) V))
(T
(DRAW-LINE-GO XA YA XB YB))))
(DEFUN DRAW-LINE-GO (XA YA XB YB)
(CALL OUT-STREAM 'DRAW-LINE (SCALE-X XA)(SCALE-Y YA)
(SCALE-X XB)(SCALE-Y YB)))
(defun make-graphics-stream (out-stream)
(let ((u (make-graphics-stream-1 out-stream out-stream)))
(lexpr-funcall #'set-viewport u (call out-stream 'boundaries))
u))
;;; V = K * W + M K=(v1-v0) / (w1-w0)
;;; M= v0 - K * w0
;;; the question is when to do the IFIX. For the convenience of having
;;; all the coeff flonum I will do it at then end.
(defun graph$-set-scaling ()
(setf (scaling-coef-k-x scaling-coef)
(//$ (float (- (viewport-x1 viewport) (viewport-x0 viewport)))
(-$ (window-x1 window) (window-x0 window))))
(setf (scaling-coef-m-x scaling-coef)
(-$ (float (viewport-x0 viewport))
(*$ (scaling-coef-k-x scaling-coef) (window-x0 window))))
(setf (scaling-coef-k-y scaling-coef)
(//$ (float (- (viewport-y1 viewport) (viewport-y0 viewport)))
(-$ (window-y1 window) (window-y0 window))))
(setf (scaling-coef-m-y scaling-coef)
(-$ (float (viewport-y0 viewport))
(*$ (scaling-coef-k-y scaling-coef) (window-y0 window))))
t)

340
src/libdoc/graph3.gjc1 Executable file
View File

@@ -0,0 +1,340 @@
;;;-*-LISP-*-
;;; A graphics utility package. - George Carrette.
;;; 3-D graphics.
(eval-when (eval compile)
(or (get 'graphm 'version)
(load (list (car (namelist infile)) 'graphm))))
(graphs-module graph3)
;;; in this stream the eye is looking down on the X-Y plane.
;;; here is a picture where it is looking right, down on the X-axis.
;;;
;;; ^
;;; | * |
;;; | | |
;;; | | |
;;; | | X-AXIS
;;; | | |
;;; | | |
;;; Z | | |
;;; eye <------Z-AXIS----------------|-------------#-
;;; | |
;;; z-screen z-clip
;;;
;;;
;;; lines are clipped at z-clip
;;; V = T (V1 - V0) + V0
;;;
;;; [X, Y, Z] = [T (X1 - X0) + X0, Y0 + T (y1 - Y0), T (Z1 - Z0) + Z0]
;;;
;;; X0 (Z - Z1) + X1 (Z0 - Z) Y0 (Z - Z1) + Y1 (Z0 - Z)
;;; X = - -------------------------, Y = - -------------------------
;;; Z1 - Z0 Z1 - Z0
;;;
(defun z-clip-stream NARGS
(COMMENT (ARG 1) = Z-CLIP-STREAM
(ARG 2) = COMMAND
(ARG 3) = X
(ARG 4) = Y
(ARG 5) = Z)
(LET ((Z-CLIP-STREAM (ARG 1)))
(LET ((OUT-STREAM (Z-CLIP-STREAM-OUT-STREAM))
(3D-CLIP (Z-CLIP-STREAM-3D-CLIP)))
(caseq (ARG 2)
((move-pen)
(NARG-CHECK NARGS 5 'Z-CLIP-STREAM)
(let ((z0 (3d-clip-z 3d-clip))
(x0 (3d-clip-x 3d-clip))
(y0 (3d-clip-y 3d-clip))
(clip (3d-clip-clip 3d-clip)))
(cond ((> z0 clip)
;; left point must clipped.
(cond ((> (ARG 5) clip)
;; whole line is clipped.
nil)
(t
(CALL out-stream
'set-pen
(x-intercept3 z0 x0 (ARG 5) (ARG 3) clip)
(y-intercept3 z0 y0 (ARG 5) (ARG 4) clip)
clip)
(CALL out-stream
'move-pen (ARG 3)(ARG 4)(ARG 5)))))
((> (ARG 5) clip)
;; right point must be clipped.
(CALL out-stream 'set-pen x0 y0 z0)
(CALL out-stream
'move-pen
(x-intercept3 z0 x0 (ARG 5) (ARG 3) clip)
(y-intercept3 z0 y0 (ARG 5) (ARG 4) clip)
clip))
(t
(CALL out-stream 'set-pen x0 y0 z0)
(CALL out-stream 'move-pen (ARG 3) (ARG 4) (ARG 5)))))
(alter-3d-clip 3d-clip
x (ARG 3)
y (ARG 4)
z (ARG 5))
t)
((set-pen)
(NARG-CHECK NARGS 5 'Z-CLIP-STREAM)
(alter-3d-clip 3d-clip
x (ARG 3)
y (ARG 4)
z (ARG 5))
t)
((set-clip-z)
(NARG-CHECK NARGS 3 'Z-CLIP-STREAM)
(setf (3d-clip-clip 3d-clip) (ARG 3))
t)
(T
(UNKNOWN-COMMAND (ARG 2) 'Z-CLIP-STREAM))))))
(defun make-z-clip-stream (out-stream)
(make-z-clip-stream-1 out-stream out-stream))
;;; Z - Z X Z - Z
;;; EYE SCREEN SCREEN EYE SCREEN
;;; -------------- = ------- X = (----------------) X
;;; Z - Z X SCREEN Z - Z
;;; EYE EYE
;;;
(declare (flonum (x-screen flonum flonum flonum flonum)))
(defun x-screen (z-eye z-screen z x)
(//$ (*$ (-$ z-eye z-screen) x)
(-$ z z-eye)))
(defun z-perspective-stream NARGS
(COMMENT (ARG 1) = Z-PERSPECTIVE-STREAM
(ARG 1) = COMMAND
(ARG 3) = X
(ARG 4) = Y
(ARG 5) = Z)
(LET ((Z-PERSPECTIVE-STREAM (ARG 1)))
(let ((out-stream (z-perspective-stream-out-stream))
(perspective (z-perspective-stream-perspective)))
(caseq (ARG 2)
((move-pen set-pen)
(NARG-CHECK NARGS 5 'Z-PERSPECTIVE-STREAM)
(let ((z-eye (3d-perspective-z-eye perspective))
(z-screen (3d-perspective-z-screen perspective)))
(CALL out-stream (ARG 2)
(x-screen z-eye z-screen (ARG 5) (ARG 3))
(y-screen z-eye z-screen (ARG 5) (ARG 4)))))
((set-z-eye)
(NARG-CHECK NARGS 3 'Z-PERSPECTIVE-STREAM)
(setf (3d-perspective-z-eye perspective) (ARG 3))
t)
((set-z-screen)
(NARG-CHECK NARGS 3 'Z-PERSPECTIVE-STREAM)
(setf (3d-perspective-z-screen perspective) (ARG 3))
t)
(T
(UNKNOWN-COMMAND (ARG 2) 'Z-PERSPECTIVE-STREAM))))))
(defun make-z-perspective-stream (out-stream)
(make-z-perspective-stream-1 Out-stream out-stream))
;;; orthogonal rotation by the eulerian angles. The convention
;;; here is from Goldstein, Classical Mechanics, a worthy source.
;;; [ COS(PHI) SIN(PHI) 0 ]
;;; [ ]
;;; D = [ - SIN(PHI) COS(PHI) 0 ]
;;; [ ]
;;; [ 0 0 1 ]
(defun phi-matrix (phi &optional
(m (make-3matrix))
&aux (cos-phi (cos phi)) (sin-phi (sin phi)))
(alter-3matrix m
x-x cos-phi x-y sin-phi x-z 0.0
y-x (-$ sin-phi) y-y cos-phi y-z 0.0
z-x 0.0 z-y 0.0 z-z 1.0)
m)
;;;
;;; [ 1 0 0 ]
;;; [ ]
;;; C = [ 0 COS(THETA) SIN(THETA) ]
;;; [ ]
;;; [ 0 - SIN(THETA) COS(THETA) ]
;;;
(defun theta-matrix (theta &optional
(m (make-3matrix))
&aux
(cos-theta (cos theta))
(sin-theta (sin theta)))
(alter-3matrix m
x-x 1.0 x-y 0.0 x-z 0.0
y-x 0.0 y-y cos-theta y-z sin-theta
z-x 0.0 z-y (-$ sin-theta) z-z cos-theta)
m)
;;;
;;; [ COS(PSI) SIN(PSI) 0 ]
;;; [ ]
;;; B = [ - SIN(PSI) COS(PSI) 0 ]
;;; [ ]
;;; [ 0 0 1 ]
(defun psi-matrix (psi &optional
(m (make-3matrix))
&aux
(cos-psi (cos psi))
(sin-psi (sin psi)))
(alter-3matrix m
x-x cos-psi x-y sin-psi x-z 0.0
y-x (-$ sin-psi) y-y cos-psi y-z 0.0
z-x 0.0 z-y 0.0 z-z 1.0)
m)
(defun 3matrix-mult (ma mb &optional (m (make-3matrix)))
;; this goes to 512 words of pdp10 code. gosh. well, it is fast.
(alter-3matrix m
x-x (3row*col x z ma mb)
x-y (3row*col x y ma mb)
x-z (3row*col x x ma mb)
y-x (3row*col y z ma mb)
y-y (3row*col y y ma mb)
y-z (3row*col y x ma mb)
z-x (3row*col z z ma mb)
z-y (3row*col z y ma mb)
z-z (3row*col z x ma mb))
ma)
(defun orthogonal-3d-stream NARGS
(COMMENT (ARG 1) = orthogonal-3d-stream
(ARG 1) = COMMAND
(ARG 3) = X
(ARG 4) = Y
(ARG 5) = Z)
(LET ((orthogonal-3d-stream (ARG 1)))
(LET ((OUT-STREAM (orthogonal-3d-stream-OUT-STREAM))
(EULER (orthogonal-3d-stream-EULER)))
(caseq (ARG 2)
((move-pen set-pen)
(NARG-CHECK NARGS 5 'orthogonal-3d-stream)
(let ((m (euler-rot euler)))
(CALL out-stream
(ARG 2)
(+$ (*$ (ARG 3) (3matrix-x-x m))
(*$ (ARG 4) (3matrix-x-y m))
(*$ (ARG 5) (3matrix-x-z m)))
(+$ (*$ (ARG 3) (3matrix-y-x m))
(*$ (ARG 4) (3matrix-y-y m))
(*$ (ARG 5) (3matrix-y-z m)))
(+$ (*$ (ARG 3) (3matrix-z-x m))
(*$ (ARG 4) (3matrix-z-y m))
(*$ (ARG 5) (3matrix-z-z m))))))
((translate)
(NARG-CHECK NARGS 2 'orthogonal-3d-stream)
(3matrix-mult (euler-drot euler)
(euler-rot euler)
(euler-rot euler))
t)
((translate-psi)
(NARG-CHECK NARGS 2 'orthogonal-3d-stream)
(3matrix-mult (euler-dpsi euler)
(euler-psi euler)
(euler-psi euler))
(setf (euler-psi-val euler)
(+$ (euler-psi-val euler) (euler-dpsi-val euler)))
(update-rot-matrix))
((translate-theta)
(NARG-CHECK NARGS 2 'orthogonal-3d-stream)
(3matrix-mult (euler-dtheta euler)
(euler-theta euler)
(euler-theta euler))
(setf (euler-theta-val euler)
(+$ (euler-theta-val euler) (euler-dtheta-val euler)))
(update-rot-matrix))
((translate-phi)
(NARG-CHECK NARGS 2 'orthogonal-3d-stream)
(3matrix-mult (euler-dphi euler)
(euler-phi euler)
(euler-phi euler))
(setf (euler-phi-val euler)
(+$ (euler-phi-val euler) (euler-dphi-val euler)))
(update-rot-matrix))
((set-psi)
(NARG-CHECK NARGS 3 'orthogonal-3d-stream)
(alter-euler euler
psi-val (ARG 3)
psi (psi-matrix (ARG 3) (euler-psi euler)))
(update-rot-matrix))
((set-theta)
(NARG-CHECK NARGS 3 'orthogonal-3d-stream)
(alter-euler euler
theta-val (ARG 3)
theta (theta-matrix (ARG 3) (euler-theta euler)))
(update-rot-matrix))
((set-phi)
(NARG-CHECK NARGS 3 'orthogonal-3d-stream)
(alter-euler euler
phi-val (ARG 3)
phi (phi-matrix (ARG 3) (euler-phi euler)))
(update-rot-matrix))
((set-dphi)
(NARG-CHECK NARGS 3 'orthogonal-3d-stream)
(alter-euler euler
dphi-val (ARG 3)
dphi (phi-matrix (ARG 3) (euler-dphi euler)))
(update-drot-matrix))
((set-dpsi)
(NARG-CHECK NARGS 3 'orthogonal-3d-stream)
(alter-euler euler
dpsi-val (ARG 3)
dpsi (psi-matrix (ARG 3) (euler-dpsi euler)))
(update-drot-matrix))
((set-dtheta)
(NARG-CHECK NARGS 3 'orthogonal-3d-stream)
(alter-euler euler
dtheta-val (ARG 3)
dtheta (theta-matrix (ARG 3) (euler-dtheta euler)))
(update-drot-matrix))
((get-angles)
(NARG-CHECK NARGS 2 'orthogonal-3d-stream)
`((psi . ,(euler-psi-val euler))
(theta . ,(euler-theta-val euler))
(phi . ,(euler-phi-val euler))
(dpsi . ,(euler-dpsi-val euler))
(dtheta . ,(euler-dtheta-val euler))
(dphi . ,(euler-dphi-val euler))))
(t
(UNKNOWN-COMMAND (ARG 2) 'orthogonal-3d-stream))))))
;;; rot = psi . theta . phi
(defun update-rot-matrix ()
(let ((m (3matrix-copy (euler-phi euler) (euler-rot euler))))
(3matrix-mult (euler-theta euler) m m)
(3matrix-mult (euler-psi euler) m m)))
(defun update-drot-matrix ()
(let ((m (3matrix-copy (euler-dphi euler) (euler-drot euler))))
(3matrix-mult (euler-dtheta euler) m m)
(3matrix-mult (euler-dpsi euler) m m)))
(defun make-orthogonal-3d-stream (out-stream)
(make-orthogonal-3d-stream-1 out-stream out-stream))

149
src/libdoc/grapha.gjc1 Executable file
View File

@@ -0,0 +1,149 @@
;;;-*-LISP-*-
;;; A graphics utility package. - George Carrette.
;;; ARDS codes.
(eval-when (eval compile)
(or (get 'graphm 'version)
(load (list (car (namelist infile)) 'graphm))))
(graphs-module grapha)
;;; local declarations to eliminate fixnum consing.
(declare (fixnum (ards-basic-1 fixnum)
(ards-basic-2 fixnum))
(*expr (ards-mode-check-out nil fixnum)
(ards-basic-io fixnum fixnum fixnum fixnum)
(ards-basic-io-s fixnum fixnum)
(ards-set-point-out fixnum fixnum)
(ards-long-vector-out fixnum fixnum)
(ards-short-vector-out fixnum fixnum)
(ards-gen-vector fixnum fixnum)))
(defun ards-stream NARGS
(COMMENT (ARG 1) = ARDS-STREAM
(ARG 2) = COMMAND
(ARG 3) = X1
(ARG 4) = Y1
(ARG 5) = X2
(ARG 6) = Y2)
(LET ((ARDS-STREAM (ARG 1)))
(LET ((OUT-STREAM (ARDS-STREAM-OUT-STREAM))
(GRAPHIC-MODE (ARDS-STREAM-GRAPHIC-MODE))
(INVISIBLEP (ARDS-STREAM-INVISIBLEP))
(DOTTEDP (ARDS-STREAM-DOTTEDP))
(LAST-POS (ARDS-STREAM-LAST-POS)))
(caseq (ARG 2)
((move-pen)
(NARG-CHECK NARGS 4 'ARDS-STREAM)
(ards-gen-vector (- (ARG 3) (ards-last-pos-x last-pos))
(- (ARG 4) (ards-last-pos-y last-pos)))
(setf (ards-last-pos-x last-pos) (ARG 3))
(setf (ards-last-pos-y last-pos) (ARG 4))
t)
((vector-pen)
(NARG-CHECK NARGS 4 'ARDS-STREAM)
(ards-gen-vector (ARG 3) (ARG 4))
(setf (ards-last-pos-x last-pos)
(+ (ards-last-pos-x last-pos) (ARG 3)))
(setf (ards-last-pos-y last-pos)
(+ (ards-last-pos-y last-pos) (ARG 4)))
t)
((draw-point)
(NARG-CHECK NARGS 4 'ARDS-STREAM)
(CALL ards-stream 'set-pen (ARG 3) (ARG 4))
(CALL ards-stream 'vector-pen 0 0))
((draw-line)
(NARG-CHECK NARGS 6 'ARDS-STREAM)
(CALL ards-stream 'set-pen (ARG 3) (ARG 4))
(CALL ards-stream 'move-pen (ARG 5) (ARG 6)))
((set-pen)
(NARG-CHECK NARGS 4 'ARDS-STREAM)
(cond ((and (= (ARG 3) (ards-last-pos-x last-pos))
(= (ARG 4) (ards-last-pos-y last-pos))))
(t
(ards-mode-check-out 'set-point #/)
(ards-set-point-out (ARG 3) (ARG 4))
(setf (ards-last-pos-x last-pos) (ARG 3))
(setf (ards-last-pos-y last-pos) (ARG 4))
t)))
((tyo)
(NARG-CHECK NARGS 3 'ARDS-STREAM)
(ards-gen-tyo (ARG 3)))
((SET-DOTTEDP)
(NARG-CHECK NARGS 3 'ARDS-STREAM)
(setf (ards-stream-dottedp) (ARG 3)))
((set-invisiblep)
(NARG-CHECK NARGS 3 'ARDS-STREAM)
(setf (ards-stream-invisiblep) (ARG 3)))
((boundaries)
(list (ards-stream-x-min)
(ards-stream-x-max)
(ards-stream-y-min)
(ards-stream-y-max)))
((which-operations)
(NARG-CHECK NARGS 2 'ARDS-STREAM)
'(tyo set-pen move-pen vector-pen draw-point
set-dottedp set-invisiblep size))
(t
(UNKNOWN-COMMAND (ARG 2) 'ARDS-STREAM))))))
(defun make-ards-stream (s)
(make-ards-stream-1 out-stream s))
(defun ards-mode-check-out (mode signal)
(when (not (eq graphic-mode mode))
(setq graphic-mode mode)
(setf (ards-stream-graphic-mode) mode)
(+tyo (+ signal #o200) OUT-STREAM)))
(defun ards-basic-1 (x)
(+ (lsh (logand (abs x) #o37) 1)
(if (minusp x) 1 0)
#o100))
(defun ards-basic-2 (x)
(+ (logand (lsh (abs x) #o-5) #o37) #o100))
(defun ards-basic-io (x1 x2 y1 y2)
(+tyo x1 OUT-STREAM)
(+tyo x2 OUT-STREAM)
(+tyo y1 OUT-STREAM)
(+tyo y2 OUT-STREAM))
(defun ards-basic-io-s (x1 y1)
(+tyo x1 OUT-STREAM)
(+tyo y1 OUT-STREAM))
(defun ards-set-point-out (x y)
(ards-basic-io (ards-basic-1 x)
(ards-basic-2 x)
(ards-basic-1 y)
(ards-basic-2 y)))
(defun ards-long-vector-out (x y)
(ards-basic-io (ards-basic-1 x)
(+ (ards-basic-2 x) (if invisiblep #o40 0))
(ards-basic-1 y)
(+ (ards-basic-2 y) (if dottedp #o40 0))))
(defun ards-short-vector-out (x y)
(ards-basic-io-s (ards-basic-1 x)
(ards-basic-1 y)))
(defun ards-gen-vector (x y)
(declare (fixnum x y))
(cond ((and (< (abs x) #o40) (< (abs y) #o40) (not invisiblep) (not dottedp))
(ards-mode-check-out 'short-vector #/)
(ards-short-vector-out x y))
(t
(ards-mode-check-out 'long-vector #/)
(ards-long-vector-out x y))))
(defun ards-gen-tyo (C)
(ards-mode-check-out nil #/)
(tyo C OUT-STREAM))

280
src/libdoc/graphm.gjc1 Executable file
View File

@@ -0,0 +1,280 @@
;;;-*-LISP-*-
;;; A graphics utility package. - George Carrette.
;; Macros and compile-time environment.
(herald graphm)
;; A form to put at the begining of the modules.
;; Works if the modules are in the same directory as
;; this macro file.
;;
;;(eval-when (eval compile)
;; (or (get 'graphm 'version)
;; (load (list (car (namelist infile)) 'graphm))))
;;
;; (graphs-module <name>)
(eval-when (eval compile load)
(or (get 'umlmac 'version)
(load '((lisp)umlmac)))
(or (fboundp 'defstruct)
(load (caseq (status opsys)
((tops-20)
"<GJC>struct")
((its)
"liblsp;struct")
(t
(error "unknown opsys" (status opsys) 'fail-act))))))
(defmacro graphs-module (name)
`(progn 'compile
(herald ,name)
(eval-when (eval)
(or (get 'graphs 'version)
(load (list (car (namelist infile)) 'graphs))))
(eval-when (load)
(or (get 'graphs 'version)
(load (list (car (namelist (status fasload))) 'graphs))))))
(defmacro defstream (name &rest slots)
`(defstruct (,name named conc-name default-pointer
(constructor ,(symbolconc 'make- name '-1)))
,@slots))
;; For GRAPHS module:
(when (status feature complr)
(*expr set-pen move-pen vector-pen draw-point
draw-frame NARG-CHECK NARG-ERROR
UNKNOWN-COMMAND
set-viewport get-viewport set-window get-window
call0 call1 call2 call3 call4 call5
graphics-stream-tyo
)
(*lexpr graphics-stream-close graphics-stream-open call
make-broadcast-stream
make-broadcast-sfa
))
(defstream broadcast-stream
out-streams)
(defstruct (graphics-sfa sfa conc-name
(constructor make-graphics-sfa-1))
out-stream)
(defstruct (broadcast-sfa sfa default-pointer conc-name
(constructor make-broadcast-sfa-1))
l)
;; For GRAPHA module.
(WHEN (STATUS FEATURE COMPLR)
(*expr make-ards-stream)
(special out-stream graphic-mode invisiblep
dottedp last-pos
ards-stream))
(defstream ards-stream
(out-stream nil)
(graphic-mode nil)
(invisiblep nil)
(dottedp nil)
(last-pos (make-ards-last-pos))
;; default information for GRAPH$
(X-MIN -400.)
(X-MAX 400.)
(Y-MIN -400.)
(Y-MAX 400.)
)
(defstruct (ards-last-pos fixnum-array conc-name) x y)
;; For GRAPH$ module:
(WHEN (STATUS FEATURE COMPLR)
(SPECIAL GRAPHICS-STREAM WINDOW VIEWPORT SCALING-COEF WLAST-POS
OUT-STREAM)
(flonum (y-intercept flonum flonum flonum flonum flonum))
(*expr y-intercept make-graphics-stream))
(defstream GRAPHICS-STREAM
(window (make-window))
(viewport (make-viewport))
(scaling-coef (make-scaling-coef))
(wlast-pos (make-wlast-pos))
out-stream
)
(defstruct (window flonum-array conc-name)
(x0 -1.0)
(x1 +1.0)
(y0 -1.0)
(y1 +1.0))
(defstruct (viewport fixnum-array conc-name)
(x0 0)
(x1 100)
(y0 0)
(y1 100))
(defstruct (scaling-coef flonum-array conc-name)
k-x k-y m-x m-y)
(defstruct (wlast-pos flonum-array conc-name)
x y)
(defmacro scale (k w m)
`(ifix (+$ (*$ ,k ,w) ,m)))
(defmacro scale-x (x)
`(scale (scaling-coef-k-x scaling-coef)
,x
(scaling-coef-m-x scaling-coef)))
(defmacro scale-y (y)
`(scale (scaling-coef-k-y scaling-coef)
,y
(scaling-coef-m-y scaling-coef)))
(DEFMACRO X-INTERCEPT (A B C D E)
`(Y-INTERCEPT ,B ,A ,D ,C ,E))
;; For GRAPH3 module:
(WHEN (STATUS FEATURE COMPLR)
(SPECIAL Z-CLIP-STREAM OUT-STREAM 3D-CLIP
Z-PERSPECTIVE-STREAM PERSPECTIVE
ORTHOGONAL-3D-STREAM EULER
))
(defstream Z-CLIP-STREAM
out-stream
(3d-clip (make-3d-clip)))
(defstruct (3d-perspective conc-name flonum-array)
z-eye z-screen)
(defstruct (3d-clip conc-name flonum-array)
x y z clip)
(defstream Z-PERSPECTIVE-STREAM
out-stream
(perspective (make-3d-perspective)))
(defmacro x-intercept3 (z0 x0 z1 x1 z)
;; this is not scewed as is the 2-dim case.
`(y-intercept ,z0 ,x0 ,z1 ,x1 ,z))
(defmacro y-intercept3 (z0 y0 z1 y1 z)
`(y-intercept ,z0 ,y0 ,z1 ,y1 ,z))
(defmacro y-screen (z-eye z-screen z y)
`(x-screen ,z-eye ,z-screen ,z ,y)))
(defstruct (3matrix conc-name flonum-array
size-macro)
x-x x-y x-z
y-x y-y y-z
z-x z-y z-z)
(defmacro 3row*col (row col m1 m2)
`(+$ (*$ (,(symbolconc '3matrix- row '-x) ,m1)
(,(symbolconc '3matrix-x- col) ,m2))
(*$ (,(symbolconc '3matrix- row '-y) ,m1)
(,(symbolconc '3matrix-y- col) ,m2))
(*$ (,(symbolconc '3matrix- row '-z) ,m1)
(,(symbolconc '3matrix-z- col) ,m2))))
(defmacro 3matrix-copy (m1 &optional (m2 (make-3matrix)))
`(fillarray ,m2 ,m1))
;; The euler matrix will keep various matricies around so that
;; certain kinds of updates will be efficient.
(defstruct (euler conc-name)
;; matrix used in transformations.
(rot (phi-matrix 0.0))
;; for differential updates of rot.
(drot (phi-matrix 0.0))
; for reference.
(ident (phi-matrix 0.0))
(phi (phi-matrix 0.0))
(phi-val 0.0)
(dphi (phi-matrix 0.0))
(dphi-val 0.0)
(theta (theta-matrix 0.0))
(theta-val 0.0)
(dtheta (theta-matrix 0.0))
(dtheta-val 0.0)
(psi (psi-matrix 0.0))
(psi-val 0.0)
(dpsi (psi-matrix 0.0))
(dpsi-val 0.0))
(defstream orthogonal-3d-stream
out-stream
(euler (make-euler)))
;; For GRAPHT module:
(WHEN (STATUS FEATURE COMPLR)
(*expr make-tek-stream)
(SPECIAL tek-stream VIEWPORT GRAPHIC-OUTPUT))
(defstruct (tek conc-name fixnum-array (default-pointer viewport))
(x-min 0)
(x-max #o1777)
(y-min 0)
(y-max #o1377)
(x-pen 0)
(y-pen 0)
(graphic-mode TEK-GRAPHMODE)
(high-y 0)
(low-y 0)
(high-x 0)
(low-x 0))
(defstream tek-stream
(viewport (make-tek))
(graphic-output))
;; Optimizations.
(DEFPROP CALL (CALL-ST) SOURCE-TRANS)
(DEFUN CALL-ST (FORM)
(LET ((ARG-N (LENGTH (CDDR FORM))))
(IF (> ARG-N 5)
(VALUES FORM NIL)
(VALUES (CONS (CDR (ASSOC ARG-N '((0 . CALL0)
(1 . CALL1)
(2 . CALL2)
(3 . CALL3)
(4 . CALL4)
(5 . CALL5))))
(CDR FORM))
T))))
(DEFPROP NARG-CHECK (NARG-CHECK-ST) SOURCE-TRANS)
(DEFUN NARG-CHECK-ST (FORM)
(IF (TRIVIAL-ARG-LIST? (CDR FORM))
(VALUES `(OR (= ,(CADR FORM) ,(CADDR FORM))
(NARG-ERROR ,@(CDR FORM)))
T)
(VALUES FORM NIL)))
(DEFUN TRIVIAL-ARG-LIST? (L)
(DO ()
((NULL L) T)
(LET ((FORM (POP L)))
(IF (NOT (ATOM FORM))
(IF (NOT (EQ (CAR FORM) 'QUOTE))
(RETURN NIL))))))

314
src/libdoc/graphs.gjc1 Executable file
View File

@@ -0,0 +1,314 @@
;;;-*-LISP-*-
;;; A graphics utility package. - George Carrette.
;;; Reorganized 3:26pm Thursday, 9 July 1981 -GJC
(eval-when (eval compile)
(or (get 'graphm 'version)
(load (list (car (namelist infile)) 'graphm))))
(herald graphs)
;; Autoload definitions:
;; Go to some hair to make sure these are in the directory from
;; which this file is being loaded.
(PUTPROP 'GRAPHS
'(LAMBDA (GRAPHS)
(PUTPROP 'MAKE-ARDS-STREAM (LIST GRAPHS 'GRAPHA)'AUTOLOAD)
(PUTPROP 'MAKE-TEK-STREAM (LIST GRAPHS 'GRAPHT)'AUTOLOAD)
(PUTPROP 'MAKE-GRAPHICS-STREAM (LIST GRAPHS 'GRAPH$)'AUTOLOAD)
(PUTPROP 'MAKE-Z-CLIP-STREAM (LIST GRAPHS 'GRAPH3)'AUTOLOAD)
(PUTPROP 'MAKE-Z-PERSPECTIVE-STREAM (LIST GRAPHS 'GRAPH3)'AUTOLOAD)
)
'GRAPHS)
(EVAL-WHEN (LOAD)
(FUNCALL (GET 'GRAPHS 'GRAPHS) (CAR (NAMELIST (STATUS FASLOAD)))))
(EVAL-WHEN (EVAL)
(FUNCALL (GET 'GRAPHS 'GRAPHS) (CAR (NAMELIST INFILE))))
(REMPROP 'GRAPHS 'GRAPHS)
;; Runtime primitives:
(DEFUN CALL N
(LEXPR-FUNCALL (CAR (ARG 1)) (ARG 1) (LISTIFY (- 1 N))))
(DEFUN NARG-ERROR (N-ACTUAL N-NEEDED THE-FUNCTION)
(ERROR (LIST "wanted" N-NEEDED "arguments but got" N-ACTUAL)
THE-FUNCTION
'FAIL-ACT))
(DEFUN NARG-CHECK (N-ACTUAL N-NEEDED THE-FUNCTION)
(UNLESS (= N-ACTUAL N-NEEDED)
(NARG-ERROR N-ACTUAL N-NEEDED THE-FUNCTION)))
(DEFUN UNKNOWN-COMMAND (COMMAND THE-FUNCTION)
(ERROR (LIST "Unknown command to" THE-FUNCTION) COMMAND
'FAIL-ACT))
;; the generic graphics functions.
(DEFUN SET-PEN (F X Y)
(CALL F 'SET-PEN X Y))
(DEFUN MOVE-PEN (F X Y)
(CALL3-MAP2-DISPATCH F 'MOVE-PEN X Y))
(DEFUN VECTOR-PEN (F X Y)
(CALL3-MAP2-DISPATCH F 'VECTOR-PEN X Y))
(DEFUN DRAW-POINT (F X Y)
(CALL3-MAP2-DISPATCH F 'DRAW-POINT X Y))
(DEFUN DRAW-LINE (F X1 Y1 X2 Y2)
(CALL5-MAP2-DISPATCH F 'DRAW-LINE X1 Y1 X2 Y2))
(DEFUN GRAPHICS-STREAM-TYO (F ARG) (CALL F 'TYO ARG))
(DEFUN SET-VIEWPORT (F X0 X1 Y0 Y1)
(CALL F 'SET-VIEWPORT X0 X1 Y0 Y1))
(DEFUN GET-VIEWPORT (F)
(CALL F 'VIEWPORT))
(DEFUN SET-WINDOW (F X0 X1 Y0 Y1)
(CALL F 'SET-WINDOW X0 X1 Y0 Y1))
(DEFUN GET-WINDOW (F)
(CALL F 'WINDOW))
(DEFUN SET-INVISIBLEP (F FLAG)
(CALL F 'SET-INVISIBLEP FLAG))
(DEFUN SET-DOTTEP (F FLAG)
(CALL 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)))
;; Splitting interface
(defun broadcast-stream n
(let* ((broadcast-stream (arg 1))
(l (broadcast-stream-out-streams)))
(caseq n
((1)
(do ()((null l))
(call (pop l))))
((2)
(do ()((null l))
(call (pop l) (arg 2))))
((3)
(do ()((null l))
(call (pop l) (arg 2) (arg 3))))
((4)
(do ()((null l))
(call (pop l) (arg 2) (arg 3) (arg 4))))
((5)
(do ()((null l))
(call (pop l) (arg 2) (arg 3) (arg 4) (arg 5))))
((6)
(do ()((null l))
(call (pop l) (arg 2) (arg 3) (arg 4) (arg 5) (arg 6))))
(t
(do ((rest (listify (- 6 n))))
((null l))
(lexpr-funcall #'call (pop l)
(arg 2) (arg 3) (arg 4) (arg 5) (arg 6)
rest))))))
(defun make-broadcast-stream (&rest l)
(make-broadcast-stream-1 out-streams l))
;; SFA Interface.
(defun make-graphics-sfa (out-stream)
(make-graphics-sfa-1 out-stream out-stream))
(defun graphics-sfa (sfa command arg)
(caseq command
((tyo)
(CALL (graphics-sfa-out-stream sfa) 'tyo arg))
((which-operations)
'(tyo))
(t
(unknown-command command 'graphics-sfa))))
(defun make-broadcast-sfa (&rest l)
(make-broadcast-sfa-1 l l))
(defun broadcast-sfa (broadcast-sfa command arg)
(caseq command
((tyo)
(do ((l (broadcast-sfa-l)))
((null l))
(+tyo arg (pop l))))
((print)
(do ((l (broadcast-sfa-l)))
((null l))
(print arg (pop l))))
((princ)
(do ((l (broadcast-sfa-l)))
((null l))
(princ arg (pop l))))
((prin1)
(do ((l (broadcast-sfa-l)))
((null l))
(prin1 arg (pop l))))
((open)
(do ((l (broadcast-sfa-l)))
((null l))
(open (pop l)))
broadcast-sfa)
((close)
(do ((l (broadcast-sfa-l)))
((null l))
(close (pop l))))
((which-operations)
'(tyo print princ prin1 open close))
(t
(unknown-command command 'broadcast-sfa))))
;; Optimizations.
(DEFUN CALL0 (F)
(FUNCALL (CAR F) F))
(DEFUN CALL1 (F A)
(FUNCALL (CAR F) F A))
(DEFUN CALL2 (F A B)
(FUNCALL (CAR F) F A B))
(DEFUN CALL3 (F A B C)
(FUNCALL (CAR F) F A B C))
(DEFUN CALL4 (F A B C D)
(FUNCALL (CAR F) F A B C D))
(DEFUN CALL5 (F A B C D E)
(FUNCALL (CAR F) F A B C D E))
;; Specialized mapping functions
;; CALL3 version.
(DEFUN CALL3-MAP2L (F A B C)
(DO ()
((NULL B))
(CALL F A (POP B) (POP C))))
(DEFUN CALL3-MAP2A (F A B C)
(DO ((J 0 (1+ J))
(N (ARRAY-DIMENSION-N 1 B)))
((= J N))
(DECLARE (FIXNUM J N))
(CALL F A (ARRAYCALL T B J) (ARRAYCALL T C J))))
(DEFUN CALL3-MAP2A$ (F A B C)
(DO ((J 0 (1+ J))
(N (ARRAY-DIMENSION-N 1 B)))
((= J N))
(DECLARE (FIXNUM J N))
(CALL F A (ARRAYCALL FLONUM B J) (ARRAYCALL FLONUM C J))))
(DEFUN CALL3-MAP2A% (F A B C)
(DO ((J 0 (1+ J))
(N (ARRAY-DIMENSION-N 1 B)))
((= J N))
(DECLARE (FIXNUM J N))
(CALL F A (ARRAYCALL FIXNUM B J) (ARRAYCALL FIXNUM C J))))
(DEFUN CALL3-MAP2-DISPATCH-WTA (M F A B C)
(CALL3-MAP2-DISPATCH F A
(ERROR M B 'WRNG-TYPE-ARG)
C))
(DEFUN CALL3-MAP2-DISPATCH (F A B C)
(IF (NOT (NULL B)) ; Stupid NIL is a SYMBOL.
(CASEQ (TYPEP B)
((FIXNUM FLONUM)
(CALL F A B C))
((LIST)
(CALL3-MAP2L F A B C))
((ARRAY)
(CASEQ (ARRAY-TYPE B)
((T NIL)
(CALL3-MAP2A F A B C))
((FLONUM)
(CALL3-MAP2A$ F A B C))
((FIXNUM)
(CALL3-MAP2A% F A B C))
(T
(CALL3-MAP2-DISPATCH-WTA "Bad type of array to map over"
F A B C))))
(T
(CALL3-MAP2-DISPATCH-WTA "Unknown type to MAP over" F A B C)))))
;; CALL5 version.
(DEFUN CALL5-MAP2L (F A B C D E)
(DO ()
((NULL B))
(CALL F A (POP B) (POP C) (POP D) (POP E))))
(DEFUN CALL5-MAP2A (F A B C D E)
(DO ((J 0 (1+ J))
(N (ARRAY-DIMENSION-N 1 B)))
((= J N))
(DECLARE (FIXNUM J N))
(CALL F A
(ARRAYCALL T B J)
(ARRAYCALL T C J)
(ARRAYCALL T D J)
(ARRAYCALL T E J))))
(DEFUN CALL5-MAP2A$ (F A B C D E)
(DO ((J 0 (1+ J))
(N (ARRAY-DIMENSION-N 1 B)))
((= J N))
(DECLARE (FIXNUM J N))
(CALL F A
(ARRAYCALL FLONUM B J)
(ARRAYCALL FLONUM C J)
(ARRAYCALL FLONUM D J)
(ARRAYCALL FLONUM E J))))
(DEFUN CALL5-MAP2A% (F A B C D E)
(DO ((J 0 (1+ J))
(N (ARRAY-DIMENSION-N 1 B)))
((= J N))
(DECLARE (FIXNUM J N))
(CALL F A
(ARRAYCALL FIXNUM B J)
(ARRAYCALL FIXNUM C J)
(ARRAYCALL FIXNUM D J)
(ARRAYCALL FIXNUM E J))))
(DEFUN CALL5-MAP2-DISPATCH-WTA (M F A B C D E)
(CALL5-MAP2-DISPATCH F A
(ERROR M B 'WRNG-TYPE-ARG)
C D E))
(DEFUN CALL5-MAP2-DISPATCH (F A B C D E)
(IF (NOT (NULL B)) ; Stupid NIL is a SYMBOL.
(CASEQ (TYPEP B)
((FIXNUM FLONUM)
(CALL F A B C D E))
((LIST)
(CALL5-MAP2L F A B C D E))
((ARRAY)
(CASEQ (ARRAY-TYPE B)
((T NIL)
(CALL5-MAP2A F A B C D E))
((FLONUM)
(CALL5-MAP2A$ F A B C D E))
((FIXNUM)
(CALL5-MAP2A% F A B C D E))
(T
(CALL5-MAP2-DISPATCH-WTA "Bad type of array to map over"
F A B C D E))))
(T
(CALL5-MAP2-DISPATCH-WTA "Unknown type to MAP over" F A B C D E)))))

74
src/libdoc/graphs.usage Executable file
View File

@@ -0,0 +1,74 @@
This is an archive of graphics utilities written sometime
during 1980 by George Carrette. Files marked with a "*"
are used by the CONSTANCE II mirror-confined plasma experiment
data-analysis system written by Michael Mauel.
* GRAPH$ Floating-point graphics.
GRAPH3 3-d graphics.
* GRAPHA Ards hardware support.
GRAPHM Declarations and Macro support for package.
* GRAPHS Generic runtime support and autoload defs.
GRAPHT Tektronics 4010 hardware support.
PLOT 2-d plotting examples.
PLOT3 3-d plotting examples.
Summary of graphics package. -George Carrette.
Load the GRAPHM module at compile-time to get all
the needed declarations.
Load the GRAPHS module at runtime to get the basic entry
points and autoload definitions.
(MAKE-ARDS-STREAM <SFA-OR-FILE-OBJECT>) ; Return a STREAM taking FIXNUMS
(MAKE-TEK-STREAM <SFA-OR-FILE-OBJECT>) ; Return a STREAM taking FIXNUMS
[Both give streams, which are implemented using hunks or lists
depending upon what the compile-time setting in GRAPHM was.]
(MAKE-GRAPHICS-STREAM <STREAM>)
Gives a floating-point stream, complete with windows and
viewports.
Operations on all streams:
(SET-PEN <STREAM> X Y) ; Sets the pen.
(MOVE-PEN <STREAM> X Y) ; Draws a line from last setting.
(VECTOR-PEN <STREAM> X Y) ; Relative MOVE-PEN
(DRAW-POINT <STREAM> X Y) ; Draw a line of zero length.
(DRAW-LINE <STREAM> X0 Y0 X1 Y1) ; Most popular operation.
The above all do mapping if X and Y are both lists or arrays.
Operations specific to GRAPHICS-STREAM:
(SET-VIEWPORT <STREAM> X0 X1 Y0 Y1) ; FIXNUM range to feed to ARDS or TEK.
(SET-WINDOW <STREAM> X0 X1 Y0 Y1) ; FLONUM domain of stream.
(GET-WINDOW <STREAM>)
(DRAW-FRAME <STREAM>) ; Calls GET-WINDOW to do the obvious thing.
Operations specific to the low-level ARDS and TEK streams.
(CALL <STREAM> 'BOUNDARIES) ; returns maximum allowed for SET-VIEWPORT
Utilities:
(MAKE-BROADCAST-SFA <SFA-OR-FILE-OBJECT1> <SFA-OR-FILE-OBJECT2> ...)
(MAKE-BROADCAST-STREAM <STREAM1> <STREAM2> ...)
3d-Graphics:
(MAKE-Z-PERSPECTIVE-STREAM <GRAPHICS-STREAM>) ; 3d=>2d mapping.
(MAKE-Z-CLIP-STREAM <3D-STREAM>) ; 3d=>3d plane clipping.
(MAKE-ORTHOGONAL-3D-STREAM <3D-STREAM>) ; 3d=>3d rotation.
Other:
(PLOTF '(<f1> <f2> ...) X0 X1 N) ; plots some functions.
The plot functions are meant to serve as example usage.

147
src/libdoc/grapht.gjc1 Executable file
View File

@@ -0,0 +1,147 @@
;;;-*-LISP-*-
;;; A graphics utility package. - George Carrette.
;;; Tektronix graphics.
(eval-when (eval compile)
(or (get 'graphm 'version)
(load (list (car (namelist infile)) 'graphm))))
(graphs-module grapht)
;; For info on Tek graphic protocol see .INFO.;TEK INFO
;; This code was nabbed from JGA.
(DEFVAR TEK-PRINTMODE #o37)
(DEFVAR TEK-GRAPHMODE #o35)
;; TEK Primitives
(defun tek-stream NARGS
(COMMENT (ARG 1) = TEK-STREAM
(ARG 2) = COMMAND
(ARG 3) = X1
(ARG 4) = Y1
(ARG 5) = X2
(ARG 6) = Y2)
(LET ((TEK-STREAM (ARG 1)))
(LET ((VIEWPORT (TEK-STREAM-VIEWPORT))
(GRAPHIC-OUTPUT (TEK-STREAM-GRAPHIC-OUTPUT)))
(caseq (ARG 2)
((SET-PEN)
(NARG-CHECK NARGS 4 'TEK-STREAM)
(TEK-SET-PEN (ARG 3) (ARG 4)))
((MOVE-PEN)
(NARG-CHECK NARGS 4 'TEK-STREAM)
(TEK-MOVE-PEN (ARG 3) (ARG 4)))
(VECTOR-PEN
(NARG-CHECK NARGS 4 'TEK-STREAM)
(TEK-VECTOR-PEN (ARG 3) (ARG 4)))
(DRAW-POINT
(NARG-CHECK NARGS 4 'TEK-STREAM)
(TEK-SET-PEN (ARG 3) (ARG 4))
(TEK-VECTOR-PEN 0 0))
(DRAW-LINE
(NARG-CHECK NARGS 6 'TEK-STREAM)
(TEK-SET-PEN (ARG 3) (ARG 4))
(TEK-MOVE-PEN (ARG 5) (ARG 6)))
((print-text)
(NARG-CHECK NARGS 3 'TEK-STREAM)
(tek-print-text (ARG 3)))
((tyo)
(NARG-CHECK NARGS 3 'TEK-STREAM)
(tek-tyo (ARG 3)))
((boundaries)
(list (tek-x-min)
(tek-x-max)
(tek-y-min)
(tek-y-max)))
((which-operations)
(NARG-CHECK NARGS 2 'TEK-STREAM)
'(SET-PEN MOVE-PEN VECTOR-PEN
DRAW-POINT DRAW-LINE TYO
print-text))
(t
(UNKNOWN-COMMAND (ARG 2) 'TEK-STREAM))))))
;; These are the basic graphic operations in fixnum (viewport) coordinates.
;; No attempt is made to clip lines for the viewport here, nor check for
;; out-of-range arguments which will fold over mod #o2000.
(defun tek-tyo (c)
(unless (= (tek-graphic-mode) TEK-PRINTMODE)
(+tyo TEK-PRINTMODE graphic-output)
(setf (tek-graphic-mode) TEK-PRINTMODE))
(tyo c graphic-output))
(defun tek-print-text (text)
(unless (= (tek-graphic-mode) TEK-PRINTMODE)
(+tyo TEK-PRINTMODE graphic-output)
(setf (tek-graphic-mode) TEK-PRINTMODE))
(princ text graphic-output))
;; tekout does the basic encoding of all coordinates into Tek format
;; Note that it does the storage of high-y, low-y, etc., but not x or y.
(DEFUN tekout (x y)
(let ((high-y (lsh (logand y #o1740) -5))
(low-y (logand y #o37))
(high-x (lsh (logand x #o1740) -5))
(low-x (logand x #o37))
(old-high-y (tek-high-y))
(old-low-y (tek-low-y))
(old-high-x (tek-high-x)))
(declare (fixnum high-y low-y high-x low-x
old-high-y old-low-y old-high-x))
(unless (= high-y old-high-y)
(+tyo (+ high-y #o40) graphic-output)
(setf (tek-high-y) high-y))
(unless (and (= low-y old-low-y) (= high-x old-high-x))
(+tyo (+ low-y #o140) graphic-output)
(setf (tek-low-y) low-y)
(unless (= high-x old-high-x)
(+tyo (+ high-x #o40) graphic-output)
(setf (tek-high-x) high-x)))
(+tyo (+ low-x #o100) graphic-output)
(setf (tek-low-x) low-x))
nil)
(defun tek-set-pen (x y)
(declare (fixnum x y)
(special viewport))
(+tyo TEK-GRAPHMODE graphic-output)
(setf (tek-graphic-mode) TEK-GRAPHMODE)
(tekout x y)
(setf (tek-x-pen) x)
(setf (tek-y-pen) y)
nil)
(defun tek-move-pen (x y)
(declare (fixnum x y))
(unless (= (tek-graphic-mode) TEK-GRAPHMODE)
(+tyo TEK-GRAPHMODE graphic-output)
(tekout (tek-x-pen)
(tek-y-pen))
(setf (tek-graphic-mode) TEK-GRAPHMODE))
(tekout x y)
(setf (tek-x-pen) x)
(setf (tek-y-pen) y)
nil)
(defun tek-vector-pen (dx dy)
(declare (fixnum dx dy))
(unless (= (tek-graphic-mode) TEK-GRAPHMODE)
(+tyo TEK-GRAPHMODE graphic-output)
(tekout (tek-x-pen)
(tek-y-pen))
(setf (tek-graphic-mode) TEK-GRAPHMODE))
(let ((x (+ dx (tek-x-pen)))
(y (+ dy (tek-y-pen))))
(declare (fixnum x y))
(tekout x y)
(setf (tek-x-pen) x)
(setf (tek-y-pen) y))
nil)
(defun make-tek-stream (s)
(make-tek-stream-1 graphic-output s))

53
src/libdoc/impdef.kmp15 Executable file
View File

@@ -0,0 +1,53 @@
;;; -*- Mode:LISP; IBase:10.; -*-
;;;
;;; IMPDEF: A library for selectively including a definition from a file of definitions
(HERALD IMPDEF /15)
(EVAL-WHEN (EVAL COMPILE)
(COND ((NOT (STATUS FEATURE IOTA))
(LOAD '((DSK LIBLSP) IOTA FASL)))))
;;; (IMPORT-DEFINITION function filename)
;;; Gets the definition of the function from filename and includes just
;;; that one function in current file.
;;;
;;; Works for DEFUNs, DEFMACROs, DEFUN&s, and recursive IMPORT-DEFINITIONs.
(DEFMACRO IMPORT-DEFINITION (NAME FILE)
(TERPRI MSGFILES)
(PRINC '|;IMPORT-DEFINITION looking for | MSGFILES)
(PRIN1 NAME MSGFILES)
(PRINC '| in /"| MSGFILES)
(PRINC (NAMESTRING FILE) MSGFILES)
(PRINC '/" MSGFILES)
(COND ((NOT (PROBEF FILE))
(TERPRI MSGFILES)
(PRINC '|;File not found. -- IMPORT-DEFINITION| MSGFILES)
'`(FILE ,FILE NOT FOUND WHEN LOOKING FOR DEFINITION
OF ,NAME))
(T
(IOTA ((STREAM FILE 'IN))
(DO ((FORM (READ STREAM STREAM)
(READ STREAM STREAM)))
((EQ FORM STREAM)
(TERPRI MSGFILES)
(PRINC '|;Definition of function | MSGFILES)
(PRIN1 NAME MSGFILES)
(PRINC '| not found. -- IMPORT-DEFINITION|
MSGFILES)
`'(FUNCTION ,NAME NOT FOUND IN ,FILE))
(COND ((AND (NOT (ATOM FORM))
(MEMQ (CAR FORM)
'(DEFUN DEFMACRO MACRO DEFUN/&
IMPORT-DEFINITION))
(OR (AND (ATOM (CADR FORM))
(EQ (CADR FORM) NAME))
(AND (NOT (ATOM (CADR FORM)))
(EQ (CAADR FORM) NAME))))
(TERPRI MSGFILES)
(PRINC '|;Using | MSGFILES)
((LAMBDA (PRINLENGTH)
(PRIN1 FORM MSGFILES)) 2.)
(PRINC '| -- IMPORT-DEFINITION| MSGFILES)
(RETURN FORM))))))))

53
src/libdoc/laugh.gsb3 Executable file
View File

@@ -0,0 +1,53 @@
; Friü˜| ASept 8,1978 22:14 NM+6D.17H.53M.39S. -*- Lisp -*-
(declare (array* (notype (laughs ?)))
(special *laughs-dimension)
(fixnum *laughs-dimension))
(defun one-laugh1 (phrase output-file)
(or (and (eq output-file t) (setq output-file tyo) (not (null ^w)))
((lambda (pos)
(declare (fixnum pos))
(cond ((> (+ (flatc phrase) 1 pos) (linel output-file))
(terpri output-file))
((not (= pos 0)) (princ '| | output-file)))
(and (eq output-file tyo) (+tyo 7. output-file))
(princ phrase output-file))
(charpos output-file))))
(defun one-laugh2 (phrase list)
(mapc '(lambda (f) (one-laugh1 phrase f)) list)
t)
(defun one-laugh (output-file)
((lambda (phrase)
(cond ((null output-file)
(one-laugh1 phrase t)
(and ^r (one-laugh2 phrase outfiles)))
((atom output-file) (one-laugh1 phrase output-file))
(t (one-laugh2 phrase output-file))))
(laughs (random *laughs-dimension))))
(defun laugh (arg output-filespec)
(prog (i no-sleep-p)
(declare (fixnum i))
(setq no-sleep-p (and (filep output-filespec)
(eq (caar (namelist output-filespec)) 'cli)))
error-return-loop
(cond ((null arg) (setq i 1))
((eq arg 'uncontrollably) (setq i 1_34.))
((eq (typep arg) 'fixnum) (setq i arg))
(t (setq arg (error '|Bad arg - LAUGH| arg 'wrng-type-arg))
(go error-return-loop)))
(terpri output-filespec)
super-hackish-losing-loop
(one-laugh output-filespec)
(and (not (plusp (setq i (1- i)))) (return 'hic))
(and (null no-sleep-p)
(sleep (+$ (//$ (float (random 20.)) 30.0) 0.05)))
(go super-hackish-losing-loop)))
((lambda (l)
(fillarray (array laughs t (setq *laughs-dimension (length l))) l))
'(|Ha Ha| |Snort| |Chortle| |Ha| |He| |He He| |He He He| |Chortle|
|Ho| |Ho Ho| |Ho Ho Ho| |Snicker| |Ha Ha Ha| |Giggle| |Chuckle|
|Guffaw|))

345
src/libdoc/lchstr.jlk24 Executable file
View File

@@ -0,0 +1,345 @@
;;; Chaosnet Streams for Maclisp
;;; todo: variable byte sizes for IN & OUT
;;; improve efficiency of ARRAY-IN, ARRAY-OUT
;;; make LSN's work
;;; flush sfa-get/store in favor of SETF and ...?
;;; To generate a Chaosnet stream do (MAKE-CHAOSNET-STREAM). Then do
;;; (OPEN <stream> '(HOST <host-address> CONTACT <contact-name>)).
;;; Then use standard operations like TYI, UNTYI, TYO, IN, OUT, CLOSE, etc
;;; or non-standard operations PACKET-IN, PACKET-OUT, ARRAY-IN, ARRAY-OUT
;;; More documentation can be found before each operation handler (e.g. OPEN).
;;; Note: If you want reasonable error handling when running in a bare
;;; LISP, you need a package like the one in MACSYMA (LIBMAX;MDEBUG >).
;;; Standard compile-time environment
(include |mc:libmax;gprelud >|)
(herald lchstr)
(eval-when (compile) (setq defmacro-for-compiling nil))
(eval-when (eval compile)
(if (not (fboundp 'loop)) (load "dsk:liblsp;loop fasl")))
;;; Load the Chaosnet support package, if not already loaded
(eval-when (load eval)
(or (get 'lchnsp 'version) (load "dsk:lisp;lchnsp fasl")))
(defvar chaos-stream-id 0)
(defvar default-window-size 10.)
(defvar default-timeout 60.)
;;; See the file L;LCHNSP > for the %chaos routines
(declare (special chaos-internal-pkt-buffer)
(*expr %chaos-open-channels %chaos-close-channels
%chaos-request-connection %chaos-eof %chaos-allocate-buffer
%chaos-pktiot %chaos-get-byte %chaos-put-byte
%chaos-set-pkt-length %chaos-set-pkt-opcode
%chaos-get-pkt-length %chaos-get-pkt-opcode))
;;; Compile time constants
(eval-when (eval compile)
;;; Connection state symbols
(setq %cscls 0 %csrfs 3 %csopn 4 %cslos 5 %csinc 6
;;; Packet Opcode definitions
%codat 200 %coeof 14 %cocls 3
;;; Other constants
max-connect-tries 5
max-pkt-size-bytes 488.)
;;; Stream slot indices (should be done as a structure, but sfa's don't win...)
(let ((slot-index 0)) ;crock...
(mapc #'(lambda(slot) (set slot (setq slot-index (1+ slot-index))))
'(connection host-address contact-name request-or-listen
byte-size window-size timeout
untyi-list in-buffer out-buffer in-count out-count
max-chaosnet-stream-slot)))) ;this must be last
;;; Generate a bare chaosnet-stream object
(defun make-chaosnet-stream ()
(let ((stream (sfa-create #'chaosnet-stream-function
#.max-chaosnet-stream-slot
(format nil "chaos-stream-object-~A"
(setq chaos-stream-id (1+ chaos-stream-id))))))
(sfa-store stream #.host-address nil)
(sfa-store stream #.contact-name nil)
(sfa-store stream #.request-or-listen t) ;default to RFC
(sfa-store stream #.byte-size 8)
(sfa-store stream #.window-size default-window-size)
(sfa-store stream #.timeout default-timeout)
(sfa-store stream #.in-count -1)
(sfa-store stream #.out-count 0)
(sfa-store stream #.in-buffer (%chaos-allocate-buffer))
(sfa-store stream #.out-buffer (%chaos-allocate-buffer))
stream))
;;; chaosnet-stream-function is at the end of the file because it depends on
;;; the following macros.
;;; These macros are only to be expanded inside chaosnet-stream-function
;;; OPEN msg handler. Format is (OPEN <stream> <option-list>) where
;;; <stream> is a chaosnet stream as returned by (MAKE-CHAOSNET-STREAM) and
;;; <option-list> is a list of keywords and values (keywd1 val1 keywd2 val2 ..)
;;; Known options are: HOST (or ADDRESS or HOST-ADDRESS) - Chaosnet host addr
;;; CONTACT-NAME (or CONTACT or NAME) - Contact name + JCL
;;; REQUEST or LISTEN - same as CONTACT
;;; BYTE-SIZE (or BYTE) - byte size (8)
;;; WINDOW-SIZE (or WINDOW) - xmt window size
;;; Note: HOST-ADDRESS and CONTACT-NAME are required.
;;; [Should OPEN errors here be signaled in a special way to be compatible?]
;;; Map keywords into slot indices with an occassional side-effect.
(defmacro chaosnet-stream-keyword-decode (stream keyword)
`(caseq ,keyword
((host address host-address host-number)
#.host-address)
((contact name contact-name request)
(sfa-store ,stream #.request-or-listen T)
#.contact-name)
(listen
(sfa-store ,stream #.request-or-listen NIL)
#.contact-name)
((byte byte-size) #.byte-size)
((window window-size) #.window-size)
(timeout #.timeout)
(T (ferror nil "Unknown keyword in OPEN for ~A - ~A"
,stream keyword))))
(defmacro chaosnet-stream-open (stream args)
`(progn
(loop for (keyword value) on ,args by #'cddr
for index = (chaosnet-stream-keyword-decode ,stream keyword)
do (sfa-store ,stream index value))
(sfa-call ,stream 'close nil) ;make sure its closed
(if (null (sfa-get ,stream #.host-address))
(ferror nil
"Error handling OPEN for ~A: No host address specified."
,stream))
(if (null (sfa-get ,stream #.contact-name))
(ferror nil
"Error handling OPEN for ~A: No contact name specified."
,stream))
(if (null (sfa-get ,stream #.connection)) ;create a connection,
(sfa-store ,stream #.connection ;if needed
(%chaos-open-channels (sfa-get ,stream #.window-size))))
(loop ;repeat #.max-connect-tries ; would be nicer...
for connect-tries from 1 to #.max-connect-tries and
state =
(*catch 'chaos-pktiot-error ;catch IOC errors
(%chaos-request-connection
(sfa-get ,stream #.connection)
(sfa-get ,stream #.host-address)
(sfa-get ,stream #.contact-name)
(sfa-get ,stream #.request-or-listen)
(sfa-get ,stream #.timeout)))
until (= #.%csopn state)
finally
(if (not (= #.%csopn state))
(error (get-chaosnet-error-msg ,stream)
"some error from chaos site")))
(sfa-call ,stream 'clear-input nil)
(sfa-call ,stream 'clear-output nil)
,stream))
;;; CLOSE msg handler. Shuts down the connection and frees up the channels.
(defmacro chaosnet-stream-close (stream)
`(let ((conn (sfa-get ,stream #.connection)))
(sfa-store ,stream #.connection nil)
(unless (null conn)
(*catch 'chaos-pktiot-error (%chaos-eof conn))
(%chaos-close-channels conn))))
;;; Standard stream operations
;;; Define a wrapper to catch IOC errors and handle them nicely
(defmacro chaosnet-op (stream &rest body)
`(if (null (*catch 'chaos-pktiot-error ,@ body))
(error (get-chaosnet-error-msg ,stream) "some error from chaos site"
'fail-act
)))
;;; TYI and TYO ignore BYTE-SIZE and always return/take 8-bit bytes.
;;; UNTYI can take anything (and TYI after UNTYI will return anything).
(defmacro chaosnet-stream-tyi (stream eof)
`(let ((utl (sfa-get ,stream #.untyi-list)))
(if utl (prog1 (car utl) (sfa-store ,stream #.untyi-list (cdr utl)))
(let ((ibuf (sfa-get ,stream #.in-buffer))
(cnt (sfa-get ,stream #.in-count)))
(when (<= cnt 0)
(chaosnet-op ,stream
(%chaos-pktiot
(car (sfa-get ,stream #.connection))
ibuf))
(sfa-store ,stream #.in-count
(setq cnt (%chaos-get-pkt-length ibuf))))
(cond ((= #.%coeof (%chaos-get-pkt-opcode ibuf))
(sfa-call ,stream 'clear-input nil)
,eof)
((= #.%cocls (%chaos-get-pkt-opcode ibuf))
(error (get-chaosnet-error-msg ,stream T))) ;cls-flag
((= 0 cnt) (sfa-call ,stream 'tyi ,eof))
(T (sfa-store ,stream #.in-count (1- cnt))
(%chaos-get-byte
ibuf
(- (%chaos-get-pkt-length ibuf) cnt))))))))
(defmacro chaosnet-stream-untyi (stream byte)
`(sfa-store ,stream #.untyi-list
(push ,byte (sfa-get ,stream #.untyi-list))))
(defmacro chaosnet-stream-tyo (stream byte)
`(let ((cnt (sfa-get ,stream #.out-count)))
(%chaos-put-byte (sfa-get ,stream #.out-buffer) ,byte)
(setq cnt (1+ cnt))
(if (> cnt #.(1- max-pkt-size-bytes)) (sfa-call ,stream 'force-output
nil)
(sfa-store ,stream #.out-count cnt))
T))
;;; what should IN and OUT do? (pack arbitrary byte sizes into 16 bit words?)
(defmacro chaosnet-stream-in (stream eof)
`(sfa-call ,stream 'tyi ,eof)) ;should do something better..
(defmacro chaosnet-stream-out (stream word)
`(sfa-call ,stream 'tyo ,word))
(defmacro chaosnet-stream-force-output (stream)
`(when (> (sfa-get ,stream #.out-count) 0)
(chaosnet-op ,stream
(%chaos-pktiot (cdr (sfa-get ,stream #.connection))
(sfa-get ,stream #.out-buffer)))
(sfa-call ,stream 'clear-output nil)))
(defmacro chaosnet-stream-clear-input (stream)
`(loop with ary = chaos-internal-pkt-buffer and
ichan = (car (sfa-get ,stream #.connection))
for count = (lsh (nth 2 (syscall 3 'whyint ichan)) -18.)
while (and (> count 0)
(*catch 'chaos-pktiot-error (%chaos-pktiot ichan ary)))
finally (sfa-store ,stream #.in-count -1) ;no packet
(sfa-store ,stream #.untyi-list nil)
(return T)))
(defmacro chaosnet-stream-clear-output (stream)
`(let ((obuf (sfa-get ,stream #.out-buffer)))
(sfa-store ,stream #.out-count 0)
(%chaos-set-pkt-length obuf 0)
(%chaos-set-pkt-opcode obuf #.%codat))) ;data opcode
;;; Non-standard stream operations
;;; Input a packet into an array
(defmacro chaosnet-stream-packet-in (stream array)
`(let ((ibuf (sfa-get ,stream #.in-buffer)))
(chaosnet-op ,stream
(%chaos-pktiot (car (sfa-get ,stream #.connection))
ibuf)
(fillarray ,array ibuf))
T))
(defmacro chaosnet-stream-packet-out (stream array)
`(let ((obuf (sfa-get ,stream #.out-buffer)))
(chaosnet-op ,stream
(fillarray obuf ,array) ;how big is obuf?
(%chaos-pktiot (cdr (sfa-get ,stream #.connection))
obuf))))
;;; These should probably be made more efficient someday...
(defmacro chaosnet-stream-array-in (stream array count)
`(progn
(dotimes (i ,count)
(setf (arraycall fixnum ,array i) (sfa-call ,stream 'tyi 0)))
T))
(defmacro chaosnet-stream-array-out (stream array count)
`(progn
(dotimes (i ,count)
(sfa-call ,stream 'out (arraycall fixnum ,array i)))
T))
(defmacro chaosnet-stream-eof (stream msg) ;hack the msg someday
`(progn (sfa-call ,stream 'force-output nil)
(chaosnet-op ,stream (%chaos-eof (sfa-get ,stream #.connection)))
(sfa-call ,stream 'clear-output nil)))
;;; Dispatching function for Chaosnet streams
(declare (*lexpr get-chaosnet-error-msg))
(defun chaosnet-stream-function (stream msg arg)
(caseq msg
(which-operations '(open close untyi tyi tyo in out force-output eof
clear-input clear-output
packet-in packet-out
array-in array-out))
;standard operations
(open (chaosnet-stream-open stream arg))
(close (chaosnet-stream-close stream))
(untyi (chaosnet-stream-untyi stream arg))
(tyi (chaosnet-stream-tyi stream arg))
(tyo (chaosnet-stream-tyo stream arg))
(in (chaosnet-stream-in stream arg))
(out (chaosnet-stream-out stream arg))
(force-output (chaosnet-stream-force-output stream))
(clear-input (chaosnet-stream-clear-input stream))
(clear-output (chaosnet-stream-clear-output stream))
;non-standard operations
(packet-in (chaosnet-stream-packet-in stream arg))
(packet-out (chaosnet-stream-packet-out stream arg))
(array-in (chaosnet-stream-array-in stream (car arg) (cadr arg)))
(array-out (chaosnet-stream-array-out stream (car arg) (cadr arg)))
(eof (chaosnet-stream-eof stream arg))
(T (ferror nil "Unknown stream operation - ~A" msg))))
;;; Function forms of non-standard stream operations
;;; packet-in/out reads/writes a packet to/from a fixnum array
;;; data is packed 32-bit to a word, left adjusted.
(defun packet-in (stream array)
(sfa-call stream 'packet-in array))
(defun packet-out (stream array)
(sfa-call stream 'packet-out array))
;;; Engorge or disgorge <n> numbers into or out of an array.
;;; Packing is either 8,16, or 32 bit, depending on the mode of the OPEN.
(defun array-in (stream array count)
(sfa-call stream 'array-in (list array count)))
(defun array-out (stream array count)
(sfa-call stream 'array-out (list array count)))
;;; Read and stringify a message about why a connection is losing
(defun get-chaosnet-error-msg (stream &optional (cls-flag nil)
&aux (ichan (car (sfa-get stream #.connection)))
(ary (sfa-get stream #.in-buffer)))
(let ((count (lsh (nth 2 (syscall 3 'whyint ichan)) -18.)))
(if (not (or cls-flag
(and (> count 0)
(*catch 'chaos-pktiot-error (%chaos-pktiot ichan ary)))))
"Chaosnet Lossage - cause undetermined."
(maknam (loop for i from 4
for word = (arraycall fixnum ary i)
until (= 0 word)
collect (load-byte word 28. 8)
collect (load-byte word 20. 8)
collect (load-byte word 12. 8)
collect (load-byte word 4. 8))))))
;; Local Modes:
;; Mode: LISP
;; Comment Col:40
;; END:

345
src/libdoc/lchstr.jlk25 Normal file
View File

@@ -0,0 +1,345 @@
;;; Chaosnet Streams for Maclisp
;;; todo: variable byte sizes for IN & OUT
;;; improve efficiency of ARRAY-IN, ARRAY-OUT
;;; make LSN's work
;;; flush sfa-get/store in favor of SETF and ...?
;;; To generate a Chaosnet stream do (MAKE-CHAOSNET-STREAM). Then do
;;; (OPEN <stream> '(HOST <host-address> CONTACT <contact-name>)).
;;; Then use standard operations like TYI, UNTYI, TYO, IN, OUT, CLOSE, etc
;;; or non-standard operations PACKET-IN, PACKET-OUT, ARRAY-IN, ARRAY-OUT
;;; More documentation can be found before each operation handler (e.g. OPEN).
;;; Note: If you want reasonable error handling when running in a bare
;;; LISP, you need a package like the one in MACSYMA (LIBMAX;MDEBUG >).
;;; Standard compile-time environment
(include |dsk:libmax;gprelud >|)
(herald lchstr)
(eval-when (compile) (setq defmacro-for-compiling nil))
(eval-when (eval compile)
(if (not (fboundp 'loop)) (load "dsk:liblsp;loop fasl")))
;;; Load the Chaosnet support package, if not already loaded
(eval-when (load eval)
(or (get 'lchnsp 'version) (load "dsk:lisp;lchnsp fasl")))
(defvar chaos-stream-id 0)
(defvar default-window-size 10.)
(defvar default-timeout 60.)
;;; See the file L;LCHNSP > for the %chaos routines
(declare (special chaos-internal-pkt-buffer)
(*expr %chaos-open-channels %chaos-close-channels
%chaos-request-connection %chaos-eof %chaos-allocate-buffer
%chaos-pktiot %chaos-get-byte %chaos-put-byte
%chaos-set-pkt-length %chaos-set-pkt-opcode
%chaos-get-pkt-length %chaos-get-pkt-opcode))
;;; Compile time constants
(eval-when (eval compile)
;;; Connection state symbols
(setq %cscls 0 %csrfs 3 %csopn 4 %cslos 5 %csinc 6
;;; Packet Opcode definitions
%codat 200 %coeof 14 %cocls 3
;;; Other constants
max-connect-tries 5
max-pkt-size-bytes 488.)
;;; Stream slot indices (should be done as a structure, but sfa's don't win...)
(let ((slot-index 0)) ;crock...
(mapc #'(lambda(slot) (set slot (setq slot-index (1+ slot-index))))
'(connection host-address contact-name request-or-listen
byte-size window-size timeout
untyi-list in-buffer out-buffer in-count out-count
max-chaosnet-stream-slot)))) ;this must be last
;;; Generate a bare chaosnet-stream object
(defun make-chaosnet-stream ()
(let ((stream (sfa-create #'chaosnet-stream-function
#.max-chaosnet-stream-slot
(format nil "chaos-stream-object-~A"
(setq chaos-stream-id (1+ chaos-stream-id))))))
(sfa-store stream #.host-address nil)
(sfa-store stream #.contact-name nil)
(sfa-store stream #.request-or-listen t) ;default to RFC
(sfa-store stream #.byte-size 8)
(sfa-store stream #.window-size default-window-size)
(sfa-store stream #.timeout default-timeout)
(sfa-store stream #.in-count -1)
(sfa-store stream #.out-count 0)
(sfa-store stream #.in-buffer (%chaos-allocate-buffer))
(sfa-store stream #.out-buffer (%chaos-allocate-buffer))
stream))
;;; chaosnet-stream-function is at the end of the file because it depends on
;;; the following macros.
;;; These macros are only to be expanded inside chaosnet-stream-function
;;; OPEN msg handler. Format is (OPEN <stream> <option-list>) where
;;; <stream> is a chaosnet stream as returned by (MAKE-CHAOSNET-STREAM) and
;;; <option-list> is a list of keywords and values (keywd1 val1 keywd2 val2 ..)
;;; Known options are: HOST (or ADDRESS or HOST-ADDRESS) - Chaosnet host addr
;;; CONTACT-NAME (or CONTACT or NAME) - Contact name + JCL
;;; REQUEST or LISTEN - same as CONTACT
;;; BYTE-SIZE (or BYTE) - byte size (8)
;;; WINDOW-SIZE (or WINDOW) - xmt window size
;;; Note: HOST-ADDRESS and CONTACT-NAME are required.
;;; [Should OPEN errors here be signaled in a special way to be compatible?]
;;; Map keywords into slot indices with an occassional side-effect.
(defmacro chaosnet-stream-keyword-decode (stream keyword)
`(caseq ,keyword
((host address host-address host-number)
#.host-address)
((contact name contact-name request)
(sfa-store ,stream #.request-or-listen T)
#.contact-name)
(listen
(sfa-store ,stream #.request-or-listen NIL)
#.contact-name)
((byte byte-size) #.byte-size)
((window window-size) #.window-size)
(timeout #.timeout)
(T (ferror nil "Unknown keyword in OPEN for ~A - ~A"
,stream keyword))))
(defmacro chaosnet-stream-open (stream args)
`(progn
(loop for (keyword value) on ,args by #'cddr
for index = (chaosnet-stream-keyword-decode ,stream keyword)
do (sfa-store ,stream index value))
(sfa-call ,stream 'close nil) ;make sure its closed
(if (null (sfa-get ,stream #.host-address))
(ferror nil
"Error handling OPEN for ~A: No host address specified."
,stream))
(if (null (sfa-get ,stream #.contact-name))
(ferror nil
"Error handling OPEN for ~A: No contact name specified."
,stream))
(if (null (sfa-get ,stream #.connection)) ;create a connection,
(sfa-store ,stream #.connection ;if needed
(%chaos-open-channels (sfa-get ,stream #.window-size))))
(loop ;repeat #.max-connect-tries ; would be nicer...
for connect-tries from 1 to #.max-connect-tries and
state =
(*catch 'chaos-pktiot-error ;catch IOC errors
(%chaos-request-connection
(sfa-get ,stream #.connection)
(sfa-get ,stream #.host-address)
(sfa-get ,stream #.contact-name)
(sfa-get ,stream #.request-or-listen)
(sfa-get ,stream #.timeout)))
until (= #.%csopn state)
finally
(if (not (= #.%csopn state))
(error (get-chaosnet-error-msg ,stream)
"some error from chaos site")))
(sfa-call ,stream 'clear-input nil)
(sfa-call ,stream 'clear-output nil)
,stream))
;;; CLOSE msg handler. Shuts down the connection and frees up the channels.
(defmacro chaosnet-stream-close (stream)
`(let ((conn (sfa-get ,stream #.connection)))
(sfa-store ,stream #.connection nil)
(unless (null conn)
(*catch 'chaos-pktiot-error (%chaos-eof conn))
(%chaos-close-channels conn))))
;;; Standard stream operations
;;; Define a wrapper to catch IOC errors and handle them nicely
(defmacro chaosnet-op (stream &rest body)
`(if (null (*catch 'chaos-pktiot-error ,@ body))
(error (get-chaosnet-error-msg ,stream) "some error from chaos site"
'fail-act
)))
;;; TYI and TYO ignore BYTE-SIZE and always return/take 8-bit bytes.
;;; UNTYI can take anything (and TYI after UNTYI will return anything).
(defmacro chaosnet-stream-tyi (stream eof)
`(let ((utl (sfa-get ,stream #.untyi-list)))
(if utl (prog1 (car utl) (sfa-store ,stream #.untyi-list (cdr utl)))
(let ((ibuf (sfa-get ,stream #.in-buffer))
(cnt (sfa-get ,stream #.in-count)))
(when (<= cnt 0)
(chaosnet-op ,stream
(%chaos-pktiot
(car (sfa-get ,stream #.connection))
ibuf))
(sfa-store ,stream #.in-count
(setq cnt (%chaos-get-pkt-length ibuf))))
(cond ((= #.%coeof (%chaos-get-pkt-opcode ibuf))
(sfa-call ,stream 'clear-input nil)
,eof)
((= #.%cocls (%chaos-get-pkt-opcode ibuf))
(error (get-chaosnet-error-msg ,stream T))) ;cls-flag
((= 0 cnt) (sfa-call ,stream 'tyi ,eof))
(T (sfa-store ,stream #.in-count (1- cnt))
(%chaos-get-byte
ibuf
(- (%chaos-get-pkt-length ibuf) cnt))))))))
(defmacro chaosnet-stream-untyi (stream byte)
`(sfa-store ,stream #.untyi-list
(push ,byte (sfa-get ,stream #.untyi-list))))
(defmacro chaosnet-stream-tyo (stream byte)
`(let ((cnt (sfa-get ,stream #.out-count)))
(%chaos-put-byte (sfa-get ,stream #.out-buffer) ,byte)
(setq cnt (1+ cnt))
(if (> cnt #.(1- max-pkt-size-bytes)) (sfa-call ,stream 'force-output
nil)
(sfa-store ,stream #.out-count cnt))
T))
;;; what should IN and OUT do? (pack arbitrary byte sizes into 16 bit words?)
(defmacro chaosnet-stream-in (stream eof)
`(sfa-call ,stream 'tyi ,eof)) ;should do something better..
(defmacro chaosnet-stream-out (stream word)
`(sfa-call ,stream 'tyo ,word))
(defmacro chaosnet-stream-force-output (stream)
`(when (> (sfa-get ,stream #.out-count) 0)
(chaosnet-op ,stream
(%chaos-pktiot (cdr (sfa-get ,stream #.connection))
(sfa-get ,stream #.out-buffer)))
(sfa-call ,stream 'clear-output nil)))
(defmacro chaosnet-stream-clear-input (stream)
`(loop with ary = chaos-internal-pkt-buffer and
ichan = (car (sfa-get ,stream #.connection))
for count = (lsh (nth 2 (syscall 3 'whyint ichan)) -18.)
while (and (> count 0)
(*catch 'chaos-pktiot-error (%chaos-pktiot ichan ary)))
finally (sfa-store ,stream #.in-count -1) ;no packet
(sfa-store ,stream #.untyi-list nil)
(return T)))
(defmacro chaosnet-stream-clear-output (stream)
`(let ((obuf (sfa-get ,stream #.out-buffer)))
(sfa-store ,stream #.out-count 0)
(%chaos-set-pkt-length obuf 0)
(%chaos-set-pkt-opcode obuf #.%codat))) ;data opcode
;;; Non-standard stream operations
;;; Input a packet into an array
(defmacro chaosnet-stream-packet-in (stream array)
`(let ((ibuf (sfa-get ,stream #.in-buffer)))
(chaosnet-op ,stream
(%chaos-pktiot (car (sfa-get ,stream #.connection))
ibuf)
(fillarray ,array ibuf))
T))
(defmacro chaosnet-stream-packet-out (stream array)
`(let ((obuf (sfa-get ,stream #.out-buffer)))
(chaosnet-op ,stream
(fillarray obuf ,array) ;how big is obuf?
(%chaos-pktiot (cdr (sfa-get ,stream #.connection))
obuf))))
;;; These should probably be made more efficient someday...
(defmacro chaosnet-stream-array-in (stream array count)
`(progn
(dotimes (i ,count)
(setf (arraycall fixnum ,array i) (sfa-call ,stream 'tyi 0)))
T))
(defmacro chaosnet-stream-array-out (stream array count)
`(progn
(dotimes (i ,count)
(sfa-call ,stream 'out (arraycall fixnum ,array i)))
T))
(defmacro chaosnet-stream-eof (stream msg) ;hack the msg someday
`(progn (sfa-call ,stream 'force-output nil)
(chaosnet-op ,stream (%chaos-eof (sfa-get ,stream #.connection)))
(sfa-call ,stream 'clear-output nil)))
;;; Dispatching function for Chaosnet streams
(declare (*lexpr get-chaosnet-error-msg))
(defun chaosnet-stream-function (stream msg arg)
(caseq msg
(which-operations '(open close untyi tyi tyo in out force-output eof
clear-input clear-output
packet-in packet-out
array-in array-out))
;standard operations
(open (chaosnet-stream-open stream arg))
(close (chaosnet-stream-close stream))
(untyi (chaosnet-stream-untyi stream arg))
(tyi (chaosnet-stream-tyi stream arg))
(tyo (chaosnet-stream-tyo stream arg))
(in (chaosnet-stream-in stream arg))
(out (chaosnet-stream-out stream arg))
(force-output (chaosnet-stream-force-output stream))
(clear-input (chaosnet-stream-clear-input stream))
(clear-output (chaosnet-stream-clear-output stream))
;non-standard operations
(packet-in (chaosnet-stream-packet-in stream arg))
(packet-out (chaosnet-stream-packet-out stream arg))
(array-in (chaosnet-stream-array-in stream (car arg) (cadr arg)))
(array-out (chaosnet-stream-array-out stream (car arg) (cadr arg)))
(eof (chaosnet-stream-eof stream arg))
(T (ferror nil "Unknown stream operation - ~A" msg))))
;;; Function forms of non-standard stream operations
;;; packet-in/out reads/writes a packet to/from a fixnum array
;;; data is packed 32-bit to a word, left adjusted.
(defun packet-in (stream array)
(sfa-call stream 'packet-in array))
(defun packet-out (stream array)
(sfa-call stream 'packet-out array))
;;; Engorge or disgorge <n> numbers into or out of an array.
;;; Packing is either 8,16, or 32 bit, depending on the mode of the OPEN.
(defun array-in (stream array count)
(sfa-call stream 'array-in (list array count)))
(defun array-out (stream array count)
(sfa-call stream 'array-out (list array count)))
;;; Read and stringify a message about why a connection is losing
(defun get-chaosnet-error-msg (stream &optional (cls-flag nil)
&aux (ichan (car (sfa-get stream #.connection)))
(ary (sfa-get stream #.in-buffer)))
(let ((count (lsh (nth 2 (syscall 3 'whyint ichan)) -18.)))
(if (not (or cls-flag
(and (> count 0)
(*catch 'chaos-pktiot-error (%chaos-pktiot ichan ary)))))
"Chaosnet Lossage - cause undetermined."
(maknam (loop for i from 4
for word = (arraycall fixnum ary i)
until (= 0 word)
collect (load-byte word 28. 8)
collect (load-byte word 20. 8)
collect (load-byte word 12. 8)
collect (load-byte word 4. 8))))))
;; Local Modes:
;; Mode: LISP
;; Comment Col:40
;; END:

1378
src/libdoc/lets.rcw1 Executable file
View File

File diff suppressed because it is too large Load Diff

79
src/libdoc/linere.jonl2 Executable file
View File

@@ -0,0 +1,79 @@
;;; -*-LISP-*-
;;; This function acts like READLINE, except instead of returning
;;; a "compressed" symbol, it "reads" each s-expression in the
;;; line, and returns a list of these s-expressions.
;;; Arguments: 0 to 2, just like READLINE, an optional EOF value,
;;; and an optional input file. Default is () for EOF value, and
;;; TYI for input file.
(herald LINEREAD /2)
(declare (setq defmacro-for-compiling () defmacro-displace-call () ))
(defmacro SQUIDIFY (x)
(COND ((MEMQ COMPILER-STATE '(COMPILE MAKLAP DECLARE))
`(,squid (LIST ',x)))
(`(QUOTE ,(list x)))) )
(defun LINEREAD n
(and (> n 2) (error '|Too many args - LINEREAD| (listify n)))
(LET ((OLD-CR-SYNTAX (STATUS SYNTAX 13.))
(OLD-TTYREAD (STATUS TTYREAD))
(UNIQUE (SQUIDIFY LINEREAD))
FILE EOFFL EOFVAL
TTYFL OLD-ITS-TTYVARS TEM)
(SETQ FILE (COND ((= N 0) TYI)
((COND ((FILEP (SETQ TEM (ARG 1))))
((MEMQ TEM '(T NIL))
(SETQ TEM TYI)
'T))
(AND (> N 1) (SETQ EOFFL 'T EOFVAL (ARG 2)))
TEM)
((= N 1)
(SETQ EOFFL 'T EOFVAL (ARG 1))
TYI)
((COND ((FILEP (SETQ TEM (ARG 2))))
((MEMQ TEM '(T NIL))
(SETQ TEM TYI)
'T))
(SETQ EOFFL 'T EOFVAL (ARG 1))
TEM)))
(COND ((AND (STATUS FEATURE ITS)
(MEMQ 'TTY (CAR (STATUS FILEMODE FILE))))
(SETQ TTYFL 'T)
(SETQ OLD-ITS-TTYVARS (STATUS TTY))))
(UNWIND-PROTECT
(PROG (LIST-OF-FORMS START-CHAR)
(SETSYNTAX 13. 197472. ()) ;Make <cr> both a "Force-feed"
;601540 ; and a "single" char object.
(SSTATUS TTYREAD ())
(COND (TTYFL
;TURN OFF ITS ACTIVATION CHARS EXCEPT FOR <bs> and <cr>
(SSTATUS TTY (BOOLE 6 34087042. (CAR OLD-ITS-TTYVARS))
;000202020202
(BOOLE 7 (BOOLE 6 2181570560.
;020202020000
(CADR OLD-ITS-TTYVARS))
8320.))
;000000020200
))
LP (SETQ START-CHAR (TYIPEEK 'T FILE))
(SETQ TEM (COND ((= START-CHAR 13.)
(TYI FILE) ;Flush worthless <cr>
(RETURN (NREVERSE LIST-OF-FORMS)))
((= START-CHAR 41.)
(PROG2 (SETSYNTAX 13. OLD-CR-SYNTAX () )
(READ UNIQUE FILE)
(SETSYNTAX 13. 197472. ())
;601540
))
((READ UNIQUE FILE))))
(AND (EQ TEM UNIQUE) (RETURN (AND EOFFL EOFVAL)))
(PUSH TEM LIST-OF-FORMS)
(GO LP))
(AND OLD-TTYREAD (SSTATUS TTYREAD T))
(SETSYNTAX 13. OLD-CR-SYNTAX ())
(COND (TTYFL (SSTATUS TTY (CAR OLD-ITS-TTYVARS) (CADR OLD-ITS-TTYVARS))
(SSTATUS TTYREAD T))))))

34
src/libdoc/link.gls Executable file
View File

@@ -0,0 +1,34 @@
TITLE LINK FUNCTION FOR LISP NEWIO (ITS)
.FASL
.INSRT SYS:.FASL DEFS
.ENTRY LINK SUBR 000003 ;SUBR 2
PUSHJ P,2MERGE ;GET MERGED FILE SPECS
.CALL LINK9 ;LINK 'EM UP
IOJRST 0,LINK1 ;LOSE LOSE
PUSHJ P,6BTNML ;IF WIN, RETURN TO FILE NAMES
SUB FXP,[4,,4]
POPJ P,
LINK1: PUSHJ P,6BTNML
CALL 1,.FUNCTION NCONS
PUSH P,A
PUSHJ P,6BTNML
POP P,B
CALL 2,.FUNCTION CONS
MOVEI B,.ATOM LINK
JRST XCIOL
LINK9: SETZ
SIXBIT \MLINK\ ;MAKE LINK
,,-7(FXP) ;FROM DEVICE
,,-5(FXP) ;FROM FILE NAME 1
,,-4(FXP) ;FROM FILE NAME 2
,,-6(FXP) ;FROM SNAME
,,-1(FXP) ;TO FILE NAME 1
,,0(FXP) ;TO FILE NAME 2
400000,,-2(FXP) ;TO SNAME
FASEND

798
src/libdoc/lispt.jlk708 Executable file
View File

@@ -0,0 +1,798 @@
;;; LISP Inferior-job Editing Package
(comment declarations and special variables)
(declare (special editor-jname editor-job null editor-usr-input editor-usr-output
lispt-read-loop crlf lispt-jname lispt-file
lispt-file-forced lispt-protect tty-return-prompt?
lispt-initial-sname lispt-text-string lispt-prompter
lispt-tty-to-ddt-msg lispt-tty-passing-msg tty-verbose
current-job tty-return-list default-tty-return-list
tty-passing-msg current-editor-buffer current-teco-buffer-block
roving-editor?)
(fixnum (examine-job fixnum))
(notype (deposit-job fixnum fixnum))
(*expr make-job load-job start-job job-returned-tty wait-for-job
deposit-job examine-job job-uset-write job-uset-read
set-job-start-adr usr-open-fix return-to-ddt
kill-job disown-job job-start-adr continue-job select-job
clear-tty-return set-jcl)
(genprefix /|lt))
(eval-when (eval compile)
(setq ibase 8)
(cond ((not (get '*uset 'macro))
(fasload lusets fasl dsk liblsp)))
(cond ((not (status feature lspmac))
(fasload lspmac fasl dsk liblsp)))
(setsyntax '/# 'macro '/#macro) ;enable #
(defun 6bit macro (x) (list 'car (list 'pnget (cadr x) 6)))
; TECO Buffer Block symbols and other things (.OPTION bits)
(setq beg 0 begv 1 pt 2 gpt 3 zv 4 z 5 extrac 6 crlf '|/
| null (ascii 0) bufblk 2 suparg 8 supcmd 7 read-jcl 1 edit-text 2
select-buffer 3 optddt 1_36))
; insert the kludgey LISP patch
(include |dsk:libdoc;lispt patch|)
(sstatus feature lispt) ; this comes after the patch
; LISP EXTERNAL REFERENCES FOR JOB MANIPULATION
(mapc '(lambda(x) (cond ((not (getl x '(subr expr autoload)))
(putprop x '(lddt fasl dsk liblsp) 'autoload))))
'(start-job set-job-start-adr continue-job wait-for-job make-job
set-job-start-adr disown-job job-start-adr))
(mapc '(lambda(x) (cond ((not (getl x '(subr autoload)))
(putprop x '(humble fasl dsk liblsp) 'autoload))))
'(select-job load-job kill-job examine-job deposit-job
job-uset-read job-uset-write))
;;; GLOBAL VARIABLES
(setq editor-job nil editor-usr-input nil editor-usr-output nil
editor-jname nil lispt-file-forced nil)
;;; These symbols may have previous definitions by the user
(special-init lispt-file '((dsk sys2) ts lispt))
(special-init lispt-initial-sname (status udir))
(special-init lispt-jname (cond ((status feature macsyma) 'macst) (t 'lispt)))
(special-init lispt-protect nil)
(special-init lispt-prompter (cond ((status feature macsyma) 'ttyretfun)
(t 'lisp-prompt)))
(special-init lispt-tty-passing-msg '|(Console Passing to the Editor)|)
(special-init lispt-tty-to-ddt-msg '|(Console Passing to DDT)|)
(special-init roving-editor? t)
(cond ((status feature macsyma)
(defprop $edprotect lispt-protect alias)
(defprop lispt-protect edprotect reversealias)
(defprop $rover roving-editor? alias)
(defprop roving-editor? rover reversealias)))
(COMMENT INTERRUPT HANDLER FOR /.BREAK 16 FROM TECO)
;;; THE .BREAK 16, CONVENTION FOR COMMUNICATING WITH AN INFERIOR TECO
;;; 100000 IS DECODED BY THE REMAINING BITS:
;;; 1 - DO A READ-EVAL-PRIN1 LOOP OVER THE WHOLE BUFFER.
;;; 2 - TRY ZAPPING MACSYMA CODE IF IN A MACSYMA
;;; 4 - random text
;;; 10 - return to DDT, and upon return, directly back to the editor
;;; 20 - return to DDT
;;; 40
;;; 100 - silent return (i.e. tty wasn't used by TECO
;;; 200
;;; 400
;;; 1000 - error return. Encountered errors while executing
;;; TECO commands requested by the superior. The
;;; error message is left in a buffer for the superior
;;; to read. After doing that, the superior should
;;; continue the teco to allow it to clean up, and then
;;; the teco will return silently.
;;; OTHERWISE JUST GENTLY RETURN
(SETQ *BREAK16-FUNCTION '*BREAK-TECO)
(defun *break-teco (eff)
(caseq (boole 1 7777 eff)
(1 (load-from-teco editor-job))
(2 (batch-from-teco editor-job))
(4 (lispt-read-text editor-job))
(10 (lispt-return-to-ddt t))
(20 (lispt-return-to-ddt nil))
(100 (clear-tty-return)) ; silent return
(1000 (lispt-teco-error editor-job)))
null)
(COMMENT LOAD AND START EDITOR)
(DEFUN MAKE-EDITOR NIL
(LET ((FILE LISPT-FILE-FORCED)
(JOB-ORIGIN) (JNAME-TAIL)
(JNAME-LIST (EXPLODEN LISPT-JNAME))
(FILE-LIST `(((DSK ,(STATUS hsname)) ,(status xuname) LISPT)
((DSK ,(STATUS hsname)) ,(status xuname) EDIT)
,LISPT-FILE)))
(IF (AND FILE (ATOM FILE)) (SETQ FILE `(TS ,FILE)))
(IF FILE (SETQ FILE-LIST
(NCONC (LIST (MERGEF FILE `((DSK ,(STATUS UDIR))))
(MERGEF FILE `((DSK ,(STATUS hsname))))
(MERGEF FILE `((DSK SYS)))
(MERGEF FILE `((DSK SYS1)))
(MERGEF FILE `((DSK SYS2))))
FILE-LIST)))
(DO ((FL FILE-LIST (CDR FL)))
((NULL FL) (ERROR '|Can't find editor on disk! |))
(IF (PROBEF (CAR FL)) (RETURN (SETQ FILE (CAR FL)))))
(IF (> (LENGTH JNAME-LIST) 6)
(DO ((L (NREVERSE JNAME-LIST) (CDR L)))
((NOT (> (LENGTH L) 6)) (SETQ JNAME-LIST (NREVERSE L)))))
(DO ((JNAME (PROG2 NIL (IMPLODE JNAME-LIST)
(SETQ JNAME-LIST (NREVERSE JNAME-LIST)
JNAME-TAIL
(IF (= 6 (LENGTH JNAME-LIST)) (RPLACA JNAME-LIST 0)
(CONS 0 JNAME-LIST))
JNAME-LIST (NREVERSE JNAME-TAIL)))
(PROG2 (RPLACA JNAME-TAIL (+ I 60)) (IMPLODE JNAME-LIST)))
(I 0 (1+ I)) (JOB))
((> I 7) (ERROR '|Can't create LISPT job |))
(SETQ JOB (MAKE-JOB JNAME)
JOB-ORIGIN (CAR JOB)
JOB (CADR JOB))
(IF (NULL JOB-ORIGIN) (ERROR '|Can't Create job (system full?) |))
(IF (NOT (EQ 'FOREIGN JOB-ORIGIN))
(RETURN (SETQ EDITOR-JNAME JNAME EDITOR-JOB JOB))))
(IF (NOT (GETL 'START-JOB '(EXPR SUBR))) ; need LDDT below
(LET ((^W T) (DEFAULTF))
(APPLY 'FASLOAD (GET 'START-JOB 'AUTOLOAD))))
(IF (NOT (EQ 'REOWNED JOB-ORIGIN))
(PROGN (IF (LOAD-JOB FILE) (ERROR '|Can't load LISPT job |))
(COND (TTY-VERBOSE
(IF (NOT (= 0 (CDR (CURSORPOS)))) (TERPRI))
(MAPC 'PRINC `(|; Editor job "| ,EDITOR-JNAME
|" Created | ,CRLF))))
(SET-JOB-START-ADR EDITOR-JOB (+ 2 (JOB-START-ADR EDITOR-JOB)))
(*USET *SSNAM (6BIT LISPT-INITIAL-SNAME)))
(IF (NOT (= 0 (CDR (CURSORPOS)))) (TERPRI))
(MAPC 'PRINC `(|; Editor job "| ,EDITOR-JNAME |" Reowned | ,CRLF))
(SET-JOB-START-ADR EDITOR-JOB 4002)) ; MAY NOT WIN. FOR $G RECOVERY.
(IF LISPT-PROTECT (VALRET* '|/..SAFE//1/î:VP |))
JOB-ORIGIN))
(defun start-editor nil
(if (not (inf-editor-test)) (make-editor))
(continue-editor t))
(defun GZP-editor nil
(if (not (inf-editor-test)) (make-editor))
(set-jcl '|100100. FS EXIT|)
(select-job editor-job)
(continue-job t)
(wait-for-editor)
T)
(defun continue-editor (tty-flag)
(setq tty-passing-msg lispt-tty-passing-msg)
(select-job editor-job)
(continue-job tty-flag))
(defun wait-for-editor nil (wait-for-job editor-job))
(COMMENT EDITOR JOB CONTROL)
(DEFUN KILL-EDITOR NIL
(IF EDITOR-JOB (PROGN (CLEAN-UP-EDITOR)
(SELECT-JOB EDITOR-JOB)
(KILL-JOB)
(PRINC0 '|; Job "|) (PRINC EDITOR-JNAME)
(PRINC '|" killed|) (TERPRI)
(SETQ EDITOR-JOB NIL EDITOR-JNAME NIL))
(PRINC0 '|; No editor job? |) (TERPRI))
'DONE)
(DEFUN $KILLEDITOR NIL (KILL-EDITOR) '$DONE)
(DEFUN DISOWN-EDITOR NIL
(IF EDITOR-JOB (PROG2 (CLEAN-UP-EDITOR)
(DISOWN-JOB EDITOR-JOB)
(PRINC0 '|; Job "|) (PRINC EDITOR-JNAME)
(PRINC '|" disowned |) (TERPRI)
(SETQ EDITOR-JOB NIL EDITOR-JNAME NIL))
(PRINC0 '|; No editor job? |) (TERPRI) NIL))
(DEFUN $DISOWNEDITOR NIL (IF (DISOWN-EDITOR) '$DONE))
(DEFUN REOWN-EDITOR (X)
(PROG NIL
(SETQ X (IF (NULL X) 'LISPT X))
(COND ((AND EDITOR-JOB (EQ EDITOR-JNAME X))
(PRINC0 '|; Editor already owned |)
(RETURN '*))
(EDITOR-JOB (CLOBBER-EDITOR?)))
(LET ((JOB (MAKE-JOB X)))
(COND ((EQ 'REOWNED (CAR JOB))
(SETQ EDITOR-JNAME X EDITOR-JOB (CADR JOB))
(SET-JOB-START-ADR EDITOR-JOB 4000)
(RETURN T))
(T (KILL-JOB)
(PRINC0 '|; Job "|) (PRINC X)
(IF (EQ 'FOREIGN (CAR JOB))
(PRINC '|" is owned by another job|)
(PRINC '|" not found |))
(TERPRI))))
(IF LISPT-PROTECT (VALRET* '|/..SAFE//1/î:VP |))))
(DEFUN $REOWNEDITOR MACRO (X)
`(PROGN (REOWN-EDITOR .,(IF X (MAPCAR 'STRIPDOLLAR X)))
'$DONE))
(DEFUN CLEAN-UP-EDITOR NIL
(IF EDITOR-USR-OUTPUT (CLOSE-EDITOR EDITOR-USR-OUTPUT))
(IF EDITOR-USR-INPUT (CLOSE-EDITOR EDITOR-USR-INPUT)))
(COMMENT Open and Closing files to Editor Buffers)
(DECLARE (SPECIAL TECO-PC))
(DEFUN OPEN-EDITOR (JOB MODE)
(COND ((EQ 'INPUT MODE)
(SETQ EDITOR-USR-INPUT (OPEN JOB '(IN ASCII)))
(USR-OPEN-FIX EDITOR-USR-INPUT (TECO-V #,ZV))
(FILEPOS EDITOR-USR-INPUT (TECO-V #,BEGV))
EDITOR-USR-INPUT)
(T (SETQ EDITOR-USR-OUTPUT (OPEN JOB '(OUT ASCII)))
(USR-OPEN-FIX EDITOR-USR-OUTPUT (TECO-V #,ZV))
(FILEPOS EDITOR-USR-OUTPUT (TECO-V #,PT))
EDITOR-USR-OUTPUT)))
(DEFUN CLOSE-EDITOR (FILE) ; not too exciting for now
(CLOSE FILE)
(SET (IF (EQ EDITOR-USR-INPUT FILE) 'EDITOR-USR-INPUT 'EDITOR-USR-OUTPUT)
NIL)
T)
(DEFUN TECO-V (X)
(LET ((BUFBLK (EXAMINE-JOB #,BUFBLK)))
(LET ((VX (EXAMINE-JOB (+ BUFBLK X))))
(COND ((NOT (< VX (EXAMINE-JOB (+ BUFBLK #,GPT))))
(+ VX (EXAMINE-JOB (+ BUFBLK #,EXTRAC))))
(T VX)))))
(setq current-editor-buffer nil)
(declare (*lexpr run-teco))
; Crufty TECO code below is for editor independence (ugh). It simply runs
; MM & LISPT SELECT WRITE BUFFER
(defun select-buffer (buffer)
(let ((tty-return))
(if (not (inf-editor-test))
(error '|Can't select buffer - No editor job.|))
(if (not (atom buffer))
(error '|Buffer names must be atoms.|))
(if editor-usr-output (close-editor editor-usr-output))
(setq current-editor-buffer buffer)
(select-job editor-job)
(set-jcl buffer)
(let ((save-pc (*uset *rupc)) (bb (examine-job #,bufblk)))
(declare (fixnum bb save-pc))
(deposit-job (+ bb #,suparg) #,select-buffer)
(*uset *supc (+ bb #,supcmd))
(continue-job T) ; JCL hacker gives tty back too
(wait-for-editor)
(setq current-teco-buffer-block (examine-job #,bufblk))
(continue-job T)
(wait-for-job editor-job)
(*uset *supc save-pc))
(open-editor editor-job 'output)
T))
(defun run-teco-command (cmd)
(select-job editor-job)
(let ((save-pc (*uset *rupc)) (bb (examine-job #,bufblk)) (TTY-RETURN))
(declare (fixnum bb save-pc))
(deposit-job (+ bb #,suparg) cmd)
(*uset *supc (+ bb #,supcmd))
(continue-job T) ; JCL hacker gives tty back too
(wait-for-editor)
(*uset *supc save-pc))
t)
(defun run-teco n
(select-job editor-job)
(apply 'set-jcl (listify n))
(let ((save-pc (*uset *rupc)) (bb (examine-job #,bufblk)))
(declare (fixnum bb save-pc))
(deposit-job (+ bb #,suparg) #,read-jcl)
(*uset *supc (+ bb #,supcmd))
(let ((tty-return))
(continue-job T)
(wait-for-job editor-job))
(*uset *supc save-pc))
t)
; ERROR Handling for Errors in TECO while executing JCL commands
; assumes that TECO has closed the gap in the current buffer
(defun lispt-teco-error (job)
(clear-tty-return)
(let ((editor-usr-input) (lispt-text-string))
(princ0 '|; Error while editor executing commands requested by LISP:|)
(terpri) (princ (lispt-read-text job)) (terpri)
(nointerrupt nil)
(select-job job)
(let ((tty-return))
(continue-job T)
(wait-for-job job))
(tyipeek nil tyi)))
(COMMENT READ-EVAL ROUTINE)
(special-init lispt-read-loop 'default-lispt-read-eval-print-loop)
(special-init lispt-readtable readtable)
(defun load-from-teco (job)
(let ((prompt? tty-return-prompt?))
(clear-tty-return)
(open-editor job 'input)
(funcall lispt-read-loop)
(close-editor editor-usr-input)
(if prompt? (funcall lispt-prompter nil))))
(defun default-lispt-read-eval-print-loop nil
(let ((errlist '((princ '|; Reading from the editor aborted|) (terpri))))
(cursorpos 'c) ; start with a fresh screen
(princ0 '|; Reading from the editor |) (terpri)
(do ((infile editor-usr-input) (^Q T) (expr))
(NIL)
(setq expr (funcall (or read 'read) 'LISPT-EOF))
(IF (EQ 'LISPT-EOF EXPR) (RETURN NIL))
(setq + expr)
(if (and (not (atom expr)) (eq 'INCLUDE (car expr)))
(let ((file (cadr expr)))
(princ0 '|; Including File |) (princ file)
(funcall 'load file)
(terpri) (princ '|; End of File |)
(princ file)))
(terpri) (funcall (or prin1 'prin1) (setq * (eval expr)))))
(terpri) (terpri) (princ '|; Finished reading |))
(COMMENT OUTPUT TO EDITOR BUFFERS)
(defun eprinc n ; doesn't force output
(if (and (> n 1) (not (eq (arg 2) current-editor-buffer)))
(select-buffer (arg 2)))
(princ (if (> n 0) (arg 1)) editor-usr-output)
T)
(defun eprint n
(if (and (> n 1) (not (eq (arg 2) current-editor-buffer)))
(select-buffer (arg 2)))
(print (if (> n 0) (arg 1)) editor-usr-output)
(eforce-output)
T)
(defun eprin1 n
(if (and (> n 1) (not (eq (arg 2) current-editor-buffer)))
(select-buffer (arg 2)))
(prin1 (if (> n 0) (arg 1)) editor-usr-output)
(eforce-output)
T)
(defun eterpri n
(if (and (> n 0) (not (eq (arg 1) current-editor-buffer)))
(select-buffer (arg 1)))
(terpri editor-usr-output)
(eforce-output)
T)
(defun esprinter n (editor-output 'sprinter (listify n)))
(defun egrindef fexpr (x) (editor-output 'grindef x))
(defun etyo n
(if (and (> n 1) (not (eq (arg 2) current-editor-buffer)))
(select-buffer (arg 2)))
(tyo (if (> n 0) (arg 1) 0) editor-usr-output)
t)
(defun eforce-output nil (force-output editor-usr-output))
(defun eclose nil (close-editor editor-usr-output))
(declare (macros t))
(defun editt macro (form)
(if (null (inf-editor-test)) (GZP-EDITOR))
(select-buffer 'LISP-EDIT)
(mapc '(lambda (x) (editor-output 'grindef x)) (cdr form))
(run-teco-command #,edit-text)
T)
(declare (macros nil))
(defun editor-output (op x)
(if (not (inf-editor-test)) (error '|No editor job|))
(if (= 2 (length x)) (select-buffer (cadr x)))
(if (null (and editor-usr-output current-editor-buffer))
(error '|No channel open to the editor or no buffer selected.|))
(if (null (getl 'grindef '(fsubr fexpr))) (grindef))
(let ((^w t) (^d nil) (outfiles (list editor-usr-output)) (^r t))
(apply op (list (car x))))
(eforce-output)
'*)
(COMMENT BATCH MACSYMA COMMAND FROM TECO)
(DECLARE (SPECIAL $DEMOMODE $TRANSLMODE $BATCHKILL $LINENUM CR LF TAB ST FF SP
$INCHAR $OUTCHAR REPHRASE $% $NOLABELS LINELABLE $LASTTIME
UPCASEP $CURSOR POS $DISPFLAG $FUNCTIONS $ARRAYS $ALL $INPUT
$STRDISP OLDST THISTIME IMAGE-STRING $ERRORFUN)
(*LEXPR PRINT-CONSOLE-MSG)
(*EXPR KILL1 STRIPDOLLAR TYI* PARSE1 CONTINUE1 TRANSLATE-MACEXPR
PRINTLABEL DISPLAY* MAKELABEL $RESET MAKSTRING GETLABELS
STRMEVAL GETLABELS* CONSFUNDEF MGET LISTARGP ERLIST REPRINT
CHECKLABEL))
(SETQ $DEMOMODE NIL $TRANSLMODE NIL)
(DEFUN BATCH-FROM-TECO (JOB)
(LET ((PROMPT? TTY-RETURN-PROMPT?))
(IF (NOT (STATUS FEATURE MACSYMA))
(ERROR '|Zapping MACSYMA code into a LISP without MACSYMA? |))
(CLEAR-TTY-RETURN)
(CURSORPOS 'C)
(PRINT-CONSOLE-MSG '|(Reading Commands from the Editor)|)
(OPEN-EDITOR JOB 'INPUT)
(COND ((PROG2 NIL (TECO-BATCH)
(CLOSE-EDITOR EDITOR-USR-INPUT))
(PRINT-CONSOLE-MSG '|(Finished)|)))
(IF PROMPT? (FUNCALL lispt-prompter NIL))
NULL))
(DEFUN TECO-BATCH NIL
(LET (($DISPFLAG) (ST) ($ERRORFUN 'TECO-BATCH-ERROR)
(ERRLIST '((TECO-BATCH-ERROR))))
(COND ($BATCHKILL (KILL1 $BATCHKILL)
(COND ((EQ $BATCHKILL T) ($RESET))) (GCTWA)))
(COND ((NOT (CHECKLABEL $INCHAR)) (SETQ $LINENUM (1+ $LINENUM))))
(MAKELABEL $INCHAR)
(DO ((COMMAND-STRING) (TERMINATOR) (COMMAND) (RESULT))
((EQ 'EOF/# TERMINATOR))
(SETQ IMAGE-STRING NIL
COMMAND-STRING (GET-COMMAND-STRING)
TERMINATOR (CAR COMMAND-STRING)
$DISPFLAG (EQ '/; TERMINATOR)
ST (mapcar '(lambda (x) (getcharn x 1)) (CDR COMMAND-STRING)))
(COND ((EQ 'EOF/# TERMINATOR) (RETURN T)))
(REPRINT IMAGE-STRING T)
(SETQ OLDST ST)
(SETQ COMMAND (COND ($TRANSLMODE ((LAMBDA (^W) (PARSE1)) NIL))
(T (PARSE1))))
(COND ((NULL COMMAND) (TERPRI)
(PRINC '|Syntax error occurred in reading commands from the editor.|)
(TERPRI) (RETURN NIL))
($TRANSLMODE (TRANSLATE-MACEXPR (CAR COMMAND)))
(T (SETQ RESULT (CONTINUE1 (CAR COMMAND)))))
(COND ((NULL RESULT) (TERPRI)
(PRINC '|Error occurred while executing commands from the editor.|)
(TERPRI) (RETURN NIL)))
(SETQ $% (CAR RESULT)) (MAKELABEL $OUTCHAR)
(COND ((NOT $NOLABELS) (SET LINELABLE $%)
(PUTPROP LINELABLE (CONS (CADR $LASTTIME) (CADDR $LASTTIME)) 'TIME)))
(COND ($DISPFLAG (REMPROP LINELABLE 'NODISP) (DISPLAY*))
(T (PUTPROP LINELABLE T 'NODISP)))
(SETQ $LINENUM (1+ $LINENUM)) (MAKELABEL $INCHAR)
(COND ($DEMOMODE (PRINC (STRIPDOLLAR $CURSOR))
(COND ((NOT (= (TYI*) 32.))
(TERPRI) (PRINC '|DEMO TERMINATED|)
(TERPRI) (SETQ ST NIL)
(RETURN nil))))))))
(DEFUN TECO-BATCH-ERROR NIL
(PRINC0 '| (Command reading from the Editor aborted)|)
(TERPRI))
(DEFUN GET-COMMAND-STRING NIL
(LET ((CH-STRING))
(DO ((CH) (STARTING T (AND STARTING (NULL CH-STRING)))
(CTRL-LIST (LIST CR LF FF TAB)))
((MEMQ CH '( EOF/# /; $)))
(SETQ CH (READCH* 'EOF/#))
(COND ((EQ '/\ CH)
(SETQ CH-STRING (CONS (SETQ CH (LET ((UPCASEP))
(READCH* 'EOF/#)))
(CONS '/\ CH-STRING))))
((EQ '/" CH)
(SETQ CH-STRING (CONS CH CH-STRING)
CH (DO ((CH) (UPCASEP))
((MEMQ CH '(/" EOF/#)) CH)
(SETQ CH (READCH* 'EOF/#)
CH-STRING (CONS CH CH-STRING)))))
((MEMQ CH CTRL-LIST)
(IF STARTING (SETQ IMAGE-STRING (CDR IMAGE-STRING))))
((AND STARTING (EQ SP CH)))
((EQ '// CH)
(SETQ CH (READCH* 'EOF/#))
(COND ((EQ '* CH) ; GOBBLE COMMENT
(SETQ STARTING NIL
CH (DO ((CH)) ((EQ 'EOF/# CH) CH)
(SETQ CH (READCH* 'EOF/#))
(IF (AND (EQ '* CH)
(EQ '//
(SETQ CH (READCH* 'EOF/#))))
(RETURN CH)))))
(T (SETQ CH-STRING (CONS CH (CONS '// CH-STRING))))))
(T (SETQ CH-STRING (CONS CH CH-STRING)))))
(IF (MEMQ (CAR CH-STRING) '(/; /$))
(DO ((CH (TYIPEEK NIL EDITOR-USR-INPUT)
(TYIPEEK NIL EDITOR-USR-INPUT)))
((MEMBER CH '(-1 15)))
(READCH* NIL)))
CH-STRING))
(DEFUN READCH* (X)
(LET ((N (TYI EDITOR-USR-INPUT 300)))
(IF (OR (= 300 N) (= 3 N)) X
(SETQ IMAGE-STRING (CONS (ASCII N) IMAGE-STRING))
(IF (AND UPCASEP (> N 96.) (< N 123.)) (ASCII (- N 32.))
(ASCII N)))))
(COMMENT READ A RANDOM STRING OF TEXT FROM TECO)
(declare (special lispt-text-string))
(setq lispt-text-string nil)
(defun lispt-read-text (job)
(open-editor job 'input)
(do ((nchlist nil (cons (tyi editor-usr-input) nchlist)))
((= -1 (car nchlist))
(close-editor editor-usr-input)
(setq lispt-text-string (implode (nreverse (cdr nchlist)))))))
(COMMENT STRING MACSYMA EXPRESSIONS INTO A EDITOR BUFFER)
(defun $selectbuffer (buffer) (select-buffer (stripdollar buffer)) '$DONE)
(DEFUN $TEDIT FEXPR (X)
(APPLY '$TSTRING X)
(CONTINUE-EDITOR T)
(WAIT-FOR-JOB EDITOR-JOB)
'$DONE)
(DECLARE (*EXPR $LISTP))
(DEFUN $TSTRING FEXPR (X)
(if (not (inf-editor-test)) (make-editor))
(if ($LISTP (car x)) (select-buffer (stripdollar (cadar x))))
(if (null editor-usr-output) (select-buffer 'MACSYMA-EDIT))
(LET ((^W T) (^D NIL) (ERROR)
(OUTFILES (LIST EDITOR-USR-OUTPUT))
(^R T))
(COND ((NULL
(ERRSET
(DO ((L X (CDR L)) (L1)) ((NULL L))
(COND ((MEMQ (CAR L) '($ALL $INPUT))
(SETQ L (NCONC (GETLABELS* $INCHAR) (CDR L))))
((EQ (CAR L) '$FUNCTIONS)
(SETQ L (NCONC (MAPCAR
(FUNCTION
(LAMBDA (X) (CONSFUNDEF (CAAR X) NIL NIL)))
(CDR $FUNCTIONS))
(MAPCAN
(FUNCTION
(LAMBDA (X)
(COND ((MGET X 'AEXPR)
(NCONS (CONSFUNDEF X T NIL))))))
(CDR $ARRAYS))
(CDR L))))
((SETQ L1 (LISTARGP (CAR L)))
(SETQ L (NCONC (GETLABELS (CAR L1) (CDR L1) T) (CDR L)))))
(TERPRI) (MAPC 'PRINC (MAKSTRING (STRMEVAL (CAR L))))
(COND ((OR (AND (ATOM (CAR L)) (GET (CAR L) 'NODISP)) (NOT $STRDISP))
(PRINC '$))
(T (PRINC '/;))))))
(SETQ ERROR T)))
(TERPRI)
(IF ERROR (LET ((ERRSET 'ERRBREAK1))
(SETQ ^W NIL)
(ERLIST '(ERROR IN TSTRING ATTEMPT))))
(SETQ ^R NIL)
(CLOSE-EDITOR EDITOR-USR-OUTPUT)
'$DONE))
(defun MACSYMA-edit-interrupt (file char) (setq char char)
(if (not (= 0 (listen file))) (tyi file))
(if (null (inf-editor-test)) (GZP-editor))
(if (not editor-usr-output) (select-buffer 'MACSYMA-EDIT))
(EPRINC (maknam (REVERSE ST)))
(eforce-output)
(run-teco-command #,edit-text)
(reprint st t)
'$DONE)
(if (and (null (status ttyint 5)) (status feature MACSYMA))
(sstatus ttyint 5 'MACSYMA-EDIT-INTERRUPT))
(COMMENT COMMANDS FOR ENTERING EDITORS)
; useless functions for calling editors
(defun $teco nil (enter-specific-inf-editor 'teco) '$done)
(defun teco nil (enter-specific-inf-editor 'teco))
(defun $emacs nil (enter-specific-inf-editor 'emacs) '$done)
(defun emacs nil (enter-specific-inf-editor 'emacs))
(defun lispt nil (enter-specific-inf-editor nil))
(declare (macros t))
(defun (inf-edit macro) (x)
(setq x (cdr x))
(cond (x `(lispt-edit ',x))
(T '(lispt-edit nil))))
(defun inf-edit* n (lispt-edit (listify n)))
(defun $edit macro (x)
(setq x (cdr x))
(cond (x `(progn (lispt-edit ',(map-strip$ x)) '$DONE))
(t '(progn (lispt-edit nil) '$DONE))))
(defun map-strip$ (x) (if (atom x) (stripdollar x) (mapcar 'map-strip$ x)))
(defun lispt-edit (x)
(if (and x (not (atom x)) (null (cdr x))) (setq x (car x)))
(let ((lispt-jname (if (null x) lispt-jname
(if (atom x) x
(if (atom (car x)) (car x)
(error '| First arg must be atomic.|)))))
(file (if (atom x) x (cadr x))))
(enter-specific-inf-editor file)))
(defun enter-specific-inf-editor (x)
(setq tty-return-prompt? nil)
(let ((lispt-file-forced x))
(if (not (inf-editor-test)) (make-editor))
(continue-editor t))
(wait-for-job editor-job)
'*)
(defun inf-editor-test nil
(or editor-job (and roving-editor? (find-roving-editor lispt-jname))))
(declare (*expr $error))
(defun find-roving-editor (jname)
(let ((job (make-job jname)))
(cond ((eq 'FOREIGN (car job))
(if (prog2 nil (not (= 0 (boole 1 #,optddt (*uset *ROPTI))))
(kill-job))
(editor-from-ddt jname)
(princ0 '|Roving editor job is inferior to some other job./
Create a new one? (Y or N):|)
(if (not (= 31 (boole 1 37 (tyi))))
(if (status feature MACSYMA) ($ERROR) (^G)))
nil))
((eq 'REOWNED (car job))
(if tty-verbose (princ0 '|; Roving editor reowned |) (TERPRI))
(setq editor-jname jname
editor-job (cadr job))
(set-job-start-adr editor-job 4000)
T)
((car job) (kill-job) nil)
(T (ERROR '|Can't create editor job (system full?)|)))))
(SSTATUS TTYINT
'/
'(LAMBDA (CHNL CHAR)
(DO ()
((OR (= 0 (LISTEN CHNL))
(= (TYI CHNL) CHAR))))
(VALRET '|/..SAFE// 1/î:VP |)
(NOINTERRUPT () )
(TERPRI (SETQ CHAR (STATUS TTYCONS CHNL)))
(PRINC '|Editor jName? | CHAR)
(AND (ZEROP (FLATC (SETQ CHAR (READLINE CHNL))))
(SETQ CHAR 'LISPT))
(UNWIND-PROTECT
(PROG2 (SETQ CHNL NOUUO)
(NOUUO ())
(LISPT-EDIT (LIST CHAR 'EMACS)))
(SSTATUS TTYINT '/ 'LISPT-EDIT-INTERRUPT)
(NOUUO CHNL))))
(defun lispt-edit-interrupt (file char)
(terpri)
(do ()
((or (= 0 (listen file))
(= (tyi file) char))))
(if (not (inf-editor-test)) (make-editor)) ; autostart
(continue-editor t)
null)
(COMMENT Commands for Passing Through to DDT)
; interrupt level routine run from *BREAK-TECO
(defun lispt-return-to-ddt (trf)
(let ((tty-return '(lambda(x) x)))
(nointerrupt nil))
(if trf (setq tty-return-list '((return-to-editor))))
(return-to-ddt))
(defun return-to-editor nil
(if editor-job
(progn (select-job editor-job)
(continue-job t)))) ; punt the tty passing message
(defun LISPT-^Z nil
(setq tty-passing-msg lispt-tty-to-ddt-msg)
(cond ((and roving-editor? editor-job)
(addl '(roving-editor-tty-return) tty-return-list)
(editor-to-ddt))))
(special-init default-return-to-ddt-list '((LISPT-^Z) (DDT-return)))
(defun roving-editor-tty-return nil
(cond ((null(errset (editor-from-ddt editor-jname) NIL))
(PRINC0 '|; Warning: Can't get the editor.|)
(terpri)
(nointerrupt nil)
(rplacd tty-return-list nil)
(if tty-return-prompt? (funcall lispt-prompter nil)))))
(defun editor-to-ddt nil
(if (null editor-job) (error '|No editor job. |))
(let ((stadr))
(select-job editor-job) (setq stadr (job-start-adr editor-job))
(clean-up-editor)
(if (null (disown-job editor-job)) (error '|Disowning the editor failed |))
(valret* '|:job | editor-jname '|  ..star//jrst | stadr '|/î:job |
(status jname) '| :vp |))
(setq editor-job nil)
'done)
(DEFUN EDITOR-FROM-DDT (X)
(SETQ X (IF (NULL X) 'LISPT X))
(IF EDITOR-JOB (CLOBBER-EDITOR?))
(LET ((JOB (MAKE-JOB X)))
(COND ((EQ 'REOWNED (CAR JOB)) (DISOWN-JOB (CADR JOB)))
((EQ 'FOREIGN (CAR JOB))
(IF (NOT (= 0 (BOOLE 1 #,OPTDDT (*USET *ROPTI))))
(KILL-JOB)
(ERROR '|Editor belongs to some job other than DDT|))
(VALRET* '|:JOB | X '| :DISOWN :JOB | (STATUS JNAME)
'| :VP |))
(T (IF (CAR JOB) (KILL-JOB)) ; INFERIOR create, or NIL
(ERROR '|Editor job doesn't exist |))))
(REOWN-EDITOR X))
(DEFUN CLOBBER-EDITOR? NIL
(LET ((^W NIL)) (PRINC0 '|Clobber the existing editor? (Y or N) |))
(IF (MEMQ (PROG2 NIL (READCH) (TERPRI)) '(Y /y)) (KILL-EDITOR)
(ERR)))
;; Local Modes:
;; Mode: LISP
;; Comment Col: 40
;; END:

221
src/libdoc/lispt.patch Executable file
View File

@@ -0,0 +1,221 @@
;;-*-LISP-*-
;; KLUDGEY PATCH FOR LISP TO GET AROUND I.T.S. LOSSAGE
;; ON INPUT, CHECKS FOR USR DEVICE, DOES WORD/BLOCK AT A TIME, BLOCK IOT'S
;; THIS CODE MUST BE CHECKED EVERY TIME A NEW LISP COMES OUT
;; THE INPUT SIDE SIMPLY HACKS $DEV5K WHICH IS THE LISP ROUTINE FOR FILLING THE
;; INPUT BUFFER FOR ASCII MODE CHANNELS ON NON-TTY DEVICES (SEE L;READER >)
;; On output, a similar trap is put in IFORCE. Unlike the input patch,
;; the output patch is a very special kludge which works by letting
;; the inferior TECO read the characters from LISP's buffer.
;; Some assumptions on which this kludge is based:
;; Assume USR-OPEN-FIX was called after calling OPEN. This
;; reopens the USR channel in block mode (but doesn't tell LISP!)
;; and sets the "file length" to whatever is specified as an arg.
;; This is usually ZV. This way, the normal LISP EOF handling
;; mechanisms can work.
;; On output, it is assumed that a variable CURRENT-TECO-BUFFER-BLOCK
;; has been set with a pointer to the buffer block of the target
;; buffer.
(eval-when (eval compile)
(SETQ OIBASE IBASE IBASE 8) ; SO WE CAN READ INTO MACSYMA AND CGOL
)
(SETQ LISPT-PATCH 0) ; HOLDS NUMBER OF "EXTRA CHARACTERS", FOR BELOW
(OR (GETDDTSYM '$DEV5K) ; BE SURE THAT SYMBOL TABLE IS LOADED
((LAMBDA (TTY-RETURN) (VALRET '|/î:SL /î:EXISTS /îºVP |)) NIL))
(LAP-A-LIST '(
(LAP LISPT-PATCH SUBR) ; ROUTINE TO ACCOMPLISH THE PATCHING
(MOVEI T ($DEV5K 0)) ; INPUT PATCH
(MOVEI TT LTINP)
(PUSHJ P PURPAT) ; GO PUT A PURE PATCH
(MOVEI T (IFORCE 4)) ; output patch
(MOVEI TT LTOUTP) ; FALL THRU
PURPAT (PUSH FXP (% PUSHJ P 0))
(PUSH FXP T) ; ALLOCATE A PDL SLOT FOR PATCH ADDRESS
(HRRM TT -1 FXP) ; ADDRESS TO COME TO, IN RH
(PUSHJ P DPUR) ; DEPURIFIES PAGE WHOSE ADDRESS IS IN 0(FXP)
(MOVE TT -1 FXP) ; GET PATCH-IN INSTRUCTION
(EXCH TT @ 0 FXP) ; SWAP THE OLD WITH THE NEW
(CAME TT @ 0 FXP) ; If same, we've already patched
(MOVEM TT @ -1 FXP) ; Otherwise save the old instruction
(PUSHJ P RPUR) ; JUST FOR WRITE PROTECTION
(SUB FXP (% 0 0 2 2)) ; POP THE FXP SLOTS
(POPJ P)
DPUR (TDZA C C)
RPUR (MOVE C 'T)
(MOVEI A 0 FXP)
(MOVEI B 0 FXP)
(JCALL 3 (FUNCTION PURIFY))
; ASCII mode input on the USR device patch:
LTINP (PUSH FXP D) ; COPIED FROM $DEV5K?
(PUSHJ P USRCHK) ; IS IT ASCII MODE ON THE USR DEVICE?
; IF NOT, RETURNS
(PUSHJ P USRPOS) ; reposition the channel
(MOVEI D 0)
(MOVE TT F/.FLEN T) ; get pseudo file length in D
(CAMG TT F/.FPOS T) ; if over EOF,
(JRST 0 USRFIX) ; skip doing input, and return 0
(PUSHJ P USRIO) ; INPUT FB.BFL CHARACTERS + (D)
(HLRES 0 D) ; UNFOLD COUNT LEFT FOR FB.CNT
(MOVNS 0 D)
(IMULI D 5)
(SUB D FB/.BFL T)
(SKIPE 0 D)
(SUB D @ (SPECIAL LISPT-PATCH)) ; add in correction for word rounding
(SUB TT F/.FPOS T)
(ADD TT D) ; adding D is subtracting the count of chars read
(SKIPG 0 TT) ; skip if not at EOF
(SUB D TT) ; subtract the difference
USRFIX (MOVNM D FB/.CNT T)
(MOVNM D FB/.BVC T)
(JUMPE D POPXDJ) ; EOF in this case
(MOVE TT FB/.IBP T) ; RESTORE THE BYTE POINTER
(SKIPE D @ (SPECIAL LISPT-PATCH)); AND WORD BOUNDARY CORRECTIONS TO DO?
IBPLP (IBP 0 TT)
(AOJL D IBPLP)
(MOVEM TT FB/.BP T)
(POP FXP D)
(JRST 0 POPJ1)
; USR device output patch.
LTOUTP (MOVE F FB/.BFL TT) ; COPIED FROM IFORCE+4?
(MOVE T TT)
(PUSHJ P USRCHK) ; IF NOT USER DEVICE, RETURNS DIRECTLY
(SUB F FB/.CNT T) ; update the filepos
(ADDM F F/.FPOS T)
(JUMPE F LTEXIT)
(HRRZ TT @ (SPECIAL CURRENT-TECO-BUFFER-BLOCK)) ;
(JUMPE TT LTEXIT) ; SKIP ON NIL (WHAT ABOUT UNBOUND?)
(ADDI TT 8) ; ADDRESS WHERE THE ARG GOES
(*CALL 0 USRACC)
(JFCL)
(HRLS 0 F)
(HRRI F FB/.BUF T) ; ADDRESS IN THE RIGHT HALF
(HRROI D F) ; -1,,F
(*CALL 0 USRIOT)
(*LOSE 1000)
(SOJ TT) ; BACK TO BUFFER BLOCK + 7
(MOVEI F 0) ; .RUPC INTO F
(PUSH FXP (% 0))
(MOVE D (% MOVEM 0 0 FXP))
(*CALL 0 USRVAR) ; SAVE THE CURRENT PC
(*LOSE 1000)
(HLL TT 0 FXP)
(MOVE D (% MOVE 0 TT)) ; SET USER PC TO SPECIFIED LOCATION
(*CALL 0 USRVAR)
(*LOSE 1000)
(MOVEI F 7) ; .RUSTP
(MOVE D (% MOVEI 0 0)) ; CLEAR USTP, ALLOWING THE INFERIOR TO RUN
(*CALL 0 USRVAR)
(*LOSE 1000)
(MOVE D (% MOVEM 0 TT)) ; WAIT UNTIL USTP IS NON-ZERO
LOOP (*CALL 0 USRVAR)
(*LOSE 1000)
(JUMPE TT LOOP)
(MOVEI F 0) ; RESTORE THE PC
(MOVE D (% MOVE 0 0 FXP))
(*CALL 0 USRVAR)
(*LOSE 1000)
(SUB FXP (% 0 0 1 1))
LTEXIT (MOVE TT T)
(JSP D FORCE6) ; RESET VARIOUS BUFFER POINTERS
(POPJ P)
USRVAR (SETZ)
(SIXBIT USRVAR)
(0 0 F/.CHAN T)
(0 0 F) ; VARIABLE SPECIFIER IN F
(0) ; IGNORED
(SETZ 0 D) ; INSTRUCTION IN D
; UTILITY ROUTINES
USRCHK (PUSH FXP F)
(PUSH FXP TT)
(MOVE D F/.DEV T) ; GET DEVICE FROM TTSAR
(MOVE F F/.MODE T) ; and check for ascii mode
(POP P TT) ; pop the stack and save in TT
(CAMN D (% (SIXBIT |USR |))) ; SIOT ON USR CHANNEL?
(TRNE F 4) ; 1.3=0 implies ascii mode
(SKIPA)
(MOVEM TT 0 p) ; clobber the return for the patch
(POP FXP TT)
(POP FXP F)
(POPJ P)
USRPOS (MOVE TT F/.FPOS T) ; FIRST, STANDARD UPDATE OF FILEPOS
(ADD TT FB/.BVC T)
(MOVEM TT F/.FPOS T)
(SETZM 0 FB/.BVC T)
(IDIVI TT 5) ; ROUND TO WORDS (CLOBBERS R - OK?)
(*CALL 0 USRACC) ; AND ACTUALLY REPOSITION
(JFCL) ; CAN'T FAIL...
(IMULI TT 5) ; BACK TO CHARS
(SUB TT F/.FPOS T) ; NUMBER OF CHARS TO SKIP (Negative)
(ADD TT CIN0) ; IN EFFECT, "FXCONS"
(MOVEM TT (SPECIAL LISPT-PATCH)) ; DUE TO FILEPOS NOT ON WORD BOUNDARY
(SUB TT CIN0)
(POPJ P)
USRIO (ADD D FB/.BFL T) ; Do input or output of (D) chars
(IDIVI D 5) ; CONVERT TO WORDS (CLOBBERS R)
(HRLOI D -1 D) ; MAKE AN AOBJN POINTER (from HAKMEM!!)
(EQVI D FB/.BUF T) ; can you figure that one out!
(*CALL 0 USRIOT) ; BLOCK IOT
(*LOSE 0 1000)
(POPJ P)
; various call blocks
USRACC (SETZ)
(SIXBIT ACCESS)
(0 0 F/.CHAN T)
(SETZ 0 TT)
USRIOT (SETZ)
(SIXBIT IOT)
(0 0 F/.CHAN T)
(SETZ 0 D) ; AOBJN POINTER IS IN D
; (USR-OPEN-FIX <file> <fillen>)
(ENTRY USR-OPEN-FIX SUBR)
(HRRZ T 1 A) ; F.FLEN TO BE (B)
(MOVEI A NIL)
(MOVE TT 0 B)
(MOVEM TT F/.FLEN T)
(MOVE TT F/.MODE T) ; REOPEN IN BLOCK MODE (BUT DON'T TELL LISP!)
(ANDI TT 1)
(IORI TT 2)
(*CALL 0 OPUSRI) ; RE-OPEN USER INPUT (SPECS FROM FILE-ARRAY)
(*LOSE 0 1000) ; WHAT IF IT FAILS?
(MOVEI A 'TRUTH)
(POPJ P)
OPUSRI (SETZ)
(SIXBIT OPEN)
(0 0 F/.CHAN T)
(5_33 0 0 TT) ; open mode (immediate cntrl arg (TT))
(0 0 F/.DEV T)
(0 0 F/.FN1 T)
(SETZ 0 F/.FN2 T)
() ; (USE WITH CAUTION - CAN CASE LOSSAGE
; IF PAGES IN INFERIOR DON'T EXIST!)
))
(AND (NOT (STATUS FEATURE LISPT)) ;PATCH TO ENABLE INTERRUPT HANDLING
(LISPT-PATCH))
(eval-when (eval compile)
(SETQ IBASE OIBASE)
)

2616
src/libdoc/loop.818 Executable file
View File

File diff suppressed because it is too large Load Diff

111
src/libdoc/lscall.16 Executable file
View File

@@ -0,0 +1,111 @@
; -*- MIDAS -*-
comment |
The following file implements functions which are to LEXPR-FUNCALL as
SUBRCALL and LSUBRCALL are to FUNCALL. Provided are:
LEXPR-SUBRCALL subr arg0 arg1 ... argn rest-arg
where n may be equal to zero. The rest-arg is a list of arguments to the
subr after the argi arguments. The user is responsible for calling the
subr with the correct number of arguments, since no checking can be done.
It is illegal to call a SUBR with more than 5 arguments. To avoid blowing
away the LISP, LEXPR-SUBRCALL always checks this constraint.
LEXPR-LSUBRCALL lsubr arg0 arg1 ... argn rest-arg
Where n may be equal to zero. The rest-arg is a list of arguments to the
lsubr after the argi arguments. The user is responsible for calling the
lsubr with the correct number of arguments, since no checking can be done.
This is particularly important with lsubr's, since calling with the incorrect
number of arguments can result in getting the stack out of phase. Typically
this will result in your being thrown to DDT with an ILOPR or MPV.
In addition, the following functions are defined:
LEXPR-SUBRCALL-FIXNUM
LEXPR-SUBRCALL-FLONUM
LEXPR-LSUBRCALL-FIXNUM
LEXPR-LSUBRCALL-FLONUM
These are just like their generic counterparts, but only take SUBR's or
LSUBRs which have been declared to return FIXNUM or FLONUM. Calling
SUBR's or LSUBR's which have not been so declared will result in
unpredictable behaviour, as the first instruction of the called subr or
lsubr will be skipped. For these to provide any advantage, they must
be declared to the compiler before compiling the calls to them. This
can be done by loading this file into the compiler before compiling
files using these functions.
Loading this file into the compiler is also a way to ensure that
these functions are known by the compiler to be LSUBR's.
|
.fasl
.insrt sys:.fasl defs
VERPRT LSCALL
.SXEVAL (AND (FBOUNDP (QUOTE FIXNUM))
(FIXNUM (LEXPR-SUBRCALL-FIXNUM) (LEXPR-LSUBRCALL-FIXNUM)))
.SXEVAL (AND (FBOUNDP (QUOTE FLONUM))
(FLONUM (LEXPR-SUBRCALL-FLONUM) (LEXPR-LSUBRCALL-FLONUM)))
lxse: WNA [WRONG NUMBER OF ARGS TO LEXPR-LSUBRCALL]
.entry LEXPR-SUBRCALL-FLONUM LSUBR 003010 ;LSUBR, 2-7 arguments
skipa d,cfix1-1
.entry LEXPR-SUBRCALL-FIXNUM LSUBR 003010 ;LSUBR, 2-7 arguments
movei d,fix1
move tt,p ;Calculate where the bottom of this frame is
add tt,t ;TT <- return address
aos 1(tt) ;Skip over the PUSH P,CFIX1
jrst lxs0
.entry LEXPR-SUBRCALL LSUBR 003010 ;LSUBR, 2-7 arguments
move tt,p ;Calculate where the bottom of this frame is
add tt,t ;TT <- return address
movei d,[popj p,]
lxs0: aos t ;count last arg
aojg t,lxse ;Count function arg, must have at least 2 args
pop p,a ;Get list of extra arguments
lxs1: jumpe a,lxs2
hlrz b,(a) ;Get the CAR of the list
push p,b ;and push it.
hrrz a,(a) ;next item
soja t,lxs1 ;repeat, counting
lxs2: movns t ;Get the number of arguments
caile t,5 ;Must have 5 or fewer args
jrst lxse ; We always check, to avoid blowing away the LISP!
hrlzi tt,2(tt) ;Address of first arg,,0
aos tt ;Address of first arg,,1
blt tt,(t) ;Move the args into the AC's
sub p,(t)[0,,0 ? 1,,1 ? 2,,2 ? 3,,3 ? 4,,4 ? 5,,5]
exch d,(p) ;Subr pointer <-> fix1/float1/popj1
jrst (d) ;Call it
.entry LEXPR-LSUBRCALL-FLONUM LSUBR 003777 ;LSUBR, 2-infinity arguments
skipa d,cfix1-1
.entry LEXPR-LSUBRCALL-FIXNUM LSUBR 003777 ;LSUBR, 2-infinity arguments
movei d,fix1
move tt,p ;Calculate where the bottom of this frame is
add tt,t ;TT <- return address
aos 1(tt) ;Skip over the PUSH P,CFIX1
jrst lxls0
.entry LEXPR-LSUBRCALL LSUBR 003777 ;LSUBR, 2-infinity arguments
move tt,p ;Calculate where the bottom of this frame is
add tt,t ;TT <- return address
movei d,[popj p,]
lxls0: aos t ;count last arg
aojg t,lxse ;Count function arg, must have at least 2 args
pop p,a ;Get list of extra arguments
lxls1: jumpe a,lxls2
hlrz b,(a) ;Get the CAR of the list
push p,b ;and push it.
hrrz a,(a) ;next item
soja t,lxls1 ;repeat, counting
lxls2: exch d,1(tt) ;Rescue the lsubr-ptr before we bash it
jrst (d) ;Call it
fasend

139
src/libdoc/lspmac.jlk34 Executable file
View File

@@ -0,0 +1,139 @@
;;; Lisp macros (variously hacked by RLB and JLK)
(eval-when (eval compile) (setq defmacro-check-args ()))
(defun /#macro ()
(let ((c (ascii (tyipeek))) b a)
(setq a (caseq c
(// (tyi) (readch)) ;#/char returns SCO for char
(/, (tyi) (eval (read))) ;#,(form) returns eval of form
;can't - QUOTE (/( (read)) ;simulate NIL #(..) vectors
((/t T) (tyi) 'T) ;truthity
(Q (tyi) ;#Qnum reads in octal
(let ((ibase 8.)) (read)))
(X (tyi) ;#Xnum reads in hex
(let ((ibase 16.)) (read)))
(^ (tyi) (boole 1 37 (tyi))) ;#^A returns 1
(= (tyi)
(cond ((= (tyipeek) 47.) ; #=/x returns code for x
(tyi) (tyi))
((ascii (read))))) ;#=num returns SCO num
(T (setq b 'T))))
(cond (b (let ((args c)) (break |Random after /#| 'T)))
(a))))
;;; (/@ <abbrev> <expansion> . body) just substitutes <abbrev> for <expansion>
;;; in (PROGN . <body>) -- useful for e.g.:
;;; (/@ x (arraycall fixnum barfa (1+ i)) (store x (1+ x)))
(defun (/@ macro) (form)
(let (((abbrev expan . body) (cdr form)))
`(progn .,(subst expan abbrev body))))
;;; (*PUSH symbol cruft) does (PUSH cruft symbol)
;; ;but looks nicer when there is a lot of cruft.
(defun (*push macro) (x) `(push ,(caddr x) ,(cadr x)))
;;; Add an element to a list non-redundantly
(defun (addl macro) (form)
(let (((() item list) form))
`(if (not (memq ,item ,list)) (setq ,list (cons ,item ,list)))))
;;; The >=, <=, and NOT= macros extend Lisp's subrs.
(defun (/>= macro) (x) (|<=> ify| (cdr x) '/<))
(defun (/<= macro) (x) (|<=> ify| (cdr x) '/>))
(defun |<=> ify| (body pred)
(caseq (length body)
(0 '(progn 'T))
(1 `(progn ,(car body) 'T))
(2 `(not (,pred .,body)))
(T (do ((body body (cdr body)) (l))
((null (cdr body)) `(and .,(nreverse l)))
(push `(not (,pred ,(car body) ,(cadr body))) l)))))
(defun (not= macro) (x) `(not (= ,(cadr x) ,(caddr x))))
;;; Variants of COND
;;; (WHEN <cond> . <body>) evaluates <body> when <cond> is non-nil.
(defun (when macro) (x)
`(cond (,(cadr x) . ,(cddr x))))
;;; (UNLESS <cond> . <body>) evaluates <body> unless <cond> is non-nil.
(defun (unless macro) (x)
`(cond ((not ,(cadr x)) . ,(cddr x))))
;;; (IF <cond> <consequence>
;;; <else1> <else2>...) This is the standard grinding.
(defun (if macro) (x)
(cond ((null (cdddr x)) `(cond (,(cadr x) ,(caddr x))))
(t `(cond (,(cadr x) ,(caddr x)) (t . ,(cdddr x))))))
;Self QUoting Internal Datum - if interpreted, like eval first time only,
;thereafter, quoted. If compiled and then fasloaded, it gets evaled
;at fasload time.
(declare (special squid))
(defun (squid macro) (x)
(cond (compiler-state (rplaca x squid)) ;Can't figure out EVAL-WHEN
((rplaca x 'quote)
(rplaca (cdr x) (eval (cadr x)))
x)))
;;; Macros for copying list structure (from MRG originally)
(defun (copy macro) (x) `(subst nil nil ,(cadr x)))
(defun (copyp macro) (x) `(cons (car ,(cadr x)) (cdr ,(cadr x))))
(defun (copyl macro) (x) `(append ,(cadr x) nil))
;;; Macro for initializing special variables if unbound at load time
(defun (special-init macro) (x)
`(if (not (boundp ',(cadr x))) (setq ,(cadr x) ,(caddr x))))
;;; print beginning at left margin
(defun (princ0 macro) (x)
`(progn (if (not (= 0 (cdr (cursorpos .,(cddr x)))))
(terpri .,(cddr x)))
(princ .,(cdr x))))
;;; Append n strings together
(defun (string-append macro) (x)
`(maknam (mapcan 'explodec (list .,(cdr x)))))
;;; VALRET several strings quitely
(defun (valret* macro) (x)
`(let ((tty-return)) (valret (string-append .,(cdr x)))))
;;; Flush LSPMAC from the enviroment
(defun cleanup-lspmac fexpr (x)
(when (null x) (setq x '(chmac macro)))
(when (memq 'chmac x)
(do l '(/# /& /!) (cdr l) (null l)
(setsyntax (car l) 'macro nil)))
(when (memq 'macro x)
(do l '(/@ lambind progb seqlam catch* throw* /<= />= not=
when unless squid if file-length *push copy copyl copyp
special-init princ0 string-append valret*)
(cdr l) (null l)
(remprop (car l) 'macro)))
(remprop 'cleanup-lspmac 'expr)
(sstatus nofeature lspmac))
(sstatus feature lspmac)
;; Local Modes:
;; Mode: LISP
;; Comment Col: 40
;; END:

156
src/libdoc/more.kmp15 Executable file
View File

@@ -0,0 +1,156 @@
;;; -*- LISP -*- Created by KMP, 11/30/80
;;; MORE: A library with a winning more break handler
;;;
;;; Description:
;;;
;;; The function +EXTERNAL-TTY-ENDPAGEFN is defined in this file.
;;; Setting the variable *MORE to a value other than T will turn
;;; on fancy features. A function *MORE is provided to ensure that
;;; a proper type value is set in the variable *MORE.
;;;
;;; Three states are possible:
;;;
;;; [1] (*MORE = NIL) Ignore More-Interrupts.
;;; The endpage function will do nothing.
;;;
;;; [2] (*MORE = T) Simulate normal more-break.
;;; Print "##More##" and if char typed is a Space or Rubout, eat the
;;; char, else leave it around on the input stream for someone else.
;;;
;;; [3] (*MORE = <n>) Pause <n> seconds. (<n> Must be greater than 0
;;; Print "--m Minute s Second Pause--" and wait. If after that time,
;;; nothing has been typed, the pause ends and computation resumes
;;; replacing the "-- ... Pause--" message with a "--Pause Timed Out--"
;;; message. If a char is typed, it is eaten and computation continues
;;; unless an Altmode is typed, in which case the timer is turned
;;; off for that more break, "--Waiting--" will display, and the
;;; break will continue until a char is typed (which will be eaten).
;;;
;;; Note that the following evil (?) side-effects happen to your lisp...
;;;
;;; * The Alarm clock feature is used. Since LISP can only have one
;;; alarmclock going at any time, using an alarm clock for anything
;;; else will lose badly.
;;;
;;; * ^B is redefined to turn off the alarmclock when it runs.
;;; If you don't redefine ^B yourself, you won't be bothered by
;;; it.
;;;
(DECLARE (MUZZLED T))
(DECLARE (SPECIAL *MORE)) ;Compiler declaration
(COND ((NOT (BOUNDP '*MORE))
(SETQ *MORE T)))
(DEFUN *MORE (X)
(COND ((AND (FLOATP X) (> X 0.0))
(SETQ *MORE X))
((AND (FIXP X) (> X 0.))
(SETQ *MORE X))
((OR (EQUAL X 0.) (NULL X))
(SETQ *MORE NIL))
((EQ X 'T)
(SETQ *MORE T))
(T
(ERROR '|- Arg to *MORE must be NIL, T, or a positive flonum.| X))))
(SETQ +EXTERNAL-TTY-ENDPAGEFN\OVERSTRIKE?
(NOT (ZEROP (BOOLE 1. (CAR (SYSCALL 1. 'TTYVAR TYO (CAR (PNGET 'TTYOPT 6))))
#o1000000000))))
(DECLARE (SPECIAL +EXTERNAL-TTY-ENDPAGEFN\POS
+EXTERNAL-TTY-ENDPAGEFN\SECONDS
+EXTERNAL-TTY-ENDPAGEFN\OVERSTRIKE?))
(DEFUN +EXTERNAL-TTY-ENDPAGEFN\ALARM (())
(LET ((TIME (FIX (-$ +EXTERNAL-TTY-ENDPAGEFN\SECONDS (TIME)))))
(COND ((< TIME 1.)
(COND ((ZEROP (LISTEN)) (*THROW 'ENDPAGE-EXIT T))
(T NIL)))
(T
(LET ((BASE 10.)
(*NOPOINT T)
(DAYS)
(HOURS)
(MINS)
(SECS))
(SETQ DAYS (// TIME 86400.))
(SETQ TIME (- TIME (* 86400. DAYS)))
(SETQ HOURS (// TIME 3600.))
(SETQ TIME (- TIME (* 3600. HOURS)))
(SETQ MINS (// TIME 60.))
(SETQ SECS (- TIME (* 60. MINS)))
(CURSORPOS (CAR +EXTERNAL-TTY-ENDPAGEFN\POS)
(CDR +EXTERNAL-TTY-ENDPAGEFN\POS)
TYO)
(IF +EXTERNAL-TTY-ENDPAGEFN\OVERSTRIKE?
(CURSORPOS 'L TYO))
(PRINC '|--| TYO)
(COND ((> DAYS 0.)
(PRINC DAYS TYO)
(PRINC '| Day | TYO)))
(COND ((> HOURS 0.)
(PRINC HOURS TYO)
(PRINC '| Hour | TYO)))
(COND ((> MINS 0.)
(PRINC MINS TYO)
(PRINC '| Minute | TYO)))
(COND ((> SECS 0.)
(PRINC SECS TYO)
(PRINC '| Second | TYO)))
(PRINC '|Pause--| TYO)
(CURSORPOS 'L TYO))
(ALARMCLOCK 'TIME 1.)))))
(DEFUN +EXTERNAL-TTY-ENDPAGEFN (TYO)
(PROG (ALARMCLOCK POS C
+EXTERNAL-TTY-ENDPAGEFN\POS
+EXTERNAL-TTY-ENDPAGEFN\SECONDS)
(NOINTERRUPT NIL)
(COND ((NULL *MORE) ; Ignore interrupt
(RETURN T))
((NOT (NUMBERP *MORE)) ; Run Standard More Break Handler
(RETURN (+INTERNAL-TTY-ENDPAGEFN TYO))))
(SETQ +EXTERNAL-TTY-ENDPAGEFN\POS (SETQ POS (CURSORPOS TYO)))
(SETQ +EXTERNAL-TTY-ENDPAGEFN\SECONDS (+$ (FLOAT *MORE) (TIME)))
(SETQ ALARMCLOCK '+EXTERNAL-TTY-ENDPAGEFN\ALARM)
(+EXTERNAL-TTY-ENDPAGEFN\ALARM NIL)
(*CATCH 'ENDPAGE-EXIT
(UNWIND-PROTECT
(PROGN (ALARMCLOCK 'TIME 1.)
(SETQ C (TYI TYI))
(COND ((= C 27.)
(ALARMCLOCK 'TIME NIL)
(CURSORPOS (CAR POS) (CDR POS) TYO)
(IF +EXTERNAL-TTY-ENDPAGEFN\OVERSTRIKE?
(CURSORPOS 'L TYO))
(PRINC '|--Waiting--| TYO)
(CURSORPOS 'L TYO)
(SETQ C (TYI TYI))))
(ALARMCLOCK 'TIME NIL)
(CURSORPOS (CAR POS) (CDR POS) TYO)
(IF +EXTERNAL-TTY-ENDPAGEFN\OVERSTRIKE?
(CURSORPOS 'L TYO))
(PRINC '|--Continuing--| TYO)
(CURSORPOS 'L TYO)
(TERPRI TYO)
(RETURN T))
(ALARMCLOCK 'TIME NIL)))
(CURSORPOS (CAR POS) (CDR POS) TYO)
(IF +EXTERNAL-TTY-ENDPAGEFN\OVERSTRIKE?
(CURSORPOS 'L TYO))
(PRINC '|--Pause Timed Out--| TYO)
(CURSORPOS 'L TYO)
(TERPRI TYO)))
(DEFUN +EXTERNAL-^B-BREAK (() ())
(ALARMCLOCK 'TIME NIL)
(NOINTERRUPT NIL)
(BREAK |^B|))
(SSTATUS TTYINT 2. '+EXTERNAL-^B-BREAK)
(ENDPAGEFN TYO '+EXTERNAL-TTY-ENDPAGEFN)

49
src/libdoc/ndone.rvb1 Executable file
View File

@@ -0,0 +1,49 @@
;;; FRIDAY FEB 06,1976 17:21:42
;;; THIS FILE IS DESIGNED TO BE FASLOADED INTO THE COMPLR IN
;;;A COMPLR (INIT) ETC. WHEN THE COMPLR IS DONE WITH THE
;;;COMPILATION A MESSAGE WILL BE SENT TO THE USER.
;;; I PRIMARILY USE THIS IN CONJUNCTION WITH "JCL" COMPILER
;;;INVOCATION TO FIND OUT WHEN THE FASL IS READY.
;;; THE MESSAGE SENT IS THE VALUE OF COMPLR-DONE-MESSAGE.
;;; THE EOC-EVAL MECHANISM OF THE COMPLR IS ALSO USED.
(SETQ COMPLR-ERROR-MESSAGE 'COME/ HERE/ WATSON/ I/ NEED/ YOU)
(SETQ COMPLR-DONE-MESSAGE 'COMPILATION/ FINISHED)
(SETQ EOC-EVAL (APPEND EOC-EVAL '((COMPLR-DONE))))
(LAP OLDIO-SEND SUBR)
(ARGS OLDIO-SEND (NIL . 1))
(SKIPA)
(ENTRY COMPLR-ERROR SUBR)
(ARGS COMPLR-ERROR (NIL . 0))
(MOVE A,(SPECIAL COMPLR-ERROR-MESSAGE))
(SKIPA)
(ENTRY COMPLR-DONE SUBR)
(ARGS COMPLR-DONE (NIL . 0))
(MOVE A,(SPECIAL COMPLR-DONE-MESSAGE))
(*IOPUSH 15,) ;GUARANTEE A FREE CHANNEL
(*SUSET 0,MYUNAME)
(*OPEN 15,HCTRN-BLOCK)
(JRST 0,DIE)
(MOVE R,(% SETZ 0,CHROUT));A & R SETUP FOR
(PUSHJ P,PRINTA) ; PRINTA THAT FOLLOWS
(*CLOSE 15,)
DIE (*IOPOP 15,)
(MOVEI A,'T)
(POPJ P,)
;;; OUTPUT CHARACTER IN A
CHROUT (*IOT 15,A)
(POPJ P,) ;PRINTA CALLING CONVENTIONS
MYUNAME (0 0 USLOT 4) ;I.E. ?,,USLOT
HCTRN-BLOCK
(SIXBIT / / /!CLI)
USLOT (0)
(SIXBIT HACTRN)
NIL

352
src/libdoc/nshare.jonl8 Executable file
View File

@@ -0,0 +1,352 @@
;;; NSHARE -*-LISP-*-
;;; **************************************************************
;;; ***** MacLISP ****** Share as Many Pure Pages as Possible ****
;;; **************************************************************
;;; ** (C) Copyright 1980 Massachusetts Institute of Technology **
;;; ****** This is a read-only file! (All writes reserved) *******
;;; **************************************************************
(eval-when (eval compile)
(or (status macro /#)
(setsyntax '/# 'SPLICING '+INTERNAL-/#-MACRO))
(and (status feature LODBYT) (load '((LISP) LODBYT)))
)
;;; Functions for creating heirachical MACLISP dumps on ITS.
;;; This will work with (STATUS FLUSH) either T or NIL.
;;; Originally provided by GSB, Thursday June 29,1978 14:13:38
;;; Extended Feb 22, 1980 by JONL to do incremental page flushing
;;; and re-association.
;;; Comments, complaints, suggestions, etc. to GSB@ML and JONL@MC
;;; For Optimal sharing, this file should be loaded into a nearly fresh
;;; lisp, with PURE bound to T; in this case, *PURE ###must### be
;;; bound to () during the loading of this file.
;;; Then a pure dump is made by loading up other functions and data
;;; with *PURE set to T, and PURE set either to a small fixnum or to T.
;;; When finished loading, you probably want to set *PURE to (), and then
;;; call PURE-SUSPEND (rather than SUSPEND) with 2 arguments - the second
;;; arg is the name of the file to PDUMP into, and the first is passed to
;;; SUSPEND. If the first arg is (), then SUSPEND merely does the PDUMP
;;; and returns; if it is 0, SUSPEND will valret to DDT after PDUMPing.
;;; All components of the filename for the second arg must be explicitly
;;; specified, since this package needs to remember exactly which
;;; file it was dumped to. For this reason, it is preferable to
;;; dump new versions with numeric second filenames, and have links
;;; from the TS file to either a specific version or the '>' version.
;;; (EG, LMS is dumped to DSK:LMS;.LMS > . Note however that you
;;; can't give '>' as a component to PURE-SUSPEND; you must figure
;;; out what version will be generated and specify it. In most cases
;;; this is done anyway, to figure out what your version number is.)
;;; The primary operation here is the function COMMUNIZE, which
;;; opens up all the files which the dump has been generated from,
;;; and maps in pages from them so as to optimize sharing between
;;; jobs which come from those files.
;;; *SUSPEND takes from 0 to 2 arguments, calls SUSPEND with them,
;;; and then calls COMMUNIZE.
;;; PURE-SUSPEND does a general purification, suspend, and communize.
;;; Hackers note -
;;; This only maps in pure pages from a file, and only pages which are
;;; not absolute. (It does not recognize public pages though.)
;;; It will not clobber an impure page in the job with a pure page from
;;; a file. If, however, an earlier dump has had a patch put into a
;;; pure area and the page has been repurified, then that change will
;;; propagate to all dumps made from that one.
(declare (special *sharing-file-list *already-shared-pure-pages))
(and (not (boundp '*sharing-file-list))
(setq *sharing-file-list () ))
(and (or (not (boundp '*already-shared-pure-pages))
(null *already-shared-pure-pages))
(setq *already-shared-pure-pages (array () FIXNUM 32.)))
;;; Information about the purity of pages is stored in a fixnum array,
;;; packed 8 4-bit bytes per word. Meaning of the 4 bits is:
;;; 0 (1) - do not delete this page
;;; 1 (2) - lisp system page
;;; 2 (4) - other pure page
;;; 3 (8) - temporary setting for purity, just before suspension
;;; This array, "*already-shared-pure-pages", is set up at the end
;;; of this file.
(defmacro (LDB-A-BYTE defmacro-for-compiling () defmacro-displace-call () )
(&optional (index 'I)
(byte-size 4)
(bytes-per-word 8)
(ar '*ALREADY-SHARED-PURE-PAGES))
`(LOAD-BYTE (ARRAYCALL FIXNUM ,ar (// ,index ,bytes-per-word))
(* ,byte-size (\ ,index ,bytes-per-word))
,byte-size))
(defmacro (DPB-A-BYTE defmacro-for-compiling () defmacro-displace-call () )
(&optional byte
(index 'I)
(byte-size 4)
(bytes-per-word 8)
(ar '*ALREADY-SHARED-PURE-PAGES))
`(STORE (ARRAYCALL FIXNUM ,ar (// ,index ,bytes-per-word))
(DEPOSIT-BYTE (ARRAYCALL FIXNUM ,ar (// ,index ,bytes-per-word))
(* ,byte-size (\ ,index ,bytes-per-word))
,byte-size
,byte)))
(comment PURE-SUSPEND)
(putprop '*SUSPEND (lsh bporg -10.) 'BPORG)
(defun PURE-SUSPEND (argument-to-suspend file-namelist)
(prog (flushp *pure zero file-to-dump-to)
;You wouldn't believe the bug which this line prevents!
(setq zero 0)
RECOVER-FROM-WRONG-TYPE-ARG
(setq file-namelist (namelist file-namelist))
(setq flushp (and (status FLUSH)
(not (alphalessp (status LISPV) '/1941))
(get '*UNPURIFY-SYMBOL 'FLUSH)))
(cond ((or (memq (cadr file-namelist) '(* /> /<))
(memq (caddr file-namelist) '(* /> /<))
(eq (caar file-namelist) '*)
(eq (cadar file-namelist) '*))
(setq file-namelist
(error '|Unspecified filename component - PURE-SUSPEND et al|
file-namelist
'WRNG-TYPE-ARG))
(go RECOVER-FROM-WRONG-TYPE-ARG)))
;Unpurify all the symbols of the file's namelist, so we can fetch it
; after suspending but before the pure data pages are loaded in.
(*unpurify-symbol (caar file-namelist))
(*unpurify-symbol (cadar file-namelist))
(*unpurify-symbol (cadr file-namelist))
(*unpurify-symbol (caddr file-namelist))
(setq file-to-dump-to (namestring file-namelist))
(gctwa)
(cond ((null argument-to-suspend)
;; Special dispensation for lazy programmers.
(setq argument-to-suspend
(cond ((eq (status hactrn) 'DDT)
;; This is the normal default that
;; the function SUSPEND provides.
'|:PDUMPED/î|)
('t ;; This causes suspend to execute a
;; .BREAK 16,300000 which causes the
;; job to simply return to its superior.
(+ 3_15. zero))))))
;; Round up binary program space to a page boundary.
;; (This should not be necessary but lisp may or
;; may not be smart enough to do so itself.)
(pagebporg)
;; Now, do the purification. This purifies all binary
;; program space, and also list structure etc. which
;; was 'purcopied'.
(purify 0 0 'bporg)
(gc)
;; Save away the name of the file we are dumping to.
(push file-to-dump-to *sharing-file-list)
;; Remember any new shared pages, and disconnect them if flushing
(do ((i 0 (1+ i)) (tpno 0))
((= i 256.) )
(declare (fixnum i tpno))
(cond ;If not pure page, then don't bother
((not (> (car (syscall 1 'CORTYP i)) 0)))
; 1_0-bit in "shared-pages" table says don't delete.
; 1_1-bit in "shared-pages" table says "LISP" system pure page.
((not (= 0 (boole 1 (setq tpno (ldb-a-byte)) #.(+ 1_1 1)))))
((not (= 0 (boole 1 tpno #.(+ 1_2))))
;Flush page from this job, if random shared page
(and flushp (syscall 0 'CORBLK 0 -1 i)))
('t ;Mark as "intermediately", or "newly", shared page
(and (= 0 (boole 1 1_3 tpno)) (dpb-a-byte (+ 1_3 tpno))) )))
;; And finally, suspend.
(suspend argument-to-suspend file-to-dump-to)
(do ((i 0 (1+ i)) (tpno 0))
((= i 256.) )
(declare (fixnum i tpno))
(setq tpno (ldb-a-byte))
(cond ((not (= 0 (boole 1 1_3 tpno)))
;Turn off bit 3, and turn on bit 2
(setq tpno (boole 7 1_2 (boole 2 1_3 tpno)))
(dpb-a-byte tpno))))
;; Now, since we are suspended, map in the pages from
;; other files.
(communize)
(return t)))
(defun COMMUNIZE ()
(let ((array-pointer (*array nil 'fixnum 256.)))
(mapc '(lambda (x) (communize-single-file x array-pointer))
*sharing-file-list)
(*rearray array-pointer)
t))
(defun COMMUNIZE-SINGLE-FILE (filename array-pointer)
(cond ((not (probef filename))
(terpri)
(princ '|; The file |)
(prin1 (namestring filename))
(princ '| is not there;|)
(terpri)
(princ '|; sharing will not be optimal.|))
((let ((file-object (open filename '(IN FIXNUM SINGLE))))
;; Note the use of unit mode.
;; This keeps the file array smaller (no buffer)
;; So, do the map-in-pure-pages-from-file thing
(cond ((not (= (in file-object) 0))
(terpri)
(princ '|File |)
(prin1 (namestring (truename file-object)))
(princ '| is not in PDUMP format.|))
('t ;Get page map from first block of file - 256. words
(fillarray array-pointer file-object)
(do ((page-number 0 (1+ page-number))
(file-page-number 1)
(entry 0)
syscall-corblk-result )
((= page-number 256.))
(declare (fixnum page-number entry))
(setq entry (arraycall fixnum array-pointer page-number))
(and
;; Negative means absolute page; zero non-existent.
(plusp entry)
;; Read-only page iff bit 2.8 is 1 and 2.9 is 0.
(= (boole 1 3. (lsh entry -16.)) 1.)
;; And it's not one of the pages with this code on it!
(= 0 (boole 1 1 (ldb-a-byte page-number)))
;; And it's either not in us, or is unpatched-pure in us
(not (minusp (car (syscall 1 'CORTYP page-number))))
;; then map it in!
(setq syscall-corblk-result
(syscall 0 'CORBLK
1_12.
-1
page-number
file-object
file-page-number))
;; Non-null indicates an error.
(error '|(SYSCALL 'CORBLK) lost|
(list file-object
(list page-number (list file-page-number entry))
syscall-corblk-result)
'wrng-type-arg))
;; Determine whether there was a page in the file
;; corresponding to PAGE-NUMBER.
(and (plusp entry)
(plusp (boole 1 3. (lsh entry -16.)))
(setq file-page-number (1+ file-page-number))))))
(close file-object)))))
;;; Wait! Dont move this one - see comments above
(defun *SUSPEND number-of-arguments
;; Suspend, then communize.
;; Note that here the exact specification of the filename
;; is not critical here, this function does no purification.
(cond ((= number-of-arguments 0) (suspend))
((= number-of-arguments 1) (suspend (arg 1)))
('t (suspend (arg 1) (arg 2))))
(communize))
(putprop '*SUSPEND (lsh bporg -10.) 'BPEND)
(defun *UNPURIFY-SYMBOL (x)
(cond ((get x '*UNPURIFY-SYMBOL))
((let ((car 't) (cdr 't) tmp)
(setq tmp (args x))
(args x '(105 . 105))
(args x tmp)
(setq tmp (munkam (1+ (maknum (car x)))))
(rplacd tmp (mapcar '*copy-fixnum (cdr tmp)))
(putprop x 'T '*UNPURIFY-SYMBOL)))))
(lap-a-list '((lap *COPY-FIXNUM subr)
(args *COPY-FIXNUM (() . 1))
(jsp t fxnv1)
(jsp t fwcons)
(popj p)
(entry *WHO-BORE-ME? subr)
(args *WHO-BORE-ME? (() . 0))
(movei tt 1 flp)
(hrli tt 2)
(jsp t (/0*0PUSH -4))
(*break 10. tt)
(pushj p take2)
(push p 1)
(pushj p take2)
(pop p 2)
(jcall 2 'CONS)
take2
(pop flp tt)
(pushj p sixatm)
(call 1 'NCONS)
(push p 1)
(pop flp tt)
(pushj p sixatm)
(pop p 2)
(jcall 2 'CONS)
() ))
(defun *set-up-shared-pages-table ()
(let ((pt (*array nil 'fixnum 256.))
(file-object (open (*who-bore-me?) '(IN FIXNUM SINGLE)))
(b-low 0) (b-hi 0)
(finishedp) (file-namelist) (tmp) )
(declare (fixnum i b-low b-hi))
(setq b-low (1- (cond ((setq tmp (get '*SUSPEND 'BPORG)) tmp) (1000.))))
(setq b-hi (1+ (cond ((setq tmp (get '*SUSPEND 'BPEND)) tmp) (-1000.))))
(setq file-namelist (truename file-object))
(cond ((or (not (= (in file-object) 0))
(not (eq (caddr file-namelist) (status LISPV))))
(terpri)
(princ '|File |)
(prin1 (namestring (truename file-object)))
(princ '| is not the pdump'd LISP file|)
(error '|LISP| file-object)))
(fillarray pt file-object)
(unwind-protect
(do ((i 0 (1+ i)))
((= i 256.) (setq finishedp 'T))
(cond ;"self" pages which must not be cut out
((lessp b-low i b-hi) (dpb-a-byte 1))
;LISP system pages, which also must not be cut out
((= (boole 1 3. (lsh (arraycall fixnum pt i) -16.)) 1.)
(dpb-a-byte 1_1))))
(or finishedp (setq *already-shared-pure-pages () )))
(cond (*already-shared-pure-pages
(*unpurify-symbol (caar file-namelist))
(*unpurify-symbol (cadar file-namelist))
(*unpurify-symbol (cadr file-namelist))
(*unpurify-symbol (caddr file-namelist))
(push file-namelist *sharing-file-list)))))
;;; Can only play the FLUSH game if this file is loaded with PURE = T
;;; Otherwise, you may try to "CALL 1 'CONS" during COMMUNIZE-SINGLE-FILE
;;; and find that the plist of CONS was on a pure page which is not yet back!
(cond ((eq pure 'T)
(*set-up-shared-pages-table)
(mapc '*unpurify-symbol '(CORBLK CORTYP |:PDUMPED/î| SYS DSK LISP))
(defprop *UNPURIFY-SYMBOL T FLUSH)))

52
src/libdoc/octal.kmp3 Executable file
View File

@@ -0,0 +1,52 @@
;;; -*- Mode:Lisp; IBase:10.; -*- Package created by KMP, 11/2/80
;;;
;;; OCTAL: A package for doing shorthand octal input (PDP10 only)
;;;
;;; Sets up "&" as a readmacro to read shorthand octal numbers. (Note that a
;;; side-effect of this is that &-keywords must be written as /&optional,
;;; etc.)
;;;
;;; Style Suggestion:
;;; This package is not intended for production use (use in programs), since
;;; it ties down a valuable character, but it can be useful as an interactive
;;; debugging tool. It is strongly recommended that programs for release use
;;; the #o octal syntax already which is primitive to Maclisp.
;;;
;;; If a comma (or two) is read in the middle of the number, it divides the
;;; right and left half of the word being assembled.
;;;
;;; Examples:
;;;
;;; &77 = 000000,,000077
;;; &-1,, = 777777,,000000
;;; &-1,,1 = 777777,,000001
;;; &0,,-1 = 000000,,777777
;;; &,-1 = 000000,,777777
;;; &37, = 000037,,000000
;;;
;;; See also the BINPRT package for display of octal numbers.
#-PDP10 (ERROR "This package not written to work except on a PDP10.")
(DECLARE (FIXNUM (READ-OCTAL-AUX) (READ-OCTAL)))
(HERALD OCTAL /3)
(DEFUN READ-OCTAL-AUX ()
(DO ((I 0. (+ (LSH I 3) (- (TYI) #/0)))
(S (IF (OR (= (TYIPEEK) #/+) (= (TYIPEEK) #/-))
(= (TYI) #/-))))
((OR (< (TYIPEEK) #/0) (> (TYIPEEK) #/7))
(IF (NOT S) I (- I)))
(DECLARE (FIXNUM I))))
(DEFUN READ-OCTAL ()
(LET ((TEMP (READ-OCTAL-AUX)))
(DECLARE (FIXNUM TEMP))
(COND ((= (TYIPEEK) #/,)
(TYI)
(IF (= (TYIPEEK) #/,) (TYI))
(LOGIOR (LSH TEMP 18.) (LOGAND (READ-OCTAL-AUX) #o777777)))
(T TEMP))))
(SSTATUS MACRO /& 'READ-OCTAL)

120
src/libdoc/optdef.gjc3 Executable file
View File

@@ -0,0 +1,120 @@
;;;-*-lisp-*-
;;; Using the /#-SYMBOLIC-CHARACTERS-TABLE as a way of specifying options.
;;; The main use of this is to be able to specify options to functions
;;; symbolically without fear of wasting symbol space in the maclisp
;;; environment, and without the hair of macro expansions.
;;; 7:16pm Sunday, 22 February 1981 -GJC
;;; N.B. Since the symbolic translation is done at read time, and since
;;; the implementation allows options from different sets to map into
;;; the same fixnum (in order that the fixnums may be most likey INUMS,
;;; which do not take up any extra space) validity of options is only
;;; checked in the obvious-call case of
;;; (FOOBAR #\<OPTION-SYMBOL> <VALUE> #\<OPTION-SYMBOL> <VALUE> ...)
;;; and this if and only if nobody has foolishly macroexpanded the
;;; arguments to FOOBAR before the syntax-checking SOURCE-TRANS property
;;; is invoked by the compiler. Oh yeah, you only get this error checking
;;; in the compiler, so much for people who debug code using the interpreter.
(OR (GET 'SHARPM 'VERSION) (LOAD '((LISP)SHARPM)))
(HERALD OPTDEF)
(DEFVAR OPTION-SETS NIL "List of symbols which have option properties")
(DECLARE (SPECIAL /#-SYMBOLIC-CHARACTERS-TABLE
;; we assume that the implementation of #\FOO is that
;; FOO is looked up in an ALIST which is the value
;; of this variable. This is true in Maclisp, and
;; will be in NIL. Off hand I don't know what to do
;; about this on the lisp machine.
))
(DEFUN ENTER-/#-SYMBOL (SYMBOL N)
(LET ((CELL (ASSQ SYMBOL /#-SYMBOLIC-CHARACTERS-TABLE)))
(IF CELL (SETF (CDR CELL) N)
(PUSH (CONS SYMBOL N)
/#-SYMBOLIC-CHARACTERS-TABLE))))
(DEFUN (|op| MACRO) (FORM)
;; this macro does NOT want to displace, has no need of memoization for speed.
(OR (GET (CADDR FORM)
(CADR FORM))
(ERROR (LIST "has no" (CADDR FORM) "option") (CADR FORM))))
;; N.B. I am aware that the macro definition does not take effect inside
;; a QUOTE. However, a useratoms hook would, in the compiler, therefore
;; we must conclude that something is wrong with the implementation of
;; quote in the interpreter.
(progn 'compile
;; interface to the hackish maclisp grinder.
(defun (|op| grindmacro) ()
(declare (special l m))
(princ "#\") (princ (caddr l)))
(defprop |op|
+internal-dwim-predictfun
grindpredict)
(defun (|op| grindflatsize) (l)
(+ 2 (flatsize (caddr l))))
)
(DEFUN OPTIONS-CHECK (FORM)
;; this catches most errors.
(DO ((SET (CAR FORM))
(ARGL (NTHCDR (1+ (OR (GET (CAR FORM) 'NUMBER-OF-LEADING-ARGUMENTS)
0))
FORM)
(CDDR ARGL)))
((NULL ARGL)
(VALUES FORM NIL))
(LET ((OPTION (CAR ARGL)))
(COND ((ATOM OPTION))
((EQ '|op| (CAR OPTION))
(OR (EQ (CADR OPTION) SET)
(ERROR (LIST "has option from outside set" OPTION)
FORM)))))))
(DEFUN ENTER-OPTION-SYMBOL (SET SYMBOL)
(DO ((L OPTION-SETS (CDR L)))
((NULL L))
(IF (MEMQ SYMBOL (GET (CAR L) 'OPTIONS))
;; this need not be an error, it could simply use the
;; existing GOEDEL number on the option symbol if it did not
;; conflict with the numbers already used by the SET in question.
;; If it did conflict then we have a problem.
;; Those familar with Pascal will recall a similar problem with
;; set implementations in that language.
;; You can't get something for nothing.
(ERROR (LIST "is already defined as an option for" (CAR L))
SYMBOL)))
(PUTPROP SYMBOL (LENGTH (GET SET 'OPTIONS)) SET)
(ENTER-/#-SYMBOL SYMBOL `(|op| ,SET ,SYMBOL))
(PUSH SYMBOL (GET SET 'OPTIONS)))
(DEFUN SETUP-OPTIONS (NAME NUMBER-OF-LEADING-ARGUMENTS OPTIONS)
(OR (MEMQ NAME OPTION-SETS) (PUSH NAME OPTION-SETS))
(OR (MEMQ 'OPTIONS-CHECK (GET NAME 'SOURCE-TRANS))
(PUSH 'OPTIONS-CHECK (GET NAME 'SOURCE-TRANS)))
(PUTPROP NAME NIL 'OPTIONS)
(PUTPROP NAME NUMBER-OF-LEADING-ARGUMENTS 'NUMBER-OF-LEADING-ARGUMENTS)
(MAPC #'(LAMBDA (OPTION)
(ENTER-OPTION-SYMBOL NAME OPTION))
OPTIONS))
(SETUP-OPTIONS 'P-READ 1
'(STOP-CHARS
NUMBER-OF-CHARS
ECHO-P
COMPLETION-CHAR
COMPLETION-ALIST
COMPLETION-QUERY-CHAR
COMPLETION-QUERY-STREAM
STOP-FUNCTION
CHAR-TRANSLATION-FUNCTION))

63
src/libdoc/phase.gls5 Executable file
View File

@@ -0,0 +1,63 @@
TITLE MOONPHASE FUNCTION FOR MACLISP (ITS ONLY)
;;; BY GUY L. STEELE JR. (GLS)
;;; PRIMARILY USED BY THE PHSPRT PACKAGE (Q.V.).
.FASL
.INSRT SYS:.FASL DEFS
;;; (MOONPHASE) RETURNS A 5-LIST (PHS DAY HOUR MIN SEC)
;;; PHS IS: 0 NEW MOON
;;; 1 FIRST QUARTER
;;; 2 FULL MOON
;;; 3 LAST QUARTER
;;; DAY, HOUR, MIN, SEC IS THE TIME SINCE PHS.
;;; THIS ROUTINE IS NOT TRULY ACCURATE, THEY SAY, BUT WHO CARES?
.ENTRY MOONPHASE SUBR 000001
SETZ A,
.RLPDT TT,
SKIPGE TT
POPJ P,
TLNE D,400000
SUBI TT,24.*60.*60.
TLNE D,100000
SUBI TT,60.*60.
MOVE F,TT
MOVEI T,-1(D)
TLZ D,-1
IMULI D,365.
LSH T,-2
ADDI D,(T)
IDIVI T,25.
SUBI D,(T)
LSH T,-2
ADDI D,1(T)
MULI D,24.*60.*60.
JFCL 4,.+1
ADD R,F
ADD R,[690882.]
JFCL 4,[AOJA D,.+1]
ASHC D,2
DIV D,[2551443.]
ANDI D,3
ASH R,-2
SETZ B,
IRP X,,[60.,60.,24.]
IDIVI R,X
MOVE TT,F
JSP T,FXCONS
CALL 2,.FUNCTION CONS
MOVEI B,(A)
TERMIN
MOVE TT,R
JSP T,FXCONS
CALL 2,.FUNCTION CONS
MOVEI B,(A)
MOVE TT,D
JSP T,FXCONS
JCALL 2,.FUNCTION CONS
FASEND

235
src/libdoc/phsprt.gls17 Executable file
View File

@@ -0,0 +1,235 @@
;;; TIMESTAMP uses DATIMPRINC, SUNPOSPRINC, PHASEPRINC to print three sentences
;;; describing the current day and date, position of sun, and phase of moon.
;;; The sentences are each preceded by a terpri-semicolon sequence.
;;; No trailing terpri is printed.
;;; An optional argument specifies which files to print on.
;;; DATIMPRINC prints a sentence describing the current day and date.
;;; An optional argument specifies one of two forms of sentence to print.
;;; A file specification may also be supplied as an argument, but defaults
;;; to the default output files.
;;; PHASEPRINC prints a single sentence describing the phase of the moon.
;;; The sentence is neither preceded or followed by a terpri.
;;; It takes zero to two arguments describing the phase to print and the
;;; files to print onto. If the former is not specified, the MOONPHASE
;;; function is called to determine the current phase of the moon.
;;; If the latter is not specified, the default output files are used.
;;; The one-argument case may specify either, and the argument is
;;; classified as being a phase or a file specification. The two-argument
;;; case takes the phase first and file specification second.
;;; SUNPOSPRINC prints a sentence describing the position of the sun.
;;; It takes zero to two arguments, one being the sun position
;;; (the output of SUN in BKPH's SUN package), and the other a file.
(declare (*lexpr timestamp datimprinc phaseprinc sunposprinc) (newio t))
(defprop moonphase (phase fasl dsk liblsp) autoload)
(defprop sun-now-here (sun fasl dsk liblsp) autoload)
(defun timestamp nargs
((lambda (terpri)
(cond ((= nargs 0)
(terpri)
(tyo 73)
(phaseprinc)
(terpri)
(tyo 73)
(sunposprinc)
(terpri)
(tyo 73)
(datimprinc 'hack))
((= nargs 1)
(terpri (arg 1))
(tyo 73 (arg 1))
(phaseprinc (arg 1))
(terpri (arg 1))
(tyo 73 (arg 1))
(sunposprinc (arg 1))
(terpri (arg 1))
(tyo 73 (arg 1))
(datimprinc 'hack (arg 1)))
(t (error '|more than 1 argument|
(cons 'timestamp (listify nargs))
'wrng-no-args))))
t))
(defun datimprinc nargs
(prog (file filep hack)
(cond ((= nargs 0))
((= nargs 1)
(cond ((eq (typep (arg 1)) 'array)
(setq file (arg 1))
(setq filep t))
(t (setq hack (arg 1)))))
((= nargs 2)
(setq hack (arg 1))
(setq file (arg 2))
(setq filep t))
(t (error '|More than 2 arguments|
(cons 'datimprinc (listify nargs))
'wrng-no-args)))
((lambda (dat tim)
(cond (hack
(phaseprinc1 file filep '|That means it is now |))
(t (phaseprinc1 file filep '|It is now |)))
(phaseprinc1 file filep (+ (\ (+ (car tim) 11.) 12.) 1))
(phaseprinc1 file filep '|:|)
(and (< (cadr tim) 10.) (phaseprinc1 file filep '|0|))
(phaseprinc1 file filep (cadr tim))
(cond ((< (car tim) 12.)
(phaseprinc1 file filep '| AM on |))
(t (phaseprinc1 file filep '| PM on |)))
((lambda (day)
(phaseprinc1 file filep (ascii (car day)))
(mapc '(lambda (n)
(phaseprinc1 file filep (ascii (+ n 40))))
(cdr day)))
(exploden (status dow)))
(phaseprinc1 file filep '|, |)
(phaseprinc1 file filep (do ((i (cadr dat) (1- i))
(m '(|January| |February| |March|
|April| |May| |June|
|July| |August| |September|
|October| |November| |December|)
(cdr m)))
((= i 1) (car m))))
(phaseprinc1 file filep '| |)
(phaseprinc1 file filep (caddr dat))
(phaseprinc1 file filep '|, 19|)
(phaseprinc1 file filep (car dat))
(phaseprinc1 file filep '|.|))
(status date)
(status daytime))))
(defun phaseprinc nargs
(prog (file filep phase units)
(cond ((= nargs 0)
(setq phase (moonphase)))
((= nargs 1)
(cond ((or (atom (arg 1))
(not (numberp (car (arg 1)))))
(setq phase (moonphase))
(setq file (arg 1))
(setq filep t))
(t (setq phase (arg 1)))))
((= nargs 2)
(setq phase (arg 1))
(setq file (arg 2))
(setq filep t))
(t (error '|More than 2 arguments|
(cons 'phaseprinc (listify nargs))
'wrng-no-args)))
(setq units
(do ((x (cdr phase) (cdr x))
(u '(| day| | hour| | minute| | second|) (cdr u))
(z nil (cond ((plusp (car x))
(cons (cons (car x) (car u)) z))
(t z))))
((or (null x) (null u)) (nreverse z))))
(cond ((oddp (car phase))
(phaseprinc1 file filep '|The moon is |))
(t (phaseprinc1 file filep '|It is |)))
(do ((u units (cdr u))
(f 0 (+ f 1)))
((null u))
(cond ((> f 0)
(cond ((cdr u)
(phaseprinc1 file filep '|, |))
((> f 1)
(phaseprinc1 file filep '|, and |))
(t (phaseprinc1 file filep '| and |)))))
(phaseprinc1 file filep (caar u))
(phaseprinc1 file filep (cdar u))
(or (= (caar u) 1)
(phaseprinc1 file filep '|s|)))
(phaseprinc1 file filep '| past the |)
(cond ((= (car phase) 0)
(phaseprinc1 file filep '|new moon.|))
((= (car phase) 1)
(phaseprinc1 file filep '|first quarter.|))
((= (car phase) 2)
(phaseprinc1 file filep '|full moon.|))
(t (phaseprinc1 file filep '|last quarter.|)))))
(defun phaseprinc1 (file filep item)
((lambda (base *nopoint)
(cond (filep (princ item file))
(t (princ item))))
10.
t))
(defun sunposprinc nargs
(prog (file filep sunpos)
(cond ((= nargs 0)
(setq sunpos (sun-now-here)))
((= nargs 1)
(cond ((or (atom (arg 1))
(atom (car (arg 1)))
(not (numberp (caar (arg 1)))))
(setq sunpos (sun-now-here))
(setq file (arg 1))
(setq filep t))
(t (setq sunpos (arg 1)))))
((= nargs 2)
(setq sunpos (arg 1))
(setq file (arg 2))
(setq filep t))
(t (error '|More than 2 arguments|
(cons 'sunposprinc (listify nargs))
'wrng-no-args)))
(phaseprinc1 file filep '|The sun is |)
(do ((i (// (cadadr sunpos) 45.) (- i 1))
(x '(|east| |north| |south| |east| |west| |south| |north| |west|) (cdr x))
(y '(|north| |east| |east| |south| |south| |west| |west| |north|) (cdr y))
(z (\ (cadadr sunpos) 45.)))
((= i 0)
(cond ((oddp (// (cadadr sunpos) 45.))
(degreeprinc file
filep
(degreediff '(45. 0 0)
(cons z (cddadr sunpos)))))
(t (degreeprinc file filep (cons z (cddadr sunpos)))))
(phaseprinc1 file filep '| |)
(phaseprinc1 file filep (car x))
(phaseprinc1 file filep '| of |)
(phaseprinc1 file filep (car y))))
(phaseprinc1 file filep '|, |)
(degreeprinc file filep (cdar sunpos))
(phaseprinc1 file filep (cond ((eq (caar sunpos) '-)
'| below |)
(t '| above |)))
(phaseprinc1 file filep '|the horizon.|)))
(defun degreeprinc (file filep deg)
(phaseprinc1 file filep (car deg))
(phaseprinc1 file filep '|*|)
(phaseprinc1 file filep (cadr deg))
(phaseprinc1 file filep '|'|)
(phaseprinc1 file filep (caddr deg))
(phaseprinc1 file filep '|"|))
(defun degreediff (x y)
(do ((a (reverse x) (cdr a))
(b (reverse y) (cdr b))
(w '(60. 60. 360.) (cdr w))
(borrow 0)
(z nil))
((null a)
(or (zerop borrow)
(error '|Losing degree difference|
(list 'degreediff x y)
'fail-act))
z)
(cond ((minusp (- (car a) (car b) borrow))
(setq z (cons (- (+ (car a) (car w))
(car b)
borrow)
z))
(setq borrow 1))
(t (setq z (cons (- (car a) (car b) borrow) z))
(setq borrow 0)))))

237
src/libdoc/phsprt.gls18 Normal file
View File

@@ -0,0 +1,237 @@
;;; TIMESTAMP uses DATIMPRINC, SUNPOSPRINC, PHASEPRINC to print three sentences
;;; describing the current day and date, position of sun, and phase of moon.
;;; The sentences are each preceded by a terpri-semicolon sequence.
;;; No trailing terpri is printed.
;;; An optional argument specifies which files to print on.
;;; DATIMPRINC prints a sentence describing the current day and date.
;;; An optional argument specifies one of two forms of sentence to print.
;;; A file specification may also be supplied as an argument, but defaults
;;; to the default output files.
;;; PHASEPRINC prints a single sentence describing the phase of the moon.
;;; The sentence is neither preceded or followed by a terpri.
;;; It takes zero to two arguments describing the phase to print and the
;;; files to print onto. If the former is not specified, the MOONPHASE
;;; function is called to determine the current phase of the moon.
;;; If the latter is not specified, the default output files are used.
;;; The one-argument case may specify either, and the argument is
;;; classified as being a phase or a file specification. The two-argument
;;; case takes the phase first and file specification second.
;;; SUNPOSPRINC prints a sentence describing the position of the sun.
;;; It takes zero to two arguments, one being the sun position
;;; (the output of SUN in BKPH's SUN package), and the other a file.
(declare (*lexpr timestamp datimprinc phaseprinc sunposprinc)
;;;(newio t)
)
(defprop moonphase (phase fasl dsk liblsp) autoload)
(defprop sun-now-here (sun fasl dsk liblsp) autoload)
(defun timestamp nargs
((lambda (terpri)
(cond ((= nargs 0)
(terpri)
(tyo 73)
(phaseprinc)
(terpri)
(tyo 73)
(sunposprinc)
(terpri)
(tyo 73)
(datimprinc 'hack))
((= nargs 1)
(terpri (arg 1))
(tyo 73 (arg 1))
(phaseprinc (arg 1))
(terpri (arg 1))
(tyo 73 (arg 1))
(sunposprinc (arg 1))
(terpri (arg 1))
(tyo 73 (arg 1))
(datimprinc 'hack (arg 1)))
(t (error '|more than 1 argument|
(cons 'timestamp (listify nargs))
'wrng-no-args))))
t))
(defun datimprinc nargs
(prog (file filep hack)
(cond ((= nargs 0))
((= nargs 1)
(cond ((eq (typep (arg 1)) 'array)
(setq file (arg 1))
(setq filep t))
(t (setq hack (arg 1)))))
((= nargs 2)
(setq hack (arg 1))
(setq file (arg 2))
(setq filep t))
(t (error '|More than 2 arguments|
(cons 'datimprinc (listify nargs))
'wrng-no-args)))
((lambda (dat tim)
(cond (hack
(phaseprinc1 file filep '|That means it is now |))
(t (phaseprinc1 file filep '|It is now |)))
(phaseprinc1 file filep (+ (\ (+ (car tim) 11.) 12.) 1))
(phaseprinc1 file filep '|:|)
(and (< (cadr tim) 10.) (phaseprinc1 file filep '|0|))
(phaseprinc1 file filep (cadr tim))
(cond ((< (car tim) 12.)
(phaseprinc1 file filep '| AM on |))
(t (phaseprinc1 file filep '| PM on |)))
((lambda (day)
(phaseprinc1 file filep (ascii (car day)))
(mapc '(lambda (n)
(phaseprinc1 file filep (ascii (+ n 40))))
(cdr day)))
(exploden (status dow)))
(phaseprinc1 file filep '|, |)
(phaseprinc1 file filep (do ((i (cadr dat) (1- i))
(m '(|January| |February| |March|
|April| |May| |June|
|July| |August| |September|
|October| |November| |December|)
(cdr m)))
((= i 1) (car m))))
(phaseprinc1 file filep '| |)
(phaseprinc1 file filep (caddr dat))
(phaseprinc1 file filep '|, 19|)
(phaseprinc1 file filep (car dat))
(phaseprinc1 file filep '|.|))
(status date)
(status daytime))))
(defun phaseprinc nargs
(prog (file filep phase units)
(cond ((= nargs 0)
(setq phase (moonphase)))
((= nargs 1)
(cond ((or (atom (arg 1))
(not (numberp (car (arg 1)))))
(setq phase (moonphase))
(setq file (arg 1))
(setq filep t))
(t (setq phase (arg 1)))))
((= nargs 2)
(setq phase (arg 1))
(setq file (arg 2))
(setq filep t))
(t (error '|More than 2 arguments|
(cons 'phaseprinc (listify nargs))
'wrng-no-args)))
(setq units
(do ((x (cdr phase) (cdr x))
(u '(| day| | hour| | minute| | second|) (cdr u))
(z nil (cond ((plusp (car x))
(cons (cons (car x) (car u)) z))
(t z))))
((or (null x) (null u)) (nreverse z))))
(cond ((oddp (car phase))
(phaseprinc1 file filep '|The moon is |))
(t (phaseprinc1 file filep '|It is |)))
(do ((u units (cdr u))
(f 0 (+ f 1)))
((null u))
(cond ((> f 0)
(cond ((cdr u)
(phaseprinc1 file filep '|, |))
((> f 1)
(phaseprinc1 file filep '|, and |))
(t (phaseprinc1 file filep '| and |)))))
(phaseprinc1 file filep (caar u))
(phaseprinc1 file filep (cdar u))
(or (= (caar u) 1)
(phaseprinc1 file filep '|s|)))
(phaseprinc1 file filep '| past the |)
(cond ((= (car phase) 0)
(phaseprinc1 file filep '|new moon.|))
((= (car phase) 1)
(phaseprinc1 file filep '|first quarter.|))
((= (car phase) 2)
(phaseprinc1 file filep '|full moon.|))
(t (phaseprinc1 file filep '|last quarter.|)))))
(defun phaseprinc1 (file filep item)
((lambda (base *nopoint)
(cond (filep (princ item file))
(t (princ item))))
10.
t))
(defun sunposprinc nargs
(prog (file filep sunpos)
(cond ((= nargs 0)
(setq sunpos (sun-now-here)))
((= nargs 1)
(cond ((or (atom (arg 1))
(atom (car (arg 1)))
(not (numberp (caar (arg 1)))))
(setq sunpos (sun-now-here))
(setq file (arg 1))
(setq filep t))
(t (setq sunpos (arg 1)))))
((= nargs 2)
(setq sunpos (arg 1))
(setq file (arg 2))
(setq filep t))
(t (error '|More than 2 arguments|
(cons 'sunposprinc (listify nargs))
'wrng-no-args)))
(phaseprinc1 file filep '|The sun is |)
(do ((i (// (cadadr sunpos) 45.) (- i 1))
(x '(|east| |north| |south| |east| |west| |south| |north| |west|) (cdr x))
(y '(|north| |east| |east| |south| |south| |west| |west| |north|) (cdr y))
(z (\ (cadadr sunpos) 45.)))
((= i 0)
(cond ((oddp (// (cadadr sunpos) 45.))
(degreeprinc file
filep
(degreediff '(45. 0 0)
(cons z (cddadr sunpos)))))
(t (degreeprinc file filep (cons z (cddadr sunpos)))))
(phaseprinc1 file filep '| |)
(phaseprinc1 file filep (car x))
(phaseprinc1 file filep '| of |)
(phaseprinc1 file filep (car y))))
(phaseprinc1 file filep '|, |)
(degreeprinc file filep (cdar sunpos))
(phaseprinc1 file filep (cond ((eq (caar sunpos) '-)
'| below |)
(t '| above |)))
(phaseprinc1 file filep '|the horizon.|)))
(defun degreeprinc (file filep deg)
(phaseprinc1 file filep (car deg))
(phaseprinc1 file filep '|*|)
(phaseprinc1 file filep (cadr deg))
(phaseprinc1 file filep '|'|)
(phaseprinc1 file filep (caddr deg))
(phaseprinc1 file filep '|"|))
(defun degreediff (x y)
(do ((a (reverse x) (cdr a))
(b (reverse y) (cdr b))
(w '(60. 60. 360.) (cdr w))
(borrow 0)
(z nil))
((null a)
(or (zerop borrow)
(error '|Losing degree difference|
(list 'degreediff x y)
'fail-act))
z)
(cond ((minusp (- (car a) (car b) borrow))
(setq z (cons (- (+ (car a) (car w))
(car b)
borrow)
z))
(setq borrow 1))
(t (setq z (cons (- (car a) (car b) borrow) z))
(setq borrow 0)))))

229
src/libdoc/plot.gjc3 Executable file
View File

@@ -0,0 +1,229 @@
;;;-*-lisp-*-
;;; Example of how to use the primitives, a simple plot package.
(eval-when (eval compile)
(or (get 'graphm 'version)
(load (list (car (namelist infile)) 'graphm))))
(graphs-module plot)
(defvar max-flonum (expt 2.0 126.))
(defvar min-flonum (expt 2.0 -129.))
(defstruct (plot (type named-hunk) conc-name
(constructor make-plot-1))
x-min
x-max
(y-min max-flonum)
(y-max min-flonum)
x
n
;; a list of Y's
y-list
;; a list of funcs that went with the Y's.
funcs
)
(defun make-domained-plot (a b n)
(setq a (float a))
(setq b (float b))
(let ((ar (*array nil 'flonum n))
(step (//$ (-$ b a) (float (1- n)))))
(declare (flonum step))
(do ((j 0 (1+ j))
(x a (+$ x step)))
((= j n)
(make-plot-1 x-min a
x-max b
n n
x ar))
(setf (arraycall flonum ar j) x))))
(defun add-function-to-plot (func plot)
(let ((n (plot-n plot)))
(do ((yar (*array nil 'flonum n))
(xar (plot-x plot))
(y-min (plot-y-min plot) (min y y-min))
(y-max (plot-y-max plot) (max y y-max))
(y 0.0)
(x 0.0)
(j 0 (1+ j)))
((= j n)
(push func (plot-funcs plot))
(push yar (plot-y-list plot))
(setf (plot-y-min plot) y-min)
(setf (plot-y-max plot) y-max)
plot)
(setq x (arraycall flonum xar j))
(setq y (float (funcall func x)))
(setf (arraycall flonum yar j) y))))
(defvar image-tty (open "tty:" '(out image tty single)))
(defvar image-file (open "nul:" '(out image dsk block)))
(close image-file)
(cnamef image-file "DSK:OUTPUT")
(defvar image-broadcast (make-broadcast-sfa image-tty image-file))
(defvar ards-stream (make-ards-stream image-broadcast))
(defvar tek-stream (make-tek-stream image-broadcast))
(defvar graphic-stream nil)
(defun set-graphic-stream ()
(when (null graphic-stream)
(setq graphic-stream
(make-graphics-stream
(COND ((PROGN (CURSORPOS 'A TYO)
(Y-OR-N-P "ARDS TTY?"))
ards-stream)
((PROGN (CURSORPOS 'A TYO)
(Y-OR-N-P "TEKRONICS TTY?"))
TEK-STREAM)
(T
(ERROR "thats all the tty's I know for graphics." 'SORRY
'FAIL-ACT)))))))
(defun open-image-file (name)
(close image-file)
(cnamef image-file name)
(open image-file))
(defvar auto-scalep t)
(defvar x-min 0.0)
(defvar x-max 1.0)
(defvar y-min 0.0)
(defvar y-max 1.0)
(defvar image-file-name
(caseq (status opsys)
((tops-20)
"plot.out")
((its)
`((DSK |.TEMP.|) ,(STATUS UNAME) |.PLOT.|))
(t
(error "unknown opsys" (status opsys) 'fail-act))))
(defun plot-plot (plot)
(set-graphic-stream)
(cond (auto-scalep
(set-window GRAPHIC-STREAM
(plot-x-min plot)
(plot-x-max plot)
(plot-y-min plot)
(plot-y-max plot)))
(t
(set-window GRAPHIC-STREAM
x-min x-max y-min y-max)))
(unwind-protect
(progn
(open-image-file image-file-name)
(draw-frame GRAPHIC-STREAM)
(do ((x (plot-x plot))
(l (plot-y-list plot) (cdr l)))
((null l))
(set-pen GRAPHIC-STREAM
(arraycall flonum x 0)
(arraycall flonum (car l) 0))
(move-pen GRAPHIC-STREAM x (car l))))
(close image-file)))
(defvar last-plot nil)
(defun re-plot ()
(CURSORPOS 'C TYO)
(and last-plot (plot-plot last-plot)))
(defun plotf (f-list a b n)
(let ((p (make-domained-plot a b n)))
(do ()
((null f-list)
(setq last-plot p)
(re-plot))
(add-function-to-plot (pop f-list) p))))
(defvar plotnum 50.)
(defmacro (plot defmacro-displace-call nil)
(f var a &optional b)
(cond (b
`(plotf (list (function (lambda (,var) ,f)))
,a ,b plotnum))
(t
`(plotf '(,f) ,var ,a plotnum))))
;; The Chirikov or Standard mapping:
;; (p[n+1] = p[n] - k/2 sin (2q[n])) and k is a parameter
;; (q[n+1] = q[n] + p[n+1])
(defvar chirikov-k 1.13)
(defvar chirikov-n-per-run 200.)
(defvar 2pi (times 8 (atan 1 1)))
(defvar 1//2pi (quotient 1 2pi))
(defvar graphic-sfa nil)
(defun gr-format (x y string &rest l)
(call graphic-stream 'set-pen x y)
(lexpr-funcall 'format graphic-sfa string l))
(declare (flonum (mod1$ flonum)))
(defun mod1$ (x) (-$ x (float (ifix x))))
(defun chirikov (&optional (runs 100.))
(if (fixp runs)
(do ((j 0 (1+ j))
(l nil (cons (cons (quotient (random 1000000.) 1000000.0)
(quotient (random 1000000.) 1000000.0))
l)))
((= j runs)
(setq runs l))))
(set-graphic-stream)
(if (not graphic-sfa)
(setq graphic-sfa (make-graphics-sfa graphic-stream)))
(call graphic-stream 'set-window 0.0 1.0 0.0 1.0)
(cursorpos 'c tyo)
(open-image-file image-file-name)
(draw-frame graphic-stream)
(gr-format 0.0 1.1
"Chirikov mapping plot. K=~S, ~D runs, ~D points per run."
chirikov-k
(length runs)
chirikov-n-per-run)
(do ((l runs (cdr l)))
((null runs)
(tyo #^g tyo)
(cursorpos 'm tyo))
(do ((j 0 (1+ j))
(p (mod1$ (caar l)))
(q (mod1$ (cdar l))))
((= j chirikov-n-per-run)
(draw-point graphic-stream p q))
(declare (fixnum j) (flonum p q))
(draw-point graphic-stream p q)
(setq p (mod1$ (-$ p (*$ 1//2pi chirikov-k (sin (*$ 2pi q))))))
(setq q (mod1$ (+$ p q))))))
(defun plot-file (filename)
;; assume the file contains sets of four floating-point numbers for
;; draw-line.
(set-graphic-stream)
(set-window GRAPHIC-STREAM x-min x-max y-min y-max)
(let (input-stream)
(unwind-protect
(progn (setq input-stream (open filename 'in))
(unwind-protect
(progn (open-image-file image-file-name)
(draw-frame GRAPHIC-STREAM)
(do ((x0)(x1)(y0)(y1))
(())
(setq x0 (read input-stream '*eof*))
(and (eq x0 '*eof*) (return ()))
(setq y0 (read input-stream))
(setq x1 (read input-stream))
(setq y1 (read input-stream))
(call graphic-stream
'draw-line
(float x0)
(float y0)
(float x1)
(float y1))))
(close image-file)))
(and input-stream (close input-stream)))))

175
src/libdoc/plot3.gjc1 Executable file
View File

@@ -0,0 +1,175 @@
;;;-*-lisp-*-
(eval-when (eval compile)
(or (get 'graphm 'version)
(load (list (car (namelist infile)) 'graphm))))
(graphs-module plot3)
(or (get 'plot 'version)
(load '((graphs)plot)))
(or (get 'graph-3d 'version)
(load '((graphs)graph3)))
(defvar 3d-perspective-stream
(make-z-perspective-stream graphic-stream))
(CALL 3d-perspective-stream
'set-z-screen 5.0)
(CALL 3d-perspective-stream
'set-z-eye 10.0)
(defvar 3d-clip-stream
(make-z-clip-stream 3d-perspective-stream))
(CALL 3d-clip-stream 'set-clip-z 10.0)
(defvar 3d-stream (make-orthogonal-3d-stream 3d-perspective-stream))
(CALL 3d-stream 'set-theta 4.188)
(CALL 3d-stream 'set-phi 0.1)
(CALL 3d-stream 'set-psi 4.188)
;;;X = (A-RHO*SIN(PHI/2))*COS(PHI);
;;;Y = (A-RHO*SIN(PHI/2))*SIN(PHI);
;;;Z = RHO*COS(PHI/2);
;;;
;;;" abs(rho)<H, minf<phi<inf, 0<h<a<inf "$
(defvar mobius-a 0.5)
(defvar mobius-h 0.2)
(declare (flonum (mobius-x flonum flonum)
(mobius-y flonum flonum)
(mobius-z flonum flonum)))
(defun mobius-x (rho phi)
(*$ (cos phi) (-$ mobius-a (*$ rho (sin (*$ 0.5 phi))))))
(defun mobius-y (rho phi)
(*$ (sin phi) (-$ mobius-a (*$ rho (sin (*$ 0.5 phi))))))
(defun mobius-z (rho phi)
(*$ rho (cos (*$ phi 0.5))))
(defun mobius (n m)
(do ((dphi (//$ (*$ 2.0 3.1416) (float n)))
(phi 0.0 (+$ phi dphi))
(rho (-$ mobius-h) (-$ mobius-h))
(drho (//$ (*$ 2.0 mobius-h) (float m)))
(j 0 (1+ j)))
((> j n))
(CALL 3d-stream
'set-pen
(mobius-x rho phi)
(mobius-y rho phi)
(mobius-z rho phi))
(do ((k 0 (1+ k)))
((> k m))
(setq rho (+$ rho drho))
(CALL 3d-stream
'move-pen
(mobius-x rho phi)
(mobius-y rho phi)
(mobius-z rho phi)))))
;;; toroidal spiral.
(defvar r1 1.0)
(defvar r2 0.3)
(defun torus-point (com theta phi)
(let ((r2-projection (+$ r1 (*$ r2 (cos phi)))))
(CALL 3d-stream
com
(*$ r2-projection (cos theta))
(*$ r2-projection (sin theta))
(*$ r2 (sin phi)))))
(defun torus (n m
&aux
(dtheta (//$ (*$ 2.0 3.1416) (float n)))
(dphi (//$ (*$ 2.0 3.1416) (float m))))
;; this is a slow torus because of all the sin and cos calculation,
;; which are not really needed.
(do ((j 0 (1+ j))
(theta 0.0 (+$ theta dtheta)))
((> j n))
(torus-point 'set-pen theta 0.0)
(do ((k 0 (1+ k))
(phi 0.0 (+$ phi dphi)))
((> k m))
(torus-point 'move-pen theta phi))))
(defmacro dotrig ((j n sin cos) . body)
`(let* ((n-temp ,n)
(dt (//$ #.(*$ 2.0 3.14159265) (float n-temp))))
(do ((,j 0 (1+ ,j))
(,cos 1.0 (-$ (*$ cdt ,cos) (*$ sdt ,sin)))
(,sin 0.0 (+$ (*$ cdt ,sin) (*$ sdt ,cos)))
(cdt (cos dt))
(sdt (sin dt)))
((> ,j n-temp))
,@body)))
(defun ftorus-point (com sin-theta cos-theta sin-phi cos-phi)
(let ((r2-projection (+$ r1 (*$ r2 cos-phi))))
(CALL 3d-stream
com
(*$ r2-projection cos-theta)
(*$ r2-projection sin-theta)
(*$ r2 sin-phi))))
;; this function is shorter and much faster, the fence-post test
;; for SET-PEN is insignificant.
(defun ftorus (n m)
(dotrig (j n sin-theta cos-theta)
(dotrig (k m sin-phi cos-phi)
(ftorus-point (if (zerop j) 'set-pen 'move-pen)
sin-theta cos-theta
sin-phi cos-phi))))
(comment
(defun fat-line (stream x1 y2 z1 x2 y2 z2 &optional (w% 0.05)
(n 3))
; first get basis vectors for the planes perpendicular to the
; line.
))
(defun draw-segment-list (stream list &aux p)
(cond ((null list))
(t
(setq p (pop list))
(CALL stream 'set-pen (car p) (cadr p) (caddr p))
(do ()
((null list) t)
(setq p (pop list))
(CALL stream 'move-pen (car p) (cadr p) (caddr p))))))
(defun cube ()
(draw-segment-list 3d-stream
'((0.0 0.0 0.0)
(0.0 0.0 1.0)
(0.0 1.0 1.0)
(0.0 1.0 0.0)
(0.0 0.0 0.0)
(1.0 0.0 0.0)
(1.0 1.0 0.0)
(1.0 1.0 1.0)
(1.0 0.0 1.0)
(0.0 0.0 1.0)))
(draw-segment-list 3d-stream
'((1.0 1.0 0.0)(0.0 1.0 0.0)))
(draw-segment-list 3d-stream
'((1.0 0.0 0.0) (1.0 0.0 1.0)))
(draw-segment-list 3d-stream
'((0.0 1.0 1.0) (1.0 1.0 1.0))))
(defvar 2pie (*$ 2.0 3.14159265))
(defun rotate-theta (f &optional (n 10.))
(CALL 3d-stream 'set-dtheta (//$ 2pie (float n)))
(do ()
((zerop (Setq n (1- n))))
(CALL 3d-stream 'translate-theta)
(funcall f)))

46
src/libdoc/prime.pratt1 Executable file
View File

@@ -0,0 +1,46 @@
(cgol)$
% Rabin's probabilistic primality tester. The value of prime(n) (for LISP
users, say (PRIME N)) will be T or NIL, with a mistake on the average at most
prime_error_rate proportion of uses, assuming the random number generator has
no unfortunate properties. A composite may be mistaken for a prime, but not
vice versa. %
export prime, witness_count, rab$ % The only symbols users
of the package may access %
special n, n_1, witness_count, w, sw $
witness_count := 15; w := 2**35; sw:=w-1 $
define brnd(x); % Auxiliary routine for computing big random numbers%
if bigp x then random(sw) + w*brnd(x/:w) else random(x) $
define witness(); (brnd(n-2) rem (n-2)) + 2 $
define mexpt(a,j); % modular exponentiation %
if j=0 then 1
else if oddp j then (a*mexpt(a,j-1)) rem n
else mexpt(a,j/:2)**2 rem n $
define rab(a,j); % careful exponentiation - %
if oddp j then mexpt(a,j) % checks for Carmichaels %
else let x = rab(a,j/:2);
if x<2 then x
else if x = n_1 then 1
else let y = x**2 rem n; if y=1 then 0 else y $
'rbp' of 'prime' := 10 $
define prime(n); % Returns T if n is prime %
if n<30 then if n isin !'(2 3 5 7 11 13 17 19 23 29) then t else nil
else
gcd(n,6469693230) = 1
and
let n_1 = n-1;
iter for k := 1 step k+1
for looks_prime := (rab(witness(),n_1) = 1) step ditto
while looks_prime and k<witness_count
return looks_prime $
=EXIT$

54
src/libdoc/privob.jonl2 Executable file
View File

@@ -0,0 +1,54 @@
;;; -*-LISP-*-
;;; Standard way to create a private obarray, starting with a copy
;;; of the current (standard) obarray, and adding some new symbols
;;; to be shared between the standard and the new one, and getting
;;; private copies of some (possibly already existing) symbols for
;;; the private obarray. Normally, the standard obarray would be
;;; current when this file is executed, so that LOCALS, GLOBALS
;;; STANDARD-OBARRAY, and PRIVATE-OBARRAY would appear as global
;;; symbols (i.e., on both obarrays).
;;; The lines of comment having "*****" in them, just below, show how
;;; this file could be modified for incorporation as a leading part
;;; of some other file. One could then replace the names used for
;;; GLOBALS, LOCALS, STANDARD-OBARRAY, and PRIVATE-OBARRAY.
;These lines must be done first, before any other actions, so that the
; initial creation of PRIVATE-OBARRAY will have on it only the symbols
; found on the standard obarray.
(PROGN (SETQ STANDARD-OBARRAY OBARRAY
PRIVATE-OBARRAY (COND ((BOUNDP 'PRIVATE-OBARRAY) PRIVATE-OBARRAY)
((*ARRAY () 'OBARRAY))))
(AND (OR (NOT (BOUNDP 'GLOBALS)) (ATOM GLOBALS)) (SETQ GLOBALS () ))
(AND (OR (NOT (BOUNDP 'LOCALS)) (ATOM LOCALS)) (SETQ LOCALS () )))
;;; ***** (SETQ GLOBALS '(globalsym1 globalsym2 | . . . | globalsymn))
;;; ***** (SETQ LOCALS '(privatesym1 privatesym2 | . . . | privatesymn))
; Check for conflicting requests.
(AND (MAPCAN '(LAMBDA (GLOBALS)
(MAPCAN '(LAMBDA (LOCALS)
(AND (SAMEPNAMEP GLOBALS LOCALS) (LIST GLOBALS)))
LOCALS))
GLOBALS)
(ERROR '|GLOBALS request conflict with LOCALS for private obarray|))
;So here we try to fix up the two obarrays, as per request
; Get private copies of the "local" symbol requests, just to factor
; out the obarray under which these requests were read in.
; Get the copies of the "global" requests from off the standard obarray,
; and remove any locals from off the standard obarray
(SETQ LOCALS (LET ((OBARRAY PRIVATE-OBARRAY))
(MAPCAR '(LAMBDA (X)
(REMOB X)
(INTERN (COPYSYMBOL X () )))
LOCALS)))
(SETQ GLOBALS (LET ((OBARRAY STANDARD-OBARRAY))
(MAPCAR 'INTERN GLOBALS)))

148
src/libdoc/prompt.gjc4 Executable file
View File

@@ -0,0 +1,148 @@
;;;-*-lisp-*-
;;; Utilities for reading information from the TTY with prompt,
;;; these utilities are simple and small, do slight amounts of consing,
;;; and are suitable for most user interactions required in utility programs.
;;; 4:45pm Sunday, 22 February 1981 -GJC
;;; Calling and return convention (P-READ <PROMPT> . <OPTIONS>)
;;; P-READ returns a list of the characters TYI'd in reverse order.
;;; Example usage. (P-READ "File name->")
;;; (P-READ (FORMAT NIL "Frob the ~A (Y or N)?" foo)
;;; #\NUMBER-OF-CHARS 1 #\STOP-CHARS NIL)
;;; (P-READ "Input-pass-word" #\ECHO-P NIL)
;;; (P-READ "Extended-command->" #\COMPLETION-ALIST FOOBAR)
;;; NOTES: [1] P-READ binds TTY-RETURN to increase user comfort and assurance.
;;; [2] In order to specify the options symbolicaly, you must load
;;; LIBLSP;OPTDEF at read time.
;;; [3] COMPLETION-ALIST is recursively of the form
;;; ((<CHAR> . COMPLETION-ALIST) (<CHAR> . COMPLETION-ALIST) ...)
;;; it is presently unimplemented.
;;; [4] STOP-FUNCTION allows arbitrary stop conditions
;;; including interface to a lisp reader.
#.(PROGN (OR (GET 'OPTDEF 'VERSION) (LOAD '((LIBLSP)OPTDEF))) NIL)
(defvar query-io-out tyo)
(defvar query-io-in tyi)
(eval-when (eval compile)
(or (get 'defstruct 'macro)
(load '((liblsp)struct)))
(OR (GET 'TTY 'VERSION) (LOAD '((LIBLSP)TTY)))
(defstruct (p-display conc-name default-pointer
;;list
;;array
;; If you don't want any hunks then use
;; arrays which add 70 words to the code, or
;; list, which is a bit slower.
)
(chars nil)
(EOL-H-CURSORPOS NIL)
(prompt '||)
ECHO-P
n
rubout-p
f
))
(eval-when (compile)
(setq defmacro-for-compiling nil))
(HERALD PROMPT)
(defvar p-display (make-p-display))
(defun p-display (IGNORE)
(cursorpos 'a query-io-out)
(princ (p-display-prompt) query-io-out)
(if (p-display-echo-p)
(p-display-sub (p-display-chars) nil)))
(defun p-display-sub (l function)
(cond ((null l))
(t
(p-display-sub (cdr l) function)
(if function
(funcall function (car l))
(tyo (car l) query-io-out)))))
(defun get= (option list default)
(do ()
((null list) default)
(if (= option (pop list))
(return (car list)))))
(defmacro optional (option default)
(comment
`(let ((given-val (get=skip ,option options)))
(if given-val (car given-val) ,default)))
`(get= ,option options ,default))
(defun p-enter-c (c)
(setf (p-display-n) (1- (p-display-n)))
(push c (p-display-chars))
(if (p-display-echo-p) (tyo c query-io-out))
(cond ((p-display-rubout-p)
(setf (p-display-rubout-p) nil)
(if (p-display-f)
(p-display-sub (p-display-chars)
(p-display-f))))))
(defun p-read (prompt
&rest options
&aux
(stop-chars (optional #\stop-chars '(#\cr)))
;;(completion-char (optional #\completion-char #\alt))
;;(completion-alist (optional #\completion-alist nil))
;;(completion-query-char (optional #\completion-query-char #/?))
;;(COMPLETION-QUERY-STREAM (OPTIONAL #\COMPLETION-QUERY-STREAM QUERY-IO-OUT))
(CT (OPTIONAL #\CHAR-TRANSLATION-FUNCTION NIL))
(p-display (make-p-display prompt prompt
echo-p (optional #\echo-p t)
f (optional #\stop-function nil)
rubout-p nil
n (optional #\number-of-chars -1)))
(tty-return #'p-display)
)
(do-with-tty-off
(p-display nil)
(do ((c))(nil)
(setq c (tyi query-io-in))
(IF CT (SETQ C (FUNCALL CT C)))
(if (or (and (p-display-f) (funcall (p-display-f) c))
(member c stop-chars))
(return (cons c (p-display-chars))))
(caseq c
((#\ff)
(cursorpos 'c query-io-out)
(p-display nil))
((#\rubout)
(if (p-display-chars)
(let ((c-rub (pop (p-display-chars))))
(setf (p-display-n) (1+ (p-display-n)))
(setf (p-display-rubout-p) t)
(if (p-display-echo-p)
(caseq c-rub
((#\cr #\tab)
;; its doesn't handle rubout of #\cr.
(if (= c-rub #\cr)
(cursorpos 'u query-io-out)
(rubout #\tab query-io-out))
(cursorpos
'h
(pop (p-display-eol-h-cursorpos))
query-io-out))
(t
(rubout c-rub query-io-out)))))))
((#\cr #\tab)
(if (p-display-echo-p)
(push (cdr (cursorpos query-io-out))
(p-display-eol-h-cursorpos)))
(p-enter-c c))
(t
(p-enter-c c)))
(if (zerop (p-display-n))
(return (p-display-chars))))))

129
src/libdoc/qtrace.kmp19 Executable file
View File

@@ -0,0 +1,129 @@
;;; -*- LISP -*-
;;; QTRACE: A QBREAKing flavor of MacLISP TRACE
;;;
;;; Interesting functions defined in this file are:
;;;
;;; (QBREAK), (QBREAK <break-name>), (QBREAK <break-name> <condition>)
;;; Works just like BREAK, but BREAK is conditionalized on
;;; *QBREAK (see below).
;;;
;;; (QTRACE <specs1> <specs2> ... <specsN>)
;;; Works just like TRACE, but will offer to BREAK at each call to
;;; the functions specified (conditionalizing on *QBREAK).
;;;
;;; (*QBREAK <state>)
;;; Changes the value of *QBREAK. (The user should not use
;;; (SETQ *QBREAK <value>) or lambda-bind *QBREAK unless he is
;;; certain that the value he is assigning to the *QBREAK
;;; variable is a legal one. The *QBREAK function does this sort
;;; of type-checking to insure a legal value.
;;;
;;; If <state>=ALWAYS,
;;; then QTRACE'd things and QBREAK will always break without
;;; asking (if their other optional conditions are also satisfied).
;;;
;;; If <state>=NEVER
;;; then QTRACE'd things and QBREAK will never break under any
;;; circumstances.
;;;
;;; If <state>=QUERY
;;; then QTRACE'd things and QBREAK will break only if any
;;; additional conditions given are satisfied AND the
;;; user also answers affirmatively to a query about whether
;;; or not to break.
;;;
(DECLARE (SPECIAL *QBREAK))
(COND ((NOT (BOUNDP '*QBREAK)) (SETQ *QBREAK 'QUERY)))
;;; QBREAK
;;; Like BREAK but listens to the value of *QBREAK.
(DEFUN (QBREAK MACRO) (X)
(COND ((> (LENGTH X) 3.)
(ERROR '|QBREAK called on too many args.| X)))
`(BREAK ,(OR (CADR X) '|QBreak|)
,(COND ((NULL (CDDR X)) '(*QBREAK$BREAK?))
((MEMBER (CADDR X) '(T 'T)) '(*QBREAK$BREAK?))
(T `(AND ,(CADDR X) (*QBREAK$BREAK?))))))
;;; QTRACE
;;; Reformat a TRACE into something that asks whether to break.
;;; Called just like TRACE. Explicitly provided info about when
;;; to break overrides the default.
(DEFUN (QTRACE MACRO) (X)
(CONS 'TRACE (MAPCAR 'QTRACE$SETUP (CDR X))))
;;; QTRACE$SETUP
;;; Looks to see that it isn't clobbering explicit info. Returns a
;;; form that can be an arg to trace.
(DEFUN QTRACE$SETUP (X)
(COND ((ATOM X) (LIST X 'BREAK '(*QBREAK$BREAK?)))
((NOT (MEMQ 'BREAK X)) (APPEND X '(BREAK (*QBREAK$BREAK?))))
(T
(DO ((C (CDR X))
(L (NCONS (CAR X))))
((NULL C) (NREVERSE L))
(PUSH (CAR C) L)
(COND ((NOT (EQ (POP C) 'BREAK))
(PUSH (POP C) L))
(T
(COND ((MEMBER (CAR C) '(T 'T))
(POP C)
(PUSH '(*QBREAK$BREAK?) L))
(T
(PUSH `(AND ,(POP C) (*QBREAK$BREAK?))
L)))))))))
;;; If *QBREAK is set to T, anything QTRACE'd will Break.
(DEFUN *QBREAK$BREAK? ()
(COND ((EQ *QBREAK 'ALWAYS) T)
((EQ *QBREAK 'QUERY) (QTRACE$QUERY))
((EQ *QBREAK 'NEVER) NIL)
(T
(ERROR '|- Illegal value for *QBREAK.| *QBREAK)
(*QBREAK$BREAK?))))
(DEFUN QTRACE$QUERY ()
(PROG1
(PROG (C)
(CLEAR-INPUT TYI)
(PRINC '|--Break?--| TYO)
TOP (SETQ C (TYI TYI))
(COND ((OR (= C 32.) (= C 89.) (= C 121.)) ;Space,Y,y
(PRINC '| [Yes]| TYO)
(RETURN T))
((OR (= C 127.) (= C 78.) (= C 110.)) ;Rubout,N,n
(PRINC '| [No]| TYO)
(RETURN NIL))
(T
(CLEAR-OUTPUT TYO)
(COND ((= C 13.)
(COND ((AND (NOT (ZEROP (LISTEN)))
(= (TYIPEEK NIL TYI) 10.))
(TYI TYI)))) ; Eat accompanying linefeed
(T (TERPRI TYO)))
(PRINC '|Create a Breakpoint? (Y or N)| TYO)
(GO TOP))))
(COND ((NOT (ZEROP (LISTEN)))
(COND ((= (TYIPEEK NIL TYI) 13.)
(TYI TYI)))))
(COND ((NOT (ZEROP (LISTEN)))
(COND ((= (TYIPEEK NIL TYI) 10.)
(TYI TYI)))))))
(DEFUN *QBREAK FEXPR (X)
(SETQ X (CAR X))
(COND ((OR (EQ X 'QUERY) (EQUAL X '(QUOTE QUERY)))
(SETQ *QBREAK 'QUERY))
((OR (EQ X 'NEVER) (EQUAL X '(QUOTE NEVER)))
(SETQ *QBREAK 'NEVER))
((OR (EQ X 'ALWAYS) (EQUAL X '(QUOTE ALWAYS)))
(SETQ *QBREAK 'ALWAYS))
(T
(ERROR
'|Illegal value for *QBREAK. Use ALWAYS, NEVER, or QUERY.|))))

219
src/libdoc/rdtags.byron2 Executable file
View File

@@ -0,0 +1,219 @@
;; -*-lisp-*-
(include |ai:ken;declare >|) ;;my macros etc.
(defcomment rdtags) ;;for emacs tags
;;this file reads emacs tags created by :tags and creates a file of
;;defprop of the function names in the tags file to an autoload-property
;;those defining functions (such as defun) without an autoload-porperty are ignored
;;there is only one known very obscure screw, that occurs only if the function
;;name in the lisp file is immediately followed by a carriage return (before argument-list)
;;and the function name ends in a number then the function name without the number is defproped
;;Currently it skips any files in your tags file whose language is not LISP
;;TO USE THIS: first define which kinds of defining forms you want autoloaded (and how)
;;by putting on the defining function a property indicating what property you want for the
;;symbol being defined to have.
;;FOR EXAMPLE:
;;(defprop defun autoload autoload-property) this is typical
;;(defprop define-macro macro-load autoload-property) where you'll make use of macro-load
;;THEN: just call the function "read-eamcs-tags" with the name of your tags file
;;and the name of the output file you want. Optionally you can restrict the program to
;;consider only functions defined in a list of file names you provide
;;FOR EXAMPLE:
;;(read-emacs-tags '|foo;foo tags| '|foo;foo ltags| '(file1 |bar;file1| file2))
;;reading foo's tags and making a file of autoload of foo's file1 and file2 and bar's file1
;;the file "foo;foo ltags" should look something like
;;(defprop function1 foo/;file1 autoload)
;;(defprop macro24 foo/;file1 macro-load)
;;(defprop function2 bar;file1 autoload)
;;and so on
;;ADVICE:
;;If you are concerned that putting an autoload property on all your functions wastes too
;;much memory you can do two things:
;;(a) Make your version of "defun" be a macro that remprop's the symbol's autoload property
;;(b) Have two names for defun: one of which will generate autoload properties
;; and the other you use only for internal functions.
(declare (special output-file input-file)) ;;for debugging
;; define-function is almost the same as "defun" but it remprops its 'autoload property
(define-function read-emacs-tags (tags-file-name ltags-file-name &optional (only-these-files))
;;if only-these-files is nil read all files otherwise only those in only-these-files are read
(let-files ;;closes files nicely and closes for errors
((input-file (open tags-file-name 'in))
(output-file (open ltags-file-name 'out)))
(let
((only-these-files
(and only-these-files
(mapcar
(function (lambda (file-name)
(mergef '((dsk *) * *)
(mergef file-name '((dsk ,(second (crunit))) * >)))))
only-these-files))))
(catch
(do ((file-name)
(next-char (tyipeek-eof input-file) (tyipeek-eof input-file)))
((= next-char 3)) ;;control-c
(cond ((or (and (not (member (setq file-name (read-tags-file-name input-file))
only-these-files))
only-these-files)
(not (eq (read-language-name input-file) 'lisp))) ;;only lisp files
(skip-rest-of-file input-file))
(t (read-defun-lines (autoload-name file-name) input-file))))
end-of-file))))
(defun autoload-name (file-name)
(maknam (append (exploden (second (first file-name))) ;;directory
'(#/;)
(exploden (second file-name)))))
(defun read-tags-file-name (input-file)
(mergef '((dsk *) * *)
(readline input-file)))
(defun read-language-name (input-file)
(read input-file) ;; the file length or something
(tyi input-file) ;;gobble up the ,
(read input-file)) ;;the name
(defun read-defun-lines (file-name input-file)
(let ((first-letter (tyi -1 input-file)))
(cond ((= first-letter #(getcharn '|(| 1))
(let ((autoload-property (get (read input-file) 'autoload-property)))
(cond ((null autoload-property) (read-to-cr input-file)) ;;skip this one
(t (flush-spaces input-file)
(cond ((= (tyipeek -1 input-file) #(getcharn '|(| 1))
;;as in (defun (foo bar) ...)
(tyi -1 input-file))) ;;gobble it up
(let* ((function-name (read input-file -1))
(next-letter (cond ((and (numberp function-name)
(= function-name -1)) -1)
(t (tyipeek -1 input-file)))))
(cond ((= next-letter -1) ;;eof
(throw t end-of-file))
((or (= next-letter #(getcharn '|(| 1))
(= next-letter #(getcharn '|| 1)))
;;if the is no space after function name as when
;;a ctrl-m is there which happens
;;if defun has carriage after function name
(setq function-name (fix-function-name function-name)))
(t (read-to-cr input-file))) ;ignore position number
(print
'(defprop ,function-name ,file-name ,autoload-property)
output-file)))))
(read-defun-lines file-name input-file))
((= first-letter #(getcharn '|| 1))
(tyi -1 input-file) (tyi -1 input-file)) ;eat up <cr> <lf>
((= first-letter 10.) ;;<lf>
(read-defun-lines file-name input-file)) ;;try again
((= first-letter 13) ;;<cr>
(read-defun-lines file-name input-file))
(t (print '(,(ascii first-letter) | first letter is not right|))
(break bad-tags-file? t)))))
;;this removes the right-most numbers from an atom
;;since there will be crud there if one had a cr after function name eg
;;(defun foo
;; (x) ...)
(defun fix-function-name (function-name)
(do ((letters (nreverse (exploden function-name)) (rest letters)))
((null letters) function-name)
(let ((letter (first letters)))
(cond ((and (> letter 47) (< letter 58)))
(t (return (implode (nreverse letters))))))))
(defun read-to-cr (input-file)
(read-ending-with #(getcharn '/
1) input-file))
(defun skip-rest-of-file (input-file)
(throw-away-until #(getcharn '|| 1) input-file)
(tyi input-file) (tyi input-file))
(declare (fixnum character))
(defun throw-away-until (stop-character input-file)
(do ((character (tyi -1 input-file) (tyi -1 input-file)))
((= character stop-character)) ;;get rid of the rest
(cond ((= character -1) (throw t end-of-file)))))
(defun read-ending-with (end-character input-file)
;;this returns the list of characters in the reverse order read
(do ((character-list nil (cons character character-list))
(character 0.))
((= (setq character (tyi -1 input-file)) end-character)
(cons end-character character-list))))
(defun flush-spaces (input-file)
(do ((character (tyipeek -1 input-file)
(progn (tyi -1 input-file) (tyipeek -1 input-file))))
((not (= character 32.)))))
(defun tyipeek-eof (input-file)
(let ((tyipeek-result (tyipeek -1. input-file)))
(cond ((minusp tyipeek-result) (throw t end-of-file))
(tyipeek-result))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Create @ xfile from tags file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;The function @-emacs-tags creates an @ xfile from a tags file, writing
;;; it out with second filename "XFILE". This file can be editted, if
;;; desired, and then executed by typing ":XFILE fn1 XFILE" to DDT.
;;;
(define-function /@-emacs-tags (tags-file-name &optional (xgp? t) (only-these-files))
;;if only-these-files is nil read all files otherwise only those in only-these-files are read
(let ((/@-xfile-name (mergef '((* *) * xfile) tags-file-name))
(/@-lrec-file-name (mergef '((* *) * lrec) tags-file-name))
(tags-file-name (mergef '((* *) * tags) tags-file-name)))
(let-files ;;closes files nicely and closes for errors
((input-file (open tags-file-name 'in))
(output-file (open /@-xfile-name 'out)))
(write-/@-leader /@-lrec-file-name output-file)
(let
((only-these-files
(and only-these-files
(mapcar
(function (lambda (file-name)
(mergef '((dsk *) * *)
(mergef file-name
(list (list 'dsk (cadr (crunit)))
'* '>)))))
only-these-files))))
(catch
(do ((file-name) (language-name)
(next-char (tyipeek-eof input-file) (tyipeek-eof input-file)))
((= next-char 3)) ;;control-c
(setq file-name (read-tags-file-name input-file))
(cond
((or (null only-these-files) (member file-name only-these-files))
(setq language-name (read-language-name input-file))
(cond
((memq language-name '(lisp macsym midas r))
(write-/@-command file-name language-name output-file xgp?)))))
(skip-rest-of-file input-file))
end-of-file)))))
(defun write-/@-leader (/@-lrec-file-name output-file)
(princ '|:@ | output-file)
(princ (namestring /@-lrec-file-name) output-file)
(or (probef /@-lrec-file-name) (princ '|//G| output-file)))
(defun write-/@-command (file-name language-name output-file xgp?)
(let ((terpri t))
(princ '|/,| output-file)
(princ (namestring file-name) output-file)
(princ '|//L[| output-file)
(princ language-name output-file)
(princ '|]| output-file)

97
src/libdoc/reads.gjc5 Executable file
View File

@@ -0,0 +1,97 @@
;;;-*-lisp-*-
;;; some readers for interactive use.
(herald reads)
(eval-when (eval compile)
(or (get 'optdef 'version)
(load "liblsp;optdef")))
(eval-when (eval compile load)
(or (get 'prompt 'version)
(load "liblsp;prompt")))
(eval-when (eval compile load)
(if (status feature complr)
(*lexpr read-filename read-number p-read read-sexp-line ok-p)))
;; READ-FILENAME takes a prompt and an optional MEREGEF spec, if the
;; filename is for input purposes.
(defun read-filename (prompt &optional (for-input nil))
;; with for-input non-nil we make sure Probef returns non-nil.
;; I/O lossage handler then only deals with really bad things.
(do ((filename)(checked-filename)(probed-filename))(nil)
(setq filename
(maknam (nreverse
(cdr (p-read prompt #\stop-chars '(#\CR #\LF))))))
(terpri query-io-out)
(setq checked-filename (errset (namestring filename) nil))
(cond ((null checked-filename)
(format query-io-out "Bad filename specification : ~A~%" filename))
(for-input
(setq checked-filename (mergef (car checked-filename)
(if (eq for-input t)
""
for-input)))
(if (setq probed-filename (probef checked-filename))
(return probed-filename)
(format query-io-out "File for input ~A cannot be found.~%"
checked-filename)))
(t
(return (car checked-filename))))))
;; READ-NUMBER takes a prompt and an optional validity test predicate,
;; and optional format-args for error message.
(defun read-number (prompt &optional (test nil) (mess "~&Number ~S is not ~A.~%")
&rest l
&aux (base 10.) (ibase 10.))
(do ((input)(number))(nil)
(setq input (nreverse (cdr (p-read prompt #\stop-chars
'(#\CR #\LF #\SP)))))
(terpri query-io-out)
(setq number (errset (readlist input) nil))
(cond ((or (null number)
(not (numberp (setq number (car number)))))
(format query-io-out "Bad numeric specification: ~{~C~}~%" input))
((and test (null (funcall test number)))
(lexpr-FUNCALL #'format query-io-out MESS NUMBER l))
(t
(return number)))))
;; READ-SEXP-LINE. arguments like read-number, very crude.
(defun read-sexp-line (prompt &optional pred (message "~&Bad input, not ~A,~%~S~%")
&rest l
&aux (base 10.) (ibase 10.))
;; only for reading in trivial little things, get P-READ
;; interfaced to read correctly eventually.
(do ((chars)(res))(nil)
(setq chars (nreverse (cdr (p-read prompt #\stop-chars '(#\CR #\LF)))))x
(setq res (errset (readlist chars)))
(cond ((null res)
(format msgfiles "~&Syntax error in input~%"))
((funcall pred (setq res (car res)))
(return res))
(t
(lexpr-funcall #'format msgfiles message pred res l)))))
;; OK-P takes a prompt and optional format-args for help message.
(defun ok-p (prompt &optional (help "~&Please reply /"Y/" or /"N/"~%")
&rest l)
(do ((chars)(bi-prompt prompt) (q-prompt "(Y or N)?"))
(nil)
(setq chars (p-read bi-prompt #\NUMBER-OF-CHARS 1 #\STOP-CHARS NIL))
(cond ((member (car chars) '(#/y #/Y))
(princ "es. " query-io-out)
(return t))
((member (car chars) '(#/n #/N))
(princ "o. " query-io-out)
(return nil))
((member (car chars) '(#/h #/H #/?))
(lexpr-funcall #'format query-io-out help l)
(setq bi-prompt prompt))
(t
(setq bi-prompt q-prompt)))))

1180
src/libdoc/redo.rms1 Executable file
View File

File diff suppressed because it is too large Load Diff

1180
src/libdoc/redo.rms2 Normal file
View File

File diff suppressed because it is too large Load Diff

649
src/libdoc/save.kmp71 Executable file
View File

@@ -0,0 +1,649 @@
;;; -*- LISP -*-
;;; LSPSAV: A package for doing environment saving/recalling from MacLISP
;;;
;;; Documentation is just a little ways down in the file.
;;; Loading this file into LISP and doing (SAVE ?) will also
;;; give documentation.
(EVAL-WHEN (EVAL)
(DEFPROP IOTA ((DSK LIBLSP) IOTA FASL) AUTOLOAD))
(EVAL-WHEN (COMPILE)
(LOAD '((DSK LIBLSP) IOTA FASL)))
(DECLARE (SPECIAL SAVE-FILE
SAVE-OPTIONS
SAVE-VERBOSE
SAVE-PARANOIA
|LSPSAV-`-,-level/||))
(SETQ |LSPSAV-`-,-level/|| 0.)
(DEFUN LSPSAV$VERSION MACRO (X) (LIST 'QUOTE LSPSAV$VERSION))
(DEFUN LSPSAV$DOC MACRO (X) (LIST 'QUOTE LSPSAV$DOC))
(EVAL-WHEN (COMPILE EVAL)
(SETQ LSPSAV$VERSION
(DO ((X (EXPLODEN (CADDR (NAMELIST (TRUENAME INFILE))))
(CDR X))
(L ()))
((NULL X) (IMPLODE (NREVERSE L)))
(COND ((AND (> (CAR X) 47.) (< (CAR X) 58.))
(PUSH (CAR X) L)))))
(SETQ LSPSAV$DOC (MAKNAM (DO ((C (TYI) (TYI)) (L NIL (CONS C L)))
((= C 12.) (NREVERSE L))))))
;;;
;;; MacLISP File-Save Package
;;;
;;; Syntax:
;;;
;;; SAVE: (SAVE <file> <symbols> <options>)
;;;
;;; UNSAVE: (UNSAVE <file>)
;;;
;;; Args needn't be quoted. If they are, the quote will be removed.
;;; Don't expect args to evaluate as variables, however.
;;;
;;; <file> has the form ((Device Directory) Filename1 Filename2)
;;; or |Device:Directory;Filename1 Filename2|
;;; The default output file is in the free variable
;;; SAVE-FILE and may be altered as needed.
;;;
;;; <vars> is a list of symbols to be saved. An arg of NIL or
;;; ALL means to save all user variables.
;;; An arg of T saves system vars too. (Can't be unsaved!)
;;;
;;; <options> is a list of options to be saved. Possible options are:
;;; [VALUES, PROPS, FUNCTIONS, ARRAYS]. Other more obscure
;;; ones are supported as well. Default options are in the
;;; free variable SAVE-OPTIONS.
;;;
;;; Examples:
;;;
;;; (SAVE ((DSK FOO) BAR >) ; Save to file FOO;BAR >
;;; (A B F) ; symbols A, B, and F
;;; (PROPS VALUES)) ; values and non-functional properites
;;; (UNSAVE |DSK:FOO; BAR >|) ; UnSave last save to FOO;BAR >
;;;
;;; (SAVE) ; Save all values and functions to default file
;;; (UNSAVE) ; UnSave last save from default file
;;;
;;; Pertinent variables:
;;;
;;; SAVE-VERBOSE -- Setting this variable to T will cause the return value of
;;; each form in the file to be printed when it is UNSAVE'd.
;;;
;;; SAVE-PARANOIA -- Setting this variable to NIL will turn off checking
;;; for an already existing file by the same name as the
;;; file you are planninng to write to.
;;;
;;; SAVE-OPTIONS -- This variable contains info on what types of things
;;; for SAVE to store into the file.
;;;
;;; SAVE-FILENAMES -- The filenames to SAVE/UNSAVE to/from.
;;; Defaults:
;;;
;;; OPTIONS => (VALUES FUNCTIONS)
;;; FILE => ((DSK hsname) username .LISP.)
;;; VERBOSE => NIL
;;; PARANOIA => T
(PROG (FILE)
(COND ((NOT (BOUNDP 'SAVE-OPTIONS))
(SETQ SAVE-OPTIONS '(VALUES FUNCTIONS))))
(SETQ FILE `((DSK ,(STATUS HSNAME)) ,(STATUS USERID) |.LISP.|))
(COND ((NOT (BOUNDP 'SAVE-PARANOIA))
(SETQ SAVE-PARANOIA T)))
(COND ((NOT (BOUNDP 'SAVE-VERBOSE))
(SETQ SAVE-VERBOSE NIL)))
(COND ((BOUNDP 'SAVE-FILE)
(SETQ SAVE-FILE (MERGEF SAVE-FILE FILE)))
(T
(SETQ SAVE-FILE FILE))))
(DEFUN LSPSAV$PRINT (FROB STREAM)
(TERPRI STREAM)
(LSPSAV$PRIN1 FROB STREAM)
(PRINC '| | STREAM))
(DEFUN LSPSAV$PRIN1 (FROB STREAM)
(COND ((ATOM FROB) (PRIN1 FROB STREAM))
((HUNKP FROB)
(PRINC '|(| STREAM)
(DO ((I 1. (1+ I))
(END (1- (HUNKSIZE FROB))))
((> I END))
(LSPSAV$PRIN1 (CXR I FROB) STREAM)
(PRINC '| . | STREAM))
(PRINC (CXR 0. FROB) STREAM)
(PRINC '| .)| STREAM))
((AND (EQ (CAR FROB) 'QUOTE)
(= (LENGTH FROB) 2.))
(PRINC '/' STREAM)
(LSPSAV$PRIN1 (CADR FROB) STREAM))
((EQ (CAR FROB) '|`-expander/||)
(LET ((|LSPSAV-`-,-level/|| (1+ |LSPSAV-`-,-level/||)))
(PRINC '|`| STREAM)
(LSPSAV$PRIN1 (CDR FROB) STREAM)))
((AND (EQ (CAR FROB) '|`,/||) (> |LSPSAV-`-,-level/|| 0.))
(LET ((|LSPSAV-`-,-level/|| (1- |LSPSAV-`-,-level/||)))
(PRINC '|,| STREAM)
(LSPSAV$PRIN1 (CDR FROB) STREAM)))
((AND (EQ (CAR FROB) '|`,@/||) (> |LSPSAV-`-,-level/|| 0.))
(LET ((|LSPSAV-`-,-level/|| (1- |LSPSAV-`-,-level/||)))
(PRINC '|,@| STREAM)
(LSPSAV$PRIN1 (CDR FROB) STREAM)))
((AND (EQ (CAR FROB) '|`,./||) (> |LSPSAV-`-,-level/|| 0.))
(LET ((|LSPSAV-`-,-level/|| (1- |LSPSAV-`-,-level/||)))
(PRINC '|,.| STREAM)
(LSPSAV$PRIN1 (CDR FROB) STREAM)))
((AND (EQ (CAR FROB) '|`.,/||) (> |LSPSAV-`-,-level/|| 0.))
(LET ((|LSPSAV-`-,-level/|| (1- |LSPSAV-`-,-level/||)))
(PRINC '|.,| STREAM)
(LSPSAV$PRIN1 (CDR FROB) STREAM)))
((AND (EQ (CAR FROB) 'MACROEXPANDED)
(GET (CADR FROB) 'MACRO))
(LSPSAV$PRIN1 (NTH 3. FROB) STREAM))
((LSPSAV$MEM '|`,/|| FROB)
(LSPSAV$PRIN1
(DO ((L FROB (CDR L))
(NL () (CONS (CAR L) NL)))
((EQ (CAR L) '|`,/||)
(NREVERSE (CONS (CONS '|`.,/|| (CDR L)) NL))))
STREAM))
(T
(PRINC '|(| STREAM)
(LSPSAV$PRIN1 (CAR FROB) STREAM)
(DO ((F (CDR FROB) (CDR F)))
((ATOM F)
(COND ((NULL F) (PRINC '|)| STREAM))
(T (PRINC '| . | STREAM)
(LSPSAV$PRIN1 F STREAM)
(PRINC '|)| STREAM))))
(PRINC '| | STREAM)
(LSPSAV$PRIN1 (CAR F) STREAM))))
T)
(DEFUN LSPSAV$MEM (X Y)
(DO ((L Y (CDR L)))
((ATOM L) NIL)
(COND ((EQ (CAR L) X) (RETURN L)))))
(DEFUN LSPSAV$DOCUMENTATION ()
(TERPRI TYO)
(PRINC '|;;; LSPSAV.| TYO)
(PRINC (LSPSAV$VERSION) TYO)
(PRINC '| Documentation.| TYO)
(PRINC (LSPSAV$DOC) TYO)
(TERPRI TYO))
(DEFUN LSPSAV$SAVE-VALUE (LAB STREAM)
(COND ((BOUNDP LAB)
((LAMBDA (VAL BASE *NOPOINT)
(LSPSAV$PRINT (LIST 'SETQ LAB
(COND ((OR (NUMBERP VAL)
(EQ VAL 'T)
(NULL VAL))
VAL)
(T (LIST 'QUOTE VAL))))
STREAM))
(EVAL LAB) 10. NIL))))
(DEFUN LSPSAV$LAMBDA? (X)
(AND (NOT (ATOM X))
(EQ (CAR X) 'LAMBDA)
(> (LENGTH X) 2.)))
(DEFUN LSPSAV$SAVE-EXPR (NAME STREAM)
((LAMBDA (BASE *NOPOINT)
(COND ((GET NAME 'EXPR)
(COND ((LSPSAV$LAMBDA? (GET NAME 'EXPR))
(LSPSAV$PRINT (APPEND (LIST 'DEFUN NAME)
(CDR (GET NAME 'EXPR)))
STREAM))
(T
(LSPSAV$PRINT (LIST 'DEFPROP
NAME
(GET NAME 'EXPR)
'EXPR)
STREAM))))))
10. NIL))
(DEFUN LSPSAV$SAVE-FEXPR (NAME STREAM)
((LAMBDA (BASE *NOPOINT)
(COND ((GET NAME 'FEXPR)
(COND ((LSPSAV$LAMBDA? (GET NAME 'FEXPR))
(LSPSAV$PRINT (APPEND (LIST 'DEFUN NAME 'FEXPR)
(CDR (GET NAME 'FEXPR)))
STREAM))
(T
(LSPSAV$PRINT (LIST 'DEFPROP
NAME
(GET NAME 'FEXPR)
'FEXPR)
STREAM))))))
10. NIL))
(DEFUN LSPSAV$SAVE-MACRO (NAME STREAM)
((LAMBDA (BASE *NOPOINT)
(COND ((GET NAME 'MACRO)
(COND ((LSPSAV$LAMBDA? (GET NAME 'MACRO))
(LSPSAV$PRINT (APPEND (LIST 'DEFUN NAME 'MACRO)
(CDR (GET NAME 'MACRO)))
STREAM))
(T
(LSPSAV$PRINT (LIST 'DEFPROP
NAME
(GET NAME 'MACRO)
'MACRO)
STREAM))))))
10. NIL))
(DEFUN LSPSAV$SAVE-PLIST (NAME STREAM)
((LAMBDA (P BASE *NOPOINT)
(AND P (LSPSAV$PRINT (LIST 'SETPLIST
(LIST 'QUOTE NAME)
(LIST 'QUOTE P))
STREAM)))
(LSPSAV$PLIST NAME) 10. NIL))
(DEFUN LSPSAV$SAVE-PROP (NAME PROP STREAM)
((LAMBDA (P BASE *NOPOINT)
(AND P
(LSPSAV$PRINT (LIST 'DEFPROP NAME PROP) STREAM)))
(GET NAME PROP) 10. NIL))
(DEFUN LSPSAV$SAVE-ARRAY (NAME STREAM)
((LAMBDA (A BASE *NOPOINT)
(AND A
(LSPSAV$PRINT (CONS 'ARRAY (CONS NAME (ARRAYDIMS A)))
STREAM)
(LSPSAV$PRINT (LIST 'FILLARRAY
NAME
(LIST 'QUOTE (LISTARRAY NAME)))
STREAM)))
(GET NAME 'ARRAY) 10. NIL))
(DEFUN LSPSAV$PLIST (NAME)
(DO ((L (PLIST NAME) (CDDR L))
(P NIL))
((NULL L) (NREVERSE P))
(COND ((MEMQ (CAR L) '(SUBR LSUBR FSUBR ; Binary garbage!
ARRAY ; Arrays
FEXPR EXPR MACRO)) ; Defun's
(COMMENT DO NOTHING WITH THESE!))
(T
(SETQ P (CONS (CADR L) (CONS (CAR L) P)))))))
(DEFUN LSPSAV$UNQUOTE (X Q)
(OR Q
(PROGN
(CURSORPOS 'A TYO)
(PRINC '|;Please don't quote args to this function. I'll strip| TYO)
(TERPRI TYO)
(PRINC '|;the quotes since it is obvious what your error was| TYO)
(TERPRI TYO)
(PRINC '|;but in general you should not expect args to this| TYO)
(TERPRI TYO)
(PRINC '|;function to get EVAL'd.| TYO)
(TERPRI TYO)))
(EVAL X))
(DEFUN SAVE FEXPR (X)
(PROG (FILE VARLIST OPTIONS QWARN SYSTEM!)
(COND ((EQUAL X '(?))
(LSPSAV$DOCUMENTATION)
(RETURN NIL)))
(COND ((> (LENGTH X) 3.)
(CURSORPOS 'A TYO)
(PRINC '|;Too many args to SAVE.| TYO)
(PRINC '| Do (SAVE ?) for help.| TYO)
(TERPRI TYO)
(RETURN NIL)))
(SETQ FILE (CAR X))
(COND ((AND (NOT (ATOM FILE))
(EQ (CAR FILE) 'QUOTE))
(SETQ FILE (PROG2 NIL
(LSPSAV$UNQUOTE FILE QWARN)
(SETQ QWARN T)))))
(SETQ FILE (MERGEF (OR FILE '||) SAVE-FILE))
(SETQ VARLIST (CADR X))
(COND ((EQ (CAR VARLIST) 'QUOTE)
(SETQ VARLIST
(PROG2 NIL
(LSPSAV$UNQUOTE VARLIST QWARN)
(SETQ QWARN T)))))
(COND ((AND VARLIST
(ATOM VARLIST)
(NOT (EQ VARLIST T)))
(SETQ VARLIST (NCONS VARLIST))))
(SETQ VARLIST
(COND ((AND (EQ VARLIST 'T)
(PROGN
(TERPRI TYO)
(PRINC '|;Save all system variables.| TYO)
(TERPRI TYO)
(PRINC '|;This dump will not be loadable| TYO)
(PRINC '| without editting out certain| TYO)
(TERPRI TYO)
(PRINC '|;reserved variables like NIL,| TYO)
(PRINC '| T, BPORG,...| TYO)
(TERPRI TYO)
(PRINC '|;Do you really want to do this? | TYO)
(COND ((MEMQ (ASCII (TYI TYI)) '(Y /y | |))
(PRINC '| [Yes]| TYO)
(SETQ SYSTEM! T)
(TERPRI TYO)
T)
(T (PRINC '| [No]| TYO)
(TERPRI TYO)
(PRINC '|;Save request aborted.| TYO)
(TERPRI TYO)
(RETURN NIL)))))
(PROG (L)
(MAPATOMS
(FUNCTION
(LAMBDA (X)
(SETQ L (CONS X L)))))
(RETURN L)))
((OR (NULL VARLIST) (EQUAL VARLIST '(ALL)))
(PROG (L)
(MAPATOMS
(FUNCTION
(LAMBDA (X)
(COND ((OR (= (FLATC X) 1.)
(NOT (STATUS SYSTEM X)))
(SETQ L (CONS X L)))))))
(RETURN L)))
(T VARLIST)))
(SETQ OPTIONS (CADDR X))
(COND ((EQ (CAR OPTIONS) 'QUOTE)
(SETQ OPTIONS (PROG2
NIL
(LSPSAV$UNQUOTE OPTIONS QWARN)
(SETQ QWARN T)))))
(SETQ OPTIONS (OR OPTIONS SAVE-OPTIONS))
(COND ((AND OPTIONS (ATOM OPTIONS))
(SETQ OPTIONS (NCONS OPTIONS))))
(SETQ OPTIONS
(APPLY 'APPEND
(MAPCAR (FUNCTION
(LAMBDA (X)
(COND ((ATOM X) (NCONS X))
(T X))))
(SUBLIS '((FUNCTIONS . (EXPR FEXPR MACRO))
(ALL . (EXPR FEXPR MACRO
VALUES ARRAY))
(FUNCTION . (EXPR FEXPR MACRO))
(PROPERTIES . PROP)
(PROPERTY . PROP)
(PROPS . PROP)
(VALUE . VAL)
(VALUES . VAL)
(EXPRS . EXPR)
(LEXPRS . LEXPR)
(MACROS . MACRO)
(ARRAYS . ARRAY))
OPTIONS))))
(RETURN (LSPSAV FILE VARLIST OPTIONS SYSTEM!))))
(DEFUN UNSAVE FEXPR (X)
(PROG (FILE)
(COND ((EQUAL X '(?))
(LSPSAV$DOCUMENTATION)
(RETURN NIL)))
(COND ((> (LENGTH X) 1.)
(CURSORPOS 'A TYO)
(PRINC '|;Too many args to UNSAVE. Usage is:| TYO)
(TERPRI TYO)
(PRINC '|; (UNSAVE) or (UNSAVE <filename>)| TYO)
(RETURN NIL)))
(SETQ FILE (CAR X))
(COND ((AND (NOT (ATOM FILE))
(EQ (CAR FILE) 'QUOTE))
(SETQ FILE (LSPSAV$UNQUOTE FILE NIL))))
(SETQ FILE (MERGEF (OR FILE '||) SAVE-FILE))
(COND ((NOT (PROBEF FILE))
(TERPRI TYO)
(PRINC '|File not found: | TYO)
(PRINC (NAMESTRING FILE) TYO)
(RETURN NIL))
((ERRSET (LSPSAV$LOAD FILE) T)
(RETURN T))
(T
(PRINC '|;Error in UNSAVE attempt. Aborting.|)
(RETURN NIL)))))
(DEFUN LSPSAV$LOAD (FILE)
(CATCH
(IOTA ((STREAM FILE '(IN)))
(SETQ FILE (NAMESTRING (TRUENAME STREAM)))
(TERPRI TYO)
(PRINC '|; UNSAVE: Reading file "| TYO)
(PRINC FILE TYO)
(PRINC '|"| TYO)
(TERPRI TYO)
(DO ((LINE (READLINE STREAM NIL) (READLINE STREAM NIL)))
((NULL LINE) (OPEN STREAM 'IN))
(TERPRI TYO)
(COND ((AND (NOT (SAMEPNAMEP LINE '||))
(NOT (EQ (GETCHAR LINE 1.) '/;)))
(RETURN T))
(T
(PRINC LINE TYO))))
(FILEPOS STREAM 0.)
(DO ((FORM (ERRSET (READ STREAM STREAM) NIL)
(ERRSET (READ STREAM STREAM) NIL))
(VERBOSE SAVE-VERBOSE)
(OLD-FILEPOS 0.)
(EOF (NCONS STREAM)))
((EQUAL FORM EOF) T)
(COND ((NULL FORM)
(LSPSAV$ERROR-IN-FILE STREAM OLD-FILEPOS))
(T
(LET ((EVAL-FORM (ERRSET (EVAL (CAR FORM)) T)))
(COND ((NULL EVAL-FORM)
(TERPRI TYO)
(PRINC '|;Unable to EVAL this form:| TYO)
(LET ((PRINLEVEL 3.) (PRINLENGTH 4.))
(PRINT (CAR FORM) TYO)))
(VERBOSE
(PRINT (CAR EVAL-FORM) TYO))))))
(SETQ OLD-FILEPOS (FILEPOS STREAM)))
(CURSORPOS 'A TYO)
(TERPRI TYO)
(PRINC '|; UNSAVE: Completed reading of "| TYO)
(PRINC FILE TYO)
(PRINC '|"| TYO))
LSPSAV-LOAD-EXIT))
(DEFUN LSPSAV$ERROR-IN-FILE (STREAM WHERE)
(PROG (C)
(TERPRI TYO)
(PRINC '|;Error in file at character | TYO)
(PRINC WHERE TYO)
TOP
(TERPRI TYO)
(PRINC '|;View region? (Y or N)| TYO)
(CLEAR-INPUT TYI)
(SETQ C (TYI TYI))
(COND ((OR (= C 89.) (= C 121.))
(LET ((POS (FILEPOS STREAM))
(OLD-ENDPAGEFN (ENDPAGEFN TYO)))
(UNWIND-PROTECT
(CATCH (PROGN
(TERPRI TYO)
(PRINC '|;Viewing erroneous region...| TYO)
(TERPRI TYO)
(ENDPAGEFN TYO 'LSPSAV$ENDPAGEFN)
(FILEPOS STREAM WHERE)
(DO ((C (TYI STREAM) (TYI STREAM))
(I WHERE (1+ I)))
((= I POS))
(TYO C TYO)))
LSPSAV-ENDPAGEFN-EXIT)
(FILEPOS STREAM POS)
(ENDPAGEFN TYO OLD-ENDPAGEFN))))
((OR (= C 78.) (= C 110.))
(TERPRI TYO)
(PRINC '|;Error not being viewed.| TYO)
(TERPRI TYO))
(T
(GO TOP)))
MIDDLE
(TERPRI TYO)
(PRINC '|;Continue UNSAVE attempt? (Y or N) | TYO)
(CLEAR-INPUT TYI)
(SETQ C (TYI TYI))
(COND ((OR (= C 89.) (= C 121.))
(PRINC '| [Yes]| TYO)
(RETURN T))
((OR (= C 78.) (= C 110.))
(PRINC '| [No]| TYO)
(THROW T LSPSAV-LOAD-EXIT))
(T
(GO MIDDLE)))))
(DEFUN LSPSAV (FILE VARS OPTIONS SYSTEM!)
(PROG (OUTSTREAM)
(COND ((EQ (CADDR FILE) '>)
(SETQ OUTSTREAM (OPEN FILE 'OUT)))
((AND SAVE-PARANOIA (PROBEF FILE))
(TERPRI TYO)
(PRINC '|;File exists.| TYO)
(TERPRI TYO)
(PRINC '|; Type "A" to append,| TYO)
(PRINC '| "C" to clobber, or "Q" to quit. -> | TYO)
((LAMBDA (CHAR)
(COND ((MEMQ CHAR '(A /a))
(PRINC '| [Append]| TYO)
(TERPRI TYO)
(SETQ OUTSTREAM (OPEN FILE 'APPEND)))
((MEMQ CHAR '(C /c))
(PRINC '| [Clobber]| TYO)
(TERPRI TYO)
(SETQ OUTSTREAM (OPEN FILE 'OUT)))
(T
(PRINC '| [Quit]| TYO)
(TERPRI TYO)
(PRINC '|;Save request aborted!| TYO)
(RETURN NIL))))
(ASCII (TYI TYI))))
(T (SETQ OUTSTREAM (OPEN FILE 'OUT))))
(PRINC '|;;; -*- LISP -*-| OUTSTREAM)
(TERPRI OUTSTREAM)
(PRINC '|;;; MacLISP.| OUTSTREAM)
(PRINC (STATUS LISPV) OUTSTREAM)
(PRINC '| Save File.| OUTSTREAM)
(TERPRI OUTSTREAM)
(PRINC '|;;; Saved by | OUTSTREAM)
(PRINC (STATUS UNAME) OUTSTREAM)
(PRINC '| from job | OUTSTREAM)
(PRINC (STATUS JNAME) OUTSTREAM)
(PRINC '| by LSPSAV.| OUTSTREAM)
(PRINC (LSPSAV$VERSION) OUTSTREAM)
(TERPRI OUTSTREAM)
(LET ((BASE 10.)
(*NOPOINT T)
(DOW (EXPLODEN (STATUS DOW)))
((YEAR MONTH DATE) (STATUS DATE))
((HOUR MIN ()) (STATUS DAYTIME)))
(PRINC '|;;; | OUTSTREAM)
(PRINC (COND ((ZEROP (\ HOUR 12.)) '|12|)
(T (\ HOUR 12.)))
OUTSTREAM)
(PRINC '/: OUTSTREAM)
(COND ((< MIN 10.) (PRINC '/0 OUTSTREAM)))
(PRINC MIN OUTSTREAM)
(PRINC (COND ((ZEROP (// HOUR 12.)) '|am |)
(T '|pm |))
OUTSTREAM)
(TYO (CAR DOW) OUTSTREAM)
(MAPC (FUNCTION (LAMBDA (X) (TYO (+ X 32.) OUTSTREAM)))
(CDR DOW))
(PRINC '|, | OUTSTREAM)
(PRINC (CDR (ASSOC MONTH '(( 1. . |January |)
( 2. . |February |)
( 3. . |March |)
( 4. . |April |)
( 5. . |May |)
( 6. . |June |)
( 7. . |July |)
( 8. . |August |)
( 9. . |September |)
(10. . |October |)
(11. . |November |)
(12. . |December |))))
OUTSTREAM)
(PRINC DATE OUTSTREAM)
(PRINC '|, 19| OUTSTREAM)
(PRINC YEAR OUTSTREAM))
(COND (SYSTEM!
(TERPRI OUTSTREAM)
(PRINC '|;;;| OUTSTREAM)
(TERPRI OUTSTREAM)
(PRINC
'|;;; >* WARNING *< Do not load this file into lisp!|
OUTSTREAM)
(TERPRI OUTSTREAM)
(TERPRI OUTSTREAM)
(PRINT
'(ERROR '|Error: SAVE'd with MacLISP reserved words!|)
OUTSTREAM)
(TERPRI OUTSTREAM)))
(TERPRI OUTSTREAM)
(MAPC (FUNCTION
(LAMBDA (OPTION)
(LSPSAV$SAVE OPTION VARS OUTSTREAM)))
OPTIONS)
(COND ((STATUS TTY)
(TERPRI TYO)
(PRINC '|;All info saved as requested in | TYO)
(PRINC (NAMESTRING OUTSTREAM) TYO)
(TERPRI TYO)))
(CLOSE OUTSTREAM)
(RETURN T)))
(DEFUN LSPSAV$SAVE (OPTION VARLIST OUTSTREAM)
(CATCH
(MAPC (FUNCTION
(LAMBDA (VAR)
(CASEQ OPTION
('VAL (LSPSAV$SAVE-VALUE VAR OUTSTREAM))
('EXPR (LSPSAV$SAVE-EXPR VAR OUTSTREAM))
('FEXPR (LSPSAV$SAVE-FEXPR VAR OUTSTREAM))
('MACRO (LSPSAV$SAVE-MACRO VAR OUTSTREAM))
('ARRAY (LSPSAV$SAVE-ARRAY VAR OUTSTREAM))
('PROP (LSPSAV$SAVE-PLIST VAR OUTSTREAM))
(T (CURSORPOS 'A TYO)
(PRINC '|;Specified option not offered: | TYO)
(PRIN1 OPTION)
(TERPRI TYO)
(PRINC '|;This option being ignored.| TYO)
(TERPRI TYO)
(THROW NIL BAD-OPTION)))))
VARLIST)
BAD-OPTION))
(DEFUN LSPSAV$ENDPAGEFN (())
(PROG (C POS)
(SETQ POS (CURSORPOS TYO))
(PRINC '|*** More? | TYO)
(SETQ C (TYI TYI))
(COND ((OR (= C 89.) (= C 121.) (= C 32.))
(CURSORPOS (CAR POS) (CDR POS) TYO)
(CURSORPOS 'L TYO)
(CURSORPOS 0. 0. TYO)
(CURSORPOS 'L TYO)
(RETURN T))
(T
(CURSORPOS (CAR POS) (CDR POS) TYO)
(PRINC '|Flushed| TYO)
(CURSORPOS 'L TYO)
(CURSORPOS 0. 0. TYO)
(THROW NIL LSPSAV-ENDPAGEFN-EXIT)))))
(REMOB '|LSPSAV-`-,-level/||)

11
src/libdoc/save.notes Executable file
View File

@@ -0,0 +1,11 @@
;;; SAVE Package Bugs
;;;
;;; [Source: DR (07/11/80)] Re: UNSAVE vs INCLUDEF
;;; When i loaded ((dsk liblsp)save fasl) , then did (setq save-verbose t)
;;; and then finally (unsave filename), where this filename had
;;; includef's, apparently unsave didn't read in from the "includef"
;;; files, or in any event, all the functions from these files turned out
;;; to be undefined.
;;;
;;; [Source: WGD (1/3/81)]
;;; loses grossly when one tries to save vectors.

249
src/libdoc/set.ira1 Executable file
View File

@@ -0,0 +1,249 @@
(COMMENT SET OPERATIONS -- Ira Goldstein)
;;;This file contains functions for operating on sets.
;;;A given function like UNION comes in several flavors.
;;; UNION takes multiple arguments and uses equal
;;; UNION2 takes 2 arguments and uses equal.
;;; UNIONQ takes multiple arguments and uses eq.
;;; UNIONQ2 takes 2 arguments and uses eq.
;;;The file currently contains the following functions:
;;;Union: (union, unionq, union2, unionq2)
;;;Intersection: (intersect, intersectq, intersect2, intersectq2)
;;;Subtraction: (setminus, setminusq, setminus2, setminusq2)
;;;Other useful set functions that are included are:
;;;(unite e v) sets the value of v (l) to be union of (e) and l
;;;(uniteq e v) similar to unite. Uses eq.
;;;(Unify e l) returns union of (list e) and L.
;;;(unifyq e l) returns unionq of (list e) and L.
;;;(Setify L) returns L with all duplicates (compared using equal) deleted.
;;;(setifyq L) returns L with all duplicates (compared using eq) deleted.
;;;(subset x y) returns t iff x is a subset of y. x atomic treated as unary set.
;;;(subsetq x y) similar to subset but uses eq.
(COMMENT MACRODEF)
;;;macrodef defines macros during compilation. But is equivalent
;;;to DEFUN during interpretation. Simplifies debugging interpretive code.
(DECLARE (MACROS NIL) (FIXNUM N))
(SSTATUS FEATURE SET)
(defun EXPAND macro (qqq)
;;from GLS;MACROS >
(list 'quote
((lambda (www)
(rplaca x (car www))
(rplacd x (cdr www)))
(sublis (mapcar (function
(lambda (hhh)
(cons (car hhh)
(eval (cadr hhh)))))
(cadr qqq))
(caddr qqq)))))
(defun MACRODEF macro (qqq)
;;from GLS;MACROS >
(list 'defun
(cadr qqq)
'macro
'(x)
(list 'expand
(do ((rrr (caddr qqq) (cdr rrr))
(ccc '(cdr x) (list 'cdr ccc))
(lll nil
(cons (list (car rrr)
(list 'car ccc))
lll)))
((atom rrr)
(and rrr
(setq lll
(cons (list rrr ccc) lll)))
(nreverse lll)))
(COND ((CDDDDR QQQ) (CONS 'PROGN (CDDDR QQQ)))
((cadddr qqq))))))
(COMMENT SET RELATED FUNCTIONS)
(DEFUN UNITEQ FEXPR (X)
;;VARIABLE IS THE NAME OF A LIST. E.G. (UNITEQ A X)
;;ELEMENT ADDED TO VALUE OF VARIABLE IF NOT ALREADY PRESENT.
(PROG (ELEMENT VARIABLE)
(SETQ ELEMENT (CAR X) VARIABLE (CADR X))
(RETURN
(COND ((NOT (BOUNDP VARIABLE)) (SET VARIABLE (LIST ELEMENT)))
((SET VARIABLE (UNIFYQ ELEMENT (EVAL VARIABLE))))))))
(DEFUN UNITE FEXPR (X)
;;VARIABLE IS THE NAME OF A LIST.
;;ELEMENT ADDED TO VALUE OF VARIABLE IF NOT ALREADY PRESENT.
(PROG (ELEMENT VARIABLE)
(SETQ ELEMENT (CAR X) VARIABLE (CADR X))
(RETURN
(COND ((NOT (BOUNDP VARIABLE)) (SET VARIABLE (LIST ELEMENT)))
((SET VARIABLE (UNIFY ELEMENT (EVAL VARIABLE))))))))
(DEFUN UNIFYQ (ELEMENT L)
;;L IS A LIST, ELEMENT IS AN ATOM. ELEMENT ADDED TO LIST IF NOT ALREADY PRESENT.
(COND ((NULL L) (LIST ELEMENT))
((MEMQ ELEMENT L))
((CONS ELEMENT L))))
(DEFUN UNIFY (ELEMENT L)
;;L IS A LIST, ELEMENT IS AN ATOM. ELEMENT ADDED TO LIST IF NOT ALREADY PRESENT.
(COND ((NULL L) (LIST ELEMENT))
((MEMBER ELEMENT L))
((CONS ELEMENT L))))
(defun SETIFY (l)
;; returns L with all duplicates (compared using
;; EQUAL) removed. The order is unchanged.
(cond((null l) nil)
(t
(do ((set (list (car l)))
(remainder (cdr l) (cdr remainder)))
((null remainder) (nreverse set))
(cond((not (member (car remainder) set))
(setq set (cons (car remainder) set))))))))
(defun SETIFYQ (l)
;; returns L with all duplicates (compared using
;; EQ) removed. The order is unchanged.
(cond((null l) nil)
(t
(do ((set (list (car l)))
(remainder (cdr l) (cdr remainder)))
((null remainder) (nreverse set))
(cond((not (memq (car remainder) set))
(setq set (cons (car remainder) set))))))))
(DEFUN SUBSETQ (X Y)
;X = ATOM <=> X = (ELEMENT). I.E. ATOM X TREATED AS UNARY SET.
;USES EQ.
(COND ((ATOM X) (MEMQ X Y))
((NULL (SETMINUSQ2 X Y)))))
(DEFUN SUBSET (X Y)
;X = ATOM <=> X = (ELEMENT). I.E. ATOM X TREATED AS UNARY SET.
;USES EQ.
(COND ((ATOM X) (MEMBER X Y))
((NULL (SETMINUS2 X Y)))))
(COMMENT SET SUBTRACTION)
;;THESE MACROS DO NOT DO NREVERSING.
(MACRODEF SETMINUSQ2-M (A B)
;;Result is not nreversed to be in order similar to args for efficiency.
;;since setminus2 is used by setminus and union repeatedly.
(do ((x a (cdr x)) (result))
((null x) result)
(or (memq (car x) b)
(setq result (cons (car x) result)))))
(MACRODEF SETMINUS2-M (A B)
;;Result is not nreversed to be in order similar to args for efficiency.
;;since setminus2 is used by setminus and union repeatedly.
(do ((x a (cdr x)) (result))
((null x) result)
(or (member (car x) b)
(setq result (cons (car x) result)))))
;;(SETMINUS a b) returns all elements of a not in b.
(defun SETMINUSQ2 (A B) (NREVERSE (SETMINUSQ2-M A B)))
(defun SETMINUS2 (A B) (NREVERSE (SETMINUS2-M A B)))
(DEFUN SETMINUS N
(COND ((= N 2) (NREVERSE (SETMINUS2-M (ARG 1) (ARG 2))))
((DO ((I 2 (1+ I)) (L (ARG 1)))
((> I N) (COND ((ODDP N) L) ((NREVERSE L))))
(SETQ L (SETMINUS2-M L (ARG I)))))))
(DEFUN SETMINUSQ N
(COND ((= N 2) (NREVERSE (SETMINUSQ2-M (ARG 1) (ARG 2))))
((DO ((I 2 (1+ I)) (L (ARG 1)))
((> I N) (COND ((ODDP N) L) ((NREVERSE L))))
(SETQ L (SETMINUSQ2-M L (ARG I)))))))
(COMMENT UNION)
;;UNION2 AND UNIONQ2 takes the union of exactly two sets.
;;Most efficient if the first is the smallest.
(DEFUN UNIONQ2 (A B)
(APPEND A (NREVERSE (SETMINUSQ2-M B A))))
(DEFUN UNION2 (A B)
(APPEND A (NREVERSE (SETMINUS2-M B A))))
;;UNION takes the union of any number of sets.
(DEFUN UNION N
;;COPY DONE TO ALLOW NCONC, WITHOUT EFFECT ON ARGS.
(COND ((= N 2) (UNION2 (ARG 1) (ARG 2)))
((DO ((I 2 (1+ I)) (RESULT (SUBST NIL NIL (ARG 1))))
((> I N) RESULT)
(SETQ RESULT (NCONC RESULT (NREVERSE (SETMINUS2-M (ARG I) RESULT))))))))
(DEFUN UNIONQ N
(COND ((= N 2) (UNIONQ2 (ARG 1) (ARG 2)))
((DO ((I 2 (1+ I)) (RESULT (ARG 1)))
((> I N) RESULT)
(SETQ RESULT (NCONC RESULT (NREVERSE (SETMINUSQ2-M (ARG I) RESULT))))))))
(COMMENT INTERSECTION)
;;;These macros are for internal efficiency to avoid repeated nreversing.
;;;They do not appear in the fasl file.
(macrodef intersectQ2-m (a b)
(do ((x a (cdr x)) (result))
((null x) result)
(and (memq (car x) b)
(setq result (cons (car x) result)))))
(macrodef intersect2-m (a b)
(do ((x a (cdr x)) (result))
((null x) result)
(and (member (car x) b)
(setq result (cons (car x) result)))))
;;;intersectQ2 and intersect2 takes the intersection of exactly two sets.
;;;The first should be the smaller, for efficiency.
(defun intersectQ2 (a b) (nreverse (intersectq2-m a b)))
(defun intersect2 (a b) (nreverse (intersect2-m a b)))
;; INTERSECT takes the intersection of n sets of atoms.
(DEFUN INTERSECT N
;;IF N ODD, REVERSING CANCEL AND NO FINAL NREVERSE IS NECESSARY.
(COND ((= N 2) (NREVERSE (INTERSECT2-M (ARG 1) (ARG 2))))
((DO ((I 2 (1+ I)) (RESULT (ARG 1)))
((> I N) (COND ((ODDP N) RESULT) ((NREVERSE RESULT))))
(SETQ RESULT (INTERSECT2-M RESULT (ARG I)))))))
(DEFUN INTERSECTQ N
(COND ((= N 2) (NREVERSE (INTERSECTQ2-M (ARG 1) (ARG 2))))
((DO ((I 2 (1+ I)) (RESULT (ARG 1)))
((> I N) (COND ((ODDP N) RESULT) ((NREVERSE RESULT))))
(SETQ RESULT (INTERSECTQ2-M RESULT (ARG I)))))))

251
src/libdoc/sets.pratt2 Executable file
View File

@@ -0,0 +1,251 @@
;;; --------------------SET PACKAGE-----------------------
;;; V.R.Pratt. Nov. 24, 1978
;;; Revised Dec. 15, 1979
;;; The following operations are provided for manipulating finite
;;; sets of arbitrary objects represented as bit vectors.
;;; The package keeps track
;;; of a universe U of objects, which are added to as needed by GATHER.
;;; GATHER considers objects distinct just when EQUAL, rather than EQ,
;;; pronounces them so. M denotes objects, A,B,... sets.
;;; (UNION A1 ... An) union of A1 ... An
;;; (INTERSECT A1 ... An) intersection of A1 ... An
;;; (GATHER M1 ... Mn) {M1,...,Mn}
;;; (SETDIFF A1 ... An) n=0: U. n=1: U-A. n>1: A1-A2-...-An.
;;; (SYMDIFF A1 ... An) elements occurring an odd number of times
;;; (ELEMENTS A) list of elements of A, in order first met
;;; (ELEMENTOF A) some element of A
;;; (CARDINAL A) number of elements of A
;;; (ELEMENTP M A) tests whether M is an element of A
;;; (SUBSETP A B) tests whether A is a subset of B
;;; The following are not essential, but the user may find them handy on
;;; occasion.
;;; Examples of use
;;; (GATHER 'XY 55 '(A B)) forms the set {XY,55,(A B)}
;;; (UNION (GATHER 'XY 55) (GATHER 55 '(A B))) ditto
;;; (ELEMENTS (GATHER 'XY 55 '(A B))) forms the list (XY 55 (A B))
;;; (SUBSETP X (UNION X Y)) is always T (assuming X bound)
;;; (ELEMENTP A (GATHER A)) is always T (assuming A bound)
;;; (CARDINAL (GATHER 'XY '(A B))) will be 2
;;; As PRINT will not distinguish between sets and integers, and MAPCAR will
;;; not know how to enumerate set elements, the function ELEMENTS is provided
;;; to convert a set to a list of its elements.
;;; The constant EMPTY may be expressed as 0, or as (GATHER) if you need to
;;; hint that it is of type SET, (CADDDR UNIVERSE) returns the present
;;; universe (everthing that has been GATHERed), SETDIFF will serve as
;;; COMPLEMENT, ZEROP will serve as the predicate EMPTYP.
;;; CGOL users have access to these routines automatically. The syntax is
;;; {a1,...,an} (GATHER A1 ... An)
;;; a1a2..an (UNION A1 ... An)
;;; a1a2..an (INTERSECT A1 ... An)
;;; a1~a2~...~an (SETDIFF A1 A2 ... An)
;;; na (ELEMENTP N A)
;;; ab (SUBSETP A B)
;;; In addition f{a} (which is (APPLY 'F A)) will have the appropriate effect
;;; for f being any of gather,union,intersect. Needless to say, f[a1,...,an]
;;; (which is (MAPCAR 'F A1 ... An) ) works correctly with all of the above.
;;; For efficiency, these routines, with the exception of GATHER and ELEMENTS,
;;; far outclass anything possible with methods based on representing sets
;;; as lists, by a factor of hundreds if not thousands. In the case of
;;; GATHER, there is an overhead associated with the first time a pointer
;;; is encountered, dominated by the cost of doing an SXHASH on the object
;;; pointed to by that pointer. While pathological cases could give rise to
;;; n**2 behavior, one can expect in general that the overhead from GATHER
;;; will not dominate. ELEMENTS is not unduly slow, but it has to be done
;;; to get back your elements, unlike a method based on lists, where there
;;; is zero overhead here.
;;; Once a universe has been GATHERed up, the order of gathering will be that
;;; in which elements of sets are listed by ELEMENTS. Thus to sort a list L
;;; all of whose elements are already in the universe, do
;;; (ELEMENTS (APPLY 'GATHER L)). Repetitions will be eliminated. If L
;;; contains elements not yet in the universe, they will retain the order
;;; they had in L, and appear after all other elements of L.
;;; The functions fall into two classes: internal and external. The internal
;;; functions deal only with bit vectors, for which LISP's unbounded-size
;;; integers are used (bignums, which are lists of 35-bit words, sign unused).
;;; Union is implemented as bitwise or, intersect as and, cardinal as
;;; bit-counting, subsetp as (zerop (bboole 4 x y)), etc. The external
;;; functions in effect Goedelize external objects to yield an internal
;;; representation. The Goedelization is defined by GATHER, which tries to
;;; work out whether it has Goedelized its arguments before. It does this
;;; through the obarray. For symbols it just uses the OBNUM property of the
;;; symbol, which yields a number giving the bit position for this object. For
;;; fixnums it first converts the fixnum to a symbol by doing (implode (explode
;;; n)) (somewhat slow - this takes 3 millisecs on AI). For lists (including
;;; bignums) it first converts the pointer to a fixnum using MAKNUM, which
;;; reduces the problem to that of fixnums. However, this by itself would only
;;; give EQ and we want EQUAL. Thus if it has not seen the pointer before it
;;; then does an SXHASH on the object pointed to by the pointer, symbolizes the
;;; result as above, and looks it up. The result is a list ("bucket") of
;;; objects with SXHASHes that give the same bucket, paired with their internal
;;; number. It does an ASSOC to extract that number. When this fails, it
;;; allocates a new number (new bit position) to the object.
;;; The external functions are GATHER, ELEMENTP, ELEMENTS, and ELEMENTOF.
;;; If demand warrants it, I may do something about speeding up the external
;;; functions, which take several milliseconds. (Note that CONS costs
;;; something like a millisecond once you've charged it for its share of
;;; garbage collection.) My present application for the package is
;;; compute-bound, involving only light use of external functions.
;;; **********************SETS PACKAGE**********************
(DECLARE '(MUZZLED T)
(FIXNUM I N X Y Z ARGNO))
(DEFUN UNION ARGNO
(DO ((I 1 (ADD1 I)) (AC 0))
((GREATERP I ARGNO) AC)
(SETQ AC (BOR AC (ARG I)))))
(DEFUN INTERSECT ARGNO
(DO ((I 1 (ADD1 I)) (AC (CADDDR UNIVERSE)))
((GREATERP I ARGNO) AC)
(SETQ AC (BAND AC (ARG I)))))
(DEFUN GATHER ARGNO
(DO ((I 1 (ADD1 I)) (AC 0))
((GREATERP I ARGNO) AC)
(SETQ AC (BOR AC (EXPT 2 (OBNUM (ARG I)))))))
(DEFUN SETDIFF ARGNO
(COND ((ZEROP ARGNO) (CADDDR UNIVERSE))
((EQUAL ARGNO 1) (DIFFERENCE (CADDDR UNIVERSE) (ARG 1)))
((DO ((I 2 (ADD1 I)) (AC (ARG 1)))
((GREATERP I ARGNO) AC)
(SETQ AC (BDIFF AC (ARG I)))))))
(DEFUN SYMDIFF ARGNO
(DO ((I 1 (ADD1 I)) (AC 0))
((GREATERP I ARGNO) AC)
(SETQ AC (BSYMDIFF AC (ARG I)))))
(DEFUN ELEMENTS (A) ;; Make a list of the elements in A
(COND ((NOT (LESSP -1 A (ADD1 (CADDDR UNIVERSE)))) '|Error in Elements|)
((BIGP A) (LELEMENTS (CDR A) 0))
((FELEMENTS A 0))))
(DEFUN LELEMENTS (L N) ;; Auxiliary function for Elements, assumes bignum list
(AND L (APPEND (FELEMENTS (CAR L) N) (LELEMENTS (CDR L) (PLUS N 35.)))))
(DEFUN FELEMENTS (X N) ;; Auxiliary function for Elements, assumes fixnum
(COND ((ZEROP X) NIL)
((ODDP X) (CONS (FUNCALL (CAR UNIVERSE) N)
(FELEMENTS (LSH X -1) (ADD1 N))))
((FELEMENTS (LSH X -1) (ADD1 N)))))
(DEFUN ELEMENTOF (A)
(COND ((PLUSP A) (FUNCALL (CAR UNIVERSE) (SUB1 (HAULONG A))))))
(DEFUN CARDINAL (A)
(COND ((BIGP A) (APPLY 'PLUS (MAPCAR 'FCARDINAL (CDR A))))
((FCARDINAL A))))
(DEFUN FCARDINAL (X)
(COND ((ZEROP X) 0)
((ODDP X) (ADD1 (FCARDINAL (LSH X -1))))
((FCARDINAL (LSH X -1)))))
(DEFUN FNORM MACRO (FORM)
((LAMBDA (X)
`(COND ((NOT (BIGP ,X)) (LIST ,X))
((CDR ,X))))
(CADR FORM)))
(DEFUN BOR (A B) (CONSBIGNUMBER (BFOR (FNORM A) (FNORM B))))
(DEFUN BFOR (A B)
(COND ((NULL A) B)
((NULL B) A)
((CONS (BOOLE 7 (CAR A) (CAR B)) (BFOR (CDR A) (CDR B))))))
(DEFUN BAND (A B) (CONSBIGNUMBER (BFAND (FNORM A) (FNORM B))))
(DEFUN BFAND (A B)
(AND A B (CONS (BOOLE 1 (CAR A) (CAR B)) (BFAND (CDR A) (CDR B)))))
(DEFUN BDIFF (A B) (CONSBIGNUMBER (BFDIFF (FNORM A) (FNORM B))))
(DEFUN BFDIFF (A B)
(AND A (CONS (BOOLE 4 (CAR A) (CAR B)) (BFDIFF (CDR A) (CDR B)))))
(DEFUN BSYMDIFF (A B) (CONSBIGNUMBER (BFSYMDIFF (FNORM A) (FNORM B))))
(DEFUN BFSYMDIFF (A B)
(COND ((NULL A) B)
((NULL B) A)
((CONS (BOOLE 6 (CAR A) (CAR B)) (BFSYMDIFF (CDR A) (CDR B))))))
(DEFUN BELEMENTP (N L)
;;; TEST IF THE N'TH BIT IS ON IN THE LIST OF FIXNUMS L.
(COND ((NULL L) NIL)
;;; IF BIT IS IN CURRENT WORD, CHECK IT.
((< N 35.) (ODDP (LSH (CAR L) (MINUS N))))
;;; OTHERWISE, TRY NEXT WORD.
((BELEMENTP (- N 35.) (CDR L)))))
(DEFUN ELEMENTP (A L)
((LAMBDA (N)
(COND ((NULL N) NIL)
;;; If L a bignum, run down list of fixnums.
((BIGP L) (BELEMENTP N (CDR L)))
;;; Check if bit on in shifted fixnum.
((ODDP (LSH L (MINUS N))))))
(OLDOBNUM A)))
(DEFUN SUBSETP (A B) (ZEROP (BDIFF A B)))
(DEFUN CONSBIGNUMBER (A)
(COND ((ATOM A) A) ((NULL (CDR A)) (CAR A)) ((CONSBIGNUM A))))
(VALRET '// :VP/ ) ;;; GET SYMBOLS FROM DDT.
(LAP CONSBIGNUM SUBR)
(JRST 0 BNCONS)
NIL
(DECLARE (SPECIAL AW ASX)) ;;; Communicates between OBNUM, OLDOBNUM
(DEFUN OBNUM (W)
;;; Converts object to a small numeric identifier for that object
(OR (OLDOBNUM W) ;;; If already in universe, use it
((LAMBDA (N) ;;; Otherwise add to universe
(STORE (FUNCALL (CAR UNIVERSE) N) W)
(STORE (FUNCALL (CADR UNIVERSE) AW)
(CONS (CONS W N) (FUNCALL (CADR UNIVERSE) AW)))
N)
(NEWNUM))))
(DEFUN OLDOBNUM (W)
;;; Like OBNUM, but returns NIL if W is not in universe
(SETQ AW (REMAINDER (ABS (SXHASH W)) 100.))
(CDR (ASSOC W (FUNCALL (CADR UNIVERSE) AW))))
(DEFUN NEWNUM ()
(PROG (CARD)
(RPLACD (CDR UNIVERSE)
(LIST (SETQ CARD (ADD1 (CADDR UNIVERSE)))
(ADD1 (TIMES 2 (CADDDR UNIVERSE)))))
(COND ((NOT (GREATERP (CADR (ARRAYDIMS (CAR UNIVERSE))) CARD))
(*REARRAY (CAR UNIVERSE) T (PLUS CARD 199.))))
(RETURN (SUB1 CARD))))
(DEFUN GENUNIVERSE () ;; Generates a new (empty) universe
(LIST (ARRAY NIL T 100.) (ARRAY NIL T 100.) 0 0))
(SETQ UNIVERSE (GENUNIVERSE)) (SETQ CAR T CDR T)

136
src/libdoc/share.jonl10 Executable file
View File

@@ -0,0 +1,136 @@
;;; This file was originally written by JONL and SUN on 9/15/1976.
;;;
;;; This file contains some functions for sharing pure pages
;;; of fasl code among a number of dumps. Its use is for occasions
;;; where a number of people will be using one basic system but
;;; where each may have a dumped copy of his or her own. By suspending
;;; and waking up the jobs correctly it is possible to share
;;; the pages even though a few :PDUMPS have been done. It is also
;;; useful where one makes a bunch of systems by adding on some files,
;;; dumping them out, adding some more, etc.
;;;
;;; The way the code works is that one runs functions to save
;;; the pointer in binary program space before fasload, after fasloading
;;; and by noting what the name of the dump will be. These three things
;;; are then pushed onto a list. Thus the list will contain a list
;;; of all the files that have been dumped out and the appropriate
;;; locations of code within each of these dumps.
;;;
;;; When the dump is awakened, one runs a program that maps down
;;; the list and reads in and shares those appropriate pages
;;; from each of the dumps.
;;;
;;; So this is the type of thing one does:
;;; (MAKE-READY-TO-FASLOAD)
;;; (FASLOAD FOO FASL)
;;; .
;;; .
;;; .
;;; (FASLOAD BAR FASL)
;;; (MAKE-READY-TO-DUMP '((DSK LOSER) TS FOO))
;;; (SUSPEND '|:PDUMP TS FOO/
;;; |)
;;; (COMMUNIZE)
;;;
;;; There is also a function called, *SUSPEND, which does
;;; a SUSPEND and then a COMMUNIZE. This is for use when
;;; one is quickly dumping out something and then want to
;;; re-communize when one restarts.
;;;
;;; Dumping out to non unique names like TS FOO can
;;; cause problems since a dump will think that TS FOO is
;;; something that has actually been deleted. Therefore it
;;; is recommended that one dump out to FOO 1, etc.. To do
;;; this simply find out what FOO's are out there and dump
;;; to a version greater than the one there. The important
;;; thing is that your dumps will know the true names
;;; of their sibling dumps.
(DECLARE (NEWIO T)
(SPECIAL *DUMP-SHARE-LIST* *INITIAL-BPORG* *PAGSIZ*)
;; ***NOTE THE FOLLOWING BASE CHANGE***
(SETQ BASE 8. IBASE 8.))
(DECLARE (EVAL (READ)))
(SETQ OLD-BASE BASE BASE 8. OLD-IBASE IBASE IBASE 8.)
(COND ((NOT (BOUNDP '*DUMP-SHARE-LIST*))
(SETQ *DUMP-SHARE-LIST* NIL)))
(SETQ *PAGSIZ* 1024.)
(DEFUN MAKE-READY-TO-FASLOAD NIL
;; This function is run before fasloading and simply
;; saves the initial bporg.
(SETQ *INITIAL-BPORG* (PAGEBPORG)))
(DEFUN MAKE-READY-TO-DUMP (FILE)
;; This function is run prior to dumping and saves
;; the final bporg and the name to be of the dump.
;; The three items are consed together and pushed
;; on the list.
(PROG
(HIGHPOINT)
(COND
((=
*INITIAL-BPORG*
(SETQ HIGHPOINT (PAGEBPORG)))
(RETURN NIL)))
(PURIFY *INITIAL-BPORG* (1- HIGHPOINT) T)
(SETQ
*DUMP-SHARE-LIST*
(CONS
(LIST FILE *INITIAL-BPORG* (1- HIGHPOINT))
*DUMP-SHARE-LIST*))))
(DEFUN COMMUNIZE NIL
;; This function is run upon wake up of the dump. It maps
;; down the list and loads appropriate sections from
;; each of the shared dumps.
(PROG (FILE LO C PN CNT I X)
(SETQ X *DUMP-SHARE-LIST*) ;(...((FN1 FN2 DSK USR) 126000 131777)...)
S (COND
((NOT (PROBEF (CAAR X)))
(TERPRI)
(PRINC '|;; The file |)
(PRIN1 (CAAR X))
(PRINC
'| is not there. Those pages will not be shared.|)
(GO NEXT)))
(SETQ C (OPEN (CAAR X) '(BLOCK IN FIXNUM))
LO (BOOLE 4 (CADAR X) (1- *PAGSIZ*))
PN (// LO *PAGSIZ*))
(OR (ZEROP (IN C)) (BREAK LOSING-FILE)) ;LOOK FOR A :PDUMP FILE
(SETQ CNT -1 I 0)
LOOP (COND ((> I PN) (FILEPOS C (* *PAGSIZ* (1+ CNT)))) ;GO TO PLACE FOR PAGE NUMBER PN IN THIS JOB
(T (AND (NOT (ZEROP (BOOLE 1 600000 (IN C)))) ;NOT COUNTING IN NON-EXISTENT PAGES
(SETQ CNT (1+ CNT)))
(SETQ I (1+ I))
(GO LOOP)))
(SETQ PN (BOOLE 7 ;CONVERT TO AOBJN PTR
(LSH (// (- LO -1 *PAGSIZ* (CADDAR X)) *PAGSIZ*) 18.)
PN))
(SYSCALL 0 'CORBLK 200000 -1 PN C)
(CLOSE C)
NEXT (AND (NULL (SETQ X (CDR X))) (RETURN NIL))
(GO S)))
(DECLARE (EVAL (READ)))
(SETQ BASE OLD-BASE IBASE OLD-IBASE)
(DEFUN *SUSPEND NARGS
;; This function is just a convenient way of suspending
;; so that when the dump wakes up, it will share its pages.
(COND
((= NARGS 0.) (SUSPEND))
(T (SUSPEND (ARG 1.))))
(COMMUNIZE))

138
src/libdoc/share.jonl11 Normal file
View File

@@ -0,0 +1,138 @@
;;; This file was originally written by JONL and SUN on 9/15/1976.
;;;
;;; This file contains some functions for sharing pure pages
;;; of fasl code among a number of dumps. Its use is for occasions
;;; where a number of people will be using one basic system but
;;; where each may have a dumped copy of his or her own. By suspending
;;; and waking up the jobs correctly it is possible to share
;;; the pages even though a few :PDUMPS have been done. It is also
;;; useful where one makes a bunch of systems by adding on some files,
;;; dumping them out, adding some more, etc.
;;;
;;; The way the code works is that one runs functions to save
;;; the pointer in binary program space before fasload, after fasloading
;;; and by noting what the name of the dump will be. These three things
;;; are then pushed onto a list. Thus the list will contain a list
;;; of all the files that have been dumped out and the appropriate
;;; locations of code within each of these dumps.
;;;
;;; When the dump is awakened, one runs a program that maps down
;;; the list and reads in and shares those appropriate pages
;;; from each of the dumps.
;;;
;;; So this is the type of thing one does:
;;; (MAKE-READY-TO-FASLOAD)
;;; (FASLOAD FOO FASL)
;;; .
;;; .
;;; .
;;; (FASLOAD BAR FASL)
;;; (MAKE-READY-TO-DUMP '((DSK LOSER) TS FOO))
;;; (SUSPEND '|:PDUMP TS FOO/
;;; |)
;;; (COMMUNIZE)
;;;
;;; There is also a function called, *SUSPEND, which does
;;; a SUSPEND and then a COMMUNIZE. This is for use when
;;; one is quickly dumping out something and then want to
;;; re-communize when one restarts.
;;;
;;; Dumping out to non unique names like TS FOO can
;;; cause problems since a dump will think that TS FOO is
;;; something that has actually been deleted. Therefore it
;;; is recommended that one dump out to FOO 1, etc.. To do
;;; this simply find out what FOO's are out there and dump
;;; to a version greater than the one there. The important
;;; thing is that your dumps will know the true names
;;; of their sibling dumps.
(DECLARE
;;; ejs: commented out since no longer compiles
;;;(NEWIO T)
(SPECIAL *DUMP-SHARE-LIST* *INITIAL-BPORG* *PAGSIZ*)
;; ***NOTE THE FOLLOWING BASE CHANGE***
(SETQ BASE 8. IBASE 8.))
(DECLARE (EVAL (READ)))
(SETQ OLD-BASE BASE BASE 8. OLD-IBASE IBASE IBASE 8.)
(COND ((NOT (BOUNDP '*DUMP-SHARE-LIST*))
(SETQ *DUMP-SHARE-LIST* NIL)))
(SETQ *PAGSIZ* 1024.)
(DEFUN MAKE-READY-TO-FASLOAD NIL
;; This function is run before fasloading and simply
;; saves the initial bporg.
(SETQ *INITIAL-BPORG* (PAGEBPORG)))
(DEFUN MAKE-READY-TO-DUMP (FILE)
;; This function is run prior to dumping and saves
;; the final bporg and the name to be of the dump.
;; The three items are consed together and pushed
;; on the list.
(PROG
(HIGHPOINT)
(COND
((=
*INITIAL-BPORG*
(SETQ HIGHPOINT (PAGEBPORG)))
(RETURN NIL)))
(PURIFY *INITIAL-BPORG* (1- HIGHPOINT) T)
(SETQ
*DUMP-SHARE-LIST*
(CONS
(LIST FILE *INITIAL-BPORG* (1- HIGHPOINT))
*DUMP-SHARE-LIST*))))
(DEFUN COMMUNIZE NIL
;; This function is run upon wake up of the dump. It maps
;; down the list and loads appropriate sections from
;; each of the shared dumps.
(PROG (FILE LO C PN CNT I X)
(SETQ X *DUMP-SHARE-LIST*) ;(...((FN1 FN2 DSK USR) 126000 131777)...)
S (COND
((NOT (PROBEF (CAAR X)))
(TERPRI)
(PRINC '|;; The file |)
(PRIN1 (CAAR X))
(PRINC
'| is not there. Those pages will not be shared.|)
(GO NEXT)))
(SETQ C (OPEN (CAAR X) '(BLOCK IN FIXNUM))
LO (BOOLE 4 (CADAR X) (1- *PAGSIZ*))
PN (// LO *PAGSIZ*))
(OR (ZEROP (IN C)) (BREAK LOSING-FILE)) ;LOOK FOR A :PDUMP FILE
(SETQ CNT -1 I 0)
LOOP (COND ((> I PN) (FILEPOS C (* *PAGSIZ* (1+ CNT)))) ;GO TO PLACE FOR PAGE NUMBER PN IN THIS JOB
(T (AND (NOT (ZEROP (BOOLE 1 600000 (IN C)))) ;NOT COUNTING IN NON-EXISTENT PAGES
(SETQ CNT (1+ CNT)))
(SETQ I (1+ I))
(GO LOOP)))
(SETQ PN (BOOLE 7 ;CONVERT TO AOBJN PTR
(LSH (// (- LO -1 *PAGSIZ* (CADDAR X)) *PAGSIZ*) 18.)
PN))
(SYSCALL 0 'CORBLK 200000 -1 PN C)
(CLOSE C)
NEXT (AND (NULL (SETQ X (CDR X))) (RETURN NIL))
(GO S)))
(DECLARE (EVAL (READ)))
(SETQ BASE OLD-BASE IBASE OLD-IBASE)
(DEFUN *SUSPEND NARGS
;; This function is just a convenient way of suspending
;; so that when the dump wakes up, it will share its pages.
(COND
((= NARGS 0.) (SUSPEND))
(T (SUSPEND (ARG 1.))))
(COMMUNIZE))

28
src/libdoc/sixbit.kmp2 Executable file
View File

@@ -0,0 +1,28 @@
;;; -*- Mode:Lisp; IBase:10.; -*-
;;;
;;; SIXBIT: A package for dealing with sixbit.
;;;
;;; This library was created by KMP, 22 Oct 81
;;;
;;; (SYMBOL->SIXBIT sym) Returns the sixbit for the first 6 characters in sym,
;;; which must be a symbol.
;;;
;;; (SIXBIT->SYMBOL num) Returns the interned symbol whose printname is described
;;; by the sixbit quantity num, which must be a fixnum.
(DEFUN SYMBOL->SIXBIT (SYM)
(IF (NOT (SYMBOLP SYM))
(SYMBOL->SIXBIT (ERROR "Arg to SYMBOL->SIXBIT must be a symbol" SYM))
(CAR (PNGET SYM 6.))))
(DEFUN SIXBIT->SYMBOL (NUMBER)
(IF (NOT (FIXNUMP NUMBER))
(SIXBIT->SYMBOL (ERROR "Arg to SIXBIT->SYMBOL must be a fixnum" NUMBER))
(DO ((N NUMBER (LSH N -6))
(I 0 (1+ I))
(L NIL (LET ((CHAR (LOGAND N #O77)))
(IF (ZEROP CHAR)
(IF L (CONS #\SPACE L))
(CONS (+ CHAR #\SPACE) L)))))
((= I 6.) (IMPLODE L)))))

93
src/libdoc/split.rich8 Executable file
View File

@@ -0,0 +1,93 @@
;;;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
;;;
;;; PACKAGE TO SET UP SPLIT SCREEN IN NEWIO
;;;
;;;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
;;; written by Charles Rich, RICH@AI June 4, 1976
;;;
(declare (special top-tty bottom-tty tyo tyi)
(fixnum i pagel))
;; TOP-TTY holds tty object for top half of screen
;; or NIL if screen not split
;;
;; BOTTOM-TTY holds tty object for bottom half of screen
;;
;; (SPLITSCREEN <number>) splits the screen with <number> lines on bottom
;; if screen already split, readjusts boundary so
;; <number> of lines on bottom.
;;
;; (SPLITSCREEN nil) or (SPLITSCREEN 0) returns to full screen
;;
;; note: ctl-K is enabled to clear the top half of screen, unless
;; it is has been set by user previously
(setq top-tty nil bottom-tty tyo)
(defun SPLITSCREEN (nlines)
;; split screen with nlines on bottom echo tty
;; or if NLINES = NIL or 0 go back to full screen
;; returns NLINES
(cond ((and (fixp nlines)(not (zerop nlines)))
(cond ((null top-tty)
;; top screen not currently open
(setq top-tty (open '((tty)) '(tty out)))
;; preserve endpagefn for bottom
(endpagefn bottom-tty
(prog2 nil
(endpagefn bottom-tty)
(setq bottom-tty (open bottom-tty '(tty out echo)))))
(sstatus ttycons tyi bottom-tty)
;; enable ctl-K to clear top half, unless already used
(or (status ttyint 11.)
(sstatus ttyint 11. 'clear-top-tty))))
(syscall 0 'scml bottom-tty nlines)
(pagel top-tty (- (car (status ttysize bottom-tty)) nlines)))
((null top-tty)) ;already full screen
(t ;nlines nil or 0 => make fullscreen
(close top-tty)
(setq top-tty nil)
;; preserve endpagefn for bottom
(endpagefn bottom-tty
(prog2 nil
(endpagefn bottom-tty)
(setq bottom-tty (open bottom-tty '(tty out)))))
(sstatus ttycons tyi bottom-tty)
(syscall 0 'scml bottom-tty 0)))
nlines)
(defun CLEAR-TOP-TTY (tty char)
;; used to clear top of screen line by line
(cond (top-tty (cursorpos 'top top-tty)
(do ((i 0 (1+ i)) (pagel (pagel top-tty)))
((equal i pagel) (cursorpos 'top top-tty))
(cursorpos 'l top-tty)
(cursorpos 'd top-tty)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Unwindable Splitscreen
;;; by BYRONL@ML (13 November 1979)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;SPLIOTA, patterned after IOTA, sets up an environment in which
;;; the screen is split, and then returns to the previous
;;; environment on exit. Thus, the SPLITness property of the
;;; screen can be "lambda bound" (and unbound).
;;;
;;;e.g. (spliota n (print 'foo top-tty) (print 'bar bottom-tty))
;;; will split the screen with n lines on the bottom, print 'foo on
;;; the top-tty and 'bar on the bottom-tty, and exit with the screen
;;; unsplit, assuming the screen was unsplit on entry. If the screen
;;; was already split on entry, SPLIOTA will return it to that state
;;; on exit.
;;;
(defmacro SPLIOTA (nlines . body)
`(let ((old-nlines (and top-tty
(- (status ttysize bottom-tty) (pagel top-tty)))))
(unwind-protect
(progn (splitscreen ,nlines) ,@body)
(splitscreen old-nlines))))

251
src/libdoc/stack.gsb3 Executable file
View File

@@ -0,0 +1,251 @@
; Monday April 28,1980 7:09 FQ+6D.2H.56M.40S. -*- Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STACK DEBUGGING TOOLS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Robert V. Baron (RVB@ML)
;;; NE43-316 x3-3539
;;; Last modified by GSB - should work without conditionalization
;;; in Multics lisp, having lowercasified the code.
;;; If you modify this, please use LOWERCASE!
;;; These routines are for crawling around in the LISP stack. For
;;;any meaningful stack information to be available *RSET must be set to
;;;T. Further, only minimal information will be present for compiled
;;;calls unless NOUUO is T. This package takes up 376. decimal words.
;;; The variable *FRAME*-*POINTER* (hereafter called the CURSOR) is
;;;always bound to a "stack frame 4-tuple". Each tuple is the value of
;;;an EVALFRAME function call. All the functions described below,
;;;unless otherwise noted, have as their value the current CURSOR.
;;; The CURSOR is either of the form:
;;; (EVAL <pdl-ptr> <form> <spec-pdl-ptr>) or
;;; (APPLY <pdl-ptr> (<operator> <arglist>) <spec-pdl-ptr>)
;;;The first atom is a keyword identifier indicating the format of the
;;;third entry. EVAL means that the form is an entity that is being
;;;EVAL'ed and the user could EVAL to see the effect. APPLY means that
;;;the third element is the list of the operator and its argument list.
;;;The argument list has been evaluated and is ready for the operator to
;;;be APPLY'ed to it. The user can do the latter by hand to see the
;;;effect.
;;; The <pdl-ptr> and <spec-pdl-ptr> print as FIXNUM's. They are
;;;pointers that are meaningful for EVALFRAME, FRETURN, EVAL, APPLY and
;;;a few other commands. The reader is refered to the MACLISP manual
;;;for a more detailed discussion.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; COMMANDS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;TOP (no args)
;;; Set the CURSOR to the "top" of the stack. The "top" is closest
;;;to the break. Like a plant the growing point of a stack is at its
;;;top.
;;;BOT (no args)
;;; Set the CURSOR to the "bottom" of the stack. The "bottom" is
;;;the frame of the last call from "command line".
;;;UP (fexpr)
;;; Move the CURSOR another frame towards the top.
;;; Falling off the top of the stack causes an error message to be
;;;printed. The CURSOR is not changed. (Thus the value of UP will be
;;;EQ to its previous value).
;;;DN (fexpr)
;;; Move the CURSOR another frame towards the bottom.
;;; Falling off the bottom of the stack causes an error message to
;;;be printed. The CURSOR is not changed. (Thus the value of DN will
;;;be EQ to its previous value).
;;;both UP and DN
;;;take the following arguments:
;;; <some number> do the operation that many times
;;; <some function> go to the frame where that function was invoked
;;; the letter F move the CURSOR until the first user function
;;; call is encountered
;;; the letter I move the CURSOR until the first non-compiled
;;; user function call is encountered
;;; the letter C move the CURSOR until the first compiled user
;;; function call is encountered
;;; the letter M move the CURSOR until the first user macro call
;;;FR (lexpr)
;;; Given no argument, its value is simply the CURSOR.
;;; Given an argument, it will reset the CURSOR to the argument.
;;;FM (no args)
;;; Return only the FORM of the stack frame. This is the third
;;;element of the CURSOR structure.
;;;RET (lexpr)
;;; no arg - reexecute the form at the cursor and unwind the stack
;;; Only this type execution of RET evaluates in the
;;; original (CURSOR) lambda variable binding environment
;;; one arg - return the arg in place of computing the value of the
;;; form at the CURSOR.
;;; two arg - as above, but use (arg 2) in place of the CURSOR.
;;;EV (lexpr)
;;; one arg - evaluate the arg in the binding environment of the
;;; CURSOR frame.
;;; two arg - as above, but use (arg 2) in place of the CURSOR.
;;;EVQ (fexpr)
;;; The evalquote version of the above function.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; HINTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; When the CURSOR 4-tuple is of the EVAL type (the first element
;;;of the tuple is EVAL), the form component is EQ to the piece of code
;;;that is in the actual function being executed. Thus RPLAC operators
;;;on this form wil make patches to the function.
;;; RET is most useful to return the correct value for some
;;;evaluation sequence that has gone amuck and proceed with the overall
;;;processing. It eliminates the necessity of starting again from the
;;;beginning because of some "simple" bug.
;;; To evaluate a number of variables and forms in some frame
;;;context it is often easier to do a (EVQ (BREAK FOO)) rather than
;;;repetitive EVQ's. The former expression places a BREAK "at an
;;;earlier place in the evaluation". Obviously this BREAK should be
;;;$P'ed, when it is no longer needed.
(declare (genprefix stack-crawl)
(special *frame*-*pointer*)
(*fexpr dn up retb evq)
(*lexpr ret ev))
(defun top ()
((lambda (*rset)
(setq *frame*-*pointer*
(evalframe (cadr (evalframe nil)))))
nil))
(defun bot ()
((lambda (*rset)
(setq *frame*-*pointer* (evalframe 0)))
nil))
(defun fr lexpr
(cond ((= lexpr 0) *frame*-*pointer*)
(t (setq *frame*-*pointer* (arg 1)))))
(defun fm ()
(caddr *frame*-*pointer*))
(defun up fexpr (arg)
(declare (fixnum temp-fixnum))
(setq *frame*-*pointer*
(do ((move (evalframe (abs (cadr *frame*-*pointer*)))
(evalframe (abs (cadr move))))
(option (and arg (car arg)))
(temp-fixnum (cond (arg (car arg)) (t 0)))
(temp))
((null move) (print 't-o-s) *frame*-*pointer*)
(cond ((null arg) (return move))
((numberp option)
(cond ((< (setq temp-fixnum
(1- temp-fixnum)) 1)
(return move))))
((and (not (atom (caddr move)))
(atom (setq temp (caaddr move))))
(cond ((and (memq option
'(i f c m))
(not (sysp temp)))
(cond ((eq option 'f)
(return move))
((and (eq option 'i)
(getl temp '(expr fexpr)))
(return move))
((and (eq option 'c)
(getl temp '(subr fsubr lsubr)))
(return move))
((and (eq option 'm)
(get temp 'macro))
(return move))))
((eq option temp)
(return move))))))) )
(defun dn fexpr (arg)
(declare (fixnum temp-fixnum))
(setq *frame*-*pointer*
(do ((move (evalframe (cadr *frame*-*pointer*))
(evalframe (cadr move)))
(option (and arg (car arg)))
(temp-fixnum (cond (arg (car arg)) (t 0)))
(temp))
((null move) (print 'b-o-s) *frame*-*pointer*)
(cond ((null arg) (return move))
((numberp option)
(cond ((< (setq temp-fixnum
(1- temp-fixnum)) 1)
(return move))))
((and (not (atom (caddr move)))
(atom (setq temp (caaddr move))))
(cond ((and (memq option
'(i f c m))
(not (sysp temp)))
(cond ((eq option 'f)
(return move))
((and (eq option 'i)
(getl temp '(expr fexpr)))
(return move))
((and (eq option 'c)
(getl temp '(subr fsubr lsubr)))
(return move))
((and (eq option 'm)
(get temp 'macro))
(return move))))
((eq option temp)
(return move))))))) )
(defun ret lexpr
(cond ((= lexpr 2) (freturn (cadr (arg 2)) (arg 1)))
((= lexpr 1) (freturn (cadr *frame*-*pointer*)
(arg 1)))
((= lexpr 0)
(cond ((eq (car *frame*-*pointer*) 'eval)
(freturn (cadr *frame*-*pointer*)
(eval (caddr *frame*-*pointer*)
(cadddr *frame*-*pointer*))))
((eq (car *frame*-*pointer*) 'apply)
(freturn (cadr *frame*-*pointer*)
(apply (caaddr *frame*-*pointer*)
(cadr (caddr *frame*-*pointer*))
(cadddr *frame*-*pointer*))))
(t (break damm-lisp t))))
(t (break wrong-number-of-args t))))
(defun ev lexpr
(cond ((= lexpr 2) (eval (arg 1) (cadddr (arg 2))))
((= lexpr 1) (eval (arg 1)
(cadddr *frame*-*pointer*)))
(t (break wrong-number-of-args t))))
(defun evq fexpr (x)
(cond ((null x) (break wrong-number-of-args t))
((null (cdr x))
(eval (car x) (cadddr *frame*-*pointer*)))
((null (cddr x))
(eval (car x) (cadddr (cadr x))))
(t (break wrong-number-of-args t))))

124
src/libdoc/stack.info Executable file
View File

@@ -0,0 +1,124 @@
;;; FRIDAY NOV 19,1976 10:51:28
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STACK DEBUGGING TOOLS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These routines are for crawling around in the LISP stack. For
;;;any meaningful stack information to be available *RSET must be set to
;;;T. Further, only minimal information will be present for compiled
;;;calls unless NOUUO is T. This package takes up 376. decimal words.
;;; The variable *FRAME*-*POINTER* (hereafter called the CURSOR) is
;;;always bound to a "stack frame 4-tuple". Each tuple is the value of
;;;an EVALFRAME function call. All the functions described below,
;;;unless otherwise noted, have as their value the current CURSOR.
;;; The CURSOR is either of the form:
;;; (EVAL <pdl-ptr> <form> <spec-pdl-ptr>) or
;;; (APPLY <pdl-ptr> (<operator> <arglist>) <spec-pdl-ptr>)
;;;The first atom is a keyword identifier indicating the format of the
;;;third entry. EVAL means that the form is an entity that is being
;;;EVAL'ed and the user could EVAL to see the effect. APPLY means that
;;;the third element is the list of the operator and its argument list.
;;;The argument list has been evaluated and is ready for the operator to
;;;be APPLY'ed to it. The user can do the latter by hand to see the
;;;effect.
;;; The <pdl-ptr> and <spec-pdl-ptr> print as FIXNUM's. They are
;;;pointers that are meaningful for EVALFRAME, FRETURN, EVAL, APPLY and
;;;a few other commands. The reader is refered to the MACLISP manual
;;;for a more detailed discussion.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; COMMANDS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;TOP (no args)
;;; Set the CURSOR to the "top" of the stack. The "top" is closest
;;;to the break. Like a plant the growing point of a stack is at its
;;;top.
;;;BOT (no args)
;;; Set the CURSOR to the "bottom" of the stack. The "bottom" is
;;;the frame of the last call from "command line".
;;;UP (fexpr)
;;; Move the CURSOR another frame towards the top. Falling off the
;;;top of the stack causes an error message to be printed. The CURSOR
;;;is not changed. (Thus the value of UP will be EQ to its previous
;;;value).
;;;DN (fexpr)
;;; Move the CURSOR another frame towards the bottom. Falling off
;;;the bottom of the stack causes an error message to be printed. The
;;;CURSOR is not changed. (Thus the value of DN will be EQ to its
;;;previous value).
;;;both UP and DN
;;;take the following arguments:
;;; <some number> do the operation that many times
;;; <some function> go to the frame where that function was invoked
;;; the letter F move the CURSOR until the first user function
;;; call is encountered
;;; the letter I move the CURSOR until the first non-compiled
;;; user function call is encountered
;;; the letter C move the CURSOR until the first compiled user
;;; function call is encountered
;;; the letter M move the CURSOR until the first user macro call
;;;FR (lexpr)
;;; Given no argument, its value is simply the CURSOR.
;;; Given an argument, it will reset the CURSOR to the argument.
;;;FM (no args)
;;; Return only the FORM of the stack frame. This is the third
;;;element of the CURSOR structure.
;;;RET (lexpr)
;;; no arg - reexecute the form at the cursor and unwind the stack
;;; Only this type execution of RET evaluates in the
;;; original (CURSOR) lambda variable binding environment
;;; one arg - return the arg in place of computing the value of the
;;; form at the CURSOR.
;;; two arg - as above, but use (arg 2) in place of the CURSOR.
;;;EV (lexpr)
;;; one arg - evaluate the arg in the binding environment of the
;;; CURSOR frame.
;;; two arg - as above, but use (arg 2) in place of the CURSOR.
;;;EVQ (fexpr)
;;; The evalquote version of the above function.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; HINTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; When the CURSOR 4-tuple is of the EVAL type (the first element
;;;of the tuple is EVAL), the form component is EQ to the piece of code
;;;that is in the actual function being executed. Thus RPLAC operators
;;;on this form wil make patches to the function.
;;; RET is most useful to return the correct value for some
;;;evaluation sequence that has gone amuck and proceed with the overall
;;;processing. It eliminates the necessity of starting again from the
;;;beginning because of some "simple" bug.
;;; To evaluate a number of variables and forms in some frame
;;;context it is often easier to do a (EVQ (BREAK FOO)) rather than
;;;repetitive EVQ's. The former expression places a BREAK "at an
;;;earlier place in the evaluation". Obviously this BREAK should be
;;;$P'ed, when it is no longer needed.

76
src/libdoc/statty.psz1 Executable file
View File

@@ -0,0 +1,76 @@
;;; THE FOLLOWING IMPLEMENT LISP CONTROL OVER THE ITS
;;PROCESSING OF INPUT CHARACTERS
(DEFUN INPUT-UPPERCASE (FLAG)
;;; (INPUT-UPPERCASE T) CAUSES ALL ALPHABETIC
;;CHARACTERS TO BE CONVERTED TO UPPERCASE ON INPUT BY
;;THE SYSTEM -- (INPUT-UPPERCASE NIL) RESETS TO THE
;;NORMAL MODE
;;; THIS FUNCTION SETS AND RESETS THE %TGSPC FLAG
;;FOR GROUP-1 CHARACTERS IN TTYST1 (SEE TTY ORDER)
((LAMBDA (TTYSTATUS)
(COND
(FLAG (SSTATUS TTY
(BOOLE 7. 67108864. (CAR TTYSTATUS))
(CADR TTYSTATUS)))
(T (SSTATUS TTY
(BOOLE 1.
(BOOLE 6. 67108864. -1.)
(CAR TTYSTATUS))
(CADR TTYSTATUS))))
FLAG)
(STATUS TTY)))
(DEFUN INPUT-ACTIVATE (FLAG)
;;; (INPUT-ACTIVATE T) CAUSES ALL INPUT
;;CHARACTERS TO ACTIVATE IMMEDIATELY RATHER THAN BEING
;;BUFFERED BY THE SYSTEM -- (INPUT-ACTIVATE NIL) RESETS
;;TO THE NORMAL MODE
;;; THIS FUNCTION SETS THE %TGACT FLAG FOR EACH
;;OF THE TWELVE INPUT GROUPS CONTROLLED BY TTYST1 AND
;;TTYST2 -- THIS FLAG IS NORMALLY SET FOR GROUPS 0. 5.
;;6. 7. 10. AND 11. WHICH ARE LEFT ACTIVATED BY
;;(INPUT-ACTIVATE NIL)
((LAMBDA (TTYSTATUS)
(COND
(FLAG
(SSTATUS TTY
(BOOLE 7. 2181570690. (CAR TTYSTATUS))
(BOOLE 7. 2181570690. (CADR TTYSTATUS))))
(T (SSTATUS TTY
(BOOLE 1.
(BOOLE 6. 34087040. -1.)
(CAR TTYSTATUS))
(BOOLE 1.
(BOOLE 6. 532480. -1.)
(CADR TTYSTATUS)))))
FLAG)
(STATUS TTY)))
(DEFUN INPUT-ECHO (FLAG)
;;; (INPUT-ECHO NIL) CAUSES THE SYSTEM TO STOP
;;ECHOING CHARACTERS AS THEY ARE READ / TYPED IN --
;;(INPUT-ECHO T) RESTORES THIS FUNCTION OF THE SYSTEM
;;TO NORMAL
;;; THIS FUNCTION SUSPENDS ECHOING BY SETTING OFF
;;THE %TGPIE FLAGS FOR ALL TWELVE CHARACTER GROUPS IN
;;THE VARIABLES TTYST1 AND TTYST2 -- NORMAL
;;INTERRUPT-LEVEL ECHOING IS RESTORED FOR ALL GROUPS
;;EXCEPT 10. (RUBOUT) BY (INPUT-ECHO T)
((LAMBDA (TTYSTATUS)
(COND (FLAG (SSTATUS
TTY
(BOOLE 7. 17452565520. (CAR TTYSTATUS))
(BOOLE 7.
17452564496.
(CADR TTYSTATUS))))
(T (SSTATUS TTY
(BOOLE 1.
(BOOLE 6. 17452565520. -1.)
(CAR TTYSTATUS))
(BOOLE 1.
(BOOLE 6. 17452565520. -1.)
(CADR TTYSTATUS)))))
FLAG)
(STATUS TTY)))

126
src/libdoc/step.rich5 Executable file
View File

@@ -0,0 +1,126 @@
;;; LISP Stepping Package
;;;
;;; <comments and problems accepted> Charles Rich, TS-824
;;; x3-6032
;;; AI: RICH
;;;
;;; For complete instructions see .INFO.;STEP INFO
;;;
;;; Rewritten 11/03/76
;;;
;;;
;;; User Interface Function
;;;
;;; Valid Forms: set EVALHOOK*
;;; (STEP) NIL
;;; (STEP T) T
;;; (STEP NIL) NIL
;;; (STEP FOO1 FOO2 ...) (FOO1 FOO2)
;;;
(declare (special evalhook evalhook* evalhook# prinlevel prinlength)
(fixnum i indent)
(setq macros nil)
(SETQ NEWIO NIL))
;; should be compiled with RICH;UTIL >
(DEFUN STEP FEXPR (ARG)
(COND ((OR (NULL ARG) (CAR ARG))
(SETQ *RSET T) ;must be on for hook to work
(SETQ EVALHOOK# 0.) ;initialize depth count
(SETQ EVALHOOK NIL) ;for safety
(SETQ EVALHOOK*
(COND ((NULL ARG) NIL)
((EQ (CAR ARG) T))
(ARG)))
(SETQ EVALHOOK 'EVALHOOK*)) ;turn system hook to my function
(T (SETQ EVALHOOK* NIL))))
(macrodef PRINT* ()
;; print with indentation
(do ((i 1 (1+ i))
(indent (* 2 evalhook#))
(prinlevel 3)
(prinlength 5))
((> i indent)(cond (prin1 (funcall prin1 form))
(t (prin1 form))))
(tyo 32.)))
;;;
;;; LISP evaluator comes here whenever EVALHOOK is Non-NIL and points here
;;; It expects me to do the evaluation and return the value.
;;;
(defun EVALHOOK* (form)
;; returns evaluation of form
(cond (evalhook*
;; see if selective feature kicks in here
(and (not (atom form))
(not (eq evalhook* t))
(memq (car form) evalhook*)
(setq evalhook* t))
(cond ((eq evalhook* t)
;; print out form before evaluation
(terpri)
(print*)
(cond ((atom form)
(cond ((not (or (numberp form)(null form)(eq form t)))
(princ '| = |)
((lambda (prinlevel prinlength)
(setq form (evalhook form nil))
(cond (prin1 (funcall prin1 form))
(t (prin1 form))))
3 5))))
(t ; s-expression
(prog (cmd hookfn)
cmdlp (setq cmd (tyi tyi))
;; uppercase alphabetics
(cond ((alpha? cmd)(setq cmd (boole 2 32. cmd))))
;; dispatch on command character
(cond ((7bit cmd 32.) ;<sp> continue, but suppress
(cond ((eq (car (getl (car form) ;macro expansion
'(expr fexpr lexpr subr fsubr lsubr macro)))
'macro)
;; do macro expansion
(setq form (funcall (get (car form) 'macro)
form))
(terpri)
(print*)
(go cmdlp))
(t (setq hookfn 'evalhook*))))
((7bit cmd 80.) ; "P" print in full
(prog (prinlevel prinlength)
(cond (prin1 (terpri)(funcall prin1 form))
(t (print form))))
(go cmdlp))
((or (7bit cmd 9.)(7bit cmd 13.)) ;<tab> or <cr>
(setq evalhook* nil ;stop everything
hookfn nil))
((7bit cmd 127.) ;<rubout> no deeper
(setq hookfn nil))
((7bit cmd 77.) ; "M" continue including macro expansion
(setq hookfn 'evalhook*))
((7bit cmd 66.) ; "B" give breakpoint
(break step)
(print* form)
(go cmdlp))
(t (tyo 7.)(go cmdlp)))
;; evaluate form
(let ((evalhook# (1+ evalhook#)))
(setq form (evalhook form hookfn)))
;; print out evaluated form
(cond ((and evalhook* (not (zerop evalhook#)))
(terpri) (print*))))))
;;return evaluated form
form)
(t (evalhook form 'evalhook*)))) ; keep looking
(t (evalhook form 'evalhook*)))) ; skip out quick

1089
src/libdoc/stepmm.71 Executable file
View File

File diff suppressed because it is too large Load Diff

994
src/libdoc/stepr.rvb2 Executable file
View File

@@ -0,0 +1,994 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SATURDAY AUG 06,1977 14:31:23
;;; lisp stepper with heuristic controls
;;;
;;; Copyright (c) 1977 by
;;; Robert V. Baron and
;;; Massachusetts Institute of Technology.
;;; All rights reserved.
;;;
;;; r.v.baron
;;; ne43-316
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment lisp "stepper" debugger)
(*rset t) ;;;else the stepper is not active
(declare (*expr seval stepper-top step-eval step-apply
step-value step-look step-check applyhook step-macroform
step-prog step-lambda step-firstarg)
(*fexpr step step-options heur atompreds formpreds
step-preds heur-atom heur-function offpreds)
(*lexpr evalhook step-print step-retrieve step-f step-v stepa
reform step-form step-fun step-op reevaluate)
(genprefix stephook)
(special step-form oldstep-form step-value oldstep-value
stepsilence stepatomdefault stepmacrodefault
stepfunctiondefault stepformdefault stepmax stepold
stepdepth oldstepdepth steplimit sprinter step-count
step-ans atompreds stepheuristics stepmarkedfunctions
stepmarkedatoms steplimitpostview steppassing
stepmarkedforms formpreds silentstepfunctiondefault
silentstepatomdefault stepcheck-enable)
(special prinlevel prinlength grindlevel grindlength))
(mapc (function (lambda (x)
(or (getl (car x) '(subr fsubr lsubr autoload))
(putprop (car x) (cdr x) 'autoload))))
'((sprinter grindef fasl com)
(pretty-print pretty fasl dsk ps1)
(pretty-print-datum pretty fasl dsk ps1)))
(setq stepdepth 0 stepmax 140. atompreds nil formpreds nil
oldstep-value nil oldstep-form nil
stepmarkedfunctions nil stepmarkedforms nil stepmarkedatoms nil)
(or (boundp 'sprinter)
(setq sprinter (cond ((memq 'ml (status features)) 'lh)
(t t))))
(array steparray t stepmax 2)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; main functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun step fexpr (the-form)
(terpri)
(step-print 'form stepdepth (or the-form stepold)
(setq the-form (stepper-top (car the-form))))
the-form)
(defun seval (the-form) (stepper-top the-form))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; execution environment
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun unbound-default macro (x)
(list 'cond
(list (list 'boundp (list 'quote (cadr x)))
(cadr x))
(list t (caddr x))))
;;; rebind and possibly initialize global variables for
;;;recursive step invocation. initialize to previous values if
;;;any.
(defun stepper-top (the-form)
(cond ((numberp the-form) (setq the-form (steparray the-form 0)))
((eq the-form t) (setq the-form (steparray stepdepth 0)))
((null the-form) (setq the-form stepold)))
(setq stepold the-form)
((lambda (*rset stepsilence steplimit stepatomdefault
stepfunctiondefault stepformdefault stepmacrodefault
stepheuristics stepold steppassing steplimitpostview
stepcheck-enable)
(setq step-count 0 oldstepdepth (1+ stepmax))
;;; (evalhook the-form (function step-eval))
(step-eval the-form))
t
(unbound-default stepsilence nil)
stepmax
(unbound-default stepatomdefault '(step-atomvalue))
(unbound-default stepfunctiondefault nil)
(unbound-default stepformdefault nil)
(unbound-default stepmacrodefault '(step-macroform))
(unbound-default stepheuristics t)
(unbound-default stepold nil)
(unbound-default steppassing t)
(unbound-default steplimitpostview t)
(unbound-default stepcheck-enable nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; main evalhook function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;at breaks step-form has the current form
;;; step-value has the value of the form
(defun step-eval (step-form)
((lambda (step-value stepdepth usertypein ^w)
(store (steparray stepdepth 0) step-form)
;;;check any unusual conditions
(and stepcheck-enable
(or atompreds formpreds)
(step-check))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; user option
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(prog () read-in
(cond
;;;second time around.
(usertypein
(setq usertypein (step-read-eval '==ok=>)))
;;;don't ask user and don't display
((and (setq usertypein stepcheck-enable)
(not (eq stepcheck-enable 'watch))))
((< steplimit stepdepth)
(setq usertypein 'no))
((and stepheuristics
(setq usertypein
(stepask step-form))
(not (eq usertypein 'ask))))
;;;print the form to user
(t
(step-print 'form stepdepth 'step-form step-form)
(setq stepsilence nil steplimit stepmax
usertypein (step-read-eval '==ok=>))))
(cond
;;;reset defaults and check for non local go to.
((numberp usertypein)
(setq steplimit usertypein usertypein 'no))
;;;stop all tree print out including on return branches
((eq usertypein 'k) ;kill killc
(setq stepsilence t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; control evaluation for this form
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq ^w nil oldstepdepth (1+ stepmax)) ;just in case.
(setq step-value
(cond ((and stepcheck-enable
(not (eq stepcheck-enable 'watch)))
(evalhook step-form (function step-eval)))
;;;no deeper evaluation on this branch
((or stepsilence
(memq usertypein '(n v no b))
(> stepdepth steplimit))
(eval step-form))
;;;recursion
((memq usertypein '(c r d y))
(evalhook step-form (function step-eval)))
;;;macro
((eq usertypein 'm)
(setq step-value
(errset (funcall (get (car step-form) 'macro)
step-form)
nil))
(cond ((null step-value)
(error step-form 'macro-expansion-error))
(t (setq step-form (car step-value)
step-value nil
usertypein nil)
(go read-in))))
;;;do checking on way down
((eq usertypein 'fork)
(setq stepcheck-enable t)
(evalhook step-form (function step-look)))
;;;user claims to have calculated the answer already
((eq usertypein 'evaled)
(setq usertypein 'n) step-value)
;;;eval the users form instead of the one present
((eq usertypein 'i)
(do ((xtemp nil
(errset (eval
(step-retrieve
'type 'a 'form 'to 'eval))))
(errset nil))
(xtemp (car xtemp))))
;;;break after the args have been accumulated
((eq usertypein 'a) ;args
((lambda (step-value)
(cursorpos 'c)
(step-f)
(step-print 'value
stepdepth 'args step-value)
(break examine-args t)
;;;apply function
(applyhook (car step-form)
step-value
(function step-eval)))
;;;build arg list
(mapcar (function eval) (cdr step-form))))
;;;other wise assume error
((eq usertypein 'again)
(setq usertypein nil) (go read-in))
((null usertypein) (go read-in))
((boundp usertypein)
(step-print 'value stepdepth 'atom-value
(symeval usertypein))
(go read-in))
(t (step-print 'value
stepdepth 'no-value-or-bad-option
usertypein)
(go read-in)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; thursday nov 13,1975 12:21:49
;;; print out control
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(store (steparray stepdepth 1) step-value)
(cond
((and stepcheck-enable
(not (eq stepcheck-enable 'watch))))
;;;if "great" motion print out marker
((or stepsilence
(> stepdepth steplimit)))
((and steplimitpostview
(= (- oldstepdepth stepdepth 1) 0)
(eq step-value oldstep-value))
(setq oldstepdepth stepdepth)
(and steppassing
(not (atom step-form))
(atom (car step-form))
(not (sysp (car step-form)))
;;;then
(step-print 'form
stepdepth 'passing step-form)))
;;;no print out
((memq usertypein '(no r n k)) nil)
;;; view does not break
((prog ()
(cond ((memq usertypein '(d c y))
(cursorpos 'c)
(step-print 'form
stepdepth 're-form step-form)))
(step-print 'value
stepdepth 'step-value step-value)))
((memq usertypein '(d v i))
;;;we guarantee at least one brak
(setq oldstepdepth stepdepth
oldstep-value step-value
oldstep-form step-form)
(sleep 2.2))
(t
;;;and break
(cond
((null
(setq usertypein
(break postview t))))
;;;if we have a return t the next clause gets invoked
((eq usertypein t) (setq stepsilence t))
((numberp usertypein)
(setq steplimit usertypein)))
(setq oldstepdepth stepdepth
oldstep-value step-value
oldstep-form step-form)))
step-value)
nil (1+ stepdepth) nil nil))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; thursday nov 13,1975 12:04:40
;;; heuristics are either atoms or list. if it is a list, it
;;;is first evaluated by calling the function that is the car of
;;;the list with two arguments. the first is the form to be
;;;evaluated and the second is the list that is the heuristic.
;;;an atom should be returned. this is then interpreted as
;;;though an atom was given originally.
;;; if the atom is neither ask nor nil it is passed back as
;;;the heuristic. if it is ask the user is asked for the
;;;heuristic to be used. finally if it is nil a default is taken.
;;;
;;; for atoms the default is the "atomdefault".
;;; for forms the default is the "formdefault" and then the
;;;function heuristic (and maybe the "functiondefault")
;;; for functions the default is the "functiondefault"
;;; for macros the default is the "macrodefault"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun stepinterpret-option macro (x)
(list 'cond
(list (list 'atom (cadr x))
(cadr x))
(list t
(list 'funcall (list 'car (cadr x))
'step-form
(cadr x)))))
(defun stepask (form)
((lambda (lookup temp)
(cond ((atom form)
;;;atom
(setq temp (get form 'stepaskatom))
(or (and temp (stepinterpret-option (car temp)))
(and stepatomdefault
(stepinterpret-option stepatomdefault))))
;;;operator
((setq temp
(get (cond ((atom (car form)) (car form))
(t (caar form)))
'stepaskfunction))
(cond ((and (cdr temp)
;;;there is a form default
(cond
((and (setq lookup
(getl temp (ncons form)))
;;;match on specific form
(stepinterpret-option
(cadr lookup))))
;;;form default
(stepformdefault
(stepinterpret-option
stepformdefault)))))
;;;fall into function defaults
(t
;;;operator
(or (stepinterpret-option (car temp))
(and stepfunctiondefault
(stepinterpret-option
stepfunctiondefault))))))
;;; ((and stepmacrodefault
;;; (get (car form) 'macro))
;;; (stepinterpret-option stepmacrodefault))
;;;unknown operator
(stepfunctiondefault
(stepinterpret-option stepfunctiondefault))
;;; if there is a non-nil functiondefault it has precedence over a
;;;macro default. Thus the (heur silent) mechanism need not recognize
;;;macros specially. This could be changed by fliping the
;;; ";;;"'s from above
((and stepmacrodefault
(get (car form) 'macro))
(stepinterpret-option stepmacrodefault))))
nil nil))
(defun stepdefault-form-to-function (form me)
(setq me (get (car form) 'stepaskfunction))
(or (stepinterpret-option (car me))
(stepinterpret-option stepfunctiondefault)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; establish special heuristic behavior
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dour fexpr (pairs)
(apply (function heur) pairs)
(setq step-count 1 step-ans 'again)
'doing-it)
(defun heur fexpr (pairs)
(cond ((null pairs)
(heur declare n quote n function n comment n nil n t n)
(heur prog prog)
(heur-function lambda lambda)
'done)
((null (cdr pairs))
(heur-command (car pairs)))
(t (do ((2-tuple pairs (cddr 2-tuple))
(ans nil (cons (enter-heur (car 2-tuple)
(cadr 2-tuple)
nil)
(cons (car 2-tuple) ans))))
((null 2-tuple) (nreverse ans))))))
(defun heur-atom fexpr (tuple)
(enter-heur (car tuple) (cadr tuple) 'atom))
(defun heur-function fexpr (tuple)
(enter-heur (car tuple) (cadr tuple) 'function))
(defun heur-command (option)
(cond ((eq option 'off)
(mapc (function (lambda (x) (enter-heur x 'off 'function)))
stepmarkedfunctions)
(setq stepmarkedfunctions nil))
((memq option '(off-forms offforms))
(mapc (function (lambda (x) (enter-heur x 'off 'function)))
stepmarkedforms)
(setq stepmarkedforms nil))
((memq option '(off-atoms offatoms))
(mapc (function (lambda (x) (enter-heur x 'off 'atom)))
stepmarkedatoms)
(setq stepmarkedatoms nil))
((eq option 'list) (append stepmarkedatoms
stepmarkedfunctions))
((memq option '(list-forms listforms)) stepmarkedforms)
((memq option '(defaults default))
(list (list 'atomdefault (or stepatomdefault 'off))
(list 'formdefault (or stepformdefault 'off))
(list 'functiondefault
(or stepfunctiondefault 'off))
(list 'macrodefault (or stepmacrodefault 'off))))
((eq option 'silent)
(setq silentstepatomdefault stepatomdefault
stepatomdefault 'n
silentstepfunctiondefault stepfunctiondefault
stepfunctiondefault 'r))
((memq option '(loud unsilent noisy))
(setq stepatomdefault silentstepatomdefault
stepfunctiondefault silentstepfunctiondefault))))
(defun heur-tuple (op heur)
(enter-heur op heur nil))
(defun enter-heur (op heur type)
(prog (form prop plist deflt)
;;;make op the operator; form is nil if spec is for function or
;;;atom.
(cond ((and (numberp op) (> op 0))
(setq form (steparray op 0)
op (car form)))
((numberp op)
(setq form (steparray (+ stepdepth
op) 0)
op (car form)))
((atom op) (setq form nil))
(t (setq form op op (car form))))
(or (atom op)
(setq op (car op)))
;;;are there any heuristics on the op
(setq type
(cond ((or form
(and type (not (eq type 'atom)))
(getl op '(expr fexpr macro subr
fsubr lsubr)))
'stepaskfunction)
(t 'stepaskatom)))
(setq plist (get op type))
;;;decode special user abberviations for heuristic options
(setq prop
(cond ((setq prop (assq
heur
'((prog step-prog)
(lambda step-lambda)
(fun step-automatic)
(atom step-atomvalue)
(macro step-macroform)
(silent . r)
(arg step-firstarg))))
(cdr prop))
(t heur)))
(and (eq prop 'off)
(setq prop nil))
;;; now the fun begins we have 3 variables
;;; plist - whether there are other heuristics - t
;;; form - whether a form is being marked - t
;;; prop - whether and what heur is set - (not nil)
;;;thus 2^3 gives 8 possible states and we decode and act
;;;specially for each.
(cond
;;;report out user defaults
((eq prop 'default)
(cond ((null plist) (setq deflt 'off))
(form (setq deflt (or (get plist form) 'off)))
(t (setq deflt (or (car plist) 'off)))))
;;;set simple defaults
((eq op 'atomdefault) (setq stepatomdefault prop))
((eq op 'functiondefault) (setq stepfunctiondefault prop))
((eq op 'formdefault) (setq stepformdefault prop))
((eq op 'macrodefault) (setq stepmacrodefault prop))
;;;the "dispatch" begins.
(form (setq stepmarkedforms
(cons form stepmarkedforms))
(cond
(plist (cond
(prop (putprop plist prop form)) ;t t t form+
((remprop plist form)
(setq stepmarkedforms
(delq form stepmarkedforms))
(and (null (cdr plist))
(null (car plist))
(remprop (car form)
type))))) ;t t nil form+
(t (cond
(prop (putprop op
(list nil form prop)
type)) ;nil t t form+
(t (putprop op
(list nil form nil)
type)))))) ;t nil nil fun-
(t (cond ((eq type 'stepaskatom)
(setq stepmarkedatoms
(cons op stepmarkedatoms)))
(t (setq stepmarkedfunctions
(cons op stepmarkedfunctions))))
(cond
(plist (cond
(prop (rplaca plist prop)) ;t nil t fun there
((and (setq stepmarkedfunctions
(delq op stepmarkedfunctions))
nil))
((null (cdr plist))
(remprop op type)) ;t nil nil fun
(t (rplaca plist nil)))) ;nil t nil form+
(t (cond
((or prop
(get op 'macro))
(putprop op (list prop)
type)) ;nil nil t fun+
(t nil))))))
(return (or deflt prop 'off))))
;;; auxiliary user print functions.
(defun step-automatic (form heur)
(step-print 'form stepdepth '==function== (car form)) 'r)
(defun step-prog (form heur)
(step-print 'form stepdepth '==autoprog==
(list 'prog (cadr form))) 'r)
(defun step-lambda (form heur)
(step-print 'form stepdepth '==autolambda==
(list 'lambda (cadar form))) 'r)
(defun step-firstarg (form heur)
(step-print 'form stepdepth '==firstarg==
(list (car form) (cadr form))) 'r)
(defun step-macroform (form heur)
(step-print 'form stepdepth 'macro form) 'm)
(defun step-atomvalue (form heur)
(cond ((numberp form) (setq step-value form))
(t
(step-print 'value stepdepth form 'value-is
(setq step-value (symeval form)))))
(sleep 1.0) 'evaled)
(defun rvbs-way (form heur)
(step-print 'form stepdepth 'dwim-nwit form)
(setq form (step-read-eval '==ok=>))
(cond ((memq form '(y c d r)) (cadr heur))
(t form)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; trace entry point
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; the next two function are auxiliaries for breaking
;;;after the arguments have been evaluated
(defun step-lively (a b)
((lambda (*rset stepsilence steplimit stepatomdefault
stepfunctiondefault stepformdefault stepmacrodefault
stepheuristics stepold steppassing steplimitpostview
stepcheck-enable)
(setq oldstepdepth (1+ stepmax) step-count 0)
(applyhook a b (function step-eval)))
t
(unbound-default stepsilence nil)
stepmax
(unbound-default stepatomdefault '(step-atomvalue))
(unbound-default stepfunctiondefault nil)
(unbound-default stepformdefault nil)
(unbound-default stepmacrodefault '(step-macroform))
(unbound-default stepheuristics t)
(unbound-default stepold nil)
(unbound-default steppassing t)
(unbound-default steplimitpostview t)
(unbound-default stepcheck-enable nil)))
(and (getl 'trace-value '(lsubr expr))
(putprop (trace-value 'intern 'step-lively)
(get 'step-lively 'subr)
'subr))
(defun applyhook (fun arglist hooker)
(cond ((and *rset (getl fun '(fsubr fexpr)))
(evalhook (cons fun arglist)
(function step-eval)))
;;;eval'ing calls
(*rset
(evalhook
(cons fun
(mapcar (function (lambda (x)
(cons '*apply-marker* x)))
arglist))
(function step-apply)))
(t (apply fun arglist))))
(defun step-apply (form)
(cond ((eq (car form) '*apply-marker*)
(cdr form))
(t (step-eval form))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; check enabling
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun step-silent fexpr (arg)
(cond ((and arg (memq (car arg) '(fast faster)))
(force-command 'fork)
'checking)
(t (setq stepcheck-enable 'c)
(force-command 'c)
'cloak-checking)))
(defun watch ()
(setq stepcheck-enable 'watch)
'watching)
(defun force-command (opt)
(setq step-count 1 step-ans opt))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; checking code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; below is a much tighter loop for steping with the check
;;;option.
(defun step-look (step-form)
((lambda (stepdepth step-value)
(store (steparray stepdepth 0) step-form)
;;;has the condition we wathc for arisen.
(cond ((or (not stepcheck-enable)
(not (or atompreds formpreds))
(and (step-check) (not stepcheck-enable)))
;;;t means condition met
(step-eval step-form))
(t
(evalhook step-form (function step-look))))
)
(1+ stepdepth)
nil))
;;; of course the actual checking is embodied in this
;;;routine soeverything will be reasonably modular
(defun step-check nil
(do ((checks (cond ((atom step-form) atompreds)
(t formpreds))
(cdr checks))
(once) (ans) (errset))
((null checks)
(cond ((null once))
((or (and (null atompreds)
(null formpreds))
(memq (step-retrieve 'should 'i
'stop 'checking)
'(y yes t)))
(setq stepcheck-enable nil)))
once)
(cond ((and (setq ans
(errset (eval (car checks)) nil))
(car ans))
(or once (progn (cursorpos 'c)
(step-f)
(terpri)
(setq once t)))
(step-print 'form
stepdepth 'condition (car checks))
(cond ((memq (step-read-eval 'flush?)
'(y yes t))
(setq atompreds
(delq (car checks) atompreds)
formpreds
(delq (car checks) formpreds))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; predicate accumulating primitives
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun step-preds fexpr (args)
(cond ((null atompreds))
((memq (step-retrieve 'do 'you 'want atompreds
'done 'when 'i 'evaluate
'atoms?)
'(y yes t)))
(t (setq atompreds nil)))
(cond ((null formpreds))
((memq (step-retrieve 'do 'you 'want formpreds
'done 'when 'i 'evaluate
'atoms?)
'(y yes t)))
(t (setq formpreds nil)))
(do ((ele args (cdr ele)) (ans) (test) (errset nil))
((null ele) (setq atompreds (nreverse atompreds))
(setq formpreds (nreverse formpreds))
'done)
;;; (setq test (predsubst (car ele)))
(setq test (car ele))
(cond ((memq (step-retrieve 'do 'you 'want test
'done 'when 'i 'evaluate
'atoms?)
'(y yes t))
(setq atompreds (cons test atompreds))))
(cond ((memq (step-retrieve 'do 'you 'want test
'done 'when 'i 'evaluate
'forms?)
'(y yes t))
(setq formpreds (cons test formpreds))))))
;;; take a user specified predicate and cons up a executable
;;;form
(defun predsubst (form)
(sublis '( (! . step-form) (!op . (car step-form))
(!v . (symeval step-form))
(!1 . (cadr step-form))
(!2 . (caddr step-form))
(!3 . (cadddr step-form))
(!4 . (car (cddddr step-form)))
(!5 . (cadr (cddddr step-form))))
form))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; low-level i/o
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;print an expression. ^x's are caught and can stop printout
(defun step-print lexpr
((lambda (^w ^r type response errset prinlevel prinlength)
(errset (cond ((eq sprinter 'lh)
(cond ((eq type 'form)
(pretty-print response))
(t
(pretty-print-datum response))))
(sprinter (sprinter response))
((null prin1) (print response))
(t (terpri)
(funcall prin1 response)))))
nil
nil
(arg 1)
(cons 'depth (listify (- 1 lexpr)))
nil
grindlevel
grindlength))
(defun setq-if-unbound macro (x)
(rplaca x 'or)
(rplacd x
(list
(list 'boundp (list 'quote (cadr x)))
(cons 'setq (cdr x)))))
(setq-if-unbound grindlength 6)
(setq-if-unbound grindlevel 10)
(defprop depth (3 1 (extra-elements-in-head test-depth-hair))
pretty-print-format-description)
(defun test-depth-hair fexpr (arg)
(cond ((atom (cadr arg)) 2)
(t 1)))
;;;print a prompt and if it is not a valid answer eval it, else
;;;return it. not valid means either a list or an atom prefixed
;;;by a colon. in the latter case the atom without the : prefix
;;;is symevaled.
(defun step-read-eval (prompt)
(prog (ans 1char errset)
a (cond ((> step-count 0)
(setq step-count (1- step-count))
(return step-ans)))
(setq ans (step-retrieve prompt))
(setq ans
(cond ((numberp ans) (return ans))
((atom ans)
(setq 1char (getcharn ans 1))
(cond ((= 1char 58.)
(errset
(symeval
(implode (cdr (explodec ans))))))
((= 1char 35.)
(setq step-ans
(implode (cdr (explodec ans))))
(enter-heur step-form
step-ans
'function)
(return step-ans))
((= 1char 33.)
(setq step-ans
(implode (cdr (explodec ans))))
(enter-heur (car step-form)
step-ans
'function)
(return step-ans))
((and (< 1char 58.) (> 1char 48.))
;;; its a number
(setq step-count (- 1char 49.)
step-ans
(implode (cdr (explodec ans))))
(return step-ans))
(t (return ans))))
(t (errset (eval ans)))))
(cond (ans
(step-print 'value
stepdepth 'eval-value (car ans)))
(t (step-print 'value
stepdepth 'error-in 'evaluation)))
(go a)))
;;;print a message and wait for a response
(defun step-retrieve expr lexpr
(terpri)
(do ((xtemp)
(readtable (get 'readtable 'array))
(obarray (get 'obarray 'array))
(^q nil nil) (^w nil nil) (^r nil nil))
(xtemp (and (atom (car xtemp))
(not (zerop (boole 1 32768.
(status syntax (tyipeek)))))
(tyi))
(car xtemp))
(do ((yt 1 (1+ yt)))
((> yt lexpr))
(princ (arg yt)) (princ '/ ))
(setq xtemp (errset (read)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utility functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;print form evaluated at "level"
(defun step-f lexpr
((lambda (level grindlevel grindlength)
(terpri)
(step-print 'form
level 'form (steparray level 0)) (ascii 0))
(cond ((= lexpr 0) stepdepth)
(t (arg 1)))
nil nil))
;;;print value returned at "level"
(defun step-v lexpr
((lambda (level grindlevel grindlength)
(terpri)
(step-print 'value
level 'value (steparray level 1)) (ascii 0))
(cond ((= lexpr 0) stepdepth)
(t (arg 1)))
nil nil))
;;;reset the return value for a form, or the arglist to a fun
(defun step-value (form)
(setq step-value form))
;;;patch the form to something else
(defun step-form expr lexpr
((lambda (level copy)
(cond ((atom (steparray level 0))
(error (steparray level 0) 'must/ be/ list))
(t (rplaca (steparray level 0) (car copy))
(rplacd (steparray level 0) (cdr copy)))))
(cond ((= lexpr 1) stepdepth)
(t (arg 2)))
(append (arg 1) nil)))
;;;find the function we are in
(defun step-fun lexpr
(terpri)
(do ((cnt (cond ((= lexpr 0) stepdepth)
(t (1- (arg 1)))) (1- cnt))
(temp) (function))
((or function (= stepdepth 1))
(and function (step-print 'form (1+ cnt) temp (car function))))
(cond ((sysp (setq temp (car (steparray cnt 0)))))
((setq function
(getl temp
'(expr fexpr macro))))
((or (= lexpr 2)
(setq function
(getl temp '(subr fsubr lsubr)))))))
(ascii 0))
;;; first stack frame that matches a given operator
(defun step-op lexpr
(do ((cnt (cond ((< lexpr 2) stepdepth)
(t (1- (arg 2)))) (1- cnt))
(function nil (car (steparray cnt 0))))
((= cnt 1) (ascii 0))
(and (eq function (arg 1))
(return (step-f (1+ cnt))))))
;;;retry or redo some form inplace of some part of the stack
;;;revaluate at given level
(defun reevaluate expr lexpr
(terpri)
(do ((point (steparray
(cond ((= lexpr 0) stepdepth) (t (arg 1)))
0))
(evf (do ((hunt (evalframe nil)
(evalframe (cadr hunt))))
((or (null hunt) (eq (caaddr hunt)
'reevaluate))
hunt))
(evalframe (cadr evf))))
((or (null evf) (eq (caddr evf) point))
(and evf
(apply
(function freturn)
(list (cadr evf)
(seval (cond ((> lexpr 1)
(step-print 'form
(1+ stepdepth)
'revaluate
(arg 2))
(arg 2))
(t (step-print 'form
(1+ stepdepth)
'revaluate
point)
point)))))))))
(defun burp fexpr (control)
(cond ((or (null control) (memq (car control) '(stack on)))
(do ((inc (1+ stepdepth) (1+ inc))
(frame (evalframe 0)
(evalframe (abs (cadr frame)))))
((or (null frame)
(eq (caaddr frame) 'burp))
(eval '(stepsetstate)
(cadddr
(evalframe (cadr (evalframe (cadr frame))))))
(and (eq (car control) 'stack)
(setq stepdepth (1- inc)))
(1- inc))
(cond ((eq (car frame) 'eval)
(store (steparray inc 0) (caddr frame)))
(t (setq inc (1- inc))))))
(t (setq evalhook nil stepdepth 0))))
(defun stepsetstate ()
(setq *rset t)
(setq step-count 0 oldstepdepth (1+ stepmax))
(setq stepsilence (unbound-default stepsilence nil))
(setq steplimit stepmax)
(setq stepatomdefault
(unbound-default stepatomdefault'(step-atomvalue)))
(setq stepfunctiondefault
(unbound-default stepfunctiondefault nil))
(setq stepformdefault
(unbound-default stepformdefault nil))
(setq stepmacrodefault
(unbound-default stepmacrodefault '(step-macroform)))
(setq stepheuristics
(unbound-default stepheuristics t))
(setq stepold
(unbound-default stepold nil))
(setq steppassing
(unbound-default steppassing t))
(setq steplimitpostview
(unbound-default steplimitpostview t))
(setq stepcheck-enable
(unbound-default stepcheck-enable nil))
(setq evalhook (function step-eval)))
(heur)
;;;uread the users step (init) if he has one
((lambda (file-name)
(cond ((probef file-name) (load file-name))))
(list (list 'dsk (status udir)) 'step '|(init)|))

164
src/libdoc/string.psz1 Executable file
View File

@@ -0,0 +1,164 @@
;;*(SLASHIFY /")
;;; This file contains definitions of (most of) the MACLISP
;;;string functions which exist on MULTICS -- simulated by much
;;;less efficient schemes here -- and several of the more common
;;;INTERLISP string functions.
;;; For this package, a string is an (uninterned) atom whose
;;;first and last characters are /" -- that character is defined
;;;as a macro character which creates such strings.
(DECLARE (*EXPR STRINGP MKSTRING MAKE-ATOM STRINGLENGTH
NTHCHAR)
(*LEXPR CATENATE SUBSTR CONCAT SUBSTRING))
(DEFUN /"-STRING-MACRO NIL
(DO
((COLLECT (NCONS '/") (CONS (READCH) COLLECT)))
((AND (EQ '/" (CAR COLLECT)) (CDR COLLECT))
(MAKNAM (NREVERSE COLLECT)))))
;;; Turn on the garbage collection of truly worthless
;;;atoms since this package will be creating a lot of them.
(GCTWA T)
(DEFUN STRINGP (STRING?)
(AND (EQ 'SYMBOL (TYPEP STRING?))
(EQ '/" (GETCHAR STRING? 1.))
(EQ '/" (GETCHAR STRING? (FLATC STRING?)))
STRING?))
(DEFUN MKSTRING (STRING?)
(COMMENT THE ATOM ^@ (ASCII NULL) MAKES THE NULL STRING)
(OR
(STRINGP STRING?)
((LAMBDA (L BASE *NOPOINT)
(COND ((SETQ L (EXPLODEN STRING?))
(RPLACD (LAST L) (NCONS '/"))
(MAKNAM (CONS '/" L)))
(T (MAKNAM '(/" /")))))
NIL 10. T)))
(DEFUN MAKE-ATOM (STRING)
(COMMENT THIS IS THE OPPOSITE OF MKSTRING -- NOTE THAT
THE NULL STRING IS MADE INTO ^@ (ASCII NULL))
(PROG (ANSWER WORK)
(SETQ ANSWER (CDR (EXPLODEN STRING)) WORK ANSWER)
(OR (CDR WORK) (RETURN (MAKNAM NIL)))
LOOP (COND
((CDDR WORK) (SETQ WORK (CDR WORK)) (GO LOOP)))
(RPLACD WORK NIL)
(RETURN (MAKNAM ANSWER))))
(DEFUN STRINGLENGTH (STRING) (- (FLATC STRING) 2.))
;;; The MACLISP functions require that their string arguments
;;;always be strings; therefore, they do not check.
(DEFUN CATENATE EXPR NARGS
(COMMENT CATENATE CONCATENATES ONE OR MORE STRING
ARGUMENTS)
(PROG (ANSWER WORK ARGNO)
(AND (EQUAL NARGS 1.) (RETURN (ARG 1.)))
(SETQ ARGNO 1.
ANSWER (EXPLODEN (ARG 1.))
WORK ANSWER)
LOOP (COND
((CDDR WORK) (SETQ WORK (CDR WORK)) (GO LOOP)))
(RPLACD
WORK
(CDR (EXPLODEN (ARG (SETQ ARGNO (1+ ARGNO))))))
(AND (< ARGNO NARGS) (GO LOOP))
(RETURN (MAKNAM ANSWER))))
(DEFUN SUBSTR EXPR NARGS
(COMMENT (SUBSTR STRING START LENGTH) SELECTS A
SUBSTRING OF <STRING> STARTING AT POSITION
<START> FOR <LENGTH> CHARACTERS -- IF
<LENGTH> IS OMITTED THEN IT DEFAULTS TO THE
REST OF THE STRING -- AN INVALID SELECTION
RETURNS NIL (NOT THE NULL STRING) -- A
<LENGTH> OF 0. YIELDS THE NULL STRING AND AN
EXCESSIVE <LENGTH> IS IGNORED)
(PROG (STRING STRINGLENGTH START LENGTH ANSWER LEN)
(DECLARE (FIXNUM START))
(SETQ STRING (EXPLODEN (ARG 1.))
ANSWER STRING
STRINGLENGTH (STRINGLENGTH (ARG 1.))
START (ARG 2.)
LEN (AND (> NARGS 2.) (ARG 3.))
LENGTH (COND
((NUMBERP LEN)
(MIN (FIX LEN)
(- STRINGLENGTH START -1.)))
(T (- STRINGLENGTH START -1.))))
(OR (AND (PLUSP START)
(NOT (> START STRINGLENGTH))
(PLUSP LENGTH))
(RETURN NIL))
(AND (NOT (= START 1.))
(PROG NIL
L1 (RPLACD STRING (CDDR STRING))
(AND (> (SETQ START (1- START)) 1.)
(GO L1))))
L2 (COND ((PLUSP (SETQ LENGTH (1- LENGTH)))
(SETQ STRING (CDR STRING))
(GO L2)))
(RPLACD (CDR STRING) (LAST STRING))
(RETURN (MAKNAM ANSWER))))
;;; CONCAT and SUBSTRING are INTERLISP versions of CATENATE and
;;;SUBSTR but with somewhat different conventions.
(DEFUN CONCAT EXPR NARGS
(COMMENT CONCAT IS JUST LIKE CATENATE EXCEPT THAT ITS
ARGUMENT NEED NOT BE STRINGS TO BEGIN WITH)
(DO ((I 1. (1+ I))
(ARGLIST NIL (CONS (MKSTRING (ARG I)) ARGLIST)))
((> I NARGS)
(APPLY (FUNCTION CATENATE) (NREVERSE ARGLIST)))))
(DEFUN SUBSTRING EXPR NARGS
(COMMENT SUBSTRING IS A GENERALIZED VERSION OF SUBSTR
-- (SUBSTRING STRING START END) SELECTS THAT
STRING IN <STRING> WHICH STARTS AT POSITION
<START> AND RUNS TO POSITION <END> -- IF
<START> OR <END> ARE NEGATIVE THEY INDICATE
CHARACTER POSITIONS FROM THE RIGHT END OF THE
STRING -- OUT OF BOUNDS PARAMETERS OR A
NEGATIVE-LENGTH RESULT CAUSE NIL TO BE
RETURNED)
(PROG (STRING START END STRINGLENGTH)
(DECLARE (FIXNUM STRINGLENGTH START))
(SETQ STRING (MKSTRING (ARG 1.))
START (ARG 2.)
END (AND (> NARGS 2.) (ARG 3.))
STRINGLENGTH (STRINGLENGTH STRING))
(AND (OR (ZEROP START) (AND END (ZEROP END)))
(RETURN NIL))
(OR (PLUSP START)
(SETQ START (+ STRINGLENGTH START 1.)))
(OR (NULL END)
(PLUSP END)
(SETQ END (+ STRINGLENGTH END 1.)))
(OR (NULL END) (NOT (< END START)) (RETURN NIL))
(RETURN (SUBSTR STRING
START
(COND (END (- END START -1.)))))))
(DEFUN NTHCHAR (STRING N)
(COND
((STRINGP STRING)
(COND ((> N (STRINGLENGTH STRING)) NIL)
(T (GETCHAR STRING (1+ N)))))
((EQ (TYPEP STRING) 'SYMBOL) (GETCHAR STRING N))
(T (NTHCHAR (MKSTRING STRING) N))))
(SETSYNTAX '/" 'MACRO '/"-STRING-MACRO)

282
src/libdoc/sun.bkph77 Executable file
View File

@@ -0,0 +1,282 @@
;;; COPYRIGHT Berthold K. P. Horn, 1977
;;;
;;; Program to calculate sun-elevation and sun-azimuth.
;;; Given observers geographical position and time of observation.
;;;
;;; T = time in days since 1975/01/01 GMT 00:00:00
;;;
;;; MEAN ANOMALY (M) = Geometric Mean Longitude - Mean Longitude of Perigee
;;; M = -2.4834 + .98560026 * T
;;;
;;; Mean Eccentricity e = .0l67343
;;; SQRT((1+e)/(1-e)) = 1.016877 in the mean
;;;
;;; ECCENTRIC ANOMALY (E) = Anomaly measured from focus of ellipse
;;; E + e sin(E) = M. Transcendental equation.
;;;
;;; TRUE ANOMALY (N): tan (N/2) = SQRT((1+e)/(1-e)) tan(E/2)
;;;
;;; LONGITUDE OF EARTH PERIGEE (G) = 282.5103 + .00004707 * T
;;; (Includes precession of earth's pole AND precession of orbit)
;;;
;;; TRUE LONGITUDE = LONGITUDE OF PERIGEE + TRUE ANOMALY
;;;
;;; (PRECESSION 50".47 per year, added to celestial longitude)
;;; (ABBERATION -20".47 taken off celestial longitude)
;;;
;;; Position of MOON'S NODE (O) = 248.58 - .052955 * T
;;; NUTATION in celestial longitude = -17".234 * sin(O)
;;; NUTATION in obliquity = 9".210 * cos(O)
;;;
;;; SEMI-DIAMETER .267 * (1 + e * cos(N) )
;;; OBLIQUITY OF ECLIPTIC PLANE (X)= 23.4425 + .0025575 * cos(O)
;;;
;;; DECLINATION (celestial latitude) of sun PHI = asin(sin(L) * sin(X))
;;; RIGHT ASCENSION (celestial longitude) of sun THETA = asin(sin(L) * cos(X)/cos(PHI))
;;; If cos(L)<0 use (180 - THETA)
;;;
;;; GHA(ARIES) = 100.025 + 360.9856473 * T
;;;
;;; GHA(SUN) = GHA(ARIES) + R.A.(SUN)
;;; LONGITUDE(SUB-SOLAR POINT) = 360.0 - GHA(SUN)
;;; LATITUDE(SUB-SOLAR POINT) = DECLINATION(SUN)
;;;
;;; Calculate GHA and Declination AND Semi-Diameter of sun.
;;; Given time (T) in days since 1975/01/01 GMT 00:00:00
;;; Result is list, (GHA DEC SD), numbers in decimal degrees.
;;;
(DEFUN SUN-POSITION (TIME)
(PROG (MEANA GUESA ECCEA TRUEA LAMBD OMEGA OBLIQ PHI THETA
GHAGAM)
(SETQ MEANA (-$ (*$ TIME 0.9856) 2.4832)
GUESA (TRUEANOM MEANA)
GUESA (ECCENANOM GUESA MEANA)
ECCEA (ECCENANOM GUESA MEANA)
TRUEA (TRUEANOM ECCEA))
(SETQ LAMBD (+$ TRUEA 282.5104 (//$ TIME 21120.0))
OMEGA (-$ 248.6 (//$ TIME 18.884))
OBLIQ (+$ 23.4425 (//$ (COSD OMEGA) 391.0))
LAMBD (-$ LAMBD (//$ (SIND OMEGA) 209.0)))
(SETQ SEMID (*$ 0.267 (+$ 1.0 (//$ (COSD TRUEA) 60.0)))
PHI (ASIND (*$ (SIND LAMBD) (SIND OBLIQ)))
THETA (-$ 0.0
(ASIND (//$ (*$ (SIND LAMBD)
(COSD OBLIQ))
(COSD PHI)))))
(COND ((< (COSD LAMBD) 0.0)
(SETQ THETA (-$ 180.0 THETA))))
(SETQ GHAGAM (+$ (*$ TIME 0.9856473)
(*$ (FRACTION TIME) 360.0)
100.025)
THETA (RANGE (+$ THETA GHAGAM)))
(RETURN (LIST THETA PHI SEMID))))
;;; CALCULATES ELEVATION AND AZIMUTH AT OBSERVERS LOCATION.
;;; THETA1 PHI1 OBSERVERS LONGITUDE AND LATITUDE (decimal degrees).
;;; THETA2 PHI2 CELESTIAL OBJECTS LONGITUDE AND LATITUDE (decimal degrees).
;;; Result is list, (ELEV AZIM), numbers are decimal degrees.
(DEFUN SKY-ANGLES (THETA1 PHI1 THETA2 PHI2)
(PROG (DTH ELEV AZIM)
(SETQ DTH (-$ THETA2 THETA1)
ELEV (ASIND (+$ (*$ (SIND PHI1) (SIND PHI2))
(*$ (COSD PHI1)
(COSD PHI2)
(COSD DTH))))
AZIM (ACOSD (//$ (-$ (SIND PHI2)
(*$ (SIND PHI1) (SIND ELEV)))
(*$ (COSD PHI1) (COSD ELEV)))))
(COND ((< (SIND DTH) 0.0) (SETQ AZIM (-$ 360.0 AZIM))))
(RETURN (LIST ELEV AZIM))))
;;; Calculate sun-elevation and sun-aximuth and semi-diameter.
;;; Given observer longitude and latitude, date and time.
;;; Input format: (A DD MM SS), (A DD MM SS), (YYYY MM DD), (HH MM SS).
;;; EAST IS POSITIVE for longitude, NORTH IS POSITIVE for latitude.
;;; RETURNS (ELEVATION AZIMUTH), format ((A DD MM SS) (A DD MM SS) (A DD MM SS))
;;; AZIMUTH MEASURED CLOCKWISE FROM NORTH
(DEFUN SUN (LONG LATI DATE HOURS)
(PROG (SUNPOS SKYANG)
(SETQ SUNPOS (SUN-POSITION (+$ (JULIAN DATE)
(HHMMSS HOURS)))
SKYANG (SKY-ANGLES (DDMMSS LONG)
(DDMMSS LATI)
(-$ 360.0 (CAR SUNPOS))
(CADR SUNPOS)))
(RETURN (LIST (ANGLED (CAR SKYANG))
(ANGLED (CADR SKYANG))
(ANGLED (CADDR SUNPOS))))))
;;; CALCULATE DAYS SINCE 1975/01/01 -- INPUT format (YY MM DD)
;;; JULIAN DATE EQUALS RESULT PLUS 2442414.
(DEFUN JULIAN (DATED)
(PROG (YEAR MONTH DAY DYR YRS)
(SETQ YEAR (CAR DATED)
MONTH (CADR DATED)
DAY (CADDR DATED))
(SETQ DYR (- 0. (// (- 14. MONTH) 12.))
YRS (+ DYR YEAR 4800.))
(RETURN (FLOAT (+ (- (// (* 367.
(- (- MONTH 2.) (* DYR 12.)))
12.)
(// (* 3. (1+ (// YRS 100.))) 4.))
(+ (// (* 1461. YRS) 4.)
(- DAY (+ 32075. 2442414.))))))))
;;; CALCULATE DATE, GIVEN DAYS SINCE 1975/01/01 -- OUTPUT format (YY MM DD)
;;; ARGUMENT IS (JULIAN DATE - 2442414.)
(DEFUN DATED (JULIAN)
(PROG (LOFF NOFF IOFF JOFF KOFF)
(SETQ LOFF (+ (FIX JULIAN) 68569. 2442414.)
NOFF (// (* LOFF 4.) 146097.)
LOFF (- LOFF (// (+ (* 146097. NOFF) 3.) 4.))
IOFF (// (* 4000. (1+ LOFF)) 1461001.)
LOFF (- LOFF (- (// (* 1461. IOFF) 4.) 31.))
JOFF (// (* 80. LOFF) 2447.)
KOFF (- LOFF (// (* 2447. JOFF) 80.))
LOFF (// JOFF 11.)
JOFF (- JOFF (- (* 12. LOFF) 2.))
IOFF (+ IOFF (* 100. (- NOFF 49.)) LOFF))
(RETURN (LIST IOFF JOFF KOFF))))
;;; NEGATE ANGLE IN FUNNY FORMAT
(DEFUN INVERT (L)
(COND ((EQUAL (CAR L) '+) (CONS '- (CDR L)))
((EQUAL (CAR L) '-) (CONS '+ (CDR L)))
(T (PRINT 'ERROR-IN-ANGLE-FORMAT))))
;;; CONVERT FROM HOURS -- format (HH MM SS) -- TO DECIMAL DAYS.
(DEFUN HHMMSS (TIMED)
(//$ (+$ (FLOAT (CAR TIMED))
(//$ (+$ (FLOAT (CADR TIMED))
(//$ (FLOAT (CADDR TIMED)) 60.0))
60.0))
24.0))
;;; CONVERT FROM DECIMAL DAYS TO HOURS -- format (HH MM SS).
(DEFUN TIMED (HHMMSS)
(PROG (HH MM SS TMP)
(SETQ HHMMSS (*$ 24.0 HHMMSS)
HH (FIX HHMMSS)
TMP (*$ 60.0 (-$ HHMMSS (FLOAT HH)))
MM (FIX TMP)
TMP (*$ 60.0 (-$ TMP (FLOAT MM)))
SS (FIX (+$ 0.5 TMP)))
(RETURN (LIST HH MM SS))))
;;; CONVERT FROM ANGLE -- format (A DD MM SS) -- TO DECIMAL DEGREES.
(DEFUN DDMMSS (ANGLED)
(COND ((EQUAL (CAR ANGLED) '-)
(-$ 0.0 (DDMMSS (INVERT ANGLED))))
(T (+$ (FLOAT (CADR ANGLED))
(//$ (+$ (FLOAT (CADDR ANGLED))
(//$ (FLOAT (CADDDR ANGLED)) 60.0))
60.0)))))
;;; CONVERT FROM DECIMAL DEGREES TO ANGLE -- format (A DD MM SS).
(DEFUN ANGLED (DDMMSS)
(PROG (DD MM SS TMP)
(COND ((< DDMMSS 0.0)
(RETURN (INVERT (ANGLED (-$ 0.0 DDMMSS))))))
(SETQ DD (FIX DDMMSS)
TMP (*$ 60.0 (-$ DDMMSS (FLOAT DD)))
MM (FIX TMP)
TMP (*$ 60.0 (-$ TMP (FLOAT MM)))
SS (FIX (+$ 0.5 TMP)))
(RETURN (LIST '+ DD MM SS))))
;;; Calculate true anomaly, given eccentric anomaly.
;;; Also gives first approximation of eccentric anomaly from mean anomaly.
;;; (Provided eccentricty is small)
(DEFUN TRUEANOM (THETA)
(*$ 2.0 (ATAND (*$ 1.01686 (TAND (//$ THETA 2.0))) 1.0)))
;;; Calculate eccentric anomaly from mean anomaly.
;;; Iterative approximation to Kepler's transcendental equation.
(DEFUN ECCENANOM (THETA MEAN) (+$ MEAN (*$ 0.958 (SIND THETA))))
;;; Restrict angle to 0.0 to 360.0 degree range.
(DEFUN RANGE (THETA)
(COND ((< THETA 0.0) (RANGE (+$ THETA 360.0)))
((> THETA 360.0) (RANGE (-$ THETA 360.0)))
(T THETA)))
(DEFUN SIND (X) (SIN (//$ (*$ 3.14159265 X) 180.0)))
(DEFUN COSD (X) (COS (//$ (*$ 3.14159265 X) 180.0)))
(DEFUN ATAND (Y X)
(*$ (-$ (//$ (ATAN (-$ 0.0 Y) (-$ 0.0 X)) 3.14159265) 1.0)
180.0))
(DEFUN TAND (X) (//$ (SIND X) (COSD X)))
;;; RETURNS RESULT IN RANGE -90 TO +90 DEGREES
(DEFUN ASIND (X) (ATAND X (SQRT (-$ 1.0 (*$ X X)))))
;;; RETURN RESULT IN RANGE 0 TO 180 DEGREES
(DEFUN ACOSD (X) (ATAND (SQRT (-$ 1.0 (*$ X X))) X))
(DEFUN FRACTION (X) (-$ X (FLOAT (FIX X))))
;;; ADD OFFSETS TO FIRST COMPONENT OF THREE-LIST.
(DEFUN UPDATE (L OFFSET) (LIST (+ (CAR L) OFFSET) (CADR L) (CADDR L)))
;;; CALCULATE POSITION OF SUN AT PRESENT TIME, HERE.
(DEFUN SUN-NOW-HERE NIL
(SUN LONGITUDE
LATITUDE
(UPDATE (STATUS DATE) 1900.)
(UPDATE (STATUS DAYTIME) GMT-OFFSET)))
;;; CALCULATE DAY OF WEEK FROM DAYS SINCE 1975/01/01
;;; MONDAY IS 1, TUESDAY IS 2, ... SUNDAY IS 7.
(DEFUN DAY-OF-WEEK (JULIAN) (1+ (REMAINDER (+ JULIAN 2.) 7.)))
;;; CALCULATE DATE OF LAST SUNDAY IN PRESENT MONTH (WITH N DAYS)
(DEFUN LAST-SUNDAY (DATE N)
(- N (PREMUTE (DAY-OF-WEEK (FIX (JULIAN (CONSTRUCT DATE N)))))))
(DEFUN PREMUTE (N) (COND ((= N 7.) 0.) (T N)))
(DEFUN CONSTRUCT (DATE N)
(CONS (CAR DATE) (CONS (CADR DATE) (CONS N NIL))))
;;; TO ADJUST FOR THAT CROCK CALLED DAY-LIGHT-SAVINGS TIME.
;;; SWITCH LAST SUNDAY OF APRIL AND LAST SUNDAY OF OCTOBER (?)
(DEFUN DAY-SAVE-CROCK (DATE)
(COND ((OR (< (CADR DATE) 4.)
(> (CADR DATE) 10.)
(AND (= (CADR DATE) 4.)
(< (CADDR DATE) (LAST-SUNDAY DATE 30.)))
(AND (= (CADR DATE) 10.)
(> (1- (CADDR DATE)) (LAST-SUNDAY DATE 31.))))
0.)
(T -1.)))
;;; GEOGRAPHICAL POSITION OF M.I.T. - A.I. LAB AND OFFSET FROM G.M.T.
;;; MODIFY TO YOUR OWN CONVENIENCE AND YOUR OWN LOCATION AND TIME SYSTEM.
(SETQ LONGITUDE '(- 71. 5. 20.))
(SETQ LATITUDE '(+ 42. 21. 50.))
;;; GIVE NORMAL OFFSET FROM G.M.T. IN HOURS AS SECOND ARGUMENT
(SETQ GMT-OFFSET (+ (DAY-SAVE-CROCK (UPDATE (STATUS DATE) 1900.)) 5.))

694
src/libdoc/time.kmp9 Normal file
View File

@@ -0,0 +1,694 @@
;;; -*- Package:TIME; Mode:Lisp; -*-
;;;
;;; This package created by KMP@MC, 24 May 81.
;;;
;;; TIME:DAYS - Bound to an alist of (daynum . dayname)
;;; TIME:MONTHS - Bound to an alist of (monthnum . monthname)
;;;
;;; STANDARD-OUTPUT - If undefined when this package loads, this variable
;;; will be set to the current value of TYO
;;;
;;; (TIME:GET-TIME-LIST)
;;; Returns (sec mins hours date month year dayofweek). This returns
;;; information similar to that returned by the LispM TIME:GET-TIME
;;; routine, but the information is returned as a list.
;;; Unlike the LispM, however, dayofweek is returned as a string (not
;;; a fixnum) and daylightsavings information is not returned at all.
;;;
;;; (TIME:PARSE-LIST string)
;;; Returns (sec mins hours date month year dayofweek). This returns
;;; information similar to that returned by the LispM TIME:PARSE
;;; routine, but the information is returned as a list.
;;; Unlike the LispM, however, dayofweek is returned as a string (not
;;; a fixnum). Daylightsavings information and relative information
;;; is not returned at all.
;;;
;;; The following several functions are used the same as in LispM lisp.
;;; The optional argument, stream, in the following functions defaults to
;;; the value of the symbol STANDARD-OUTPUT. A stream argument of () means
;;; to return the string rather than printing it.
;;; Year arguments less than one hundred are assumed to be offset from
;;; 1900.
;;; Day of week arguments to the dateprinting functions may be either
;;; strings or fixnums (0=Monday).
;;;
;;; (TIME:PRINT-CURRENT-TIME &optional stream)
;;; Calls TIME:PRINT-TIME using the current time.
;;;
;;; (TIME:PRINT-TIME sec min hrs date month year &optional stream)
;;; Displays the given time in format yr/mo/dy hr:min:sec
;;;
;;; (TIME:PRINT-CURRENT-DATE &optional stream)
;;; Calls TIME:PRINT-DATE using the current date.
;;;
;;; (TIME:PRINT-DATE sec min hrs date month year dayofweek &optional stream)
;;; Displays the given time in full English format. eg,
;;; Sunday the twenty-fourth of May; 3:02:17 pm
;;;
;;; (TIME:MONTH-STRING n &optional ignore)
;;; Returns the name of the nth month (1=January).
;;; Mode is not supported but is provided for calling compatibility
;;; with the LispM.
;;;
;;; (TIME:DAY-OF-THE-WEEK-STRING n &optional ignore)
;;; Returns the name of the nth day of the week (0=Monday).
;;; Mode is not supported but is provided for calling compatibility
;;; with the LispM.
;;;
;;; (TIME:VERIFY-DATE date month year dayofweek)
;;; Returns () if day,month,year fell on dayofweek. Else returns a string
;;; containing a suitable error message.
;;;
;;; This last function is not in the LispM lisp time package, but seemed
;;; a useful function to have, so is provided at no extra cost.
;;;
;;; (TIME:ON-WHAT-DAY-OF-THE-WEEK? day month year)
;;; Returns the day of the week that a given day fell on.
;;;
#+Maclisp
(HERALD TIME /4)
#+Maclisp
(DEFVAR STANDARD-OUTPUT TYO)
#+Maclisp
(EVAL-WHEN (COMPILE) (SETQ DEFMACRO-FOR-COMPILING ()))
#+Maclisp
(DEFMACRO CHAR-UPCASE (X)
(IF (NOT (ATOM X))
`(LET ((X ,X)) (CHAR-UPCASE X))
`(IF (AND (>= ,X #/a) (<= ,X #/z))
(- ,X #.(- #/a #/A))
,X)))
#+Maclisp
(DEFMACRO CHAR-DOWNCASE (X)
(IF (NOT (ATOM X))
`(LET ((X ,X)) (CHAR-DOWNCASE X))
`(IF (AND (>= ,X #/A) (<= ,X #/Z))
(- ,X #.(- #/A #/a))
,X)))
(DEFMACRO STANDARDIZE-YEAR (YEAR)
(IF (NOT (ATOM YEAR))
`(LET ((YEAR ,YEAR)) (STANDARDIZE-YEAR YEAR))
`(IF (< ,YEAR 100.) (+ ,YEAR 1900.) ,YEAR)))
(DEFMACRO STRING-UPPERCASE-INITIAL (FORM)
`(LET ((EXPL (EXPLODEN ,FORM)))
(IMPLODE (CONS (CHAR-UPCASE (CAR EXPL))
(DO ((L (CDR EXPL) (CDR L))
(LL () (CONS (CHAR-DOWNCASE (CAR L)) LL)))
((NULL L) (NREVERSE LL)))))))
(DEFMACRO DAY (X) `(CDR (ASSQ ,X TIME:DAYS)))
(DEFVAR TIME:DAYS
'((0. . "Monday" )
(1. . "Tuesday" )
(2. . "Wednesday")
(3. . "Thursday" )
(4. . "Friday" )
(5. . "Saturday" )
(6. . "Sunday" )))
(DEFMACRO MONTH (X) `(CDR (ASSQ ,X TIME:MONTHS)))
(DEFVAR TIME:MONTHS
'((1. . "January" )
(2. . "February" )
(3. . "March" )
(4. . "April" )
(5. . "May" )
(6. . "June" )
(7. . "July" )
(8. . "August" )
(9. . "September")
(10. . "October" )
(11. . "November" )
(12. . "December" )))
(DEFUN TIME:GET-TIME-LIST ()
(LET ((FULL-DATE (STATUS DATE))
(FULL-TIME (STATUS DAYTIME))
(DAY-OF-WEEK (STATUS DOW)))
(IF (NOT (EQUAL FULL-DATE (STATUS DATE)))
(TIME:GET-TIME-LIST)
(LET (((HOURS MINUTES SECONDS) FULL-TIME)
((YEAR MONTH DATE ) FULL-DATE)
(DOW (STRING-UPPERCASE-INITIAL DAY-OF-WEEK)))
(LIST SECONDS MINUTES HOURS DATE MONTH YEAR DOW)))))
(DEFUN TIME:PRINT-CURRENT-TIME (&OPTIONAL (STREAM STANDARD-OUTPUT))
(LEXPR-FUNCALL #'TIME:PRINT-TIME
(NREVERSE
(CONS STREAM (CDR (REVERSE (TIME:GET-TIME-LIST)))))))
(DEFUN TIME:PRINT-TIME (SECONDS MINUTES HOURS DATE MONTH YEAR
&OPTIONAL (STREAM STANDARD-OUTPUT))
(SETQ YEAR (STANDARDIZE-YEAR YEAR))
(FORMAT STREAM "~D//~D//~D ~D:~2,'0D:~2,'0D"
MONTH
DATE
(- YEAR 1900.)
HOURS
MINUTES
SECONDS))
(DEFUN TIME:PRINT-CURRENT-DATE (&OPTIONAL (STREAM STANDARD-OUTPUT))
(LEXPR-FUNCALL #'TIME:PRINT-DATE
(APPEND (TIME:GET-TIME-LIST) (NCONS STREAM))))
(DEFUN TIME:PRINT-DATE (SECONDS MINUTES HOURS DATE MONTH YEAR DAY-OF-WEEK
&OPTIONAL (STREAM STANDARD-OUTPUT))
(SETQ YEAR (STANDARDIZE-YEAR YEAR))
(LET ((MSG (TIME:VERIFY-DATE DATE MONTH YEAR DAY-OF-WEEK)))
(IF MSG (FERROR NIL MSG)))
(FORMAT STREAM "~A the ~:R of ~A, ~D; ~D:~2,'0D:~2,'0D ~A"
(IF (FIXP DAY-OF-WEEK)
(DAY DAY-OF-WEEK)
(STRING-UPPERCASE-INITIAL DAY-OF-WEEK))
DATE
(MONTH MONTH)
YEAR
(LET ((HR (\ HOURS 12.))) (IF (ZEROP HR) 12. HR))
MINUTES
SECONDS
(IF (ZEROP (// HOURS 12.)) "am" "pm")))
(DEFUN TIME:MONTH-STRING (MONTHNUM &OPTIONAL MODE) MODE ;ignored
(MONTH MONTHNUM))
(DEFUN TIME:DAY-OF-THE-WEEK-STRING (DAYNUM &OPTIONAL MODE) MODE ;ignored
(DAY DAYNUM))
(DEFUN TIME:VERIFY-DATE (DATE MONTH YEAR DAY-OF-THE-WEEK)
(SETQ YEAR (STANDARDIZE-YEAR YEAR))
(LET ((TRUE-DOW (TIME:DAY-OF-THE-WEEK-STRING
(TIME:ON-WHAT-DAY-OF-THE-WEEK? DATE MONTH YEAR))))
(IF (FIXP DAY-OF-THE-WEEK)
(SETQ DAY-OF-THE-WEEK (TIME:DAY-OF-THE-WEEK-STRING DAY-OF-THE-WEEK)))
(SETQ DAY-OF-THE-WEEK (STRING-UPPERCASE-INITIAL DAY-OF-THE-WEEK))
(IF (NOT (SAMEPNAMEP DAY-OF-THE-WEEK TRUE-DOW))
(LET (((TODAY-DATE TODAY-MONTH TODAY-YEAR)
(CDDDR (TIME:GET-TIME-LIST))))
(SETQ TODAY-YEAR (STANDARDIZE-YEAR TODAY-YEAR))
(FORMAT ()
(COND ((OR (> TODAY-YEAR YEAR)
(AND (= TODAY-YEAR YEAR)
(OR (> TODAY-MONTH MONTH)
(AND (= TODAY-MONTH MONTH)
(> TODAY-DATE DATE)))))
"The ~:R of ~A, ~D fell on a ~A, not a ~A.")
((AND (= TODAY-YEAR YEAR)
(= TODAY-MONTH MONTH)
(= TODAY-DATE DATE))
"Today is a ~3G~A, not a ~A.")
(T
"The ~:R of ~A, ~D will fall on a ~A, not a ~A."))
DATE
(MONTH MONTH)
YEAR
TRUE-DOW
DAY-OF-THE-WEEK)))))
;;; This code adapted from JONL's package MC:LIBDOC;DOW >
;;; The following function, when given the date as three numbers,
;;; will produce a number of the day-of-week for that date (0=Monday).
;;; eg,
;;; (TIME:DAY-OF-THE-WEEK-STRING
;;; (TIME:ON-WHAT-DAY-OF-THE-WEEK? 22. 11. 1963.))
;;; => "Friday"
;;; which happened to be the day President John F. Kennedy was assasinated.
(DEFUN TIME:ON-WHAT-DAY-OF-THE-WEEK? (DAY MONTH YEAR)
(IF (NOT (AND (FIXP YEAR) (FIXP MONTH) (FIXP DAY)))
(ERROR "Args to TIME:DAY-OF-WEEK must be fixnums" (LIST YEAR MONTH DAY))
(SETQ YEAR (STANDARDIZE-YEAR YEAR))
(LET ((A (+ YEAR (// (+ MONTH -14.) 12.))))
(DECLARE (FIXNUM A))
(\ (+ (// (1- (* 13. (+ MONTH 10. (* (// (+ MONTH 10.) -13.) 12.))))
5.)
DAY
76.
(// (* 5. (- A (* (// A 100.) 100.))) 4.)
;; ejs: commented out as per Alan Sampson. This is an incorrect
;; check.
;; (// A -2000.)
(// A 400.)
(* (// A -100.) 2.))
7.))))
;;; The following sequence is translated from the Teco code in
;;; KMP's TPARSE library.
(EVAL-WHEN (EVAL COMPILE)
(COND ((NOT (GET 'UMLMAC 'VERSION))
(LOAD '((LISP) UMLMAC)))))
(DEFPROP GMT -4 TIMEZONE-OFFSET)
(DEFPROP EDT 0 TIMEZONE-OFFSET)
(DEFPROP EST 0 TIMEZONE-OFFSET)
(DEFPROP CDT 1 TIMEZONE-OFFSET)
(DEFPROP CST 1 TIMEZONE-OFFSET)
(DEFPROP MDT 2 TIMEZONE-OFFSET)
(DEFPROP MST 2 TIMEZONE-OFFSET)
(DEFPROP PDT 3 TIMEZONE-OFFSET)
(DEFPROP PST 3 TIMEZONE-OFFSET)
(DEFPROP MONDAY MONDAY DAY-VALUE)
(DEFPROP MON MONDAY DAY-VALUE)
(DEFPROP TUESDAY TUESDAY DAY-VALUE)
(DEFPROP TUESDAY TUE DAY-VALUE)
(DEFPROP WEDNESDAY WEDNESDAY DAY-VALUE)
(DEFPROP WEDNESDAY WED DAY-VALUE)
(DEFPROP THURSDAY THURSDAY DAY-VALUE)
(DEFPROP THURSDAY THU DAY-VALUE)
(DEFPROP FRIDAY FRIDAY DAY-VALUE)
(DEFPROP FRIDAY FRI DAY-VALUE)
(DEFPROP SATURDAY SATURDAY DAY-VALUE)
(DEFPROP SATURDAY SAT DAY-VALUE)
(DEFPROP SUNDAY SUNDAY DAY-VALUE)
(DEFPROP SUNDAY SUN DAY-VALUE)
(DEFPROP JANUARY 1 MONTH-VALUE)
(DEFPROP JAN 1 MONTH-VALUE)
(DEFPROP FEBRUARY 2 MONTH-VALUE)
(DEFPROP FEB 2 MONTH-VALUE)
(DEFPROP MARCH 3 MONTH-VALUE)
(DEFPROP MAR 3 MONTH-VALUE)
(DEFPROP APRIL 4 MONTH-VALUE)
(DEFPROP APR 4 MONTH-VALUE)
(DEFPROP MAY 5 MONTH-VALUE)
(DEFPROP JUNE 6 MONTH-VALUE)
(DEFPROP JUN 6 MONTH-VALUE)
(DEFPROP JULY 7 MONTH-VALUE)
(DEFPROP JUL 7 MONTH-VALUE)
(DEFPROP AUGUST 8 MONTH-VALUE)
(DEFPROP AUG 8 MONTH-VALUE)
(DEFPROP SEPTEMBER 9 MONTH-VALUE)
(DEFPROP SEP 9 MONTH-VALUE)
(DEFPROP SEPT 9 MONTH-VALUE)
(DEFPROP OCTOBER 10. MONTH-VALUE)
(DEFPROP OCT 10. MONTH-VALUE)
(DEFPROP NOVEMBER 11. MONTH-VALUE)
(DEFPROP NOV 11. MONTH-VALUE)
(DEFPROP DECEMBER 12. MONTH-VALUE)
(DEFPROP DEC 12. MONTH-VALUE)
(DEFUN TIME:PARSE-WORD-INTERNAL ()
(DECLARE (SPECIAL CHARS))
(DO ((L NIL (CONS C L))
(C (CAR CHARS) (CAR CHARS)))
((AND (OR (< C #/A) (> C #/Z))
(OR (< C #/a) (> C #/z)))
(IMPLODE (NREVERSE L)))
(SETQ C (IF (AND (NOT (< C #/a))
(NOT (> C #/z)))
(- C #.(- #/a #/A))
C))
(POP CHARS)))
(DEFUN TIME:PARSE-NUMBER-INTERNAL ()
(DECLARE (SPECIAL CHARS))
(DO ((FLAG NIL T)
(NUM 0 (+ (- (POP CHARS) #/0) (* NUM 10.))))
((NOT (MEMQ (CAR CHARS)
'(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)))
(AND FLAG NUM))))
(DEFUN GOTO MACRO (X)
#+DEBUG `(PROGN (FORMAT T "~&TO ~A N=~D. ~D//~D//~D ~D:~D:~D"
',(CADR X) N O D Y H M S)
(GO ,(CADR X)))
#-DEBUG `(GO ,(CADR X)))
(DEFUN TIME:PARSE-LIST (STRING)
(LET ((CHARS (EXPLODEN STRING))
/0 /1
(S -1) (M -1) (H -1)
(D -1) (O -1) (Y -1)
(Q 0.) (W NIL) (N -1) (X 0.) (R 0.))
(DECLARE (SPECIAL CHARS S M H D O Y))
(PROG ()
MAIN
(DO () ((OR (NULL CHARS)
(NOT (MEMBER (CAR CHARS)
'(#/( #/) #/- #\TAB #\SPACE #\LF #\CR)))))
(POP CHARS))
(IF (NULL CHARS) (GOTO RET))
(WHEN (= (CAR CHARS) #/,) ;Watch for MONTH DAY, YR
(POP CHARS)
(WHEN (NOT (MINUSP O))
(WHEN (NOT (MINUSP N))
(WHEN (MINUSP D)
(SETQ D N)
(SETQ N -1))))
(GOTO MAIN))
(LET ((NUM (TIME:PARSE-NUMBER-INTERNAL)))
(WHEN NUM
(IF (NOT (MINUSP N)) (GOTO SYN))
(SETQ N NUM)
(GOTO NUM)))
(SETQ /0 (TIME:PARSE-WORD-INTERNAL))
(WHEN (SETQ /1 (GET /0 'MONTH-VALUE))
(WHEN (NOT (MINUSP N))
(SETQ D N)
(SETQ N -1))
(SETQ X (LOGIOR X 2.))
(SETQ O /1)
(GOTO MAIN))
(WHEN (SETQ /1 (GET /0 'DAY-VALUE))
(SETQ W /1)
(GOTO MAIN))
(IF (EQ /0 'PM) (GOTO EVE))
(GOTO NOT-EVE)
EVE
(COND ((MINUSP H)
(IF (OR (MINUSP N) (PLUSP (- N 12.))) (GOTO SYN))
(SETQ H N)
(SETQ N -1.))
((NOT (MINUSP N)) (GOTO SYN)))
(IF (= H 12.) (SETQ H 0.))
(SETQ H (+ H 12.))
(GOTO MAIN)
NOT-EVE
(IF (EQ /0 'AM) (GOTO MORN))
(GOTO NOT-MORN)
MORN
(COND ((MINUSP H)
(IF (OR (MINUSP N) (PLUSP (- N 12.))) (GOTO SYN))
(SETQ H N)
(SETQ N -1.))
((NOT (MINUSP N)) (GOTO SYN)))
(IF (= H 12.) (SETQ H 0.))
(GOTO MAIN)
NOT-MORN
(IF (EQ /0 'THE) (GOTO MAIN))
(WHEN (SETQ /1 (GET /0 'TIMEZONE-OFFSET))
(SETQ Q (+ Q /1))
(GOTO MAIN))
(IF (MEMQ /0 '(AT IN ON)) (GOTO MAIN))
(IF (MEMQ /0 '(ST ND RD TH)) (GOTO DATE-END))
(WHEN (AND (EQ /0 'O)
(NOT (MINUSP N)))
(UNLESS (AND (= (POP CHARS) #/')
(EQ (TIME:PARSE-WORD-INTERNAL) 'CLOCK))
(GOTO SYN))
(SETQ H N)
(SETQ X (LOGIOR X 1.))
(SETQ N -1.)
(GOTO MAIN))
(IF (EQ /0 'A) (GOTO MAIN))
(WHEN (EQ /0 'NOON)
(IF (PLUSP (LOGAND X 1.)) (GOTO SYN))
(SETQ H 12.)
(SETQ M 0.)
(SETQ S 0.)
(SETQ X (LOGIOR X 1.))
(GOTO MAIN))
(WHEN (EQ /0 'NOW)
(SETQ X (LOGIOR X 1.))
(GOTO MAIN))
(WHEN (EQ /0 'TODAY)
(GOTO MAIN))
(WHEN (EQ /0 'TOMORROW)
(SETQ Q (+ Q 24.))
(GOTO MAIN))
(WHEN (EQ /0 'YESTERDAY)
(SETQ Q (- Q 24.))
(GOTO MAIN))
(WHEN (EQ /0 'HENCE)
(SETQ X (LOGIOR X 1.))
(SETQ /0 'AFTER))
(WHEN (MEMQ /0 '(AFTER FROM))
(IF (NOT (MINUSP N)) (GOTO SYN))
(SETQ Q (+ Q R))
(SETQ R 0.)
(GOTO MAIN))
(WHEN (MEMQ /0 '(AGO BEFORE))
(IF (NOT (MINUSP N)) (GOTO SYN))
(SETQ Q (- Q R))
(SETQ R 0.)
(GOTO MAIN))
(WHEN (EQ /0 'OF)
(IF (NOT (PLUSP R)) (GOTO MAIN))
(IF (NOT (ZEROP (\ R 24.))) (GOTO SYN))
(SETQ Q (+ Q (- R 24.)))
(SETQ R 0.)
(GOTO MAIN))
(WHEN (MEMQ /0 '(WK WKS WEEK WEEKS))
(SETQ R (+ R (* (IF (MINUSP N) 1 N) 168.)))
(SETQ N -1.)
(GOTO MAIN))
(WHEN (MEMQ /0 '(DY DYS DAY DAYS))
(SETQ R (+ R (* (IF (MINUSP N) 1 N) 24.)))
(SETQ N -1.)
(GOTO MAIN))
(WHEN (MEMQ /0 '(HR HRS HOUR HOURS))
(SETQ R (+ R (IF (MINUSP N) 1 N)))
(SETQ N -1.)
(GOTO MAIN))
(WHEN (MEMQ /0 '(AFTERNOON EVENING NIGHT LATE)) (GOTO EVE))
(WHEN (MEMQ /0 '(MORNING EARLY)) (GOTO MORN))
(WHEN (MINUSP N)
(PROG ()
(WHEN (MEMQ /0 '(FIFTY FIFTIETH )) (SETQ N 50.) (GOTO CK-UNITS))
(WHEN (MEMQ /0 '(FORTY FORTIETH )) (SETQ N 40.) (GOTO CK-UNITS))
(WHEN (MEMQ /0 '(THIRTY THIRTIETH)) (SETQ N 30.) (GOTO CK-UNITS))
(WHEN (MEMQ /0 '(TWENTY TWENTIETH)) (SETQ N 20.) (GOTO CK-UNITS))
(GOTO NOTENS)
CK-UNITS
(WHEN (= (CAR CHARS) #/-)
(POP CHARS)
(SETQ /0 (TIME:PARSE-WORD-INTERNAL))
(GOTO UNITS))
(RETURN T)
NOTENS
(WHEN (MEMQ /0 '(NINETEEN NINETEENTH )) (SETQ N 19.) (RETURN T))
(WHEN (MEMQ /0 '(EIGHTEEN EIGHTEENTH )) (SETQ N 18.) (RETURN T))
(WHEN (MEMQ /0 '(SEVENTEEN SEVENTEENTH)) (SETQ N 17.) (RETURN T))
(WHEN (MEMQ /0 '(SIXTEEN SIXTEENTH )) (SETQ N 16.) (RETURN T))
(WHEN (MEMQ /0 '(FIFTEEN FIFTEENTH )) (SETQ N 15.) (RETURN T))
(WHEN (MEMQ /0 '(FOURTEEN FOURTEENTH )) (SETQ N 14.) (RETURN T))
(WHEN (MEMQ /0 '(THIRTEEN THIRTEENTH )) (SETQ N 13.) (RETURN T))
(WHEN (MEMQ /0 '(TWELVE TWELFTH )) (SETQ N 12.) (RETURN T))
(WHEN (MEMQ /0 '(ELEVEN ELEVENTH )) (SETQ N 11.) (RETURN T))
(WHEN (MEMQ /0 '(TEN TENTH )) (SETQ N 10.) (RETURN T))
UNITS
(WHEN (MEMQ /0 '(NINE NINTH))
(IF (MINUSP N) (SETQ N 0.))
(SETQ N (+ N 9.))
(RETURN T))
(WHEN (MEMQ /0 '(EIGHT EIGHTH))
(IF (MINUSP N) (SETQ N 0.))
(SETQ N (+ N 8.))
(RETURN T))
(WHEN (MEMQ /0 '(SEVEN SEVENTH))
(IF (MINUSP N) (SETQ N 0.))
(SETQ N (+ N 7.))
(RETURN T))
(WHEN (MEMQ /0 '(SIX SIXTH))
(IF (MINUSP N) (SETQ N 0.))
(SETQ N (+ N 6.))
(RETURN T))
(WHEN (MEMQ /0 '(FIVE FIFTH))
(IF (MINUSP N) (SETQ N 0.))
(SETQ N (+ N 5.))
(RETURN T))
(WHEN (MEMQ /0 '(FOUR FOURTH))
(IF (MINUSP N) (SETQ N 0.))
(SETQ N (+ N 4.))
(RETURN T))
(WHEN (MEMQ /0 '(THREE THIRD))
(IF (MINUSP N) (SETQ N 0.))
(SETQ N (+ N 3.))
(RETURN T))
(WHEN (MEMQ /0 '(TWO SECOND))
(IF (MINUSP N) (SETQ N 0.))
(SETQ N (+ N 2.))
(RETURN T))
(WHEN (MEMQ /0 '(ONE FIRST A AN))
(IF (MINUSP N) (SETQ N 0.))
(SETQ N (+ N 1.))
(RETURN T))))
(IF (NOT (MINUSP N)) (GOTO NUM))
SYN
(ERROR "Syntax error in time spec" STRING)
DATE-END
(WHEN (AND (PLUSP N)
(MINUSP (- N 32.)))
(SETQ D N)
(SETQ N -1.)
(SETQ X (LOGIOR X 2.))
(GOTO MAIN))
(GOTO SYN)
NUM ;By now, N must have a positive number in it
(WHEN (AND (PLUSP (- N 1899.))
(MINUSP Y))
(SETQ Y (- N 1900.))
(SETQ N -1.)
(SETQ X (LOGIOR X 2.))
(GOTO MAIN))
(WHEN (< N 100.)
(COND ((= (CAR CHARS) #/:)
(IF (NOT (ZEROP (LOGAND X 1.))) (GOTO SYN))
(SETQ X (LOGIOR X 1.))
(IF (PLUSP (- N 24.)) (GOTO SYN))
(SETQ H N)
(SETQ N -1.)
(POP CHARS)
(SETQ M (TIME:PARSE-NUMBER-INTERNAL))
(IF (NOT M) (GOTO SYN))
(SETQ S (IF (NOT (= (CAR CHARS) #/:)) 0
(POP CHARS)
(TIME:PARSE-NUMBER-INTERNAL)))
(IF (NOT S) (GOTO SYN))
(GOTO SYN))
((MEMBER (CAR CHARS) '(#/- #//))
(IF (NOT (ZEROP (LOGAND X 2.))) (GOTO SYN))
(SETQ X (LOGIOR X 2.))
(POP CHARS)
(SETQ /0 (TIME:PARSE-NUMBER-INTERNAL))
(IF (NOT /0) (GOTO NOTDATE))
(IF (PLUSP (- N 12.)) (GOTO SYN))
(SETQ O N)
(SETQ N -1.)
(SETQ D /0)
(SETQ Y (IF (NOT (MEMBER (CAR CHARS) '(#// #/-))) 0
(TIME:PARSE-NUMBER-INTERNAL)))
(IF (NOT Y) (GOTO SYN))
(GOTO MAIN))))
NOTDATE
(WHEN (AND (NOT (MINUSP D))
(NOT (MINUSP O))
(MINUSP Y)
(> N 24.))
(SETQ Y N)
(SETQ X (LOGIOR X 2.))
(SETQ N -1.)
(GOTO MAIN))
(WHEN (AND (NOT (MINUSP Y))
(NOT (MINUSP O))
(NOT (MINUSP D)))
(WHEN (ZEROP (LOGAND X 1.))
(IF (< N 25.) (GOTO MAIN))
(SETQ H (// N 100.))
(SETQ M (- N (* H 100.)))
(SETQ S 0.)
(SETQ X (LOGIOR X 2.))
(SETQ N -1.)
(GOTO MAIN)))
(WHEN (AND (NOT (MINUSP O))
(MINUSP D)
(OR (ZEROP (LOGAND X 1.))
(AND (NOT (MINUSP H))
(NOT (MINUSP M))
(NOT (MINUSP S)))))
(SETQ D N)
(SETQ X (LOGIOR X 2.))
(SETQ N -1.)
(GOTO MAIN))
(GOTO MAIN)
RET
(WHEN (NOT (MINUSP N))
(WHEN (MINUSP D)
(SETQ D N) (SETQ N -1.) (SETQ X (LOGIOR X 2.)) (GOTO DEFAULTS))
(WHEN (MINUSP Y)
(WHEN (> N 24.)
(SETQ Y N) (SETQ N -1.) (SETQ X (LOGIOR X 2.)) (GOTO DEFAULTS)))
(WHEN (MINUSP H)
(SETQ H N) (SETQ N -1.) (SETQ X (LOGIOR X 1.)) (GOTO DEFAULTS))
(GOTO SYN))
DEFAULTS
(LET ((DATE (STATUS DATE))
(DOW (STATUS DOW))
(TIME (STATUS DAYTIME)))
(WHEN (NOT (EQUAL (STATUS DATE) DATE)) ;just after midnite?
(SETQ DATE (STATUS DATE))
(SETQ DOW (STATUS DOW))
(SETQ TIME (STATUS DAYTIME)))
(PROG ()
(WHEN (AND (NOT (ZEROP (LOGAND X 1.)))
(MINUSP H)
(MINUSP M)
(MINUSP S))
(SETQ H (CAR TIME) M (CADR TIME) S (CADDR TIME)))
(IF (MINUSP H) (SETQ H 0.))
(IF (MINUSP M) (SETQ M 0.))
(IF (MINUSP S) (SETQ S 0.))
(WHEN (AND (NOT (ZEROP (LOGAND X 2.)))
(MINUSP Y)
(MINUSP O)
(MINUSP D))
(GOTO TODAY))
(IF (NOT (ZEROP (LOGAND X 2.))) (GOTO NOT-TODAY))
TODAY
(SETQ Y (CAR DATE))
(SETQ O (CADR DATE))
(SETQ D (CADDR DATE))
NOT-TODAY
(IF (MINUSP Y) (SETQ Y (CAR DATE)))
(IF (MINUSP O) (SETQ O (IF (MINUSP D) 1 (CADR DATE))))
(IF (MINUSP D) (SETQ D 1.)))
(WHEN (NOT (ZEROP Q))
(SETQ /0 (+ 1 (* 2 (IF (PLUSP Q) -1 0))))
(SETQ H (+ H Q))
(PROG ()
TOP
(TIME:NORMALIZE-DATE-INTERNAL)
(IF (AND (NOT (MINUSP H)) (< H 24.))
(RETURN T))
(SETQ W NIL)
(SETQ H (+ H (* 24. /0)))
(SETQ D (- D /0))
(GO TOP)))
;W holds specified date or NIL. We ignore that for now...
(RETURN
(LIST S M H D O Y
(TIME:DAY-OF-THE-WEEK-STRING
(TIME:ON-WHAT-DAY-OF-THE-WEEK? D O Y))))))))
(DEFUN TIME:NORMALIZE-DATE-INTERNAL ()
(DECLARE (SPECIAL Y O D H M S))
(PROG (TT X)
(IF (AND (PLUSP D) (MINUSP (- D 29.))) (RETURN T))
(SETQ TT (TIME:ON-WHAT-DAY-OF-THE-WEEK? D O Y))
(COND ((NOT (PLUSP D))
(SETQ O (1- O))
(SETQ D 28.)
(WHEN (ZEROP O) (SETQ O 12.) (SETQ Y (1- Y)))
(SETQ X (TIME:ON-WHAT-DAY-OF-THE-WEEK? D O Y))
(IF (MINUSP (- TT X)) (SETQ TT (+ TT 7)))
(SETQ D (+ D TT (- X))))
(T
(LET ((YY Y) (OO (1+ O)) (DD 1))
(WHEN (> O 12.) (SETQ O 1) (SETQ Y (1+ Y)))
(SETQ X (TIME:ON-WHAT-DAY-OF-THE-WEEK? DD OO YY))
(IF (ZEROP (- X TT)) (SETQ Y YY O OO D DD)))))))

193
src/libdoc/timer.doc Executable file
View File

@@ -0,0 +1,193 @@
-*- TEXT -*-
[Written and maintained by RWK. The source lives in MC:Z;TIMER >]
The TIMER package is a useful tool in making performance measurements.
It currently will measure the amount of time spent inside a given function,
without reference to where it is called from, etc. For example, if you wish
to find out how many times the function FOO gets called and how much time
out of the total it takes in doing a call to BAR, this package will tell
you how much time BAR takes, and how many non-recursive calls to FOO there
were and how much time total was consumed (both runtime and realtime.)
*NOTE* : Due to the problem LISP has with needing DDT symbols in order
to reference certain things, in order to load this file you will need to
do  to DDT before loading. Perhaps someday LISP will be changed to
make this step unnecessary.
Functions: (Note, all functions are SUBRS, not an FSUBR or LSUBR among them)
(TIME-FUNCTION <symbol>)
The symbol *MUST* have one of the following properties: (SUBR, LSUBR, FSUBR).
It cannot handle interpreted functions, although it can handle functions
being called from interpreted code. See theory of operation section.
(UNTIME-FUNCTION <symbol>)
Removes the entry from its internal table of functions, withdraws the timer's
prob, and returns T it was there and NIl otherwise.
(TIME-SUBR <subr> <symbol>)
(TIME-LSUBR <lsubr> <symbol>)
These are like calling (TIME-FUNCTION <symbol>) except that the subr pointer
is not on a functional property. This is for the sake of people who hack
subr pointers. The only purpose of the symbol is for a handle to refer
to the function by with GET-TIME and GET-ALL-TIMES.
Due to LISP internals, it is necessary to distinguish between SUBR'S and
LSUBR'S. If you blow it, UNTIME-FUNCTION it, since your LISP will die
if you call a SUBR as an LSUBR or vice versa.
(INIT-TIMER)
Initializes all counts to zero and ensures that all probes are in place.
Either this or (SET-TIMER) should be done between trials to ensure that
the probes are in.
(SET-TIMER)
Ensures that all probes are in place. When a function is called from
inside the timer, the probes are withdrawn, so that recursive calls will
not get charged multiply and will not incurr the cost of running the timer.
Quits and other abnormal exits out of a function being timed will result in
the probes being left out, rather than being restored when the function
returns. See below.
(GET-TIME <symbol>)
Returns the statistics on it's arguments. Currently in the order
(<count> <run-time> <real-time>)
where the count is the number of non-recursive calls, and the runtime is in
micro-seconds, and the real-time in seconds.
(GET-ALL-TIMES)
Returns an ALIST of the symbols which were given to TIME-FUNCTION and
the results of (GET-TIME on those symbols).
(UNTIME)
Removes timing from all functions, and returns a list of the functions which
were bing timed.
Basic Usage:
Load in the file ((DSK LIBLSP) TIMER FASL) and for each function you
want to time, do (TIME-FUNCTION <name-of-function>). For example,
if you want to find out how much consing an interpreted function does
(interpreted, because compiled function does not contain calls to the
function CONS) you would do (TIME-FUNCTION 'CONS). Then when you had
done this for all the functions on which you wish to take statistics
in a given run, do (INIT-TIMER) and run your test. Thereafter, if
you wish to run additional tests, you should do either (INIT-TIMER)
to reset the times and counts to zero, and to be sure that the probes
are in place, or you should do (SET-TIMER) which will not clear the
counts but will ensure that the probles are in place. (See section
on theory of operation.)
Getting results:
There are two functions for getting back the results. GET-TIME gets
the information for a single function, while GET-ALL-TIMES returns
an ALIST of the function names and the results of a GET-TIME for
that function. It is useful if you forget what functions you have
being timed.
Example of usage:
(load '((liblsp)timer))
143573
(time-function 'equal) ;It can time lisp functions
T
(time-function 'frotz) ;as well as user-functions,
(time-function 'random-user-function) ;providing they're compiled.
T
(time-function 'cons) ;Will not get called from compiled code.
T
(get-all-times) ;just checking what we have here.
((EQUAL 0 0 0.0) (FROTZ 0 0 0.0) (RANDOM-USER-FUNCTION 0 0 0.0) (CONS 0 0 0.0))
(init-timer)
T
(mumble-frotz) ;Do something that calls the functions.
....... ;mumble-frotz could be interpreted, it's
;the functions timed that have to be
;compiled.
(get-time 'cons) ;check the time on one function
(0 0 0.0) ;It hasn't been called yet.
(cons 'a 'b)
(A . B)
(get-time 'cons)
(1 120 0.0) ;The cons called from the interpreter
;is different than the one called by the
;compiler.
(set-timer) ;We want to add the following to the
T ;previous timings. However, either
;SET-TIMER or INIT-TIMER should be done
;if you've been playing around at the
;terminal.
(fumblefoot) ;some more timing testing.
(get-all-times)
((EQUAL 235 298794 3.0) (FROTZ 3 4098080 10000.) (RANDOM-USER-FUNCTION 234 980
5.7) (CONS 1 120 0.0))
(UNTIME-ALL) ;Don't want these anymore. Removes probes.
-------------------------------------------------------------------------------
Theory of operation:
This package operates by clobbering the first two instructions of the code to
be a call to one of two internal handlers, depending on whether or not it is an
LSUBR. It remembers these instructions in the entry for the function, along
with it's start address (so it can find the entry given the start address, and
so it can easily restore the instructions). It clobbers two instructions
instead of just one because of the posibilities of being NCALLed for number
functions.
On entry the timer's handler will get called, which will unclobber the
first two instructions, and remember the runtime and realtime of entry.
It will also clobber the return address in the manner appropriate for
SUBR's or for LSUBR's, depending, to be the rest of the handler which counts
the time spent in that function and saves that information in the appropriate
slot of the entry for that function. It then replaces the probes (I.e.
re-clobbers the first two instructions) so that future calls will run
the timer.
It can be given pointers to pure subrs, including LISP internals, since
it unpurifies the locations it patches with the probes.
-------------------------------------------------------------------------------
Problems with as-yet unimplemented solutions:
It currently makes no allowances for garbage collections or time spent
in interrupts. I plan to make it subtract out GC time and PDL-overflow
time and ^B-break time and other asynchrounous interrupt time and present
these separately.
There are certain internal routines which this package would be able
to time except there are no subr pointers to them. For example, CONS
called from compiled code, and the various number consers get called with
JSP T, ... rather than via the entry points for compiled code. It would not
be hard to set it up to put in it's probes into these routines and tell
how many of each kind of cons gets done from each function statistics are
taken for.
Similarly, it would often be nice to know A calls B. There could be a slot
or two with indicies of functions already in the table, and the increases
in the counts that these point to would be totaled and stored in another
slot.
Inaccuracies can result with abnormal exits. The solution to this would be
to put in special probes at the entry to the various abnormal-exit stack
unwinders, and parse the REGPDL for pointers to the various TIMER
continuations. It could easily be set up so that these would contain an
index into the table of functions in their left half so that the package
could know what probes to put back before letting the stack-unwinder do
it's thing.
The SUBR/LSUBR dichotomy might be eliminated by checking the stack: Either (P)
or (P)+(T) must contain the return address, T negative. Unless it was JRST'd
to, the this should be one instruction after the instruction that called us.
If this heuristic is good enough, it would be a win for both this and for
STL's breakpoints hackery.
For A calls B timing tests, it should keep track of how many times it
gets called. The number of times the timer gets called while in the
subject function should be multiplied times some magic constant and
subtracted from the total.

133
src/libdoc/trap.kmp7 Executable file
View File

@@ -0,0 +1,133 @@
;;; -*- Mode: Lisp; IBase: 10.; -*-
;;; TRAP: A library for trapping errors at runtime
;;; (AWAIT val [pred])
;;;
;;; Sets up an EVALHOOK which looks for any evaluation or subevaluation
;;; which results in value, retval, which answers non-() to the test
;;; (FUNCALL pred retval val)
;;;
;;; The function pred defaults to #'EQ, for efficiency.
;;;
;;; Since it works by EVALHOOK, can work only on return values that go
;;; through the interpreter. Can't find such values in compiled code.
;;;
;;; Since Lisp resets EVALHOOK to NIL in breakpoints and globally, when
;;; a ^G or error quit is done, the effect of AWAIT may be fleeting. If
;;; it doesn't seem to be working, check to see that EVALHOOK has not
;;; been reset to NIL.
;;;
;;; Sample usage:
;;;
;;; (AWAIT 'FOO)
;;; => T
;;; (LIST (IMPLODE '(F O O)) 'BAR)
;;; ;BKPT Found It!
;;; (EVALFRAME NIL)
;;; => (APPLY -21746 (AWAIT-EVALHOOK ((IMPLODE (QUOTE (F O O))))) -7767)
;;; P
;;; => (FOO BAR)
;;;
(DECLARE (SPECIAL AWAIT-VALUE AWAIT-PREDICATE))
(DEFVAR AWAIT-PREDICATE () "Function to use in recognition of awaited values")
(DEFVAR AWAIT-VALUE () "Value being awaited")
(DEFUN AWAIT-EVALHOOK (EVAL-HOOK-VAR)
(LET ((RETURN-VALUE (EVALHOOK EVAL-HOOK-VAR 'AWAIT-EVALHOOK)))
(COND ((FUNCALL AWAIT-PREDICATE RETURN-VALUE AWAIT-VALUE)
(LET ((ARGS EVAL-HOOK-VAR))
(BREAK "Found it!" T))))
RETURN-VALUE))
(DEFMACRO AWAIT (&OPTIONAL (VAL () VAL?) (PRED '#'EQ))
(COND (VAL?
`(PROGN (SETQ AWAIT-PREDICATE ,PRED
AWAIT-VALUE ,VAL
EVALHOOK #'AWAIT-EVALHOOK)
T))
(T
(SETQ EVALHOOK ()))))
;;; (MAR-TRACE sym)
;;;
;;; sym is not evaluated. It should be a lisp symbol.
;;;
;;; Initializes a hardware trap on writes to the value cell of sym.
;;; Any attempt to set this variable from either compiled or interpreted
;;; code, including special variable binding in compiled code, will fire
;;; an interrupt to let you know.
;;;
;;; If the variable MAR-BREAKP is
;;; T Then a Lisp breakpoint will happen automatically.
;;; () Then a Lisp breakpoint will not happen, but
;;; notification will be typed out.
;;; QUERY Then Lisp will query if you want a breakpoint.
;;; This is the default behavior.
;;;
;;; Sample usage:
;;;
;;; (MAR-TRACE FOO)
;;; => T
;;; (SETQ FOO 5)
;;; ;Variable FOO being set to 5
;;; ;*** Break? (Y or N) Y (Yes)
;;; ;BKPT FOO
;;; (BAKTRACE)
;;; BAKTRACE
;;; MAR-HANDLER_ SETQ_
;;; => NIL
;;; P
;;; => 5
;;; (MAR-UNTRACE)
;;; => T
;;;
(DEFVAR MAR-BITS 2. "See .INFO.;LISP NEWS for info on bits")
(DEFVAR MAR-BREAK () "Handler to call on MAR interrupts")
(DEFVAR MAR-BREAKP 'QUERY "Ask before breaking")
(DEFVAR MAR-VARIABLE () "Variable being traced")
(SETQ MAR-BREAK #'MAR-HANDLER) ;; Lisp System variable. Was initially ()
(DEFUN MAR-HANDLER (())
(SSTATUS MAR MAR-BITS (MUNKAM (VALUE-CELL-LOCATION MAR-VARIABLE)))
(NOINTERRUPT NIL)
(TERPRI MSGFILES)
(PRINC ";Variable " MSGFILES)
(PRIN1 MAR-VARIABLE MSGFILES)
(PRINC " being set to " MSGFILES)
(PRIN1 (SYMEVAL MAR-VARIABLE) MSGFILES)
(TERPRI MSGFILES)
(*BREAK (AND MAR-BREAKP
(OR (EQ MAR-BREAKP T)
(PROG (CHAR)
(CLEAR-INPUT TYI)
TOP (CURSORPOS 'A TYO)
(PRINC ";**** Break? " TYO)
(SETQ CHAR (TYI TYI))
(COND ((OR (= CHAR #/Y)
(= CHAR #/y)
(= CHAR #\SPACE))
(PRINC " (Yes)" TYO)
(RETURN T))
((OR (= CHAR #/N)
(= CHAR #/n)
(= CHAR #\RUBOUT))
(PRINC " (No)" TYO)
(RETURN NIL))
(T (PRINC " ?? Answer 'Y' or 'N'")
(GO TOP))))))
MAR-VARIABLE))
(DEFMACRO MAR-TRACE (SYM)
`(PROGN (SETQ MAR-VARIABLE ',SYM)
(COND ((NOT (BOUNDP ',SYM)) (SETQ ,SYM 'UNBOUND)))
(SSTATUS MAR MAR-BITS (MUNKAM (VALUE-CELL-LOCATION ',SYM)))
T))
(DEFUN MAR-UNTRACE () (SSTATUS MAR 0 NIL) T)

Some files were not shown because too many files have changed in this diff Show More