# 27aug25 Software Lab. Alexander Burger

(symbols '(llvm))

(local) (bufSize pathSize bufString pathString)

(de i64 bufSize (Nm)
   (let N 1
      (while (big? Nm)
         (inc 'N 8)
         (setq Nm (val (big Nm))) )
      (setq Nm (int Nm))
      (while Nm
         (inc 'N)
         (setq Nm (shr Nm 8)) )
      N ) )

(de i64 pathSize (Nm)
   (let
      (Len (bufSize Nm)
         N (if (cnt? Nm) (int @) (val (dig @)))
         B (i8 N) )
      (cond
         ((or
               (== B (char "@"))
               (and
                  (== B (char "+"))
                  (== (i8 (shr N 8)) (char "@")) ) )
            (+ (val $PilLen) (dec Len)) )
         ((or
               (== B (char "~"))
               (and
                  (== B (char "+"))
                  (== (i8 (shr N 8)) (char "~")) ) )
            (+ (val $UsrLen) (dec Len)) )
         (T Len) ) ) )

(de i8* bufString (Nm (i8* . P))
   (let Q (push 0 Nm)  # [cnt name]
      (prog1 P
         (while (set P (symByte Q))
            (inc 'P) ) ) ) )

(de i8* pathString (Nm (i8* . P))
   (let (Q (push 0 Nm)  B (symByte Q))  # [cnt name]
      (prog1 P
         (when (== B (char "+"))
            (set P B)
            (inc 'P)
            (setq B (symByte Q)) )
         (case B
            ((char "@")
               (when (val $PilLen)
                  (memcpy P (val $PilHome) @)
                  (inc 'P @) ) )
            ((char "~")
               (when (val $UsrLen)
                  (memcpy P (val $UsrHome) @)
                  (inc 'P @) ) )
            (T
               (set P B)
               (inc 'P) ) )
         (while (set P (symByte Q))
            (inc 'P) ) ) ) )

(local) (mkChar mkStr firstByte firstChar isBlank)

(de mkChar ((i32 . C))
   (consStr
      (cnt
         (cond
            ((>= 127 C) (i64 C))  # Single byte
            ((== TOP C) (hex "FF"))  # Infinite
            ((> (hex "800") C)  # Double-byte
               (i64
                  (|
                     (| (hex "C0") (& (shr C 6) (hex "1F")))  # 10xxxxx 10xxxxxx
                     (shl (| (hex "80") (& C (hex "3F"))) 8) ) ) )
            ((> (hex "10000") C)  # Three bytes
               (i64
                  (|
                     (|
                        (| (hex "E0") (& (shr C 12) (hex "0F")))  # 1110xxxx 10xxxxxx 10xxxxxx
                        (shl (| (hex "80") (& (shr C 6) (hex "3F"))) 8) )
                     (shl (| (hex "80") (& C (hex "3F"))) 16) ) ) )
            (T
               (|
                  (i64
                     (|
                        (|
                           (| (hex "F0") (& (shr C 18) (hex "07")))  # 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
                           (shl (| (hex "80") (& (shr C 12) (hex "3F"))) 8) )
                        (shl (| (hex "80") (& (shr C 6) (hex "3F"))) 16) ) )
                  (shl
                     (| (hex "80") (& (i64 C) (hex "3F")))
                     24 ) ) ) ) ) ) )

(de mkStr ((i8* . Str))
   (if Str
      (let P (push 4 NIL ZERO NIL)  # [cnt last name link]
         (link (ofs P 2) T)
         (while (val Str)
            (byteSym @ P)
            (inc 'Str) )
         (consStr (val 3 P)) )
      $Nil ) )

(de mkStrE ((i8* . Str) (i8* . End))
   (let P (push 4 NIL ZERO NIL)  # [cnt last name link]
      (link (ofs P 2) T)
      (loop
         (? (== Str End))
         (? (=0 (val Str)))
         (byteSym @ P)
         (inc 'Str) )
      (consStr (val 3 P)) ) )

(de i8 firstByte (Sym)
   (i8
      (cond
         ((nil? Sym) 0)
         ((sym? (val (tail Sym))) 0)
         ((cnt? (name @)) (int @))
         (T (val (dig @))) ) ) )

(de i32 firstChar (Sym)
   (cond
      ((nil? Sym) 0)
      ((sym? (val (tail Sym))) 0)  # External symbol
      (T (symChar (push 0 (name @)))) ) )  # Else get name

(de i1 isBlank (X)
   (or
      (nil? X)
      (and
         (symb? X)
         (not (sym? (val (tail X))))
         (let P (push 0 (name @))  # [cnt name]
            (loop
               (? (=0 (symByte P)) YES)
               (? (> @ 32) NO) ) ) ) ) )

# Build external symbol name
(local) extNm

(de extNm ((i32 . File) (i64 . Obj))
   (cnt
      (|
         (& Obj (hex "FFFFF"))  # Lowest 20 bits
         (|
            (shl (i64 (& File (hex "FF"))) 20)  # Lower 8 bits
            (|
               (shl
                  (& (setq Obj (shr Obj 20)) (hex "FFF"))  # Middle 12 bits
                  28 )
               (|
                  (shl (i64 (shr File 8)) 40)  # Upper 8 bits
                  (shl (shr Obj 12) 48) ) ) ) ) ) )  # Highest 10 bits

(local) (objFile objId packAO packOct packExtNm pack chopExtNm)

# Get file number from external symbol name
(de i32 objFile (Name)
   (|
      (& (i32 (setq Name (shr Name 24))) (hex "FF"))  # Low 8 bits
      (& (i32 (shr Name 12)) (hex "FF00")) ) )  # High 8 bits

# Get object ID from external symbol name
(de i64 objId (Name)
   (|
      (|
         (& (setq Name (shr Name 4)) (hex "FFFFF"))  # Lowest 20 bits
         (& (setq Name (shr Name 8)) (hex "FFF00000")) )  # Middle 12 bits
      (& (shr Name 8) (hex "3FF00000000")) ) )  # Highest 10 bits

# Pack external symbol name
(de void packAO ((i32 . File) (i64* . P))
   (when (> File 15)
      (packAO (shr File 4) P) )  # Divide by 16
   (byteSym (+ (& (i8 File) 15) (char "@")) P) )  # Make ASCII letter

(de void packOct ((i64 . Obj) (i64* . P))
   (when (> Obj 7)
      (packOct (shr Obj 3) P) )  # Divide by 8
   (byteSym (+ (& (i8 Obj) 7) (char "0")) P) )  # Make ASCII digit

(de void packExtNm (Name (i64* . P))
   (when (objFile Name)
      (packAO @ P) )
   (packOct (objId Name) P) )

# General pack
(de void pack (X (i64* . P))
   (when (pair X)
      (stkChk 0)
      (loop
         (pack (++ X) P)
         (? (atom X)) ) )
   (cond
      ((nil? X))
      ((num? X) (fmtNum X 0 0 0 P))
      ((sym? (val (tail X)))
         (byteSym (char "{") P)
         (packExtNm (name (& @ -9)) P)
         (byteSym (char "}") P) )
      (T
         (let Q (push 0 (name @))  # [cnt name]
            (while (symByte Q)
               (byteSym @ P) ) ) ) ) )

# Chop external symbol name
(de chopExtNm (Name)
   (let (R (link (push $Nil NIL))  N (objId Name))
      (loop
         (let A (+ (& N 7) (char "0"))  # Make ASCII digit
            (when (setq N (shr N 3))
               (setq A
                  (|
                     (shl A 8)
                     (+ (& N 7) (char "0")) ) )  # Second octal digit
               (when (setq N (shr N 3))
                  (setq A
                     (|
                        (shl A 8)
                        (+ (& N 7) (char "0")) ) ) ) )  # Third octal digit
            (set R
               (cons (consSym (cnt A) 0) (val R)) ) )
         (? (=0 (setq N (shr N 3)))) )
      (when (setq N (objFile Name))
         (let F (i32 0)
            (loop
               (setq F
                  (| F (+ (& N 15) (char "@"))) )  # Make ASCII letter
               (? (=0 (setq N (shr N 4))))
               (setq F (shl F 8)) )
            (set R
               (cons (consStr (cnt (i64 F))) (val R)) ) ) )
      (pop R) ) )

### Interning ###
(local) (cmpLong isIntern isLstIntern findSym)

# Compare long names
(de i64 cmpLong (X Y)
   (loop
      (? (sub (val (dig X)) (val (dig Y)))
         (if @@ -1 +1) )
      (setq X (val (big X))  Y (val (big Y)))
      (? (cnt? X)
         (cond
            ((big? Y) -1)
            ((== Y X) 0)
            ((> Y X) -1)
            (T +1) ) )
      (? (cnt? Y) +1) ) )

# Is name interned?
(de isIntern (Name Tree)
   (if (cnt? Name)  # Short name
      (let X (val Tree)  # First tree
         (loop
            (? (atom X) 0)  # Empty
            (let (S (car X)  Nm (name (val (tail S))))
               (? (== Name Nm) S)
               (setq X
                  (if (> Name Nm)  # Symbol is smaller
                     (cddr X)
                     (cadr X) ) ) ) ) )
      # Long name
      (let X (val 2 Tree)  # Second tree
         (loop
            (? (atom X) 0)  # Empty
            (let (S (car X)  Nm (name (val (tail S))))
               (? (=0 (cmpLong Nm Name)) S)
               (setq X
                  (if (lt0 @)  # Symbol is smaller
                     (cddr X)
                     (cadr X) ) ) ) ) ) ) )

(de isLstIntern (Name Lst)
   (loop
      (? (atom Lst) 0)
      (? (isIntern Name (cdar (car Lst))) @)
      (shift Lst) ) )

(de i1 findSym (Sym Name Lst)
   (loop
      (? (atom Lst) NO)
      (? (== Sym (isIntern Name (cdar (car Lst)))) YES)
      (shift Lst) ) )

(local) (intern1 intern2 internRight internLeft)

(inline intern1 (Sym Val Name Node More)
   (if (isLstIntern Name More)
      @
      (unless Sym  # New symbol
         (setq Sym (consSym Name Val)) )
      (set Node (cons Sym $Nil))
      Sym ) )

(inline intern2 (Sym Val Name Node More)
   (if (isLstIntern Name More)
      @
      (unless Sym  # New symbol
         (setq Sym (consSym Name Val)) )
      (set 2 Node (cons Sym $Nil))
      Sym ) )

(inline internRight (Sym Val Name Node More)
   (if (isLstIntern Name More)
      @
      (unless Sym  # New symbol
         (setq Sym (consSym Name Val)) )
      (set 2 Node (cons $Nil (cons Sym $Nil)))
      Sym ) )

(inline internLeft (Sym Val Name Node More)
   (if (isLstIntern Name More)
      @
      (unless Sym  # New symbol
         (setq Sym (consSym Name Val)) )
      (set 2 Node (cons (cons Sym $Nil) $Nil))
      Sym ) )

(local) (intern requestSym extern delNode unintern)

# Intern a symbol/name
(de intern (Sym Val Name Tree More (i1 . Rpl))
   (if (cnt? Name)  # Short name
      (let X (val Tree)  # First tree
         (if (pair X)  # Not empty
            (loop
               (let (S (car X)  Nm (name (val (tail S))))
                  (? (== Name Nm)  # Found name
                     (if Rpl
                        (set X Sym)  # Replace with argument symbol
                        S ) )  # Return found symbol
                  (let Y (cdr X)  # Get link cell
                     (cond
                        ((> Name Nm)  # Symbol is smaller
                           (? (atom Y) (internRight Sym Val Name X More))  # No link yet
                           (? (atom (setq Y (cdr (setq X Y))))
                              (intern2 Sym Val Name X More) ) )
                        (T  # Symbol is greater
                           (? (atom Y) (internLeft Sym Val Name X More))  # No link yet
                           (? (atom (setq Y (car (setq X Y))))
                              (intern1 Sym Val Name X More) ) ) )
                     (setq X Y) ) ) )
            # Empty
            (intern1 Sym Val Name Tree More) ) )
      # Long name
      (let X (val 2 Tree)  # Second tree
         (if (pair X)  # Not empty
            (loop
               (let (S (car X)  Nm (name (val (tail S))))
                  (? (=0 (cmpLong Nm Name))  # Found name
                     (if Rpl
                        (set X Sym)  # Replace with argument symbol
                        S ) )  # Return found symbol
                  (let Y (cdr X)  # Get link cell
                     (cond
                        ((lt0 @)  # Symbol is smaller
                           (? (atom Y) (internRight Sym Val Name X More))  # No link yet
                           (? (atom (setq Y (cdr (setq X Y))))
                              (intern2 Sym Val Name X More) ) )
                        (T  # Symbol is greater
                           (? (atom Y) (internLeft Sym Val Name X More))  # No link yet
                           (? (atom (setq Y (car (setq X Y))))
                              (intern1 Sym Val Name X More) ) ) )
                     (setq X Y) ) ) )
            # Empty
            (intern2 Sym Val Name Tree More) ) ) ) )

(de requestSym (Name)
   (if (isIntern Name $PrivT)
      @
      (let L (val $Intern)
         (intern 0 $Nil Name
            (cdar (car L))
            (cdr L)
            NO ) ) ) )

# Intern an external symbol
(de extern (Name)
   (need3)  # Reserve 3 cells
   (let (X (val $Extern)  C 0  Sym T)
      (loop
         (inc 'C)  # Next level
         (setq Sym (car X))  # Next symbol
         (let Nm
            (&
               (name (& (val (tail Sym)) -9))
               (hex "3FFFFFFFFFFFFFF7") )  # Mask status and extern bits
            (? (== Nm Name))  # Found
            (let Y (cdr X)  # Get link cell
               (cond
                  ((> Name Nm)  # Symbol is smaller
                     (? (atom Y)  # No link yet
                        (set 2 X
                           (cons $Nil (cons (setq Sym (consExt Name)) $Nil)) ) )
                     (? (atom (setq Y (cdr (setq X Y))))
                        (set 2 X
                           (cons (setq Sym (consExt Name)) $Nil) ) ) )
                  (T  # Symbol is greater
                     (? (atom Y)  # No link yet
                        (set 2 X
                           (cons (cons (setq Sym (consExt Name)) $Nil) $Nil) ) )
                     (? (atom (setq Y (car (setq X Y))))
                        (set X
                           (cons (setq Sym (consExt Name)) $Nil) ) ) ) )
               (setq X Y) ) ) )
      (setq C (shr C 1))  # Half depth
      (when (> (shl 1 C) (val $ExtCnt))  # 2 ** (C/2)
         (setq X (val $Extern))
         (let N (val $ExtSkip)  # Levels to skip
            (if (> (inc 'N) C)  # Beyond half depth
               (set $ExtSkip 0)  # Don't skip
               (set $ExtSkip N)
               (loop  # Skip
                  (setq X
                     (if
                        (>
                           Name
                           (&
                              (name (& (val (tail (++ X))) -9))
                              (hex "3FFFFFFFFFFFFFF7") ) )
                        (cdr X)
                        (car X) ) )
                  (? (=0 (dec 'C))) ) ) )
         (loop  # Pivot
            (let
               (Nm
                  (&
                     (name (& (val (tail (car X))) -9))
                     (hex "3FFFFFFFFFFFFFF7") )
                  Y (cdr X) )
               (? (== Nm Name))  # Done
               (if (> Name Nm)  # Symbol is smaller
                  (let Z (cdr Y)  # Get right node
                     (? (atom (cdr Z)))
                     (xchg Z X)  # Pivot left
                     (setq Z (cdr Z)  X (cdr Z))
                     (set  # Rotate pointers
                        2 Z (val Z)
                        Z (val Y)
                        Y (cdr Y)
                        2 Y X) )
                  (let Z (car Y)  # Get left node
                     (? (atom (cdr Z)))
                     (xchg Z X)  # Pivot right
                     (setq Z (cdr Z)  X (val Z))
                     (set  # Rotate pointers
                        Z (cdr Z)
                        2 Z (cdr Y)
                        2 Y (val Y)
                        Y X) ) ) ) ) )
      Sym ) )

(de void delNode (X P)
   (let Y (cdr X)  # Subtrees
      (cond
         ((atom (car Y))  # No left branch
            (set P (cdr Y)) )  # Use right branch
         ((atom (cdr Y))  # No right branch
            (set P (car Y)) )  # Use left branch
         ((atom (car (setq P (cdr (shift Y)))))  # Y on right branch, P on sub-branches
            (set  # No left sub-branch
               X (car Y)  # Insert right sub-branch
               2 (cdr X) (cdr P) ) )
         (T
            (setq P (car P))  # Left sub-branch
            (loop
               (let Z (cdr P)  # More left branches
                  (? (atom (car Z))
                     (set
                        X (car P)  # Insert left sub-branch
                        (cdr Y) (cdr Z) ) )
                  (setq Y P  P (car Z)) ) ) ) ) ) )  # Go down left

(de void unintern (Sym Name P)
   (if (cnt? Name)  # Short name
      (loop  # First tree
         (let X (car P)  # Next node
            (? (atom X))  # Empty
            (let (S (car X)  Nm (name (val (tail S))))
               (? (== Name Nm)
                  (when (== S Sym)  # Correct symbol
                     (delNode X P) ) )
               (? (atom (shift X)))
               (setq P
                  (if (> Name Nm) (ofs X 1) X) ) ) ) )
      # Long name
      (setq P (ofs P 1))  # Second tree
      (loop
         (let X (car P)  # Next node
            (? (atom X))  # Empty
            (let
               (S (car X)
                  Nm (name (val (tail S)))
                  I (cmpLong Nm Name) )
               (? (=0 I)
                  (when (== S Sym)  # Correct symbol
                     (delNode X P) ) )
               (? (atom (shift X)))
               (setq P
                  (if (lt0 I) (ofs X 1) X) ) ) ) ) ) )

# (name 'sym) -> sym
(de _Name (Exe)
   (let Tail (val (tail (needSymb Exe (eval (cadr Exe)))))
      (if (sym? Tail)  # External
         (let P (push 4 NIL ZERO NIL)  # [cnt last name link]
            (link (ofs P 2) T)
            (packExtNm (name (& Tail -9)) P)
            (consStr (val 3 P)) )
         (consStr (name Tail)) ) ) )

# (nsp 'sym) -> sym
(de _Nsp (Exe)
   (let Sym (needSymb Exe (eval (cadr Exe)))
      (if (sym? (val (tail Sym)))
         $Nil
         (let Nm (name @)
            (if (== Sym (isIntern Nm $PrivT))  # Private?
               $priv
               (let Lst (val $Intern)  # Search namespaces
                  (loop
                     (? (atom Lst) $Nil)
                     (let Nsp (car Lst)
                        (? (== Sym (isIntern Nm (cdar Nsp))) Nsp) )
                     (shift Lst) ) ) ) ) ) ) )

# (sp? 'any) -> flg
(de _SpQ (Exe)
   (if (isBlank (eval (cadr Exe)))
      $T
      $Nil ) )

# (pat? 'any) -> sym | NIL
(de _PatQ (Exe)
   (let X (eval (cadr Exe))
      (if (and (symb? X) (== (firstChar X) (char "@")))
         X
         $Nil ) ) )

# (fun? 'any) -> any
(de _FunQ (Exe)
   (if (funq (eval (cadr Exe)))
      @
      $Nil ) )

# (getd 'any) -> fun | NIL
(de _Getd (Exe)
   (let (X (eval (cadr Exe))  V T)
      (cond
         ((not (symb? X)) $Nil)
         ((funq (setq V (val X))) V)
         ((and (nil? V) (sharedLib X)) (val X))
         (T $Nil) ) ) )

### Namespaces ###
(local) consTree

# Build sorted list from tree
(de consTree (P Lst)
   (if (atom P)
      Lst
      (let
         (Q (link (push NIL NIL))
            Tos (link (push -ZERO NIL)))
         (loop
            (loop
               (let X (cdr P)  # Get subtrees
                  (? (atom (cdr X)))  # Right subtree
                  (let Y P  # Go right
                     (setq P @)  # Invert tree
                     (set 2 X (val Tos))
                     (set Tos Y) ) ) )
            (set Q P)  # Save tree
            (loop
               (setq Lst (cons (car P) Lst))  # Cons symbol
               (let X (cdr P)
                  (? (pair (car X))  # Left subtree
                     (let Y P  # Go left
                        (setq P @)  # Invert tree
                        (set X (val Tos))
                        (set Tos (| Y 8))  # First visit
                        (set Q P) ) ) )  # Save tree
               (loop
                  (let X (val Tos)
                     (when (== -ZERO X)
                        (drop Q)
                        (ret Lst) )
                     (? (=0 (& X 8))  # Second visit
                        (let Y (cdr X)  # Nodes
                           (set Tos (cdr Y))  # TOS on up link
                           (set 2 Y P)
                           (setq P X)
                           (set Q P) ) )  # Save tree
                     (setq X (& X -9))  # Clear visit bit
                     (let Y (cdr X)  # Nodes
                        (set Tos (car Y))
                        (set Y P)
                        (setq P X)
                        (set Q P) ) ) ) ) ) ) ) )  # Save tree

# (all ['NIL | 'T | '0 | 'sym | '(NIL . flg) | '(T . flg) | '(0)]) -> lst
(de _All (Exe)
   (let X (eval (cadr Exe))
      (cond
         ((nil? X)  # Internal symbols
            (let Y (val $Intern)
               (loop
                  (let Z (cdar (++ Y))
                     (setq X
                        (consTree (val Z) (consTree (val 2 Z) X)) ) )
                  (? (atom Y) X) ) ) )
         ((t? X)  # Transient symbols
            (consTree (val $Transient) (consTree (val 2 $Transient) $Nil)) )
         ((num? X)  # External symbols
            (consTree (val $Extern) $Nil) )
         ((sym? X)  # Given namespace
            (let Y (cdar X)
               (if (pair Y)
                  (consTree (val Y) (consTree (val 2 Y) $Nil))
                  $Nil ) ) )
         ((nil? (car X))  # Direct internal tree
            (let Y (val (car (val $Intern)))
               (if (nil? (cdr X))
                  (val Y)
                  (val 2 Y) ) ) )
         ((t? (car X))  # Direct transient trees
            (if (nil? (val 2 X))
               (val $Transient)
               (val 2 $Transient) ) )
         (T (val $Extern)) ) ) ) # Direct external tree

# (symbols) -> lst
# (symbols 'lst) -> lst
# (symbols 'lst . prg) -> any
# (symbols ['T] 'sym1 'sym2 ..) -> lst
(de _Symbols (Exe)
   (let X (cdr Exe)
      (if (atom X)  # No args
         (val $Intern)
         (let Y (eval (++ X))
            (if (pair Y)  # List argument
               (let L Y
                  (loop
                     (needNsp Exe (needSymb Exe (++ L)))
                     (? (atom L)) )
                  (if (atom X)  # No 'prg'
                     (prog1
                        (val $Intern)
                        (set $Intern Y) )
                     (let Z (save (val $Intern))
                        (set $Intern Y)
                        (prog1
                           (run X)  # Run 'prg'
                           (set $Intern Z) ) ) ) )
               (let F (t? Y)
                  (when F
                     (setq Y (eval (++ X))) )
                  (if
                     (or  # New namespace
                        (nil? (val (needSymb Exe Y)))
                        (== @ Y) )
                     (set
                        (chkVar Exe Y)
                        (cons $Tilde (cons $Nil $Nil)) )
                     (needNsp Exe Y) )
                  (let R (setq Y (save (cons Y $Nil)))
                     (while (pair X)
                        (setq Y
                           (set 2 Y
                              (cons
                                 (needNsp Exe (needSymb Exe (eval (++ X))))
                                 $Nil ) ) ) )
                     (prog1
                        (val $Intern)
                        (set $Intern R)
                        (when F
                           (set (val $NsLink) R) )
                        (putSrc (car R) 0) ) ) ) ) ) ) ) )

# (intern 'any ['nsp]) -> sym
(de _Intern (Exe)
   (let (X (cdr Exe)  Sym (save (evSym X)))
      (cond
         ((sym? (val (tail Sym))) $Nil)  # External symbol
         ((== (name @) ZERO) $Nil)  # Anonymous symbol
         (T
            (let Nm @
               (if (nil? (eval (cadr X)))
                  (let L (val $Intern)
                     (intern Sym 0 Nm
                        (cdar (car L))
                        (cdr L)
                        NO ) )
                  (intern Sym 0 Nm
                     (if (t? @)
                        (cdar (car (val $Intern)))
                        (cdar @) )
                     $Nil
                     NO ) ) ) ) ) ) )

# (====) -> NIL
(de _Hide (Exe)
   (set $Transient (set 2 $Transient $Nil)) )

# (box? 'any) -> sym | NIL
(de _BoxQ (Exe)
   (let X (eval (cadr Exe))
      (if
         (and
            (symb? X)
            (not (sym? (val (tail X))))
            (== ZERO (name @)) )
         X
         $Nil ) ) )

# (str? 'any) -> sym | NIL
(de _StrQ (Exe)
   (let X (eval (cadr Exe))
      (cond
         ((not (symb? X)) $Nil)
         ((or
               (sym? (val (tail X)))  # External
               (findSym X (name @) (val $Intern)) )
            $Nil )
         (T X) ) ) )

# (zap 'sym) -> sym
(de _Zap (Exe)
   (let Sym (needSymb Exe (eval (cadr Exe)))
      (if (sym? (val (tail Sym)))  # External
         (dbZap Sym)
         (unintern Sym (name @) (cdar (car (val $Intern)))) )
      Sym ) )

# (chop 'any) -> lst
(de _Chop (Exe)
   (let X (eval (cadr Exe))
      (if (or (pair X) (nil? X))
         X
         (let Tail (val (tail (xSym X)))
            (if (sym? Tail)  # External
               (chopExtNm (name (& Tail -9)))
               (let (P (push 0 (name Tail))  C (symChar P))
                  (if C
                     (save Tail
                        (let (Y (cons (mkChar C) $Nil)  R (save Y))
                           (while (setq C (symChar P))
                              (setq Y
                                 (set 2 Y (cons (mkChar C) $Nil)) ) )
                           R ) )
                     $Nil ) ) ) ) ) ) )

# (pack 'any ..) -> sym
(de _Pack (Exe)
   (save -ZERO
      (let
         (X (cdr Exe)
            P (push 4 NIL ZERO NIL) )  # [cnt last name link]
         (link (ofs P 2))
         (while (pair X)
            (pack (safe (eval (++ X))) P) )
         (consStr (val 3 P)) ) ) )

# (glue 'any 'lst) -> sym
(de _Glue (Exe)
   (let (X (cdr Exe)  Y (save (eval (++ X))))  # 'any'
      (if (atom (eval (++ X)))  # 'lst'
         @
         (let (Z (save @)  P (push 4 NIL ZERO NIL))  # [cnt last name link]
            (link (ofs P 2))
            (loop
               (pack (++ Z) P)
               (? (atom Z))
               (pack Y P) )
            (consStr (val 3 P)) ) ) ) )

# (text 'any1 'any ..) -> sym
(de _Text (Exe)
   (let (X (cdr Exe)  Y (evSym X))
      (if (nil? Y)
         Y
         (let
            (P (push 0 (xName Y) NIL)  # [cnt name link]
               Q (link (ofs P 1) T)
               R (push 4 NIL ZERO NIL)  # [cnt last name link]
               A (link (ofs R 2))
               N 0
               C T )
            (while (pair (shift X))
               (setq A (link (push (eval (car X)) NIL)))
               (inc 'N) )
            (while (setq C (symByte P))
               (cond
                  ((<> C (char "@")) (byteSym C R))
                  ((== (setq C (symByte P)) (char "@"))
                     (byteSym C R) )  # "@@"
                  ((gt0 (dec 'C (char "0")))
                     (when (> C 9)
                        (dec 'C 7) )  # Adjust for letter
                     (when (ge0 (setq C (- N (i64 C))))
                        (let I A
                           (while (ge0 (dec 'C))
                              (shift I) )
                           (pack (val I) R) ) ) ) ) )
            (consStr (val 3 R)) ) ) ) )

### Matching ###
(local) (preStr subStr)

(de i1 preStr (Nm (i8 . B) (i64* . P))
   (let (Q (push 0 (i64 Nm))  C (symByte Q))
      (loop
         (? (<> B C) NO)
         (? (=0 (setq C (symByte Q))) YES)
         (? (=0 (setq B (symByte P))) NO) ) ) )

(de i64 subStr (X Y (i64 . N))
   (cond
      ((nil? X) 0)
      ((== ZERO (setq X (xName X))) 0)
      (T
         (let (P (push 0 (xName Y))  B T  R 1)
            (while (gt0 (dec 'N))
               (when (=0 (symByte P))
                  (ret -1) )
               (inc 'R) )
            (loop
               (? (=0 (setq B (symByte P))) -1)
               (let (Cnt (val P)  Nm (val 2 P))
                  (? (preStr X B P) R)
                  (set P Cnt  2 P Nm) )
               (inc 'R) ) ) ) ) )

# (pre? 'any1 'any2) -> any2 | NIL
(de _PreQ (Exe)
   (let (X (cdr Exe)  Y (save (evSym X))  Z (evSym (shift X)))
      (cond
         ((nil? Y) Z)
         ((== ZERO (setq Y (xName Y)))
            Z )
         (T
            (let P (push 0 (xName Z))
               (cond
                  ((=0 (symByte P)) $Nil)
                  ((preStr Y @ P) Z)
                  (T $Nil) ) ) ) ) ) )

# (sub? 'any1 'any2 ['cnt]) -> any2 | NIL
(de _SubQ (Exe)
   (let
      (X (cdr Exe)
         Y (save (evSym X))
         Z (evSym (shift X)) )
      (if
         (lt0
            (subStr Y Z
               (if (pair (shift X)) (evCnt Exe X) 1) ) )
         $Nil
         (set $At2 (cnt @))
         Z ) ) )

# (val 'var) -> any
(de _Val (Exe)
   (let V (needVar Exe (eval (cadr Exe)))
      (when (and (sym? V) (sym? (val (tail V))))
         (dbFetch Exe V) )
      (val V) ) )

# (set 'var 'any ..) -> any
(de _Set (Exe)
   (save -ZERO
      (let X (cdr Exe)
         (loop
            (let Y (safe (needChkVar Exe (eval (++ X))))
               (when (and (sym? Y) (sym? (val (tail Y))))
                  (dbTouch Exe Y) )
               (let Z (eval (++ X))
                  (set Y Z)
                  (? (atom X) Z) ) ) ) ) ) )

# (setq var 'any ..) -> any
(de _Setq (Exe)
   (let X (cdr Exe)
      (loop
         (let Y (set (needChkVar Exe (++ X)) (eval (++ X)))
            (? (atom X) Y) ) ) ) )

# (swap 'var 'any) -> any
(de _Swap (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )
      (let (Z (eval (car X))  V (val Y))
         (set Y Z)
         V ) ) )

# (xchg 'var 'var ..) -> any
(de _Xchg (Exe)
   (save -ZERO
      (let X (cdr Exe)
         (loop
            (let Y (safe (needChkVar Exe (eval (++ X))))
               (when (and (sym? Y) (sym? (val (tail Y))))
                  (dbTouch Exe Y) )
               (let Z (needChkVar Exe (eval (++ X)))
                  (when (and (sym? Z) (sym? (val (tail Z))))
                     (dbTouch Exe Z) )
                  (setq Z (xchg Y Z))
                  (? (atom X) Z) ) ) ) ) ) )

# (on var ..) -> T
(de _On (Exe)
   (let X (cdr Exe)
      (loop
         (set (needChkVar Exe (++ X)) $T)
         (? (atom X) $T) ) ) )

# (off var ..) -> NIL
(de _Off (Exe)
   (let X (cdr Exe)
      (loop
         (set (needChkVar Exe (++ X)) $Nil)
         (? (atom X) $Nil) ) ) )

# (onOff var ..) -> flg
(de _OnOff (Exe)
   (let X (cdr Exe)
      (loop
         (let
            (Y (needChkVar Exe (++ X))
               Z (if (nil? (val Y)) $T $Nil) )
            (set Y Z)
            (? (atom X) Z) ) ) ) )

# (zero var ..) -> 0
(de _Zero (Exe)
   (let X (cdr Exe)
      (loop
         (set (needChkVar Exe (++ X)) ZERO)
         (? (atom X) ZERO) ) ) )

# (one var ..) -> 1
(de _One (Exe)
   (let X (cdr Exe)
      (loop
         (set (needChkVar Exe (++ X)) ONE)
         (? (atom X) ONE) ) ) )

# (default sym 'any ..) -> any
(de _Default (Exe)
   (let X (cdr Exe)
      (loop
         (let Y (needChkVar Exe (++ X))
            (when (nil? (val Y))
               (set Y (eval (car X))) )
            (? (atom (shift X)) (val Y)) ) ) ) )

# (push 'var 'any ..) -> any
(de _Push (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )
      (loop
         (let Z (eval (++ X))
            (set Y (cons Z (val Y)))
            (? (atom X) Z) ) ) ) )

# (push1 'var 'any ..) -> any
(de _Push1 (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )
      (loop
         (let (Z (eval (++ X))  V (val Y))
            (unless (member Z V)
               (set Y (cons Z V)) )
            (? (atom X) Z) ) ) ) )

# (push1q 'var 'any ..) -> any
(de _Push1q (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )
      (loop
         (let (Z (eval (++ X))  V (val Y))
            (unless (memq Z V)
               (set Y (cons Z V)) )
            (? (atom X) Z) ) ) ) )

# (pop 'var) -> any
(de _Pop (Exe)
   (let X (needChkVar Exe (eval (cadr Exe)))
      (when (and (sym? X) (sym? (val (tail X))))
         (dbTouch Exe X) )
      (if (atom (val X))
         @
         (set X (cdr @))
         (car @) ) ) )

# (++ var) -> any
(de _Popq (Exe)
   (let X (needChkVar Exe (cadr Exe))
      (if (atom (val X))
         @
         (set X (cdr @))
         (car @) ) ) )

# (shift 'var) -> any
(de _Shift (Exe)
   (let X (needChkVar Exe (eval (cadr Exe)))
      (when (and (sym? X) (sym? (val (tail X))))
         (dbTouch Exe X) )
      (set X (cdr (needLst Exe (val X)))) ) )

# (cut 'cnt 'var) -> lst
(de _Cut (Exe)
   (let (X (cdr Exe)  N (evCnt Exe X))
      (if (le0 N)
         $Nil
         (let Y (needChkVar Exe (eval (cadr X)))
            (when (and (sym? Y) (sym? (val (tail Y))))
               (dbTouch Exe Y) )
            (if (atom (val Y))
               @
               (let
                  (V (save @)
                     Z (cons (++ V) $Nil)
                     R (save Z) )
                  (while (and (pair V) (dec 'N))
                     (setq Z (set 2 Z (cons (++ V) $Nil))) )
                  (set Y V)  # Set new value
                  R ) ) ) ) ) )

# (del 'any 'var ['flg]) -> lst
(de _Del (Exe)
   (let
      (X (cdr Exe)
         Y (save (eval (++ X)))
         Var (save (needChkVar Exe (eval (++ X))))
         Flg (nil? (eval (car X))) )
      (when (and (sym? Var) (sym? (val (tail Var))))
         (dbTouch Exe Var) )
      (let V (val Var)
         (loop
            (? (atom V) V)
            (let Z (++ V)
               (? (not (equal Y Z))
                  (let (P (cons Z $Nil)  R P)
                     (save R
                        (loop
                           (? (atom V))
                           (if (equal Y (setq Z (++ V)))
                              (? Flg)
                              (setq P (set 2 P (cons Z $Nil))) ) ) )
                     (set 2 P V  Var R) ) ) )
            (set Var V)
            (? Flg V) ) ) ) )

# (queue 'var 'any) -> any
(de _Queue (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )
      (let
         (Z (eval (car X))
            L (cons Z $Nil)
            V (val Y) )
         (if (atom V)
            (set Y L)
            (while (pair (cdr V))
               (shift V) )
            (set 2 V L) )
         Z ) ) )

# (fifo 'var ['any ..]) -> any
(de _Fifo (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )  # External symbol
      (let V (val Y)
         (cond
            ((pair X)  # Add to fifo
               (let E (eval (car X))
                  (if (pair V)
                     (setq V (set 2 V (cons E (cdr V))))  # Concat into value
                     (setq V (cons E -ZERO))  # Circular cell
                     (set 2 V V) )
                  (while (pair (shift X))
                     (setq V
                        (set 2 V
                           (cons
                              (setq E (eval (car X)))
                              (cdr V) ) ) ) )
                  (set Y V)
                  E ) )
            ((atom V) $Nil)  # Empty
            ((== (cdr V) V)  # Single cell
               (set Y $Nil)  # Clear value
               (car V) )
            (T
               (set 2 V (cdr @))  # Remove
               (car @) ) ) ) ) )  # and return

# (rid 'var 'any) -> any
(de _Rid (Exe)
   (let
      (X (cdr Exe)
         Y (save (needChkVar Exe (eval (++ X)))) )
      (when (and (sym? Y) (sym? (val (tail Y))))
         (dbTouch Exe Y) )  # External symbol
      (setq X (eval (car X)))
      (let V (val Y)
         (cond
            ((pair V)
               (let (Z V  L (cdr Z))
                  (loop
                     (? (atom L)  # Non-circular
                        (when (equal L X)
                           (set 2 Z $Nil) )
                        (if (equal (car V) X)
                           (set Y (cdr V))
                           V ) )
                     (? (== L V)  # Circular
                        (nond
                           ((equal (car L) X) V)
                           ((== L Z)
                              (set 2 Z (cdr L))
                              (set Y Z) )
                           (NIL (set Y $Nil)) ) )
                     (if (equal (car L) X)
                        (set 2 Z (shift L))
                        (setq L (cdr (shift Z))) ) ) ) )
            ((equal V X) (set Y $Nil))
            (T V) ) ) ) )

# (enum 'var 'cnt ['cnt ..]) -> lst
# (enum 'var ['flg]) -> lst
(de _Enum (Exe)
   (let
      (X (cdr Exe)
         Var (save (needChkVar Exe (eval (++ X))))
         Arg (eval (car X))
         Cnt 0 )
      (if (num? Arg)
         (loop
            (? (le0 (setq Cnt (xCnt Exe Arg))) $Nil)
            (let P (val Var)
               (loop
                  (let N (shr Cnt 1)
                     (? (=0 N)
                        (setq Var
                           (if (pair P)
                              @
                              (set Var (cons $Nil $Nil)) ) ) )
                     (if (& Cnt 1)
                        (cond
                           ((atom P)
                              (let Y (cons $Nil (setq P $Nil))
                                 (set Var (cons $Nil Y))
                                 (setq Var (ofs Y 1)) ) )
                           ((atom (cdr P))
                              (setq Var
                                 (ofs
                                    (set 2 P (cons $Nil (setq P $Nil)))
                                    1 ) ) )
                           (T
                              (setq P (val (setq Var (ofs @ 1)))) ) )
                        (cond
                           ((atom P)
                              (let Y (cons (setq P $Nil) $Nil)
                                 (set Var (cons $Nil Y))
                                 (setq Var Y) ) )
                           ((atom (cdr P))
                              (setq Var
                                 (set 2 P (cons (setq P $Nil) $Nil)) ) )
                           (T (setq P (val (setq Var @)))) ) )
                     (setq Cnt N) ) ) )
            (? (atom (shift X)) Var)
            (setq Arg (eval (car X)) ) )
         (let
            (Q (link (push NIL NIL))
               Tos (link (push -ZERO NIL))
               R (link (push $Nil NIL))
               P (val Var)
               M 1 )
            (loop
               (loop
                  (let Y (cdr P)  # Get subtrees
                     (? (atom (cdr Y)))  # Right subtree
                     (let Z P  # Go right
                        (setq P @)  # Invert tree
                        (set 2 Y (val Tos))
                        (set Tos Z) )
                     (setq
                        Cnt (| Cnt M)
                        M (shl M 1) ) ) )
               (set Q P)  # Save tree
               (loop
                  (unless (nil? (car P))
                     (set R
                        (cons
                           (if (nil? Arg)
                              (cons (cnt (| Cnt M)) (car P))  # (cnt . any)
                              (cons (car P) (cnt (| Cnt M))) )  # (any . cnt)
                           (val R) ) ) )
                  (let Y (cdr P)
                     (? (pair (car Y))  # Left subtree
                        (let Z P  # Go left
                           (setq P @)  # Invert tree
                           (set Y (val Tos))
                           (set Tos (| Z 8))  # First visit
                           (set Q P) )  # Save tree
                        (setq M (shl M 1)) ) )
                  (loop
                     (let Y (val Tos)
                        (when (== -ZERO Y)
                           (ret (val R)) )
                        (? (=0 (& Y 8))  # Second visit
                           (setq
                              M (shr M 1)
                              Cnt (& Cnt (x| M -1)) )
                           (let Z (cdr Y)  # Nodes
                              (set Tos (cdr Z))  # TOS on up link
                              (set 2 Z P)
                              (setq P Y)
                              (set Q P) ) )  # Save tree
                        (setq
                           Y (& Y -9)  # Clear visit bit
                           M (shr M 1)
                           Cnt (& Cnt (x| M -1)) )
                        (let Z (cdr Y)  # Nodes
                           (set Tos (car Z))
                           (set Z P)
                           (setq P Y)
                           (set Q P) ) ) ) ) ) ) ) ) )  # Save tree

# (enum? 'lst 'cnt ['cnt ..]) -> lst | NIL
(de _EnumQ (Exe)
   (let
      (X (cdr Exe)
         P (save (eval (++ X)))
         Cnt T )
      (loop
         (? (le0 (setq Cnt (evCnt Exe X))) $Nil)
         (loop
            (let N (shr Cnt 1)
               (? (=0 N))
               (setq P
                  (if (& Cnt 1) (cddr P) (cadr P)) )
               (? (atom P) (ret $Nil))
               (setq Cnt N) ) )
         (? (atom (shift X)) P)
         (setq P (car P)) ) ) )

(local) (idxPut idxGet idxDel)

(de idxPut (Var Key Flg)
   (let X (val Var)
      (if (pair X)
         (loop
            (? (=0 (compare (car X) Key)) X)  # Found key
            (let Y (cdr X)  # Get link cell
               (cond
                  ((lt0 @)  # Entry is smaller
                     (? (atom Y)  # No link yet
                        (if (or (t? Flg) (chance 1))
                           (set 2 X (cons $Nil (cons Key $Nil)))
                           (set 2 X (cons (cons (car X) $Nil) $Nil))
                           (set X Key) )
                        $Nil )
                     (? (atom (setq Y (cdr Y)))
                        (if (or (t? Flg) (chance 1))
                           (set 2 (cdr X) (cons Key $Nil))
                           (set (cdr X)
                              (cons (car X) (cons (cadr X) $Nil)) )
                           (set X Key) )
                        $Nil )
                     (if
                        (or
                           (t? Flg)
                           (atom (cdr Y))
                           (gt0 (compare (car Y) Key))
                           (chance (hex "FFF")) )
                        (setq X Y)
                        (xchg X Y)
                        (set
                           2 (cdr X) (cddr Y)
                           2 (cdr Y) (cadr Y)
                           (cdr Y) (cadr X)
                           (cdr X) Y ) ) )
                  (T  # Entry is greater
                     (? (atom Y)  # No link yet
                        (if (or (t? Flg) (chance 1))
                           (set 2 X (cons (cons Key $Nil) $Nil))
                           (set 2 X (cons $Nil (cons (car X) $Nil)))
                           (set X Key) )
                        $Nil )
                     (? (atom (setq Y (car Y)))
                        (if (or (t? Flg) (chance 1))
                           (set (cdr X) (cons Key $Nil))
                           (set 2 (cdr X)
                              (cons (car X) (cons $Nil (cddr X))) )
                           (set X Key) )
                        $Nil )
                     (if
                        (or
                           (t? Flg)
                           (atom (cdr Y))
                           (lt0 (compare (car Y) Key))
                           (chance (hex "FFF")) )
                        (setq X Y)
                        (xchg X Y)
                        (set
                           (cdr X) (cadr Y)
                           (cdr Y) (cddr Y)
                           2 (cdr Y) (cddr X)
                           2 (cdr X) Y ) ) ) ) ) )
         (set Var (cons Key $Nil))
         $Nil ) ) )

(de idxGet (Var Key)
   (let X (val Var)
      (cond
         ((nil? Key)
            (while (pair (cadr X))
               (setq X @) )
            X )
         ((t? Key)
            (while (pair (cddr X))
               (setq X @) )
            X )
         (T
            (loop
               (? (atom X) $Nil)
               (? (=0 (compare (car X) Key)) X)  # Found key
               (let Y (cdr X)  # Get link cell
                  (setq X
                     (if (lt0 @) (cdr Y) (car Y)) ) ) ) ) ) ) )

(de idxDel (Var Key)
   (loop
      (let X (val Var)
         (? (atom X) $Nil)
         (let Y (cdr X)  # Subtrees
            (let I (compare (car X) Key)
               (? (=0 I)  # Found key
                  (cond
                     ((atom (car Y))  # No left branch
                        (set Var (cdr Y)) )  # Use right branch
                     ((atom (cdr Y))  # No right branch
                        (set Var (car Y)) )  # Use left branch
                     (T
                        (let Z (cdr (setq Y (cdr Y)))  # Sub-branches
                           (if (atom (car Z))  # No left sub-branch
                              (set   # Insert right sub-branch
                                 X (car Y)
                                 2 (cdr X) (cdr Z) )
                              (let L (cdr (setq Z (car Z)))  # Left sub-branch
                                 (loop
                                    (? (atom (car L)))
                                    (setq Y Z  Z (car L)  L (cdr Z)) )
                                 (set
                                    X (car Z)
                                    (cdr Y) (cdr L) ) ) ) ) ) )
                  X )
               (? (atom Y) $Nil)  # No link cell
               (setq Var Y)  # Default point to left subtree
               (and (lt0 I) (setq Var (ofs Var 1))) ) ) ) ) )  # Point to right

# (idx 'var 'any 'flg) -> lst
# (idx 'var 'any) -> lst
# (idx 'var) -> lst
(de _Idx (Exe)
   (let
      (X (cdr Exe)
         Var (needChkVar Exe (eval (++ X))) )
      (if (atom X)
         (consTree (val Var) $Nil)  # Single arg
         (save Var
            (let Key (save (eval (++ X)))
               (cond
                  ((atom X) (idxGet Var Key))  # Two args
                  ((nil? (eval (car X))) (idxDel Var Key))  # Delete
                  (T (idxPut Var Key @)) ) ) ) ) ) )

# (lup 'lst 'any) -> lst
# (lup 'lst 'any 'any2) -> lst
(de _Lup (Exe)
   (let (X (cdr Exe)  P (save (eval (++ X))))
      (if (atom P)
         P
         (let Key (eval (++ X))
            (if (atom X)
               (loop
                  (let Y (car P)
                     (cond
                        ((t? Y) (setq P (cadr P)))
                        ((atom Y) (setq P (cddr P)))
                        (T
                           (? (=0 (compare (car Y) Key)) (car P))
                           (setq
                              P (cdr P)
                              P (if (lt0 @) (cdr P) (car P)) ) ) ) )
                  (? (atom P) $Nil) )
               (save Key)
               (let
                  (Key2 (save (eval (car X)))
                     Q (link (push NIL NIL))
                     Tos (link (push -ZERO NIL))
                     R $Nil )
                  (loop
                     (loop
                        (let Y (cdr (setq X (cdr P)))  # Right subtree
                           (? (atom Y))
                           (let Z (car P)
                              (? (t? Z))
                              (? (and (pair Z) (gt0 (compare (car Z) Key2)))) )
                           (let Z P  # Go right
                              (setq P Y)  # Invert tree
                              (set 2 X (val Tos))
                              (set Tos Z) ) ) )
                     (set Q P)  # Save tree
                     (loop
                        (when
                           (and
                              (pair (setq X (car P)))
                              (ge0 (compare (car X) Key)) )
                           (when (le0 (compare (car X) Key2))
                              (setq R (cons X R)) )  # Cons symbol
                           (? (pair (car (setq X (cdr P))))  # Left subtree
                              (let Z P  # Go left
                                 (setq P @)  # Invert tree
                                 (set X (val Tos))
                                 (set Tos (| Z 8))  # First visit
                                 (set Q P) ) ) )  # Save tree
                        (loop
                           (when (== -ZERO (setq X (val Tos)))
                              (ret R) )
                           (? (=0 (& X 8))  # Second visit
                              (let Y (cdr X)  # Nodes
                                 (set Tos (cdr Y))  # TOS on up link
                                 (set 2 Y P)
                                 (setq P X)
                                 (set Q P) ) )  # Save tree
                           (setq X (& X -9))  # Clear visit bit
                           (let Y (cdr X)  # Nodes
                              (set Tos (car Y))
                              (set Y P)
                              (setq P X)
                              (set Q P) ) ) ) ) ) ) ) ) ) )  # Save tree

### Property access ###
(local) (put putn get getn prop)

(de void put (Sym Key Val)
   (let Tail (val (tail Sym))
      (unless (num? Tail)  # Property list
         (let (L (any (& Tail -9))  X (car L))
            (if (atom X)
               (when (== Key X)
                  (cond
                     ((nil? Val)
                        (shift L)  # Remove first property
                        (set (tail Sym)
                           (if (sym? Tail) (sym L) L) ) )
                     ((<> Val $T)  # Change to cell
                        (set L (cons Val Key)) ) )
                  (ret) )
               (when (== Key (cdr X))
                  (cond
                     ((nil? Val)
                        (shift L)  # Remove first property
                        (set (tail Sym)
                           (if (sym? Tail) (sym L) L) ) )
                     ((t? Val) (set L Key))  # Change to flag
                     (T (set X Val)) )  # Set new value
                  (ret) ) )
            (while (pair (setq X (cdr L)))
               (let Y (car X)
                  (if (atom Y)
                     (when (== Key Y)
                        (if (nil? Val)
                           (set 2 L (cdr X))  # Remove cell
                           (unless (t? Val)
                              (set X (cons Val Key)) )
                           (set 2 L (cdr X))  # Unlink cell
                           (ifn (sym? Tail)
                              (set 2 X Tail)
                              (set 2 X (& Tail -9))
                              (setq X (sym X)) )
                           (set (tail Sym) X) )
                        (ret) )
                     (when (== Key (cdr Y))
                        (if (nil? Val)
                           (set 2 L (cdr X))  # Remove cell
                           (if (t? Val)
                              (set X Key)  # Change to flag
                              (set Y Val) )  # Set new value
                           (set 2 L (cdr X))  # Unlink cell
                           (ifn (sym? Tail)
                              (set 2 X Tail)
                              (set 2 X (& Tail -9))
                              (setq X (sym X)) )
                           (set (tail Sym) X) )
                        (ret) ) ) )
                  (setq L X) ) ) )
      (unless (nil? Val)  # Non-NIL value
         (setq Val
            (if (t? Val) Key (cons Val Key)) )
         (set (tail Sym)
            (if (sym? Tail)
               (sym (cons Val (& Tail -9)))
               (cons Val Tail) ) ) ) ) )

(de void putn (Exe Lst Key Val)
   (nond
      ((num? Key)
         (loop  # asoq
            (let X (car Lst)
               (? (and (pair X) (== Key (car X)))
                  (set 2 X Val) ) )
            (when (atom (shift Lst))
               (itemErr Exe Key) ) ) )
      ((== ZERO Key)
         (let Cnt (int Key)  # index
            (while (dec 'Cnt)
               (when (atom (shift Lst))
                  (itemErr Exe Key) ) ) )
         (if (sign? Key)
            (set 2 Lst Val)
            (set Lst Val) ) )
      (NIL (argErr Exe Key)) ) )

(de get (Sym Key)
   (let Tail (val (tail Sym))
      (unless (num? Tail)
         (let (L (any (& Tail -9))  X (car L))
            (if (atom X)
               (when (== Key X)
                  (ret $T) )
               (when (== Key (cdr X))
                  (ret (car X)) ) )
            (while (pair (setq X (cdr L)))
               (let Y (car X)
                  (if (atom Y)
                     (when (== Key Y)
                        (set 2 L (cdr X))  # Unlink cell
                        (ifn (sym? Tail)
                           (set 2 X Tail)
                           (set 2 X (& Tail -9))
                           (setq X (sym X)) )
                        (set (tail Sym) X)
                        (ret $T) )
                     (when (== Key (cdr Y))
                        (set 2 L (cdr X))  # Unlink cell
                        (ifn (sym? Tail)
                           (set 2 X Tail)
                           (set 2 X (& Tail -9))
                           (setq X (sym X)) )
                        (set (tail Sym) X)
                        (ret (car Y)) ) )
                  (setq L X) ) ) ) )
      $Nil ) )

(de getn (Exe X Key)
   (when (num? X)  # Need symbol or pair
      (argErr Exe X) )
   (if (pair X)
      (nond
         ((num? Key)
            (loop  # asoq
               (let Y (car X)
                  (? (and (pair Y) (== Key (car Y)))
                     (cdr Y) ) )
               (? (atom (shift X)) $Nil) ) )
         ((== ZERO Key) (nth Key X))
         (NIL $Nil) )
      (when (sym? (val (tail X)))
         (dbFetch Exe X) )
      (if (== Key ZERO)
         (val X)
         (tailcall (get X Key)) ) ) )

(de prop (Sym Key)
   (let Tail (val (tail Sym))
      (unless (num? Tail)
         (let (L (any (& Tail -9))  X (car L))
            (if (atom X)
               (when (== Key X)
                  (ret Key) )
               (when (== Key (cdr X))
                  (ret X) ) )
            (while (pair (setq X (cdr L)))
               (let Y (car X)
                  (if (atom Y)
                     (when (== Key Y)
                        (set 2 L (cdr X))  # Unlink cell
                        (ifn (sym? Tail)
                           (set 2 X Tail)
                           (set 2 X (& Tail -9))
                           (setq X (sym X)) )
                        (set (tail Sym) X)
                        (ret Key) )
                     (when (== Key (cdr Y))
                        (set 2 L (cdr X))  # Unlink cell
                        (ifn (sym? Tail)
                           (set 2 X Tail)
                           (set 2 X (& Tail -9))
                           (setq X (sym X)) )
                        (set (tail Sym) X)
                        (ret Y) ) ) )
               (setq L X) ) ) )
      (let R (cons $Nil Key)
         (set (tail Sym)
            (if (sym? Tail)
               (sym (cons R (& Tail -9)))
               (cons R Tail) ) )
         R ) ) )

# (put 'sym1|lst ['sym2|cnt ..] 'any) -> any
(de _Put (Exe)
   (let
      (X (cdr Exe)
         Y (save (eval (++ X)))
         Key T )
      (loop
         (setq Key (eval (++ X)))
         (? (atom (cdr X)))
         (setq Y (safe (getn Exe Y Key))) )
      (when (num? Y)  # Need symbol or pair
         (argErr Exe Y) )
      (link (push Key NIL))
      (let Val (eval (car X))
         (if (pair Y)
            (putn Exe Y Key Val)
            (when (sym? (val (tail Y)))
               (if (nil? Key)
                  (dbFetch Exe Y)  # Volatile property
                  (dbTouch Exe Y) ) )
            (if (== ZERO Key)
               (set (chkVar Exe Y) Val)
               (put Y Key Val) ) )
         Val ) ) )

# (get 'sym1|lst ['sym2|cnt ..]) -> any
(de _Get (Exe)
   (let (X (cdr Exe)  Y (eval (++ X)))
      (when (pair X)
         (save Y
            (loop
               (setq Y (getn Exe Y (eval (++ X))))
               (? (atom X))
               (safe Y) ) ) )
      Y ) )

# (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var
(de _Prop (Exe)
   (let
      (X (cdr Exe)
         Y (save (eval (++ X)))
         Key T )
      (loop
         (setq Key (eval (++ X)))
         (? (atom X))
         (setq Y (safe (getn Exe Y Key))) )
      (needSymb Exe Y)
      (link (push Key NIL))
      (when (sym? (val (tail Y)))
         (if (nil? Key)
            (dbFetch Exe Y)  # Volatile property
            (dbTouch Exe Y) ) )
      (prop Y Key) ) )

# (; 'sym1|lst [sym2|cnt ..]) -> any
(de _Semicol (Exe)
   (let (X (cdr Exe)  Y (eval (++ X)))
      (when (pair X)
         (save Y
            (loop
               (setq Y (getn Exe Y (++ X)))
               (? (atom X))
               (safe Y) ) ) )
      Y ) )

# (=: sym|0 [sym1|cnt ..] 'any) -> any
(de _SetCol (Exe)
   (let (X (cdr Exe)  Y (val $This)  Key T)
      (loop
         (setq Key (++ X))
         (? (atom (cdr X)))
         (setq Y (getn Exe Y Key)) )
      (when (num? Y)  # Need symbol or pair
         (argErr Exe Y) )
      (let Val (eval (car X))
         (if (pair Y)
            (putn Exe Y Key Val)
            (when (sym? (val (tail Y)))
               (if (nil? Key)
                  (dbFetch Exe Y)  # Volatile property
                  (dbTouch Exe Y) ) )
            (if (== ZERO Key)
               (set (chkVar Exe Y) Val)
               (put Y Key Val) ) )
         Val ) ) )

# (: sym|0 [sym1|cnt ..]) -> any
(de _Col (Exe)
   (let (X (cdr Exe)  Y (val $This))
      (loop
         (setq Y (getn Exe Y (++ X)))
         (? (atom X) Y) ) ) )

# (:: sym|0 [sym1|cnt .. sym2]) -> var
(de _PropCol (Exe)
   (let (X (cdr Exe)  Y (val $This)  Key T)
      (loop
         (setq Key (++ X))
         (? (atom X))
         (setq Y (getn Exe Y Key)) )
      (needSymb Exe Y)
      (when (sym? (val (tail Y)))
         (if (nil? Key)
            (dbFetch Exe Y)  # Volatile property
            (dbTouch Exe Y) ) )
      (prop Y Key) ) )

# (putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst
(de _Putl (Exe)
   (let
      (X (cdr Exe)
         Y (save (eval (++ X)))
         Z T )
      (loop
         (setq Z (eval (++ X)))
         (? (atom X))
         (setq Y (safe (getn Exe Y Z))) )
      (let
         (R (save Z)
            Tail (val (tail (needSymb Exe Y))) )
         (when (sym? (setq X Tail))
            (dbTouch Exe Y)
            (setq X (& (val (tail Y)) -9)) )
         (until (num? X)  # Skip old properties
            (shift X) )
         (while (pair Z)  # New property list
            (let P (++ Z)
               (if (atom P)
                  (setq X (cons P X))
                  (unless (nil? (car P))
                     (when (t? (car P))
                        (setq P (cdr P)) )
                     (setq X (cons P X)) ) ) ) )
         (set (tail Y)
            (if (sym? Tail) (sym X) X) )
         R ) ) )

# (getl 'sym1|lst1 ['sym2|cnt ..]) -> lst
(de _Getl (Exe)
   (let (X (cdr Exe)  Y (save (eval (car X))))
      (while (pair (shift X))
         (setq Y
            (safe (getn Exe Y (eval (car X)))) ) )
      (when (sym? (setq X (val (tail (needSymb Exe Y)))))
         (dbFetch Exe Y)
         (setq X (& (val (tail Y)) -9)) )
      (if (num? X)
         $Nil
         (let R (setq Y (cons (car X) $Nil))
            (link (push R NIL))
            (while (pair (shift X))
               (setq Y
                  (set 2 Y (cons (car X) $Nil)) ) )
            R ) ) ) )

(local) wipe

(de void wipe (Exe X)
   (let
      (Tail (val (tail (needSymb Exe X)))
         Nm (name (& Tail -9)) )
      (ifn (sym? Tail)  # External symbol
         (set
            X $Nil  # Clear value
            (tail X) Nm )  # and properties
         (setq Nm (add Nm Nm))  # Get carry
         (unless @@  # Not dirty
            (setq Nm (add Nm Nm))
            (when @@  # and loaded
               (set
                  X $Nil
                  (tail X) (sym (shr Nm 2)) ) ) ) ) ) )  # Set "not loaded"

# (wipe 'sym|lst) -> sym|lst
(de _Wipe (Exe)
   (let X (eval (cadr Exe))
      (unless (nil? X)
         (if (atom X)
            (wipe Exe X)
            (let Y X
               (loop
                  (wipe Exe (++ Y))
                  (? (atom Y)) ) ) ) )
      X ) )

(local) meta

(de meta (X Key)
   (loop
      (? (atom X) $Nil)
      (let Y (car X)
         (when (symb? Y)
            (?
               (not
                  (nil?
                     (if (== Key ZERO) (val Y) (get Y Key)) ) )
               @ )
            (stkChk 0)
            (? (not (nil? (meta (car Y) Key))) @) ) )
      (shift X) ) )

# (meta 'obj|typ 'sym ['sym2|cnt ..]) -> any
(de _Meta (Exe)
   (let (X (cdr Exe)  Y (save (eval (++ X))))
      (when (num? Y)  # Need symbol or pair
         (argErr Exe Y) )
      (when (sym? Y)
         (when (sym? (val (tail Y)))
            (dbFetch Exe Y) )
         (setq Y (val Y)) )
      (setq Y (meta Y (eval (car X))))
      (while (pair (shift X))
         (safe Y)
         (setq Y (getn Exe Y (eval (car X)))) )
      Y ) )

# (low? 'any) -> sym | NIL
(de _LowQ (Exe)
   (let X (eval (cadr Exe))
      (if (and (symb? X) (isLowc (firstChar X)))
         X
         $Nil ) ) )

# (upp? 'any) -> sym | NIL
(de _UppQ (Exe)
   (let X (eval (cadr Exe))
      (if (and (symb? X) (isUppc (firstChar X)))
         X
         $Nil ) ) )

# (lowc 'any) -> any
(de _Lowc (Exe)
   (let X (eval (cadr Exe))
      (if (or (not (symb? X)) (nil? X))
         X
         (let
            (P (push 0 (xName X) NIL)  # [cnt name link]
               Q (link (ofs P 1) T)
               R (push 4 NIL ZERO NIL)  # [cnt last name link]
               C T )
            (link (ofs R 2))
            (while (setq C (symChar P))
               (charSym (toLowerCase C) R) )
            (consStr (val 3 R)) ) ) ) )

# (uppc 'any) -> any
(de _Uppc (Exe)
   (let X (eval (cadr Exe))
      (if (or (not (symb? X)) (nil? X))
         X
         (let
            (P (push 0 (xName X) NIL)  # [cnt name link]
               Q (link (ofs P 1) T)
               R (push 4 NIL ZERO NIL)  # [cnt last name link]
               C T )
            (link (ofs R 2))
            (while (setq C (symChar P))
               (ifn (== C (char "ß"))
                  (charSym (toUpperCase C) R)
                  (charSym (char "S") R)
                  (charSym (char "S") R) ) )
            (consStr (val 3 R)) ) ) ) )

# (fold 'any ['cnt]) -> sym
(de _Fold (Exe)
   (let (X (cdr Exe)  Y (eval (++ X)))
      (if (or (not (symb? Y)) (nil? Y))
         Y
         (let
            (N (if (atom X) 0 (evCnt Exe X))
               P (push 0 (xName Y) NIL)  # [cnt name link]
               Q (link (ofs P 1) T)
               R (push 4 NIL ZERO NIL)  # [cnt last name link]
               C T )
            (link (ofs R 2))
            (while (setq C (symChar P))
               (when (isLetterOrDigit C)
                  (charSym (toLowerCase C) R)
                  (? (=0 (dec 'N))) ) )
            (consStr (val 3 R)) ) ) ) )
