picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

dbase.l (2368B)

      1 # 10may11abu
      2 # (c) Software Lab. Alexander Burger
      3 
      4 (de dbase (File)
      5    (use (Cnt Hdr Siz Fld X)
      6       (in File
      7          (unless (= 3 (rd 1))    # Version
      8             (quit "dBASE Version") )
      9          (rd 3)                  # Date
     10          (setq
     11             Cnt (rd -4)          # Record count
     12             Hdr (rd -2)          # Header size
     13             Siz (rd -2) )        # Record size
     14          (rd 3)                  # Reserved
     15          (unless (=0 (rd 1))     # Encryption Flag
     16             (quit "Encrypted") )
     17          (rd 16)                 # Reserved
     18          (setq Fld
     19             (make
     20                (until (= 13 (setq X (rd 1)))
     21                   (link
     22                      (cons
     23                         (intern                    # Name
     24                            (pack
     25                               (char X)
     26                               (make
     27                                  (for
     28                                     (L (make (do 10 (link (rd 1))))
     29                                        (n0 (car L))
     30                                        (cdr L) )
     31                                     (link (char (car L))) ) ) ) )
     32                         (cons
     33                            (char (rd 1))           # Type
     34                            (cons
     35                               (prog (rd 4) (rd 1)) # Size
     36                               (rd 1) ) ) ) )       # Prec
     37                   (rd 14) ) ) ) )  # Skip
     38 
     39       (in (list "@bin/utf2" "-dd" (pack "if=" File) (pack "bs=" Hdr) "skip=1")
     40          (prog1
     41             (make
     42                (do Cnt
     43                   (setq X (make (do Siz (link (char)))))
     44                   (when (<> "*" (pop 'X))
     45                      (link
     46                         (extract
     47                            '((F)
     48                               (let? S (pack (clip (cut (caddr F) 'X)))
     49                                  (cons
     50                                     (car F)
     51                                     (case (cadr F)
     52                                        ("C" S)
     53                                        ("D" ($dat S))
     54                                        ("L" (bool (member S `(chop "JjTt"))))
     55                                        ("N" (format S (cdddr F)))
     56                                        (T "?") ) ) ) )
     57                            Fld ) ) ) ) )
     58             (unless (= "^Z" (char))
     59                (quit "Missing EOF") ) ) ) ) )