too.l

A very small LISP implementation with several packages and demo programs.

# 21oct07abu
# (c) Software Lab. Alexander Burger

### DB Garbage Collection ###
(de dbgc ()
   (markExt *DB)
   (let Cnt 0
      (finally (mark 0)
         (for (F . @) (or *Dbs (2))
            (for (S (seq F)  S  (seq S))
               (unless (mark S)
                  (inc 'Cnt)
                  (and (isa '+Entity S) (zap> S))
                  (zap S) ) ) ) )
      (commit)
      (when *Blob
         (use (@S @R F S)
            (let Pat (conc (chop *Blob) '(@S "." @R))
               (in (list 'find *Blob "-type" "f")
                  (while (setq F (line))
                     (when (match Pat F)
                        (unless
                           (and
                              (setq S (extern (pack (replace @S '/))))
                              (get S (intern (pack @R))) )
                           (inc 'Cnt)
                           (call 'rm (pack F)) )
                        (wipe S) ) ) ) ) ) )
      (gt0 Cnt) ) )

(de markExt (S)
   (unless (mark S T)
      (markData (val S))
      (maps markData S)
      (wipe S) ) )

(de markData (X)
   (while (pair X)
      (markData (pop 'X)) )
   (and (ext? X) (markExt X)) )


### DB Mapping ###
(de dbMap ("ObjFun" "TreeFun")
   (default "TreeFun" quote)
   (finally (mark 0)
      (_dbMap *DB)
      (dbMapT *DB) ) )

(de _dbMap ("Hook")
   (unless (mark "Hook" T)
      ("ObjFun" "Hook")
      (for "X" (getl "Hook")
         (when (pair "X")
            (if
               (and
                  (ext? (car "X"))
                  (not (isa '+Entity (car "X")))
                  (sym? (cdr "X"))
                  (find
                     '(("X") (isa '+Relation (car "X")))
                     (getl (cdr "X")) ) )
               (let ("Base" (car "X")  "Cls" (cdr "X"))
                  (dbMapT "Base")
                  (for "X" (getl "Base")
                     (when
                        (and
                           (pair "X")
                           (sym? (cdr "X"))
                           (pair (car "X"))
                           (num? (caar "X"))
                           (ext? (cdar "X")) )
                        ("TreeFun" "Base" (car "X") (cdr "X") "Cls" "Hook")
                        (iter (tree (cdr "X") "Cls" "Hook") _dbMap) ) )
                  (wipe "Base") )
               (dbMapV (car "X")) ) ) )
      (wipe "Hook") ) )

(de dbMapT ("Base")
   (let "X" (val "Base")
      (when
         (and
            (pair "X")
            (num? (car "X"))
            (ext? (cdr "X")) )
         ("TreeFun" "Base" "X")
         (iter "Base" dbMapV) ) ) )

(de dbMapV ("X")
   (while (pair "X")
      (dbMapV (pop '"X")) )
   (and (ext? "X") (_dbMap "X")) )


### DB Check ###
(de dbCheck ()
   # Lock whole database
   (and (lock) (quit 'lock @))
   # Low-level integrity check
   (for (F . N) (or *Dbs (2))
      (unless (pair (println F N (dbck F T)))
         (quit 'dbck @) ) )
   # Check tree structures
   (dbMap
      quote
      '((Base Root Var Cls Hook)
         (println Base Root Var Cls Hook)
         (unless (= (car Root) (chkTree (cdr Root)))
            (quit "Tree size mismatch") )
         (when Var
            (scan (tree Var Cls Hook)
               '((K V)
                  (or
                     (isa Cls V)
                     (isa '+Alt (meta V Var))
                     (quit "Bad Type" V) )
                  (unless (has> V Var (if (pair K) (car K) K))
                     (quit "Bad Value" K) ) )
               NIL T T ) ) ) )
   # Check DB file assignments
   (and *Dbs (dbfCheck))
   # Show dangling index references
   (when (dangling)
      (prin "### ")
      (println 'dangling @) )
   T )

(de dangling ()
   (make
      (dbMap
         '((This)
            (and
               (not (: T))
               (dangle This)
               (link @) ) ) ) ) )

# Check Index References
(de dangle (Obj)
   (and
      (make
         (for X (getl Obj)
            (let V (or (atom X) (pop 'X))
               (with (meta Obj X)
                  (and
                     (isa '+Fold This)
                     (setq V
                        (if (pair V)
                           (mapcar fold V)
                           (fold V) ) ) )
                  (cond
                     ((isa '+Joint This)
                        (if (isa '+List This)
                           (when
                              (find
                                 '((Y)
                                    (if (atom (setq Y (get Y (: slot))))
                                       (n== Obj Y)
                                       (not (memq Obj Y)) ) )
                                 V )
                              (link X) )
                           (let Y (get V (: slot))
                              (if (atom Y)
                                 (unless (== Obj Y) (link X))
                                 (unless (memq Obj Y) (link X)) ) ) ) )
                     ((isa '+Key This)
                        (and
                           (<> Obj
                              (fetch
                                 (tree X (: cls) (get Obj (: hook)))
                                 V ) )
                           (link X) ) )
                     ((isa '+Ref This)
                        (let
                           (Tree (tree X (: cls) (get Obj (: hook)))
                              Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) )
                           (if (isa '+List This)
                              (or
                                 (find
                                    '((Y) (fetch Tree (cons Y Aux)))
                                    V )
                                 (link X) )
                              (and
                                 (<> Obj (fetch Tree (cons V Aux)))
                                 (link X) ) ) ) )
                     (T
                        (for B (: bag)
                           (cond
                              ((isa '+Key B)
                                 (let N (index B (: bag))
                                    (with B
                                       (when
                                          (find
                                             '((L)
                                                (and
                                                   (get L N)
                                                   (<> Obj
                                                      (fetch
                                                         (tree (: var) (: cls)
                                                            (get
                                                               (if (sym? (: hook)) Obj L)
                                                               (: hook) ) )
                                                         (get L N) ) ) ) )
                                                V )
                                             (link X) ) ) ) )
                              ((isa '+Ref B)
                                 (let N (index B (: bag))
                                    (with B
                                       (when
                                          (find
                                             '((L)
                                                (and
                                                   (get L N)
                                                   (<> Obj
                                                      (fetch
                                                         (tree (: var) (: cls)
                                                            (get
                                                               (if (sym? (: hook)) Obj L)
                                                               (: hook) ) )
                                                         (cons (get L N) Obj) ) ) ) )
                                                V )
                                             (link X) ) ) ) ) ) ) ) ) ) ) ) )
      (cons Obj @) ) )


### Rebuild tree ###
(de rebuild (Lst Var Cls Hook)
   (when (get (or Hook *DB) Cls)
      (zapTree (get @ Var -1))
      (put @ Var NIL)
      (commit) )
   (for Obj Lst
      (re-index Obj Var)
      (commit) ) )

(de re-index (Obj Var)
   (when (and (not (get Obj T)) (get Obj Var))
      (rel> (meta Obj Var) Obj NIL
         (put> (meta Obj Var) Obj NIL @) ) ) )


### Database file management ###
(de dbfCheck ()
   (dbMap
      '((Obj)