github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-20 06:25:45 +00:00
Code Issues Releases Wiki Activity

Added INQUIR, the user account management program.

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

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

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

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

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

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

File diff suppressed because it is too large Load Diff

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

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

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

Binary file not shown.

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

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