diff --git a/Makefile b/Makefile index e00146a8..01793aff 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ EMULATOR ?= simh -SRC = system syseng sysen1 sysen2 sysnet kshack dragon channa midas _teco_ emacs rms klh syshst sra mrc ksc cstacy gren bawden emacs1 _mail_ l lisp liblsp libdoc comlap +SRC = system syseng sysen1 sysen2 sysnet kshack dragon channa midas _teco_ emacs rms klh syshst sra mrc ksc cstacy gren bawden emacs1 _mail_ l lisp liblsp libdoc comlap lspsrc nilcom rwk inquir DOC = info _info_ sysdoc kshack _teco_ emacs emacs1 MINSYS = _ sys sys2 sys3 device emacs _teco_ sysbin inquir diff --git a/README.md b/README.md index 811f076d..61cd6b94 100644 --- a/README.md +++ b/README.md @@ -102,6 +102,7 @@ from scratch. - LISP, lisp interpreter and runtime library (autoloads only) - COMPLR, lisp compiler - BINPRT, display information about binary executable file + - INQUIR, user account database 6. A brand new host table is built from the host table source and installed into SYSBIN; HOSTS3 > using H3MAKE. diff --git a/build/build.tcl b/build/build.tcl index 0e14d777..8cde65fa 100644 --- a/build/build.tcl +++ b/build/build.tcl @@ -481,9 +481,10 @@ respond "*" ":link .info.;mail info,.info.;qmail info\r" # lisp respond "*" ":link l;fasdfs 1,lisp;.fasl defs\r" -respond "*" ":link l;grind fasl,lisp;gfile fasl\r" -respond "*" ":link l;grinde fasl,lisp;gfn fasl\r" +respond "*" ":link lisp;grind fasl,lisp;gfile fasl\r" +respond "*" ":link lisp;grinde fasl,lisp;gfn fasl\r" respond "*" ":link l;loop fasl,liblsp;loop fasl\r" +respond "*" ":link lisp;loop fasl,liblsp;loop fasl\r" respond "*" ":midas .temp.;_l;*lisp\r" respond "end input with ^C" "\003" @@ -528,6 +529,33 @@ respond "*" ":link info;complr 1,info;lispc >\r" respond "*" ":midas sys3;ts binprt_sysen1;binprt\r" expect ":KILL" +# inquir +respond "*" ":link lisp;subloa lsp,nilcom;subloa >\r" +respond "*" ":link sys;.fasl defs,lisp;.fasl defs\r" +respond "*" ":midas inquir;_lsrrtn\r" +expect ":KILL" +respond "*" ":link liblsp;debug fasl,liblsp;dbg fasl\r" +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;tty\r" +respond "_" "inquir;reader\r" +respond "_" "lisp;_nilcom;subloa\r" +respond "_" "lisp;_lspsrc;umlmac\r" +respond "_" "inquir;fake-s\r" +respond "_" "rwk;debmac\r" +respond "_" "liblsp;_libdoc;lispm\r" +respond "_" "lisp;_nilcom;evonce\r" +respond "_" "inquir;inquir\r" +respond "_" "\032" +type ":kill\r" +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;dbg rwk1\r" +respond "_" "liblsp;_libdoc;comrd kmp1\r" +respond "_" "\032" +type ":kill\r" +respond "*" ":lisp inquir;inquir (dump)\r" +respond "*" ":link inquir;ts inquir,inquir;inqbin >\r" +respond "*" ":link sys;ts inquir,inquir;ts inquir\r" + # ndskdmp tape respond "*" ":link kshack;good ram,.;ram ram\r" diff --git a/src/_mail_/names.2006 b/src/_mail_/names.2006 index 3ec1c0e4..6e36414c 100644 --- a/src/_mail_/names.2006 +++ b/src/_mail_/names.2006 @@ -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)) diff --git a/src/inquir/fake-s.28 b/src/inquir/fake-s.28 new file mode 100644 index 00000000..3aafe467 --- /dev/null +++ b/src/inquir/fake-s.28 @@ -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:;î diff --git a/src/inquir/inquir.(dump) b/src/inquir/inquir.(dump) new file mode 100644 index 00000000..9c394481 --- /dev/null +++ b/src/inquir/inquir.(dump) @@ -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)) diff --git a/src/inquir/inquir.182 b/src/inquir/inquir.182 new file mode 100644 index 00000000..22f305f7 --- /dev/null +++ b/src/inquir/inquir.182 @@ -0,0 +1,1351 @@ +;;; -*- Mode: Lisp -*- + +;;;; New INQUIR - User interface to the LSR1 database of ITS users. +;;; - CStacy, November 1983. +;;; +;;; Replaces awful MIDAS program of the same name. +;;; Includes lots of KMP packages and influence. +;;; +;;; (c) 1983, Massachusetts Institute of Technology. All rights reserved. +;;; Permission to copy all or part of this material is granted, provided +;;; that the copies are not made or distributed for resale, the MIT +;;; copyright notice and reference to the source file and the software +;;; distribution version appear, and that notice is given that copying +;;; is by permission of Massachusetts Institute of Technology. + +;Things to do: +; o WHOIS command (FIRST-NAME-FIRST,FIRST-LINE-OF) +; o Add LGOTIM pkg +; o Finish implementing updates propogation feature +; o Inquire reap +; o Stats + + +;;;; Basic Support and Setup. + +(herald inquir) ;INQUIR Version. + ;There may also be INQFIX files. +;(putprop 'inquir "Experimental" 'release-status) + +(setq base 10. ibase 10. *nopoint t) ;Reasonable numbers. + +(sstatus feature noldmsg) ;Quietly. + +;;; Macros. +(eval-when (eval compile) + (if (not (get 'umlmac 'version)) + (load '((lisp) umlmac fasl)))) + +;;; Lisp Machine compatability. +(eval-when (eval compile) + (load '((liblsp) lispm fasl))) + +;;; KMP's reader and fancy completing command reader. +(load '((inquir) reader)) +(load '((liblsp) comrd)) + +;;; KMP & CSTACY's Fake Strings. +(if (not (status feature fake-s)) + (load '((inquir) fake-s fasl))) + +;;; TTY hackery. +(eval-when (eval compile) (load '((liblsp) tty))) + +;;; LSR1 database access. +(if (not (status feature lsrrtn)) + (load '((inquir) lsrrtn fasl))) + +;;; HOSTS3 database access. +(if (not (status feature netrtn)) + (load '((inquir) netrtn fasl))) + +;;; LOGOUT TIMES database access. +;(if (not (status feature netrtn)) +; (load '((spacy) lgotim fasl))) + +;;; Declarations to keep COMPLR happy. + +(declare (*lexpr + substring string-search string-append + terminate-command abort-command bug + abort-command-handler flush-command-handler + pretty-more-handler flush-inquir + change-item verify-item + update-one-machine) + (*expr + string-upcase string-downcase + reader *completing-read *completing-read1 + char-upcase string string-equal + lsritm lsrunm lsrmap lsrnxt lsrdta)) +; host-equal lookup-host +; map-lgotim last-logout)) + + +;;;; Low-level Lisp extensions. + +;;; Macro to define accessor macros for preoperties. + +(defmacro define-property-cell (name) + `(defmacro ,name (x) `(get ,x ',',name))) + +;;; Lisp Machine Lisp has this general-purpose +;;; MEMbership testing function. +;;; (MEM #'EQ FOO BAR) <==> (MEMQ FOO BAR) + +(defun mem (pred item list) + (do l list (cdr l) (null l) + (and (funcall pred item (car l)) + (return l)))) + +;;; A limited kind of READ-FROM-STRING. + +(defun list-from-string (s) + (readlist (explodec (string-append "(" s ")" )))) + + + +;;;; The Inquir items. + +;;; These are the item numbers defined in and used for LSRRTNs. + +(declare (special I$UNAM I$NAME I$NICK I$LOCL I$MITA I$MITT I$HOMA + I$HOMT I$SUPR I$PROJ I$DIR I$AUTH I$GRP I$REL + I$BRTH I$REM I$NETA I$ALTR I$MACH)) + + +;;; The names of each of the items is a command the user can type. +;;; Asking for HELP on it will tell him the brief command description. +;;; + +;;; We store the description of the item on plist of its symbolic name. +;;; The aggregate "current INQUIR entry" we are hacking is +;;; *INQUIR-ITEMS*, a list of the item symbols. + +(defvar *suname* nil + "The UNAME of the current INQUIR entry we are modifying.") + +(defvar *inquir-items* nil + "All the item symbols.") + +(define-property-cell inquir-value) +(define-property-cell i$number) +(define-property-cell inqupd-name) +(define-property-cell doc) +(define-property-cell windy-doc) +(define-property-cell max-length) + +(defmacro def-item (item max-length i$number inqupd-name doc windy-doc) + `(progn 'compile + (setf (inquir-value ',item) nil) + (setf (i$number ',item) ,i$number) + (setf (doc ',item) ',doc) + (setf (windy-doc ',item) ',windy-doc) + (setf (inqupd-name ',item) ,inqupd-name) + (setf (max-length ',item) ,max-length) + (when (not (member ',item *inquir-items*)) + (push ',item *inquir-items*)))) + + + +(def-item USER-NAME 6. I$UNAM "UNAME" "User name" + "~&What you intend to usually log in as.~ + ~%If you don't have one picked out, use your initials.") + +(def-item AUTHORIZATION 16. I$AUTH "AUTHO" "Authorization" + "~&Whether you are a good guy (wear a white hat).") + +(def-item NAME 40. I$NAME "NAME" "Name" + "~&Full name. Last name first, as in /"Luser, John Q./"~ + ~%If you have a suffix, such as /"Jr./", put it at the end, after a second~ + ~%comma: /"Luser, John Q., Jr./". Please capitalize your name as you wish~ + ~%the machine to.") + +(def-item NICK-NAME 30. I$NICK "NICK" "Nickname" + "~&Nickname. What you like to be called.") + +(def-item MIT-ADDRESS 80. I$MITA "MITAD" "MIT address" + "~&MIT building # and room #, as in /"10-251/".~ + ~%(Note: 545 Technology Sq. is building # NE43.)~ + ~%If you do not frequent MIT, use your address at work.") + +(def-item MIT-PHONE 30. I$MITT "MITTE" "MIT phone #" + "~&Your MIT phone number(s), as in /"3-1415/".") + +(def-item HOME-ADDRESS 80. I$HOMA "HOMAD" "Home address" + "~&Your home address.") + +(def-item HOME-PHONE 30. I$HOMT "HOMTE" "Home phone #" + "~&Your home phone number.") + +(def-item NETWORK-ADDRESS 40. I$NETA "NETAD" "Network address" + "~&This is where you specify your /"home address/" on the network;~ + ~&where you receive your computer mail.~ + ~&~%If you want to receive your computer mail on this system, just + ~&type a Return. Otherwise, enter a network host name, or~ + ~&username@hostname. Your computer mail will be forwarded there.~ + ~&~%Do not put a U.S. mail address here, since the network mailing~ + ~&programs will not understand what you mean. +~&~%Note : o Do not give just as username with no hostname.~ + ~& o Do not specify a TAC as the hostname, since TACs are~ + ~& unable able to receive mail for you.~ +~&~%Just type a Return if you don't know what to do with this field.") + +(def-item SUPERVISOR 30. I$SUPR "SUPER" "Supervisor" + "~&Your supervisor//advisor's name(s).") + +(def-item PROJECT 40. I$PROJ "PROJE" "Project" + "~&The name of your project.~ + ~%This will fill in /"I am hacking _____ for /".") + +(def-item FILE-DIRECTORIES 40. I$DIR "FILDI" "File directory name(s)" + "~&The name of your home directory.~ + ~%Type the names of the directories you want as your HSNAME on the~ + ~%various ITS machines. You should not mention machines on which~ + ~%you have a directory of your own.~ + ~&~%A directory with no machine name applies to all machines that~ + ~%such a directory exists on.~ + ~&~%Example: /"SIPB@MC,KBS/" specifies SIPB on the MC machine, and KBS~ + ~%on all other machines with a KBS directory.~ + ~&~%Note: Do not specify USERSn or GUESTn directories here.~ + ~& These are chosen for you by the system, and are~ + ~& subject to change, and ARE NOT CONSTANT FROM ONE~ + ~& MACHINE TO ANOTHER.") + + +(def-item GROUP-AFFILIATION 1. I$GRP "GROUP" "Group" + "~&Group affiliation. Enter one letter only.~ + ~%Choose the one that fits best, from the following list:~ + ~%A - Artificial Intelligence Lab person.~ + ~%B - Educational Computing Group person.~ + ~%C - Theory Group person.~ + ~%L - Laboratory for Computer Science person.~ + ~%P - Plasma Fusion Center person.~ + ~%S - MIT guest - student//staff//faculty not in one of the other groups.~ + ~%T - Guest (tourist).~ + ~%V - NIL Group.+ + ~%Z - Clinical Decision Making person.~ + ~%+ - Official maintainter//Liaison on some MIT computer system.~ + ~%$ - Official maintainter//Liaison on some ARPANET computer system.~ + ~%@ - This is an alias for someone known under another name.~ + ~%O - Other. This designates a program, not a person.") + +(def-item RELATION-TO-GROUP 1. I$REL "RELAT" "Relation" + "~&Your Relation to your group. Enter one letter only.~ + ~%Choose the one that fits, best from the following list:~ + ~%A - Administrative F - Faculty~ + ~%G - Graduate student P - Publications//Editing~ + ~%R - Research associate S - DSR (sponsored research) staff~ + ~%U - Undergraduate student ~ + ~%X - Ex-user (former MIT staff//faculty)~ + ~% N - None~%") + +(def-item BIRTHDAY 20. I$BRTH "BIRTH" "Birthday" + "~&Birthday. The format should be as in /"January 1/".~ + ~%(ie, no year or European-style formats).") + +(def-item REMARKS 630. I$REM "REMAR" "Remarks" + "~&Remarks. Put anything in here you want to add.~ + ~%It will be printed whenever someone looks you up.") + +;(def-item MACHINES-KNOWN-ON 80. I$MACH "MACHI" "Machines known on" +; "~&This is not used at the present time.~ +; ~&Your INQUIR entry is automatically known on all ITS machines.") +; +;(def-item LOCAL-FIELDS 30. I$LOCL "LOCAL" "Local fields" +; "~&This is not used at the present time. It goes with Machines Known On") + +(def-item ALTERATION-DATE 0. I$ALTR "ALTER" "Last alteration" + "~&This says who last altered your INQUIR entry, and when they did so.~ + ~&(This is filled in automatically for you.") + + + +;;;; Groups and Relations +;;; (We don't use this yet; need it for INQREP stuff later.) + +;;; Associate the group letters with their documentation. + +(defvar *inquir-groups-alist* + (list + (cons #/A "Artificial Intelligence Lab person") + (cons #/B "Educational Computing Group person") + (cons #/C "Theory Group person") + (cons #/L "Laboratory for Computer Science person") + (cons #/P "Plasma Fusion Center person") + (cons #/S "MIT guest - student//staff//faculty not in one of the other groups") + (cons #/T "Guest (tourist)") + (cons #/V "NIL Group") + (cons #/X "Ex-user (former MIT staff//faculty") + (cons #/Z "Clinical Decision Making person") + (cons #/+ "Official Maintainter//Liaison on some MIT computer system") + (cons #/$ "Official Maintainter//Liaison on some ARPANET computer system") + (cons #/@ "This is an alias for someone known under another name") + (cons #/O "Other. This designates a program, not a person"))) + +;;; Associates the relation letters with their documentation. + +(defvar *inquir-relats-alist* + (list + (cons #/A "Administrative") + (cons #/F "Faculty") + (cons #/G "Graduate student") + (cons #/P "Publications//Editing") + (cons #/R "Research associate") + (cons #/S "DSR (sponsored research) staff") + (cons #/U "Undergraduate student ") + (cons #/N "None"))) + + + +;;;; I/O Support functions. + +;;; Feep the bell. + +(defun beep () + (tyo #^G)) ;Ding. + +;;; Function to strip away those nasty chars. + +(defun trim-bad-chars (char-list) + (delete '#.(ascii #\Null) char-list)) + +;;; "A" or "An"? from KMP's ANIMAL technology. + +(defun a-or-an (symbol) + (let ((ch (char-upcase (getcharn symbol 1))) + (len (flatc symbol))) + (cond ((= len 1) + (cond ((member ch '(#/A #/E #/F #/H #/I #/L #/M + #/N #/O #/R #/S #/X)) + 'an) + (t 'a))) + (t + (cond ((member (char-upcase ch) '(#/A #/E #/I #/O #/U)) + 'an) + (t 'a)))))) + + + +;;; When we pass reading functions around, there callers +;;; sometimes need to know what the best break character +;;; is, for documentation purposes. + +(defvar *terminator* #\return "The terminator we're looking for") + +(defmacro with-terminator (terminator &body forms) + `(let ((*terminator* ,terminator)) + ,@forms)) + + +;;; REASONABLE-DISPLAY-TERMINAL? returns T if the TTY is something +;;; I could stand with e.g. automatic LISTME turned on. + +(defun reasonable-display-terminal? (&optional (tty (status ttyofa))) + (let ((tty-flags (cdr (status filemode tty))) + (tty-speed (status ospeed tty))) + (if (and (memq 'rubout tty-flags) + (memq 'cursorpos tty-flags) + (or (zerop tty-speed) + (>= tty-speed 1200.)) + (> (car (status ttysize tty)) + (plus 2. (length *inquir-items*)))) + t + NIL))) + + +;;; DISPLAY-ITEM prints an item as for a LISTME display. + +(defvar *display-start-col* 25.) + +(defun display-item (stream item &optional (start-col *display-start-col*) + (max-width #.(cdr (status ttysize)))) + (format stream "~&~A:~VT" (doc item) start-col) ;Print item name. + (let* ((val (inquir-value item)) + (chars (if val (exploden val)))) ;Get value. + (do ((c chars (cdr c)) + (new-line-flag nil) + (pos-avail max-width)) + ((null c)) + (let ((c (car c))) + (cond (new-line-flag + (cond ((= c #\LF) + (tyo c stream) + (format stream "~VT" start-col) + (setq pos-avail max-width)) + (t + (format stream "~VT" start-col) + (setq pos-avail max-width) + (tyo c stream)))) + (t + (tyo c stream) + (setq pos-avail (1- pos-avail)))) + (setq new-line-flag (= c #\CR)) + (when (zerop pos-avail) + (terpri stream) + (format stream "~VT" start-col) + (setq pos-avail max-width)))))) ;Restart count. + + +;;; Print the name and value of an item as INQUPD likes to see it. + +(defun print-inqupd-item (stream item) + (format stream "~&~A:~C" (inqupd-name item) #\tab) ;Item name. + (let* ((val (inquir-value item)) + (chars (if val (exploden val))) + (new-line-flag nil)) + (dolist (c chars) + (cond (new-line-flag + (cond ((= c #\LF) + (tyo c stream) + (tyo #\tab stream)) + (t + (tyo #\tab stream) + (tyo c stream)))) + (t + (tyo c stream))) + (setq new-line-flag (= c #\CR))))) + + + +;;;; Prettier MORE processing. + +;;; Stolen from TNP;FORT. +;;; CATCH-**MORE** +;;; Catch a throw to flush output after a **MORE**. + + +(defvar *can-flush-more* nil) +(defvar *in-more-break* nil) + +(defmacro catch-**more** (&body body) + `(*catch '*can-flush-more* + (let ((*can-flush-more* t)) + ,@body))) + + +;;; DONT-CATCH-**MORE** +(defmacro dont-catch-**more** (&body body) + `(let ((*can-flush-more* nil)) + ,@body)) + +(defun **more** (stream) + (nointerrupt nil) + (do-with-tty-off + (let ((*in-more-break* t)) + (cond (*can-flush-more* (maybe-**more** stream (status ttycons stream))) + (t (surely-**more** stream (status ttycons stream))))))) + +(defun maybe-**more** (outstream instream) + (let ((where (cursorpos outstream))) + (cursorpos 'l outstream) + (format outstream "--More?--") + (do ((c (tyi instream) (tyi instream)) + (flag t)) + (nil) + (cond ((= c #\rubout) + (cursorpos (car where) (cdr where) outstream) + (cursorpos 'l outstream) + (format outstream "--Output flushed--~%") + (*throw '*can-flush-more* t)) + ((= c #\space) + (cursorpos (car where) (cdr where) outstream) + (cursorpos 'l outstream) + (format outstream "--Continuing--~%") + (return t)) + (flag + (setq flag nil) + (format outstream + "(Type SPACE to continue or RUBOUT to flush output)")))))) + +(defun surely-**more** (outstream instream) + (let ((where (cursorpos outstream))) + (cursorpos 'l outstream) + (format outstream "--Pause--") + (do ((c (tyi instream) (tyi instream)) + (flag t)) + (nil) + (cond ((= c #\space) + (cursorpos (car where) (cdr where) outstream) + (cursorpos 'l outstream) + (format outstream "--Continuing--~%") + (return t)) + (flag + (setq flag nil) + (format outstream + "(Type SPACE to continue)")))))) + + + +;;;; Hacking items + +;;; These variables control the mode of interaction: + +(defvar *brief-prompt* "What next? ") +(defvar *windy-prompt* "What next? (Type ? for assistance): ") + +(defvar *prompt* *brief-prompt* + "The top-level command prompt.") + + +(defvar *windy-mode* nil + "T for maximum verbosity") + +(defvar *display-mode* nil + "T to do automatic LISTME after each change.") + +(defvar *verify-mode* nil + "T to require verification on input") + + +(defvar *modified* nil + "T if the current entry has been changed.") + +(defvar *inhibit-listme?* nil + "T to inhibit LISTME in CHANGE-ITEM.") + +;;; CHANGE-ITEM is called by commands which change items. +;;; It provides a uniform kind of prompt, and hacks verification. +;;; You pass it a function to read the item and the argumentsts for same. + +(defun change-item (item-name read-fn &rest read-args) + (lexpr-funcall #'change-item1 item-name read-fn read-fn read-args) + (if (and *display-mode* + (not *inhibit-listme?*)) + (listme))) + + +(defun change-item1 (item-name read-fn verify-fn &rest read-args) + (let ((val (inquir-value item-name))) + (if val ;If something already filled in + (format t "~&~A~%~A" (doc item-name) val)) ; print it out. + (terpri t) + (format t (if *windy-mode* (windy-doc item-name) + (doc item-name))) + (if *terminator* + (format t "~&End your input with a ~@:C.~%" *terminator*) + (format t "~&")) + (setf (inquir-value item-name) (lexpr-funcall read-fn read-args)) + (setq *modified* t) + (if *verify-mode* ; Now make sure he really meant it. + (do ((newnewval + (lexpr-funcall #'verify-item item-name verify-fn read-args) + (lexpr-funcall #'verify-item item-name verify-fn read-args))) + ((not newnewval)) )))) + + +;;; Returns NIL when the user is satisfied with the changes. + +(defun verify-item (item-name read-fn &rest read-args &aux newval) + (format t "~& Is this right for ~A?" (doc item-name)) + (format t "~& Type what it should look like, or ~@:C if this looks good.~ + ~&~A~%" + (or *terminator* #\Return) + (inquir-value item-name)) + (setq newval (lexpr-funcall read-fn read-args)) ;Get a replacement value. + (cond ((not (string-equal newval "")) ;Store it. + (setf (inquir-value item-name) newval) + newval))) ;Return it, or NIL if there was no replacement. + + +;;; TTY item reader, calls READER. +;;; Returns a string. + +(defun inputter (&optional (prompt "->") + (max #.(* 24. 80.)) + multi? + upcase?) + (*catch 'too-long + (let ((chars (nreverse + (mapcar #'(lambda (x) + (setq x (getcharn x 1)) + (if upcase? (setq x (char-upcase x))) + x) + (reader prompt (if multi? '(#^C) '(#\CR #\LF #^C))))))) + (if (and multi? + (> (length chars) 1) + (= (car chars) #\CR)) + (pop chars)) ;Flush trailing CR. + (when (> (length chars) max) + (format t "~&That's too long for this item.") + (dolist (c chars) ;Let him try again. + (untyi c tyi)) + (*throw 'too-long t)) + (string (implode (nreverse (trim-bad-chars chars))))))) + + +;;; For reading in items: +;;; PROMPT-TYI for single chars. +;;; PROMPT-READLINE for single lines. +;;; PROMPT-INPUT for multiple lines. +;;; INPUT-SIXBIT for six uppercase chars. + +(defun prompt-readline (&optional (prompt "->") max) + (inputter prompt max nil nil)) + +(defun prompt-tyi (&optional (prompt "->") (upcase? t) &aux c) + (format t "~A" prompt) + (setq c (tyi)) + (if (or (equal c #\CR) (equal c #\LF)) + "" + (if upcase? (ascii (char-upcase c)) + (ascii c)))) + + +(defun input-sixbit (&optional (prompt "->")) + (inputter prompt 6. nil t)) + +(defun prompt-input (&optional (prompt "->") (max)) + (inputter prompt max t nil)) + + +;;; INPUT-NETADDR is for typing in network addresses. + +(defun input-netaddr (&rest read-args) + (let ((netaddr (lexpr-funcall #'inputter read-args))) + (if (string-equal netaddr "") + (string (status site)) + netaddr))) + + + +;;; Fancy completing command reader, calls *COMPLETING-READ1. + +(defun get-input-line (prompt options &optional (over-rubout-allowed? t)) + (cond ((zerop (charpos tyo)) (format t "~&~A" prompt))) + (prog1 (do () (nil) + (let ((command (*completing-read1 prompt + options + '() + tyi + tyo + t + t + '(#\ALT) + '(#\RETURN #\SPACE) + t + over-rubout-allowed?))) + (cond ((memq command '(over-rubout line-rubout)) + (abort-command)) + ((atom command) ;line-rubout, word-rubout, etc. + (format t "~&~A" prompt)) + (t (return (cadr command)))))) + (cond ((and (plusp (listen tyi)) (= (tyipeek nil tyi) #\LF)) + (tyo (tyi tyi) tyo))))) + + + +;;;; LSR1 and LOGOUT TIMES database hacking. +;;; +;;; LSRRTN primitives: +;;; +;;; (LSRMAP ) ==> file object. +;;; (LSRDTA ) ==> core address of first entry or -1 +;;; (LSRNXT ) ==> core address of next entry or -1 +;;; (LSRUNM ) ==> core address or -1 +;;; (LSRITM ) ==> item symbol frob +;;; +;;; NETRTN primitives: +;;; +;;; (MAP-HOSTS3) ==> gets the network database in core. +;;; (OWN-HOST network-number) ==> host. +;;; (HOST-EQUAL host1 host2) ==> T iff they refer to same host. +;;; (LOOKUP-HOST host-name) ==> host-number. +;;; (HOST-SIXBIT-NAME host) ==> sixbit host name. + + +(defvar *lsr1* nil) ;LSR1 file object. +;(defvar *logout-times* nil) ;LGOTIM file object. + +;;; Map databases. + +(defun map-inquir () + (setq *lsr1* (lsrmap 20.))) + +;(defun map-logout-times () +; (setq *logout-times* (map-lgotim))) + + +;;; GET-ENTRY reads the data for the current INQUIR entry from the +;;; LSR1 database. The LSR1 database must already be mapped in. +;;; If the named user does not have an entry, GET-ENTRY returns NIL. + +(defun get-entry (uname) + (without-interrupts ;No interruptions, please. + ;; Remember who the current entry belongs to. + ;; Try looking up in the LSR1 database. + (let ((entry (lsrunm *lsr1* uname)) + (val)) + (cond + ((and entry (not (= entry -1))) + (dolist (item *inquir-items*) ;Fill in current entry from LSR1. + (setq val (lsritm (i$number item) entry)) + (setf (inquir-value item) (string val))) + t) + (t ;If unknown, just set Uname. + (setf (inquir-value 'user-name) (string (string-upcase uname))) + nil))))) + + +(defvar *default-local-items-string* + "FILE-DIRECTORIES GROUP-AFFILIATION RELATION-TO-GROUP") + + +;;; LAST-ALTERATION returns the current timestamp string for an ALTER item. + +(defun last-alteration () + (lexpr-funcall #'format nil "~A ~2,'0D~2,'0D~2,'0D-~2,'0D~2,'0D~2,'0D" + (status uname) + (append (status date) (status daytime)))) + + +;;; UPDATE-INQUIR updates the LSR1 file from the current Inquir entry. +;;; (Actually, it mails off a request for INQUPD to do so.) +;;; This is the mail routine usually called by DONE. + +(defvar *inqupd-request-file* "DSK:.MAIL.;MAIL >") + +;;; We have to use this until we get HOSTS3 going in Lisp. +;;; Would you believe...until we get domains going in Lisp! + +(defun old-style-update-inquir () + (setf (inquir-value 'machines-known-on) + (string-append *suname* "@AI @MC @ML @MD @DB")) + (if (or (null (inquir-value 'authorization)) + (string-equal (inquir-value 'authorization) "")) + (setf (inquir-value 'authorization) "*")) + (setf (inquir-value 'local-fields) "FILDI GROUP RELAT") + (setf (inquir-value 'alteration-date) (last-alteration)) + (with-open-file (s *inqupd-request-file* '(out)) + (format s "~&FROM-PROGRAM:~A~ + ~&AUTHOR:~A~ + ~&RCPT:(UPDATE-ITS-INQUIR)" + (status jname) + (status uname)) + (format s "~&TEXT;-1~ + ~&BEGIN:~%~ + ~&SUNAME:~C~A" + #\tab *suname*) + (dolist (item *inquir-items*) + (print-inqupd-item s item)) + (format s "~&END:~%"))) + + +;;;; UPDATE-INQUIR is called by the DONE command to update all the +;;;; databases mentioned. +; +;(defun update-inquir () +; ;; Set up the ALTER item. +; (setf (inquir-value 'alteration-date) (last-alteration)) +; (let ((macs (list-from-string (inquir-value 'machines-known-on))) +; (updated-hosts nil)) +; (dolist (mac macs) +; (let* ((machine (substring mac (1+ (string-search "@" mac)))) +; (suname (substring mac 0 (string-search "@" mac))) +; (host (lookup-host machine))) +; +; (when (not (mem #'host-equal host updated-hosts)) +; (update-one-machine suname machine) +;; (push host updated-hosts)))))) +;;;;; *** Need to make sure local host is updated with all the items! +; +; +; +; +;;;; UPDATE-ONE-MACHINE sends off an update for a single database. +;;;; It can optionally ignore the LOCAL-FIELDS item. +; +;(defun update-one-machine (suname machi &optional (use-local-fields? t)) +; (with-open-file (s *inqupd-request-file* '(out)) +; (format s "~&FROM-PROGRAM:~A~%~ +; ~&AUTHOR:~A~%~ +; ~&RCPT:(UPDATE-INQUIR ~A)~%~ +; ~&TEXT;-1~ +; ~&BEGIN:~%~ +; ~&SUNAME:~C~A" +; (status jname) +; (status uname) +; machi +; #\tab suname) +; (let ((locals (list-from-string (inquir-value 'local-items)))) +; (dolist (item *inquir-items*) +; (if (and use-local-fields? +; (not (member item locals))) +; (print-inqupd-item s item))) +; (format s "~&END:~%")))) + + + + +;;;; Commands. + +;;; Amazing hairy macro defining macro frobozz. + +(defmacro def-command-type (name) + (let ((doc (symbolconc name '-documentation)) + (var (symbolconc '* name 's*)) + (def (symbolconc 'define- name)) + (fn (symbolconc name '-fn))) + `(progn 'compile + (defmacro ,fn (x) `(get ,x ',',name)) + (defmacro ,doc (x) `(get ,x ',',doc)) + (defvar ,var '()) + (defmacro ,def (name doc &body body) + `(progn 'compile + (push ',name ,',var) + (defun (,name ,',name) () ,@body) + (setf (,',doc ',name) ',doc) + ',name)) + (,def HELP "Gives help on a given command type." + (format t "~&~A" + (,doc (get-input-line + ',(format nil "Help with ~A: " name) + ,var))) + (terminate-command)) + ',name))) + + +(defun not-implemented () + (format t "~&I don't know how to do that to ~A ~A, yet!" + (string-downcase (a-or-an *suname*)) + *suname*)) + + + +;;;; Primary commands. + +(def-command-type command) + +(define-command QUIT "Exits the program without updating any entries." + (cond (*modified* + (if (yes-or-no-p "~&Cancel all these changes? ") + (flush-inquir t) + (format t "~&Use the DONE command when you are happy with ~ + your changes."))) + (t + (flush-inquir t)))) + + +(define-command DONE "Exits the program and starts the update." + (cond (*modified* + (old-style-update-inquir) + (format t "~&Your changes have been sent for processing and~ + ~&should be completed in a little while.")) + (t + (format t "~&(No changes made.)"))) + (format t "~&Thank you.~%") + (flush-inquir t)) + + +;;; Commands which affect the mode of interaction. + +(define-command WINDY "Make INQUIR be verbose." + (setq *windy-mode* t) + (setq *prompt* *windy-prompt*) + (format t "~&Maximum verbosity.")) + + +(define-command BRIEF "Make INQUIR be less verbose." + (setq *windy-mode* nil) + (setq *prompt* *brief-prompt*)) + +(define-command VERIFY "Make INQUIR verify all your changes." + (setq *verify-mode* t)) + + +(define-command NOVERIFY "Make INQUIR stop asking you to verify all your changes." + (setq *verify-mode* nil)) + + +(define-command LISTME "Show what your entry looks like." + (listme)) + +;;; Routine to list our entry. +;;; Called automatically from CHANGE-ITEM when in display mode. + +(defun listme () + (cursorpos 'C) + (dolist (item *inquir-items*) + (display-item t item)) + (terpri) + (terpri)) + +(define-command DESCRIBE + "Tell about a particular INQUIR item." + (let ((item (get-input-line "Describe item: " *inquir-items*))) + (format t (string-append "~&~%" (doc item) ".~&" + (or (windy-doc item) "") + "~2&Current value is:~&~A~2%") + (inquir-value item)))) + +(define-command REVERT + "Cancel all changes; read your old info back in from the database." + (if (yes-or-no-p t "~%Cancel all these changes? ") + (cond ((get-entry *suname*) + (format t "~&OK.") + (setq *modified* nil) + (listme)) + (t + (abort-command "You have no previous info on file."))) + (abort-command))) + + +;(define-command NOTME "Update someone else's entry." +; (not-implemented)) + +;(define-command OTHER "Prefix to other, less commonly used commands." +; (not-implemented)) + +(define-command ALL "Change all of your items." + (change-all-items nil)) + +;;; CHANGE-ALL-ITEMS is for changing all the fields in an entry. +;;; FIRST-TIME? is whether we should ask only for the items we +;;; expect novices running INQUIR for the first time to fill in. + +(defun change-all-items (first-time?) + (let ((*inhibit-listme?* t)) + (dolist (cmd '(NAME NICK-NAME MIT-ADDRESS MIT-PHONE + HOME-ADDRESS HOME-PHONE NETWORK-ADDRESS + SUPERVISOR PROJECT GROUP RELATION BIRTHDAY REMARKS)) + (funcall (command-fn cmd))) + (if (not first-time?) + (dolist (cmd '(AUTHORIZATION FILE-DIRECTORIES)) + (funcall (command-fn cmd)))))) + +;(define-command WHOIS "Display your entry like WHOIS would show it." +; (let ((uname (inquir-value 'uname))) +; (format t "~2&~A ~C~C ~A Last logout ~A" +; uname +; (inquir-value 'group-affiliation) +; (inquir-value 'relation-to-group) +; (first-name-first (inquir-value 'name)) +; (implode (last-logout *logout-times* uname))) +; (format t " (~A) [~A] hacking ~A for ~A~ +; ~% Birthday ~A; ~A; ~A~ +; ~% ~A; ~A~%" +; (inquir-item 'nick-name) +; (inquir-item 'network-address) +; (inquir-item 'project) +; (inquir-item 'supervisor) +; (inquir-item 'birthday) +; (first-line-of (inquir-item 'mit-address)) +; (inquir-item 'mit-phone) +; (first-line-of (inquir-item 'home-address)) +; (inquir-item 'home-phone)))) + + +;;;; Commands which change items + +;;; I had considered making a form which would automatically +;;; write these commands, but I don't think it will save +;;; enough typing to bother with. Something like: +;;; +;;; (defmacro def-item-command (item cmd-doc input-fn) +;;; `(progn 'compile +;;; (setf (initial-asked? ',item) ,initial-asked?) +;;; (define-command ,item ,cmd-doc +;;; (change-item ',item ,input-fn "->" (max-length ',item))))) +;;; + +(define-command USER-NAME "Changes your username." + (change-item 'user-name #'inputter "->" 6. nil t)) + +(define-command NAME "Changes your full personal name." + (change-item 'name #'inputter "->" (max-length 'name))) + +(define-command NICK-NAME "Changes your nickname." + (change-item 'nick-name #'inputter "->" (max-length 'nick-name))) + +(define-command GROUP "Changes your group affiliation." + (with-terminator nil + (change-item 'group-affiliation #'prompt-tyi "->" t))) + +(define-command RELATION "Changes your group relation." + (with-terminator nil + (change-item 'relation-to-group #'prompt-tyi "->" t))) + +(define-command AUTHORIZATION "Say whether you are a good-guy." + (change-item 'authorization #'inputter "->" + (max-length 'authorization))) + +(define-command MIT-ADDRESS "Change your MIT (work) address." + (with-terminator #^C + (change-item 'mit-address #'inputter + "-> +" + (max-length 'mit-address) + t + nil))) + +(define-command HOME-ADDRESS "Change your home address." + (with-terminator #^C + (change-item 'home-address #'inputter + "-> +" + (max-length 'home-address) + t + nil))) + +(define-command MIT-PHONE "Change your MIT (office) phone." + (change-item 'mit-phone #'inputter "->" (max-length 'mit-phone))) + +(define-command HOME-PHONE "Change your home phone." + (change-item 'home-phone #'inputter "->" (max-length 'home-phone))) + +(define-command SUPERVISOR "Change your supervisor." + (change-item 'supervisor #'inputter "->" (max-length 'supervisor))) + +(define-command PROJECT "Change your project." + (change-item 'project #'inputter "->" (max-length 'project))) + +(define-command FILE-DIRECTORIES "Change your home file directories." + (change-item 'file-directories #'inputter + "->" + (max-length 'file-directories))) + +(define-command BIRTHDAY "Change your birthday." + (change-item 'birthday #'inputter "->" (max-length 'birthday))) + +(define-command REMARKS "Change your remarks." + (with-terminator #^C + (change-item 'remarks #'inputter "->" + (max-length 'remarks) + t + nil))) + +(define-command NETWORK-ADDRESS "Change your electronic mail address." + (change-item1 'network-address + #'input-netaddr + #'inputter "->" (max-length 'network-address) nil nil) + (if (and *display-mode* + (not *inhibit-listme?*)) + (listme))) + + +;(define-command MACHINES "Change which database your entry is updated on." +; (not-implemented)) + +;(define-command LOCAL-FIELDS "Change which fields are not propogated to foreign INQUIR databases." +; (not-implemented)) + + + +;;;; Other commands. + +(def-command-type extended-command) + +(define-command EXTENDED + "Preface to less frequently used commands." + (funcall (extended-command-fn + (get-input-line "What else? " *extended-commands*)))) + +(define-command DISPLAY-MODE + "Manually force display terminal mode on." + (setq *display-mode* t)) + +(define-command NODISPLAY-MODE + "Manually force display terminal mode off." + (setq *display-mode* nil)) + + +(define-extended-command DELETE + "Delete the entry you are editing from the database. +INQUIR will forget all about this person." + (terpri t) + (cond ((yes-or-no-p t "Do you really want to flush ~:[your~*~;~A's~] INQUIR entry? " + (not (eq (status xuname) *suname*)) + *suname*) + (setf (inquir-value 'user-name) "") + (setq *modified* t) + (format t "~&OK.") + (if *display-mode* (listme))) + (t + (abort-command)))) + +;(define-extended-command LIST-USERS +; "List users." +; ;; Massive non-destruction! +; (not-implemented)) + + +;;; BREAK loop is for hackers only. +;;; Maybe should be binding ^X and ^G to normal frobs, and ^B to Abort Command. + +(define-extended-command BREAK "Enter a break loop for debugging!" + (setq *can-flush-more* nil) + (break "Type P to continue.") + (setq *can-flush-more* t)) + + +(define-extended-command IGNORE + "Ignore you and get back to regular commands." + (terminate-command)) + + + +;;;; Reaping the INQUIR database. + +;;; These should really be on a seperate INQREP comtab. + +(define-extended-command MASSIVE + "Do massive updates to the database." + ;; Massive destruction! user could supply predicate somehow. + (not-implemented)) + +(define-extended-command NEXT-LUSER + "Update the next luser's entry (used after a MASSIVE command.)" + (not-implemented)) + + + +;;;; Spiels. + +;;; If we are started as inqchk, we give a little explanatory spiel +;;; before getting down to business. + +(defun inqchk-spiel () + (format t + "~2%The program /"INQUIR/" is being run for you so that you can tell us~ + ~%who you are. When you are done running inquir you will be left in~ + ~%DDT, the command interpreter for this computer system.")) + +;;; Here is the long spiel explaining what inquir is, and giving general help. + +(defun explain-inquir-spiel () + (format t + "~&~%The purpose of this program is to maintain a list of users for this~ + ~%computer. It will lead you by the hand; just provide the information~ + ~%requested. If you know what you are doing and don't like being lead,~ + ~%use the BRIEF command.~ + ~2%Each user on ITS has an individual user-name, or /"UNAME/"; a word of~ + ~%six characters or less, which you use to log in. INQUIR keeps its~ + ~%records filed under people's UNAMEs.~ + ~2%Your dossier consists of several items; each is one piece of ~ + ~%information, such as your name, or your home address. + ~%If you are completely unknown, INQUIR will ask you for all of the~ + ~%items in order. If you are already known, you can type the name~ + ~%of any items you wish to alter.~ + ~2%You can leave any of the items blank, if you feel the questions are~ + ~%too nosey. Most people fill in most of the items so that people in~ + ~%the user community can find out about them.~ + ~2%If you are on a display terminal, your entire dossier will be shown~ + ~%frequently. On printing terminals, you must type the LISTME command~ + ~%to see it.~ + ~2%If you make a mistake typing, you can use the Rubout key to erase a~ + ~%character. Typing ^U (holding the Control key down and striking /"U/")~ + ~%will erase the line you are typing. To redisplay the line you are~ + ~%typing, type ^R. To clear the screen and redisplay the line, type ^L.~ + ~2%When INQUIR is ready for a command, it will prompt you.~ + ~%You can type a question mark (?) to see what the possibilities are.~ + ~%If you type a question mark in the middle of a command name, + ~%INQUIR will show you what the possible completions are. + ~%Typing a Space or an Escape will complete the command name for you.")) + + +;;;; Startup. + +;;; TOPLEVEL is magically called when we start up. + +(defun toplevel () + (initialize) ;Map in database, etc. + (dont-catch-**more** + (start-inquir)) ;Prologue. + (do ((first-time-thru t nil)) + (nil) ;This is the command infinite-loop. + (*catch 'command-abort + (catch-**more** + (bind-ttyint ((#^G #'abort-command-handler) + (#^S #'flush-command-handler) + (#^B NIL) (#^C NIL) (#^D NIL) (#^R NIL) + (#^T NIL) (#^V NIL) (#^W NIL) (#^X NIL)) + (when (and first-time-thru + *display-mode*) + (listme)) + (format t "~&") + (when (not + (errset + (funcall + (command-fn (get-input-line *prompt* + *commands* nil))) + t)) + (bug nil))))))) + +(defun initialize () + (without-interrupts + (setq *inquir-items* (nreverse *inquir-items*)) + (setq *commands* (nreverse *commands*)) + (map-inquir) ;Map in the LSR1 database. + #| (map-logout-times) |# ;Map in the LOGOUT TIMES database. + (setq *display-mode* (reasonable-display-terminal?)) + (endpagefn t #'**more**))) ;Turn on **MORE** handler. + + +;;; START-INQUIR makes sure the luser knows who is being hacked, +;;; figures out how verbose to be, and makes new users fill out +;;; everything before returning to the main program. + +(defun start-inquir () + (unless + (errset + (*catch 'command-abort + (catch-**more** + (bind-ttyint ((#^G #'flush-inquir-handler) + (#^S #'flush-inquir-handler) + (#^B NIL) (#^C NIL) (#^D NIL) (#^R NIL) + (#^T NIL) (#^V NIL) (#^W NIL) (#^X NIL)) + (let ((inqchk? (eq (status jname) 'INQCHK)) + (jcl (jcl-as-string))) + (setq *suname* (or jcl + (string-upcase (status xuname)))) + (cond + (inqchk? ;When started by DDT init file, + (when (get-entry *suname*) ; if luser already exists + (flush-inquir t)) ; then punt right now. + (unless (yes-or-no-p t "~%You have logged in as ~A, which is a new UNAME.~ + ~&Is this what you you intended? " + *suname*) + (format t "~&Please type ^Z and try again.") + (valret "0U")) + (inqchk-spiel) + (funcall (command-fn 'WINDY)) + (funcall (command-fn 'VERIFY)) + (enter-new-user)) + (t ;See who the luser is hacking. + (format t "~&~@[~A ~]INQUIR.~D" + (get 'inquir 'release-status) + (get 'inquir 'version)) + (when (null jcl) + (when (null (get-entry *suname*)) + (format t "~%~A is not known." *suname*)) + (unless (y-or-n-p t "~&Is ~A your user name? " *suname*) + (format t "~&Well, that's who you are logged in as.~ + ~&If you want to modify someone else,~ + ~&invoke INQUIR with their UNAME as JCL.") + (flush-inquir t))) + (cond ((null (get-entry *suname*)) + (unless jcl + (explain-inquir-spiel) + (funcall (command-fn 'WINDY)) + (funcall (command-fn 'VERIFY))) + (enter-new-user)) + (t + ;; Luser exists, so just set the verbosity level. + (funcall (command-fn 'NOVERIFY)) + (funcall (command-fn (if jcl 'BRIEF 'WINDY))))))))))) + t) + (bug t))) + +(defun enter-new-user () + (*catch 'command-abort + (bind-ttyint ((#^G #'abort-command-handler) + (#^S #'flush-command-handler) + (#^B NIL) (#^C NIL) (#^D NIL) (#^R NIL) + (#^T NIL) (#^V NIL) (#^W NIL) (#^X NIL)) + (terpri t) + (change-all-items t)))) ;Then put luser to work. + +(defun jcl-as-string (&aux jcl) + "JCL-AS-STRING finds out if there is JCL, and returns it or NIL. + Flushes spaces and JCL-terminators." + (setq jcl (status jcl)) + (when jcl + (let ((jcl (delete '#.(ascii #\return) + (delete '#.(ascii #\space) + (delete '#.(ascii #^C) + (delete '#.(ascii #^_) jcl)))))) + (if jcl ;Prevent "". + (string-upcase (substring (implode jcl) 0 6)))))) + + + +;;; TERMINATE-COMMAND, gets us back to toplevel. +;;; +;;; ABORT-COMMAND prints an error message for the user and aborts +;;; the current command. +;;; +;;; FLUSH-INQUIR is the way out of the program, rather than just QUIT. +;;; We offer the user the chance to flush INQUIR (or optionally don't bother.) + + +(defun terminate-command (&rest ignore) + (setq *can-flush-more* t) + (*throw 'command-abort t)) + +(defun abort-command (&optional msg) + (format t "~&~:[Command aborted.~;~A~]" msg msg) + (terminate-command)) + +(defun flush-inquir-handler (stream nil) + (clear-input stream) + (flush-inquir)) + +(defun flush-inquir (&optional without-asking) + (if (or without-asking + (yes-or-no-p t "~&~%Do you really want to flush this program now? ")) + (quit))) + +;;; Bug reporting + +(defun bug (&optional awful? &rest ignore) + (format t "~&~2%A bug in INQUIR has been encountered.~ + ~%This should never happen.~ + ~%Please send a message explaining the circumstances leading to this ~ + ~%to Bug-INQUIR@MIT-MC. Thank you. ~%") + (valret (if awful? + ":PDUMP CRASH;INQUIR > +:BUG INQUIR An INQUIR crash file was just dumped.  +:KILL +" + ":PDUMP CRASH;INQUIR > +:BUG INQUIR An INQUIR crash file was just dumped.  +:CONTINUE +")) + (terpri t)) + + +;;; Interrupt handlers. +;;; ABORT-COMMAND-HANDLER and FLUSH-COMMAND-HANDLER abort commands. + +(defun abort-command-handler (&rest ignore) + (clear-input t) + (abort-command)) + +(defun flush-command-handler (&rest ignore) + (clear-input t) + (format t "~&Flushed.~%") + (terminate-command)) + +(defun flush-fallthru-handler (&rest ignore) + (clear-input t) + (format t "~&Flushed.~%")) + + +;;;; Utility Functions + +;;; Searching the INQUIR database. + +(defun find (item-no target-string fn &optional (stream t) (display item-no)) + (do ((entry (lsrdta *lsr1*) (lsrnxt *lsr1* entry)) + (hits 0.) + (count 0. (1+ count))) + ((= -1 entry) (format stream "~&~%~D//~D entries." hits count)) + (when (string-search target-string (string (lsritm item-no entry))) + (funcall fn entry display stream) + (setq hits (1+ hits))))) + + + +(defun print-entry (entry item-no &optional (stream t)) + (format stream "~%~A~10T~A~&~A~%" + (lsritm i$unam entry) + (lsritm i$name entry) + (lsritm item-no entry))) + + + +;;; Local Modes: +;;; Lisp with-open-file Indent:1 +;;; Lisp with-terminator Indent:1 +;;; Lisp bind-ttyint Indent:1 +;;; Compile Command: :qc inquir;inquir >(t):inquir;inqdmp +;;; End: diff --git a/src/inquir/lsrrtn.31 b/src/inquir/lsrrtn.31 new file mode 100644 index 00000000..94fd03cc --- /dev/null +++ b/src/inquir/lsrrtn.31 @@ -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 )î +;;; 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 î +;;;î +;;; 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 )î +;;;î +;;; 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 )î +;;; 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 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 )î +;;; returns the slot of the entry î +;;; 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 )î +;;; 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 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î diff --git a/src/inquir/netrtn.fasl b/src/inquir/netrtn.fasl new file mode 100644 index 00000000..6f993713 Binary files /dev/null and b/src/inquir/netrtn.fasl differ diff --git a/src/inquir/reader.28 b/src/inquir/reader.28 new file mode 100644 index 00000000..ed0263f3 --- /dev/null +++ b/src/inquir/reader.28 @@ -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) ')î + (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 ' 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- (PROMPT)î + (IMPLODE (READER PROMPT '(13.))))î +î +(DEFUN READ-SPACE (PROMPT)î + (IMPLODE (READER PROMPT '(32.))))î +î +(DEFUN R ()î + (CURSORPOS 'A TYO)î + (READER '|> | '(13.)))î +î +(DEFPROP READER T LOADED) \ No newline at end of file diff --git a/src/libdoc/comrd.kmp1 b/src/libdoc/comrd.kmp1 new file mode 100755 index 00000000..f184054f --- /dev/null +++ b/src/libdoc/comrd.kmp1 @@ -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 ) +;;; 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 ( ...) +;;; ( ...) ...) +;;; Prints and reads words on a single line returning NIL if +;;; over-rubout and ( ... ) +;;; if sucessful. ... are only used if the user types +;;; to terminate the option before that. If he types 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) diff --git a/src/libdoc/dbg.rwk1 b/src/libdoc/dbg.rwk1 new file mode 100755 index 00000000..4a598602 --- /dev/null +++ b/src/libdoc/dbg.rwk1 @@ -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 +;;; -- 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) diff --git a/src/libdoc/lispm.8 b/src/libdoc/lispm.8 new file mode 100755 index 00000000..14f4db09 --- /dev/null +++ b/src/libdoc/lispm.8 @@ -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:; diff --git a/src/libdoc/tty.24 b/src/libdoc/tty.24 new file mode 100755 index 00000000..db22bf2b Binary files /dev/null and b/src/libdoc/tty.24 differ diff --git a/src/lisp/defset.fasl b/src/lisp/defset.fasl new file mode 100755 index 00000000..f52ff009 Binary files /dev/null and b/src/lisp/defset.fasl differ diff --git a/src/lspsrc/umlmac.35 b/src/lspsrc/umlmac.35 new file mode 100755 index 00000000..d15cf6b4 --- /dev/null +++ b/src/lspsrc/umlmac.35 @@ -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-, 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. evaluates to the number of times, +;and is executed with bound to 0, 1, ... +;Don't generate dummy variable if is an integer. We could also do this +;if 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 ( ) +;; ((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))) + + + diff --git a/src/nilcom/evonce.14 b/src/nilcom/evonce.14 new file mode 100755 index 00000000..ad647dd7 --- /dev/null +++ b/src/nilcom/evonce.14 @@ -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))) + + diff --git a/src/nilcom/subloa.3 b/src/nilcom/subloa.3 new file mode 100755 index 00000000..613e2242 --- /dev/null +++ b/src/nilcom/subloa.3 @@ -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)))) + +) diff --git a/src/rwk/debmac.4 b/src/rwk/debmac.4 new file mode 100755 index 00000000..3f3399db --- /dev/null +++ b/src/rwk/debmac.4 @@ -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)))) + +