Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
(FILECREATED "24-JAN-82 11:19:39" <LISPUSERS>MSG.;39 51228
changes to: MSGCOMS MYASKUSER REWRITEMSGS FINDTO READMESSAGETEST FINDFROM FLDID GETFIELD MSG
MSGSETUP PRINTHEADER PRINTMESSAGE PUTMESSAGE COPYLAURELMSG
previous date: "24-JAN-79 02:34:40" <LISPUSERS>MSG.;37)
(* Copyright (c) 1982 by Xerox Corporation)
(PRETTYCOMPRINT MSGCOMS)
(RPAQQ MSGCOMS ((VARS (MSGDATE "24 Jan 79"))
(VARS MSGINTERRUPTS (MSGFILE)
(MSGS)
(REVMSGS)
(LASTMSGWRITE 0)
(MSGRDTBL)
(MSGTTBL)
MSGLENGTHFLG
(MSGSETUP))
(FNS MSG CHECKMSG# CHECKMSGDATE CONFIRM DELCHECK DOMSGS FINDMESSAGE# GETFILENAME MSGOPEN
MSGSETUP NEWMAIL PARSEMSGRANGE PRINTCURRENT PRINTFIELD PRINTHEADER PRINTMESSAGE
PUTMESSAGE READMESSAGES READMESSAGETEST READSTRING REWRITEMSGS MSGXXX MSGTJFN TESTRANGE)
(FNS ORPRED ANDPRED NOTPRED TESTMSG# MSGSEARCH FINDTO FINDFROM FINDKEY FINDMSGKEY DELETED?
EXAMINED? RECENT? GETFIELD MARKMESSAGE UNMARKMESSAGE TRUE)
(FNS MYSTRPOS MYASKUSER MYTAB MYSUBSYS MYCOPYBYTES MYGTJFN)
(FNS MSGABORT)
[DECLARE: EVAL@COMPILE DONTCOPY (P (CLISPDEC (QUOTE FAST]
(MACROS FLDID)
(BLOCKS (MSGBLOCK MSG DELCHECK DOMSGS FINDMESSAGE# MSGOPEN MSGSETUP NEWMAIL PRINTCURRENT
PRINTFIELD PRINTHEADER PRINTMESSAGE PUTMESSAGE READMESSAGES READMESSAGETEST
READSTRING REWRITEMSGS (ENTRIES MSG PRINTHEADER PRINTMESSAGE PUTMESSAGE
MSGSETUP)
(NOLINKFNS . T)
(RETFNS DOMSGS)
(SPECVARS MSGOPEN MSGJFN KEEPJFN NEWMAIL LSTFIL LL #MSGS CURRENTMESSAGE
INTS INVERTED LASTMSGREAD MSGFILE OLDINT)
(GLOBALVARS MSGDATE MSGINTERRUPTS OLDTTBL USERNAMESTRING MSGTTBL REVMSGS
MSGS UPLOW MSGSETUP MSGRDTBL MSGLENGTHFLG LASTMSGWRITE USERNAME
LASTEXEC)
PARSEMSGRANGE CHECKMSG# GETFILENAME MYCOPYBYTES MYGTJFN CONFIRM MYTAB
MYASKUSER MYSUBSYS))
(COMS * LAURELMSGCOMS)
(LOCALVARS . T)
(SPECVARS ARG)
(GLOBALVARS USERFORKS LASTSUBSYS SUBSYSSPELLINGS)
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS MSG)
(FILES (SYSLOAD)
CJSYS))))
(RPAQ MSGDATE "24 Jan 79")
(RPAQQ MSGINTERRUPTS (14 ERROR 15 (MSGABORT)
T 28 NIL 8 NIL))
(RPAQQ MSGFILE NIL)
(RPAQQ MSGS NIL)
(RPAQQ REVMSGS NIL)
(RPAQQ LASTMSGWRITE 0)
(RPAQQ MSGRDTBL NIL)
(RPAQQ MSGTTBL NIL)
(RPAQQ MSGLENGTHFLG T)
(RPAQQ MSGSETUP NIL)
(DEFINEQ
(MSG
[LAMBDA (FILE SUBSYSTEM) (* lmm "24-JAN-82 11:15")
(RESETLST (MSGSETUP)
[RESETSAVE NIL (LIST (QUOTE SETTERMTABLE)
(SETQ OLDTTBL (SETTERMTABLE MSGTTBL]
(RESETSAVE (OUTPUT T))
[RESETSAVE NIL (LIST (QUOTE INTCHAR)
(SETQ OLDINT (INTCHAR MSGINTERRUPTS]
(RESETSAVE (RADIX 10))
(PROG (#MSGS CURRENTMESSAGE (KEEPJFN (CONS))
LSTFIL MSGJFN NEWMAIL QUIT V MSGOPEN (LL (SUB1 (LINELENGTH)))
[BREAKRESETFORMS (QUOTE ((INTCHAR OLDINT)
(SETTERMTABLE OLDTTBL]
INTS)
(COND
(SUBSYSTEM (MINFS 10000 30)
(MINFS 8000)
(RECLAIM 30)
(RELINK (QUOTE WORLD))
(SYSOUT SUBSYSTEM)))
(SETLINELENGTH)
(SETQ LL (LINELENGTH))
(PRIN1 "
Lisp MSG -- version of ")
(PRIN1 MSGDATE)
(TERPRI)
[SETQ USERNAME (MKATOM (SETQ USERNAMESTRING (USERNAME]
(OR (AND (SELECTQ FILE
(NIL (SETQ FILE (PACKFILENAME (QUOTE DIRECTORY)
USERNAME
(QUOTE NAME)
(QUOTE MESSAGE)
(QUOTE EXTENSION)
(QUOTE TXT)
(QUOTE VERSION)
1)))
(T (SETQ FILE MSGFILE))
(? NIL)
T)
(ERSETQ (READMESSAGES FILE T)))
(PROGN (SETQ MSGFILE NIL)
(PRIN1 "No active message file
")
(GO LP)))
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (X)
(AND (CAR X)
(RLJFN (CAR X]
KEEPJFN))
(SETQ #MSGS (fetch # of (CAR REVMSGS)))
(OR CURRENTMESSAGE (SETQ CURRENTMESSAGE (CAR REVMSGS)))
(PRIN1 #MSGS)
(PRIN1 " messages.
")
LP (COND
(INTS (INTCHAR INTS)
(SETQ INTS)))
(OR (ZEROP (POSITION))
(TERPRI))
[COND
(MSGFILE (AND (OPENP MSGFILE)
(CLOSEF MSGFILE))
(COND
((AND (NULL REVMSGS)
MSGS)
(* got reset in REWRITEMSGS)
(READMESSAGES MSGFILE)
(PRINTCURRENT)))
(NEWMAIL)
(COND
(NEWMAIL (PRIN1 " -- there are new messages
")
(READMESSAGES MSGFILE)
(PRINTCURRENT]
(SETQ LSTFIL T)
[COND
[(ERSETQ (SELECTQ (SETQ V (MYASKUSER "-> "
(QUOTE ((H eaders)
(T ype)
(L ist)
(P ut)
(M ove)
(D elete)
(U ndelete)
(B "ackup
")
(^"
" RETURN B EXPLAINSTRING "^ - same as Backup")
(% "
" RETURN B EXPLAINSTRING "^H - same as Backup")
(N "ext
")
(%
""RETURN N EXPLAINSTRING "<lf> -- same as Next")
(R "ead file: ")
(G "et Laurel File: ")
(% Exec RETURN Exec
EXPLAINSTRING
"^E - call an Exec as a lower fork")
(A "nswer (not implemented)")
(F "orward (not implemented)")
(S ndmsg)
(E "xit & update ")
(O "verwrite ")
(W "rite sorted ")
(Q uit)
(%
"")
(%
Lisp%
EXPLAINSTRING "^L -- enter lisp, for debugging purposes.")
(:"" EXPLAINSTRING
": - Date & Time ")))
NIL))
(%
(* C.R. -
IGNORE)
NIL)
(H (DOMSGS (FUNCTION PRINTHEADER)))
[B (AND (MSGOPEN)
(COND
((NOT (IGREATERP (fetch # of CURRENTMESSAGE)
1))
(PRINTCURRENT))
(T (PRINTMESSAGE (FINDMESSAGE# (SUB1 (fetch #
of
CURRENTMESSAGE]
[N (AND (MSGOPEN)
(COND
((NOT (ILESSP (fetch # of CURRENTMESSAGE)
#MSGS))
(PRINTCURRENT))
(T (PRINTMESSAGE (FINDMESSAGE# (ADD1 (fetch #
of
CURRENTMESSAGE]
(T (DOMSGS (FUNCTION PRINTMESSAGE)))
[L (SETQ LSTFIL)
(DOMSGS (FUNCTION PRINTMESSAGE))
(COND
(LSTFIL (CLOSEF LSTFIL))
(T (PRIN1 "No messages.
")
(CLEARBUF]
[P (SETQ LSTFIL)
(DOMSGS (FUNCTION PUTMESSAGE)
T)
(COND
(LSTFIL (CLOSEF LSTFIL))
(T (PRIN1 "No messages.
")
(CLEARBUF]
[M
(* put + delete)
(SETQ LSTFIL)
(DOMSGS [FUNCTION (LAMBDA (MSG)
(AND (PUTMESSAGE MSG " to file: ")
(MARKMESSAGE MSG 2]
T)
(COND
(LSTFIL (CLOSEF LSTFIL))
(T (PRIN1 "No messages.
")
(CLEARBUF]
[D (DOMSGS (FUNCTION (LAMBDA (X)
(MARKMESSAGE X 2]
[U (DOMSGS (FUNCTION (LAMBDA (X)
(UNMARKMESSAGE X 2]
[Q (CONFIRM)
(COND
(SUBSYSTEM (LOGOUT))
(T (SETQ QUIT T]
[E (COND
(MSGFILE (PRIN1 MSGFILE)
(CONFIRM)
(REWRITEMSGS)
(COND
(SUBSYSTEM (LOGOUT))
(T (SETQ QUIT T]
[(O W)
(COND
(MSGFILE (PRIN1 MSGFILE)
(CONFIRM)
(REWRITEMSGS (EQ V (QUOTE W)))
(READMESSAGES MSGFILE T)
(PRINTCURRENT]
[Exec (CONFIRM)
(OR (NLSETQ (SETQ LASTEXEC (MYSUBSYS LASTEXEC)))
(SETQ LASTEXEC (MYSUBSYS]
[S (CONFIRM)
(NLSETQ (KFORK (MYSUBSYS (QUOTE <SUBSYS>SNDMSG.SAV)
NIL NIL NIL NIL NIL T]
(R (READMESSAGES (GETFILENAME (QUOTE OLD)
NIL
(QUOTE MESSAGES)))
(SETQ CURRENTMESSAGE (CAR REVMSGS))
(PRINTCURRENT))
(G (SETQ FILE (COPYLAURELMSG (MKATOM (RSTRING T T))
(PACK* "<" USERNAME
">LAUREL.MAIL;-1;T")))
(printout NIL " {copied to " FILE ";T}" T)
(READMESSAGES FILE NIL 0)
(OR (MSGOPEN)
(SHOULDNT))
[for X in MSGS bind DT
do (COND
([AND (SETQ DT (GETFIELD X (FLDID DATE)
T))
(SETQ DT (IDATE (CAR DT]
(replace DATE of X with DT)
(JS SFPTR (LOC MSGJFN)
(fetch BEGIN of X))
(JS ODTIM (LOC MSGJFN)
DT 0)]
(SETQ CURRENTMESSAGE (CAR REVMSGS))
(PRINTCURRENT))
((A F)
(* answer, forward)
(PRIN1 "
Sorry, that command not implemented!
" T)
(ERROR!))
(: (PRIN1 (GDATE NIL NIL (CONSTANT (CONCAT)))
T T)
(TERPRI T))
(PROGN (BREAK1 NIL T LISP (TRACE]
(T (CLEARBUF)
(* reset terminal)
(ASSEMBLE NIL
(FASTCALL SETMOD]
(OR QUIT (GO LP])
(CHECKMSG#
(LAMBDA (N) (* lmm "28-JUL-78 04:42")
(COND
((NOT (NUMBERP (SETQ N (PACK N))))
(PRIN1 N)
(PRIN1 "? ")
(ERROR!))
((OR (NOT (IGREATERP N 0))
(IGREATERP N #MSGS))
(PRIN1 N)
(PRIN1 " out of range; ")
(PRIN1 #MSGS)
(PRIN1 " messages
")
(ERROR!))
(T N))))
(CHECKMSGDATE
(LAMBDA (MSG) (* lmm "28-JUL-78 05:03")
(COND
((EQ (CAR ARG)
(QUOTE >))
(IGREATERP (fetch DATE of MSG)
(CDR ARG)))
(T (ILESSP (fetch DATE of MSG)
(CDR ARG))))))
(CONFIRM
[LAMBDA NIL (* lmm: "25-OCT-76 20:19:56")
(PRIN1 " [confirm] ")
(SELECTQ (READC T)
((Y y)
(PRIN1 "es."))
((N n)
(PRIN1 "o")
(ERROR!))
(%
)
(PROGN (PRIN1 " XXX ")
(ERROR!])
(DELCHECK
[LAMBDA (MSG) (* lmm: "17-FEB-77 20:00:03")
(COND
((DELETED? MSG)
(OR (ZEROP (POSITION))
(TERPRI))
(PRIN1 (fetch # of MSG))
(PRIN1 " is a deleted message
")
(CLEARBUF)
T])
(DOMSGS
(LAMBDA (FN FLG) (* lmm "24-JAN-79 01:17")
(PROG (TEST ARG INVERTED)
(COND
((NULL MSGFILE)
(OR FLG (PRIN1 "
No active message file.
" T))
(RETURN)))
(SETQ TEST (CAR (SETQ ARG (READMESSAGETEST))))
(SETQ ARG (CDR ARG))
(MSGOPEN)
(MAPC (COND
(INVERTED REVMSGS)
(T MSGS))
(FUNCTION (LAMBDA (MSG)
(AND (APPLY* TEST MSG)
(APPLY* FN MSG))))))))
(FINDMESSAGE#
[LAMBDA (N) (* lmm: 20-APR-76 17 41)
(find X in MSGS suchthat (EQ (fetch # of X)
N])
(GETFILENAME
(LAMBDA (RECOG NAME EXT) (* lmm "11-APR-78 16:20")
(* returns the FULLNAME of a file in RECOG recognition context
after prompting from user)
(PROG (J FILE)
(SETQ J (OR (MYGTJFN NIL NAME EXT (SELECTQ RECOG
(OLD
(* old file only -
e.g. READ)
160000Q)
(OLD/NEW
(* prefer old but will take new
-
e.g. Move)
60000Q)
(NEW
(* prefer new file, e.g. List)
460000Q)
(HELP)))
(MSGXXX)))
(JS BKJFN 100Q)
(COND
((NEQ (JS PBIN NIL NIL NIL 1)
37Q)
(* confirmed with altmode -
Do another bin and bkjfn to peek at next char and make sure
that it isn't a "delete" char)
(CONFIRM)))
(SETQ FILE (JFNS J))
(RLJFN J)
(RETURN FILE))))
(MSGOPEN
(LAMBDA (READONLY) (* lmm "24-JAN-79 01:10")
(COND
(MSGFILE (NEWMAIL)
(COND
((AND (NOT READONLY)
(NLSETQ (SETQ MSGOPEN (OPENF MSGFILE 7516291584))))
(SETQ LASTMSGWRITE (JS GTFDB (LOC (SETQ MSGJFN (VAG (OPNJFN MSGOPEN))))
1000014Q 1 1)))
(T (SETQ MSGOPEN)
(SETQ MSGJFN (VAG (OPNJFN (OPENF MSGFILE 7516258816))))))
T)
(T (PRIN1 "No message file
")
NIL))))
(MSGSETUP
[LAMBDA NIL (* lmm "24-JAN-82 10:32")
(COND
((NEQ MSGSETUP T)
(COND
([NOT (TERMTABLEP (GETATOMVAL (QUOTE MSGTTBL]
(SETQ MSGTTBL (COPYTERMTABLE (QUOTE ORIG)))
(CONTROL T MSGTTBL)
(RAISE T MSGTTBL)
(ECHOCONTROL 5 (QUOTE IGNORE)
MSGTTBL)
(ECHOCONTROL 8 (QUOTE IGNORE)
MSGTTBL)
(ECHOCONTROL 12 (QUOTE IGNORE)
MSGTTBL)
(ECHOCONTROL 27 (QUOTE IGNORE)
MSGTTBL)))
(COND
([NOT (READTABLEP (GETATOMVAL (QUOTE MSGRDTBL]
(SETQ MSGRDTBL (COPYREADTABLE (QUOTE ORIG)))
(SETSEPR (QUOTE (31))
NIL MSGRDTBL)
(SETBRK NIL NIL MSGRDTBL)))
[COND
([NOT (ARRAYP (GETATOMVAL (QUOTE UPLOW]
(SETQ UPLOW (CASEARRAY))
(for I from (CHARCODE A) to (CHARCODE Z) do (SETCASEARRAY UPLOW I
(IPLUS I (IDIFFERENCE
(CHARCODE a)
(CHARCODE A]
[COND
((NOT (FGETD (QUOTE BREAK1)))
(LOAD (QUOTE <LISP>BREAK.COM)
(QUOTE SYSLOAD]
[COND
((NOT (FGETD (QUOTE INTERRUPTCHAR)))
(LOAD (QUOTE <LISP>HELPDL.COM)
(QUOTE SYSLOAD]
(SETQ MSGSETUP T])
(NEWMAIL
(LAMBDA NIL (* lmm "28-JUL-78 05:55")
(OR NEWMAIL (SETQ NEWMAIL (ILESSP LASTMSGWRITE (JS GTFDB
(CAR KEEPJFN)
262156 1 1))))))
(PARSEMSGRANGE
(LAMBDA (L) (* lmm "28-JUL-78 04:48")
(PROG ((TL (FMEMB (QUOTE ,)
L)))
(RETURN (COND
(TL (LIST (CAR TL)
(PARSEMSGRANGE (LDIFF L TL))
(PARSEMSGRANGE (CDR TL))))
((SETQ TL (OR (FMEMB (QUOTE -)
L)
(FMEMB (QUOTE >)
L)))
(SETQ L (LIST (QUOTE >)
(CHECKMSG# (LDIFF L TL))
(CHECKMSG# (CDR TL))))
(COND
((IGREATERP (CADR L)
(CADDR L))
(PRIN1 (CADR L))
(PRIN1 " greater than ")
(PRIN1 (CADDR L))
(ERROR!))
(T L)))
(T (CHECKMSG# L)))))))
(PRINTCURRENT
[LAMBDA (FLG) (* lmm: "11-APR-77 17:14")
(OR FLG (PRIN1 "Currently at "))
(PRIN1 (fetch # of CURRENTMESSAGE))
(PRIN1 "; ")
(PRIN1 #MSGS)
(PRIN1 " messages
"])
(PRINTFIELD
[LAMBDA (LMAR ID MSG FLG) (* lmm: "12-APR-77 10:52")
(PROG ([X (OR (GETFIELD MSG ID)
(QUOTE (--]
POS
(MAXCHARS (IDIFFERENCE LL LMAR))
NPOS X1)
(MYTAB LMAR (OR FLG 1))
LP0 (SETQ X1 (CAR X))
[while (EQ (NTHCHAR X1 1)
(QUOTE % ))
do (SETQ X1 (SUBSTRING X1 2 NIL (QUOTE "teitelman"]
PRINTLP
[COND
((ILESSP (NCHARS X1)
MAXCHARS)
(PRIN1 X1)
(COND
((SETQ X (CDR X))
(MYTAB LMAR 1)
(GO LP0))
(T (RETURN] (* X1 is more than available
space; search for minimum)
(SETQ POS 0)
SPACELP
(COND
((AND (SETQ NPOS (MYSTRPOS " " X1 (ADD1 POS)))
(ILESSP NPOS MAXCHARS))
(SETQ POS NPOS)
(GO SPACELP)))
[COND
((EQ POS 0)
(COND
(NPOS (SETQ POS NPOS))
(T (PRIN1 X1)
(RETURN]
(PRIN1 (SUBSTRING X1 1 (SUB1 POS)
"making number functions run the"))
(SETQ X1 (SUBSTRING X1 (ADD1 POS)
-1 "same compiled and interpreted"))
(TERPRI)
(SPACES LMAR)
(GO PRINTLP])
(PRINTHEADER
[LAMBDA (MSG) (* lmm "24-JAN-82 10:13")
(PROG (D)
(OR (ZEROP (POSITION))
(TERPRI))
(PRIN1 (COND
((RECENT? MSG)
"+")
(T " ")))
(PRIN1 (COND
((EXAMINED? MSG)
" ")
(T "-")))
(PRIN1 (COND
((DELETED? MSG)
"*")
(T " ")))
(PRIN1 (fetch # of MSG))
(SPACES 1)
[PRIN1 (COND
((SETQ D (CAR (GETFIELD MSG (FLDID DATE)
T)))
(SUBSTRING D 1 6))
(T (QUOTE ---]
(SPACES 1)
(COND
((EQUAL (CAR (GETFIELD MSG (FLDID FROM)))
USERNAMESTRING)
(PRIN1 "To: ")
(PRINTFIELD 14 (FLDID TO)
MSG T))
(T (PRINTFIELD 14 (FLDID FROM)
MSG T)))
(PRINTFIELD 36 (FLDID SUBJECT)
MSG)
(COND
(MSGLENGTHFLG (COND
((IGREATERP (POSITION)
(IDIFFERENCE LL 14))
(TERPRI)
(SPACES 15)))
(PRIN1 " (")
(PRIN1 (fetch SIZE of MSG))
(PRIN1 " chars)")))
(TERPRI])
(PRINTMESSAGE
[LAMBDA (MSG) (* lmm "28-JUL-78 03:56")
(SETQ CURRENTMESSAGE MSG)
(COND
((NOT (DELCHECK MSG))
[COND
((NULL LSTFIL)
(PRIN3 " on file: ")
(SETQ LSTFIL (OUTPUT (OUTFILE (GETFILENAME (QUOTE NEW]
(COND
((EQ LSTFIL T)
(OR (EQ (POSITION)
0)
(TERPRI))
(PRIN3 "msg. ")
(PRIN3 (fetch # of MSG))
(PRIN3 " -- "))
(T (PRIN3 (fetch # of MSG)
LSTFIL)
(PRIN3 " - *******************************************
" LSTFIL)))
(MYCOPYBYTES MSGJFN LSTFIL (fetch START of MSG)
(fetch END of MSG))
(MARKMESSAGE MSG 1])
(PUTMESSAGE
[LAMBDA (MSG STR) (* lmm "11-APR-78 16:17")
(COND
((NOT (DELCHECK MSG))
[COND
((NULL LSTFIL)
(PRIN1 (OR STR " on file: "))
(SETQ LSTFIL (OPENFILE (GETFILENAME (QUOTE OLD/NEW)
(QUOTE OLD)
(QUOTE MESSAGES))
(QUOTE APPEND]
[INTERRUPTABLE (PROG1 (INTERRUPTABLE)
(MYCOPYBYTES MSGJFN LSTFIL (fetch BEGIN of MSG)
(fetch END of MSG]
T])
(READMESSAGES
(LAMBDA (FILE FIRSTIME NOPRINTFLG) (* lmm "24-JAN-79 02:26")
(* if this is aborted, then it should not change
anything)
(DECLARE (SPECVARS NOPRINTFLG))
(PROG (SIZE VAL HERE TIMEWRITE (I 0)
MSG TIMEREAD JFN JFN0)
(SETQ INTS (INTCHAR 15 (QUOTE NOPRINTFLG)))
(SETQ TIMEREAD (JS GTFDB (LOC (SETQ JFN0 (VAG (MSGTJFN FILE))))
1000015Q 1 1))
(SETQ FILE (JFNS (LOC JFN0))) (* MSGTJFN might have done a correction)
(COND
((SETQ MSG (OPENP FILE (QUOTE INPUT)))
(SETFILEPTR (SETQ FILE MSG)
0))
(T (SETQ FILE (OPENF FILE 7516258816))
(* open for read, always wait)
(RESETSAVE NIL (LIST (QUOTE CLOSEF?)
FILE))))
(SETQ SIZE (JS SIZEF (LOC (SETQ JFN (VAG (OPNJFN FILE))))
NIL NIL 2))
(COND
((AND (EQ FILE MSGFILE)
REVMSGS)
(JS SFPTR (LOC JFN)
(fetch BEGIN of (SETQ MSG (CAR REVMSGS))))
(COND
((IEQP (JS IDTIM (LOC JFN)
1000000000Q NIL 2)
(fetch DATE of MSG))
(MAPC (SETQ VAL REVMSGS)
(FUNCTION (LAMBDA (X)
(COND
((NEQ (fetch MARKPOS of X)
0)
(JS SFPTR (LOC JFN)
(IPLUS (fetch MARKPOS of X)
(fetch BEGIN of X)))
(replace MARKS of X with (JS NIN (LOC JFN)
NIL 12Q 2)))))))
(SETQ I (fetch # of MSG))
(AND FIRSTIME (SETQ CURRENTMESSAGE MSG))
(GO ENDLP)))))
(JS SFPTR (LOC JFN)
0)
(SETQ HERE 0)
LP (COND
((NOT (ILESSP HERE SIZE))
(SETQ TIMEWRITE (JS GTFDB (LOC JFN)
1000014Q 1 1))
(CLOSEF FILE)
(INTERRUPTABLE (PROG1 (INTERRUPTABLE)
(AND (CAR KEEPJFN)
(RLJFN (CAR KEEPJFN)))
(SETQ NEWMAIL)
(SETQ LASTMSGWRITE TIMEWRITE)
(AND FIRSTIME (SETQ LASTMSGREAD TIMEREAD))
(SETQ #MSGS I)
(SETQ MSGFILE FILE)
(SETQ MSGS (REVERSE VAL))
(SETQ REVMSGS VAL)
(FRPLACA KEEPJFN (LOC JFN0))))
(RETURN FILE)))
(SETQ VAL (CONS (SETQ MSG (create MSG
# _(SETQ I (ADD1 I))
DATE _(JS IDTIM (LOC JFN)
1000000000Q NIL 2)
BEGIN _ HERE
SIZE _(JS NIN (LOC JFN)
NIL 12Q 2)))
VAL))
(JS BKJFN (LOC JFN))
(SELECTQ (JS BIN (LOC JFN)
NIL NIL 2)
(59 (* semi-colon after count -- followed by word of marks)
(replace MARKPOS of MSG with (IDIFFERENCE (JS RFPTR (LOC JFN)
NIL NIL 2)
HERE))
(replace MARKS of MSG with (JS NIN (LOC JFN)
NIL 10Q 2))
(JS BIN (LOC JFN)))
(13 (* skip lf after cr)
(JS BIN (LOC JFN)))
(HELP))
(replace HEADLEN of MSG with (IDIFFERENCE (JS RFPTR (LOC JFN)
NIL NIL 2)
HERE))
(COND
((IGREATERP TIMEREAD (fetch DATE of MSG))
(AND FIRSTIME (SETQ CURRENTMESSAGE MSG)))
(T (SELECTQ NOPRINTFLG
(NIL (PROG ((MSGFILE FILE)
(LASTMSGREAD TIMEREAD)
(MSGJFN JFN))
(PRINTHEADER MSG)))
(T (SETQ NOPRINTFLG (PRIN1 "^O")))
NIL)))
ENDLP
(JS SFPTR (LOC JFN)
(SETQ HERE (fetch END of MSG)))
(GO LP))))
(READMESSAGETEST
[LAMBDA NIL (* lmm "24-JAN-82 10:19")
(PROG (V A POS)
(RETURN (CONS (SELECTQ [SETQ V
(MYASKUSER " " (QUOTE ((A ll)
(I nverse)
(F "rom string: ")
(T "o string: ")
(S "ubject string: ")
(K "eywords string: ")
(C "ontaining string: ")
(D eleted)
(P rinted EXPLAINSTRING
"Printed -- same as MSG's examined")
(R ecent)
( "" EXPLAINSTRING
"<esc> -- current message")
(B oth EXPLAINSTRING
"Both <message spec> and <message spec>")
(E ither EXPLAINSTRING
"Either <message spec> or <message spec>")
(N ot EXPLAINSTRING "Not <message spec>")
(> " since date: ")
(<" before date: ")))
"
message spec: "
(QUOTE (0 1 2 3 4 5 6 7 8 9 - , >]
(A (FUNCTION TRUE))
( (PRIN1 (SETQ A (fetch # of CURRENTMESSAGE)))
(FUNCTION TESTMSG#))
(C (SETQ A (READSTRING))
(FUNCTION MSGSEARCH))
(T (SETQ A (READSTRING))
(FUNCTION FINDTO))
(F (SETQ A (READSTRING))
(FUNCTION FINDFROM))
((S K)
(SETQ A (CONS (SELECTQ V
(S (FLDID SUBJECT))
(F (FLDID FROM))
(K (FLDID KEYWORDS))
(HELP))
(READSTRING)))
(FUNCTION FINDKEY))
(I (SETQ INVERTED T)
(FUNCTION TRUE))
(E
(* Union)
(SETQ POS (POSITION))
[SETQ A (CONS (READMESSAGETEST)
(PROGN (MYTAB (IDIFFERENCE POS 3))
(PRIN1 "or ")
(READMESSAGETEST]
(FUNCTION ORPRED))
(B
(* Intersection)
(SETQ POS (POSITION))
[SETQ A (CONS (READMESSAGETEST)
(PROGN (MYTAB (IDIFFERENCE POS 4))
(PRIN1 "and ")
(READMESSAGETEST]
(FUNCTION ANDPRED))
(N
(* negation)
(SETQ A (READMESSAGETEST))
(FUNCTION NOTPRED))
(D (FUNCTION DELETED?))
(P (FUNCTION EXAMINED?))
(R (FUNCTION RECENT?))
((> <)
[SETQ A (CONS V (COND
((IDATE (CONCAT (SETQ V (READSTRING))
" 00:00")))
(T (PRIN1 "can't parse date: ")
(PRIN1 V)
(ERROR!]
(FUNCTION CHECKMSGDATE))
(PROGN (SETQ A (PARSEMSGRANGE V))
(FUNCTION TESTMSG#)))
A])
(READSTRING
[LAMBDA (PROMPT) (* lmm: "25-OCT-76 20:17:25")
(PROG (V)
LP (SETQ V (RSTRING T MSGRDTBL))
(READC T)
(COND
((ZEROP (NCHARS V))
(PRIN1 PROMPT)
(GO LP)))
(RETURN V])
(REWRITEMSGS
[LAMBDA (SORTFLG) (* lmm "24-JAN-82 10:16")
(PROG (NMSG (CNT 0))
(SETQ REVMSGS)
(MSGOPEN)
(COND
(NEWMAIL (PRIN1 "
new mail recieved -- will not rewrite
")
(MSGXXX)))
(SETQ LSTFIL (OPENFILE (PACKFILENAME (QUOTE DIRECTORY)
(USERNAME)
(QUOTE NAME)
(QUOTE SCRATCH)
(QUOTE EXTENSION)
(QUOTE MESSAGES)
(QUOTE TEMPORARY)
T
(QUOTE VERSION)
-1)
(QUOTE OUTPUT)
(QUOTE NEW)))
[COND
(SORTFLG [SORT MSGS (FUNCTION (LAMBDA (X Y)
(ILESSP (fetch DATE of X)
(fetch DATE of Y]
(PROG ((X MSGS))
(* weed out duplicates)
LP (COND
((CDR X)
[COND
([AND (IEQP (fetch DATE of (CAR X))
(fetch DATE of (CADR X)))
(IEQP (fetch SIZE of (CAR X))
(fetch SIZE of (CADR X)))
(IEQP (fetch HEADLEN of (CAR X))
(fetch HEADLEN of (CADR X)))
(EQUAL (GETFIELD (CAR X)
(FLDID FROM))
(GETFIELD (CADR X)
(FLDID FROM)))
(EQUAL (GETFIELD (CAR X)
(FLDID SUBJECT))
(GETFIELD (CADR X)
(FLDID SUBJECT)))
(EQUAL (GETFIELD (CAR X)
(FLDID DATE))
(GETFIELD (CADR X)
(FLDID DATE]
(FRPLACD X (CDDR X)))
(T (SETQ X (CDR X]
(GO LP]
[SETQ MSGS (for X in MSGS when (NOT (DELETED? X)) collect (replace BEGIN of X
with (PROG1 (GETFILEPTR LSTFIL)
(PUTMESSAGE X)))
(replace # of X
with (SETQ CNT (ADD1 CNT]
(CLOSEF LSTFIL)
(INTERRUPTABLE (PROG1 (INTERRUPTABLE)
(CLOSEF MSGFILE)
[SETQ MSGJFN (VAG (OPNJFN (INPUT (INFILE (SETQ MSGFILE
(OR (RENAMEFILE LSTFIL
MSGFILE)
(HELP]
(SETQ #MSGS (FLENGTH (SETQ REVMSGS (REVERSE NMSG])
(MSGXXX
(LAMBDA NIL (* lmm: "25-OCT-76 20:17:17")
(PRIN1 " XXX
")
(ERROR!)))
(MSGTJFN
[LAMBDA (FILE)
(OR (GTJFN FILE NIL NIL 100001Q)
(ERRORX (LIST 27Q FILE])
(TESTRANGE
(LAMBDA (N RANGE) (* lmm "28-JUL-78 04:47")
(COND
((NLISTP RANGE)
(EQ N RANGE))
(T (SELECTQ (CAR RANGE)
(, (OR (TESTRANGE N (CADR RANGE))
(TESTRANGE N (CADDR RANGE))))
(> (AND (NOT (IGREATERP (CADR RANGE)
N))
(NOT (IGREATERP N (CADDR RANGE)))))
(SHOULDNT))))))
)
(DEFINEQ
(ORPRED
[LAMBDA (MSG) (* lmm: "18-FEB-77 15:32:42")
(PROG ((ARG1 (CAR ARG))
(ARG2 (CDR ARG))
ARG)
(RETURN (OR (PROGN (SETQ ARG (CDR ARG1))
(BLKAPPLY* (CAR ARG1)
MSG))
(PROGN (SETQ ARG (CDR ARG2))
(BLKAPPLY* (CAR ARG2)
MSG])
(ANDPRED
[LAMBDA (MSG) (* lmm: "18-FEB-77 15:33:02")
(PROG ((ARG1 (CAR ARG))
(ARG2 (CDR ARG))
ARG)
(RETURN (AND (PROGN (SETQ ARG (CDR ARG1))
(BLKAPPLY* (CAR ARG1)
MSG))
(PROGN (SETQ ARG (CDR ARG2))
(BLKAPPLY* (CAR ARG2)
MSG])
(NOTPRED
[LAMBDA (MSG)
(PROG ((FN (CAR ARG))
(ARG (CDR ARG)))
(RETURN (NOT (BLKAPPLY* FN MSG])
(TESTMSG#
(LAMBDA (MSG) (* lmm "28-JUL-78 04:47")
(COND
((EQ ARG T)
(RETFROM (QUOTE DOMSGS)))
((EQ (fetch # of MSG)
ARG)
(SETQ ARG T))
((LISTP ARG)
(TESTRANGE (fetch # of MSG)
ARG)))))
(MSGSEARCH
[LAMBDA (MSG) (* lmm: "21-FEB-77 13:15:22")
(FFILEPOS ARG MSGFILE (fetch START of MSG)
(fetch END of MSG)
NIL NIL UPLOW])
(FINDTO
[LAMBDA (MSG) (* lmm "24-JAN-82 10:16")
(OR (FINDMSGKEY (FLDID TO)
ARG MSG)
(FINDMSGKEY (FLDID CC)
ARG MSG])
(FINDFROM
[LAMBDA (MSG) (* lmm "24-JAN-82 10:18")
(OR (FINDMSGKEY (FLDID FROM)
ARG MSG)
(FINDMSGKEY (FLDID SENDER)
ARG MSG])
(FINDKEY
[LAMBDA (MSG)
(FINDMSGKEY (CAR ARG)
(CDR ARG)
MSG])
(FINDMSGKEY
[LAMBDA (KEYTYPE KEY MSG) (* lmm: 3-MAY-76 1 49)
(SOME (GETFIELD MSG KEYTYPE)
(FUNCTION (LAMBDA (X)
(MYSTRPOS KEY X])
(DELETED?
[LAMBDA (MSG)
(NEQ (LOGAND (fetch MARKS of MSG)
2)
0])
(EXAMINED?
[LAMBDA (MSG) (* lmm: "17-FEB-77 19:25:08")
(NEQ (LOGAND (fetch MARKS of MSG)
1)
0])
(RECENT?
[LAMBDA (MSG) (* lmm: "17-FEB-77 19:21:17")
(NOT (IGREATERP LASTMSGREAD (fetch DATE of MSG])
(GETFIELD
[LAMBDA (MSG ID FLG) (* lmm "24-JAN-82 10:38")
(CDR (OR (FASSOC ID (fetch FIELDS of MSG))
(CAR (replace FIELDS of MSG
with (CONS (CONS ID
(bind [HE _(OR (fetch HEADEREND of MSG)
(replace HEADEREND of MSG
with (OR (FILEPOS "
" MSGFILE (fetch START of MSG)
(fetch END of MSG))
(fetch START of MSG]
first (JS SFPTR (LOC MSGJFN)
(IDIFFERENCE (fetch START of MSG)
2))
while (FFILEPOS ID MSGFILE NIL HE NIL T UPLOW)
collect (RSTRING MSGFILE MSGRDTBL) repeatuntil FLG))
(fetch FIELDS of MSG])
(MARKMESSAGE
[LAMBDA (MSG MASK) (* lmm: "21-FEB-77 16:08:03")
(OR (IEQP (fetch MARKS of MSG)
(replace MARKS of MSG
with (LOGOR (fetch MARKS of MSG)
MASK)))
(COND
((AND MSGOPEN (NEQ 0 (fetch MARKPOS of MSG)))
(JS SFPTR (LOC MSGJFN)
(IPLUS (fetch BEGIN of MSG)
(fetch MARKPOS of MSG)))
(JS NOUT (LOC MSGJFN)
(fetch MARKS of MSG)
140014000010Q])
(UNMARKMESSAGE
[LAMBDA (MSG MASK) (* lmm: "21-FEB-77 16:07:49")
(OR [IEQP (fetch MARKS of MSG)
(replace MARKS of MSG
with (LOGAND (fetch MARKS of MSG)
(LOGXOR -1 MASK]
(COND
((AND MSGOPEN (NEQ 0 (fetch MARKPOS of MSG)))
(JS SFPTR (LOC MSGJFN)
(IPLUS (fetch BEGIN of MSG)
(fetch MARKPOS of MSG)))
(JS NOUT (LOC MSGJFN)
(fetch MARKS of MSG)
140014000010Q])
(TRUE
[LAMBDA NIL "lmm: 21-JUL-76 19:07:01"
T])
)
(DEFINEQ
(MYSTRPOS
[LAMBDA (X Y START) (* lmm: 7-APR-76 22 59)
[COND
[(LITATOM X)
(SETQ X (CDR (VAG (IPLUS (LOC X)
2]
((NULL (STRINGP X))
(SETQ X (MKSTRING X]
[COND
((STRINGP Y))
[(LITATOM Y)
(SETQ Y (CDR (VAG (IPLUS (LOC Y)
2]
(T (SETQ Y (MKSTRING Y]
(ASSEMBLE NIL
(SETO 1 ,)
(PUSHN 1)
(CQ X)
(PUSHJ CP , UPATM)
(PUSHN 3) (* BYTE PTR. ORIG X)
(PUSHN 4) (* LENGTH ORIG X)
(CQ START)
(CAMN 1 , KNIL)
(SKIPA 1 , = 1)
(PUSHJ CP , IUNBOX)
(MOVE 7 , 1) (* SAVE START)
(CQ Y)
(PUSHJ CP , UPATM)
(PUSHN 3) (* BYTE PTR ORIG Y)
(PUSHN 4) (* LENGTH ORIG Y)
(SKIPG 7)
(ADDI 7 , 1 (4)) (* START NEG, ADD LEN+1)
(JUMPLE 7 , FALSE)
(SUBI 4 , -1 (7))
(JUMPL 4 , FALSE)
(SUBI 7 , 1)
(IDIVI 7 , 5)
(NREF (ADDM 7 , -1)) (* UPDATE BYTE PTR TO START)
(SKIPA)
(NREF (IBP -1))
(SOJGE 10Q , * -1)
(SETZ 7 ,)
B (NREF (MOVE 3 , -1))
(NREF (MOVE 5 , -3))
(NREF (MOVE 6 , -2))
(CAIGE 4 , 0 (6))
(JRST FALSE)
L (SOJL 6 , RY)
(ILDB 1 , 5)
(ILDB 2 , 3)
(CAIL 2 , 141Q)
(CAILE 2 , 172Q)
(ADDI 2 , 40Q)
(SUBI 2 , 40Q)
(CAIE 1 , 0 (2))
(NREF (CAMN 1 , -4))
(JRST L)
(JUMPN 7 , FALSE) (* QUIT IF ANCHORED)
(SOJLE 4 , FALSE) (* QUIT IF Y EMPTY)
(NREF (IBP -1))
(JRST B)
RY (NREF (MOVE 1 , 0))
(SUBI 1 , -1 (4))
(PUSHJ CP , MKN)
(JRST OUT)
FALSE
(MOVE 1 , KNIL)
OUT (POPNN 5)
(RET])
(MYASKUSER
[LAMBDA (PROMPT LST REPROMPT SEQCHARS)
(* lmm "24-JAN-82 10:01")
(PROG (C V SEQ)
LP [COND
((STRINGP PROMPT)
(PRIN1 PROMPT))
(T (MAPC PROMPT (FUNCTION (LAMBDA (X)
(PRIN1 X)
(SPACES 1]
(AND SEQ (MAPC (REVERSE SEQ)
(FUNCTION PRIN1)))
RD (SETQ C (READC T))
(SELECTQ C
(? [for X in LST do (OR (ZEROP (POSITION))
(TERPRI))
(COND
([SETQ V (CADR (FMEMB (QUOTE EXPLAINSTRING)
(CDDR X]
(PRIN1 V))
(T (PRIN1 (CAR X))
(PRIN1 (CADR X]
(COND
(SEQCHARS (PRIN1 "
sequence of numbers")))
(OR (ZEROP (POSITION))
(TERPRI))
(GO REPROMPT))
(% (* control-A)
(OR SEQ (MSGXXX))
(SETQ SEQ (CDR SEQ))
(GO RD))
(% (* control-Q)
(OR SEQ (MSGXXX))
(SETQ SEQ NIL)
(GO RD))
[%
(* carriage return)
(AND SEQCHARS (COND
(SEQ (RETURN (REVERSE SEQ)))
(T (MSGXXX]
NIL)
(COND
[(AND (NULL SEQ)
(SETQ V (FASSOC C LST)))
(PRIN1 (CADR V))
(RETURN (OR (CADR (FMEMB (QUOTE RETURN)
(CDDR V)))
(CAR V]
((FMEMB C SEQCHARS)
(SETQ SEQ (CONS C SEQ))
(GO RD))
(T (MSGXXX)))
REPROMPT
(AND REPROMPT (SETQ PROMPT REPROMPT))
(GO LP])
(MYTAB
[LAMBDA (POS MINSPACES FILE FLG) (* lmm: "12-APR-77 10:42")
(PROG (X)
(COND
((NOT (IGREATERP (IPLUS (SETQ X (POSITION FILE))
(OR (NUMBERP MINSPACES)
1))
POS))
(SPACES (IDIFFERENCE POS X)
FILE))
((EQ MINSPACES T) (* MINSPACES=T means space over
to POS unless you are already
beyond it.)
)
(T (TERPRI FILE)
(SPACES POS FILE])
(MYSUBSYS
(LAMBDA (FILE/FORK INCOMFILE OUTCOMFILE ENTRYPOINT ACS MAPPAGES
INTERRUPTS) (* lmm "28-MAR-78 16:37")
(PROG (FORK TTYMODE SAVEJFN IJFN OJFN ICLOSE OCLOSE STARTADR TEMP
ERRORFLG OLDINTS (I 777000Q))
TOP (SETQ SAVEJFN (COND
((EQ FILE/FORK T) (* Continue last FORK.)
(SETQ FILE/FORK LASTSUBSYS)
(SETQQ ENTRYPOINT CONTINUE)
(GO TOP))
((AND (FIXP FILE/FORK)
(IGREATERP FILE/FORK 400000Q)
(ILESSP FILE/FORK 400035Q)
(GETHASH FILE/FORK USERFORKS))
(* User restarting old one.)
(SETQ FORK FILE/FORK)
(SETQ TEMP (RFSTS FORK))
(COND
((OR (NULL TEMP)
(EQ (CAR TEMP)
777777777777Q))
(* FORK mysteriously died
(like there was a SYSOUT
overnite.))
(KFORK FORK)
(ERROR (QUOTE "ILLEGAL FORK:")
FORK)))
(SETQ STARTADR (SELECTQ ENTRYPOINT
((NIL CONTINUE)
(CADDR TEMP))
(START (GEVEC FORK))
(REENTER (ADD1 (GEVEC FORK)))
(COND
((FIXP ENTRYPOINT)
(IPLUS ENTRYPOINT
(GEVEC FILE/FORK)))
(T (ERRORX (LIST 33Q
ENTRYPOINT)))))
)
(GO MIDDLE))
((OR (NULL FILE/FORK)
(EQ FILE/FORK (QUOTE EXEC)))
(GTJFN (COND
((EQ (SYSTEMTYPE)
(QUOTE TOPS20))
(QUOTE <SYSTEM>EXEC.EXE))
(T (QUOTE <SYSTEM>EXEC.SAV)))
NIL NIL 100000Q))
((GTJFN FILE/FORK (SELECTQ (SYSTEMTYPE)
(TOPS20 (QUOTE EXE))
(QUOTE SAV))
NIL 100000Q))
((GTJFN (PACK (COND
((EQ (SYSTEMTYPE)
(QUOTE TOPS20))
(LIST (QUOTE SYS:)
FILE/FORK
(QUOTE .EXE)))
(T (LIST (QUOTE <SUBSYS>)
FILE/FORK
(QUOTE .SAV)))))
NIL NIL 100000Q))
((AND (SETQ SAVEJFN (FIXSPELL FILE/FORK 74Q
SUBSYSSPELLINGS))
(NEQ FILE/FORK SAVEJFN))
(SETQ FILE/FORK SAVEJFN)
(GO TOP))
(T (ERROR (QUOTE "SUBSYS - BAD FILE/FORK")
FILE/FORK))))
(SETQ FORK (CFORK))
(ASSEMBLE NIL
(CQ (VAG FORK))
(PUSHN)
(CQ (VAG SAVEJFN))
(POPN 2)
(HRLM 2 , 1)
(JS GET))
(SETQ STARTADR (IPLUS (OR ENTRYPOINT 0)
(GEVEC FORK)))
MIDDLE
(COND
((OR INCOMFILE OUTCOMFILE)
(SETQ IJFN (COND
((NULL INCOMFILE)
(CAR (GPJFN)))
((STRINGP INCOMFILE)
(* INCOMFILE is a command string. Set up a temporary file,
print the string on it with PRIN1, close;
then open for input and return jfn.)
(SETQ IJFN (OUTPUT (OUTFILE (QUOTE
SUBSYS.INCOMFILE;T))))
(* Next higher version,
temporary.)
(PRIN1 INCOMFILE IJFN)
(OPNJFN (SETQ ICLOSE (INPUT (INFILE (CLOSEF IJFN))))
))
((OPENP INCOMFILE (QUOTE INPUT))
(OPNJFN (SETQ ICLOSE INCOMFILE)))
((INFILEP INCOMFILE)
(INPUT (INFILE INCOMFILE))
(OPNJFN (SETQ ICLOSE INCOMFILE)))
(T (ERROR (QUOTE "SUBSYS - BAD INCOMFILE:")
INCOMFILE))))
(SETQ OJFN (COND
((NULL OUTCOMFILE)
(CDR (GPJFN)))
((OPENP OUTCOMFILE (QUOTE OUTPUT))
(OPNJFN (SETQ OCLOSE OUTCOMFILE)))
((OUTFILEP OUTCOMFILE)
(OUTPUT (OUTFILE OUTCOMFILE))
(OPNJFN (SETQ OCLOSE OUTCOMFILE)))
(T (ERROR (QUOTE "SUBSYS - BAD OUTCOMFILE:")
OUTCOMFILE))))
(ASSEMBLE NIL (* Set up primary JFN's)
(CQ (VAG OJFN))
(PUSHN)
(CQ (VAG IJFN))
(NREF (HRLM 1 , 0))
(CQ (VAG FORK))
(POPN 2)
(JS SPJFN) (* Fork handle in ac1,
IJFN,,OJFN in AC2.)
)))
(COND
(ACS (MAPC ACS (FUNCTION (LAMBDA (AC)
(CLOSER I AC)
(SETQ I (ADD1 I)))))
(JS SFACS FORK 777000Q)
(* set forks ac's)
))
(COND
(MAPPAGES
(* MAPPAGES is a list of ((page# getblk)) to be shared with
lower fork)
(MAPC MAPPAGES
(FUNCTION (LAMBDA (X)
(JS PMAP (XWD 400000Q
(LRSH (LOC (CADR X))
11Q))
(XWD FORK (CAR X))
160000000000Q))))))
(SETQ TTYMODE (JS RFMOD 101Q NIL NIL 2))
(OR (NLSETQ (ASSEMBLE NIL (* Turn off interrupts)
(CQ (AND INTERRUPTS
(GETINTERRUPT (QUOTE ERROR))))
(MOVEI 2 , 0 (1))
(SUBI 2 , ASZ)
(MOVE 7 , CTCTP)
T1 (HLRZ 1 , 0 (7))
(TRNE 1 , 400000Q)
(JRST NOTASN)
(* Skip if assigned.)
(CAIE 1 , 0 (2))
(* skip if it is the error
character and INTERRUPTS was
set)
(JS DTI)
(* Deassigns Terminal Interrupt code. Stepping thru the Lisp
interrupt table pointed to by CTCTP (which stands for Channel
Table ConTrol Pointer or something like that and just contains
pointer to CHNTAB). Effect is to turn off all Lisp-activated
interrupts I think.)
NOTASN
(AOBJN 7 , T1)
(* Now start FORK at STARTADR.)
(CQ (VAG FORK))
(PUSHN)
(CQ (VAG STARTADR))
(MOVE 2 , 1)
(POPN)
(JS SFORK)
(JS WFORK)
(* Causes LISP to wait until
lower FORK terminates.
Takes forkhandle in ac1.)
))
(PROGN (ASSEMBLE NIL
(CQ (VAG FORK))
(JS HFORK)
(* HFORK -
halt lower fork)
(JS WFORK)
(* WFORK -
wait for it to halt)
)
(SETQ ERRORFLG T)))
(ASSEMBLE NIL
(CQ (VAG TTYMODE))
(* Restore tty mode.)
(MOVE 2 , 1)
(MOVEI 1 , 101Q)
(JS SFMOD) (* SFMOD.)
(PUSHJ CP , SETINT)
(PUSHJ CP , SETMOD)
(* Both sfmod and SETMOD are necessary: SETMOD does an sfcoc,
and a sfmod as well, but doesn't reset all bits.)
)
(COND
(ICLOSE (CLOSEF ICLOSE)
(AND (STRINGP INCOMFILE)
(DELFILE ICLOSE))))
(AND OCLOSE (CLOSEF OCLOSE))
(POSITION T (LOGAND (JS RFPOS 100Q NIL NIL 2)
777777Q))
(* In case lower fork left us in the middle of a line, e.g.
SNDMSG)
(RETURN (COND
(ERRORFLG (ERROR!))
(T (/SETATOMVAL (QUOTE LASTSUBSYS)
FORK)))))))
(MYCOPYBYTES
(LAMBDA (SRCFIL DSTFIL START END) (* lmm "28-MAR-78 16:27")
(PROG ((SRCJFN (COND
((ILESSP (LOC SRCFIL)
777Q)
(JS SFPTR (LOC SRCFIL)
START)
SRCFIL)
(T (SETFILEPTR SRCFIL START)
(VAG (OPNJFN SRCFIL (QUOTE INPUT))))))
(DSTJFN (COND
((ILESSP (LOC DSTFIL)
777Q)
DSTFIL)
(T (VAG (OPNJFN DSTFIL (QUOTE OUTPUT)))))))
(ASSEMBLE NIL
(PUSHN)
(CQ SRCJFN)
(JS RFBSZ) (* get byte size for this
opening of file)
(MOVEI 3 , 1000Q)
(IDIV 3 , 2)
(PUSHN 3) (* # bytes on the page)
(LSH 2 , 30Q)
(IOR 2 , = -337777001000Q)
(* make byte pointer with right
byte size)
(PUSHN 2)
(HRROI 1 , -1)
(SKIPA 2 , * 1)
(XWD 400000Q 777Q)
(JS PMAP) (* clear page 777q)
(CQ (VAG (IDIFFERENCE END START)))
(PUSHN)
(JUMPL 1 , PUNT)
LOOP(NREF (SKIPN 1 , 0))
(JRST DONE)
(NREF (CAMG 1 , -2))
(JRST LAST-TIME)
(NREF (SUB 1 , -2))
(NREF (MOVEM 1 , 0))
(NREF (MOVN 3 , -2))
(JRST HIT-IT)
LAST-TIME
(NREF (MOVN 3 , 0))
(NREF (SETZM 0))
HIT-IT
(NREF (MOVEM 3 , -3))
(CQ SRCJFN)
(NREF (MOVE 2 , -1))
(JS SIN)
(JUMPN 3 , IOERR)
(CQ DSTJFN)
(NREF (MOVE 3 , -3))
(CAIE 1 , 100Q)
(CAIN 1 , 101Q)
(JRST OUT-TO-TTY)
(NREF (MOVE 2 , -1))
(JS SOUT)
(JUMPN 3 , IOERR)
(JRST LOOP)
OUT-TO-TTY
(MOVEI FX , 1)
(NREF (MOVE 2 , -1))
LOOP2
(ILDB 1 , 2)
(PUSHJ CP , FOUT)
(AOJL 3 , LOOP2)
(JRST LOOP)
IOERR
(CQ (SETQ SRCJFN (AC)))
(CQ (ERROR (QUOTE "IO ERROR IN COPYBYTES")
(JFNS (LOC SRCJFN))))
PUNT(CQ (ERROR (LOC (AC))
"NEG. # BYTES TO COPY??"))
DONE(POPNN 4))
(RETURN T))))
(MYGTJFN
(LAMBDA (DIR NAME EXT FLAGS) (* lmm "28-MAR-78 16:26")
(* get jfn from TTY, with
default directory, name, and
extension)
(ASSEMBLE NIL
(PUSHNN (= 0)
(= 100000101Q)
(= 0)
(XXXMHC)
(= 0)
(= 0)
(= 0)
(= 0))
(* gtjfn block are -
-7 flags -
e+1 injfn,,outjfn -
e+2 device -
-4 directory -
-3 name -
-2 extension -
e+6 protection -
e+7 account)
(CQ (VAG (OR FLAGS 0)))
(NREF (HRLM 1 , -7))
(CQ DIR)
(CAMN 1 , KNIL)
(VAR (HRRZ 1 , USERNAME))
(LDTY 3)
(CAIN 3 , ATOMT)
(HLRZ 1 , 2 (1))
(MOVE 2 , XXXMHC)
(PUSHJ CP , SUBROUTINE)
(CQ NAME)
(CAMN 1 , KNIL)
(JRST NOFILE)
(NREF (MOVEM 2 , -3))
(LDTY 3)
(CAIN 3 , ATOMT)
(HLRZ 1 , 2 (1))
(PUSHJ CP , SUBROUTINE)
NOFILE
(CQ EXT)
(CAMN 1 , KNIL)
(JRST NOEXT)
(NREF (MOVEM 2 , -2))
(LDTY 3)
(CAIN 3 , ATOMT)
(HLRZ 1 , 2 (1))
(PUSHJ CP , SUBROUTINE)
NOEXT
(NREF (MOVEI 1 , -7))
(MOVEI 2 , 0)
(JS GTJFN)
(SKIPA 1 , KNIL)
(ADDI 1 , ASZ)
(JRST OUT)
SUBROUTINE
(FASTCALL UPATM)
(* UPATM takes a string or pname in ac1, preserves acs 1 and 2
and returns a byte pointer in ac3 and a byte count in ac4.)
SUBROUTINE1
(ILDB 1 , 3)
(IDPB 1 , 2)
(SOJG 4 , SUBROUTINE1)
(IDPB 4 , 2) (* Add NULL byte on end to
terminate.)
(RET)
RETNIL
(CQ NIL)
OUT (POPNN 10Q))))
)
(DEFINEQ
(MSGABORT
(LAMBDA NIL (* lmm: "17-FEB-77 07:45:56")
(JS CFOBF 101Q)
(PRIN1 "
** aborting **
")
(ERROR!)))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(CLISPDEC (QUOTE FAST))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS FLDID MACRO (X (KWOTE (PACK* "
" (CAR X)
": "))))
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: MSGBLOCK MSG DELCHECK DOMSGS FINDMESSAGE# MSGOPEN MSGSETUP NEWMAIL PRINTCURRENT PRINTFIELD
PRINTHEADER PRINTMESSAGE PUTMESSAGE READMESSAGES READMESSAGETEST READSTRING REWRITEMSGS
(ENTRIES MSG PRINTHEADER PRINTMESSAGE PUTMESSAGE MSGSETUP)
(NOLINKFNS . T)
(RETFNS DOMSGS)
(SPECVARS MSGOPEN MSGJFN KEEPJFN NEWMAIL LSTFIL LL #MSGS CURRENTMESSAGE INTS INVERTED
LASTMSGREAD MSGFILE OLDINT)
(GLOBALVARS MSGDATE MSGINTERRUPTS OLDTTBL USERNAMESTRING MSGTTBL REVMSGS MSGS UPLOW MSGSETUP
MSGRDTBL MSGLENGTHFLG LASTMSGWRITE USERNAME LASTEXEC)
PARSEMSGRANGE CHECKMSG# GETFILENAME MYCOPYBYTES MYGTJFN CONFIRM MYTAB MYASKUSER MYSUBSYS)
]
(RPAQQ LAURELMSGCOMS [(FNS COPYLAURELMSG)
(DECLARE: DONTCOPY (MACROS MSGBIN))
(BLOCKS (NIL COPYLAURELMSG (LOCALVARS . T])
(DEFINEQ
(COPYLAURELMSG
[LAMBDA (LAURELFILE TENXFILE) (* lmm "24-JAN-82 11:12")
(RESETLST [RESETSAVE (INFILE LAURELFILE)
(QUOTE (PROGN (CLOSEF (INPUT]
[RESETSAVE (OUTFILE TENXFILE)
(QUOTE (COND [RESETSTATE (DELFILE (CLOSEF (OUTPUT]
(T (CLOSEF (OUTPUT]
(PROG ([IJ (VAG (OPNJFN (INPUT]
[OJ (VAG (OPNJFN (OUTPUT]
CHCOUNT LFCNT (OF (OUTPUT))
CHSEEN DPOS NCHCOUNT CH HERE)
MSGLP
(SETQ CHSEEN 0)
(OR (SELCHARQ (SETQ CH (LOC (MSGBIN)))
(NULL (RETURN OF))
[* (AND (EQ (LOC (MSGBIN))
(CHARCODE s))
(EQ (LOC (MSGBIN))
(CHARCODE t))
(EQ (LOC (MSGBIN))
(CHARCODE a))
(EQ (LOC (MSGBIN))
(CHARCODE r))
(EQ (LOC (MSGBIN))
(CHARCODE t))
(EQ (LOC (MSGBIN))
(CHARCODE *))
(EQ (LOC (MSGBIN))
(CHARCODE CR]
NIL)
(ERROR "Bad Laurel File Format" (INPUT)))
(SETQ CHCOUNT 0)
(do (SELCHARQ (SETQ CH (LOC (MSGBIN)))
[(0 1 2 3 4 5 6 7 8 9)
(SETQ CHCOUNT (IDIFFERENCE (IPLUS (ITIMES CHCOUNT 10)
CH)
(CHARCODE 0]
(RETURN)))
[until (EQ (MSGBIN)
(VAG (CHARCODE CR]
(PRIN3 "01-JAN-01 00:00:01,")
(SETQ DPOS (GETFILEPTR OF))
(PRIN3 "0000000;000000000000
")
(SETQ LFCNT 0)
(FRPTQ (SETQ NCHCOUNT (IDIFFERENCE CHCOUNT CHSEEN))
(ASSEMBLE NIL
(CQ IJ)
GLP (JS BIN)
(CAIN 2 , 12Q)
(JRST GLP)
(CQ OJ)
(JS BOUT)
(CAIE 2 , 15Q)
(JRST OUT)
(MOVEI 2 , 12Q)
(JS BOUT)
(CQ (ADD1VAR LFCNT))
OUT))
(SETQ HERE (GETFILEPTR OF))
(SETFILEPTR OF DPOS)
(PRINTNUM (QUOTE (FIX 7 10 T))
(IPLUS NCHCOUNT LFCNT))
(SETFILEPTR OF HERE)
(GO MSGLP])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS MSGBIN MACRO [NIL (ASSEMBLE NIL
(CQ IJ)
LP (JS BIN)
(CAIN 2 , 12Q)
(JRST LP)
(VAR (AOS CHSEEN))
(MOVEI 1 , 0 (2])
)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL COPYLAURELMSG (LOCALVARS . T))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS ARG)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS USERFORKS LASTSUBSYS SUBSYSSPELLINGS)
)
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(ARRAYBLOCK MSG ((# BETWEEN 0 4095)
(DATE INTEGER)
(HEADLEN BETWEEN 0 127)
(BEGIN INTEGER)
(SIZE BETWEEN 0 262143)
(MARKS INTEGER)
(MARKPOS BETWEEN 0 127)
(FIELDS POINTER)
(HEADEREND POINTER))
(* max # messages 4000 -
max length 4000 chars?)
[ACCESSFNS MSG ((END (IPLUS (fetch SIZE of DATUM)
(fetch BEGIN of DATUM)
(fetch HEADLEN of DATUM)))
(START (IPLUS (fetch BEGIN of DATUM)
(fetch HEADLEN of DATUM])
]
(FILESLOAD (SYSLOAD)
CJSYS)
)
(DECLARE: DONTCOPY (PUTPROPS MSG COPYRIGHT ("Xerox Corporation" 1982)))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2437 28004 (MSG 2449 . 9423) (CHECKMSG# 9427 . 9772) (CHECKMSGDATE 9776 . 10025) (
CONFIRM 10029 . 10319) (DELCHECK 10323 . 10576) (DOMSGS 10580 . 11098) (FINDMESSAGE# 11102 . 11248) (
GETFILENAME 11252 . 12329) (MSGOPEN 12333 . 12829) (MSGSETUP 12833 . 13999) (NEWMAIL 14003 . 14207) (
PARSEMSGRANGE 14211 . 14873) (PRINTCURRENT 14877 . 15110) (PRINTFIELD 15114 . 16319) (PRINTHEADER
16323 . 17474) (PRINTMESSAGE 17478 . 18171) (PUTMESSAGE 18175 . 18648) (READMESSAGES 18652 . 22289) (
READMESSAGETEST 22293 . 24895) (READSTRING 24899 . 25173) (REWRITEMSGS 25177 . 27405) (MSGXXX 27409 .
27533) (MSGTJFN 27537 . 27632) (TESTRANGE 27636 . 28001)) (28006 32059 (ORPRED 28018 . 28345) (ANDPRED
28349 . 28683) (NOTPRED 28687 . 28813) (TESTMSG# 28817 . 29087) (MSGSEARCH 29091 . 29283) (FINDTO
29287 . 29466) (FINDFROM 29470 . 29657) (FINDKEY 29661 . 29747) (FINDMSGKEY 29751 . 29928) (DELETED?
29932 . 30019) (EXAMINED? 30023 . 30169) (RECENT? 30173 . 30318) (GETFIELD 30322 . 31057) (MARKMESSAGE
31061 . 31500) (UNMARKMESSAGE 31504 . 31956) (TRUE 31960 . 32056)) (32061 46744 (MYSTRPOS 32073 .
33967) (MYASKUSER 33971 . 35465) (MYTAB 35469 . 35943) (MYSUBSYS 35947 . 42848) (MYCOPYBYTES 42852 .
44904) (MYGTJFN 44908 . 46741)) (46746 46920 (MSGABORT 46758 . 46917)) (47950 49896 (COPYLAURELMSG
47962 . 49893)))))
STOP