(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "INTERLISP")

(filecreated "16-Oct-86 17:19:48" {eris}<lispcore>sources>iochar.\;23
 100722 

      |changes| |to:|  (fns date dateformat gdate \\outdate)

      |previous| |date:| "12-Oct-86 15:34:10" {eris}<lispcore>sources>iochar.\;21)


; Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation.  All rights reserved.

(prettycomprint iocharcoms)

(rpaqq iocharcoms
 ((coms (fns chcon unpack dchcon dunpack)
                         (fns ualphorder alphorder packc concat pack pack* \\pack.item strpos)
                         (functions xcl:pack xcl:pack*)
                         (globalvars \\signflag \\printradix)
                         (declare\: dontcopy (macros \\catranslate)))
                   (coms (fns strposl makebittable)
                         (declare\: dontcopy (resources \\strposlarray))
                         (initresources \\strposlarray))
                   (coms (fns casearray uppercasearray)
                         (p (movd? 'seta 'setcasearray)
                            (movd? 'elt 'getcasearray))
                         (declare\: donteval@load docopy (vars (\\transparent (casearray))
                                                               (uppercasearray (uppercasearray))))
                         (declare\: eval@compile (prop globalvar uppercasearray)
                                dontcopy
                                (globalvars \\transparent)))
                   (coms (fns skread skbracket skreadc)
                         (blocks (skread skread skbracket skreadc)))
                   (coms (fns filepos ffilepos \\setup.ffilepos)
                         (declare\: eval@compile dontcopy (resources \\ffdelta1 \\ffdelta2 
                                                                 \\ffpatchar)
                                (constants (\\max.pattern.size 128)
                                       (\\min.pattern.size 3)
                                       (filepos.segment.size 32768)
                                       (\\min.search.length 100)))
                         (initresources \\ffdelta1 \\ffdelta2 \\ffpatchar))
                   (coms (* date)
                         (fns date dateformat gdate idate \\idatescantoken \\outdate \\rplright 
                              \\unpackdate \\packdate \\dtscan \\isdst? \\checkdstchange)
                         (optimizers 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)
                   (prop filetype iochar)
                   (declare\: donteval@load doeval@compile dontcopy compilervars
                          (addvars (nlama dateformat)
                                 (nlaml)
                                 (lama pack* concat)))))
(defineq

(chcon

  (lambda (x flg rdtbl)
                                      (* |bvm:| "24-Mar-86 16:29")

    (prog (base offst len \\chconlst \\chconlstail fatp)
          (cond
             (flg (go slowcase)))
          (selectc (ntypx x)
              (\\litatom (setq base (|ffetch| (litatom pnamebase)
                                           |of| x))
                         (setq offst 1)
                         (setq fatp (|ffetch| (litatom fatpnamep)
                                           |of| x))
                         (setq len (|ffetch| (litatom pnamelength)
                                          |of| x)))
              (\\stringp (setq base (|ffetch| (stringp base)
                                           |of| x))
                         (setq fatp (|ffetch| (stringp fatstringp)
                                           |of| x))
                         (setq offst (|ffetch| (stringp offst)
                                            |of| x))
                         (setq len (|ffetch| (stringp length)
                                          |of| x)))
              (go slowcase))
          (return (|for| i |from| offst |to| (iplus offst len -1)
                         |collect|
                         (\\getbasechar fatp base i)))
      slowcase
          (\\mappname (function (lambda (dummy code)         (* |Open| |code| collect)

                                  (cond
                                     (\\chconlstail (frplacd \\chconlstail (setq \\chconlstail
                                                                            (list code))))
                                     (t (setq \\chconlst (setq \\chconlstail (list code)))))))
                 x flg rdtbl)
          (return \\chconlst))))

(unpack

  (lambda (x flg rdtbl)
                                      (* |bvm:| "24-Mar-86 16:29")

    (prog (base offst len \\chconlst \\chconlstail fatp)
          (cond
             (flg (go slowcase)))
          (selectc (ntypx x)
              (\\litatom (setq base (|ffetch| (litatom pnamebase)
                                           |of| x))
                         (setq offst 1)
                         (setq fatp (|ffetch| (litatom fatpnamep)
                                           |of| x))
                         (setq len (|ffetch| (litatom pnamelength)
                                          |of| x)))
              (\\stringp (setq base (|ffetch| (stringp base)
                                           |of| x))
                         (setq offst (|ffetch| (stringp offst)
                                            |of| x))
                         (setq fatp (|ffetch| (stringp fatstringp)
                                           |of| x))
                         (setq len (|ffetch| (stringp length)
                                          |of| x)))
              (go slowcase))
          (return (|for| i |from| offst |to| (iplus offst len -1)
                         |collect|
                         (fcharacter (\\getbasechar fatp base i))))
      slowcase
          (\\mappname (function (lambda (dummy code)
                                  (setq code (fcharacter code))
                                                             (* |Open| |code| collect)

                                  (cond
                                     (\\chconlstail (frplacd \\chconlstail (setq \\chconlstail
                                                                            (list code))))
                                     (t (setq \\chconlst (setq \\chconlstail (list code)))))))
                 x flg rdtbl)
          (return \\chconlst))))

(dchcon

  (lambda (x scratchlist flg rdtbl)
                          (* |bvm:| "24-Mar-86 16:30")

    (scratchlist scratchlist (prog (base offst len fatp)
                                   (cond
                                      (flg (go slowcase)))
                                   (selectc (ntypx x)
                                       (\\litatom (setq base (|ffetch| (litatom pnamebase)
                                                                    |of| x))
                                                  (setq offst 1)
                                                  (setq fatp (|ffetch| (litatom fatpnamep)
                                                                    |of| x))
                                                  (setq len (|ffetch| (litatom pnamelength)
                                                                   |of| x)))
                                       (\\stringp (setq base (|ffetch| (stringp base)
                                                                    |of| x))
                                                  (setq offst (|ffetch| (stringp offst)
                                                                     |of| x))
                                                  (setq offst (|ffetch| (stringp offst)
                                                                     |of| x))
                                                  (setq len (|ffetch| (stringp length)
                                                                   |of| x)))
                                       (go slowcase))
                                   (return (|for| i |from| offst |to| (iplus offst len -1)
                                                  |do|
                                                  (addtoscratchlist (\\getbasechar fatp base i))))
                               slowcase
                                   (return (\\mappname (function (lambda (dummy code)
                                                                   (addtoscratchlist code)))
                                                  x flg rdtbl))))))

(dunpack

  (lambda (x scratchlist flg rdtbl)
                          (* |bvm:| "24-Mar-86 16:30")

    (scratchlist scratchlist (prog (base offst len fatp)
                                   (cond
                                      (flg (go slowcase)))
                                   (selectc (ntypx x)
                                       (\\litatom (setq base (|ffetch| (litatom pnamebase)
                                                                    |of| x))
                                                  (setq offst 1)
                                                  (setq fatp (|ffetch| (litatom fatpnamep)
                                                                    |of| x))
                                                  (setq len (|ffetch| (litatom pnamelength)
                                                                   |of| x)))
                                       (\\stringp (setq base (|ffetch| (stringp base)
                                                                    |of| x))
                                                  (setq offst (|ffetch| (stringp offst)
                                                                     |of| x))
                                                  (setq fatp (|ffetch| (stringp fatstringp)
                                                                    |of| x))
                                                  (setq len (|ffetch| (stringp length)
                                                                   |of| x)))
                                       (go slowcase))
                                   (return (|for| i |from| offst |to| (iplus offst len -1)
                                                  |do|
                                                  (addtoscratchlist (fcharacter (\\getbasechar fatp 
                                                                                       base i)))))
                               slowcase
                                   (return (\\mappname (function (lambda (dummy code)
                                                                   (addtoscratchlist (fcharacter
                                                                                      code))))
                                                  x flg rdtbl))))))
)
(defineq

(ualphorder

  (lambda (arg1 b)
                                           (* |rmk:| " 2-Apr-85 11:20")

    (alphorder
 arg1 b uppercasearray)))

(alphorder

  (lambda (a b casearray)
                                    (* |rmk:| "27-Mar-85 17:43")

    (declare (globalvars \\transparent))
    (prog (cabase abase alen aoffset afatp bbase blen boffset bfatp c1 c2)
          (cond
             ((litatom a)
              (setq abase (|ffetch| (litatom pnamebase)
                                 |of| a))
              (setq aoffset 1)
              (setq alen (|ffetch| (litatom pnamelength)
                                |of| a))
              (setq afatp (|ffetch| (litatom fatpnamep)
                                 |of| a)))
             ((stringp a)
              (setq abase (|ffetch| (stringp base)
                                 |of| a))
              (setq aoffset (|ffetch| (stringp offst)
                                   |of| a))
              (setq alen (|ffetch| (stringp length)
                                |of| a))
              (setq afatp (|ffetch| (stringp fatstringp)
                                 |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 (|ffetch| (litatom pnamebase)
                                 |of| b))
              (setq boffset 1)
              (setq blen (|ffetch| (litatom pnamelength)
                                |of| b))
              (setq bfatp (|ffetch| (litatom fatpnamep)
                                 |of| b)))
             ((stringp b)
              (setq bbase (|ffetch| (stringp base)
                                 |of| b))
              (setq boffset (|ffetch| (stringp offst)
                                   |of| b))
              (setq blen (|ffetch| (stringp length)
                                |of| b))
              (setq bfatp (|ffetch| (stringp fatstringp)
                                 |of| b)))
             (t                                              (* |Only| |numbers| |are| "less than" 

                                                             |atoms| |and| |strings|)

                (return (not (numberp b)))))
          (setq cabase (|fetch| (arrayp base)
                              |of|
                              (setq casearray (\\dtest (or casearray \\transparent)
                                                     'arrayp))))
          (return (|for| i (cafat _ (eq \\st.pos16 (|fetch| (arrayp typ)
                                                          |of| casearray)))
                         (casize _ (|fetch| (arrayp length)
                                          |of| casearray))
                         |from| 0 |do| (cond
                                          ((igeq i alen)
                                           (return (cond
                                                      ((eq alen blen)
                                                       'equal)
                                                      (t 'lessp))))
                                          ((igeq i blen)
                                           (return nil))
                                          ((eq (setq c1 (\\catranslate cabase casize cafat
                                                               (\\getbasechar afatp abase
                                                                      (iplus i aoffset))))
                                               (setq c2 (\\catranslate cabase casize cafat
                                                               (\\getbasechar bfatp bbase
                                                                      (iplus i boffset))))))
                                          ((ilessp c1 c2)
                                           (return 'lessp))
                                          (t                 (* "Greater")

                                             (return nil))))))))

(packc

  (lambda (x)
                                                (* |rmk:| "11-Apr-85 15:35")

          
          (* |Takes| |character| |codes| |in| x\, |stuffs| |them| |into| |the| 

          \\pnamestring\, |and| |then| |calls| \\mkatom)


    (with-resource (\\pnamestring)
           (bind (pbase _ (|ffetch| (stringp xbase)
                                 |of| \\pnamestring))
                 |for| n |from| 0 |as| c |in| x |do| (and (igreaterp n \\pnamelimit)
                                                          (lisperror "ATOM TOO LONG"))
                 (\\pnamestringputchar pbase n c)
                 |finally|
                 (return (\\mkatom pbase 0 n \\fatpnamestringp))))))

(concat

  (lambda n
                                                  (* |rmk:| "26-Mar-85 19:08")

    (prog ((j n)
           (len 0)
           (pos 1)
           s nm fatseenp)
      l1  (cond
             ((neq j 0)
              (cond
                 ((stringp (setq nm (arg n j)))
                  (or fatseenp (setq fatseenp (|ffetch| (stringp fatstringp)
                                                     |of| nm))))
                 ((litatom nm)
                  (or fatseenp (setq fatseenp (|ffetch| (litatom fatpnamep)
                                                     |of| nm))))
                 (t (setarg n j (setq nm (mkstring nm)))
                    (or fatseenp (setq fatseenp (|ffetch| (stringp fatstringp)
                                                       |of| nm)))))
              (setq len (iplus len (nchars nm)))
              (setq j (sub1 j))
              (go l1)))
          (setq s (allocstring len nil nil fatseenp))
      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)
                                                (* |bvm:| "27-Jun-85 13:10")

    (and x (nlistp x)
         (\\illegal.arg x))
    (declare (specvars n \\pnamestring))
    (with-resource (\\pnamestring)
           (prog ((n 1)
                  item)
             lp  (cond
                    ((null x)
                     (return (\\mkatom (|fetch| (stringp xbase)
                                              |of| \\pnamestring)
                                    0
                                    (sub1 n)
                                    \\fatpnamestringp))))
                 (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 (\\pack.item
 item)))
                 (setq x (listp (cdr x)))
                 (go lp)))))

(pack*

  (lambda u
                                                  (* |bvm:| "27-Jun-85 13:10")

    (declare (specvars n \\pnamestring))
    (with-resource (\\pnamestring)
           (prog ((n 1)
                  (m 1)
                  item)
             lp  (cond
                    ((igreaterp m u)
                     (return (\\mkatom (|fetch| (stringp xbase)
                                              |of| \\pnamestring)
                                    0
                                    (sub1 n)
                                    \\fatpnamestringp))))
                 (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 (\\pack.item
 item)))
                 (setq m (add1 m))
                 (go lp)))))

(\\pack.item

  (lambda (item)
                                             (* |bvm:| "24-Mar-86 16:30")

    (declare (usedfree n \\pnamestring))
          
          (* * |Slow| |case| |for| pack |and| pack* --

          |append| |characters| |of| item |to| \\pnamestring\, |updating| n |accordingly|)


    (\\mappname (function (lambda (dummy code)
                            (and (igreaterp n \\pnamelimit)
                                 (lisperror "ATOM TOO LONG"))
                            (\\pnamestringputchar (|fetch| (stringp base)
                                                         |of| \\pnamestring)
                                   (sub1 n)
                                   code)
                            (|add| n 1)))
           item)))

(strpos

  (lambda (pat string start skip anchor tail casearray backwardsflg)

                                                             (* |rmk:| "26-Mar-85 09:54")

    (declare (globalvars \\transparent))
    (prog (patlen patbase patoffst stringlen stringbase stringoffst maxi jmax |1stPATchar| 
                 |jthPATchar| strfat patfat)
          (|if| (litatom pat)
                |then|
                (setq patbase (|fetch| (litatom pnamebase)
                                     |of| pat))
                (setq patoffst 1)
                (setq patlen (|fetch| (litatom pnamelength)
                                    |of| pat))
                (setq patfat (fetch (litatom fatpnamep)
                                    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))
                (setq patfat (fetch (stringp fatstringp)
                                    of pat)))
          (|if| (litatom string)
                |then|
                (setq stringbase (|fetch| (litatom pnamebase)
                                        |of| string))
                (setq stringoffst 1)
                (setq stringlen (|fetch| (litatom pnamelength)
                                       |of| string))
                (setq strfat (fetch (litatom fatpnamep)
                                    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))
                (setq strfat (fetch (stringp fatstringp)
                                    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)
                          (or (eq \\st.byte (|fetch| (arrayp typ)
                                                   |of| casearray))
                              (eq \\st.pos16 (|fetch| (arrayp typ)
                                                    |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))
                         (cafat (eq \\st.pos16 (|fetch| (arrayp typ)
                                                      |of| casearray)))
                         (casize (|fetch| (arrayp length)
                                        |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)
                            (error "CASEARRAY can't be a sub-array: " casearray))
                        (setq |1stPATchar| (\\catranslate cabase casize cafat (\\getbasechar
                                                                               patfat 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| (\\catranslate cabase casize cafat
                                                               (\\getbasechar strfat stringbase 
                                                                      offst.i))))
                                   (|for| j |from| jstart |to| jmax |as| k |from| (add1 offst.i)
                                          |always|
                                          (or (eq skip (setq |jthPATchar|
                                                        (\\catranslate cabase casize cafat
                                                               (\\getbasechar patfat patbase j))))
                                              (eq |jthPATchar| (\\catranslate cabase casize cafat
                                                                      (\\getbasechar strfat 
                                                                             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|)

                    )))))
)
(cl:defun xcl:pack
 (names &optional (package *package*)) 

                                                  (* |;;;| "NAMES should be a list of symbols and strings.  A new symbol is created in the given package with a print name equal to the concatenation of the of the NAMES. ")

   (cl:intern (concatlist names)
          package))

(cl:defun xcl:pack*
 (&rest names) 
                (* |;;;| "NAMES should be a list of symbols and strings.  A new symbol is created in the current package with a print name equal to the concatenation of the of the NAMES. ")

   (cl:intern (concatlist names)))

(declare\: doeval@compile dontcopy

(globalvars \\signflag \\printradix)
)
(declare\: dontcopy 
(declare\: eval@compile 

(putprops \\catranslate macro (openlambda (cabase casize cafat char)
                                     (cond ((ileq char casize)
                                            (* i\f |it's| |in| |the| |table,| |use| |the| |table| 
                                               |value|)
                                            (\\getbasebyte cabase char))
                                           (t (* |Off| |the| |end| -- |assume| |it's| |itself|)
                                              char))))
)
)
(defineq

(strposl

  (lambda (a string start neg backwardsflg)
                  (* |edited:| "18-Mar-86 17:20")

          
          (* |Given| \a |list| |of| |charcodes,| a\, |find| |the| |first| |one| |in| 

          string.)


    (globalresource \\strposlarray (prog (base offst len i lasti strfat ch)
                                         (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)
                                               (setq strfat (|fetch| (litatom fatpnamep)
                                                                   |of| string))
                                               |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))
                                               (setq strfat (|fetch| (stringp fatstringp)
                                                                   |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 (\\getbasechar strfat base i)))
                                               |then|
                                               (return (idifference i offst)))
                                         (go lp)))))

(makebittable

  (lambda (l neg a)
                                          (* |edited:| "18-Mar-86 18:49")

    (cond
       ((|type?| chartable a)                                (* |Clear| |it|)

        (\\zerobytes a 0 \\maxthinchar)
        (|if| (|fetch| (chartable nscharhash)
                     |of| a)
              |then|
              (clrhash (|fetch| (chartable nscharhash)
                              |of| a))))
       (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))
)
(declare\: dontcopy 
(declare\: eval@compile 
(putdef '\\strposlarray 'resources '(new (ncreate 'chartable)))
)
)
(/settopval '\\\\strposlarray.globalresource)
(defineq

(casearray

  (lambda (oldar)
                                            (* |lmm| "20-MAR-81 10:21")

    (cond
       (oldar (copyarray oldar))
       (t (prog ((ar (array 256 'byte 0 0)))
                (|for| i |from| 0 |to| 255 |do| (seta ar i i))
                (return ar))))))

(uppercasearray

  (lambda nil
                                                (* |rmk:| " 2-Apr-85 11:22")

    (or (arrayp uppercasearray)
        (let ((ca (casearray
)))
             (|for| i |from| (charcode \a)
                    |to|
                    (charcode \z)
                    |do|
                    (setcasearray ca i (idifference i (constant (idifference (charcode \a)
                                                                       (charcode a))))))
             (setq uppercasearray ca)))))
)
(movd? 'seta 'setcasearray)
(movd? 'elt 'getcasearray)
(declare\: donteval@load docopy 

(rpaq \\transparent
 (casearray))

(rpaq uppercasearray
 (uppercasearray))
)
(declare\: eval@compile 

(putprops uppercasearray globalvar
 t)
dontcopy 
(declare\: doeval@compile dontcopy

(globalvars \\transparent)
)
)
(defineq

(skread

  (lambda (file rereadstring rdtbl)
                          (* |Pavel| "24-Sep-86 18:22")

    (declare (specvars rrptr rereadstring)
           (globalvars filerdtbl))
                (* \; 

                                      "RDTBL defaults to FILERDTBL;  not an argument in Interlisp-10")

    (prog (snx (strm (\\getstream file 'input))
               (rrptr (and rereadstring 1)))
          (cond
             ((\\intermp strm)                               (* |mainly| |because| |of| |the| 

                                                             |backfileptr|)

              (error "SKREAD NOT LEGAL FROM TTY" file)))
          (setq rdtbl (\\gtreadtable (or rdtbl filerdtbl)))
      top (setq snx (skreadc
 rrptr strm rdtbl))
      retry
          (return (selectc snx
                      (leftbracket.rc 
                           (skbracket
 strm rdtbl))
                      (rightbracket.rc 
                           '])
                      (leftparen.rc (prog ((parencount 1))
                                      prn (selectc (skreadc
 rrptr strm rdtbl)
                                              (leftbracket.rc 
                                                   (skbracket
 strm rdtbl))
                                              (rightbracket.rc 
                                                   (return ']))
                                              (leftparen.rc (|add| parencount 1))
                                              (rightparen.rc (cond
                                                                ((eq 0 (setq parencount (sub1 
                                                                                           parencount
                                                                                              )))
                                                                 (return))))
                                              (stringdelim.rc 
                                                   (|until| (eq stringdelim.rc (skreadc
 rrptr strm 
                                                                                      rdtbl))))
                                              nil)
                                          (go prn)))
                      (rightparen.rc '\))
                      (seprchar.rc (go top))
                      (breakchar.rc nil)
                      (stringdelim.rc 
                           (|until| (eq stringdelim.rc (skreadc
 rrptr strm rdtbl))))
                      (other.rc 
          
          (* |Only| |macros| |and| |others| |left.|

          i\f |necessary,| |the| |file| |will| |be| |backed| |up| |so| |that| |the| 

          |terminating| |character| |can| |be| |re-read|)


                                (|while| (eq other.rc (skreadc
 rrptr strm rdtbl)))
                                (or rrptr (\\backchar strm))
                                nil)
                      (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| (stream fullname)
                                                                         |of| strm)
                                                             rdtbl rereadstring))
                                   (go top)))
                         (rrptr 
          
          (* |Reading| |from| |the| |rereadstring| |and| \a |top| |level| macro |found.|

          |For| |right| |now,| |bomb| |out,| |fix| |it| |up| |later.|)


                                (|while| (eq other.rc (skreadc
 rrptr strm rdtbl))))
                         (t (\\backchar strm)
                            (read strm rdtbl)
                            nil)))))))

(skbracket

  (lambda (strm rdtbl)
                                       (* |rmk:| "26-Mar-85 21:36")

    (prog ((bracketcount 1))
      brkt
          (selectc (skreadc
 rrptr strm rdtbl)
              (leftbracket.rc 
                   (|add| bracketcount 1))
              (rightbracket.rc 
                   (cond
                      ((eq 0 (setq bracketcount (sub1 bracketcount)))
                       (return))))
              (stringdelim.rc 
                   (|until| (eq stringdelim.rc (skreadc
 rrptr strm rdtbl))))
              nil)
          (go brkt))))

(skreadc

  (lambda (userrptrflg strm rdtbl)
                           (* |rmk:| " 4-Apr-85 11:40")

          
          (* |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.|)


    (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| rdtbl)
                                             char))
                            escape.rc)
                        (and (|fetch| escapeflg |of| rdtbl)
                             (cond
                                ((null (nthcharcode rereadstring (prog1 rrptr (|add| rrptr 1))))
                                 (setq rrptr nil)
                                 (\\inccode strm))))         (* |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 rdtbl))))
                                     (getprop char 'skread))))
                       (t (return snx)))))
          (setq char (\\inccode strm))
          (setq snx (\\syncode (|fetch| readsa |of| rdtbl)
                           char))
          (return (cond
                     ((eq snx escape.rc)
                      (and (|fetch| escapeflg |of| rdtbl)
                           (\\inccode strm))
          
          (* |The| |effect| |is| |that| |the| |character| |following| |the| % |is| 

          |treated| |as| |what| |skreadc| |read,| |but| |special| |interpretation| |is| 

          |suppresed.| w\e |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 rdtbl)))
                                  )
                           (getprop char 'skread)))
                     (t snx))))))
)
(declare\: donteval@load doeval@compile dontcopy
(block\: skread skread skbracket skreadc)
)
(defineq

(filepos

  (lambda (str file start end skip tail casearray)
           (* |Pavel| "12-Oct-86 15:13")


                                                  (* |;;| "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))))
           (stream (\\getstream file 'input))
           char firstchar strbase strindex patlen patindex orgfileptr lastindex startbyte endbyte 
           bigendbyte startseg endseg)
          (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 start addr and set file ptr.")

          (setq startbyte (cond
                             (start (cond
                                       ((not (and (fixp start)
                                                  (igeq start 0)))
                                        (lisperror "ILLEGAL ARG" start)))
                                    (setq orgfileptr (\\getfileptr stream))
                                    (\\setfileptr stream start)
                                    start)
                             (t (setq orgfileptr (\\getfileptr stream)))))

                                                  (* \; 

                    "calculate the character address of the character after the last possible match.")

          (setq endbyte (add1 (cond
                                 ((null end)
                 (* \; "Default is end of file")

                                  (idifference (\\geteofptr stream)
                                         patlen))
                                 ((igeq end 0)
               (* \; "Absolute byte pointer given")

                                  (imin end (idifference (\\geteofptr stream)
                                                   patlen)))
                                 ((igreaterp patlen (iminus end))

                                                        (* \; "END is too far, use eof less length")

                                  (idifference (\\geteofptr stream)
                                         patlen))
                                 (t (idifference (iplus (\\geteofptr stream)
                                                        end 1)
                                           patlen)))))

                                                  (* |;;| "use STARTBYTE and ENDBYTE instead of START and END because vm functions shouldn't change their arguments.")

          (cond
             ((igeq startbyte endbyte)
                       (* \; "nothing to search")

              (go failed)))
          (setq lastindex patlen)
      skiplp
          
                                        (* \; 

                                      "set the first character to FIRSTCHAR, handling leading skips.")

          (cond
             ((eq lastindex 0)
                               (* \; "null case")

              (go foundit))
             ((eq (setq firstchar (\\getbasebyte ca (\\getbasebyte strbase strindex)))
                  skipchar)
                             (* \; "first character in pattern is skip.")

              (setq lastindex (sub1 lastindex))
              (\\bin stream)
                                 (* \; "Move forward a character.")

              (|add| strindex 1)
              (|add| startbyte 1)
              (go skiplp)))
          (setq lastindex (iplus lastindex strindex))

                                                  (* \; 

                                     "Used for end of pattern check, comparing against current INDEX")

          (cond
             ((smallp endbyte)
              (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 STARTBYTE and ENDBYTE are never actually used as file ptrs, just for counting.")

                (setq endseg (foldlo endbyte filepos.segment.size))
                (setq bigendbyte (imod endbyte filepos.segment.size))
                (setq startseg (foldlo startbyte filepos.segment.size))
                (setq startbyte (imod startbyte filepos.segment.size))
                (setq endbyte (cond
                                 ((eq startseg endseg)
                                  bigendbyte)
                                 (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
          
                                        (* |;;| "STARTBYTE is the possible beginning of a match.  the file ptr of the file is always at STARTBYTE position when the FIRSTCHAR loop is passed.")

          (cond
             ((eq startbyte endbyte)
                         (* \; "end of this part of search")

              (cond
                 ((eq startseg endseg)
                       (* \; "failed")

                  (go failed)))
                   (* \; 

                                                  "Finished this segment, roll over into new one")

              (setq startbyte 0)
                           (* \; "= STARTBYTE-FILEPOS.SEGMENT.SIZE")

              (cond
                 ((eq (|add| startseg 1)
                      endseg)
                     (* \; 

                        "Entering final segment, so set ENDBYTE to actual end instead of segment end")

                  (cond
                     ((eq (setq endbyte bigendbyte)
                          0)
                      (go failed)))))
              (go firstcharlp))
             ((neq firstchar (\\getbasebyte ca (\\bin stream)))
              (|add| startbyte 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 stream)))
                  (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 stream (idifference (\\getfileptr stream)
                                            (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| startbyte 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 stream (idifference (\\getfileptr stream)
                                          patlen))))
          (return (\\getfileptr stream))
      failed
          
                                        (* \; "return the fileptr to its initial position.")

          (\\setfileptr stream orgfileptr)
          (return nil))))

(ffilepos

  (lambda (pattern file start end skip tail casearray)
       (* |Pavel| "12-Oct-86 15:20")

    (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| (stream 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)

                                                             (* |jop:| "25-Sep-86 11:44")

          
          (* * |Set| |up| patchar\, delta1 |and| delta2 |arrays| |from| |string.|

          |This| |is| \a |separate| |function| |currently| |so| i |can| |gather| |stats| 

          |on| |it|)


    (prog ((patlen\,patlen (iplus (llsh patlen bitsperbyte)
                                  patlen))
           (maxpatindex (sub1 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))))))))))
)
(declare\: eval@compile dontcopy 
(declare\: eval@compile 
(putdef '\\ffdelta1 'resources '(new (array (add1 \\maxchar)
                                            'byte)))
(putdef '\\ffdelta2 'resources '(new (array \\max.pattern.size 'byte)))
(putdef '\\ffpatchar 'resources '(new (array \\max.pattern.size 'byte)))
)

(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))
)
)
(/settopval '\\\\ffdelta1.globalresource)
(/settopval '\\\\ffdelta2.globalresource)
(/settopval '\\\\ffpatchar.globalresource)



(* date)


(defineq

(date

  (lambda (format)
                                           (* |raf| "16-Oct-86 17:16")

    (\\outdate
 (\\unpackdate
)
           format)))

(dateformat

  (nlambda format
                                            (* |raf| "16-Oct-86 17:17")

    (cons 'dateformat format)))

(gdate

  (lambda (date
 format strptr)
                               (* |raf| "16-Oct-86 17:17")

    (\\outdate
 (\\unpackdate
 date)
           format strptr)))

(idate

  (lambda (str)
                                              (* |bvm:| "28-Jun-85 16:56")

    (declare (specvars pos str))
    (cond
       ((null str)
        (daytime))
       (t (prog ((pos 1)
                 month day year hour minutes seconds n1 n2 ch dls timezone)
                (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 -) 
                                 (cond
                                    ((setq timezone (\\idatescantoken
))
                                     (setq timezone
                                      (|for| x |in| time.zones |do|
                                             (cond
                                                ((eq (cdr x)
                                                     timezone)
                                                 (return (car x)))
                                                ((and (eq (nthchar timezone 1)
                                                          (cdr x))
                                                      (eq (nthchar timezone 3)
                                                          't))
                                                 (selectq (nthchar timezone 2)
                                                     (d      (* |Daylight| |time,| |subtract| 1 

                                                             |hour|)

                                                        (return (sub1 (car x))))
                                                     (s      (* |Standard| |time|)

                                                        (return (car x)))
                                                     nil))))))))
                            (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)
                               timezone)))))))

(\\idatescantoken

  (lambda nil
                                                (* |bvm:| "26-OCT-82 14:36")

    (declare (usedfree str pos))
          
          (* |Returns| |next| |token| |in| str\, |starting| |at| pos.

          i\s |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)
                                 (* |raf| "16-Oct-86 17:18")

    (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 day.of.week day.short)
          (cond
             ((not format)
              nil)
             ((neq (car (listp format))
                   '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))
                                                  (day.of.week (setq day.of.week t))
                                                  (day.short (setq day.short 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)))
                               (cond
                                  (day.of.week (setq day.of.week
                                                (car (nth '("Monday" "Tuesday" "Wednesday" "Thursday" 
                                                                  "Friday" "Saturday" "Sunday")
                                                          (add1 (car (cddddr time))))))
                                         (iplus 3 (setq day.short (cond
                                                                     (day.short (setq day.of.week
                                                                                 (substring 
                                                                                        day.of.week 1 
                                                                                        3))
                                                                            3)
                                                                     (t (nchars day.of.week))))))
                                  (t 0))
                               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 '("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))
              (cond
                 (day.of.week                                (* |Day| |of| |week| |at| |very| |end| 

                                                             |in| |parens|)

                        (rplcharcode s (sub1 (idifference size day.short))
                               (charcode "("))
                        (rplstring s (idifference size day.short)
                               day.of.week)
                        (rplcharcode s size (charcode ")")))))
             (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:| "28-Jun-85 18:07")

          
          (* |Converts| |an| |internal| |Lisp| |date| d |into| \a |list| |of| |integers|

          (|Year| |Month| |Day| |Hours| |Minutes| |Seconds| |daylightp| |DayOfWeek|)\.

          d |defaults| |to| |current| |date.| -

          |DayOfWeek| |is| |zero| |for| |Monday| -

          -

          d |is| |first| |converted| |to| |the| |alto| |standard,| \a |32-bit| |unsigned| 

          |integer,| |representing| |the| |number| |of| |seconds| |since| |jan| 1\, 

          |1901-Gmt.| w\e |have| |to| |be| \a |little| |tricky| |in| |our| |computations| 

          |to| |avoid| |the| |sign| |bit.|)


    (setq d (or d (daytime)))
    (prog ((checkdls |\\DayLightSavings|)
           (dq (iquotient (logand max.fixp (lrsh (lisp.to.alto.date d)
                                                 1))
                      30))
           month sec hr day4 yday wday year4 totaldays min dls)
          
          (* dq |is| |number| |of| |minutes| |since| |day| 0\, |getting| |us| |past| 

          |the| |sign| |bit| |problem.|)


          (setq sec (imod (iplus d (constant (idifference 60 (imod min.fixp 60))))
                          60))
          (setq min (iremainder dq 60))
          
          (* n\o |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 '((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|))

          (setq wday (iremainder (iplus totaldays 3)
                            7))
          (cond
             ((and checkdls (setq dls (\\isdst?
 yday hr wday)))
          
          (* |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 checkdls nil)
                  (go dtloop)))))
          (setq month (\\dtscan
 yday '((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 wday)))))

(\\packdate

  (lambda (yr month day hr min sec timezone)
                 (* |bvm:| "27-Jan-86 17:36")

          
          (* |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))
              (return)))
          (setq dayssinceday0 (iplus (setq yday (iplus (cond
                                                          ((and (igreaterp month 1)
                                                                (eq 0 (iremainder yr 4))
                                                                (neq yr 1900))
                                                             (* |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
             ((or (lessp dayssinceday0 -1)
                  (lessp (|add| hr (itimes 24 dayssinceday0)
                                (cond
                                   (timezone)
                                   ((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)


                                    (sub1 |\\TimeZoneComp|))
                                   (t |\\TimeZoneComp|)))
                         0))
          
          (* |Earlier| |than| |day| 0 -- |second| |check| |is| |needed| |because| |day| 0 

          |west| |of| gmt |is| |sometime| |during| |Dec| 31\, 1900)


              (return)))
          (return (iplus sec (progn 
          
          (* |Add| |the| |seconds| |to| |the| |converted| |date,| |rather| |than| |the| 

          |raw| |one,| |and| |use| llsh |instead| |of| |multiplying| |by| 60\, |to| 

          |avoid| |creating| \a |bignum|)


                                    (alto.to.lisp.date (llsh (itimes 30 (iplus min (itimes 60 hr)))
                                                             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))))))
)
(defoptimizer dateformat
 (&rest x) (kwote (cons '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

(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)
)

(putprops iochar filetype
 cl:compile-file)
(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 1985 1986))
(declare\: dontcopy
  (filemap (nil (3591 11766 (chcon 3601 . 5377) (unpack 5379 . 7286) (dchcon 7288 . 9423) (dunpack 9425
 . 11764)) (11767 28796 (ualphorder 11777 . 11934) (alphorder 11936 . 16264) (packc 16266 . 16990) (
concat 16992 . 18185) (pack 18187 . 19338) (pack* 19340 . 20468) (\\pack.item 20470 . 21257) (strpos 
21259 . 28794)) (30052 35831 (strposl 30062 . 34949) (makebittable 34951 . 35829)) (35992 36835 (
casearray 36002 . 36297) (uppercasearray 36299 . 36833)) (37153 45461 (skread 37163 . 41233) (
skbracket 41235 . 41827) (skreadc 41829 . 45459)) (45555 70758 (filepos 45565 . 54874) (ffilepos 54876
 . 66111) (\\setup.ffilepos 66113 . 70756)) (71537 99726 (date 71547 . 71712) (dateformat 71714 . 
71858) (gdate 71860 . 72042) (idate 72044 . 78845) (\\idatescantoken 78847 . 80280) (\\outdate 80282
 . 88367) (\\rplright 88369 . 88749) (\\unpackdate 88751 . 93732) (\\packdate 93734 . 97481) (\\dtscan
 97483 . 97760) (\\isdst? 97762 . 98178) (\\checkdstchange 98180 . 99724)))))
stop