github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-15 12:26:27 +00:00
Code Issues Releases Wiki Activity

Built a bunch of missing FASL files from LIBLSP.

Browse Source 
Resolves #1287.
This commit is contained in:
Eric Swenson
2018-10-02 23:18:22 -07:00
parent a53f0aff3c
commit 02d9eb9851
14 changed files with 5509 additions and 24 deletions
Download Patch File Download Diff File Expand all files Collapse all files

104
src/ken/decla2.186 Normal file
View File

@@ -0,0 +1,104 @@
;;-*-lisp-*-
;;the declaration to the compiler for Director system code is here
(declare ;;(macros t) removed since (defun (foo macro) ...) does it for me
(mapex t)
;;want all mapped functions open coded so that macros are never double expanded
(muzzled t) ;;for the time being not worried about number optimations
(setq nfunvars t)) ;;i use funcall to make functional variables explicit
(defun defcomment macro (nil) nil) ;this is useful mostly for tags
(defcomment decla2) ;for tags
(declare (special :penstate :xorstate :eraserstate :heading :colors :pencolor :erasercolor
:last-runtime :xcor :ycor :turtle-windows :outline
:tvrtle-file-name pi-over-180 :e
:last-thing-upped :tvstep :reasonable-size-interpolation
turtle-picture-right turtle-picture-top)) ;;these are tvrtle variables
(declare (special compiled-pattern-of-name ask-all-result)) ;;for expansion of ask-all
(defcomment *lexpr)
(declare
(*lexpr turtlesize tvsize mw hw sw range bearing eval-define dicks-print dicks-prin1 /#princ
director-load merge-suggestions gen-number time-to-walk copy test-part-of-pattern
estimate-time-to-move-character find-screen-coordinate-of ideal-number-of-cycles
some-number-of-cycles estimate-time-for-cycles ask-macro predicate-of-pattern
type print-without-parens princ-without-parens princ+blank insert-receive
update-compiled-transmission compile-cases-cleverly extractor-of-difference
update-all-dependent-selectors update-appropriate-dependent-compiled-transmissions
compile-file compile-files defunize compile-actor make-actor union intersect
collect-all-variable-names collect-all-memory-items super-member))
(defcomment special)
(declare
(special :self :message :compiler-on ? :old-value :new-value :files-already-read
:protected-actors :compile-simple-transmissions :help-storage-place
:default-compilation-target :print-load-messages :reset-default-compilation-target?
:reversed-already? no-value nothing-found :frames-per-second :ticks-per-frame
:compiled-movies :line-length :actors-currently-traced :actor-of-method-being-run
:dont-want-to-see-warnings-from :use-expansions :replace-old-methods
:message-not-understood :actor-not-defined :ask-type-macros :warning-break
:color-tvrtle-file-name :method-being-run :circular-list-of-nils
:actor+skipped-methods :skip-current-method? :collecting-actors :actors-collected
:expansion-number-indicator :maximum-number-of-matching-methods
:make-method-selectors :internal-methods-first
:compilation-target :update-all-dependent-selectors :non-inheritable-variable-names))
(declare (special arg-package-appearance-drawer)) ;;for compiling movies
;;for compiling actors
(declare (special :help-file-object :macros-file-object
:want-to-make-help-file :collecting-actors-in-this-file)
(special :compile-all-together :stuff-not-printed))
(declare (special :insert-methods-at-end :old-macro-form :whole-macro-form))
;;when fast-compile is declared in a file the special compiling macros are activated
(declare
(setq :displace-macro-calls t) ;;so that macro calls are expanded only once
(setq :protected-actors nil) ;;anybody can be redefined while compiling
(cond ((and (boundp 'clever-compile)
clever-compile) ;;on the c switch in compiler version 769 and >
(setq errset t) ;since bugs pop up so often
((lambda (*rset nouuo)
(cond ((status features director-loader)) ;;already loaded
(t (load '|ai:ken;ken lisp|)
(load '|ai:ken;load|)
(director '(ani direct))))) ;;both systems should be available
nil nil)
(setq :compile-all-together nil) ;;so that it makes Macros, Depends and Help
(coutput (append '(comment fast compiling) (status crfile)))
(or (member (full-file-name (status crfile)) :files-already-read)
(director-load-and-return-actors (status crfile) '(to define its actors)))
(compiler-switch t)
(setq :reset-default-compilation-target? t ;;this is the default and should
:default-compilation-target 'something) ;;be reset in the file
(setq :use-expansions nil))))
(declare (or (status features gcdemn) (load '|ken;gcdemn|)))
(declare (cond ((not (status features dicks-printer))
(load '|liblsp;#print|)
(sstatus features dicks-printer))))
(declare (or (status features henrys-read-macros) (load '|ken1;reamac|)))
(declare (or (status features macro-expansion) (load '|ken1;expmac|)))
;;(declare (or (status features henrys-macros) (load '|ken1;hmac|)))
(declare (or (status features director-macros) (load '|ken1;macros|)))
(declare (or (status features kens-utilities) (load '|ken1;util|)))
(declare (or (status features director) (load'|ken1;drect|)))
;;these files are needed to complete macro defintions (ask for example)

15
src/ken/declar.67 Normal file
View File

@@ -0,0 +1,15 @@
;; -*-lisp-*-
;;when compiling this should include decla2 > where the real declarations are
(defun declarations-only-when-needed macro (useless)
(cond ((or (status features ncomplr) ;;old way
(status features complr)) ;;new way
(sstatus feature complr) ;;since some now expect the new way but still might
;;run in an older compiler
(sstatus feature ncomplr) ;;until I recompile my macros and drect >
'(include |ai:ken;decla2 >|))))
(declarations-only-when-needed)

15
src/ken/declar.68 Normal file
View File

@@ -0,0 +1,15 @@
;; -*-lisp-*-
;;when compiling this should include decla2 > where the real declarations are
(defun declarations-only-when-needed macro (useless)
(cond ((or (status features ncomplr) ;;old way
(status features complr)) ;;new way
(sstatus feature complr) ;;since some now expect the new way but still might
;;run in an older compiler
(sstatus feature ncomplr) ;;until I recompile my macros and drect >
'(include |ken;decla2 >|))))
(declarations-only-when-needed)

4251
src/libdoc/#print.rcw3 Normal file
View File

File diff suppressed because it is too large Load Diff

50
src/libdoc/bssq.gls5 Executable file
View File

@@ -0,0 +1,50 @@
TITLE BUBBLING ASSQ
;;; BSSQ IS LIKE ASSQ, BUT IF IT FINDS A PAIR IT BUBBLES IT
;;; TOWARD THE FRONT OF THE A-LIST BY DOING TWO RPLACA'S.
.FASL
.INSRT SYS:.FASL DEFS
.ENTRY BSSQ SUBR 0003 ;2 ARGS
BSSQ: MOVS C,(B) ;WORKS FOR SECOND ARG = NIL!
HLRZ T,(C)
CAIN T,(A)
JRST BSSQ7
BSSQ0: HLRZ C,C
JUMPE C,BSSQ7
MOVS AR1,(C)
HLRZ T,(AR1)
CAIN T,(A)
JRST BSSQ2
HLRZ AR1,AR1
JUMPE AR1,BSSQ8
MOVS B,(AR1)
HLRZ T,(B)
CAIN T,(A)
JRST BSSQ4
HLRZ B,B
JUMPE B,BSSQ9
MOVS C,(B)
HLRZ T,(C)
CAIE T,(A)
JRST BSSQ0
HLRZ T,(AR1)
HRLM C,(AR1)
HRLM T,(B)
BSSQ7: MOVEI A,(C)
POPJ P,
BSSQ2: HLRZ T,(B)
HRLM AR1,(B)
HRLM T,(C)
BSSQ8: MOVEI A,(AR1)
POPJ P,
BSSQ4: HLRZ T,(C)
HRLM B,(C)
HRLM T,(AR1)
BSSQ9: MOVEI A,(B)
POPJ P,
FASEND

607
src/libdoc/lddt.ejs211 Normal file
View File

@@ -0,0 +1,607 @@
;;; -*-LISP-*-
; NEWIO LISP DDT
;
; This file contains functions to manipulate I.T.S. jobs from LISP using
; the primitives defined in NEWIO LISP. A package for interacting with TECO
; is available as (LIBLSP;LISPT FASL, "LISP INFERIOR TECO")
(COMMENT DECLARATIONS AND SPECIALS)
(DECLARE (SPECIAL NULL *BREAK16-FUNCTION *VALUE *BREAK CURRENT-JOB DDT-READTABLE
J*STADR J*CRUFT SEND-*VALUE-TO-DDT? JOB-STACK
JOB-INTERRUPT-LIST JOB-RING JOB-INFORM CRLF LISP-CURSORPOS
WAITING-FOR-JOB-INT THE-JOB-INPUT-CHANNEL %OPCMD %OPLSP
TTY-PASSING-MSG TTY-RETURN-LIST DEFAULT-TTY-RETURN-LIST
TTY-RETURN-MSG TTY-RETURN-PROMPT? TTY-RETURN-PROMPTER
RETURN-TO-DDT-LIST DEFAULT-RETURN-TO-DDT-LIST TTY-YANKED-FLAG
JOB-HAD-TTY? TTY-YANKED? TTY-VERBOSE JOB-MSG-FILE TTYRETFUN)
(FIXNUM I N (CALC-EFF-ADR FIXNUM))
(*EXPR P JOB-USET-WRITE JOB-USET-READ EXAMINE-JOB DEPOSIT-JOB
KILL-JOB VALUE-STRING *ATTY *DTTY SELECT-JOB)
(*LEXPR G START :JCL SET-JCL CREATE-JOB print-console-msg))
(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)))
(defun prinj macro (x) `(princ ,(cadr x) 'job-msg-file))
(defun terprj macro (x) '(terpri job-msg-file)))
(if (not (getl 'create-job '(lsubr autoload)))
(defprop create-job (humble fasl dsk liblsp) autoload))
(special-init send-*value-to-ddt? t)
; SET UP DEFAULT HANDLERS FOR PARTICULAR INTERRUPTS
(SETQ *VALUE '*VALUE-HANDLER *BREAK '*BREAK-HANDLER ^ZTYPED '^Z-INTERRUPT
PIDCL 'DEFERRED-CALL LISP-CURSORPOS NIL WAITING-FOR-JOB-INT NIL
NULL (ASCII 0) JOB-STACK NIL
J*STADR (GETDDTSYM 'J/.STADR)
J*CRUFT (GETDDTSYM 'J/.CRUFT)
%OPCMD 1_40
%OPLSP 100_18.
TTY-PASSING-MSG NIL
JOB-HAD-TTY? NIL
TTY-YANKED? T
TTY-VERBOSE T
JOB-MSG-FILE (OPEN '|TTY:| '(OUT TTY ASCII)))
(SPECIAL-INIT *BREAK16-FUNCTION NIL)
(SPECIAL-INIT TTY-RETURN-MSG (COND ((STATUS FEATUR MACSYMA)
'|(Console connected with MACSYMA)|)
(T '|(Console connected with LISP)|)))
(SETQ LNULL '(NIL) JOB-RING NIL ;(RPLACD LNULL LNULL)
CRLF '|/
|)
(COMMENT JOB INTERRUPT HANDLER)
; This is the ordinary function for handling job related interrupts.
; When a job is created, this is specified as the interrupt handler,
; e.g. (CREATE-JOB JOB-INTERRUPT-HANDLER <JNAME> <UNAME> NIL)
; The basic dispatch mechanism is that the PIRQC word for the job
; causing the interrupt is decoded into a list of symbolic interrupt
; names. An arbitrator decides which of the interrupts should get
; handled in which order. The handling mechanism is by applying
; the value of the interrupt symbol (if non-nil) to the UUO word.
; The most useful one's are .VAULE and .BREAK.
(DEFUN JOB-INTERRUPT-HANDLER (JOB)
(SETQ JOB-HAD-TTY? (NULL (STATUS TTY))) ; IF LISP DIDN'T, JOB DID
(*DTTY)
(PUSH-SELECT-JOB JOB)
(DO ((UUO (*USET *RSV40))
(INTERRUPT-LIST (ARBITRATE-INTERRUPTS
(PIRQC-DECODE (*USET *RPIRQ) (*USET *RMASK)))
(CDR INTERRUPT-LIST))
(INTBIT) (INTSYM))
((NULL INTERRUPT-LIST))
(SETQ INTBIT (LSH 1 (CDAR INTERRUPT-LIST))
INTSYM (CAAR INTERRUPT-LIST))
(*USET *SAPIR INTBIT)
(COND ((BOUNDP INTSYM) (FUNCALL (SYMEVAL INTSYM) UUO))
(T (RANDOM-CLASS1-INTERRUPT INTSYM)))
(POP-SELECT-JOB))
(IF (AND (STATUS TTY) WAITING-FOR-JOB-INT) ; not very general...
(SETQ WAITING-FOR-JOB-INT NIL))
NULL)
; Arbitrator could do something useful someday
(DEFUN ARBITRATE-INTERRUPTS (INT-LIST) INT-LIST)
(COMMENT PIRQC DECODE)
; Interrupt word decoder. Decodes into a list of symbols whose value
; is a routine to run.
(DEFUN PIRQC-DECODE (PIRQC MASK)
(DECLARE (FIXNUM PIRQC))
(PROG (L)
(RETURN
(COND ((PLUSP PIRQC) ; FIRST WORD INTERRUPTS
(DO ((PIRQC PIRQC (LSH PIRQC -1))
(MASK (BOOLE 6 -1 MASK) (LSH MASK -1))
(DECOD JOB-INTERRUPT-LIST (CDR DECOD))
(I 0 (1+ I)))
((ZEROP PIRQC) L)
(DECLARE (FIXNUM I))
(COND ((PLUSP (BOOLE 1 1 PIRQC MASK))
(SETQ L (CONS (CONS (CAR DECOD) I) L))))))
(T ;2ND WORD INTS
(DO ((PIRQC PIRQC (LSH PIRQC -1))
(I 0 (1+ I)))
((> I 17))
(IF (PLUSP (BOOLE 1 1 PIRQC))
(SETQ L (CONS
(CONS (IMPLODE
(NCONC (EXPLODEN 'IOCH) (EXPLODEN (1- I))))
I)
L))))
(DO ((PIRQC (BOOLE 1 377777 (LSH PIRQC -18.)) (LSH PIRQC -1))
(I 0 (1+ I)))
((> I 7) L)
(IF (PLUSP (BOOLE 1 1 PIRQC))
(SETQ L (CONS
(CONS (IMPLODE
(NCONC (EXPLODEN 'INF) (NCONS (+ 60 I))))
(+ 18. I))
L)))))))))
(COMMENT RANDOM INTERRUPTS (UN-HANDLED))
; If we don't want to bother figuring out what to do, just punt informatively
(DEFUN RANDOM-CLASS1-INTERRUPT (INT)
(PRINJ '|INFERIOR CLASS 1 INTERRUPT - |)
(PRINJ INT)
(TERPRJ)
null)
; If ^Z typed ...
(DEFUN ^Z-INTERRUPT (DUMMY) (DECLARE (FIXNUM DUMMY))
(SETQ DUMMY DUMMY)
(DO NIL ((ZEROP (LISTEN T))) (TYI))) ; GOBBLE TYPE-AHEAD
(DEFUN DEFERRED-CALL (DUMMY) (SETQ DUMMY DUMMY))
(DEFUN CALC-EFF-ADR (ADR)
(DECLARE (FIXNUM ADR))
((LAMBDA (@ X Y) (DECLARE (FIXNUM @ X Y))
(OR (ZEROP X)
(SETQ Y (BOOLE 1 777777
(+ Y (EXAMINE-JOB X)))))
(COND ((ZEROP @) Y)
(T (CALC-EFF-ADR (EXAMINE-JOB Y)))))
(BOOLE 1 ADR 20_22)
(BOOLE 1 17 (LSH ADR -22))
(BOOLE 1 777777 ADR))); .VALUE Handler.
(COMMENT *VALUE HANDLER)
(DEFUN *VALUE-HANDLER (UUO)
(COND ((ZEROP (BOOLE 1 777777 UUO)) (*VALUE0))
(T (*VALUE-STRING (GET-STRING (BOOLE 1 777777 UUO))))))
; A simple return with no information. (SHOULD TELL WHICH JOB!!)
(DEFUN *VALUE0 NIL (PRINC0 '|.VALUE 0.| job-msg-file) (TERPRI job-msg-file) NULL)
; A return with a request for action in the form of a string. (SHOULD BE IMPROVED)
(DEFUN *VALUE-STRING (VST)
(COND ((EQUAL VST '|:PROCED |) (CONTINUE-JOB NIL))
((EQUAL VST '|:KILL |) (PRINJ '|:KILL |) (KILL-JOB))
((= 33 (GETCHARN VST 1)) (EVAL (READLIST (CDR (EXPLODEN VST)))))
(SEND-*VALUE-TO-DDT?
(COND ((NOT (EQ T SEND-*VALUE-TO-DDT?))
(PRINJ '|Inferior .VALUE = "|) (PRINJ VST)
(PRINJ '| "|) (TERPRJ) (PRINJ '|Feed commands to DDT?: |)
(COND ((NOT (MEMQ (let ((READTABLE
(ARRAY NIL READTABLE)))
(SETSYNTAX 15 500500 15)
(READ))
'(Y YES T)))
(SETQ VST NIL)))))
(COND (VST (setq tty-return-prompt? nil)
(nointerrupt nil)
(let ((tty-return)) (VALRET VST))))
(CONTINUE-JOB JOB-HAD-TTY?))
(T (PRINC0 '|; Inferior .VALUE ignored.|) (TERPRI)
(CONTINUE-JOB JOB-HAD-TTY?))))
; Get a string from the memory of the current job as an exploded list
(DEFUN GET-STRING (LOC) (MAKNAM (VALUE-STRING LOC))) ; REWRITE USING EXAMINE-JOB
(DEFUN VALUE-STRING (ADR)
((LAMBDA (FILE)
(FILEPOS FILE (* ADR 5))
(DO ((C (TYI FILE) (TYI FILE))
(L NIL (CONS C L)))
((ZEROP C) (CLOSE FILE) (NREVERSE L))
(DECLARE (FIXNUM C))))
(OPEN CURRENT-JOB '(IN BLOCK ASCII))))
(COMMENT JOB CONTROL FUNCTIONS)
; Deposit JCL in the job.
(DEFUN PUT-JCL (LOC JCL)
(IF (AND JCL (NOT (ATOM JCL))) (SETQ JCL (MAKNAM (MAPCAN 'EXPLODEC JCL))))
(IF JCL
(DO ((I LOC (1+ I)) (L (PNGET JCL 7) (CDR L)))
((NULL L) (DEPOSIT-JOB I 0))
(DEPOSIT-JOB I (CAR L)))))
(DEFUN SET-JCL N
(IF (NULL CURRENT-JOB) (ERROR '|No job - :JCL |))
(*USET *SOPTI (BOOLE 7 %opcmd (*USET *ROPTI)))
(PROGB ((JCRUFT (MUNKAM (ARRAYCALL FIXNUM CURRENT-JOB J*CRUFT))))
(COND ((NULL JCRUFT)
(SETQ JCRUFT (LIST NIL))
(STORE (ARRAYCALL FIXNUM CURRENT-JOB J*CRUFT)
(MAKNUM JCRUFT))))
(PUTPROP JCRUFT (LISTIFY N) 'JCL))
T)
(DEFUN START-JOB (LOC ATTYP)
(DECLARE (FIXNUM LOC))
(IF (NULL CURRENT-JOB) (ERROR '|No job - START-JOB|))
(IF (NOT (ZEROP LOC)) (STORE (ARRAYCALL FIXNUM CURRENT-JOB J*STADR)
(+ 254_33 (BOOLE 1 777777 LOC))))
(SETQ LOC (JOB-START-ADR CURRENT-JOB))
(IF (ZEROP LOC) (ERROR '|No start address? |))
(*USET *SUPC LOC)
(CONTINUE-JOB ATTYP))
(DEFUN JOB-START-ADR (JOB)
(IF (NOT (EQ CURRENT-JOB JOB)) (SELECT-JOB JOB))
(BOOLE 1 777777 (ARRAYCALL FIXNUM CURRENT-JOB J*STADR)))
(DEFUN SET-JOB-START-ADR (JOB ADDR)
(STORE (ARRAYCALL FIXNUM JOB J*STADR) (BOOLE 1 777777 ADDR)))
(DEFUN CONTINUE-JOB (ATTYP)
(IF (NULL CURRENT-JOB) (ERROR '|No job - CONTINUE-JOB |))
(IF ATTYP
(PROGN (COND (TTY-PASSING-MSG
(print-console-msg TTY-PASSING-MSG)
(CURSORPOS 'E)))
(SETQ LISP-CURSORPOS (CURSORPOS)
TTY-PASSING-MSG NIL
TTY-YANKED? NIL)))
(*USET *SPIRQ 0)
(IF (= 0 (BOOLE 1 777777 (*USET *RUPC)))
(*USET *SUPC (JOB-START-ADR CURRENT-JOB)))
(nointerrupt 'T)
(*USET *SUSTP 0)
(SLEEP .001)
(cond (attyp (%tbnot-off) (*atty)))
(NOINTERRUPT NIL)
NULL)
(DEFUN WAIT-FOR-JOB (JOB) ; WAITS UNTIL JOB HAS STOPPED
(NOINTERRUPT NIL)
(DO ((CURRENT-JOB JOB))
((NOT (ZEROP (*USET *RUSTP))))
(WAIT-FOR-JOB-INT JOB))
(*DTTY) T)
(DEFUN MAKE-JOB (JNAME)
(let ((^W T))
(CREATE-JOB 'JOB-INTERRUPT-HANDLER 'CHANNEL-INT-HANDLER
JNAME (STATUS UNAME))))
(DEFUN DISOWN-JOB (JOB)
(IF (NOT (EQ CURRENT-JOB JOB)) (SELECT-JOB JOB))
(IF (AND WAITING-FOR-JOB-INT (EQ JOB WAITING-FOR-JOB-INT))
(SETQ WAITING-FOR-JOB-INT NIL))
(*USET *SPIRQ 0)
(*USET *SOPTI (BOOLE 2 %OPLSP (*USET *ROPTI)))
(PROG2 NIL (NULL (SYSCALL 0 'DISOWN THE-JOB-INPUT-CHANNEL))
(KILL-JOB))) ; flush the job
; generally useful DDT commands
(DEFUN :CONTIN NIL (CONTINUE-JOB T) NULL)
(DEFUN P NIL (TERPRI) (:CONTIN))
(DEFUN :START N (START-JOB (COND ((ZEROP N) 0) (T (ARG 1))) T) NULL)
(DEFUN G N (TERPRI) (APPLY '/:START (LISTIFY N)))
(DEFUN :DISOWN NIL (DISOWN-JOB CURRENT-JOB))
(COMMENT
; DDT LIKE COMMANDS
(ARRAY DDT-READTABLE READTABLE)
(SETQ DDT-READTABLE (GET 'DDT-READTABLE 'ARRAY))
(let ((READTABLE DDT-READTABLE))
(SETSYNTAX '/ 'MACRO 'DDT-ALTMODE-MACRO)
(SETSYNTAX '/: 'MACRO 'DDT-COLON-MACRO)
(SETSYNTAX 15 601540 15)
(SSTATUS TTYREAD NIL))
(DEFUN DDT () (DO ((READTABLE DDT-READTABLE)) (NIL) (PRINT (EVAL (READ)))))
(DEFUN DDT-ALTMODE-MACRO (X) X) ; USE PRE SCAN??
(DEFUN DDT-COLON-MACRO (X) X)
(DEFUN :JCL N (APPLY 'SET-JCL (LISTIFY N)))
(DEFUN :PROCEED NIL (CONTINUE-JOB NIL) '*)
(DEFUN ^P NIL (TERPRI) (:PROCEED))
(DEFUN :GZP NIL (START-JOB 0 T) '*)
(DEFUN J N
(COND ((= 0 N)
(COND (JOB-RING (SETQ JOB-RING (CDR JOB-RING))
(SELECT-JOB (CAR JOB-RING)) (CAR JOB-RING))))
(T (COND ((MEMQ (ARG 1) JOB-RING)
(DO NIL ((EQ (ARG 1) (CAR JOB-RING)))
(SETQ JOB-RING (CDR JOB-RING)))
(SELECT-JOB (CAR JOB-RING)) (CAR JOB-RING))
(T (SET (ARG 1)
(CADR (CREATE-JOB 'JOB-INTERRUPT-HANDLER
'JOB-CHANNEL-HANDLER
(ARG 1)
(STATUS USERID))))
(SETQ JOB-RING
(CDR (RPLACD JOB-RING
(CONS CURRENT-JOB (CDR JOB-RING))))))))))
(DEFUN J FEXPR (X) (SET (CAR X) (CAR JOB-RING)))
) ; END OF COMMENTED OUT CODE
(DEFUN *BREAK-HANDLER (UUO)
(DECLARE (FIXNUM AC EFF UUO))
(PROG (AC EFF)
(SETQ AC (BOOLE 1 17 (LSH UUO -23.)) EFF (BOOLE 1 777777 UUO))
(COND ((= AC 16) (*BREAK16-HANDLER EFF))
((= AC 12) (*BREAK12-HANDLER EFF))
(T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC)))
(PRINJ '|>>.BREAK |) (PRINJ AC) (PRINJ '/,) (PRINJ EFF) (TERPRJ)))))
(DEFUN *BREAK16-HANDLER (EFF)
(COND ((PLUSP (BOOLE 1 100000 EFF))
(COND (*BREAK16-FUNCTION (APPLY *BREAK16-FUNCTION (LIST EFF)))))
((PLUSP (BOOLE 1 40000 EFF))
(PRINJ '|:KILL |) (KILL-JOB) CRLF)
((PLUSP (BOOLE 1 24000 EFF)) (KILL-JOB) CRLF)
(T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC)))
(PRINJ '|>>.BREAK 16,|) (PRINJ EFF) (TERPRJ) CRLF)))
(DEFUN *BREAK12-HANDLER (EFF)
(LET ((TTY-RETURN '(LAMBDA (X) NIL)))
(NOINTERRUPT NIL) ; let tty-return lose
(DO ((CEFF (EXAMINE-JOB EFF)) (TYPE 0)) NIL (DECLARE (FIXNUM CEFF TYPE))
(COND ((= 6 (LSH CEFF -41))
(DO ((I (1+ (BOOLE 6 777777 (LSH CEFF -22))) (1- I))
(LOC (BOOLE 1 777777 CEFF) (1+ LOC)))
((ZEROP I))
(*BREAK12-HANDLER (EXAMINE-JOB LOC))))
((MINUSP CEFF)
(SETQ TYPE (LSH (BOOLE 6 -4_41 CEFF) -22)
CEFF (BOOLE 1 777777 CEFF))
(COND ((= TYPE 1)
(STORE (ARRAYCALL FIXNUM CURRENT-JOB J*STADR)
(+ 254_33 (BOOLE 1 777777 (EXAMINE-JOB CEFF))))
(CONTINUE-JOB JOB-HAD-TTY?))
((= TYPE 3) (CONTINUE-JOB JOB-HAD-TTY?)) ;SYMBOLS
((= TYPE 4) (CONTINUE-JOB JOB-HAD-TTY?)) ;SYMBOLS
((= TYPE 5)
(PUTPROP (MUNKAM (ARRAYCALL FIXNUM CURRENT-JOB
J*CRUFT))
NIL
'JCL) ; CLEAR JCL
(CONTINUE-JOB JOB-HAD-TTY?))
((= TYPE 6) (CONTINUE-JOB JOB-HAD-TTY?)) ; SET DFILE
((= TYPE 7) (CONTINUE-JOB JOB-HAD-TTY?)) ; SYMBOL HACKING
(T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC)))
(PRINJ '|>>.BREAK 12,|) (PRINJ EFF) (TERPRJ) CRLF)))
(T (SETQ TYPE (LSH CEFF -22)
CEFF (BOOLE 1 777777 CEFF))
(COND ((= TYPE 1)
(DEPOSIT-JOB CEFF (ARRAYCALL FIXNUM CURRENT-JOB J*STADR)))
((= TYPE 2) (CONTINUE-JOB JOB-HAD-TTY?))
((= TYPE 3)
(DEPOSIT-JOB CEFF 0)
(CONTINUE-JOB JOB-HAD-TTY?)) ; SYMBOLS
((= TYPE 4)
(DEPOSIT-JOB CEFF 0)
(CONTINUE-JOB JOB-HAD-TTY?)) ; SYMBOLS
((= TYPE 5)
(PUT-JCL CEFF
(GET (MUNKAM (ARRAYCALL FIXNUM CURRENT-JOB
J*CRUFT))
'JCL))
(CONTINUE-JOB JOB-HAD-TTY?))
((= TYPE 6) (CONTINUE-JOB T))
((= TYPE 7)
(DEPOSIT-JOB CEFF 0)
(CONTINUE-JOB JOB-HAD-TTY?))
((= TYPE 10)
(DEPOSIT-JOB (1+ CEFF) (EXAMINE-JOB CEFF))
(DEPOSIT-JOB CEFF 0)
(CONTINUE-JOB JOB-HAD-TTY?))
(T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC)))
(PRINJ '|>>.BREAK 12,|) (PRINJ EFF) (TERPRJ) (SLEEP 60)
(CONTINUE-JOB JOB-HAD-TTY?))))))))
(COMMENT TTY Return Functions)
(special-init default-tty-return-list '((default-tty-return ttyretarg)))
(setq tty-return 'tty-return-handler
tty-return-list default-tty-return-list
tty-yanked-flag T)
(defun tty-return-handler (ttyretarg) (declare (special ttyretarg))
(let ((tty-yanked-flag tty-yanked?))
(setq tty-yanked? T)
(mapc 'eval tty-return-list)
(setq tty-return-list default-tty-return-list)))
(defun default-tty-return (x)
(cond ((and (or (status feature MACSYMA) (= 0 (listen tyi)))
(null tty-yanked-flag))
(cursorpos 'C job-msg-file)
(funcall (if (status feature MACSYMA) 'print-console-msg 'princt)
(if tty-return-msg tty-return-msg
(if (status feature MACSYMA) '|(MACSYMA)|
'|(LISP)|))
job-msg-file)))
(force-output job-msg-file)
(if tty-return-prompt? (funcall tty-return-prompter x))
(setq tty-return-prompt? t)
T)
(defun princt n
(progb ((args (listify n)))
(apply 'princ args)
(apply 'terpri (cdr args))))
(defun clear-tty-return nil
(let ((tty-return '(lambda(x) x))) (declare (special tty-return))
(nointerrupt nil))
(setq tty-return-prompt? T
tty-return-list default-tty-return-list))
(special-init tty-return-prompt? t)
(special-init tty-return-prompter
(cond ((status feature MACSYMA) 'ttyretfun)
(t 'lisp-prompt)))
(defun lisp-prompt (x) (if (eq 'IN x) (progn (princ0 '*) (terpri))))
(special-init default-return-to-ddt-list '((ddt-return)))
(setq return-to-ddt-list default-return-to-ddt-list)
(defun return-to-ddt nil
(mapc 'eval return-to-ddt-list)
(setq return-to-ddt-list default-return-to-ddt-list))
(defun ddt-return nil
(CURSORPOS 'A)
(funcall (if (status feature MACSYMA) 'print-console-msg 'PRINCT)
(if tty-passing-msg tty-passing-msg '|(DDT)|))
(cursorpos 'E)
(setq tty-passing-msg nil tty-yanked? NIL)
(ddt-exit))
(defun ^Z-char-interrupt (file ch) (setq ch ch)
(if (not (= 0 (listen file))) (tyi file))
(return-to-ddt))
(sstatus ttyint 32 '^Z-char-interrupt)
(sstatus ttyint 25 '^Z-char-interrupt)
(defun print-console-msg nargs
(let ((msg (arg 1))
(job-msg-file (cond ((< nargs 2) job-msg-file)
(T (arg 2)))))
(cond ((and tty-verbose (memq 'CURSORPOS (status filemode job-msg-file))
(STATUS FEATURE MACSYMA))
(if (not (= 0 (cdr (cursorpos)))) (terpri job-msg-file))
(CURSORPOS 'L)
(CURSORPOS 'H (1- (// (- (LINEL JOB-MSG-FILE) (flatc msg)) 2)))))
(cond (tty-verbose
(princ msg job-msg-file)
(terpri)))
T))
(DEFUN PUSH-SELECT-JOB (JOB)
(SETQ JOB-STACK (CONS CURRENT-JOB JOB-STACK))
(SELECT-JOB JOB))
(DEFUN POP-SELECT-JOB NIL
(DO NIL
((NULL JOB-STACK))
(IF (JOBP (CAR JOB-STACK)) ; FILTER DEAD JOBS
(RETURN (SELECT-JOB (CAR JOB-STACK))))
(IF (EQ (CAR JOB-STACK) WAITING-FOR-JOB-INT)
(SETQ WAITING-FOR-JOB-INT NIL))
(SETQ JOB-STACK (CDR JOB-STACK))))
; LIST OF PARTICULAR INTERRUPT HANDLERS
(SETQ JOB-INTERRUPT-LIST
'(TYPEIN
^ZTYPED
BADPI
AROV
340DPY
ILOPR
SYSDED
*VALUE
IOC
ILUAD
*BREAK
1PROC
SLOWCLOCK
MPV
MAR
LTPEN
PDLOV
CLI
RESTR
SYSDBG
ARMTP1
ARMTP2
ARMTP3
SYSUUO
PURINS
PURPG
ARFOV
PARERR
PITTY
PIATY ; JOB GOT TTY BACK
PIDCL ; DELAYED CALL
<4/.5>
<4/.6>
RUNTIM
REALTM
))
(Comment Functions to interface with ITS)
(OR (GETDDTSYM T)
((LAMBDA (TTY-RETURN) (VALRET '|/î:SL /î:VP |)) NIL))
(lap %TBNOT-OFF subr)
(movei t tt)
(hrli t 2) ; .RTTY
(*suset 0 t) ; read it
(tlz tt 4000) ; clear %tbout
(tlo t 400000) ; make into .STTY
(*suset 0 t) ; set it
(movei 1 't) ; return T
(popj p)
()
;; takes a job object and waits for an interrupt on that job
(lap wait-for-job-int subr)
(args wait-for-job-int (nil . 1))
(movem a (special waiting-for-job-int))
(movei a (special waiting-for-job-int))
(skipe 0 0 a)
(*hang 0)
(movei A 'T)
(popj p)
()
(lap jobp subr) ; is it a valid job object (and open)
(args jobp (nil . 1))
(move t 1 (a))
(movei a nil)
(tlnn t 'tts/.cl)
(movei a 'truth)
(popj p)
()
(lap ddt-exit subr)
(*break 16 300000) ; return with a kerchink
(movei A 'truth)
(popj p)
()

28
src/libdoc/ndone.rvb1 → src/libdoc/ndone.ejs2 Executable file → Normal file
View File

@@ -19,27 +19,27 @@
(SKIPA)
(ENTRY COMPLR-ERROR SUBR)
(ARGS COMPLR-ERROR (NIL . 0))
(MOVE A,(SPECIAL COMPLR-ERROR-MESSAGE))
(MOVE A (SPECIAL COMPLR-ERROR-MESSAGE))
(SKIPA)
(ENTRY COMPLR-DONE SUBR)
(ARGS COMPLR-DONE (NIL . 0))
(MOVE A,(SPECIAL COMPLR-DONE-MESSAGE))
(MOVE A (SPECIAL COMPLR-DONE-MESSAGE))
(*IOPUSH 15,) ;GUARANTEE A FREE CHANNEL
(*SUSET 0,MYUNAME)
(*OPEN 15,HCTRN-BLOCK)
(JRST 0,DIE)
(*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,)
(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
CHROUT (*IOT 15 A)
(POPJ P) ;PRINTA CALLING CONVENTIONS
MYUNAME (0 0 USLOT 4) ;I.E. ?,,USLOT
HCTRN-BLOCK

19
src/libdoc/prime.pratt1 → src/libdoc/prime.ejs2 Executable file → Normal file
View File

@@ -6,8 +6,9 @@ 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 %
% commented out by ejs: 2018-10-01 since it appears to not work %
% export prime, witness_count, rab $ %
% The only symbols users of the package may access %
special n, n_1, witness_count, w, sw $
@@ -32,15 +33,15 @@ define rab(a,j); % careful exponentiation - %
'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
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
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$
=EXIT$

220
src/libdoc/rdtags.byron3 Normal file
View File

@@ -0,0 +1,220 @@
;; -*-lisp-*-
(include |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)
(and xgp? (princ '|//F[20FG]| output-file))))

3
src/libdoc/step.rich12 → src/libdoc/step.ejs13
View File

@@ -20,6 +20,9 @@
;;; (STEP FOO1 FOO2 ...) (FOO1 FOO2)
;;;
(eval-when (compile)
(setsyntax '/# 'macro nil))
(declare (special evalhook evalhook* evalhook# prinlevel prinlength)
(fixnum i n indent cmd)
(macros nil))

22
src/libdoc/utils.ejs2 Normal file
View File

@@ -0,0 +1,22 @@
(cgol)$
% The following utility routines are of general interest. %
define lexpr cat(n); % concatenates arguments; e.g. (CAT 'AB 'XY) -> ABXY %
implode append{explodec[arg[1 to n]]} $
define mod(a,b); % (MOD A B) is in the range 0 to b-1 even when a < 0 %
let x := a rem b; if minusp a ne minusp b and not zerop x then x+b else x $
define to(aa, b, c); % (TO 5 19 3) = (5 8 11 14 17) %
aa <= b and new x; x := [aa] & while b>=aa:=aa+c do x := cdr(cdr x := [aa]) $
define circ(x); x & cdr last x := x $
special ?&stopwatch$ % used by following timing routine %
define timer(); % (TIMER) = CPU time in seconds since last invoked %
-?&stopwatch + ?&stopwatch := runtime()/1000000 $
=exit$