(FILECREATED " 8-Jun-84 22:35:31" {ERIS}<LISPCORE>SOURCES>IOCHAR.;3 58657
previous date: " 1-JUN-84 23:24:48" {ERIS}<LISPCORE>SOURCES>IOCHAR.;2)
(* Copyright (c) 1981, 1982, 1983, 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT IOCHARCOMS)
(RPAQQ IOCHARCOMS [(COMS (FNS CHCON UNPACK DCHCON DUNPACK)
(FNS UALPHORDER ALPHORDER PACKC CONCAT PACK PACK* STRPOS)
(GLOBALVARS \SIGNFLAG \PRINTRADIX))
(COMS (FNS STRPOSL MAKEBITTABLE)
(GLOBALRESOURCES \STRPOSLARRAY))
(COMS (FNS CASEARRAY UPPERCASEARRAY)
(P (MOVD? (QUOTE SETA)
(QUOTE SETCASEARRAY))
(MOVD? (QUOTE ELT)
(QUOTE GETCASEARRAY)))
[DECLARE: DONTEVAL@LOAD DOCOPY (VARS (\TRANSPARENT (CASEARRAY))
(UPPERCASEARRAY (UPPERCASEARRAY]
(DECLARE: EVAL@COMPILE (PROP GLOBALVAR UPPERCASEARRAY)
DONTCOPY
(GLOBALVARS \TRANSPARENT)))
(COMS (FNS SKREAD SKATOM SKBRACKET SKREADC SKSTRING)
(BLOCKS (SKREAD SKREAD SKATOM SKBRACKET SKREADC SKSTRING)))
[COMS (FNS FILEPOS FFILEPOS \SETUP.FFILEPOS)
(GLOBALRESOURCES \FFDELTA1 \FFDELTA2 \FFPATCHAR)
(DECLARE: EVAL@COMPILE DONTCOPY (CONSTANTS (\MAX.PATTERN.SIZE 128)
(\MIN.PATTERN.SIZE 3)
(FILEPOS.SEGMENT.SIZE 32768)
(\MIN.SEARCH.LENGTH 100]
[COMS (* DATE)
(FNS DATE DATEFORMAT GDATE IDATE \IDATESCANTOKEN \OUTDATE \RPLRIGHT
\UNPACKDATE \PACKDATE \DTSCAN \ISDST? \CHECKDSTCHANGE)
(MACROS DATEFORMAT)
(INITVARS (\TimeZoneComp 8)
(\BeginDST 120)
(\EndDST 304)
(\DayLightSavings T))
(ADDVARS (TIME.ZONES (8 . P)
(7 . M)
(6 . C)
(5 . E)
(0 . GMT)))
(DECLARE: EVAL@COMPILE DONTCOPY (GLOBALVARS \TimeZoneComp \BeginDST \EndDST
\DayLightSavings TIME.ZONES)
(CONSTANTS (\4YearsDays (ADD1 (ITIMES 365 4]
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA DATEFORMAT)
(NLAML)
(LAMA PACK* CONCAT])
(DEFINEQ
(CHCON
[LAMBDA (X FLG RDTBL) (* rmk: "26-MAY-80 22:32")
(PROG (BASE OFFST LEN \CHCONLST)
(COND
(FLG (GO SLOWCASE)))
(SELECTC (NTYPX X)
(\LITATOM (SETQ BASE (fetch (LITATOM PNAMEBASE) of X))
(SETQ OFFST 1)
(SETQ LEN (fetch (LITATOM PNAMELENGTH) of X)))
(\STRINGP (SETQ BASE (fetch (STRINGP BASE) of X))
(SETQ OFFST (fetch (STRINGP OFFST) of X))
(SETQ LEN (fetch (STRINGP LENGTH) of X)))
(GO SLOWCASE))
(RETURN (for I from OFFST to (IPLUS OFFST LEN -1) collect (GETBASEBYTE BASE I)))
SLOWCASE
(\MAPCHARS [FUNCTION (LAMBDA (CODE)
(SETQ \CHCONLST (DOCOLLECT CODE \CHCONLST]
X FLG RDTBL)
(RETURN (ENDCOLLECT \CHCONLST])
(UNPACK
[LAMBDA (X FLG RDTBL) (* rmk: "26-MAY-80 22:33")
(PROG (BASE OFFST LEN \UNPACKLST)
(COND
(FLG (GO SLOWCASE)))
(SELECTC (NTYPX X)
(\LITATOM (SETQ BASE (fetch (LITATOM PNAMEBASE) of X))
(SETQ OFFST 1)
(SETQ LEN (fetch (LITATOM PNAMELENGTH) of X)))
(\STRINGP (SETQ BASE (fetch (STRINGP BASE) of X))
(SETQ OFFST (fetch (STRINGP OFFST) of X))
(SETQ LEN (fetch (STRINGP LENGTH) of X)))
(GO SLOWCASE))
[RETURN (for I from OFFST to (IPLUS OFFST LEN -1) collect (FCHARACTER (GETBASEBYTE BASE I]
SLOWCASE
(\MAPCHARS [FUNCTION (LAMBDA (CODE)
(SETQ \UNPACKLST (DOCOLLECT (FCHARACTER CODE)
\UNPACKLST]
X FLG RDTBL)
(RETURN (ENDCOLLECT \UNPACKLST])
(DCHCON
[LAMBDA (X SCRATCHLIST FLG RDTBL) (* rmk: "26-MAY-80 22:33")
(SCRATCHLIST SCRATCHLIST (PROG (BASE OFFST LEN)
(COND
(FLG (GO SLOWCASE)))
(SELECTC (NTYPX X)
(\LITATOM (SETQ BASE (fetch (LITATOM PNAMEBASE)
of X))
(SETQ OFFST 1)
(SETQ LEN (fetch (LITATOM PNAMELENGTH)
of X)))
(\STRINGP (SETQ BASE (fetch (STRINGP BASE) of X))
(SETQ OFFST (fetch (STRINGP OFFST)
of X))
(SETQ LEN (fetch (STRINGP LENGTH) of X)))
(GO SLOWCASE))
[RETURN (for I from OFFST to (IPLUS OFFST LEN -1)
do (ADDTOSCRATCHLIST (GETBASEBYTE BASE I]
SLOWCASE
(RETURN (\MAPCHARS (FUNCTION [LAMBDA (CODE)
(ADDTOSCRATCHLIST CODE])
X FLG RDTBL])
(DUNPACK
[LAMBDA (X SCRATCHLIST FLG RDTBL) (* rmk: "26-MAY-80 22:34")
(SCRATCHLIST SCRATCHLIST (PROG (BASE OFFST LEN)
(COND
(FLG (GO SLOWCASE)))
(SELECTC (NTYPX X)
(\LITATOM (SETQ BASE (fetch (LITATOM PNAMEBASE)
of X))
(SETQ OFFST 1)
(SETQ LEN (fetch (LITATOM PNAMELENGTH)
of X)))
(\STRINGP (SETQ BASE (fetch (STRINGP BASE) of X))
(SETQ OFFST (fetch (STRINGP OFFST)
of X))
(SETQ LEN (fetch (STRINGP LENGTH) of X)))
(GO SLOWCASE))
[RETURN (for I from OFFST to (IPLUS OFFST LEN -1)
do (ADDTOSCRATCHLIST (FCHARACTER (GETBASEBYTE BASE I]
SLOWCASE
(RETURN (\MAPCHARS [FUNCTION (LAMBDA (CODE)
(ADDTOSCRATCHLIST (FCHARACTER CODE]
X FLG RDTBL])
)
(DEFINEQ
(UALPHORDER
[LAMBDA (A B) (* JonL "17-Dec-83 05:26")
(ALPHORDER A B UPPERCASEARRAY])
(ALPHORDER
[LAMBDA (A B CASEARRAY) (* bvm: "17-Dec-83 18:04")
(DECLARE (GLOBALVARS \TRANSPARENT))
(PROG (CA ABASE ALEN AOFFSET BBASE BLEN BOFFSET C1 C2)
[COND
((LITATOM A)
(SETQ ABASE (fetch (LITATOM PNAMEBASE) of A))
(SETQ AOFFSET 1)
(SETQ ALEN (fetch (LITATOM PNAMELENGTH) of A)))
((STRINGP A)
(SETQ ABASE (fetch (STRINGP BASE) of A))
(SETQ AOFFSET (fetch (STRINGP OFFST) of A))
(SETQ ALEN (fetch (STRINGP LENGTH) of A)))
(T (RETURN (COND
[(NUMBERP A) (* Numbers are less than all other types)
(OR (NOT (NUMBERP B))
(NOT (GREATERP A B]
((OR (NUMBERP B)
(LITATOM B)
(STRINGP B))
NIL)
(T T]
[COND
((LITATOM B)
(SETQ BBASE (fetch (LITATOM PNAMEBASE) of B))
(SETQ BOFFSET 1)
(SETQ BLEN (fetch (LITATOM PNAMELENGTH) of B)))
((STRINGP B)
(SETQ BBASE (fetch (STRINGP BASE) of B))
(SETQ BOFFSET (fetch (STRINGP OFFST) of B))
(SETQ BLEN (fetch (STRINGP LENGTH) of B)))
(T (* Only numbers are "less than" atoms and strings)
(RETURN (NOT (NUMBERP B]
[SETQ CA (fetch (ARRAYP BASE) of (\DTEST (OR CASEARRAY \TRANSPARENT)
(QUOTE ARRAYP]
(RETURN (for I from 0 do (COND
[(IGEQ I ALEN)
(RETURN (COND
((EQ ALEN BLEN)
(QUOTE EQUAL))
(T (QUOTE LESSP]
((IGEQ I BLEN)
(RETURN NIL))
[(EQ [SETQ C1 (\GETBASEBYTE CA (\GETBASEBYTE ABASE
(IPLUS I AOFFSET]
(SETQ C2 (\GETBASEBYTE CA (\GETBASEBYTE BBASE
(IPLUS I BOFFSET]
((ILESSP C1 C2)
(RETURN (QUOTE LESSP)))
(T (* "Greater")
(RETURN NIL])
(PACKC
[LAMBDA (X) (* rmk: "27-JAN-81 20:46")
(GLOBALRESOURCE \PNAMESTRING
(PROG ((N 0)
(PBASE (fetch (STRINGP BASE) of \PNAMESTRING)))
LP [COND
((NULL X)
(RETURN (\MKATOM PBASE 0 N]
(AND (IGREATERP N \PNAMELIMIT)
(LISPERROR "ATOM TOO LONG"))
(PUTBASEBYTE PBASE N (CAR X))
(add N 1)
(SETQ X (CDR X))
(GO LP)))])
(CONCAT
[LAMBDA N (* lmm "20-APR-80 17:10")
(PROG ((J N)
(LEN 0)
(POS 1)
S NM)
L1 (COND
((NEQ J 0)
[OR (STRINGP (SETQ NM (ARG N J)))
(LITATOM NM)
(SETARG N J (SETQ NM (MKSTRING NM]
(SETQ LEN (IPLUS LEN (NCHARS NM)))
(SETQ J (SUB1 J))
(GO L1)))
(SETQ S (ALLOCSTRING LEN))
L2 (COND
((NEQ J N)
(SETQ J (ADD1 J))
(RPLSTRING S POS (ARG N J))
[SETQ POS (IPLUS POS (NCHARS (ARG N J]
(GO L2)))
(RETURN S])
(PACK
[LAMBDA (X) (* rmk: "21-OCT-81 13:42")
(AND X (NLISTP X)
(\ILLEGAL.ARG X))
(GLOBALRESOURCE \PNAMESTRING
(PROG (ITEM (N 1))
(DECLARE (SPECVARS N))
LP [COND
((NULL X)
(RETURN (\MKATOM (fetch (STRINGP BASE) of \PNAMESTRING)
0
(SUB1 N]
(COND
((OR (STRINGP (SETQ ITEM (CAR X)))
(LITATOM ITEM))
(RPLSTRING \PNAMESTRING (PROG1 N (AND (IGREATERP (add N (NCHARS ITEM))
(ADD1 \PNAMELIMIT))
(LISPERROR "ATOM TOO LONG")))
ITEM))
(T (\MAPCHARS (FUNCTION [LAMBDA (CODE)
(AND (IGREATERP N \PNAMELIMIT)
(LISPERROR "ATOM TOO LONG"))
(\RPLCHARCODE \PNAMESTRING N CODE)
(add N 1])
ITEM)))
(SETQ X (LISTP (CDR X)))
(GO LP)))])
(PACK*
[LAMBDA U (* rmk: "29-JAN-81 14:36")
(GLOBALRESOURCE \PNAMESTRING
(PROG (ITEM (N 1)
(M 1))
(DECLARE (SPECVARS N))
LP [COND
((IGREATERP M U)
(RETURN (\MKATOM (fetch (STRINGP BASE) of \PNAMESTRING)
0
(SUB1 N]
(COND
((OR (STRINGP (SETQ ITEM (ARG U M)))
(LITATOM ITEM))
(RPLSTRING \PNAMESTRING (PROG1 N (AND (IGREATERP (add N (NCHARS ITEM))
(ADD1 \PNAMELIMIT))
(LISPERROR "ATOM TOO LONG")))
ITEM))
(T (\MAPCHARS (FUNCTION [LAMBDA (CODE)
(AND (IGREATERP N \PNAMELIMIT)
(LISPERROR "ATOM TOO LONG"))
(\RPLCHARCODE \PNAMESTRING N CODE)
(add N 1])
ITEM)))
(SETQ M (ADD1 M))
(GO LP)))])
(STRPOS
(LAMBDA (PAT STRING START SKIP ANCHOR TAIL CASEARRAY BACKWARDSFLG)
(* JonL " 7-May-84 03:12")
(DECLARE (GLOBALVARS \TRANSPARENT))
(PROG (PATLEN PATBASE PATOFFST STRINGLEN STRINGBASE STRINGOFFST MAXI JMAX 1stPATchar jthPATchar)
(if (LITATOM PAT)
then (SETQ PATBASE (fetch (LITATOM PNAMEBASE) of PAT))
(SETQ PATOFFST 1)
(SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of PAT))
else (OR (STRINGP PAT)
(SETQ PAT (MKSTRING PAT)))
(SETQ PATBASE (fetch (STRINGP BASE) of PAT))
(SETQ PATOFFST (fetch (STRINGP OFFST) of PAT))
(SETQ PATLEN (fetch (STRINGP LENGTH) of PAT)))
(if (LITATOM STRING)
then (SETQ STRINGBASE (fetch (LITATOM PNAMEBASE) of STRING))
(SETQ STRINGOFFST 1)
(SETQ STRINGLEN (fetch (LITATOM PNAMELENGTH) of STRING))
else (OR (STRINGP STRING)
(SETQ STRING (MKSTRING STRING)))
(SETQ STRINGBASE (fetch (STRINGP BASE) of STRING))
(SETQ STRINGOFFST (fetch (STRINGP OFFST) of STRING))
(SETQ STRINGLEN (fetch (STRINGP LENGTH) of STRING)))
(if (IGEQ 0 (SETQ MAXI (ADD1 (IDIFFERENCE STRINGLEN PATLEN))))
then (* Who's he kidding? The PATTERN length is greater than
the STRING length)
(RETURN))
(if (NULL START)
then (SETQ START (if BACKWARDSFLG
then MAXI
else 1))
elseif (ILESSP START 0)
then (add START (ADD1 STRINGLEN))
(if (ILESSP START 1)
then (RETURN))
elseif (IGREATERP START MAXI)
then (RETURN)) (* Normalize start to a 1-origin index between 1 and
LEN)
(if (ILEQ PATLEN 0)
then (RETURN START)) (* Null pattern matches anything)
(AND SKIP (SETQ SKIP (CHCON1 SKIP)))
(if (NULL CASEARRAY)
then (SETQ CASEARRAY \TRANSPARENT)
elseif (NOT (AND (ARRAYP CASEARRAY)
(EQ \ST.BYTE (fetch (ARRAYP TYP) of CASEARRAY))
(EQ (CONSTANT (EXPT 2 BITSPERBYTE))
(fetch (ARRAYP LENGTH) of CASEARRAY))))
then (\ILLEGAL.ARG CASEARRAY)) (* Oh, for a LET here!)
(add STRINGOFFST -1)
(add PATOFFST -1)
(RETURN (PROG ((CAOFFST (fetch (ARRAYP OFFST) of CASEARRAY))
(CABASE (fetch (ARRAYP BASE) of CASEARRAY))
(OFFST.I (IPLUS STRINGOFFST START (if BACKWARDSFLG
then 1
else -1)))
(LASTI (IPLUS STRINGOFFST
(if ANCHOR
then START
elseif BACKWARDSFLG
then 1
else MAXI)))
(JSTART (IPLUS PATOFFST 2))
(JMAX (IPLUS PATOFFST PATLEN))) (* Remember! START is a 1-origin index)
(* There will be at least one pass thru the following
loop, or else we would have (RETURN) before now)
(OR (EQ 0 CAOFFST)
(SHOULDNT "NonZero OFFST for a CASEARRAY?"))
(SETQ 1stPATchar (\GETBASEBYTE CABASE (\GETBASEBYTE PATBASE (ADD1 PATOFFST))))
LP (if (if BACKWARDSFLG
then (ILESSP (add OFFST.I -1)
LASTI)
else (IGREATERP (add OFFST.I 1)
LASTI))
then (RETURN)
elseif (AND (OR (EQ 1stPATchar SKIP)
(EQ 1stPATchar (\GETBASEBYTE CABASE (\GETBASEBYTE
STRINGBASE
OFFST.I))))
(for J from JSTART to JMAX as K from (ADD1 OFFST.I)
always (OR (EQ SKIP (SETQ jthPATchar
(\GETBASEBYTE CABASE (\GETBASEBYTE PATBASE
J))))
(EQ jthPATchar (\GETBASEBYTE CABASE
(\GETBASEBYTE
STRINGBASE K)))
)))
then (RETURN (IDIFFERENCE (if TAIL
then (IPLUS OFFST.I PATLEN)
else OFFST.I)
STRINGOFFST)))
(GO LP) (* Fall out thru bottom if didn't find it)
)))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \SIGNFLAG \PRINTRADIX)
)
(DEFINEQ
(STRPOSL
(LAMBDA (A STRING START NEG BACKWARDSFLG) (* JonL "30-Apr-84 19:59")
(GLOBALRESOURCE \STRPOSLARRAY (PROG (BASE OFFST LEN I LASTI)
(OR (type? CHARTABLE A)
(SETQ A (MAKEBITTABLE A NIL \STRPOSLARRAY)))
(if (LITATOM STRING)
then (SETQ BASE (fetch (LITATOM PNAMEBASE) of STRING))
(SETQ LEN (fetch (LITATOM PNAMELENGTH) of STRING))
(SETQ OFFST 1)
else (OR (STRINGP STRING)
(SETQ STRING (MKSTRING STRING)))
(SETQ BASE (fetch (STRINGP BASE) of STRING))
(SETQ LEN (fetch (STRINGP LENGTH) of STRING))
(SETQ OFFST (fetch (STRINGP OFFST) of STRING)))
(if (NULL START)
then (SETQ START (if BACKWARDSFLG
then LEN
else 1))
elseif (ILESSP START 0)
then (add START (ADD1 LEN))
(if (ILESSP START 1)
then (RETURN))
elseif (IGREATERP START LEN)
then (RETURN)) (* Normalize start to a 1-origin index between 1 and
LEN)
(add OFFST -1) (* Bias the OFFST since START is 1-origin and the loop
deals in 0-origin)
(SETQ NEG (if NEG
then
(* Convert NEG to match the correct value returned by
\SYNCODE)
0
else 1))
(SETQ I (IPLUS OFFST START))
(SETQ LASTI (IPLUS OFFST (if BACKWARDSFLG
then (add I 1)
1
else (add I -1)
LEN)))
(* There will be at least one pass thru the following
loop, or else we would have (RETURN) before now)
LP (if (if BACKWARDSFLG
then (ILESSP (add I -1)
LASTI)
else (IGREATERP (add I 1)
LASTI))
then (RETURN)
elseif (EQ NEG (\SYNCODE A (\GETBASEBYTE BASE I)))
then (RETURN (IDIFFERENCE I OFFST)))
(GO LP)))))
(MAKEBITTABLE
[LAMBDA (L NEG A) (* rmk: "20-NOV-81 15:19")
[COND
((type? CHARTABLE A) (* Clear it)
(\ZEROBYTES A 0 \MAXCHAR))
(T (SETQ A (create CHARTABLE]
(for X in L do (\SETSYNCODE A (OR (AND (SMALLP X)
(LOGAND X \MAXCHAR))
(CHCON1 X))
1)) (* Invert 1 and 0 if NEG)
[AND NEG (for I from 0 to \MAXCHAR do (\SETSYNCODE A I (LOGXOR 1 (\SYNCODE A I]
A])
)
(RPAQQ \\STRPOSLARRAY.GLOBALRESOURCE NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
[PUTDEF (QUOTE \STRPOSLARRAY)
(QUOTE GLOBALRESOURCES)
(QUOTE (NEW (NCREATE (QUOTE CHARTABLE]
)
(DEFINEQ
(CASEARRAY
[LAMBDA (OLDAR) (* lmm "20-MAR-81 10:21")
(COND
(OLDAR (COPYARRAY OLDAR))
(T (PROG ((AR (ARRAY 256 (QUOTE BYTE)
0 0)))
(for I from 0 to 255 do (SETA AR I I))
(RETURN AR])
(UPPERCASEARRAY
(LAMBDA NIL (* bvm: "14-Dec-83 10:46")
(OR (ARRAYP UPPERCASEARRAY)
(PROG ((CA (CASEARRAY)))
(for I from (CHARCODE a) to (CHARCODE z)
do (SETCASEARRAY CA I (IDIFFERENCE I (CONSTANT (IDIFFERENCE (CHARCODE a)
(CHARCODE A))))))
(RETURN (SETQ UPPERCASEARRAY CA))))))
)
(MOVD? (QUOTE SETA)
(QUOTE SETCASEARRAY))
(MOVD? (QUOTE ELT)
(QUOTE GETCASEARRAY))
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ \TRANSPARENT (CASEARRAY))
(RPAQ UPPERCASEARRAY (UPPERCASEARRAY))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS UPPERCASEARRAY GLOBALVAR T)
DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \TRANSPARENT)
)
)
(DEFINEQ
(SKREAD
(LAMBDA (FILE REREADSTRING) (* JonL " 7-May-84 03:17")
(DECLARE (SPECVARS RRPTR REREADSTRING)
(GLOBALVARS FILERDTBL))
(PROG (SNX (OFD (\GETOFD FILE (QUOTE INPUT)))
(RRPTR (AND REREADSTRING 1)))
(COND
((\INTERMP OFD) (* mainly because of the backfileptr)
(ERROR "SKREAD NOT LEGAL FROM TTY" FILE)))
(OR (READTABLEP FILERDTBL)
(SETQ FILERDTBL (\GTREADTABLE FILERDTBL))) (* Make sure FILERDTBL is OK)
TOP (SETQ SNX (SKREADC RRPTR OFD))
RETRY
(RETURN (SELECTC SNX
(LEFTBRACKET.RC (SKBRACKET OFD))
(RIGHTBRACKET.RC (QUOTE %]))
(LEFTPAREN.RC (PROG ((PARENCOUNT 1))
PRN (SELECTC (SKREADC RRPTR OFD)
(LEFTBRACKET.RC (SKBRACKET OFD))
(RIGHTBRACKET.RC (RETURN (QUOTE %])))
(LEFTPAREN.RC (add PARENCOUNT 1))
(RIGHTPAREN.RC (COND
((EQ 0 (SETQ PARENCOUNT
(SUB1 PARENCOUNT)))
(RETURN))))
(STRINGDELIM.RC (SKSTRING OFD))
NIL)
(GO PRN)))
(RIGHTPAREN.RC (QUOTE %)))
(SEPRCHAR.RC (GO TOP))
(BREAKCHAR.RC NIL)
(STRINGDELIM.RC (SKSTRING OFD))
(OTHER.RC (* Only macros and others left.
If necessary, the file will be backed up so that the
terminating character can be re-read)
(SKATOM OFD))
(COND
(SNX
(* SKREADC returns a skip-function or NIL for macros. This is a kludge that follows the pdp-10 implementation.
Note, for example, that macro-contexts are not handled properly.)
(AND (SETQ REREADSTRING (APPLY* SNX (fetch FULLNAME of OFD)
FILERDTBL REREADSTRING))
(GO TOP)))
(RRPTR (* Reading from the rereadstring and a top level MACRO
found. For right now, bomb out, fix it up later.)
(SKATOM OFD))
(T (\BACKFILEPTR OFD)
(READ OFD FILERDTBL)
NIL)))))))
(SKATOM
[LAMBDA (OFD) (* rmk: "18-SEP-80 16:40")
(* This only gets called fro top-level SKREAD or for a
macro char.)
(while (EQ (SKREADC RRPTR OFD)
OTHER.RC)) (* If last character did not come from the file, we can
just ignore it cause the SKREAD finishes without
touching the file.)
(OR RRPTR (\BACKFILEPTR OFD))
NIL])
(SKBRACKET
(LAMBDA (OFD) (* JonL " 7-May-84 03:18")
(PROG ((BRACKETCOUNT 1))
BRKT(SELECTC (SKREADC RRPTR OFD)
(LEFTBRACKET.RC (add BRACKETCOUNT 1))
(RIGHTBRACKET.RC (COND
((EQ 0 (SETQ BRACKETCOUNT (SUB1 BRACKETCOUNT)))
(RETURN))))
(STRINGDELIM.RC (SKSTRING OFD))
NIL)
(GO BRKT))))
(SKREADC
[LAMBDA (USERRPTRFLG OFD) (* rmk: " 9-DEC-80 21:37")
(* Returns the syntax class for non-macro characters, and the a skipfn or NIL for macros. -
USERRPTRFLG is actually the RRPTR of the caller. Free variable lookup done only when using the re-read string, which
is rare.)
(DECLARE (GLOBALVARS FILERDTBL))
(PROG (SNX CHAR)
[COND
(USERRPTRFLG [SETQ CHAR (NTHCHARCODE REREADSTRING (PROG1 RRPTR (add RRPTR 1]
(COND
((NULL CHAR) (* Set the free variable that all callers use to pass in
the string, and fall thru to the file case)
(SETQ RRPTR NIL))
((EQ (SETQ SNX (\SYNCODE (fetch READSA of FILERDTBL)
CHAR))
ESCAPE.RC)
[AND (fetch ESCAPEFLG of FILERDTBL)
(COND
([NULL (NTHCHARCODE REREADSTRING (PROG1 RRPTR (add RRPTR 1]
(SETQ RRPTR NIL)
(\BIN OFD] (* Treat escape as other if escapeflg is NIL)
(RETURN OTHER.RC))
[(fetch MACROP of SNX) (* A macro--return either the associated skip-function
or NIL. (could be SNX instead of NIL, but who cares?))
(RETURN (AND [LITATOM (SETQ CHAR (fetch MACROFN of (\GETREADMACRODEF
CHAR FILERDTBL]
(GETPROP CHAR (QUOTE SKREAD]
(T (RETURN SNX]
(SETQ CHAR (\BIN OFD))
(SETQ SNX (\SYNCODE (fetch READSA of FILERDTBL)
CHAR))
(RETURN (COND
((EQ SNX ESCAPE.RC)
(AND (fetch ESCAPEFLG of FILERDTBL)
(\BIN OFD))
(* The effect is that the character following the %% is treated as what skreadc read, but special interpretation is
suppresed. We could read another character, e.g. when encountering %(FOO we could return with CHAR corresponding to
F, but if we were to do this, then we probaby should also have SKREADC simply filter out all non--breaks and
separators as well as handle escape characters. basically, feels better to have one call to skreadc correspond to
each character.)
OTHER.RC)
[(fetch MACROP of SNX) (* Macro)
(AND [LITATOM (SETQ CHAR (fetch MACROFN of (\GETREADMACRODEF CHAR FILERDTBL]
(GETPROP CHAR (QUOTE SKREAD]
(T SNX])
(SKSTRING
[LAMBDA (OFD) (* rmk: "18-SEP-80 16:41")
(until (EQ (SKREADC RRPTR OFD)
STRINGDELIM.RC])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: SKREAD SKREAD SKATOM SKBRACKET SKREADC SKSTRING)
]
(DEFINEQ
(FILEPOS
[LAMBDA (STR FILE START END SKIP TAIL CASEARRAY) (* bvm: "25-OCT-83 14:29")
(* NB this function now works on non-PAGEMAPPED files.
It must use only IO functions that respect that.)
(PROG ((SKIPCHAR (AND SKIP (CHCON1 SKIP)))
[CA (fetch (ARRAYP BASE) of (COND
[CASEARRAY (COND
((AND (ARRAYP CASEARRAY)
(EQ (fetch (ARRAYP TYP) of CASEARRAY)
\ST.BYTE))
CASEARRAY)
(T (CASEARRAY CASEARRAY]
(T \TRANSPARENT]
[OFD (\GETOFD (OR FILE (INPUT]
CHAR FIRSTCHAR STRBASE STRINDEX PATLEN PATINDEX ENDOFFSET ORGFILEPTR LASTINDEX STARTOFFSET
ENDOFFSET BIGENDOFFSET STARTSEG ENDSEG) (* calculate start addr and set file ptr.)
[SETQ STARTOFFSET (COND
(START (COND
((NOT (AND (FIXP START)
(IGEQ START 0)))
(LISPERROR "ILLEGAL ARG" START)))
(SETQ ORGFILEPTR (\GETFILEPTR OFD))
(\SETFILEPTR OFD START)
START)
(T (SETQ ORGFILEPTR (\GETFILEPTR OFD]
[COND
((LITATOM STR)
(SETQ STRBASE (fetch (LITATOM PNAMEBASE) of STR))
(SETQ STRINDEX 1)
(SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of STR)))
(T (OR (STRINGP STR)
(SETQ STR (MKSTRING STR)))
(SETQ STRBASE (fetch (STRINGP BASE) of STR))
(SETQ STRINDEX (fetch (STRINGP OFFST) of STR))
(SETQ PATLEN (fetch (STRINGP LENGTH) of STR]
(* calculate the character address of the character
after the last possible match.)
[SETQ ENDOFFSET (ADD1 (COND
((NULL END) (* Default is end of file)
(IDIFFERENCE (\GETEOFPTR OFD)
PATLEN))
((IGEQ END 0) (* Absolute byte pointer given)
(IMIN END (IDIFFERENCE (\GETEOFPTR OFD)
PATLEN)))
((IGREATERP PATLEN (IMINUS END))
(* END is too far, use eof less length)
(IDIFFERENCE (\GETEOFPTR OFD)
PATLEN))
(T (IDIFFERENCE (IPLUS (\GETEOFPTR OFD)
END 1)
PATLEN] (* use STARTOFFSET and ENDOFFSET instead of START and
END because vm functions shouldn't change their
arguments.)
(COND
((IGEQ STARTOFFSET ENDOFFSET) (* nothing to search)
(GO FAILED)))
(SETQ LASTINDEX PATLEN)
SKIPLP (* set the first character to FIRSTCHAR, handling
leading skips.)
(COND
((ZEROP LASTINDEX) (* null case)
(GO FOUNDIT))
((EQ (SETQ FIRSTCHAR (GETBASEBYTE CA (GETBASEBYTE STRBASE STRINDEX)))
SKIPCHAR) (* first character in pattern is skip.)
(SETQ LASTINDEX (SUB1 LASTINDEX))
(\BIN OFD) (* Move forward a character.)
(add STRINDEX 1)
(add STARTOFFSET 1)
(GO SKIPLP)))
(SETQ LASTINDEX (IPLUS LASTINDEX STRINDEX)) (* Used for end of pattern check, comparing against
current INDEX)
[COND
((SMALLP ENDOFFSET)
(SETQ STARTSEG (SETQ ENDSEG 0)))
(T
(* The search will be in the large integers at least part of the time, so split the start and end fileptrs into hi
and lo parts. The "segment" size we choose is smaller than 2↑16 so that we are still smallp near the boundary
(can get around that here by decrementing everyone, but can't in FFILEPOS). Note that STARTOFFSET and ENDOFFSET
are never actually used as file ptrs, just for counting.)
(SETQ ENDSEG (FOLDLO ENDOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ BIGENDOFFSET (MOD ENDOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ STARTSEG (FOLDLO STARTOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ STARTOFFSET (MOD STARTOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ ENDOFFSET (COND
((EQ STARTSEG ENDSEG)
BIGENDOFFSET)
(T
(* In different segments, so we'll have to search all the way to the end of this seg; hence, "end" is currently as
big as it gets)
FILEPOS.SEGMENT.SIZE]
FIRSTCHARLP
(* STARTOFFSET is the possible beginning of a match. the file ptr of the file is always at STARTOFFSET position
when the FIRSTCHAR loop is passed.)
(COND
[(EQ STARTOFFSET ENDOFFSET) (* end of this part of search)
(COND
((EQ STARTSEG ENDSEG) (* failed)
(GO FAILED))
(T (* Finished this segment, roll over into new one)
(add STARTSEG 1)
(SETQ STARTOFFSET 0) (* = STARTOFFSET-FILEPOS.SEGMENT.SIZE)
(COND
((EQ STARTSEG ENDSEG)
(COND
((ZEROP (SETQ ENDOFFSET BIGENDOFFSET))
(GO FAILED]
((NEQ FIRSTCHAR (GETBASEBYTE CA (\BIN OFD)))
(add STARTOFFSET 1)
(GO FIRSTCHARLP)))
(SETQ PATINDEX STRINDEX)
MATCHLP (* At this point, STR is matched thru offset PATINDEX)
(COND
((EQ (SETQ PATINDEX (ADD1 PATINDEX))
LASTINDEX) (* matched for entire length)
(GO FOUNDIT))
((OR (EQ (SETQ CHAR (GETBASEBYTE CA (GETBASEBYTE STRBASE PATINDEX)))
(GETBASEBYTE CA (\BIN OFD)))
(EQ CHAR SKIPCHAR)) (* Char from file matches char from STR)
(GO MATCHLP))
(T (* Match failed, so we have to start again with first
char)
(\SETFILEPTR OFD (IDIFFERENCE (\GETFILEPTR OFD)
(IDIFFERENCE PATINDEX STRINDEX)))
(* Back up over the chars we have just read in trying to match, less one. I.e. go back to one past the previous
starting point)
(add STARTOFFSET 1)
(GO FIRSTCHARLP)))
FOUNDIT (* set fileptr, adjust for beginning skips and return
proper value.)
[COND
((NOT TAIL) (* Fileptr wants to be at start of string)
(\SETFILEPTR OFD (IDIFFERENCE (\GETFILEPTR OFD)
PATLEN]
(RETURN (\GETFILEPTR OFD))
FAILED (* return the fileptr to its initial position.)
(\SETFILEPTR OFD ORGFILEPTR)
(RETURN NIL])
(FFILEPOS
[LAMBDA (PATTERN FILE START END SKIP TAIL CASEARRAY) (* jds "26-AUG-83 13:27")
(PROG ([OFD (\GETOFD (OR FILE (INPUT]
PATBASE PATOFFSET PATLEN ORGFILEPTR STARTOFFSET ENDOFFSET BIGENDOFFSET STARTSEG ENDSEG EOF)
(COND
(SKIP (* Slow case--use FILEPOS)
(GO TRYFILEPOS))
((NOT (fetch PAGEMAPPED of (fetch DEVICE OF OFD)))
(* This is a non-page-oriented file.
Use FILEPOS instead.)
(GO TRYFILEPOS))) (* calculate start addr and set file ptr.)
[COND
((LITATOM PATTERN)
(SETQ PATBASE (fetch (LITATOM PNAMEBASE) of PATTERN))
(SETQ PATOFFSET 1)
(SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of PATTERN)))
(T (OR (STRINGP PATTERN)
(SETQ PATTERN (MKSTRING PATTERN)))
(SETQ PATBASE (fetch (STRINGP BASE) of PATTERN))
(SETQ PATOFFSET (fetch (STRINGP OFFST) of PATTERN))
(SETQ PATLEN (fetch (STRINGP LENGTH) of PATTERN]
(COND
((OR (IGREATERP PATLEN \MAX.PATTERN.SIZE)
(ILESSP PATLEN \MIN.PATTERN.SIZE))
(GO TRYFILEPOS)))
(SETQ ORGFILEPTR (\GETFILEPTR OFD))
(SETQ STARTOFFSET (IPLUS (COND
(START (COND
((NOT (AND (FIXP START)
(IGEQ START 0)))
(LISPERROR "ILLEGAL ARG" START)))
START)
(T ORGFILEPTR))
(SUB1 PATLEN))) (* STARTOFFSET is the address of the character
corresponding to the last character of PATTERN.)
(SETQ EOF (\GETEOFPTR OFD)) (* calculate the character address of the character
after the last possible match.)
[SETQ ENDOFFSET (COND
((NULL END) (* Default is end of file)
EOF)
(T (IMIN (IPLUS (COND
((ILESSP END 0)
(IPLUS EOF END 1))
(T END))
PATLEN)
EOF] (* use STARTOFFSET and ENDOFFSET instead of START and
END because vm functions shouldn't change their
arguments.)
(COND
((IGEQ STARTOFFSET ENDOFFSET) (* nothing to search)
(RETURN))
((ILESSP (IDIFFERENCE ENDOFFSET STARTOFFSET)
\MIN.SEARCH.LENGTH) (* too small to make FFILEPOS worthwhile)
(GO TRYFILEPOS)))
(\SETFILEPTR OFD STARTOFFSET)
[RETURN (GLOBALRESOURCE
(\FFDELTA1 \FFDELTA2 \FFPATCHAR)
(PROG ([CASE (fetch (ARRAYP BASE)
of (COND
[CASEARRAY (COND
((AND (ARRAYP CASEARRAY)
(EQ (fetch (ARRAYP TYP) of CASEARRAY)
\ST.BYTE))
CASEARRAY)
(T (CASEARRAY CASEARRAY]
(T \TRANSPARENT]
(DELTA1 (fetch (ARRAYP BASE) of \FFDELTA1))
(DELTA2 (fetch (ARRAYP BASE) of \FFDELTA2))
(PATCHAR (fetch (ARRAYP BASE) of \FFPATCHAR))
(MAXPATINDEX (SUB1 PATLEN))
CHAR CURPATINDEX LASTCHAR INC)
(* Use Boyer-Moore string search algorithm. Use two auxiliary tables, DELTA1 and DELTA2, to tell how far ahead to
move in the file when a partial match fails. DELTA1 contains, for each character code, the distance of that
character from the right end of the pattern, or PATLEN if the character does not occur in the pattern.
DELTA2 contains, for each character position in the pattern, how far ahead to move such that the partial substring
discovered to the right of the position now matches some other substring (to the left) in the pattern.
PATCHAR is just PATTERN translated thru CASEARRAY)
(\SETUP.FFILEPOS PATBASE PATOFFSET PATLEN PATCHAR DELTA1 DELTA2 CASE)
[COND
((SMALLP ENDOFFSET)
(SETQ STARTSEG (SETQ ENDSEG 0)))
(T
(* The search will be in the large integers at least part of the time, so split the start and end fileptrs into hi
and lo parts. The "segment" size we choose is smaller than 2↑16 so that we are still smallp near the boundary.
Note that STARTOFFSET and ENDOFFSET are never actually used as file ptrs, just for counting.)
(SETQ ENDSEG (FOLDLO ENDOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ BIGENDOFFSET (MOD ENDOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ STARTSEG (FOLDLO STARTOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ STARTOFFSET (MOD STARTOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ ENDOFFSET (COND
((EQ STARTSEG ENDSEG)
BIGENDOFFSET)
(T
(* In different segments, so we'll have to search all the way to the end of this seg; hence, "end" is currently as
big as it gets)
FILEPOS.SEGMENT.SIZE]
(SETQ LASTCHAR (GETBASEBYTE PATCHAR MAXPATINDEX))
FIRSTCHARLP
(COND
[(IGEQ STARTOFFSET ENDOFFSET) (* End of this chunk)
(COND
((EQ STARTSEG ENDSEG) (* failed)
(GO FAILED))
(T (* Finished this segment, roll over into new one)
(add STARTSEG 1)
(SETQ STARTOFFSET (IDIFFERENCE STARTOFFSET FILEPOS.SEGMENT.SIZE))
(COND
((EQ STARTSEG ENDSEG)
(SETQ ENDOFFSET BIGENDOFFSET)))
(GO FIRSTCHARLP]
((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN OFD)))
LASTCHAR)
(add STARTOFFSET (SETQ INC (GETBASEBYTE DELTA1 CHAR)))
(OR (EQ INC 1)
(\INCFILEPTR OFD (SUB1 INC)))
(* advance file pointer accordingly
(\BIN already advanced it one))
(GO FIRSTCHARLP)))
(SETQ CURPATINDEX (SUB1 MAXPATINDEX))
MATCHLP
(COND
((ILESSP CURPATINDEX 0)
(GO FOUNDIT)))
(\DECFILEPTR OFD 2) (* back up to read previous char)
(COND
((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN OFD)))
(GETBASEBYTE PATCHAR CURPATINDEX))
(* Mismatch, advance by greater of delta1 and delta2)
(add STARTOFFSET (IDIFFERENCE (SETQ INC (IMAX (GETBASEBYTE DELTA1 CHAR)
(GETBASEBYTE DELTA2
CURPATINDEX)))
(IDIFFERENCE MAXPATINDEX CURPATINDEX)))
(OR (EQ INC 1)
(\INCFILEPTR OFD (SUB1 INC)))
(GO FIRSTCHARLP)))
(SETQ CURPATINDEX (SUB1 CURPATINDEX))
(GO MATCHLP)
FOUNDIT (* set fileptr, adjust for beginning skips and return
proper value.)
(\INCFILEPTR OFD (COND
(TAIL (* Put fileptr at end of string)
(SUB1 PATLEN))
(T (* back up over the last char we looked at, i.e. the
first char of string)
-1)))
(RETURN (\GETFILEPTR OFD))
FAILED (* return the fileptr to its initial position.)
(\SETFILEPTR OFD ORGFILEPTR)
(RETURN NIL]
TRYFILEPOS
(RETURN (FILEPOS PATTERN OFD START END SKIP TAIL CASEARRAY])
(\SETUP.FFILEPOS
[LAMBDA (PATBASE PATOFFSET PATLEN PATCHAR DELTA1 DELTA2 CASE)
(* bvm: " 2-JUN-81 14:13")
(* * Set up PATCHAR, DELTA1 and DELTA2 arrays from string. This is a separate function currently so I can gather
stats on it)
(PROG ((MAXPATINDEX (SUB1 PATLEN))
(PATLEN,PATLEN (IPLUS (LLSH PATLEN BITSPERBYTE)
PATLEN))
CHAR)
(for I from 0 to (FOLDLO \MAXCHAR BYTESPERWORD) do (PUTBASE DELTA1 I PATLEN,PATLEN))
(* DELTA1 initially all PATLEN, the default for chars
not in the pattern. I assume array is word-aligned)
(for I from 0 to MAXPATINDEX do [PUTBASEBYTE PATCHAR I (SETQ CHAR
(GETBASEBYTE CASE (GETBASEBYTE PATBASE
(IPLUS
PATOFFSET I]
(* Translate STR now so we don't have to do it
repeatedly)
(PUTBASEBYTE DELTA1 CHAR (IDIFFERENCE MAXPATINDEX I))
(* DELTA1 = how far ahead to move when we mismatch with
this char))
(* * Now set up DELTA2. Scan pattern backwards. For each character, we want to find the rightmost reoccurrence of
the substring consisting of the chars to the right of the current char. This is slightly different than Boyer-Moore,
in that we do not insist that it be the rightmost reoccurrence that is not preceded by the current char.
Small difference, noticeable only in patterns that contain multiple occurrences of tails of the pattern.
The following loop calculates DELTA2 in almost the obvious way, using the observation that DELTA2 is strictly
increasing (by our definition) as the pattern index decreases. This algorithm is potentially quadratic, as it
amounts to searching a string (PATTERN, backwards) for a given substring in the "dumb" way; fortunately, it is
rarely so in practice for "normal" patterns)
(for P from (SUB1 MAXPATINDEX) to 0 by -1 bind LASTD2←1
LASTMATCHPOS←MAXPATINDEX
do (PUTBASEBYTE DELTA2 P (SETQ LASTD2 (COND
([OR (IGEQ LASTD2 PATLEN)
(EQ (GETBASEBYTE PATCHAR (IDIFFERENCE MAXPATINDEX LASTD2))
(GETBASEBYTE PATCHAR (ADD1 P]
(* The last time around we matched a terminal substring somehow, and now the next char matches the char before that
substring, so DELTA2 is just one more, i.e. the match continues. Once we've overflowed the pattern, the "match"
continues trivially)
(ADD1 LASTD2))
(T [do (SETQ LASTMATCHPOS (SUB1 LASTMATCHPOS))
repeatuntil (for I from MAXPATINDEX to (ADD1 P) by -1
as J from LASTMATCHPOS to 0 by -1
always (EQ (GETBASEBYTE PATCHAR I)
(GETBASEBYTE PATCHAR J]
(* Substring from P+1 onward matches substring that ends
at LASTMATCHPOS)
(IPLUS (IDIFFERENCE MAXPATINDEX LASTMATCHPOS)
(IDIFFERENCE MAXPATINDEX P])
)
(RPAQQ \\FFDELTA1.GLOBALRESOURCE NIL)
(RPAQQ \\FFDELTA2.GLOBALRESOURCE NIL)
(RPAQQ \\FFPATCHAR.GLOBALRESOURCE NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
[PUTDEF (QUOTE \FFDELTA1)
(QUOTE GLOBALRESOURCES)
(QUOTE (NEW (ARRAY (ADD1 \MAXCHAR)
(QUOTE BYTE]
[PUTDEF (QUOTE \FFDELTA2)
(QUOTE GLOBALRESOURCES)
(QUOTE (NEW (ARRAY \MAX.PATTERN.SIZE (QUOTE BYTE]
[PUTDEF (QUOTE \FFPATCHAR)
(QUOTE GLOBALRESOURCES)
(QUOTE (NEW (ARRAY \MAX.PATTERN.SIZE (QUOTE BYTE]
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ \MAX.PATTERN.SIZE 128)
(RPAQQ \MIN.PATTERN.SIZE 3)
(RPAQQ FILEPOS.SEGMENT.SIZE 32768)
(RPAQQ \MIN.SEARCH.LENGTH 100)
(CONSTANTS (\MAX.PATTERN.SIZE 128)
(\MIN.PATTERN.SIZE 3)
(FILEPOS.SEGMENT.SIZE 32768)
(\MIN.SEARCH.LENGTH 100))
)
)
(* DATE)
(DEFINEQ
(DATE
[LAMBDA (FORMAT) (* bvm: " 2-NOV-80 16:10")
(\OUTDATE (\UNPACKDATE)
FORMAT])
(DATEFORMAT
[NLAMBDA FORMAT (* bvm: "21-NOV-83 17:54")
(CONS (QUOTE DATEFORMAT)
FORMAT])
(GDATE
[LAMBDA (DATE FORMAT STRPTR) (* bvm: " 6-DEC-80 16:55")
(\OUTDATE (\UNPACKDATE DATE)
FORMAT STRPTR])
(IDATE
(LAMBDA (STR) (* JonL " 7-May-84 03:18")
(DECLARE (SPECVARS POS STR))
(COND
((NULL STR)
(DAYTIME))
(T (PROG ((POS 1)
MONTH DAY YEAR HOUR MINUTES SECONDS N1 N2 CH)
(OR (SETQ N1 (\IDATESCANTOKEN))
(RETURN))
(SELCHARQ (NTHCHARCODE STR POS)
((/ - SPACE) (* Okay to put inside date)
(add POS 1))
NIL)
(OR (SETQ N2 (\IDATESCANTOKEN))
(RETURN))
(SELCHARQ (NTHCHARCODE STR POS)
((/ - SPACE ,)
(add POS 1))
NIL)
(OR (FIXP (SETQ YEAR (\IDATESCANTOKEN)))
(RETURN))
(COND
((ILESSP YEAR 100)
(add YEAR 1900))
((OR (ILESSP YEAR 1900)
(IGREATERP YEAR 2037))
(RETURN))) (* Now figure out day and month)
(COND
((FIXP N2) (* Must be month-day)
(SETQ DAY N2)
(SETQ MONTH N1))
(T (SETQ MONTH N2)
(SETQ DAY (OR (FIXP N1)
(RETURN)))))
(COND
((FIXP MONTH)
(COND
((OR (EQ 0 MONTH)
(IGREATERP MONTH 12))
(RETURN))))
(T (SETQ MONTH (SELECTQ MONTH
(JAN 1)
(FEB 2)
(MAR 3)
(APR 4)
(MAY 5)
(JUN 6)
(JUL 7)
(AUG 8)
(SEP 9)
(OCT 10)
(NOV 11)
(DEC 12)
(RETURN)))))
(COND
((OR (EQ 0 DAY)
(IGREATERP DAY (SELECTQ MONTH
((1 3 5 7 8 10 12)
31)
(2 (COND
((EQ 0 (IREMAINDER YEAR 4))
29)
(T 28)))
30)))
(RETURN))) (* Now scan time)
(OR (FIXP (SETQ HOUR (\IDATESCANTOKEN)))
(RETURN))
(COND
((EQ (SETQ CH (NTHCHARCODE STR POS))
(CHARCODE :))
(add POS 1)
(OR (FIXP (SETQ MINUTES (\IDATESCANTOKEN)))
(RETURN))
(COND
((EQ (SETQ CH (NTHCHARCODE STR POS))
(CHARCODE :))
(add POS 1)
(OR (FIXP (SETQ SECONDS (\IDATESCANTOKEN)))
(RETURN))
(SETQ CH (NTHCHARCODE STR POS)))))
(T (* break apart time given without colon)
(SETQ MINUTES (IREMAINDER HOUR 100))
(SETQ HOUR (IQUOTIENT HOUR 100))))
(COND
(CH (SELCHARQ CH
((A P a p) (* AM or PM appended)
(SELCHARQ (NTHCHARCODE STR (ADD1 POS))
((M m)
(SELCHARQ CH
((P p)
(COND
((ILESSP HOUR 12)
(add HOUR 12))))
(COND
((EQ HOUR 12)
(add HOUR -12))
((IGREATERP HOUR 12)
(RETURN)))))
NIL))
(SPACE)
(RETURN))))
(COND
((OR (IGREATERP HOUR 23)
(IGREATERP MINUTES 59)
(AND SECONDS (IGREATERP SECONDS 59)))
(RETURN)))
(RETURN (\PACKDATE YEAR (SUB1 MONTH)
DAY HOUR MINUTES (OR SECONDS 0))))))))
(\IDATESCANTOKEN
[LAMBDA NIL (* bvm: "26-OCT-82 14:36")
(DECLARE (USEDFREE STR POS)) (* Returns next token in STR, starting at POS.
Is either a number or word. Skips blanks)
(PROG (RESULT CH)
LP (SETQ CH (NTHCHARCODE STR POS))
(RETURN (COND
((NULL CH)
NIL)
((EQ CH (CHARCODE SPACE)) (* Skip leading spaces)
(add POS 1)
(GO LP))
((DIGITCHARP CH)
(SETQ RESULT (IDIFFERENCE CH (CHARCODE 0)))
[while (AND (SETQ CH (NTHCHARCODE STR (add POS 1)))
(DIGITCHARP CH))
do (SETQ RESULT (IPLUS (ITIMES RESULT 10)
(IDIFFERENCE CH (CHARCODE 0]
RESULT)
((ALPHACHARP CH)
(PACKC (CONS (UCASECODE CH)
(while (AND (SETQ CH (NTHCHARCODE STR (add POS 1)))
(ALPHACHARP CH))
collect (UCASECODE CH])
(\OUTDATE
[LAMBDA (UD FORMAT STRING) (* bvm: "22-Nov-83 12:39")
(PROG ((TIME (CDDDR UD))
(SEPR (CHARCODE -))
YEAR SIZE DAY MONTH S N NO.DATE NO.TIME NO.LEADING.SPACES TIME.ZONE TIME.ZONE.LENGTH
YEAR.LENGTH MONTH.LENGTH NO.SECONDS NUMBER.OF.MONTH YEAR.LONG)
[COND
((NOT FORMAT)
NIL)
((NEQ (CAR (LISTP FORMAT))
(QUOTE DATEFORMAT))
(LISPERROR "ILLEGAL ARG" FORMAT))
(T (for TOKEN in FORMAT do (SELECTQ TOKEN
(NO.DATE (SETQ NO.DATE T))
(NO.TIME (SETQ NO.TIME T))
(NUMBER.OF.MONTH (SETQ NUMBER.OF.MONTH T))
(YEAR.LONG (SETQ YEAR.LONG T))
(SLASHES (SETQ SEPR (CHARCODE /)))
(SPACES (SETQ SEPR (CHARCODE SPACE)))
(NO.LEADING.SPACES (SETQ NO.LEADING.SPACES T))
[TIME.ZONE (SETQ TIME.ZONE (CDR (ASSOC \TimeZoneComp
TIME.ZONES]
(NO.SECONDS (SETQ NO.SECONDS T))
NIL]
[SETQ SIZE (IPLUS (COND
(NO.DATE 0)
(T (IPLUS (SETQ YEAR.LENGTH (COND
((IGREATERP (SETQ YEAR (CAR UD))
1999)
(SETQ YEAR.LONG T)
4)
(YEAR.LONG 4)
(T (SETQ YEAR (IREMAINDER YEAR 100))
2)))
(COND
((AND (ILESSP (SETQ DAY (CADDR UD))
10)
NO.LEADING.SPACES)
1)
(T 2))
(PROGN (SETQ MONTH (ADD1 (CADR UD)))
(COND
[NUMBER.OF.MONTH (SETQ MONTH.LENGTH
(COND
((AND NO.LEADING.SPACES
(ILESSP MONTH 10))
1)
(T 2]
(T 3)))
2)))
(COND
(NO.TIME 0)
(T (IPLUS (COND
(NO.DATE 5)
(T 6))
(COND
(NO.SECONDS 0)
(T 3))
(COND
((NULL TIME.ZONE)
0)
((EQ (SETQ TIME.ZONE.LENGTH (NCHARS TIME.ZONE))
1)
4)
(T (ADD1 TIME.ZONE.LENGTH]
(SETQ S (ALLOCSTRING SIZE (CHARCODE SPACE)))
(COND
((NOT NO.DATE)
(\RPLRIGHT S (SETQ N (COND
((AND NO.LEADING.SPACES (ILESSP DAY 10))
1)
(T 2)))
DAY 1)
(RPLCHARCODE S (add N 1)
SEPR)
(COND
(NUMBER.OF.MONTH (\RPLRIGHT S (add N MONTH.LENGTH)
MONTH MONTH.LENGTH))
(T (RPLSTRING S (ADD1 N)
(CAR (NTH (QUOTE ("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep"
"Oct"
"Nov" "Dec"))
MONTH)))
(add N 3)))
(RPLCHARCODE S (add N 1)
SEPR)
(\RPLRIGHT S (add N YEAR.LENGTH)
YEAR 2)
(OR NO.TIME (add N 1)))
(T (SETQ N 0)))
[COND
((NOT NO.TIME)
(\RPLRIGHT S (IPLUS N 2)
(CAR TIME)
2)
(RPLCHARCODE S (IPLUS N 3)
(CHARCODE :))
(\RPLRIGHT S (add N 5)
(CADR TIME)
2)
(COND
((NOT NO.SECONDS)
(RPLCHARCODE S (ADD1 N)
(CHARCODE :))
(\RPLRIGHT S (add N 3)
(CADDR TIME)
2)))
(COND
(TIME.ZONE (RPLSTRING S (IPLUS N 2)
TIME.ZONE)
(COND
((EQ TIME.ZONE.LENGTH 1) (* Fill in daylight or standard)
(RPLSTRING S (IPLUS N 3)
(COND
((CADDDR TIME)
"DT")
(T "ST"]
(RETURN (COND
(STRING (SUBSTRING S 1 -1 STRING))
(T S])
(\RPLRIGHT
[LAMBDA (S AT N MINDIGITS) (* bvm: "21-NOV-83 17:19")
(RPLCHARCODE S AT (IPLUS (CHARCODE 0)
(IREMAINDER N 10)))
(COND
((OR (IGREATERP MINDIGITS 1)
(IGEQ N 10))
(\RPLRIGHT S (SUB1 AT)
(IQUOTIENT N 10)
(SUB1 MINDIGITS])
(\UNPACKDATE
[LAMBDA (D) (* bvm: "21-Nov-83 18:05")
(* Converts an internal Lisp date D into a list of integers (Year Month Day Hours Minutes Seconds daylightp). D
defaults to current date. -
-
D is first converted to the alto standard, a 32-bit unsigned integer, representing the number of seconds since jan
1, 1901-Gmt. We have to be a little tricky in our computations to avoid the sign bit.)
[SETQ D (LISP.TO.ALTO.DATE (OR D (DAYTIME]
(PROG ((DLS \DayLightSavings)
(DQ (IQUOTIENT (LRSH D 1)
30))
MONTH SEC HR DAY4 YDAY YEAR4 TOTALDAYS MIN) (* DQ is number of minutes since day 0, getting us past
the sign bit problem.)
(SETQ SEC (IDIFFERENCE D (LLSH (ITIMES DQ 30)
1)))
(SETQ MIN (IREMAINDER DQ 60))
(* No we can adjust to the current time zone. Since this might cause DQ to go negative, first add in 4 years worth
of hours, making the base date be Jan 1, 1897)
(SETQ HR (IREMAINDER (SETQ DQ (IDIFFERENCE (IPLUS (IQUOTIENT DQ 60)
(CONSTANT (ITIMES 24 \4YearsDays)))
\TimeZoneComp))
24))
(SETQ TOTALDAYS (IQUOTIENT DQ 24))
DTLOOP
(SETQ DAY4 (IREMAINDER TOTALDAYS \4YearsDays)) (* DAY4 = number of days since last leap year day 0)
[SETQ DAY4 (IPLUS DAY4 (CDR (\DTSCAN DAY4 (QUOTE ((789 . 3)
(424 . 2)
(59 . 1)
(0 . 0]
(* pretend every year is a leap year, adding one for
days after Feb 28)
(SETQ YEAR4 (IQUOTIENT TOTALDAYS \4YearsDays)) (* YEAR4 = number of years til that last leap year / 4)
(SETQ YDAY (IREMAINDER DAY4 366)) (* YDAY is the ordinal day in the year
(jan 1 = zero))
[COND
([AND DLS (SETQ DLS (\ISDST? YDAY HR (IREMAINDER (IPLUS TOTALDAYS 3)
7]
(* This date is during daylight savings, so add 1 hour. Third arg is day of the week, which we determine by taking
days mod 7 plus offset. Monday = zero in this scheme. Jan 1 1897 was actually a Friday (not Thursday=3), but we're
cheating--1900 was not a leap year)
(COND
((IGREATERP (SETQ HR (ADD1 HR))
23)
(* overflowed into the next day. This case is too hard (we might have overflowed the month, for example), so just
go back and recompute)
(SETQ TOTALDAYS (ADD1 TOTALDAYS))
(SETQ HR 0)
(SETQ DLS NIL)
(GO DTLOOP]
[SETQ MONTH (\DTSCAN YDAY (QUOTE ((335 . 11)
(305 . 10)
(274 . 9)
(244 . 8)
(213 . 7)
(182 . 6)
(152 . 5)
(121 . 4)
(91 . 3)
(60 . 2)
(31 . 1)
(0 . 0] (* Now return year, month, day, hr, min, sec)
(RETURN (LIST (IPLUS 1897 (ITIMES YEAR4 4)
(IQUOTIENT DAY4 366))
(CDR MONTH)
(ADD1 (IDIFFERENCE YDAY (CAR MONTH)))
HR MIN SEC DLS])
(\PACKDATE
(LAMBDA (YR MONTH DAY HR MIN SEC) (* JonL " 7-May-84 03:19")
(* Packs indicated date into a single integer in Lisp
date format. Returns NIL on errors.)
(PROG (YDAY DAYSSINCEDAY0)
(COND
((NOT (AND YR MONTH DAY HR MIN SEC (IGREATERP YR 1900)))
(RETURN)))
(RETURN
(ALTO.TO.LISP.DATE
(IPLUS
SEC
(LLSH
(ITIMES
30
(IPLUS MIN
(ITIMES 60
(IPLUS HR \TimeZoneComp
(ITIMES 24
(SETQ DAYSSINCEDAY0
(IPLUS (SETQ YDAY
(IPLUS (COND
((AND (IGREATERP MONTH 1)
(EQ 0 (IREMAINDER YR 4)))
(* After Feb 28 of a leap year)
1)
(T 0))
(SELECTQ MONTH
(0 0)
(1 31)
(2 59)
(3 90)
(4 120)
(5 151)
(6 181)
(7 212)
(8 243)
(9 273)
(10 304)
(11 334)
NIL)
(SUB1 DAY)))
(ITIMES 365 (SETQ YR (IDIFFERENCE YR 1901))
)
(IQUOTIENT YR 4))))
(COND
((AND \DayLightSavings (\ISDST? YDAY HR
(IREMAINDER (IPLUS
DAYSSINCEDAY0 1)
7)))
(* Subtract one to go from daylight to standard time. This time we computed weekday based on day 0 = Jan 1, 1901,
which was a Tuesday = 1)
-1)
(T 0))))))
1)))))))
(\DTSCAN
[LAMBDA (X L) (* lmm: 22 NOV 75 1438)
(PROG NIL
LP (COND
((IGREATERP (CAAR L)
X)
(SETQ L (CDR L))
(GO LP)))
(RETURN (CAR L])
(\ISDST?
[LAMBDA (YDAY HOUR WDAY) (* bvm: " 2-NOV-80 15:35")
(* Returns true if YDAY, HOUR is during the daylight
savings period. WDAY is day of week, zero = Monday.)
(AND (\CHECKDSTCHANGE YDAY HOUR WDAY \BeginDST)
(NOT (\CHECKDSTCHANGE YDAY HOUR WDAY \EndDST])
(\CHECKDSTCHANGE
[LAMBDA (YDAY HOUR WDAY DSTDAY) (* bvm: " 2-NOV-80 15:34")
(* Tests to see if YDAY, HOUR is after the start of daylight (or standard) time. WDAY is the day of the week,
Monday=zero. DSTDAY is the last day of the month in which time changes, as a YDAY, usually Apr 30 or Oct 31)
(COND
((IGREATERP YDAY DSTDAY) (* Day is in the next month already)
T)
((ILESSP YDAY (IDIFFERENCE DSTDAY 6)) (* day is at least a week before end of month, so time
hasn't changed yet)
NIL)
((EQ WDAY 6)
(* It's Sunday, so time changes today at 2am. Check for hour being past that. Note that there is a hopeless
ambiguity when the time is between 1:00 and 2:00 am the day that DST goes into effect, as that hour happens twice)
(IGREATERP HOUR 1))
(T (* okay if last Monday (YDAY-WDAY) is less than a week
before end of month)
(IGREATERP (IDIFFERENCE YDAY WDAY)
(IDIFFERENCE DSTDAY 6])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS DATEFORMAT DMACRO (X (KWOTE (CONS (QUOTE DATEFORMAT)
X))))
)
(RPAQ? \TimeZoneComp 8)
(RPAQ? \BeginDST 120)
(RPAQ? \EndDST 304)
(RPAQ? \DayLightSavings T)
(ADDTOVAR TIME.ZONES (8 . P)
(7 . M)
(6 . C)
(5 . E)
(0 . GMT))
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \TimeZoneComp \BeginDST \EndDST \DayLightSavings TIME.ZONES)
)
(DECLARE: EVAL@COMPILE
(RPAQ \4YearsDays (ADD1 (ITIMES 365 4)))
[CONSTANTS (\4YearsDays (ADD1 (ITIMES 365 4]
)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DATEFORMAT)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA PACK* CONCAT)
)
(PUTPROPS IOCHAR COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2046 5653 (CHCON 2056 . 2895) (UNPACK 2897 . 3775) (DCHCON 3777 . 4701) (DUNPACK 4703
. 5651)) (5654 14807 (UALPHORDER 5664 . 5811) (ALPHORDER 5813 . 7809) (PACKC 7811 . 8260) (CONCAT
8262 . 8841) (PACK 8843 . 9680) (PACK* 9682 . 10492) (STRPOS 10494 . 14805)) (14889 17707 (STRPOSL
14899 . 17149) (MAKEBITTABLE 17151 . 17705)) (17887 18578 (CASEARRAY 17897 . 18184) (UPPERCASEARRAY
18186 . 18576)) (18942 24616 (SKREAD 18952 . 21065) (SKATOM 21067 . 21618) (SKBRACKET 21620 . 22022) (
SKREADC 22024 . 24440) (SKSTRING 24442 . 24614)) (24724 42208 (FILEPOS 24734 . 31531) (FFILEPOS 31533
. 38903) (\SETUP.FFILEPOS 38905 . 42206)) (43034 57766 (DATE 43044 . 43196) (DATEFORMAT 43198 . 43346
) (GDATE 43348 . 43517) (IDATE 43519 . 46531) (\IDATESCANTOKEN 46533 . 47517) (\OUTDATE 47519 . 50847)
(\RPLRIGHT 50849 . 51160) (\UNPACKDATE 51162 . 54329) (\PACKDATE 54331 . 55988) (\DTSCAN 55990 .
56220) (\ISDST? 56222 . 56620) (\CHECKDSTCHANGE 56622 . 57764)))))
STOP