(FILECREATED "11-DEC-82 22:04:16" <BLISP>IOCHAR.;169 49164
changes to: (FNS STRPOSL)
previous date: "26-OCT-82 16:16:19" <BLISP>IOCHAR.;168)
(* Copyright (c) 1981, 1982 by Xerox Corporation)
(PRETTYCOMPRINT IOCHARCOMS)
(RPAQQ IOCHARCOMS [(COMS (FNS CHCON UNPACK DCHCON DUNPACK)
(FNS ALPHORDER PACKC CONCAT PACK PACK* STRPOS)
(GLOBALVARS \SIGNFLAG \PRINTRADIX))
[COMS (FNS STRPOSL MAKEBITTABLE)
(GLOBALRESOURCES (\STRPOSLARRAY (create CHARTABLE]
(COMS (FNS SKREAD SKATOM SKBRACKET SKREADC SKSTRING)
(BLOCKS (SKREAD SKREAD SKATOM SKBRACKET SKREADC SKSTRING)))
[COMS (FNS FILEPOS FFILEPOS \SETUP.FFILEPOS CASEARRAY)
[DECLARE: DONTEVAL@LOAD DOCOPY (VARS (\TRANSPARENT (CASEARRAY]
(P (MOVD? (QUOTE SETA)
(QUOTE SETCASEARRAY)))
[GLOBALRESOURCES (\FFDELTA1 (ARRAY (ADD1 \MAXCHAR)
(QUOTE BYTE)))
(\FFDELTA2 (ARRAY \MAX.PATTERN.SIZE (QUOTE BYTE)))
(\FFPATCHAR (ARRAY \MAX.PATTERN.SIZE (QUOTE BYTE]
(DECLARE: EVAL@COMPILE DONTCOPY (GLOBALVARS \TRANSPARENT)
(CONSTANTS (\MAX.PATTERN.SIZE 128)
(\MIN.PATTERN.SIZE 3)
(FILEPOS.SEGMENT.SIZE 32768)
(\MIN.SEARCH.LENGTH 100]
[COMS (* DATE)
(FNS DATE GDATE IDATE \IDATESCANTOKEN \OUTDATE \RPLRIGHT \UNPACKDATE
\PACKDATE \DTSCAN \ISDST? \CHECKDSTCHANGE)
(GLOBALVARS \TimeZoneComp \BeginDST \EndDST \DayLightSavings)
(VARS (\TimeZoneComp 8)
(\BeginDST 120)
(\EndDST 304)
(\DayLightSavings T))
(DECLARE: DONTCOPY (CONSTANTS (\4YearsDays (ADD1 (ITIMES 365 4]
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(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
(ALPHORDER
[LAMBDA (A B) (* rrb "18-JUL-80 15:04")
(* ALPHORDER compares two items from a list being sorted, returns T if they are in order, i.e. if it is ok to place
A before B in the final list. Order of precedence is numbers, literals, and everything else.
Numbers are sorted by size; literals (strings, atoms and pnames) are sorted character by character by the magnitude
of the character code (straight alphabetization is a subset of this) and other types are not sorted among
themselves.)
(COND
[(NUMBERP A)
(OR (NOT (NUMBERP B))
(NOT (GREATERP A B]
((NUMBERP B)
NIL)
[(OR (LITATOM A)
(STRINGP A))
(OR (NOT (OR (STRINGP B)
(LITATOM B)))
(PROG ((I 1)
AC BC) (* both atoms or strings)
LP (COND
[(NULL (SETQ BC (NTHCHARCODE B I))) (* B ran out)
(RETURN (NULL (NTHCHARCODE A I]
((NULL (SETQ AC (NTHCHARCODE A I))) (* Same)
(RETURN T))
((IGREATERP BC AC)
(RETURN T))
((EQ BC AC)
(SETQ I (ADD1 I))
(GO LP))
(T (RETURN]
((OR (ATOM B)
(STRINGP B))
NIL)
(T T])
(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) (* rmk: " 1-MAY-82 22:00")
(OR (STRINGP PAT)
(LITATOM PAT)
(SETQ PAT (MKSTRING PAT)))
(OR (STRINGP STRING)
(LITATOM STRING)
(SETQ STRING (MKSTRING STRING)))
[COND
(SKIP (SETQ SKIP (CHCON1 SKIP]
(PROG ((NS (NCHARS STRING))
(NP (NCHARS PAT))
(P1 (CHCON1 PAT)))
[COND
((NOT START)
(SETQ START 1))
((ILESSP START 0)
(SETQ START (IPLUS START 1 NS]
(OR (AND (IGEQ START 0)
(ILEQ START NS))
(RETURN NIL))
(OR P1 (RETURN START))
(RETURN (for I from START to [COND
(ANCHOR START)
(T (IDIFFERENCE NS (SUB1 NP]
when [AND (OR (EQ P1 SKIP)
(EQ P1 (NTHCHARCODE STRING I)))
(bind PJ for J from 2 to NP as L from (ADD1 I)
always (OR (EQ (SETQ PJ (NTHCHARCODE PAT J))
SKIP)
(EQ PJ (NTHCHARCODE STRING L]
do (RETURN (COND
(TAIL (IPLUS I NP))
(T I])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \SIGNFLAG \PRINTRADIX)
)
(DEFINEQ
(STRPOSL
[LAMBDA (A STR START NEG) (* edited: "11-DEC-82 22:01")
(GLOBALRESOURCE \STRPOSLARRAY
[PROG [BASE OFFST LEN (TBL (COND
((type? CHARTABLE A)
A)
(T (MAKEBITTABLE A NIL \STRPOSLARRAY]
[COND
((LITATOM STR)
(SETQ BASE (fetch (LITATOM PNAMEBASE) of STR))
(SETQ LEN (fetch (LITATOM PNAMELENGTH) of STR))
(SETQ OFFST 1))
(T (OR (STRINGP STR)
(SETQ STR (MKSTRING STR)))
(SETQ BASE (fetch (STRINGP BASE) of STR))
(SETQ LEN (fetch (STRINGP LENGTH) of STR))
(SETQ OFFST (fetch (STRINGP OFFST) of STR]
[COND
((NULL START)
(SETQ START 1))
((IGREATERP 0 START)
(SETQ START (IPLUS START LEN 1] (* The various +/-1's can be eliminated by letting OFFST
be OFFST-1, but this looses similarity to other string
code.)
(RETURN (AND (IGREATERP START 0)
(ILEQ START LEN)
(for I (VAL ←(COND
(NEG 0)
(T 1)))
from (IPLUS OFFST (SUB1 START)) to (IPLUS LEN OFFST -1)
when (EQ VAL (\SYNCODE TBL (GETBASEBYTE BASE I)))
do (RETURN (ADD1 (IDIFFERENCE I OFFST))) finally (RETURN NIL])])
(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 NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \STRPOSLARRAY)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \STRPOSLARRAY)
(QUOTE GLOBALRESOURCES)
(QUOTE (create CHARTABLE)))
)
(DEFINEQ
(SKREAD
[LAMBDA (FILE REREADSTRING) (* rmk: " 9-DEC-80 21:40")
(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
((ZEROP (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) (* rmk: "18-SEP-80 16:40")
(PROG ((BRACKETCOUNT 1))
BRKT(SELECTC (SKREADC RRPTR OFD)
(LEFTBRACKET.RC (add BRACKETCOUNT 1))
[RIGHTBRACKET.RC (COND
((ZEROP (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: " 2-JUN-81 16:04")
(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))
(\INCFILEPTR OFD 1)
(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)
(SETQ ENDOFFSET BIGENDOFFSET]
((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)
(\DECFILEPTR 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)
(\DECFILEPTR 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) (* bvm: " 2-JUN-81 16:04")
(PROG ([OFD (\GETOFD (OR FILE (INPUT]
PATBASE PATOFFSET PATLEN ORGFILEPTR STARTOFFSET ENDOFFSET BIGENDOFFSET STARTSEG ENDSEG EOF)
(COND
(SKIP (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])
(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])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ \TRANSPARENT (CASEARRAY))
)
(MOVD? (QUOTE SETA)
(QUOTE SETCASEARRAY))
(RPAQQ \FFDELTA1 NIL)
(RPAQQ \FFDELTA2 NIL)
(RPAQQ \FFPATCHAR NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \FFDELTA1 \FFDELTA2 \FFPATCHAR)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
[PUTDEF (QUOTE \FFDELTA1)
(QUOTE GLOBALRESOURCES)
(QUOTE (ARRAY (ADD1 \MAXCHAR)
(QUOTE BYTE]
[PUTDEF (QUOTE \FFDELTA2)
(QUOTE GLOBALRESOURCES)
(QUOTE (ARRAY \MAX.PATTERN.SIZE (QUOTE BYTE]
[PUTDEF (QUOTE \FFPATCHAR)
(QUOTE GLOBALRESOURCES)
(QUOTE (ARRAY \MAX.PATTERN.SIZE (QUOTE BYTE]
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \TRANSPARENT)
)
(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])
(GDATE
[LAMBDA (DATE FORMAT STRPTR) (* bvm: " 6-DEC-80 16:55")
(\OUTDATE (\UNPACKDATE DATE)
FORMAT STRPTR])
(IDATE
[LAMBDA (STR) (* bvm: "26-OCT-82 16:15")
(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 (ZEROP 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 (ZEROP DAY)
(IGREATERP DAY (SELECTQ MONTH
((1 3 5 7 8 10 12)
31)
(2 (COND
((ZEROP (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 FMT STRING) (* bvm: "26-OCT-82 15:33")
(AND FMT (LISPERROR "ILLEGAL ARG" FMT))
(PROG ((TIME (CDDDR UD))
(YEAR (CAR UD))
SIZE S)
(SETQ SIZE (COND
((IGREATERP YEAR 1999)
20)
(T 18)))
[SETQ S (COND
((STRINGP STRING)
(SUBSTRING (QUOTE " ")
1 SIZE STRING))
(T (ALLOCSTRING SIZE]
(RPLSTRING S 1 (QUOTE " 0-XXX-00"))
(RPLSTRING S (IDIFFERENCE SIZE 8)
" 00:00:00")
(\RPLRIGHT S 2 (CADDR UD))
[RPLSTRING S 4
(CAR (NTH (QUOTE (JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC))
(ADD1 (CADR UD]
[\RPLRIGHT S (IDIFFERENCE SIZE 9)
(COND
((IGREATERP YEAR 1999)
YEAR)
(T (IREMAINDER YEAR 100]
(\RPLRIGHT S (IDIFFERENCE SIZE 6)
(CAR TIME))
(\RPLRIGHT S (IDIFFERENCE SIZE 3)
(CADR TIME))
(\RPLRIGHT S SIZE (CADDR TIME))
(RETURN S])
(\RPLRIGHT
[LAMBDA (S AT N) (* rmk: "25-MAY-80 23:00")
(RPLCHARCODE S AT (IPLUS (CHARCODE 0)
(IREMAINDER N 10)))
(OR (IGREATERP 10 N)
(\RPLRIGHT S (SUB1 AT)
(IQUOTIENT N 10])
(\UNPACKDATE
[LAMBDA (D) (* bvm: " 6-DEC-80 17:03")
(* Converts an internal Lisp date D into a list of integers (Year Month Day Hours Minutes Seconds). 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 (\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])
(\PACKDATE
[LAMBDA (YR MONTH DAY HR MIN SEC) (* bvm: " 6-DEC-80 17:04")
(* 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 2)
(ZEROP (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: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \TimeZoneComp \BeginDST \EndDST \DayLightSavings)
)
(RPAQQ \TimeZoneComp 8)
(RPAQQ \BeginDST 120)
(RPAQQ \EndDST 304)
(RPAQQ \DayLightSavings T)
(DECLARE: DONTCOPY
(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 )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA PACK* CONCAT)
)
(DECLARE: DONTCOPY (PUTPROPS IOCHAR COPYRIGHT ("Xerox Corporation" 1981 1982)))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1757 5364 (CHCON 1767 . 2606) (UNPACK 2608 . 3486) (DCHCON 3488 . 4412) (DUNPACK 4414
. 5362)) (5365 10363 (ALPHORDER 5375 . 6634) (PACKC 6636 . 7085) (CONCAT 7087 . 7666) (PACK 7668 .
8505) (PACK* 8507 . 9317) (STRPOS 9319 . 10361)) (10445 12298 (STRPOSL 10455 . 11740) (MAKEBITTABLE
11742 . 12296)) (12524 18181 (SKREAD 12534 . 14635) (SKATOM 14637 . 15188) (SKBRACKET 15190 . 15587) (
SKREADC 15589 . 18005) (SKSTRING 18007 . 18179)) (18289 35291 (FILEPOS 18299 . 24703) (FFILEPOS 24705
. 31697) (\SETUP.FFILEPOS 31699 . 35000) (CASEARRAY 35002 . 35289)) (36339 48504 (DATE 36349 . 36501)
(GDATE 36503 . 36672) (IDATE 36674 . 39655) (\IDATESCANTOKEN 39657 . 40641) (\OUTDATE 40643 . 41693)
(\RPLRIGHT 41695 . 41946) (\UNPACKDATE 41948 . 45083) (\PACKDATE 45085 . 46726) (\DTSCAN 46728 . 46958
) (\ISDST? 46960 . 47358) (\CHECKDSTCHANGE 47360 . 48502)))))
STOP