perm filename DICT[DEN,LMM] blob sn#070833 filedate 1973-11-07 generic text, type T, neo UTF8
(FILECREATED " 7-NOV-73  5:23:59" S-DICT)


  (LISPXPRINT (QUOTE DICTVARS)
              T)
  [RPAQQ DICTVARS
         ((* Dictionary creation - Really needs work to make sure 
             interfaces with advising, breaking, etc will all work)
          (FNS ENTER LOOKUP MAKTAB WRITESOME PUSHCAR WRITEALL 
               WRITEDICT WRITESOME1)
          (VARS (DICTIONARYLST)
                (CHANGEDICTLST))
          (ADDVARS (PRETTYTYPELST (CHANGEDICTLST NIL "dictionaries")))
          (P (ADVISE (QUOTE CLEANUP)
                     (QUOTE BEFORE)
                     (QUOTE (WRITEDICT)))
             (SETQ ADVISEDFNS (/DREMOVE (QUOTE CLEANUP)
                                        ADVISEDFNS)))
          (BLOCKS (DICTBLOCK ENTER LOOKUP MAKTAB WRITESOME PUSHCAR 
                             WRITEALL WRITEDICT WRITESOME1
                             (ENTRIES ENTER LOOKUP MAKTAB WRITEALL 
                                      WRITEDICT)
                             (GLOBALVARS DICTIONARYLST CHANGEDICTLST)
                             (LOCALFREEVARS DICT]

(* Dictionary creation - Really needs work to make sure interfaces
with advising, breaking, etc will all work)

(DEFINEQ

(ENTER
  [LAMBDA (PTR DICT VAL)

          (* ENTER value into dictionary -
          VAL is the value, PTR is the return from LOOKUP 
          (which should be (LIST ARGS)) and DICT is the 
          dictionary in which PTR is contained 
          (needed to get the file name, and the number in 
          core verses the max in core allowed))


    (OR (LISTP DICT)
        (ERROR "BAD DICTIONARY" "GIVEN TO ENTER"))
    (FRPLACA (CDR DICT)
             (ADD1 (CADR DICT)))                (* Bump the incore 
                                                counter)
    (FRPLACD PTR (CONS NIL VAL))
    (FRPLACA (QUOTE CHANGEDICTLST)
             DICTIONARYLST)
    (WRITESOME DICT)
    VAL])

(LOOKUP
  [LAMBDA (INDEX DICT NOENTER)

          (* Lookup INDEX on the dictionary DICT -
          Unless NOENTER is on, insert empty marker and 
          return it if INDEX isn't found)


    (OR (LISTP DICT)
        (ERROR "LOOKUP GIVEN" "EMPTY DICTIONARY"))
    (PROG ((FND (SASSOC INDEX (CDDDR DICT)))
           FIL)                                 (* Use SACCOC to find 
                                                entry, if any)
          (COND
            ((NOT FND)
              (AND NOENTER (RETURN))            (* If no entry, just 
                                                insert empty entry in 
                                                the dictionary and 
                                                return)
              (SETQ FND (LIST INDEX))
              (FRPLACD (CDDR DICT)
                       (CONS FND (CDDDR DICT)))
              (RETURN FND)))
          [PUSHCAR (CDDR DICT)
                   (NLEFT (CDDR DICT)
                          1
                          (FMEMB FND (CDDDR DICT]
                                                (* Move the found 
                                                entry to the front of 
                                                the dictionary)
          (COND
            ((NULL (CDR FND))

          (* If no file pointer, then this was an empty 
          entry (only possible for an aborted computation))


              (RETURN FND))
            ((NULL (CDDR FND))
              (COND
                ((NULL (CADR FND))

          (* No value, no ptr, but a ptr place -- this is a 
          funny situation again, but might happen if abort 
          occurs)


                  (FRPLACD FND NIL)
                  (RETURN FND)))

          (* Read in from file, bump incore counter, and 
          check if too many incore, writing outsome;
          then return the value)


              (SFPTR [SETQ FIL (OR (OPENP (CAR DICT))
                                   (IOFILE (CAR DICT]
                     (CADR FND))
              (FRPLACD (CDR FND)
                       (READ FIL))
              (FRPLACA (CDR DICT)
                       (ADD1 (CADR DICT)))
              (WRITESOME DICT)                  (* Check if need to 
                                                bump some out)
              (RETURN FND))
            (T                                  (* It's already in 
                                                core)
               (RETURN FND])

(MAKTAB
  [LAMBDA (FN MAXCORE FILE)

          (* Fix up FN so that it uses a dictionary called 
          FILE (which is also the file name that it uses) -
          If FILE is NIL, use the FN name -
          MAXCORE is the maximum number of dictionary 
          entries that can reside in core -
          If FN is NIL, just create the dictionary, but 
          don't ADVISE any function)


    (PROG (VARS TEM)
          (OR FN FILE (ERROR "NO NAME FOR THIS" "DICTIONARY"))
          (SETQ TEM (NAMEFIELD (OR FN FILE)))
          [OR FILE (SETQ FILE (PACK (LIST TEM (QUOTE ".DICT"]
          (COND
            ((MEMB FILE DICTIONARYLST)
              (ERROR FILE "ALREADY IS A DICTIONARY")))
          (COND
            (FN [COND
                  ((CDR (SETQ VARS (ARGLIST FN)))
                    (SETQ VARS (CONS (QUOTE LIST)
                                     VARS)))
                  (T (SETQ VARS (CAR VARS]

          (* VARS will be the expression that is to be 
          looked up -
          Usually (LIST <ARGLIST FN>) but if there is only 
          one ARG to FN, will use it alone)


                (VIRGINFN FN T)

          (* The function will look like -
          (tem← (LOOKUP <ARGS> <DICT>)) 
          (if (CDR TEM) then (RETURN 
          (CDDR TEM)) else <compute function> 
          (ENTER TEM FN !VALUE)))


                [ADVISE FN (QUOTE BIND)
                        (LIST (LIST (QUOTE TEM)
                                    (LIST (QUOTE LOOKUP)
                                          VARS FILE]
                [ADVISE FN (QUOTE BEFORE)
                        (QUOTE (COND
                                 ((CDR TEM)
                                   (RETURN (CDDR TEM]
                [ADVISE FN (QUOTE AFTER)
                        (LIST (QUOTE COND)
                              (LIST (QUOTE (NULL (CDR TEM)))
                                    (LIST (QUOTE ENTER)
                                          (QUOTE TEM)
                                          FILE
                                          (QUOTE !VALUE]
                (/PUT FN (QUOTE DICTIONARY)
                      FILE)))                   (* Open FILE, and set 
                                                up incore dictionary)
          [/SET FILE (COND
                  ([INFILEP (SETQ TEM (PACK (LIST TEM ".INDEX"]
                    (READFILE TEM))
                  (T (LIST (IOFILE (OR (INFILEP FILE)
                                       (OUTFILEP FILE)))
                           0
                           (OR MAXCORE 10]
          (/PUT FILE (QUOTE INDEX)
                TEM)
          (/RPLACA (QUOTE DICTIONARYLST)
                   (CONS FILE DICTIONARYLST])

(WRITESOME
  [LAMBDA (DICT CNT)

          (* If the number of incore entries exceeds the max 
          incore entries, look for the first incore entry 
          that is followed by one not in core -
          Delete the incore value (writing it out if it's 
          not already on file), and decrement the incore 
          counter)


    (AND [NOT (ILESSP (CADR DICT)
                      (OR CNT (CADDR DICT]
         (WRITESOME1 (CDDDR DICT))
         (FRPLACA (CDR DICT)
                  (SUB1 (CADR DICT])

(PUSHCAR
  [LAMBDA (L1 L2)

          (* PUSH (CADR L2) after (CAR L1) -
          L2 is a tail of L1 -
          Sort of complicated)


    (OR (EQ L1 L2)
        (PROG (TEM)
              (SETQ TEM (CDR L1))
              (FRPLACD L1 (CDR L2))
              (FRPLACD L2 (CDDR L2))
              (FRPLACD (CDR L1)
                       TEM])

(WRITEALL
  [LAMBDA (DICT)
    (WHILE (WRITESOME DICT 0) DO NIL])

(WRITEDICT
  [LAMBDA (FILE)
    (COND
      [(NULL FILE)
        (COND
          ((AND CHANGEDICTLST DICTIONARYLST)
            (LISPXPRIN1 "writing dictionaries:
" T)
            [MAPC DICTIONARYLST (FUNCTION (LAMBDA (FILE)
                      (LISPXPRINT (WRITEDICT FILE)
                                  T]
            (SETQ CHANGEDICTLST]
      ((MEMB FILE DICTIONARYLST)
        (WRITEALL (CAR FILE))
        [WRITEFILE (CAR FILE)
                   (OR (GETP FILE (QUOTE INDEX))
                       (PACK (LIST (NAMEFIELD FILE)
                                   (QUOTE .INDEX]
        FILE)
      [(PROG [(TEM (GETP FILE (QUOTE DICTIONARY]
             (COND
               (TEM (WRITEDICT TEM]
      (T (ERROR FILE "is not a dictionary"])

(WRITESOME1
  [LAMBDA (DICTL)

          (* Tries to write out the last possible DICT 
          element -
          Should be the one referenced least recently)


    (COND
      ((NULL DICTL)                             (* End of list, back 
                                                up)
        NIL)
      ((WRITESOME1 (CDR DICTL))                 (* First try on CDR, 
                                                if sucessful, return)
        T)
      ((CDDR (CAR DICTL))                       (* This is the last 
                                                entry that has a value
                                                in it)
        [COND
          ((NULL (CADAR DICTL))

          (* If it hasn't been written out on a file, the 
          ptr field will be NIL)


            (PROG (POS (FIL (CAR DICT)))        (* Get the file name 
                                                from DICT)
                  (SFPTR (SETQ FIL (OR (OPENP FIL (QUOTE OUTPUT))
                                       (IOFILE FIL)))
                         -1)                    (* Set file pointer to
                                                end of file)
                  (SETQ POS (SFPTR FIL))

          (* And save the pointer so that it can be entered 
          into the DICT)


                  (PRINT (CDDR (CAR DICTL))
                         FIL)                   (* Write out value on 
                                                the file)
                  (FRPLACA (CDAR DICTL)
                           POS)                 (* Insert file pointer
                                                in dictionary)
              ]
        (FRPLACD (CDR (CAR DICTL))
                 NIL])
)
  (RPAQ DICTIONARYLST)
  (RPAQ CHANGEDICTLST)
  (ADDTOVAR PRETTYTYPELST (CHANGEDICTLST NIL "dictionaries"))
  (ADVISE (QUOTE CLEANUP)
          (QUOTE BEFORE)
          (QUOTE (WRITEDICT)))
  (SETQ ADVISEDFNS (/DREMOVE (QUOTE CLEANUP)
                             ADVISEDFNS))
(DECLARE
  (BLOCK: DICTBLOCK ENTER LOOKUP MAKTAB WRITESOME PUSHCAR WRITEALL 
          WRITEDICT WRITESOME1 (ENTRIES ENTER LOOKUP MAKTAB WRITEALL 
                                        WRITEDICT)
          (GLOBALVARS DICTIONARYLST CHANGEDICTLST)
          (LOCALFREEVARS DICT))
)STOP