github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-28 21:01:16 +00:00
Code Issues Releases Wiki Activity

Added INQUIR, the user account management program.

Browse Source
This commit is contained in:
Eric Swenson
2016-11-30 15:30:19 -08:00
parent e1a465ec25
commit af866af9c7
19 changed files with 4051 additions and 8 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
src/_mail_/names.2006
View File

@@ -48,7 +48,7 @@
;; UPDATE-INQUIR@AI UPDATE-INQUIR@MC
;; UPDATE-INQUIR@ML
;;UPDATE-INQUIR@MD
UPDATE-INQUIR@ES
UPDATE-INQUIR@DB
))
(UPDATE-INQUIR (EQV-LIST ([INQUIRE;INQUPD RECORD] (R-OPTION APPEND))
[INQUIR;.UPD1. >]
@@ -70,7 +70,7 @@
;; The entry for "*" is the only one which varies in the NAMES file for
;; each site.
(* (R-OPTION NOTDIST) (EQV-LIST *ES))
(* (R-OPTION NOTDIST) (EQV-LIST *DB))
;; *msg mailing lists -- see .MAIL.;BBOARD INFO for accepted policy on
;; which list to use for what purpose.
;(*MIT (R-OPTION NOTDIST)
@@ -79,7 +79,7 @@
; (EQV-LIST *ITS *HX *LCS-UVAX *MLSITE *REAGAN *THEORY *WH))
(*TENS (R-OPTION NOTDIST) (EQV-LIST *ITS))
(*ITS (R-OPTION NOTDIST) (EQV-LIST
ES
DB
;;*NX
;; *AI *MC
;; *MD *ML
@@ -104,7 +104,7 @@
;; (*MC (EQV-LIST *MSGS-TO-ITSES))
;; (*ML (EQV-LIST *MSGS-TO-ITSES))
;;(*MD (EQV-LIST *MSGS-TO-ITSES))
(*ES (EQV-LIST *MSGS-TO-ITSES))
(*DB (EQV-LIST *MSGS-TO-ITSES))
(*MSGS-TO-ITSES (R-OPTION NOTDIST) ; This just makes above 4 simpler.
(EQV-LIST
;;(*MSG-SINK@NX (R-OPTION NOTDIST))
@@ -112,7 +112,7 @@
;; (*MSG-SINK@MC (R-OPTION NOTDIST))
;; (*MSG-SINK@ML (R-OPTION NOTDIST))
;; (*MSG-SINK@MD (R-OPTION NOTDIST))
(*MSG-SINK@ES (R-OPTION NOTDIST))
(*MSG-SINK@DB (R-OPTION NOTDIST))
))
; This is final "sink". Mailer converts to filename specially.
(*MSG-SINK (R-OPTION NOTDIST))

284
src/inquir/fake-s.28 Normal file
View File

@@ -0,0 +1,284 @@
;;; -*- Mode:LISP; -*-î
î
;;; FAKE-STRING: Package for manipulating fake strings as real stringsî
î
;;; `fake' string definitions for:î
;;;î
;;; (STRINGP obj) - Returns T if obj is a fake string.î
;;; (CHARACTER s) - Coerces a string to a character.î
;;; (CHAR-UPCASE c) - Uppercases a character.î
;;; (CHAR-DOWNCASE c) - Lowercases a character.î
;;; (STRING-UPCASE s) - Uppercases a string.î
;;; (STRING-DOWNCASE s) - Lowercases a string.î
;;; (STRING-APPEND s1 s2 ...) - Appends any number of strings together.î
î
;;; *ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON* - T or NIL global flag.î
;;; (STRING symbol) - Creates a string.î
;;; (STRING-LENGTH s) - Returns number of chars.î
;;; (SUBSTRING s start &optional end) - Takes substrings.î
;;; (STRING-SEARCH key s1 &optional start end) - Searches for strings.î
î
;;; Package created and maintained by KMP@MC.î
;;; Kludgey enhancements courtesy of CSTACY@MC.î
î
(SSTATUS FEATURE FAKE-S)î
î
(EVAL-WHEN (EVAL COMPILE)î
(IF (NOT (GET 'UMLMAC 'VERSION))î
(LOAD '((DSK LISP) UMLMAC FASL))))î
î
î
;;; Gloabl variable for users to control case sensitivity during comparisons. î
î
(DECLARE (SPECIAL *ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON*))î
î
î
(SETQ *ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON* NIL)î
î
î
;;; (STRINGP x)î
;;;î
;;; Predicate returns true iff x is a fake string, otherwise returns false.î
;;;î
;;; Note: Because of the way Maclisp implements fake strings, SYMBOLP willî
;;; also return true for fake strings. Hence, in any case where î
;;; dispatching is being done on type, do the STRINGP check before theî
;;; SYMBOLP check as in:î
;;;î
;;; (COND ...î
;;; ((STRINGP x) ...) ;Check strings firstî
;;; ((SYMBOLP x) ...) ;Things that aren't STRINGP are `real' symbolsî
;;; ...)î
î
(DEFUN STRINGP (X)î
(AND (SYMBOLP X) (GET X '+INTERNAL-STRING-MARKER)))î
î
;;; (STRING-EQUAL string1 string2)î
;;;î
;;; Predicate compares string1 and string2 returning true iff string1 î
;;; and string2 represent the same string. Case is not significant in î
;;; comparisons.î
î
(DEFUN STRING-EQUAL (S1 S2)î
(IF (FIXP S1) (SETQ S1 (CHAR-UPCASE S1)))î
(IF (FIXP S2) (SETQ S2 (CHAR-UPCASE S2)))î
(COND ((FIXP S1)î
(COND ((FIXP S2) (= S1 S2))î
((SYMBOLP S2)î
(LET ((PNAME (PNGET S2 7.)))î
(AND (NULL (CDR PNAME))î
(= (CAR PNAME) (LSH S1 #o35)))))î
(T (ERROR "Not a string -- STRING-EQUAL" S2))))î
((SYMBOLP S1)î
(COND ((FIXP S2)î
(LET ((PNAME (PNGET S1 7.)))î
(AND (NULL (CDR PNAME))î
(= (CAR PNAME) (LSH S2 #o35)))))î
((SYMBOLP S2)î
(DO ((L1 (PNGET S1 7.) (CDR L1))î
(L2 (PNGET S2 7.) (CDR L2))î
(CHAR1 0.) (CHAR2 0.))î
((NULL L1) (NULL L2))î
(DECLARE (FIXNUM CHAR1 CHAR2))î
(IF (NULL L2) (RETURN NIL))î
(LET ((W1 (FIXNUM-IDENTITY (CAR L1)))î
(W2 (FIXNUM-IDENTITY (CAR L2))))î
(DECLARE (FIXNUM W1 W2))î
(IF (AND (NOT (= W1 W2))î
(DO ((BP #o3507 (- BP #o700)))î
((MINUSP BP) NIL)î
(DECLARE (FIXNUM BP))î
(SETQ CHAR1 (LDB BP W1)î
CHAR2 (LDB BP W2))î
(COND ((NOT *ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON*)î
(IF (NOT (OR (< CHAR1 #/a)î
(> CHAR1 #/z)))î
(SETQ CHAR1 (+ CHAR1 #.(- #/A #/a))))î
(IF (NOT (OR (< CHAR2 #/a)î
(> CHAR2 #/z)))î
(SETQ CHAR2 (+ CHAR2 #.(- #/A #/a))))))î
(IF (NOT (= CHAR1 CHAR2))î
(RETURN T))))î
(RETURN NIL)))))î
(T (ERROR "Not a string -- STRING-EQUAL" S2))))î
(T (ERROR "Not a string -- STRING-EQUAL" S1))))î
î
î
î
î
;;; (CHARACTER x)î
;;;î
;;; Coerces x to be a character in fixnum representation.î
;;; If x is a fixnum, it is returned.î
;;; If x is a symbol, the first character of its pname is returned.î
;;; If x is a fake string, its first character is returned.î
î
(DEFUN CHARACTER (X)î
(COND ((SYMBOLP X) (GETCHARN X 1.))î
((FIXP X) X)î
(T (ERROR "Not a string -- CHARACTER" X))))î
î
;;; (STRING-APPEND string1 string2 string3 ...)î
;;;î
;;; Returns a string which is the concatenation of the given strings.î
î
(DEFUN STRING-APPEND NARGSî
(DECLARE (FIXNUM NARGS))î
(DO ((STRING "" (COND ((FIXP (ARG I)) (FORMAT NIL "~A~C" STRING (ARG I)))î
((SYMBOLP (ARG I)) (FORMAT NIL "~A~A" STRING (ARG I)))î
(T (ERROR "Not a string -- STRING-APPEND" (ARG I)))))î
(I 1 (1+ I)))î
((> I NARGS) STRING)î
(DECLARE (FIXNUM I))))î
î
;;; (STRING-UPCASE string)î
;;;î
;;; Returns an uppercased copy of string.î
î
(DEFUN STRING-UPCASE (STRING)î
(DO ((L (+INTERNAL-GET-PNAME STRING 'STRING-UPCASE) (CDR L))î
(NEW-L NIL))î
((NULL L) (+INTERNAL-MAKE-STRING (NREVERSE NEW-L)))î
(DO ((WORD (FIXNUM-IDENTITY (CAR L)))î
(BP #o3507 (- BP #o700))î
(NEW 0. (DPB CHAR BP NEW))î
(CHAR 0.))î
((MINUSP BP) (PUSH NEW NEW-L))î
(DECLARE (FIXNUM WORD BP NEW CHAR))î
(COND ((NOT (OR (< (SETQ CHAR (LDB BP WORD)) #/a) (> CHAR #/z)))î
(SETQ CHAR (+ CHAR #.(- #/A #/a))))))))î
î
;;; (STRING-DOWNCASE string)î
;;;î
;;; Returns a lowercased copy of string.î
î
(DEFUN STRING-DOWNCASE (STRING)î
(DO ((L (+INTERNAL-GET-PNAME STRING 'STRING-DOWNCASE) (CDR L))î
(NEW-L NIL))î
((NULL L) (+INTERNAL-MAKE-STRING (NREVERSE NEW-L)))î
(DO ((WORD (FIXNUM-IDENTITY (CAR L)))î
(BP #o3507 (- BP #o700))î
(NEW 0. (DPB CHAR BP NEW))î
(CHAR 0.))î
((MINUSP BP) (PUSH NEW NEW-L))î
(DECLARE (FIXNUM WORD BP NEW CHAR))î
(COND ((NOT (OR (< (SETQ CHAR (LDB BP WORD)) #/A) (> CHAR #/Z)))î
(SETQ CHAR (+ CHAR #.(- #/a #/A))))))))î
î
î
;;; (CHAR-UPCASE C)î
;;;î
;;; Returns the character C in uppercase.î
î
(DEFUN CHAR-UPCASE (C)î
(COND ((NOT (FIXP C)) (ERROR "Not a character -- CHAR-UPCASE"))î
((OR (< C #/a) (> C #/z)) C)î
(T (+ C #.(- #/A #/a)))))î
î
;;; (CHAR-DOWNCASE C)î
;;;î
;;; Returns the character C in lowercase.î
î
(DEFUN CHAR-DOWNCASE (C)î
(COND ((NOT (FIXP C)) (ERROR "Not a character -- CHAR-DOWNCASE"))î
((OR (< C #/A) (> C #/Z)) C)î
(T (+ C #.(- #/a #/A)))))î
î
î
;;;; Kludgey enhancements.î
î
;;; (STRING Symbol)î
î
(DEFUN STRING (SYMBOL)î
(IF (NOT (SYMBOLP SYMBOL))î
(ERROR "Not a symbol -- ~A" SYMBOL 'STRING))î
(LET ((FOO (COPYSYMBOL SYMBOL T)))î
(PUTPROP FOO T '+INTERNAL-STRING-MARKER)î
FOO))î
î
î
;;; (STRING-LENGTH String)î
;;;î
;;; Returns the number of characters in String.î
î
(DEFUN STRING-LENGTH (STRING)î
(- (FLATSIZE STRING) 2)) ;; FLATC doesn't work right for strings, sigh.î
î
î
;;; (SUBSTRING String Start &optional End)î
;;; î
;;; Extracts a substring of String, from Start up to End,î
;;; not including End. Origins are zero based.î
;;; If End is not specified, get the rest of the string from Start.î
î
(DEFUN SUBSTRING (STRING START &OPTIONAL END)î
(SETQ STRING (STRING STRING)) ;Coerce so symbols work.î
(IF (NULL END)î
(SETQ END (STRING-LENGTH STRING)))î
(LET ((N 0)î
(RESULT-BP #O3507)î
(NEW-WORD 0)î
(NEW-WORDS))î
(DO ((WORDS (+INTERNAL-GET-PNAME STRING 'SUBSTRING) (CDR WORDS)))î
((NULL WORDS) (STRING-APPEND (+INTERNAL-MAKE-STRING (NREVERSE NEW-WORDS))))î
(DO ((WORD (CAR WORDS) (CAR WORDS))î
(BP #O3507 (- BP #O700))î
(CHAR 0.))î
((MINUSP BP))î
(SETQ CHAR (LDB BP WORD))î
(WHEN (AND (NOT (ZEROP CHAR)) ;;FLUSH NULS.î
(>= N START)î
(< N END))î
(SETQ NEW-WORD (DPB CHAR RESULT-BP NEW-WORD))î
(SETQ RESULT-BP (- RESULT-BP #O700))î
(WHEN (OR (MINUSP RESULT-BP)î
(<= N (STRING-LENGTH STRING)))î
(PUSH NEW-WORD NEW-WORDS)î
(SETQ NEW-WORD 0)î
(SETQ RESULT-BP #O3507)))î
(SETQ N (1+ N))))))î
î
î
;;; This version will probably CONS a lot of list structure insideî
;;; SUBSTRING, but it was the easiest way to write it.î
î
(DEFUN STRING-SEARCH (KEY STRING &OPTIONAL (START 0) END)î
(IF (NULL END)î
(SETQ END (STRING-LENGTH STRING)))î
(COND ((ZEROP (+ (STRING-LENGTH STRING) (STRING-LENGTH KEY)))î
0)î
(T (*CATCH 'FOUND-ITî
(DO ((N START (1+ N)))î
((OR (= N (STRING-LENGTH STRING))î
(> (STRING-LENGTH KEY) (- (STRING-LENGTH STRING) N))î
(= N END))î
NIL)î
(IF (STRING-EQUAL KEY (SUBSTRING STRING Nî
(+ N (STRING-LENGTH KEY))))î
(*THROW 'FOUND-IT N)))))))î
î
î
î
î
î
;;; Utility functions. Not for use by users.î
î
;;; Takes a symbol, fake string, or fixnum and returns its pname.î
î
(DEFUN +INTERNAL-GET-PNAME (STRING FN)î
(COND ((SYMBOLP STRING) (PNGET STRING 7.))î
((FIXP STRING) (NCONS (LSH STRING #o35)))î
(T (ERROR "Not a string -- ~A" STRING FN))))î
î
;;; Takes a pname and returns a fake string.î
î
(DEFUN +INTERNAL-MAKE-STRING (PNAME)î
(SETQ PNAME (PNPUT PNAME NIL))î
(PUTPROP PNAME T '+INTERNAL-STRING-MARKER)î
PNAME)î
î
î
;;; Local Modes:;î
;;; Mode:LISP;î
;;; Lisp IF Indent:2;î
;;; End:;î

41
src/inquir/inquir.(dump) Normal file
View File

@@ -0,0 +1,41 @@
;;; -*- LISP -*-
;;; Init file for dumping out a new version of INQUIR.
(COMMENT) ;magic
(PROGN (CLOSE (PROG1 INFILE (INPUSH -1))) ; Close this init file
(LOAD "DSK: INQUIR; INQUIR FASL")
(SETQ BASE 10. IBASE 10. *NOPOINT ())
(DEFPROP DEBUG ((DSK LIBLSP) DEBUG FASL) AUTOLOAD)
(FORMAT T "~&Dumping: Inquire.~A" (GET 'INQUIR 'VERSION))
(SSTATUS TOPLEVEL '(TOPLEVEL)) ; Init our toplevel
(SSTATUS FEATURE NOLDMSG) ; No load messages after dump
(SETQ GC-OVERFLOW '(LAMBDA (X) T)) ; Prevent GC-OVERFLOW lossage
(ALLOC '(LIST 60000.)) ; Set GC parameters
(ALLOC '(SYMBOL 50000.))
(ALLOC '(FIXNUM 10000.))
(GCTWA) ; Reclaim worthless symbols
(GC) ; GC cruft made during dump
(SSTATUS FLUSH T) ; Share with system LISP
(SUSPEND ":KILL "
(LIST '(DSK INQUIR) 'INQBIN (GET 'INQUIR 'VERSION))) ; Dump
((LAMBDA (FILENAME)
(COND (FILENAME
(COND ((NOT (ERRSET (PROGN
(FORMAT T "~&Loading fix file ~A~%"
(NAMESTRING FILENAME))
(LOAD FILENAME))
T))
(FORMAT T "~&;Bug in patch load. Please report this."))))))
(PROBEF (LIST '(DSK INQUIR) 'INQFIX (GET 'INQUIR 'VERSION))))
(TOPLEVEL))

1351
src/inquir/inquir.182 Normal file
View File

File diff suppressed because it is too large Load Diff

234
src/inquir/lsrrtn.31 Normal file
View File

@@ -0,0 +1,234 @@
;;; -*- Mode: MIDAS -*-î
î
TITLE LSRRTN - LSR1 database interface.î
;Originally by RLB, extended by CSTACY.î
î
SUBTTL Basic definitionsî
î
.FASLî
.INSRT sys:.fasl defsî
.SXEVAL (SSTATUS FEATURE LSRRTN) î
î
;;; Get the system LSR1 database routines.î
î
lsrtns"$$ovly==1 ;Map only a few pages and hack overlaying.î
lsrtns"$$hsnm==1 ;HSNAME lookup.î
lsrtns"$$ulnm==0 ;No last name searching.î
lsrtns"$$ulnp==0 ;No abbrev l.name lookups.î
lsrtns"$$unam==0 ;No name permutations.î
î
lsrtns"a==t ;LSRTNS requires some ACs.î
lsrtns"b==ttî
lsrtns"c==dî
lsrtns"d==rî
lsrtns"e==f î
.INSRT dsk:syseng;lsrtnsî
î
;;; Random utility routines and macros.î
î
;;; Given a Byte pointer in D, return a list of chars in B.î
î
chlp0: setz b, ;start with ()î
chlp: ildb tt,d ;get a charî
jumpe tt,chlpx ;zero terminatesî
jsp t,fxcons ;turn into fixnumî
call 2,.function CONS ;cons onto listî
move b,aî
jrst chlp ;go for another charî
chlpx: popj p, ;all done.î
î
î
;;; Item numbers.î
î
.SXEVA (SETQ I$UNAM #0 ) ;UNAMEî
.SXEVA (SETQ I$NAME #1 ) ;FULL NAMEî
.SXEVA (SETQ I$NICK #2 ) ;NICKNAMEî
.SXEVA (SETQ I$LOCL #3 ) ;LOCAL ITEMSî
.SXEVA (SETQ I$MITA #4 ) ;MIT ADDRESSî
.SXEVA (SETQ I$MITT #5 ) ;MIT TELEPHONE NUMBERî
.SXEVA (SETQ I$HOMA #6 ) ;HOME ADDRESSî
.SXEVA (SETQ I$HOMT #7 ) ;HOME TELEPHONE NUMBERî
.SXEVA (SETQ I$SUPR #10 ) ;SUPERVISOR(S)î
.SXEVA (SETQ I$PROJ #11 ) ;PROJECTî
.SXEVA (SETQ I$DIR #12 ) ;FILE DIR NAMESî
.SXEVA (SETQ I$AUTH #13 ) ;AUTHORIZATIONî
.SXEVA (SETQ I$GRP #14 ) ;GROUP AFFILIATIONî
.SXEVA (SETQ I$REL #15 ) ;RELATION TO GROUPî
.SXEVA (SETQ I$BRTH #16 ) ;BIRTHDAYî
.SXEVA (SETQ I$REM #17 ) ;REMARKSî
.SXEVA (SETQ I$NETA #20 ) ;NETWORK ADDRESSî
.SXEVA (SETQ I$ALTR #21 ) ;USER AND TIME OF LAST ALTERATIONî
.SXEVA (SETQ I$MACH #22 ) ;SUNAME@MACHINE PAIRSî
î
î
SUBTTL Mapping the database.î
î
;;; (LSRMAP <number of pages to use>)î
;;; opens up and maps in the inquir database for looking up people.î
;;; Returns a file object to be passed to other routines.î
;;; Uses GETCOR to reserve address space. Don't try this too many timesî
;;; since the addr space isn't reused.î
î
.ENTRY LSRMAP SUBR 1+1î
jsp t,fxnv1 ;get & save # pages to use, a->ttî
push fxp,ttî
;; (OPEN '|INQUIR;LSR1 >| '(IN))î
movei a,.atom INQUIR/;LSR1/ >î
movei b,.sx (IN)î
call 2,.function OPENî
push p,aî
;; extract I/O channel number from the file array, into TTî
movei tt,f.chanî
move tt,@ttsar(a)î
push fxp,ttî
;; get pages via getcorî
move tt,-1(fxp) ;# pagesî
pushj p,getcor ;request addr space from Lispî
jumpe tt,corlos ;its addr is returned zero if none avblî
idivi tt,2000 ;cvt to page numberî
movn d,-1(fxp) ;get number of pages requested to constructî
hrl tt,d ;aobjn to themî
;; construct args for lsrmapî
move lsrtns"b,tt ;aobjn to free page rangeî
move lsrtns"a,(fxp) ;disk channel numberî
;; Get the INQUIR data base mapped inî
pushj p,lsrtns"lsrmap ;try to map in the data baseî
jrst lsrluz ;no skip if it lostî
;; I guess we won, clean up and return the file object.î
opnbye: sub fxp,[2,,2]î
pop p,aî
popj p,î
î
;;; Return () instead of file obj.î
corlos:î
lsrluz: move a,(p) ;get the file objî
call 1,.function CLOSE ;close itî
setzm (p) ;return ()î
jrst opnbyeî
î
î
SUBTTL Stepping through the database.î
î
;;; The screw with stepping through the database is thatî
;;; LSRDTA and LSRNXT return a core address, not a file address.î
;;;î
;;; For example, you can not search by stepping through the database andî
;;; storing the addresses of the found entries, because succesive LSRNXTsî
;;; will not necessarily leave the entries mapped. Instead, you mustî
;;; process each entry as you find it, and then call LSRNXT.î
î
î
;;; (LSRDTA <file-object>î
;;;î
;;; Returns the core address of the first data entry.î
;;; This can be used to get an initial pointer for LSRNXT.î
;;; Returns -1 if the LSR1 database does not appear to be mapped.î
î
.ENTRY LSRDTA SUBR 1+1î
push p,[fix1] ;Ncallable: (declare (fixnum (lsrnxt ...)))î
; so return machine number in TT.î
movei tt,f.chan ;Pick up disk channel number.î
move lsrtns"a,@ttsar(a)î
move lsrtns"b,lsrtns"datfpgî
imuli lsrtns"b,2000 ;File data page => addr first entryî
pushj p,lsrtns"lsrget ;Map it and get core addr.î
movni lsrtns"b,1 ; Say -1 for lossage.î
move tt,lsrtns"b ;Return value.î
popj p,î
î
;;; (LSRNXT <file-obj> <core address>)î
;;;î
;;; Given the core address of an entry, returns the core address of theî
;;; next sequential entry in the LSR1 database. Returns -1 iff thereî
;;; are no more entries.î
î
.ENTRY LSRNXT SUBR 2+1î
push p,[fix1] ;Ncallable: (declare (fixnum (lsrnxt ...)))î
; so return machine number in TT.î
movei tt,f.chan ;Pick up disk channel number.î
move lsrtns"a,@ttsar(a)î
move lsrtns"b,(b)î
pushj p,lsrtns"lsrnxt ;Get entry into lsrtns"b.î
movni lsrtns"b,1 ; Say -1 for lossage.î
move tt,lsrtns"b ;Return value.î
popj p,î
î
î
SUBTTL Looking up a user.î
î
;;; (LSRUNM <file obj returned by LSRMAP> <uname>)î
;;; Returns a magic number to be passed to LSRITM, etc., or -1 if uname unknown.î
;;; Actually, the "magic number" is the entry's core address returnedî
;;; by the lib subr.î
î
.ENTRY LSRUNM SUBR 2+1î
push p,cfix1 ;NCALLable!î
movei tt,f.chan ;pick up disk channel numberî
move tt,@ttsar(a)î
push fxp,tt ;and save itî
move a,b ;(car (pnget <uname> 6))î
movei b,.atom #6.î
call 2,.function PNGETî
hlrz a,(a)î
move lsrtns"b,(a) ;set up uname in 6bit for lsrunmî
pop fxp,lsrtns"a ;the channelî
pushj p,lsrtns"lsrunm ;get entry addr in lsrtns"bî
movni lsrtns"b,1 ;-1 for lossî
move tt,lsrtns"b ;move to where Lisp wants it.î
popj p,î
î
î
SUBTTL Fetching an item.î
î
;;; (LSRITM <item number> <magic number>)î
;;; returns the <item number> slot of the entry <magic number>î
;;; returned by LSRUNM.î
;;; This file sets the symbols I$UNAM etc to the correct values.î
;;; Look after this function, and in :INFO LIB LSRTNS .î
î
.ENTRY LSRITM SUBR 2+1î
jsp t,fxnv1 ;item number, a->ttî
jsp t,fxnv2 ;address, b->dî
push fxp,d ;save so we don't have to worry about ac corresî
movem tt,lsrtns"aî
pop fxp,lsrtns"bî
pushj p,lsrtns"lsritm ;returns bp in lsrtns"aî
skipa d,[440700,,[0]] ;unless there was no skip: use null string thenî
move d,lsrtns"a ;d is input bpî
pushj p,chlp0î
move a,b ;reverse the list and atomifyî
call 1,.function NREVERSEî
jcall 1,.function IMPLODE ;Return the symbol!î
î
î
SUBTTL HSNAME hackery.î
;;; Most often you want (STATUS HSNAME user) and not LSRHTL.î
î
;;; (LSRHTL <file object> <uname>)î
;;; Returns a symbol which is the hsname of the argument uname.î
;;; Returns NIL if unknown.î
î
.ENTRY LSRHTL SUBR 2+1î
push p,cfix1 ;NCALLable!î
movei tt,f.chan ;pick up disk channel numberî
move tt,@ttsar(a)î
push fxp,tt ;and save itî
move a,b ;(car (pnget <uname> 6))î
movei b,.atom #6.î
call 2,.function PNGETî
hlrz a,(a)î
move lsrtns"a,(a) ;set up uname in 6bit for lsrunmî
pop fxp,lsrtns"b ;the channelî
movei c,lsrtns"hx$nrm ;use the normal table.î
setz lsrtns"c, ;use the local site.î
pushj p,lsrtns"lsrhtl ;get entry addr in lsrtns"bî
jrst [ move d,[440700,,[0]] ; use null string for pretend resultî
jrst lsrht1 ]î
move r,lsrtns"b ;get Bp to user's directory nameî
move d,[440600,,r]î
lsrht1: pushj p,chlp0 ;CONS up list of letters symbol from Bp in Dî
move a,b ;reverse the list and atomifyî
call 1,.function NREVERSEî
jcall 1,.function IMPLODE ;Return the symbol!î
î
FASENDî

BIN
src/inquir/netrtn.fasl Normal file
View File

Binary file not shown.

232
src/inquir/reader.28 Normal file
View File

@@ -0,0 +1,232 @@
;;; -*- LISP -*-î
î
(EVAL-WHEN (EVAL COMPILE) (LOAD '((LIBLSP) TTY FASL)))î
î
(DECLARE (SPECIAL INITIAL-TTY-SPECIFICATIONS SMART-TTY))î
î
(DECLARE (*LEXPR WHERE-TTY-SHOULD-BE))î
î
(COND ((NOT (BOUNDP 'SMART-TTY))î
(SETQ SMART-TTY (NOT (NOT (MEMQ 'CURSORPOS (STATUS FILEM TYO)))))))î
î
(DEFUN SMART-TTY? () SMART-TTY)î
î
(DEFUN BACK-UP-AND-OVERSTRIKE (POS)î
(LET ((INITIAL-POS (CDR (CURSORPOS))))î
(COND ((= INITIAL-POS POS)î
(TYO 10. TYO))î
((> INITIAL-POS POS)î
(DO ((I INITIAL-POS (1- I)))î
((= I POS) T)î
(TYO 8. TYO)î
(TYO 92. TYO)î
(TYO 8. TYO)))î
(Tî
(TYO 10. TYO)î
(DO ((I INITIAL-POS (1+ I)))î
((= I POS) T)î
(TYO 32. TYO))))))î
î
(DEFUN FANCY-RUBOUT (POS CHAR)î
; ((LAMBDA (CURRENT) ;debugging codeî
; (CURSORPOS 23. 0. TYO)î
; (PRINC (LIST 'POS= POS 'ASCII= CHAR) TYO)î
; (PRINC '| --MORE--| TYO)î
; (TYI TYI)î
; (CURSORPOS 23. 0. TYO)î
; (CURSORPOS 'L TYO)î
; (CURSORPOS (CAR CURRENT) (CDR CURRENT) TYO))î
; (CURSORPOS))î
(COND ((= CHAR 10.)î
(CURSORPOS 'U TYO)î
(CURSORPOS 'L TYO))î
((= CHAR 13.)î
(CURSORPOS (1- (CAR (CURSORPOS))) POS)î
(CURSORPOS 'L TYO))î
(Tî
(CURSORPOS NIL POS TYO)î
(CURSORPOS 'L TYO))))î
î
(DEFUN READER$RUBOUT (POS SMART-FLAG CHAR)î
(COND (SMART-FLAG (FANCY-RUBOUT POS CHAR))î
(T (BACK-UP-AND-OVERSTRIKE POS))))î
î
(DEFUN REDISPLAY (LINE PROMPT) (REDISPLAY1 LINE PROMPT))î
î
(DEFUN REDISPLAY1 (LINE PROMPT)î
(COND ((ANDî
(SMART-TTY?)î
(EQ (CAR (WHERE-TTY-SHOULD-BE)) (CAR (CURSORPOS))))î
(CURSORPOS NIL 0. TYO)î
(CURSORPOS 'L TYO))î
(T (CURSORPOS 'A TYO)))î
(COND (PROMPT (PRINC PROMPT TYO))î
(T (CURSORPOS NIL (CDAR (LAST LINE)) TYO)))î
(DO ((L (REVERSE LINE) (CDR L)))î
((NULL L))î
(COND ((ATOM (CAR L))î
(CURSORPOS NIL (LINEL TYO) TYO)î
(PRINC '- TYO)î
(TERPRI TYO))î
(Tî
(RPLACD (CAR L) (CDR (CURSORPOS TYO)))î
(TYO (CAAR L) TYO))))î
(WHERE-TTY-SHOULD-BE (CURSORPOS TYO)))î
î
(DEFUN SCROD-DISPLAY () (NOT (EQUAL (WHERE-TTY-SHOULD-BE) (CURSORPOS TYO))))î
î
(DEFUN WHERE-TTY-SHOULD-BE Xî
(COND ((ZEROP X) (GET 'INPUT-LINE 'WHERE-TTY-SHOULD-BE))î
((= X 1.) (PUTPROP 'INPUT-LINE (ARG 1) 'WHERE-TTY-SHOULD-BE))î
(T (BREAK |(Wrong Number of Args to WHERE-TTY-SHOULD-BE)|))))î
î
(DEFUN ONE-LINE-ONLY (LINE)î
(DO ((L LINE (CDR L))î
(A NIL))î
((NULL L) (REVERSE A))î
(COND ((OR (EQ (CAR L) '<CR>)î
(MEMBER (CAAR L) '(13. 10.)))î
(RETURN (REVERSE A)))î
(T (SETQ A (CONS (CAR L) A))))))î
î
(DEFUN RUBBING-OUT @î
(COND ((ZEROP @) (GET 'INPUT-LINE 'RUBBING-OUT))î
(T (PUTPROP 'INPUT-LINE (ARG 1) 'RUBBING-OUT))))î
î
(SSTATUS TTYINT 23. NIL)î
î
(DEFUN READER$DELETE (LINE PROMPT)î
(PROG (POS CHAR)î
(COND ((NULL LINE)î
(PRINC (ASCII 7.) TYO)î
(RETURN NIL)))î
(COND ((ATOM (CAR LINE))î
(CURSORPOS (1- (CAR (CURSORPOS))) (1- (LINEL TYO)) TYO)î
(WHERE-TTY-SHOULD-BE (CURSORPOS))î
(SETQ LINE (CDR LINE))))î
(SETQ POS (CDAR LINE))î
(SETQ CHAR (CAAR LINE))î
(SETQ LINE (CDR LINE))î
(COND ((SCROD-DISPLAY) (REDISPLAY LINE PROMPT))î
(Tî
(READER$RUBOUT POS (SMART-TTY?) CHAR)))î
(WHERE-TTY-SHOULD-BE (CURSORPOS))î
(RUBBING-OUT T)î
(RETURN LINE)))î
î
(DEFUN ADD (CHAR LINE PROMPT)î
(PROG (POS)î
(SETQ POS (CDAR LINE))î
(COND ((SCROD-DISPLAY) (REDISPLAY LINE PROMPT)))î
(COND ((> (+ (FLATC (ASCII CHAR)) (CDR (CURSORPOS)))î
(LINEL TYO))î
(CURSORPOS NIL (LINEL TYO) TYO)î
(PRINC '- TYO)î
(TERPRI TYO)î
(SETQ LINE (CONS '<CR> LINE))))î
(SETQ LINE (CONS (CONS CHAR (CDR (CURSORPOS))) LINE))î
(COND ((RUBBING-OUT) (UPDATE-DISPLAY)))î
(RUBBING-OUT NIL)î
(TYO CHAR TYO)î
(RETURN LINE)))î
î
(DEFUN UPDATE-DISPLAY ()î
(COND ((NOT (SMART-TTY?)) (TYO 10. TYO))))î
î
(DEFUN CLEAR-SCREEN ()î
(CURSORPOS 'C TYO))î
î
(DEFUN LINE-READ-A-NUMBER (PROMPT TYPE)î
(PROG (NUM)î
TOPî
(SETQ NUM (READER PROMPT '(13.)))î
(SETQ NUMî
(CARî
(ERRSET (READLIST (DELETE '| | NUM))î
NIL)))î
(COND ((NUMBERP NUM)î
(RETURN (COND (TYPE (FUNCALL TYPE NUM))î
(T NUM))))î
(Tî
(CURSORPOS 'A TYO)î
(PRINC '|Data must be numeric. Please retry.| TYO)î
(CURSORPOS 'A TYO)î
(GO TOP)))))î
î
(DEFUN READER (PROMPT TERMINAL)î
(DO-WITH-TTY-OFFî
(PROG (TEMP)î
(PRINC PROMPT TYO)î
(WHERE-TTY-SHOULD-BE (CURSORPOS))î
(SETQ TEMPî
(DO ((C (TYI TYI) (TYI TYI))î
(LINE NIL))î
((MEMBER C TERMINAL) LINE)î
(COND ((= C 127.)î
(SETQ LINE (READER$DELETE LINE PROMPT)))î
((= C 12.)î
(CLEAR-SCREEN)î
(REDISPLAY LINE PROMPT))î
((= C 18.)î
; ((LAMBDA (TEMP)î
; (CURSORPOS 12. 0. TYO)î
; (PRINT (LIST 'LINE= LINEî
; 'ONE= (ONE-LINE-ONLY LINE)))î
; (CURSORPOS (CAR TEMP) (CDR TEMP) TYO))î
; (CURSORPOS))î
(REDISPLAY (ONE-LINE-ONLY LINE) NIL))î
((= C 21.)î
(SETQ LINE (READER$FLUSH-LINE LINE PROMPT)))î
((= C 23.)î
(SETQ LINE (READER$DELETE-WORD LINE PROMPT)))î
(T (SETQ LINE (ADD C LINE PROMPT))))î
(WHERE-TTY-SHOULD-BE (CURSORPOS))))î
(SETQ TEMPî
(DO ((L TEMP (CDR L))î
(A NIL))î
((NULL L) A)î
(COND ((NOT (ATOM (CAR L)))î
(SETQ A (CONS (ASCII (CAAR L)) A))))))î
(RETURN TEMP))))î
î
(DEFUN READER$DELETE-WORD (LINE PROMPT)î
(READER$FLUSH-ALPHA (READER$FLUSH-NON-ALPHA LINE PROMPT) PROMPT))î
î
(DEFUN READER$FLUSH-NON-ALPHA (LINE PROMPT)î
(DO ((L LINE))î
((OR (NULL L) (AND (NOT (ATOM (CAR L))) (ALPHAP (CAAR L)))) L)î
(SETQ L (READER$DELETE L PROMPT))î
(WHERE-TTY-SHOULD-BE (CURSORPOS))))î
î
(DEFUN READER$FLUSH-ALPHA (LINE PROMPT)î
(DO ((L LINE))î
((OR (NULL L) (ATOM (CAR L)) (NOT (ALPHAP (CAAR L)))) L)î
(SETQ L (READER$DELETE L PROMPT))î
(WHERE-TTY-SHOULD-BE (CURSORPOS))))î
î
(DEFUN READER$FLUSH-LINE (LINE PROMPT)î
(DO ((L (AND LINE (READER$DELETE LINE PROMPT))î
(READER$DELETE L PROMPT)))î
((OR (NULL L)î
(AND (NOT (ATOM (CAR L))) (= (CAAR L) 13.)))î
L)))î
î
(DEFUN ALPHAP (X)î
(AND (NUMBERP X)î
(OR (AND (> X 64.) (< X 91.))î
(AND (> X 96.) (< X 123.)))))î
î
(DEFUN READ-ALTMODE (PROMPT)î
(IMPLODE (READER PROMPT '(27.))))î
î
(DEFUN READ-<CR> (PROMPT)î
(IMPLODE (READER PROMPT '(13.))))î
î
(DEFUN READ-SPACE (PROMPT)î
(IMPLODE (READER PROMPT '(32.))))î
î
(DEFUN R ()î
(CURSORPOS 'A TYO)î
(READER '|> | '(13.)))î
î
(DEFPROP READER T LOADED)

462
src/libdoc/comrd.kmp1 Executable file
View File

@@ -0,0 +1,462 @@
;;; -*- LISP -*-
;;; COMRD: A library that implements a completing reader.
;;; Written by KMP some time ago, (obviously before # readmacro
;;; and defmacro were in use in maclisp), moved to LIBDOC by GJC
;;; as this is of general use as a command reader for
;;; interactive programs.
;;; The simplest and most common call will be
;;; (completing-read "prompt-> " '(foo bar baz bomb))
(herald comrd)
(DECLARE (SPECIAL COMPLETING-READER-OBJECT-HEADER)
(*LEXPR *COMPLETING-READ-OPTIONS
*COMPLETING-READ-PROMPT
*COMPLETING-READ-INSTREAM
*COMPLETING-READ-OUTSTREAM
*COMPLETING-READ-AMBIGUITY-ERROR
*COMPLETING-READ-NULL-ERROR
*COMPLETING-READ-COMPLETION-CHARS
*COMPLETING-READ-RETURN-CHARS
*COMPLETING-READ-CASE-CONVERT
*COMPLETING-READ-LAST-CASE
*COMPLETING-READ-OVERRUBOUT-RETURN
*COMPLETING-READ-CHARS-READ))
(SSTATUS TTYINT 23. NIL) ; Turn off ^W as a tty interrupt
(SSTATUS TTYINT 21. NIL) ; Turn off ^U as a tty interrupt
(EVAL-WHEN (EVAL COMPILE)
(OR (GET 'TTY 'VERSION)
(LOAD (CASEQ (STATUS OPSYS)
((ITS) '((DSK LIBLSP) TTY))
(T '((LISP)TTY))))))
(DEFUN LAMBDA MACRO (FORM) (LIST 'FUNCTION FORM))
;;; *COMPLETING-READ and *COMPLETING-READ1
;;;
;;; *COMPLETING-READ prints a newline and a prompt.
;;; *COMPLETING-READ1 starts in cold (this is good for if completion
;;; has been done and user rubs back out into the read)
;;;
;;; Args are:
;;;
;;; PROMPT: What to type out as a prompt if anything.
;;; CHARS-PENDING: What characters have already been read (won't echo).
;;; INSTREAM: Where to read more chars from.
;;; OUTSTREAM: Where to do type-out to.
;;; AMBIGUITY-ERROR: If T, then beep instead of return if result is ambiguous.
;;; NULL-ERROR: If T, then beep instead of return if result is null.
;;; COMPLETION-CHARS: List of fixnums for chars that show completion.
;;; RETURN-CHARS: List of fixnums for chars that return value(s).
;;; CASE-CONVERT: If T, then lowercase stuff input gets canonicalized.
;;; OVER-RUBOUT-RETURN-FLAG: Should form return if over-rubout?
;;; If non-NIL returns OVER-RUBOUT for too many
;;; rubouts, WORD-RUBOUT for ^W, and LINE-RUBOUT
;;; for ^U.
;;;
;;; Returns a list whose CAR is the list of characters read and the
;;; CDR of which is the set of still-possible completions at the end of the
;;; read.
(DEFUN *COMPLETING-READ (PROMPT OPTIONS INSTREAM OUTSTREAM
AMBIGUITY-ERROR NULL-ERROR
COMPLETION-CHARS RETURN-CHARS
CASE-CONVERT OVER-RUBOUT-RETURN-FLAG)
(TERPRI OUTSTREAM)
(PRINC PROMPT OUTSTREAM)
(*COMPLETING-READ1 PROMPT OPTIONS () INSTREAM OUTSTREAM
AMBIGUITY-ERROR NULL-ERROR
COMPLETION-CHARS RETURN-CHARS
CASE-CONVERT OVER-RUBOUT-RETURN-FLAG))
(DEFUN *COMPLETING-READ1 (PROMPT OPTIONS CHARS-PENDING INSTREAM OUTSTREAM
AMBIGUITY-ERROR NULL-ERROR
COMPLETION-CHARS RETURN-CHARS
CASE-CONVERT OVER-RUBOUT-RETURN-FLAG)
(LET ((COMPLETION-OBJECT (*COMPLETING-READ-OBJECT
OPTIONS
PROMPT
INSTREAM
OUTSTREAM
AMBIGUITY-ERROR
NULL-ERROR
COMPLETION-CHARS
RETURN-CHARS
CASE-CONVERT
OVER-RUBOUT-RETURN-FLAG)))
(MAPC (LAMBDA (X) (*COMPLETING-READ-PUSH-COMPLETION
X
COMPLETION-OBJECT))
CHARS-PENDING)
(*CATCH 'COMPLETING-READ-EXIT
(DO-WITH-TTY-OFF
(DO ()
(NIL)
(*COMPLETING-READ-TYI COMPLETION-OBJECT))))))
;;; (COMPLETING-READ <prompt> <options>)
;;; I/O default is to/from tty
;;; ambiguous or null response acceptable
;;; return or space causes return
;;; altmode causes completion
;;; no initial character
;;;
;;; Sample: (COMPLETING-READ '> '(THIS THAT THOSE))
;;;
(DEFUN COMPLETING-READ (PROMPT OPTIONS)
(CDR (*COMPLETING-READ PROMPT OPTIONS TYI TYO
T T
'(27.) '(13. 32.)
T NIL)))
(DEFUN *COMPLETING-READ-SOFT-TYI (COMPLETION CHAR)
(LET ((OUTSTREAM (*COMPLETING-READ-OUTSTREAM COMPLETION)))
(TYO CHAR OUTSTREAM)
(*COMPLETING-READ-PUSH-COMPLETION CHAR COMPLETION)))
(DEFUN *COMPLETING-READ-CASE-FUNCTION (CHAR)
(COND ((AND (> CHAR 96.) (< CHAR 123.))
'*COMPLETING-READ-LOWERCASIFY)
(T
'*COMPLETING-READ-UPPERCASIFY)))
(DEFUN *COMPLETING-READ-TYI (COMPLETION)
(LET ((INSTREAM (*COMPLETING-READ-INSTREAM COMPLETION))
(OUTSTREAM (*COMPLETING-READ-OUTSTREAM COMPLETION)))
(LET ((CHAR (TYI INSTREAM)))
(COND ((= CHAR 12.)
(CURSORPOS 'C OUTSTREAM)
(*COMPLETING-READ-REDISPLAY-LINE COMPLETION))
((= CHAR 18.)
(*COMPLETING-READ-REDISPLAY-LINE COMPLETION))
((MEMBER CHAR '(63. 2120.))
(*COMPLETING-READ-DISPLAY-OPTIONS COMPLETION)
(*COMPLETING-READ-REDISPLAY-LINE COMPLETION))
((MEMBER CHAR (*COMPLETING-READ-COMPLETION-CHARS
COMPLETION))
(*COMPLETING-READ-ATTEMPT-COMPLETION COMPLETION))
((MEMBER CHAR (*COMPLETING-READ-RETURN-CHARS
COMPLETION))
(*COMPLETING-READ-RETURN COMPLETION CHAR))
((= CHAR 23.)
(PRINC '|/| TYO)
(COND
((*COMPLETING-READ-OVERRUBOUT-RETURN COMPLETION)
(*THROW 'COMPLETING-READ-EXIT 'WORD-RUBOUT))
(T
(*COMPLETING-READ-RESET-COMPLETION COMPLETION)
(*COMPLETING-READ-REDISPLAY-LINE COMPLETION))))
((= CHAR 21.)
(PRINC '|/| TYO)
(COND
((*COMPLETING-READ-OVERRUBOUT-RETURN COMPLETION)
(*THROW 'COMPLETING-READ-EXIT 'LINE-RUBOUT))
(T
(*COMPLETING-READ-RESET-COMPLETION COMPLETION)
(*COMPLETING-READ-REDISPLAY-LINE COMPLETION))))
((= CHAR 127.)
(LET ((CHAR
(*COMPLETING-READ-POP-COMPLETION COMPLETION)))
(COND (CHAR
(COND ((MEMQ 'RUBOUT
(STATUS FILEM OUTSTREAM))
(RUBOUT CHAR OUTSTREAM))
(T
(TYO 92. OUTSTREAM)
(TYO CHAR OUTSTREAM))))
((*COMPLETING-READ-OVERRUBOUT-RETURN
COMPLETION)
(*THROW 'COMPLETING-READ-EXIT
'OVER-RUBOUT)))))
(T
(TYO CHAR (*COMPLETING-READ-OUTSTREAM COMPLETION))
(*COMPLETING-READ-LAST-CASE
COMPLETION
(*COMPLETING-READ-CASE-FUNCTION CHAR))
(*COMPLETING-READ-PUSH-COMPLETION CHAR COMPLETION))))))
(DEFUN *COMPLETING-READ-REDISPLAY-LINE (COMPLETION)
(LET ((OUTSTREAM (*COMPLETING-READ-OUTSTREAM COMPLETION)))
(CURSORPOS 'A OUTSTREAM)
(PRINC (*COMPLETING-READ-PROMPT COMPLETION) OUTSTREAM)
(DO ((L (REVERSE (*COMPLETING-READ-CHARS-READ COMPLETION))
(CDR L))
(CASE-FUN (*COMPLETING-READ-LAST-CASE COMPLETION)))
((NULL L))
(TYO (FUNCALL CASE-FUN (CAR L)) OUTSTREAM))))
(DEFUN *COMPLETING-READ-RETURN (COMPLETION CHAR)
(LET ((OPTIONS (CAR (*COMPLETING-READ-OPTIONS COMPLETION)))
(NUMBER-OF-CHARS)
(CHARS))
(COND ((OR (AND (NULL OPTIONS)
(NOT (*COMPLETING-READ-NULL-ERROR COMPLETION)))
(= (LENGTH OPTIONS) 1.)
(NOT (*COMPLETING-READ-AMBIGUITY-ERROR COMPLETION)))
(COND ((AND (NOT (= CHAR 13.))
(= (LENGTH OPTIONS) 1.))
(*COMPLETING-READ-SHOW-COMPLETION COMPLETION)))
(TYO CHAR (*COMPLETING-READ-OUTSTREAM COMPLETION))
(*THROW 'COMPLETING-READ-EXIT
(CONS (CONS
CHAR
(*COMPLETING-READ-CHARS-READ COMPLETION))
OPTIONS))))
(SETQ NUMBER-OF-CHARS
(LENGTH (SETQ CHARS
(*COMPLETING-READ-CHARS-READ COMPLETION))))
(MAPC (LAMBDA (X)
(COND ((= (FLATC X) NUMBER-OF-CHARS)
(TYO CHAR
(*COMPLETING-READ-OUTSTREAM COMPLETION))
(*THROW 'COMPLETING-READ-EXIT
(LIST (CONS CHAR CHARS) X)))))
OPTIONS)
(TYO 7. (*COMPLETING-READ-OUTSTREAM COMPLETION))
(*COMPLETING-READ-ATTEMPT-COMPLETION COMPLETION)))
(DEFUN *COMPLETING-READ-DISPLAY-OPTIONS (COMPLETION)
(LET ((OUTSTREAM (*COMPLETING-READ-OUTSTREAM COMPLETION))
(OPTIONS (CAR (*COMPLETING-READ-OPTIONS COMPLETION))))
(CURSORPOS 'A OUTSTREAM)
(COND ((NOT OPTIONS)
(PRINC '|No options match.| OUTSTREAM))
((= (LENGTH OPTIONS) 1.)
(PRINC '|Unambiguous match: | OUTSTREAM)
(PRINC (CAR OPTIONS) OUTSTREAM))
(T
(PRINC '|Options are: | OUTSTREAM)
(PRINC (CAR OPTIONS) OUTSTREAM)
(DO ((L (CDR OPTIONS) (CDR L)))
((NULL L))
(PRINC '|, | OUTSTREAM)
(COND ((> (+ (FLATC (CAR L)) (CHARPOS OUTSTREAM)) 67.)
(TERPRI OUTSTREAM)
(TYO 9. OUTSTREAM)))
(PRINC (CAR L) OUTSTREAM))))))
(DEFUN *COMPLETING-READ-ATTEMPT-COMPLETION (COMPLETION)
(LET ((OUTSTREAM (*COMPLETING-READ-OUTSTREAM COMPLETION))
(OPTIONS (CAR (*COMPLETING-READ-OPTIONS COMPLETION)))
(LEN (1+ (LENGTH (*COMPLETING-READ-CHARS-READ COMPLETION)))))
(COND ((NULL OPTIONS)
(TYO 7. OUTSTREAM))
(T
(DO ((I LEN (1+ I))
(CASE-FUN (*COMPLETING-READ-LAST-CASE COMPLETION))
(END (FLATC (CAR OPTIONS))))
((OR (> I END)
(NOT (*COMPLETING-READ-MATCH-ALL OPTIONS I)))
(COND ((= I LEN)
(TYO 7. OUTSTREAM))))
(*COMPLETING-READ-SOFT-TYI
COMPLETION
(FUNCALL CASE-FUN (GETCHARN (CAR OPTIONS) I))))))))
(DEFUN *COMPLETING-READ-SHOW-COMPLETION (COMPLETION)
(LET ((OPTION (CAAR (*COMPLETING-READ-OPTIONS COMPLETION)))
(LEN (1+ (LENGTH (*COMPLETING-READ-CHARS-READ COMPLETION)))))
(DO ((I LEN (1+ I))
(CASE-FUN (*COMPLETING-READ-LAST-CASE COMPLETION))
(END (FLATC OPTION)))
((> I END))
(*COMPLETING-READ-SOFT-TYI
COMPLETION
(FUNCALL CASE-FUN (GETCHARN OPTION I))))))
(DEFUN *COMPLETING-READ-MATCH-ALL (OPTIONS I)
(DO ((C (GETCHARN (CAR OPTIONS) I))
(O (CDR OPTIONS) (CDR O)))
((NULL O) T)
(COND ((NOT (= C (GETCHARN (CAR O) I)))
(RETURN NIL)))))
(EVAL-WHEN (EVAL LOAD)
(SETQ COMPLETING-READER-OBJECT-HEADER
(MAKNAM '(/# C O M P L E T I O N))))
(DEFUN *COMPLETING-READ-OBJECT? (X)
(AND (NOT (ATOM X))
(EQ (CAR X) COMPLETING-READER-OBJECT-HEADER)))
(DEFUN *COMPLETING-READ-OBJECT (OPTIONS PROMPT INSTREAM OUTSTREAM
AMBIGUITY-ERROR NULL-ERROR
COMPLETION-CHARS RETURN-CHARS
CASE-CONVERT OVER-RUBOUT-RETURN-FLAG)
(HUNK COMPLETING-READER-OBJECT-HEADER
(NCONS OPTIONS) ; Options stack
PROMPT ; How to prompt
INSTREAM ; Where to get input from
OUTSTREAM ; Where to output echo
AMBIGUITY-ERROR ; Is ambiguity an error?
NULL-ERROR ; Is null choice an error?
COMPLETION-CHARS; Chars that complete
RETURN-CHARS ; Chars that cause a return
CASE-CONVERT ; Should lowercase chars convert?
(LAMBDA (X) X) ; What case to do completions in
OVER-RUBOUT-RETURN-FLAG ; Return if over-rubout occurs?
() ; Stack of chars read
))
(DEFUN *COMPLETING-READ-OPTIONS X
(COND ((= X 1.) (CXR 2. (ARG 1.)))
(T (RPLACX 2. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-PROMPT X
(COND ((= X 1.) (CXR 3. (ARG 1.)))
(T (RPLACX 3. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-INSTREAM X
(COND ((= X 1.) (CXR 4. (ARG 1.)))
(T (RPLACX 4. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-OUTSTREAM X
(COND ((= X 1.) (CXR 5. (ARG 1.)))
(T (RPLACX 5. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-AMBIGUITY-ERROR X
(COND ((= X 1.) (CXR 6. (ARG 1.)))
(T (RPLACX 6. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-NULL-ERROR X
(COND ((= X 1.) (CXR 7. (ARG 1.)))
(T (RPLACX 7. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-COMPLETION-CHARS X
(COND ((= X 1.) (CXR 8. (ARG 1.)))
(T (RPLACX 8. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-RETURN-CHARS X
(COND ((= X 1.) (CXR 9. (ARG 1.)))
(T (RPLACX 9. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-CASE-CONVERT X
(COND ((= X 1.) (CXR 10. (ARG 1.)))
(T (RPLACX 10. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-LAST-CASE X
(COND ((= X 1.) (CXR 11. (ARG 1.)))
(T (RPLACX 11. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-OVERRUBOUT-RETURN X
(COND ((= X 1.) (CXR 12. (ARG 1.)))
(T (RPLACX 12. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-CHARS-READ X
(COND ((= X 1.) (CXR 0. (ARG 1.)))
(T (RPLACX 0. (ARG 1.) (ARG 2.)))))
(DEFUN *COMPLETING-READ-RESET-COMPLETION (OBJECT)
(*COMPLETING-READ-OPTIONS OBJECT
(LAST (*COMPLETING-READ-OPTIONS OBJECT)))
(*COMPLETING-READ-CHARS-READ OBJECT ()))
(DEFUN *COMPLETING-READ-PUSH-COMPLETION (CHAR OBJECT)
(LET ((OPTS (*COMPLETING-READ-OPTIONS OBJECT))
(CHARS (*COMPLETING-READ-CHARS-READ OBJECT)))
(COND ((*COMPLETING-READ-CASE-CONVERT OBJECT)
(SETQ CHAR (*COMPLETING-READ-UPPERCASIFY CHAR))))
(*COMPLETING-READ-OPTIONS OBJECT
(CONS
(*COMPLETING-READ-PROCESS-OPTIONS
CHAR
(CAR OPTS)
(1+ (LENGTH CHARS)))
OPTS))
(*COMPLETING-READ-CHARS-READ OBJECT (CONS CHAR CHARS))))
(DEFUN *COMPLETING-READ-UPPERCASIFY (X)
(COND ((AND (> X 96.) (< X 123.)) (- X 32.))
(T X)))
(DEFUN *COMPLETING-READ-LOWERCASIFY (X)
(COND ((AND (> X 64.) (< X 91.)) (+ X 32.))
(T X)))
(DEFUN *COMPLETING-READ-POP-COMPLETION (OBJECT)
(LET ((CHARS (*COMPLETING-READ-CHARS-READ OBJECT)))
(COND (CHARS
(*COMPLETING-READ-OPTIONS
OBJECT
(CDR (*COMPLETING-READ-OPTIONS OBJECT)))
(*COMPLETING-READ-CHARS-READ OBJECT (CDR CHARS))
(CAR CHARS))
(T
NIL))))
(DEFUN *COMPLETING-READ-PROCESS-OPTIONS (CHAR OPTIONS N)
(DO ((L OPTIONS (CDR L))
(NEW-L ()))
((NULL L) (NREVERSE NEW-L))
(COND ((= (GETCHARN (CAR L) N) CHAR)
(PUSH (CAR L) NEW-L)))))
;;; (COMPLETING-READ-LINE (<prompt1> <option1[1]> <option1[2]> ...)
;;; (<prompt2> <option2[1]> <option2[2]> ...) ...)
;;; Prints <prompt1> and reads words on a single line returning NIL if
;;; over-rubout and (<option1-choice> <option2-choice> ... <optionN-choice>)
;;; if sucessful. <prompt2> ... <promptN> are only used if the user types
;;; <CR> to terminate the option before that. If he types <space> instead
;;; he will not be prompted. Ambiguous or null responses are not allowed.
(DEFUN (COMPLETING-READ-LINE MACRO) (X)
`(*COMPLETING-READ-LINE1 ',(CDR X)))
(DEFUN *COMPLETING-READ-LINE1 (PROMPT-ALIST)
(CURSORPOS 'A TYO)
(*CATCH 'COMPLETING-READ-LINE-EXIT
(*COMPLETING-READ-LINE1-AUX (CAAR PROMPT-ALIST)
PROMPT-ALIST
NIL
T)))
(DEFUN *COMPLETING-READ-LINE1-AUX (PROMPT PROMPT-ALIST VALUES PROMPTFLAG)
(COND ((NULL PROMPT-ALIST)
(*THROW 'COMPLETING-READ-LINE-EXIT
(NREVERSE VALUES)))
(T
(COND (PROMPTFLAG (PRINC (CAAR PROMPT-ALIST) TYO)))
(DO ((VAL)
(CHARS NIL))
(NIL)
(SETQ VAL
(*COMPLETING-READ1 PROMPT ; Prompt
(CDAR PROMPT-ALIST) ; Options
CHARS ; Chars read
TYI ; Instream
TYO ; Outstream
T ; Ambiguity
T ; Null
'(27.) ; Completion
'(32. 13.) ; Return chars
T ; Case
T)) ; Over-rubout
(COND ((EQ VAL 'OVER-RUBOUT)
(RETURN NIL))
((EQ VAL 'LINE-RUBOUT)
(*THROW 'COMPLETING-READ-LINE-EXIT NIL))
((EQ VAL 'WORD-RUBOUT)
(CURSORPOS 'A TYO)
(PRINC PROMPT TYO)
(RETURN NIL)))
(SETQ CHARS (REVERSE (CAR VAL)))
(*COMPLETING-READ-LINE1-AUX
(MAKNAM (NCONC (EXPLODEN PROMPT) CHARS))
(CDR PROMPT-ALIST)
(CONS (CADR VAL) VALUES)
(= (CAAR VAL) 13.))
(SETQ CHARS (REVERSE (CDAR VAL)))
(COND ((= (CAAR VAL) 13.)
(CURSORPOS 'A TYO)
(PRINC PROMPT TYO)
(MAPC (LAMBDA (X) (TYO X TYO)) CHARS))
(T
(COND ((MEMQ 'RUBOUT (STATUS FILEM TYO))
(CURSORPOS 'X TYO))
(T
(PRINC '|\ | TYO)))))))))
(SSTATUS FEATURE COMPLETING-READER-PACKAGE)

639
src/libdoc/dbg.rwk1 Executable file
View File

@@ -0,0 +1,639 @@
; -*- Mode:LISP;Lowercase:T-*-
;;; DEBUG ==> Allows user to inspect LISP stack
;;; BT ==> Prints out an indented list of the user functions called
;;; Debugging function for examining stack.
;;; (DEBUG ARG) sets *RSET and NOUUO to arg, thus typical usage is:
;;; (DEBUG T)
;;; T
;;; (FOO BAR BAZ)
;;; ;BKPT *RSET-TRAP
;;; (DEBUG)
;;; ( ...) ==> Top of stack
;;; D ==> Command to debug
;;; ( ...) ==> Next to last expression evaluated
;;; Q ==> Back to lisp
;;; NIL ==> Remember you are still inside breakloop
;;; Since having *RSET on is innefficient you might want it off, so
;;; (DEBUG NIL)
;;; DEBUG of no arguments prints (with the PRINLEVEL set to 4. and
;;; PRINDEPTH to 3.) Last S-Expression evaluated and
;;; waits for character input (no need to type SPACE after characters).
;;; Options are:
;;; D -- Down stack
;;; U -- Up stack
;;; B -- Enter break loop
;;; T -- Go to top of stack
;;; Z -- Go to bottom of stack
;;; P -- Print current level. If given arg, always print.
;;; S -- Sprinter current level. If given non-zero arg, always sprinter.
;;; > -- Sets debug-prinlength to arg
;;; ^ -- Sets debug-prinlevel to arg
;;; A -- Print indented list of all user calls, compiled or no. Uses BAKLIST
;;; V -- Print indented list of all visible calls. (from current loc down).
;;; E -- Evaluate and print an S-expression.
;;; C -- Continue execution from current level (asks for verification)
;;; R -- return value (asks for verification)
;;; Q -- Quit
;;; ^S -- Flush output at interrupt level, turn it on at top-level
;;; ? -- Type this stuff
;;; <number> -- argument for following command.
;;;
;;; The form under evaluation is the value of the special variable
;;; *CURSOR*, and may be modified in a break loop to cause the continue
;;; command to continue with it, or may be output to be edited, etc...
;;; The entire EVALFRAME is the value of the variable *FRAME*
;;;
;;; There are a few options which can be controlled, say in your init file:
;;; DEBUG-PRINLEVEL default 3 -- Initial value for PRINLEVEL
;;; DEBUG-PRINLENGTH default 4 -- Initial value for PRINLENGTH
;;; DEBUG-PRIN1 default () -- If non-null, alternate printer
;;; DEBUG-SPRINTER-MODE default () -- If non-null, GRIND sexpressions
;;; DEBUG-INDENT-MAX default 50. -- Max depth for A, V options
;;; DEBUG-PROMPT default DBG> -- What to prompt with
;;; DEBUG-FRAME-SUPPRESSION-ALIST
;;; default () -- An alist of functions-names and
;;; functions of one argument. The
;;; one argument will be an internal
;;; frame-object, which can be given
;;; a SUPPRESSED property if it is to
;;; be suppressed. Any number of frames
;;; can be suppressed by this mechanism.
;;; The function should return the last
;;; frame suppressed.
(herald DEBUG /69)
(eval-when (eval load) ;We need GRINDEF now
(or (get 'grindef 'version)
(funcall autoload `(grindef . ,(get 'grindef 'autoload))))
(or (get 'FORMAT 'version)
(funcall autoload `(FORMAT . ,(get 'FORMAT 'AUTOLOAD))))
)
(declare (own-symbol debug back-trace ;We load DEBUG into the compiler
bt debug-printer *readch2 back-trace print-frame))
(declare (*lexpr debug back-trace bt sprin1 debug-printer debug-print-frame
debug-frame-printer
y-or-n-p))
(eval-when (eval compile)
(or (get 'umlmac 'version)
(load '((LISP) umlmac))))
(or (get 'yesnop 'version)
(load '((LISP) YESNOP)))
(eval-when (eval compile)
(or (get 'debmac 'version)
(load '((rwk) debmac))))
(defprop debug-frame (next previous) suppressed-component-names)
(defvar query-io 't) ;should be set up by YESNOP
(defvar error-io query-io)
(defvar debug-command-list ())
(defvar debug-prinlevel 3)
(defvar debug-prinlength 4)
(defvar debug-prin1 ())
(defvar debug-sprinter-mode ())
(defvar debug-indent-max 50.)
(defvar debug-prompt '|DBG>|)
(defvar debug-frame-suppression-alist ())
(defvar debug-suppression-reasons
'(LET GARBAGE DEBUG-INTERNAL))
(defvar si:ignored-error-funs ())
;; The following function is defined for compile time by DEBMAC, make any
;; chanes there as well.
(defun debug-name-char (ch)
(caseq ch
(#\HELP "Help")
(#\RETURN "Return")
(#\TAB "Tab")
(#\SPACE "Space")
(#\LINEFEED "Linefeed")
(#\BACKSPACE "Backspace")
(#\RUBOUT "Rubout")
(#\FORM "Form")
(T (if (> ch #\SPACE)
(format () "~C" ch)
(format () "^~C" (+ ch #o100))))))
(defun enter-debug-command (character command-fun-symbol documentation)
(push (cons-a-debug-command-spec
CHARS character
FUN command-fun-symbol
DOC documentation)
debug-command-list))
(defun debug-find-command-spec (char)
(dolist (spec debug-command-list)
(if (member char (debug-command-spec-chars spec))
(return spec))))
(defun debug-next-valid-frame (frame)
(do ((frame (debug-frame-next frame) (debug-frame-next frame)))
((null frame))
(if (not (memq (get (debug-frame-plist frame) 'SUPPRESSED)
debug-suppression-reasons))
(return frame))))
(defun debug-previous-valid-frame (frame)
(do ((frame (debug-frame-previous frame) (debug-frame-previous frame)))
((null frame))
(if (not (memq (get (debug-frame-plist frame) 'SUPPRESSED)
debug-suppression-reasons))
(return frame))))
(def-debug-command #/D ;Move down (backwards in time)
"Down to next frame."
(do ((i (or **arg** 1) (1- i))
(frame *frame* next)
(next (debug-next-valid-frame *frame*) (debug-next-valid-frame *frame*)))
((or (= i 0) (null next)))
(declare (fixnum i))
(setq *frame* next))
(debug-print-frame *frame* debug-sprinter-mode))
(def-debug-command #/U ;Move up
"Up to previous frame."
(do ((i (or **arg** 1) (1- i))
(frame *frame* previous)
(previous (debug-previous-valid-frame *frame*) (debug-previous-valid-frame *frame*)))
((or (= i 0) (null previous)))
(declare (fixnum i))
(setq *frame* previous))
(debug-print-frame *frame* debug-sprinter-mode))
(def-debug-command #/T ;Jump back to the top of stack
"Go to the top of the stack."
(setq *frame* *top-frame*)
(debug-print-frame *frame* debug-sprinter-mode))
(def-debug-command #/Z ;Bottom of the stack
"Go to the bottom of the stack."
(setq *frame* *bottom-frame*)
(debug-print-frame *frame* debug-sprinter-mode))
(def-debug-command #/B ;Break in current environment
"Enter break loop in the environment of the current frame."
(eval '(break debug t)
(debug-frame-bindstk *frame*))
(debug-print-frame *frame* debug-sprinter-mode))
(def-debug-command #/E ;EVAL!
"Evaluate and print an S-expression."
(princ '|valuate: | error-io)
(let* ((infile t)
(form (errset (eval (read t)
(debug-frame-bindstk *frame*))
t)))
(when form
(format error-io "~&==> ")
(debug-printer (car form) () ())
(terpri error-io))
(cond ((not (zerop (listen error-io)))
(let ((character (tyipeek () error-io)))
(if (or (= character #\SPACE)
(= character #\RETURN))
(tyi error-io)))))))
(def-debug-command #/R ;Force a return from this point
"Return a value from the current frame."
(cond ((and (y-or-n-p error-io '|~&>>>RETURN ??|)
(progn
(format error-io
"~&>>>What should this S-Expression return? ")
'T)
(errset
(let* ((infile t)
(ret (read T))
(ERRSET 'CAR))
(freturn (debug-frame-callstk *frame*)
(eval ret (debug-frame-bindstk *frame*))))
T)))
(t (format error-io "Try again!~%"))))
(def-debug-command #/C ;Just re-evaluates the current S-Exp
"Continue execution by re-evaluating current frame."
(cond ((and (y-or-n-p error-io '|~&>>>Continue ??|)
(let ((ERRSET 'CAR))
(fretry (debug-frame-callstk *frame*)
(debug-frame-frame-list *frame*)))))
(t (format error-io '|~&Try again~%|))))
(def-debug-command #/A
"Print indented list of all user calls, compiled or no."
(BT 'DEBUG))
(def-debug-command #/V
"Print indented list of all visible calls, from current frame down"
(back-trace *frame*))
(def-debug-command #/P
"Print current level. If given arg, print without abbreviation."
(debug-printer (debug-frame-form *frame*)
(if (null **arg**) 'long ())))
(def-debug-command #/S
"SPRINT (grind) current level. If given non-zero arg, always SPRINT."
(if (null **arg**) (debug-printer (debug-frame-form *frame*) t)
(cond ((zerop **arg**)
(setq debug-sprinter-mode ())
(format error-io " SPRINT mode OFF~%"))
(t (setq debug-sprinter-mode t)
(format error-io " SPRINT mode ON~%")))))
(def-debug-command (#\SPACE #\RETURN #\RUBOUT #^S #^X #^W #^V #^D #^C) ;Let's win!)
"No-ops."
(setq ^W ())) ;No-ops
(def-debug-command #\FORM
"Clear screen."
(cursorpos 'c error-io))
(def-debug-command #/^
"Set DEBUG-PRINLEVEL to argument (or () if no argument)."
(setq debug-prinlevel **arg**)
(format error-io " DEBUG-PRINLEVEL set to ~S~%" **arg**))
(def-debug-command #/>
"Set DEBUG-PRINLEVEL to argument (or () if no argument)."
(setq debug-prinlength **arg**)
(format error-io " DEBUG-PRINLENGTH set to ~S~%" **arg**))
(def-debug-command #/=
"Display status of DEBUG-PRINLEVEL, DEBUG-PRINLENGTH, DEBUG-GRIND."
(format error-io
" ~5TSPRINT mode is ~:[OFF~;ON~]~@
~5TDEBUG-PRINLEVEL = ~S~@
~5TDEBUG-PRINLENGTH = ~S~%"
debug-sprinter-mode debug-prinlevel debug-prinlength))
(def-debug-command #/Q
"Quit DEBUG."
(*throw 'END-DEBUG 'END-DEBUG))
(def-debug-command (#/? #\HELP)
"Document DEBUG."
(cursorpos 'A error-io)
(princ "Type a character to document, * for all, or ? for general help." error-io)
(let ((char (debug-upcase (tyi error-io))))
(caseq char
(#/* (cursorpos 'C error-io)
(debug-print-all-help))
((#/? #\HELP)
(cursorpos 'C error-io)
(princ "The DEBUG package is entered by calling the DEBUG function with
no arguments, or automatically on error if the SIGNAL package is loaded.
It takes single-character commands to examine the environment of an error.
With it you can determine what functions have called what functions with
what arguments, and what the values of special variables were when those
functions were on the stack.
To use DEBUG, *RSET must be set to T. In addition, NOUUO should be set
to T and (SSTATUS UUOLINKS) should be done, or many calls to compiled
functions will not be seen by DEBUG.
The basic commands are:
U -- Up, D -- Down, T -- Top, Z -- Bottom, P -- Print, S -- SPRINT
Q -- Quit DEBUG
The following operate in the context of the current frame:
R -- Return a value from the current frame
C -- Continue (reexecute current frame),
B -- Break loop, E -- Evaluate
The following control how frames are printed:
^ -- set PRINLEVEL, > -- set PRINLENGTH, S -- set use of SPRINTER,
= -- show switches.
The following provide a brief backtrace listing:
V -- Calls visible to DEBUG
A -- All calls, including those not seen due to NOUUO.
The X command works only with SIGNAL to continue or restart from errors.
"
error-io))
(T (cursorpos 'A error-io)
(princ (debug-name-char char) error-io)
(princ " -- " error-io)
(if (debug-digitp char)
(princ "Numerical argument to a command" error-io)
(let ((cmd (debug-find-command-spec char)))
(if cmd
(princ (debug-command-spec-doc cmd)
error-io)
(princ "Not a defined command." error-io))))))))
(defun debug-print-all-help ()
(dolist (spec (reverse debug-command-list))
(lexpr-funcall #'format error-io
"~&~A~@{, ~A~}:"
(mapcar #'debug-name-char
(debug-command-spec-chars spec)))
(if (> (charpos error-io) 7.) (terpri error-io))
(format error-io "~5T ~A~%" (debug-command-spec-doc spec))))
(defun debug (&optional (*rset-new () *RSET-p) (ignore-funs '(debug) ignore-funs-p)
&aux **arg** *top-frame* *bottom-frame*
(debug-prinlevel debug-prinlevel)
(debug-prinlength debug-prinlength))
(cond ((and *rset-p (null ignore-funs-p)) ;hack for call from NIL
(*rset (nouuo *rset-new))
(if *rset-new (sstatus uuolinks)))
((null (evalframe () )) 'try-setting-*rset)
('T
(setq *top-frame* (debug-parse-all-frames))
(debug-analyze-stack *top-frame* ignore-funs)
(setq *frame* (or (debug-next-valid-frame *top-frame*) *top-frame*))
(do ((frame *top-frame* (debug-frame-next frame))) ;Find bottom frame
((null frame))
(setq *bottom-frame* frame))
(debug-print-frame *frame* () 'T) ;don't say at top or bottom of stack
(*catch 'END-DEBUG
(errset
(do ((char (*readch2) (*readch2))
(spec))
(())
(declare (fixnum (char)))
(if (setq spec (debug-find-command-spec char))
(funcall (debug-command-spec-fun spec))
(princ '|???| error-io)))
T)))))
;;; Reads a character and returns that character as either a
;;; number or a symbol.
;;; It also converts small letters into capitals
(defun *readch2 (&aux help-p)
(let ((debug-infile infile)
(infile error-io)) ;LISP bug
(cursorpos 'A error-io)
(format error-io debug-prompt)
(do ((char (tyipeek () error-io) (tyipeek () error-io)))
((not (= char #/())
(when (= char #\HELP) ;Get around LISP bug, TYPEEK forgets HELP
(tyi error-io)
(setq help-p T)))
(declare (fixnum char))
(cursorpos 'x error-io) ;try to erase it
(cursorpos 'a error-io)
(tyo #/( error-io)
(errset
(let* ((errset 'CAR)
(form (read error-io)) ;READ with INFILE rebound
(infile debug-infile) ;but undo that for the eval (SMURF)
(val (eval form (debug-frame-bindstk *frame*))))
(when val
(format error-io "~&==> ")
(debug-printer val t)))
T)
(format error-io debug-prompt))
(setq **arg** ())
(do ((char (if help-p #\HELP ;Get around LISP bug, TYIPEEK sucks.
(tyi error-io))
(tyi error-io)))
((not (debug-digitp char)) ;Return first non-digit
(debug-upcase char))
(declare (fixnum char))
(setq **arg** (+ (* (or **arg** 0) 10.) (- char #/0))))))
(defun debug-upcase (char)
(declare (fixnum char))
(if (lessp #.(1- #/a) char #.(1+ #/z))
(- char #.(- #/a #/A))
char))
(defun debug-digitp (char)
(declare (fixnum char))
(lessp #.(1- #/0) char #.(1+ #/9)))
;;;TO GET AROUND JONL'S WEIRD SPELLING
(defprop backtrace baktrace expr)
;;; This function prints an indented list of functions from the frame
;;; provided
(defun back-trace (&optional (frame (debug-parse-all-frames)))
(cursorpos 'a error-io)
(do ((spaces 0 (1+ spaces))
(frame frame (debug-frame-next frame)))
((null frame) 'end)
(declare (fixnum spaces))
(debug-frame-printer frame () t spaces)))
;;; THIS FUNCTION PRINTS THE BAKLIST, A LIST OF THE USER FUNCTIONS
;;; CALLED, IN A NICE FORMAT I.E. INDENTED
(defun bt (&optional (until 'BT) &aux (btlist (baklist)))
(do nil
((or (null btlist) (eq (caar btlist) until)))
(setq btlist (cdr btlist)))
(cursorpos 'A error-io)
(do ((btlist (cdr btlist) (cdr btlist))
(spaces 0 (1+ spaces)))
((null btlist) 'END)
(declare (fixnum spaces))
(debug-n-spaces spaces)
(debug-printer (caar btlist) t () )
(cursorpos 'a error-io)))
;;; This just prints using the user's special print function if
;;; he has one.
(defun debug-printer (X sprinter-mode &optional (terpri-p t) (n-spaces 0))
(let ((prinlevel (if (eq sprinter-mode 'long) () debug-prinlevel))
(prinlength (if (eq sprinter-mode 'long) () debug-prinlength)))
(errset (progn (when terpri-p
(cursorpos 'a error-io)
(debug-n-spaces n-spaces))
(cond ((eq sprinter-mode T) (sprin1 x error-io))
(debug-prin1 (funcall debug-prin1 x error-io))
(prin1 (funcall prin1 x error-io))
(T (prin1 x error-io))))
t)
(if terpri-p (terpri error-io))))
;; Takes a frame pointer, and prints it.
(defun debug-print-frame (frame sprinter-p &optional suppress)
(when (and (not suppress)
(or (null frame) (null (debug-next-valid-frame frame))))
(format error-io "~&You are at the bottom of the stack.~%"))
(when (and (not suppress)
(or (null frame) (null (debug-previous-valid-frame frame))))
(format error-io "~&You are at the top of the stack.~%"))
(setq *frame* frame)
(setq *cursor* (debug-frame-form frame))
(debug-frame-printer frame sprinter-p))
(defun debug-n-spaces (n)
(dotimes (\\ n debug-indent-max)
(tyo #\SPACE error-io)))
(defun debug-frame-printer (frame sprinter-p
&optional (terpri-p 'T) (n-spaces 0)
&aux (form (debug-frame-form frame)))
(when (get (debug-frame-plist frame) 'elided-count)
(if terpri-p (cursorpos 'a error-io))
(princ ";Elided ")
(let ((base 10.))
(prin1 (get (debug-frame-plist frame) 'elided-count) error-io))
(princ " times.")
(setq terpri-p t))
(if (and (not (atom form))
(eq (car form) 'apply) ;APPLY form
(not (atom (cdr form))) ;of constant
(not (atom (cadr form))) ;#'function format
(eq (caadr form) 'FUNCTION) ;prints nicely
(not (atom (cddr form))) ;but be sure it is a legal
(null (cdddr form))) ;APPLY call
(let (( ( () (() function) arguments third) form))
(if terpri-p (cursorpos 'A error-io))
(debug-n-spaces n-spaces)
(princ "(APPLY #'" error-io)
(debug-printer function sprinter-p () (+ 9. n-spaces))
(terpri error-io)
(debug-n-spaces (+ 7 n-spaces))
(when (and (not (atom arguments))
(eq (car arguments) 'QUOTE)
(not (atom (cdr arguments)))
(null (cddr arguments)))
(tyo #/' error-io)
(setq arguments (cadr arguments)))
(debug-printer arguments sprinter-p () (+ 8. n-spaces))
(when third
(terpri error-io)
(debug-n-spaces (+ 7 n-spaces))
(debug-printer third sprinter-p () (+ 7 n-spaces)))
(tyo #/) error-io)
(if terpri-p (terpri error-io)))
(debug-printer form sprinter-p terpri-p n-spaces)))
(defun debug-parse-frame (previous frame)
(debug-link-frames previous
(let (( (type callstk form bindstk) frame)
(plist (ncons 'DEBUG-FRAME-PLIST)))
(caseq (car frame)
(APPLY (let (( (function arguments) form))
(cons-a-debug-frame
TYPE type
FUNCTION function
ARGUMENTS arguments
FORM `(apply #',function
',arguments)
CALLSTK callstk
BINDSTK bindstk
PLIST plist
FRAME-LIST frame)))
(EVAL (cons-a-debug-frame
TYPE type
FORM (debug-mexp-check form)
CALLSTK callstk
BINDSTK bindstk
PLIST plist
FRAME-LIST frame))))))
(defun debug-mexp-check (form)
(if (eq (car form) 'MACROEXPANDED)
(cadddr form)
form))
(defun debug-parse-all-frames ()
(loop for evf = (evalframe ()) then (evalframe (cadr evf))
with frame
for top-frame = () then (or top-frame frame)
until (null evf)
when (eq (caaddr evf) '+internal-pdl-break)
do
(loop for check-evf = evf then (evalframe (cadr check-evf))
with elidable-frames
for match = (debug-frame-match check-evf elidable-frames)
until match
unless check-evf
do (setq top-frame (or top-frame frame))
(setq evf ())
(return ())
do (setq frame (debug-parse-frame frame check-evf))
(push frame elidable-frames)
finally
(setq top-frame (or top-frame frame))
(loop for elide-evf = check-evf
then (evalframe (cadr elide-evf))
for match = (debug-frame-match elide-evf elidable-frames)
while match
unless elide-evf do (loop-finish)
do (increment-elided-count match)
finally (setq evf elide-evf)))
unless evf do (loop-finish)
do (setq frame (debug-parse-frame frame evf))
finally (return (or top-frame frame))))
(defun debug-frame-match (evf frames)
(loop with form = (debug-mexp-check (caddr evf))
for frame in frames
when (equal form (caddr (debug-frame-frame-list frame)))
return frame
finally (return ()) ))
(defun debug-link-frames (previous frame)
(setf (debug-frame-previous frame) previous)
(if previous
(setf (debug-frame-next previous) frame))
frame)
(defun increment-elided-count (frame)
(setf (get (debug-frame-plist frame) 'elided-count)
(1+ (or (get (debug-frame-plist frame) 'elided-count)
0))))
(defun debug-analyze-stack (top-frame ignore-frames)
(do ((frame top-frame (debug-frame-next frame))
(prev top-frame frame))
((null frame) ;start at bottom
(do ((frame prev (debug-frame-previous frame))
(fun) (suppressor-fun))
((null frame))
(caseq (debug-frame-type frame)
(EVAL (setq fun (if (not (atom (debug-frame-form frame)))
(car (debug-frame-form frame)))))
(APPLY (setq fun (debug-frame-function frame))))
(if (or (memq fun ignore-frames)
(memq fun SI:IGNORED-ERROR-FUNS)
(eq fun 'debug-parse-all-frames))
(putprop (debug-frame-plist frame) 'DEBUG-INTERNAL 'SUPPRESSED)
(if (setq suppressor-fun (cdr (assq fun DEBUG-FRAME-SUPPRESSION-ALIST)))
(setq frame (funcall suppressor-fun frame))))))))
(defun debug-let-suppressor (frame)
(let ((previous (debug-frame-previous frame)))
(if (not (and (eq (debug-frame-type frame) 'EVAL)
(eq (debug-frame-type previous) 'EVAL)
(not (atom (debug-frame-form previous)))
(not (atom (car (debug-frame-form previous))))
(eq (caar (debug-frame-form previous)) 'LAMBDA)))
frame
(putprop (debug-frame-plist previous) 'LET 'SUPPRESSED)
previous)))
(push '(LET . debug-let-suppressor) DEBUG-FRAME-SUPPRESSION-ALIST)
(defun debug-garbage-suppressor (frame)
(putprop (debug-frame-plist frame) 'GARBAGE 'SUPPRESSED)
frame)
(push '(+INTERNAL-TTYSCAN-SUBR . DEBUG-GARBAGE-SUPPRESSOR)
DEBUG-FRAME-SUPPRESSION-ALIST)

315
src/libdoc/lispm.8 Executable file
View File

@@ -0,0 +1,315 @@
;;; -*- Mode:Lisp; Fonts:MEDFNB; -*-
;;; LISPM: A library of LispM compatibility software for Maclisp
;;; Created by KMP@MC, 12:30am September 2, 1982
;;; The master copy of this file is MC:LIBDOC;LISPM >.
;;; Please do not edit this file. Contact KMP@MC with bugs/comments.
;;; The following are defined by this file:
;;;
;;; Name Description LispM Doc Reference
;;;
;;; DEFSUBST macro definition facility Manual, 4th ed, p215
;;; DOLIST iteration construct Manual, 4th ed, p42
;;; DOTIMES iteration construct Manual, 4th ed, p42
;;; DO* iteration construct (undocumented)
;;; MEXP macro expansion utility Manual, 4th ed, p226
;;; ONCE-ONLY macro building utility Manual, 4th ed, p223
;;; WITH-OPEN-FILE file i/o binding abstraction Manual, 4th ed, p365
;;; WITH-OPEN-STREAM stream i/o binding abstraction (undocumented)
(herald LISPM-COMPATIBILITY /6)
(sstatus feature LISPM-COMPATIBILITY) ; So people can do #+LISPM-COMPATIBILITY
;;; (DOLIST (item list) . body) LispM Manual, 4th ed, p 42
;;;
;;; DOLIST is a convenient abbreviation for the most common list iteration.
;;; DOLIST performs body once for each element in the list which is the
;;; value of LIST, with ITEM bound to the successive elements...
;;; You can use RETURN and GO and PROG-tags inside the body, as with DO.
;;; DOLIST forms return NIL unless returned from explicitly with RETURN....
(defmacro dolist (spec . body)
(cond ((or (atom spec)
(atom (cdr spec))
(cddr spec)
(not (symbolp (car spec))))
(error "Invalid binding spec for DOLIST" spec)))
(let ((l (gensym))
(item (car spec))
(list (cadr spec)))
`(do ((,l ,list (cdr ,l))
(,item))
((null ,l))
(setq ,item (car ,l))
,@body)))
;;; LispM Manual, 4th ed, p 223
;;;
;;; (ONCE-ONLY (var-list) form1 form2 ...)
;;;
;;; VAR-LIST is a list of variables. The FORMs are a lisp program that
;;; presumably uses the values of those variables. When the form resulting
;;; from the expansion of the ONCE-ONLY is evaluated, the first thing it
;;; does is to inspect the values of each of the variables in VAR-LIST;
;;; these values are assumed to be Lisp forms. For each of the variables, it
;;; binds that variable to either its current value, if the current value is
;;; a trivial form, or to a generated symbol. Next, once-only evalutes the
;;; forms in this new binding environment, and when they have been
;;; evaluated, it undoes the bindings. The result of the evaluation of the
;;; last FORM is presumed to be a Lisp form, typically the expansion of a
;;; maro. If all of the variables had been bound to trivial forms, the
;;; ONCE-ONLY just returns that result. Otherwise, ONCE-ONLY returns the
;;; result wrapped in a lambda-combination that binds the generated symbols
;;; to the result of evaluating the respective non-trivial forms.
(defmacro once-only (varlist &body forms)
(cond ((or (atom varlist)
(dolist (var varlist) (if (not (symbolp var)) (return t))))
(error "bad variable list in once-only" varlist)))
(let ((lose? (gensym))
(vars (gensym)))
`(let (,@(mapcar #'list varlist varlist)
(,lose? nil)
(,vars '()))
,@(mapcar #'(lambda (x)
`(cond ((and (symbolp ,x)
(not (get ,x '+INTERNAL-STRING-MARKER)))
(push (list ',x (gensym) ,x) ,vars))
((not (or (atom ,x)
(memq (car ,x) '(function quote))))
(setq ,lose? t)
(push (list ',x (gensym) ,x) ,vars))))
varlist)
(cond (,lose?
,@(mapcar #'(lambda (x)
`(setq ,x (or (cadr (assq ',x ,vars)) ,x)))
varlist)))
(let ((result (progn ,@forms)))
(if ,lose?
`(let ,(mapcar #'cdr (nreverse ,vars)) ;get side-effects right!
,result)
result)))))
;;; (DOTIMES (index count) . body) LispM Manual, 4th ed, p 42
;;;
;;; DOTIMES is a convenient abbreviation for the most common integer
;;; iteration. DOTIMES performs BODY the number of times given by the value
;;; of COUNT, with INDEX bound to 0, 1, etc. on successive iterations...
;;; You can use RETURN and GO and PROG-tags inside the body, as with DO.
;;; DOTIMES forms return NIL unless returned from explicitly with RETURN....
(defmacro dotimes (spec . body)
(cond ((or (atom spec)
(atom (cdr spec))
(cddr spec)
(not (symbolp (car spec))))
(error "Invalid binding spec for DOTIMES" spec)))
(let ((index (car spec))
(count (cadr spec)))
(once-only (count)
`(do ((,index 0 (1+ ,index)))
((not (< ,index ,count)))
,@body))))
;;; (DEFSUBST name bvl . body) LispM Manual, 4th ed, p 215
;;;
;;; A substitutable function is a function which is open coded by the
;;; compiler. It is like anyh other function when applied, but it can be
;;; expanded instead, and in that regard it resembles a macro....
;;;
;;; Note: Using #'name in code after a DEFSUBST of that name will result in
;;; a proceedable compiler error currently. This is a bug in the
;;; compiler which will hopefully be fixed. Typing P to the compiler
;;; will make the right thing happen.
(defmacro defsubst (name bvl . body)
(cond ((atom bvl)
(error "DEFSUBST can't hack atomic bvl." bvl)))
(dolist (var bvl)
(cond ((or (not (symbolp var))
(= (getcharn var 1) #/&))
(error "defsubst can't hack this variable spec." var))))
(let ((subst-name (symbolconc name " SUBST")))
`(progn 'compile
(defmacro ,name ,bvl
,(cond ((cdr body)
``(progn
,@(sublis (list ,@(mapcar #'(lambda (x)
`(cons ',x ,x))
bvl))
',body)))
(t
`(sublis
(list ,@(mapcar #'(lambda (X) `(cons ',x ,x)) bvl))
',(car body)))))
(eval-when (eval compile load)
(cond ((status feature complr)
(putprop ',name 't 'defcomplrmac))))
(defun ,subst-name ,bvl ,@body)
(let ((def (getl ',subst-name '(expr subr lsubr))))
(putprop ',name (cadr def) (car def)))
',name)))
;;; LispM Manual, 4th ed, p 365
;;;
;;; (WITH-OPEN-FILE ((var filename . options) . body) ...)
;;;
;;; Evaluates the BODY forms with the variable VAR bound to a stream which
;;; reads or writes the file named by the value of FILENAME. OPTIONS may be
;;; any number of keywords to be passed open. These options control whether
;;; a stream is for input from an existing file or output to a new file,
;;; whether the file is text or binary, etc. The options are the same as
;;; those which may be given to the OPEN function.
;;;
;;; When control leaves the body, either normally or abnormally (eg, via
;;; *THROW), the file is closed.
;;;
;;; NOTE: The LispM feature wherein the file is deleted if a throw is done
;;; is not currently supported and is not likely to be in the near
;;; future. In any case, code using this compatibility macro should
;;; not make assumptions about its behavior one way or the other on
;;; point. Please contact KMP if you have any troubles in this regard.
;;;
;;; Because it always closes the file even when an error exit is taken,
;;; WITH-OPEN-FILE is preferred over OPEN. Opening a large number of files
;;; and forgetting to close them is anti-social on some file systems (eg, ITS)
;;; because there are only a finite number of disk channels available which
;;; must be shared among the community of logged-in users.
;;;
;;; Because the filename will be passed to OPEN, either a namestring or a
;;; namelist will work. However, code intended to run on the LispM should
;;; use only namestring format for files since that's all the LispM will
;;; accept.
;;;
;;; NOTE: If an error occurs during the OPEN, the friendly behavior of the
;;; LispM (wherein a new filename is prompted for) will not occur.
;;; Instead, the IO-LOSSAGE handler will run as for any OPEN, probably
;;; resulting in an error breakpoint. Users are encouraged to verify
;;; the existence of a file before invoking WITH-OPEN-FILE on it.
(defmacro with-open-file ((var filename . options) &body body)
(cond ((not (symbolp var))
(error
"bad var. Syntax is: (with-open-file (var file . modes) . body)"
var)))
(let ((true-options (cond ((not (cdr options)) (car options))
((not (dolist (option options)
(if (or (atom option)
(not (eq (car option) 'quote)))
(return t))))
`',(mapcar #'cadr options))
(t
`(list ,@options)))))
`(with-open-stream (,var (open ,filename ,true-options))
,@body)))
;;; Not documented in LispM Manual, 4th ed
;;;
;;; (WITH-OPEN-STREAM (var exp) . body)
;;;
;;; Like WITH-OPEN-FILE but exp may be an arbitrary form to accomplish the
;;; OPEN. The result of evaluating EXP should be a file or sfa. BODY will be
;;; evaluated in a context where VAR is bound to that file or sfa.
;;; Upon return, as with WITH-OPEN-FILE, the file or sfa will be closed.
;;;
;;; Note: This is a reasonably low-level primitive. If you don't know the
;;; which you want of WITH-OPEN-FILE or WITH-OPEN-STREAM, you almost
;;; surely want WITH-OPEN-FILE.
(defmacro with-open-stream (bindings &body body)
(cond ((or (atom bindings)
(not (symbolp (car bindings))) ;var to bind
(atom (cdr bindings))
(not (null (cddr bindings))))
(error "bad bindings. Syntax is: (WITH-OPEN-STREAM (var form) . body)"
bindings)))
(let (((var val) bindings)
(temp (gensym)))
`(let ((,temp nil))
(unwind-protect (progn (without-interrupts (setq ,temp ,val))
(let ((,var ,temp))
,@body))
(if (or (filep ,temp)
(sfap ,temp))
(close ,temp))))))
;;; (MEXP) LispM Manual, 4th ed, p 226
;;;
;;; MEXP goes into a loop in which it reads forms and sequentially expands
;;; them, printing out the result of each expansion (using the pretty printer
;;; to improve readability). It terminates when it reads an atom. If you type
;;; in a form which is not a macro form, there will be no expansions. This
;;; allows you to see what your macros are expanding into without actually
;;; evaluating the result of the expansion.
(defun mexp ()
(do ((form)) (nil)
(errset
(progn
(format t "~&> ")
(setq form (read))
(cond ((atom form) (return nil)))
(cond ((symbolp (car form))
(let ((fn (car form)))
(cond ((and (not (get fn 'macro))
(not (getl fn '(expr fexpr subr lsubr fsubr))))
(let ((autoload-file (get fn 'autoload)))
(cond (autoload-file
(format t "~&;Autoloading ~A looking for ~S..."
(namestring autoload-file)
fn)
(load (get fn 'autoload))
(format t "~%"))))))
(cond ((get fn 'macro)
(do ((form (macroexpand-1 form) (macroexpand-1 form)))
(nil)
(format t "~& ==> ")
(sprin1 form)
(cond ((or (atom form)
(not (symbolp (car form)))
(not (get (car form) 'macro)))
(return nil)))))
(t
(format t "~&;~S has no macro definition." fn)))))
(t
(format t
"~&;CAR of that form is not a symbol, but I'll try it...~
~% ==> ")
(sprin1 (macroexpand form)))))
t)))
;;; (DO* bindings exitforms . body) ...undocumented...
;;;
;;; Like DO, but does sequential assignment rather than parallel assignment.
(defmacro do* (bindings exitforms &body body)
(cond ((< (length bindings) 2)
`(do ,bindings ,exitforms ,@body))
(t
`(let* ,(mapcar #'(lambda (x)
(if (atom x) x
(cons (car x) (if (cdr x) (list (cadr x))))))
bindings)
(do () ,exitforms
,@body
,@(mapcan #'(lambda (x)
(if (and (not (atom x)) (cddr x))
(ncons `(setq ,(car x) ,(caddr x)))))
bindings))))))
;;; Local Modes:;
;;; Mode:LISP;
;;; Lisp ONCE-ONLY Indent:1;
;;; End:;

BIN
src/libdoc/tty.24 Executable file
View File

Binary file not shown.

BIN
src/lisp/defset.fasl Executable file
View File

Binary file not shown.

240
src/lspsrc/umlmac.35 Executable file
View File

@@ -0,0 +1,240 @@
;;; UMLMAC -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; *************************************************************************
;;; ***** MacLISP ******* Utility MacLisp MACros ****************************
;;; *************************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *************
;;; *************************************************************************
(herald UMLMAC /35)
(include ((lisp) subload lsp))
(eval-when (eval compile)
(setq defmacro-for-compiling 'T defmacro-displace-call MACROEXPANDED)
(mapc #'(lambda (x) (putprop x 'T 'SKIP-WARNING))
'(SELECTQ STRUCT-LET STRUCT-SETF))
(subload LOOP)
)
;;;; MSETQ-..., for backwards compatibility
;;;; BIT-<TEST,SET,CLEAR>, WHEN, UNLESS,
(defmacro MSETQ-CALL (&rest w) `(MULTIPLE-VALUE ,.w))
(defmacro MSETQ-RETURN (&rest w) `(VALUES ,.w))
(DEFBOTHMACRO BIT-TEST (X Y) `(NOT (= (BOOLE 1 ,X ,Y) 0)))
(DEFBOTHMACRO BIT-SET (X Y) `(BOOLE 7 ,X ,Y))
(DEFBOTHMACRO BIT-CLEAR (X Y) `(BOOLE 2 ,X ,Y))
(DEFMACRO WHEN (P . C) `(COND (,P . ,C)))
(DEFMACRO UNLESS (P . C) `(COND ((NOT ,P) . ,C)))
(def-or-autoloadable GENTEMP MACAID)
(def-or-autoloadable SYMBOLCONC MACAID)
;;;; SELECTQ
(defvar SI:SELECTQ-TYPE-TESTERS '((FIXNUM . =) (BIGNUM . EQUAL)) )
(defvar SI:SELECTQ-PREDICATES '((FIXNUM . FIXNUMP) (BIGNUM . BIGP) ))
;;; We could all (FLONUM . =$) to SI:SELECTQ-TYPE-TESTERS, and
;;; (FLONUM . FLONUMP) to SI:SELECTQ-PREDICATES
(defvar SI:SELECTQ-OTHERWISE-KEYWORDS '(T OTHERWISE :OTHERWISE))
(defvar SI:SELECTQ-TYPEP-ALIST)
(defvar SI:SELECTQ-VAR)
(defmacro SELECTQ (key-form &rest clauses &aux types-used tem newclauses)
(cond
((or (null clauses) (memq (caar clauses) si:selectq-otherwise-keywords))
`(PROGN ,key-form () ,@(cdar clauses)))
('T (loop as clause = (car clauses)
as test = (car clause)
until (memq test si:selectq-otherwise-keywords)
as typed-alist = ()
do (loop for key in (cond ((atom test) (list test)) (test))
as type = (car (assq (typep key)
si:selectq-type-testers))
unless (memq type types-used)
do (push type types-used)
unless (setq tem (assq type typed-alist))
do (push (setq tem (ncons type)) typed-alist)
do (nconc tem (list key)))
(push (cons typed-alist (cdr clause)) newclauses)
while (setq clauses (cdr clauses)))
(let* ((si:selectq-var (cond ((atom key-form) key-form)
('T (si:gen-local-var () "Selector"))))
(q (selectq-compile-1 newclauses types-used (cdar clauses))))
(cond ((eq key-form si:selectq-var) q)
('T `((LAMBDA (,si:selectq-var) ,q) ,key-form)))))))
(defun SELECTQ-COMPILE-1 (clauses types-used otherwisep)
(and (equal otherwisep '(())) (setq otherwisep ()))
(let ((si:selectq-typep-alist ())
(pre-test ())
(final-form ())
(type-vars ())
(type-vals ())
(type-inits ()))
(cond ((and (null (cdr types-used))
(or (null (car types-used)) (not otherwisep)))
(or (null (car types-used))
(setq pre-test `(,(cdr (assq (car types-used)
si:selectq-predicates))
,si:selectq-var))))
('T (loop with var = ()
for type in types-used
when type
do (si:gen-local-var var type)
(push (cons type var) si:selectq-typep-alist)
(push () type-vals)
(push var type-vars)
(push `(SETQ ,var
(,(cdr (assq type si:selectq-predicates))
,si:selectq-var))
type-inits))))
(loop with nclauses = ()
for xclause in clauses
do (push (cons (cond ((not si:selectq-typep-alist)
(selectq-one-hairy-predicate (caar xclause)))
('T (selectq-hairy-predicate (car xclause))))
(or (cdr xclause) '(())))
nclauses)
finally (and otherwisep (nconc nclauses (list `('T ,@otherwisep))))
(setq final-form (cons 'cond nclauses)))
(and pre-test (setq final-form `(and ,pre-test ,final-form)))
(cond ((not (null (cdr type-inits))) (push 'OR type-inits))
('T (setq type-inits (car type-inits))))
`((LAMBDA ,type-vars ,type-inits ,final-form) ,@type-vals)))
(defun SELECTQ-HAIRY-PREDICATE (type-alist &aux untyped)
(loop with clauses = ()
for entry in type-alist
do (cond ((not (null (car entry)))
(push `(,(cdr (assq (car entry) si:selectq-typep-alist))
,(selectq-one-hairy-predicate entry))
clauses))
('T (setq untyped entry)))
finally (and untyped
(push (ncons (selectq-one-hairy-predicate untyped))
clauses))
(return (cond ((cdr clauses) `(COND ,.(nreverse clauses)))
((cdar clauses) `(AND ,.(car clauses)))
('T (caar clauses))))))
(defun SELECTQ-ONE-HAIRY-PREDICATE (entry)
; Consider optimizing MEMQ.
(loop with fn = (or (cdr (assq (car entry) si:selectq-type-testers)) 'eq)
for k in (cdr entry)
collect `(,fn ,si:selectq-var ',k) into preds
finally (return (cond ((cdr preds) `(OR ,.preds))
('T (car preds))))))
;;;; DOLIST, DOTIMES
(defmacro DOLIST ((var form index) &rest body &aux dummy decls)
(setq decls (cond ((and body
(not (atom (car body)))
(eq (caar body) 'DECLARE))
(prog2 () (cdar body) (pop body)))))
(cond (index (push `(FIXNUM ,INDEX) decls)
(setq index (ncons `(,INDEX 0 (1+ ,INDEX)) ))))
(and decls (setq decls (ncons `(DECLARE ,.decls))))
(si:gen-local-var dummy)
`(DO ((,DUMMY ,FORM (CDR ,DUMMY)) (,VAR) ,.index )
((NULL ,DUMMY))
,@decls
(SETQ ,VAR (CAR ,DUMMY)) ,.BODY))
(eval-when (eval compile)
(setq defmacro-for-compiling 'T defmacro-displace-call 'T)
)
;Repeat a number of times. <count> evaluates to the number of times,
;and <body> is executed with <var> bound to 0, 1, ...
;Don't generate dummy variable if <count> is an integer. We could also do this
;if <count> were a symbol, but the symbol may get clobbered inside the body,
;so the behavior of the macro would change.
(defmacro DOTIMES ((var count) &rest body &aux dummy decls)
(or var (si:gen-local-var var))
(and *RSET
(do ()
((symbolp var))
(setq var (error '|Must be a variable -- DOTIMES|
var
'WRNG-TYPE-ARG))))
(setq count (macroexpand count))
(cond ((|constant-p/|| count)
(do ()
((fixnump count))
(setq count (error '|Must be FIXNUM -- DOTIMES|
count
'WRNG-TYPE-ARG))))
('T (si:gen-local-var dummy)
(psetq dummy `((,dummy ,count))
count dummy)))
(setq decls `(DECLARE
(FIXNUM ,var ,.(and dummy (list count)))
,.(cond ((and body
(not (atom (car body)))
(eq (caar body) 'DECLARE))
(prog2 () (cdar body) (pop body))))))
`(DO ((,var 0 (1+ ,var)) ,.dummy)
((NOT (< ,var ,count)))
,decls
,.body))
;;;; STRUCT-LET and STRUCT-SETF
(eval-when (eval compile)
(setq defmacro-displace-call '|defvst-construction/||)
)
;;; E.g. (STRUCT-LET (<structure-name> <struct-object-to-be-destructured>)
;; ((var slot-name) ; or,
;; (var-named-same-as-slot) ; or,
;; var-named-same-as-slot
;; ...)
;; . body)
(defmacro STRUCT-LET ((struct-name str-obj) bvl &rest body)
(let (var slot-name accessor)
(setq bvl (mapcar
#'(lambda (e)
(if (atom e) (setq e `(,e ,e)))
(desetq (var slot-name) e)
(or slot-name (setq slot-name var))
(setq accessor (symbolconc struct-name '/- slot-name))
`(,var (,accessor ,str-obj)))
bvl))
`(LET ,bvl ,.body)))
;;; E.g. (STRUCT-SETF (structure-name object) (slot-name value) ...)
(defmacro STRUCT-SETF ((str-name str-obj) &rest l &aux slot-name accessor val)
`(PROGN ,. (mapcar
#'(lambda (x)
(if (atom x) (setq x `(,x ,x)))
(desetq (slot-name val) x)
(setq accessor (symbolconc str-name '/- slot-name))
`(SETF (,accessor ,str-obj) ,val))
l)))

97
src/nilcom/evonce.14 Executable file
View File

@@ -0,0 +1,97 @@
;;; EVONCE -*-MODE:LISP;PACKAGE:SI-*- -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ******* Macro for Defining SETF Structures *****
;;; **************************************************************
;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
(eval-when (eval compile)
(cond ((and (status feature MACLISP) (status nofeature FOR-NIL))
(sstatus feature FM)
(sstatus feature FOR-MACLISP)))
)
#-FM (globalize "EVAL-ORDERED" "EVAL-ORDERED*")
(herald EVONCE /14)
#-For-NIL (eval-when (eval compile)
(macro lispdir (x)
(setq x (cadr x))
#+Pdp10 `(QUOTE ((LISP) ,x))
#+Lispm (string-append "lisp;" (get-pname x) "qfasl")
#+Multics (catenate ">exl>lisp_dir>object" (get_pname x))
#+For-NIL (string-append "lisp:" (get-pname x) "vasl")
)
(macro subload (x)
(setq x (cadr x))
`(OR (GET ',x 'VERSION) (LOAD #%(LISPDIR ,x))))
(subload DEFSETF)
)
(defmacro EVAL-ORDERED (bvl forms &rest body)
(eval-ordered* bvl forms body))
; (not (null (SETF-gensyms expf))) is not really the right
; predicate. Consider where one side-effectible and rest all constant.
; the right thing to do is to use SETF-SIDE-EFFECT-SCAN rather than SIMPLEP
; since we aren't worried about multiple evaluation, just ordering.
; Don't forget to write SETF-SIDE-EFFECT-SCAN first!
(defun eval-ordered* (bvl forms body)
(let ((expf (SETF-struct () () () forms)))
(SETF-simplep-scan expf ())
(progv bvl (SETF-compute expf)
(cond ((not (null (SETF-gensyms expf)))
`((lambda ,(SETF-gensyms expf)
,@(eval body))
,@(setf-genvals expf)))
('T `(progn ,@(eval body)))))))
;; The following is not yet complete...make it invisible
#+EVAL-ONCE-TEST
(defmacro eval-once (bvl . body)
(do ((ibvl bvl (cdr ibvl))
(expfsym (gensym) (gensym))
(expf-bvl) (nbvl))
((null ibvl)
`(let ,expf-bvl
(let ,nbvl ,@body)))
(desetq (bindform expf-form) (car ibvl))
(push `(,expfsym (+internal-setf-x-1 ',expf-form)) expf-bvl)
(cond ((not (and (get (cons () bindform) 'genvals)
(get (cons () bindform) 'gensyms)))
(error '|GENVALS and GENSYMS are required information -- EVAL-ONCE|
bindform)))
(do ((form bindform (cddr form)))
((null form))
(cond ((setq temp
(cdr (assq (car form)
'((COMPUTE . SETF-compute)
(I-COMPUTE . SETF-i-compute)
(SIDE-EFFECTS . SETF-side-effects)
(RET-OK . SETF-ret-ok)
(ACCESS-FUN . SETF-access)
(ACCESS . SETF-access-expanded)
(INVERT-FUN . SETF-invert)
(GENVALS . SETF-genvals)
(GENSYMS . SETF-gensyms)))))
(push `(,(cadr form) (,temp ,expfsym)) nbvl))
(T (error '|Unknown info name -- EVAL-ONCE| (car form)
'wrng-type-arg))))))
#+EVAL-ONCE-TEST
(defmacro SETF-access-expanded (expf)
`(apply (setf-access ,expf) (setf-compute ,expf)))

45
src/nilcom/subloa.3 Executable file
View File

@@ -0,0 +1,45 @@
;;; SUBLOAD -*-mode:lisp;package:si;lowercase:T-*-
;;; **************************************************************************
;;; ***** NIL ****** NIL/MacLISP/LISPM Preamble for Autoloadings *************
;;; **************************************************************************
;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
;;; **************************************************************************
#+Compile-Subload
(herald SUBLOAD /3) ;DONT USE HERALD!! this file usually gets included
#+(or Compile-Subload
#.(if (fboundp 'SUBLOAD) ;How to say "Flush this stuff if merely
'THIS-AINT-NO-FEATURE ; INCLUDEing it into a lisp/compiler
'PAGING ; which already have these loaded"
))
(eval-when (eval compile #+Compile-Subload load)
(defun (AUTOLOAD-FILENAME macro) (x)
(let (((() module-name) x)
(more (and (if (get 'SHARPCONDITIONALS 'VERSION)
(featurep '(and MacLISP (not For-NIL)))
(status nofeature For-NIL))
'(FASL))))
`'((LISP) ,module-name ,.more)))
(defun (SUBLOAD macro) (x)
(let ((module-name (cadr x)))
`(OR (GET ',module-name 'VERSION)
(LOAD ,(macroexpand `(AUTOLOAD-FILENAME ,module-name))))))
(defun (SUBLOAD-FUNCTION macro) (x)
(let ((fun-name (cadr x)))
`(OR (FBOUNDP ',fun-name)
(+INTERNAL-TRY-AUTOLOADP ',fun-name))))
(defun (DEF-OR-AUTOLOADABLE macro) (x)
(let (((() function-name module-name) x))
`(OR (FBOUNDP ',function-name)
(GET ',function-name 'AUTOLOAD)
,`(DEFPROP ,function-name
,(eval `(AUTOLOAD-FILENAME ,module-name))
AUTOLOAD))))
)

74
src/rwk/debmac.4 Executable file
View File

@@ -0,0 +1,74 @@
; -*- Mode:LISP;Lowercase:T-*-
(herald DEBMAC /1)
(defvar *CURSOR*)
(defvar *FRAME*)
(defvar *TOP-FRAME*)
(defvar *BOTTOM-FRAME*)
(defvar **ARG** () "Argument to debug commands")
(declare (fixnum (*readch2)))
(defvar debug-prinlevel)
(defvar debug-prinlength)
(defvar debug-prin1)
(defvar debug-sprinter-mode)
(defvar debug-indent-max)
(defvar debug-prompt)
(defvar debug-frame-suppression-alist)
(defvar debug-suppression-reasons)
(defvar si:ignored-error-funs)
(and (fboundp 'special) (special error-io))
;; The following function is defined for run time in DEBUG, make any changes
;; there as well.
(defun debug-name-char (ch)
(caseq ch
(#\HELP "Help")
(#\RETURN "Return")
(#\TAB "Tab")
(#\SPACE "Space")
(#\LINEFEED "Linefeed")
(#\BACKSPACE "Backspace")
(#\RUBOUT "Rubout")
(#\FORM "Form")
(T (if (> ch #\SPACE)
(format () "~C" ch)
(format () "^~C" (+ ch #o100))))))
(defvst debug-frame
next
previous
next-interesting
previous-interesting
type
form
function
arguments
bindstk
callstk
frame-list
plist)
(defvst debug-command-spec
chars
fun
doc)
(defmacro def-debug-command (chars doc &body fun)
(if (atom chars)
(setq chars (ncons chars)))
(let ((command-fun-sym (symbolconc 'DEBUG-COMMAND-
(debug-name-char (car chars)))))
`(progn 'compile
(defun ,command-fun-sym ()
,@fun)
(enter-debug-command ',chars ',command-fun-sym ',doc))))