initial commit

crypto/fift/lib/Fift.fif

@@ -0,0 +1,83 @@
+{ 0 word drop 0 'nop } :: //
+{ char " word 1 { swap { abort } if drop } } ::_ abort"
+{ { bl word dup "" $= abort"comment extends after end of file" "*/" $= } until 0 'nop } :: /*
+// { bl word 1 2 ' (create) } "::" 1 (create)
+// { bl word 0 2 ' (create) } :: :
+// { bl word 2 2 ' (create) } :: :_
+// { bl word 3 2 ' (create) } :: ::_
+// { bl word 0 (create) } : create
+// { bl word (forget) } : forget
+{ bl word 1 ' (forget) } :: [forget]
+{ char " word 1 ' type } ::_ ."
+{ swap ({) over 2+ -roll swap (compile) (}) } : does
+{ 1 'nop does create } : constant
+{ 2 'nop does create } : 2constant
+{ hole constant } : variable
+10 constant ten
+{ bl word 1 { find 0= abort"word not found" } } :: (')
+{ bl word find not abort"-?" 0 swap } :: [compile]
+{ bl word 1 { 
+  dup find { " -?" $+ abort } ifnot nip execute
+} } :: @'
+{ bl word 1 { swap 1 'nop does swap 0 (create) }
+} :: =:
+{ bl word 1 { -rot 2 'nop does swap 0 (create) }
+} :: 2=:
+{ <b swap s, b> } : s>c
+{ s>c hash } : shash
+// to be more efficiently re-implemented in C++ in the future
+{ dup 0< ' negate if } : abs
+{ 2dup > ' swap if } : minmax
+{ minmax drop } : min
+{ minmax nip } : max
+"" constant <#
+' $reverse : #>
+{ swap 10 /mod char 0 + rot swap hold } : #
+{ { # over 0<= } until } : #s
+{ 0< { char - hold } if } : sign
+// { dup abs <# #s rot sign #> nip } : (.)
+// { (.) type } : ._
+// { ._ space } : .
+{ bl (-trailing) } : -trailing
+{ char 0 (-trailing) } : -trailing0
+{ char " word 1 ' $+ } ::_ +"
+{ find 0<> dup ' nip if } : (def?)
+{ bl word 1 ' (def?) } :: def?
+{ bl word 1 { (def?) not } } :: undef?
+{ def? ' skip-to-eof if } : skip-ifdef
+{ bl word dup (def?) { drop skip-to-eof } { 'nop swap 0 (create) } cond } : library
+{ bl word dup (def?) { 2drop skip-to-eof } { swap 1 'nop does swap 0 (create) } cond } : library-version
+{ char ) word "$" swap $+ 1 { find 0= abort"undefined parameter" execute } } ::_ $(
+// b s -- ?
+{ sbitrefs rot brembitrefs rot >= -rot <= and } : s-fits?
+{ 0 swap ! } : 0!
+{ tuck @ + swap ! } : +!
+{ tuck @ swap - swap ! } : -!
+{ 1 swap +! } : 1+!
+{ -1 swap +! } : 1-!
+{ null swap ! } : null!
+0 tuple constant nil
+{ 1 tuple } : single
+{ 2 tuple } : pair
+{ 3 tuple } : triple
+{ 1 untuple } : unsingle
+{ 2 untuple } : unpair
+{ 3 untuple } : untriple
+{ over tuple? { swap count = } { 2drop false } cond } : tuple-len?
+{ 0 tuple-len? } : nil?
+{ 1 tuple-len? } : single?
+{ 2 tuple-len? } : pair?
+{ 3 tuple-len? } : triple?
+{ 0 [] } : first
+{ 1 [] } : second
+{ 2 [] } : third
+' pair : cons
+' unpair : uncons
+{ 0 [] } : car
+{ 1 [] } : cdr
+{ cdr car } : cadr
+{ cdr cdr } : cddr
+{ cdr cdr car } : caddr
+{ null ' cons rot times } : list
+{ true (atom) drop } : atom
+{ bl word atom 1 'nop } ::_ `

crypto/fift/lib/Lisp.fif

@@ -0,0 +1,436 @@
+library Lisp  // tiny Lisp (or rather Scheme) interpreter
+"Lists.fif" include
+variable lisp-dict
+{ hole dup 1 { @ execute } does create } : recursive
+{ atom>$ +" undefined" abort } : report-not-found
+// a l -- d -1 or a 0  Look up definition d of atom a in dictionary l
+{ { dup null? { drop false true }
+    { uncons -rot unpair -rot over eq?
+      { drop nip true true } { nip swap false } cond
+    } cond
+  } until
+} : lookup-in
+// a dict -- def
+{ lookup-in ' report-not-found ifnot } : lookup-or-fail
+{ lisp-dict @ lookup-or-fail } : lisp-dict-lookup
+// a d --  Defines a with definition d in dictionary lisp-dict
+{ pair lisp-dict @ cons lisp-dict ! } : lisp-dict-int-define
+{ box lisp-dict-int-define } : lisp-dict-define
+// a d -- Defines new a with defininition d
+{ over lisp-dict @ lookup-in { 2drop atom>$ +" already defined" abort }
+  { drop lisp-dict-int-define } cond
+} : lisp-dict-int-define-new
+{ box lisp-dict-int-define-new } : lisp-dict-define-new
+// a e -- Defines a with executable definition given by e
+{ single lisp-dict-define-new } : lisp-dict-define-exec
+// expr ctx def -- val
+{ dup first execute } : run-definition
+// expr ctx -- val
+recursive lisp-ctx-eval {
+  over tuple?
+  { over first over lisp-ctx-eval run-definition }
+  { over atom? { lookup-or-fail @ } { drop } cond }
+  cond
+} swap !
+// exp -- value
+{ lisp-dict @ lisp-ctx-eval } : lisp-eval
+// (exprs) ctx -- (vals)
+recursive lisp-ctx-eval-list
+{ over null? { drop } {
+  swap uncons -rot over lisp-ctx-eval -rot lisp-ctx-eval-list cons
+  } cond 
+} swap !
+// (exprs) ctx -- val
+{ null rot {
+  dup null? { drop nip true } {
+  nip uncons swap 2 pick lisp-ctx-eval swap false
+  } cond } until
+} : lisp-ctx-eval-list-last
+// l c -- (args)
+{ swap uncons nip swap lisp-ctx-eval-list } : extract-eval-arg-list
+{ drop uncons nip } : extract-arg-list
+// (x1 .. xn) e n -- x1 .. xn e
+{ { swap uncons rot } swap times
+  swap null? not abort"invalid number of arguments"
+} : unpack-list
+// l c n e -- v
+{ swap 2swap extract-eval-arg-list  // e n (args)
+  -rot unpack-list execute
+} : eval-exec-fixed
+// l c n e -- v
+{ 2 pick pair
+  swap 2swap extract-arg-list  // [e c] n (args)
+  -rot unpack-list unpair swap execute
+} : exec-fixed
+// l c e -- v
+{ -rot extract-eval-arg-list  // e (args)
+  swap execute
+} : eval-exec-list
+{ -rot tuck extract-arg-list  // e c (args)
+  swap rot execute
+} : exec-list
+// e a n --
+{ rot 2 {  // expr ctx def n e
+    rot drop eval-exec-fixed } does
+  lisp-dict-define-exec
+} : lisp-fixed-primitive
+{ rot 2 { rot drop exec-fixed } does lisp-dict-define-exec
+} : lisp-fixed-lazy-primitive
+// e a --
+{ swap 1 { nip eval-exec-list } does lisp-dict-define-exec
+} : lisp-primitive
+{ swap 1 { nip exec-list } does lisp-dict-define-exec
+} : lisp-lazy-primitive
+
+// Uncomment next line for Fift booleans
+// false constant #f  true constant #t  null constant no-answer
+// Uncomment next line for Scheme booleans
+`#f constant #f  `#t constant #t  #f constant no-answer
+{ #f eq? } : lisp-false?
+{ lisp-false? 0= } : lisp-true?
+{ ' #t ' #f cond } : lisp-bool
+
+// temp for defining a lot of primitives
+{ bl word atom lisp-primitive } : L:
+{ bl word atom swap lisp-dict-define } : L=:
+{ bl word atom swap lisp-fixed-primitive } : #L:
+{ 0 #L: } : 0L:
+{ 1 #L: } : 1L:
+{ 2 #L: } : 2L:
+
+// basic primitives
+{ sum-list } L: +
+{ - } 2L: -
+{ dup null? { drop 1 } { ' * foldl-ne } cond } L: *
+{ / } 2L: /
+{ mod } 2L: modulo
+{ abs } 1L: abs
+{ ' min foldl-ne } L: min
+{ ' max foldl-ne } L: max
+{ true ' and foldl } L: integer-and
+{ false ' or foldl } L: integer-or
+{ 0 ' xor foldl } L: integer-xor
+{ not } 1L: integer-not
+{ = lisp-bool } 2L: =
+{ <> lisp-bool } 2L: <>
+{ < lisp-bool } 2L: <
+{ <= lisp-bool } 2L: <=
+{ > lisp-bool } 2L: >
+{ >= lisp-bool } 2L: >=
+{ eq? lisp-bool } 2L: eq?
+{ eqv? lisp-bool } 2L: eqv?
+{ equal? lisp-bool } 2L: equal?
+{ cons } 2L: cons
+{ car } 1L: car
+{ cdr } 1L: cdr
+{ cadr } 1L: cadr
+{ cddr } 1L: cddr
+{ caddr } 1L: caddr
+{ cdr cddr } 1L: cdddr
+{ concat-list-lists } L: append
+{ list-reverse } 1L: reverse
+{ list-tail } 2L: list-tail
+{ list-ref } 2L: list-ref
+{ list-member-eq } 2L: memq
+{ list-member-eqv } 2L: memv
+{ list-member-equal } 2L: member
+{ assq ' #f ifnot } 2L: assq
+{ assv ' #f ifnot } 2L: assv
+{ assoc ' #f ifnot } 2L: assoc
+{ list? lisp-bool } 1L: list?
+{ pair? lisp-bool } 1L: pair?
+{ tuple? lisp-bool } 1L: tuple?
+{ string? lisp-bool } 1L: string?
+{ integer? lisp-bool } 1L: integer?
+{ integer? lisp-bool } 1L: number?
+{ count } 1L: width
+{ list-length } 1L: length
+{ [] } 2L: tuple-ref
+{ first } 1L: first
+{ second } 1L: second
+{ third } 1L: third
+{ 3 [] } 1L: fourth
+{ list>tuple } 1L: list->tuple
+{ explode list } 1L: tuple->list
+null L=: null
+{ atom? lisp-bool } 1L: symbol?
+{ atom } 1L: string->symbol
+{ atom>$ } 1L: symbol->string
+{ dup #f eq? swap #t eq? or lisp-bool } 1L: boolean?
+#t L=: else
+#f L=: #f
+#t L=: #t
+{ null? lisp-bool } 1L: null?
+{ 0= lisp-bool } 1L: zero?
+{ 0> lisp-bool } 1L: positive?
+{ 0< lisp-bool } 1L: negative?
+{ 1 and 0= lisp-bool } 1L: even?
+{ 1 and 0<> lisp-bool } 1L: odd?
+{ bye } 0L: exit
+{ .l null } 1L: write
+{ lisp-eval } 1L: eval
+{ drop } `quote 1 lisp-fixed-lazy-primitive
+'nop L: list
+{ list>tuple } L: tuple
+{ list-last } L: begin
+{ $len } 1L: string-length
+{ concat-string-list } L: string-append
+{ $= lisp-bool } 2L: string=?
+{ $cmp 0< lisp-bool } 2L: string<?
+{ $cmp 0<= lisp-bool } 2L: string<=?
+{ $cmp 0> lisp-bool } 2L: string>?
+{ $cmp 0>= lisp-bool } 2L: string>=?
+{ (number) dup 1 = { drop } { ' 2drop if no-answer } cond
+} 1L: string->number
+{ (.) } 1L: number->string
+{ box? lisp-bool } 1L: box?
+{ box } 1L: box
+{ hole } 0L: new-box
+{ @ } 1L: unbox
+{ tuck swap ! } 2L: set-box!
+{ abort } 1L: error
+{ dup find { nip execute } { +" -?" abort } cond } : find-execute
+{ explode-list 1- roll find-execute } L: fift-exec
+{ explode-list dup 1- swap roll find-execute } L: fift-exec-cnt
+{ uncons swap find-execute } L: fift-exec-list
+// end of basic primitives
+forget L:  forget #L:  forget L=:
+forget 0L:  forget 1L:  forget 2L:
+
+{ { dup tuple? ' do-quote if } list-map } : map-quote
+{ uncons ' cons foldr-ne map-quote
+  null swap cons lisp-dict @ rot run-definition
+} `apply lisp-primitive  // bad: should have preserved original context
+// e1 e2 e3 ctx
+{ 3 exch 3 pick lisp-ctx-eval lisp-true? ' swap if nip swap lisp-ctx-eval }
+`if 3 lisp-fixed-lazy-primitive
+// (e) ctx
+{ #t -rot 
+  { over null? { 2drop true } {
+    swap uncons swap 2 pick lisp-ctx-eval dup lisp-true? // v' c t v ?
+    { swap 2swap nip false } { -rot 2drop nip true } cond
+  } cond } until
+} `and lisp-lazy-primitive
+{ #f -rot
+  { over null? { 2drop true } {
+    swap uncons swap 2 pick lisp-ctx-eval dup lisp-false? // v' c t v ?
+    { swap 2swap nip false } { -rot 2drop nip true } cond
+  } cond } until
+} `or lisp-lazy-primitive
+{ lisp-false? lisp-bool } `not 1 lisp-fixed-primitive
+// cond-clause ctx -- v -1 or 0
+{ swap uncons -rot dup `else eq? {
+  drop lisp-ctx-eval-list-last true } {
+  over lisp-ctx-eval lisp-true? {
+  lisp-ctx-eval-list-last true } {
+  2drop false
+  } cond } cond
+} : eval-cond-clause
+// (clauses) ctx -- v
+{ { over null? { no-answer true } {
+    swap uncons -rot over eval-cond-clause } cond 
+  } until -rot 2drop
+} `cond lisp-lazy-primitive
+{ lisp-dict @ lookup-in { hole tuck lisp-dict-int-define } ifnot
+} : lisp-create-global-var
+// a e ctx  -- old (simple) define
+{ drop over atom? not abort"only a variable can be define'd"
+  over lisp-create-global-var swap lisp-eval swap ! 
+} drop // `define 2 lisp-fixed-lazy-primitive
+{ tuck lisp-ctx-eval rot dup atom? not abort"only a variable can be set"
+  rot lookup-or-fail dup @ -rot !
+} `set! 2 lisp-fixed-lazy-primitive
+// define lambda
+{ { dup null? { drop true true }
+    { uncons swap atom? { false } { drop false true } cond } cond
+  } until
+} : var-list?
+{ { dup null? over atom? or { drop true true }
+    { uncons swap atom? { false } { drop false true } cond } cond
+  } until
+} : lambda-var-list?
+// (quote x) -- x -1 ; else 0
+{ dup pair? { uncons swap `quote eq? { car true } { drop false } cond }
+  { drop false } cond
+} : is-quote?
+recursive match-arg-list-acc
+// l (vars) (args) -- ((var . arg) ...)+l -1 or ? 0
+{ over atom? { over `_ eq? { 2drop } { pair swap cons } cond true } { 
+  over null? { nip null? } { // (vars) (args)
+  over tuple? not { 2drop false } {
+  over is-quote? { eq? nip } { // (v) (a)
+  dup tuple? not { 2drop false } {
+  over count over count over <> { drop 2drop false } { // l [v] [a] n
+  3 roll 0 rot { // [v] [a] l i
+    dup 0< {
+      3 pick over [] swap  // [v] [a] l vi i
+      3 pick over [] 2swap rot // [v] [a] i l vi ai
+      match-arg-list-acc { // [v] [a] i l'
+        swap 1+ } { nip -1 } cond
+    } ifnot
+  } swap times
+  2swap 2drop 0>=
+  } cond } cond } cond } cond } cond } cond
+} swap !
+{ null -rot match-arg-list-acc } : match-arg-list
+// ((var . arg)...) ctx -- ctx'
+{ { over null? not }
+  { swap uncons swap unpair box pair rot cons } while
+  nip
+} : extend-ctx-by-list
+// ((vars) body) ctx
+{ swap uncons -rot 
+  dup lambda-var-list? not abort"invalid formal parameter list"
+  { // l-expr ctx' [_ body ctx (vars)]
+    -rot 2 pick 3 [] swap rot  // [_ body ...] (vars) ctx' l-expr
+    uncons nip swap lisp-ctx-eval-list  // [_ body ...] (vars) (arg-vals)
+    match-arg-list not abort"invalid arguments to lambda" // [_ body ...] ((var arg)...)
+    over third extend-ctx-by-list // [_ body ctx (vars)] ctx''
+    swap second swap lisp-ctx-eval-list-last
+  } 3 -roll 4 tuple
+} : make-lambda
+{ make-lambda } `lambda lisp-lazy-primitive
+// (a e) ctx -- more sophisticated (define a e)
+{ drop uncons swap dup atom? { // (e) a 
+    tuck lisp-create-global-var
+    swap lisp-dict @ lisp-ctx-eval-list-last swap !
+  } { // (e) (a v..)
+    uncons over atom? not abort"only variables can be define'd"  // (e) a (v..)
+    rot cons over lisp-create-global-var   // a ((v..) (e)) h
+    swap lisp-dict @ make-lambda swap !
+  } cond
+} `define lisp-lazy-primitive
+// ((x e) ..) ctx -- ((x.v) ..)
+recursive eval-assign-list
+{ over null? { drop } {
+  swap uncons swap uncons // ctx t x (e)
+  over atom? not abort"invalid variable name in assignment list"
+  3 pick lisp-ctx-eval-list-last  // ctx t x v
+  pair swap rot eval-assign-list cons
+  } cond
+} swap !
+// (((x v) ..) body) ctx  -- let construct
+{ swap uncons swap 2 pick eval-assign-list  // ctx body ((x v)...)
+  rot extend-ctx-by-list lisp-ctx-eval-list-last
+} `let lisp-lazy-primitive
+// ((x e) ..) ctx -- ctx'
+{ swap {
+  dup null? { drop true } {
+  uncons swap uncons  // ctx t x (e)
+  over atom? not abort"invalid variable name in assignment list"
+  3 pick lisp-ctx-eval-list-last  // ctx t x v
+  box pair rot cons swap false
+  } cond } until
+} : compute-let*-ctx
+// (((x v) ..) body) ctx  -- let* construct
+{ swap uncons swap rot compute-let*-ctx lisp-ctx-eval-list-last
+} `let* lisp-lazy-primitive
+// ((x e) ..) ctx -- ((h e) ..) ctx' , with x bound to h in ctx'
+recursive prepare-letrec-ctx {
+  over null? {
+  swap uncons swap uncons swap // ctx t (e) x
+  hole tuck pair swap rot cons // ctx t (x.h) (h e)
+  3 -roll rot cons prepare-letrec-ctx // (h e) t ctx'
+  -rot cons swap
+  } ifnot
+} swap !
+// (((x v) ..) body) ctx  -- letrec construct
+{ swap uncons swap rot prepare-letrec-ctx swap { // body ctx' ((h e)..)
+    dup null? { drop true } {
+    uncons -rot uncons 2 pick lisp-ctx-eval-list-last // body t ctx' h v
+    swap ! swap false
+  } cond } until
+  lisp-ctx-eval-list-last
+} `letrec lisp-lazy-primitive
+// (e (p e)...) ctx -- match construct
+{ swap uncons swap 2 pick lisp-ctx-eval swap { // ctx v ((p e)..)
+  dup null? { drop 2drop no-answer true } {
+  uncons swap uncons swap 3 pick // ctx v t e p v
+  match-arg-list { // ctx v t e ((x' . v')...)
+  2swap 2drop rot extend-ctx-by-list lisp-ctx-eval-list-last true } {
+  2drop false
+  } cond } cond } until
+} `match lisp-lazy-primitive
+//
+lisp-dict @ constant original-lisp-dict
+{ original-lisp-dict lisp-dict ! } : reset-lisp
+{ ' drop { lisp-eval .l cr } List-generic( } :_ LISP-EVAL-PRINT(
+// LISP-EVAL-PRINT((+ 3 4) (* 5 6)) computes and prints 12 and 30
+{ hole dup 1 { @ nip } does swap 
+  1 { swap lisp-eval swap ! } does 
+  List-generic(
+} :_ LISP-EVAL(
+// LISP-EVAL((+ 3 4) (* 5 6)) computes 12 and 30, returns only 30
+// /*
+LISP-EVAL-PRINT(
+  (define succ (lambda (x) (+ x 1)))
+  (define (twice f) (lambda (x) (f (f x))))
+  (define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
+  (fact ((twice succ) 5))
+  (define compare (lambda (x y) (cond ((< x y) 'less) ((= x y) 'equal) (else 'greater))))
+  (compare 2 3)
+  (compare 7 (+ 2 3))
+  (define next (let ((cnt 0)) (lambda () (set! cnt (+ cnt 1)) cnt)))
+  (list (next) (next))
+  (define new-counter (lambda () (let ((x 0)) (lambda () (set! x (+ x 1)) x))))
+  (define c1 (new-counter))
+  (define c2 (new-counter))
+  (list (c1) (c1) (c2) (c1) (c2) (c1) (c1) (c2) (c2))
+  (let* ((x (+ 2 3)) (y (* x x)) (z (+ x y))) (list x y z))
+  (letrec ((even? (lambda (n) (if (= n 0) #t (odd? (- n 1)))))
+           (odd?  (lambda (n) (if (= n 0) #f (even? (- n 1))))))
+          (even? 88))
+  (define (len l) (if (null? l) 0 (+ 1 (len (cdr l)))))
+  (len '(2 3 9))
+  (define (len2 l) (match l (() 0) ((x . t) (+ 1 (len2 t)))))
+  (len2 '(2 3 9))
+  (define (foo x) (match x
+     (('zero) 0)
+     (('succ x) (+ (foo x) 1))
+     (('plus x y) (+ (foo x) (foo y)))
+     (('minus x y) (- (foo x) (foo y)))
+     (x x)))
+  (foo '(plus (succ (zero)) (minus (succ (succ 5)) 3)))
+  (define (bar x) (match x
+     (['zero] 0)
+     (['succ x] (+ (bar x) 1))
+     (['plus x y] (+ (bar x) (bar y)))
+     (['minus x y] (- (bar x) (bar y)))
+     (['const x] x)))
+  (bar '[plus [succ [zero]] [minus [succ [succ [const 5]]] [const 3]]])
+  (define (map f l) (letrec
+    ((map-f (lambda (l) (match l
+      (() ())
+      ((h . t) (cons (f h) (map-f t)))))))
+    (map-f l)))
+  (map (lambda (x) (* x (+ 2 x))) '(2 3 9))
+  (define (make-promise proc) (let ((result-ready? #f) (result #f))
+    (lambda ()
+      (if result-ready? result
+        (let ((x (proc)))
+	  (if result-ready? result
+	    (begin (set! result x) (set! result-ready? #t) result)))))))
+  (define (force promise) (promise))
+)
+// */
+// words for invoking Lisp definitions from Fift
+// (args) def -- val
+{ null rot map-quote cons lisp-dict @ rot run-definition
+} : invoke-lisp-definition
+{ atom lisp-dict-lookup 1 { @ invoke-lisp-definition }
+} : (invoke-lisp)
+{ bl word (invoke-lisp) } :: invoke-lisp
+// ( 2 3 ) invoke-lisp compare .l
+{ atom lisp-dict-lookup 2 { @ mklist-1 invoke-lisp-definition }
+} : (invoke-lisp-fixed)
+{ bl word (invoke-lisp-fixed) } :: invoke-lisp-fixed
+// 9 8  2 invoke-lisp-fixed compare .l
+{ bl word (invoke-lisp) does } : make-lisp-invoker
+{ bl word (invoke-lisp-fixed) does } : make-lisp-fixed-invoker
+// 2 make-lisp-fixed-invoker compare : compare
+// 3 9 compare
+// import Lisp definitions as Fift words
+{ bl word dup (invoke-lisp) does swap 0 (create) } : import-lisp
+{ bl word tuck (invoke-lisp-fixed) does swap 0 (create) } : import-lisp-fixed
+// 1 import-lisp-fixed fact
+// 7 fact .

crypto/fift/lib/Lists.fif

@@ -0,0 +1,184 @@
+library Lists  // List utilities
+//
+{ hole dup 1 { @ execute } does create } : recursive
+// x x' -- ?  recursively compares two S-expressions
+recursive equal? {
+  dup tuple? {
+    over tuple? {
+      over count over count over = { // t t' l ?
+        0 { dup 0>= { 2dup [] 3 pick 2 pick [] equal? { 1+ } { drop -1 } cond
+            } if } rot times
+        nip nip 0>=
+      } { drop 2drop false } cond
+    } { 2drop false } cond
+  } { eqv? } cond
+} swap !
+// (a1 .. an) -- (an .. a1)
+{ null swap { dup null? not } { uncons swap rot cons swap } while drop } : list-reverse
+// (a1 .. an) -- an   Computes last element of non-empty list l
+{ { uncons dup null? { drop true } { nip false } cond } until } : list-last
+// l l' -- l++l'  Concatenates two lists
+recursive list+ {
+  over null? { nip } { swap uncons rot list+ cons } cond
+} swap !
+// l l' -- l'' -1 or 0, where l = l' ++ l''
+// Removes prefix from list
+{ { dup null? { drop true true } {
+  swap dup null? { 2drop false true } { // l' l
+  uncons swap rot uncons -rot equal? { false } {
+  2drop false true
+  } cond } cond } cond } until
+} : list-
+// (a1 .. an) -- a1 .. an n   Explodes a list
+{ 0 { over null? not } { swap uncons rot 1+ } while nip } : explode-list
+// (a1 .. an) x -- a1 .. an n x   Explodes a list under the topmost element
+{ swap explode-list dup 1+ roll } : explode-list-1
+// l -- t   Transforms a list into a tuple with the same elements
+{ explode-list tuple } : list>tuple
+// a1 ... an n x -- (a1 .. an) x
+{ null swap rot { -rot cons swap } swap times } : mklist-1
+// (s1 ... sn) -- s1+...+sn   Concatenates a list of strings
+{ "" { over null? not } { swap uncons -rot $+ } while nip
+} : concat-string-list
+// (x1 ... xn) -- x1+...+xn   Sums a list of integers
+{ 0 { over null? not } { swap uncons -rot + } while nip
+} : sum-list
+// (a1 ... an) a e -- e(...e(e(a,a1),a2),...),an)
+{ -rot { over null? not } { swap uncons -rot 3 pick execute } while nip nip
+} : foldl
+// (a1 ... an) e -- e(...e(e(a1,a2),a3),...),an)
+{ swap uncons swap rot foldl } : foldl-ne
+// (a1 ... an) a e -- e(a1,e(a2,...,e(an,a)...))
+recursive foldr {
+  rot dup null? { 2drop } {
+    uncons -rot 2swap swap 3 pick foldr rot execute
+  } cond
+} swap !
+// (a1 ... an) e -- e(a1,e(a2,...,e(a[n-1],an)...))
+recursive foldr-ne {
+  over cdr null? { drop car } {
+    swap uncons 2 pick foldr-ne rot execute
+  } cond
+} swap !
+// (l1 ... ln) -- l1++...++ln   Concatenates a list of lists
+{ dup null? { ' list+ foldr-ne } ifnot } : concat-list-lists
+// (a1 .. an . t) n -- t   Computes the n-th tail of a list
+{ ' cdr swap times } : list-tail
+// (a0 .. an ..) n -- an   Computes the n-th element of a list
+{ list-tail car } : list-ref
+// l -- ?
+{ { dup null? { drop true true } {
+    dup pair? { cdr false } {
+    drop false true
+  } cond } cond } until
+} : list?
+// l -- n
+{ 0 { over null? not } { 1+ swap uncons nip swap } while nip
+} : list-length
+// l e -- t  // returns tail of l after first member that satisfies e
+{ swap {
+  dup null? { nip true } {
+  tuck car over execute { drop true } {
+  swap cdr false
+  } cond } cond } until
+} : list-tail-from
+// a l -- t  // tail of l after first occurence of a using eq?
+{ swap 1 ' eq? does list-tail-from } : list-member-eq
+{ swap 1 ' eqv? does list-tail-from } : list-member-eqv
+{ swap 1 ' equal? does list-tail-from } : list-member-equal
+// a l -- ?
+{ list-member-eq null? not } : list-member?
+{ list-member-eqv null? not } : list-member-eqv?
+// l -- a -1 or 0 // returns car l if l is non-empty
+{ dup null? { drop false } { car true } cond
+} : safe-car
+{ dup null? { drop false } { car second true } cond
+} : get-first-value
+// l e -- v -1 or 0
+{ list-tail-from safe-car } : assoc-gen
+{ list-tail-from get-first-value } : assoc-gen-x
+// a l -- (a.v) -1 or 0 -- returns first entry (a . v) in l
+{ swap 1 { swap first eq? } does assoc-gen } : assq
+{ swap 1 { swap first eqv? } does assoc-gen } : assv
+{ swap 1 { swap first equal? } does assoc-gen } : assoc
+// a l -- v -1 or 0 -- returns v from first entry (a . v) in l
+{ swap 1 { swap first eq? } does assoc-gen-x } : assq-val
+{ swap 1 { swap first eqv? } does assoc-gen-x } : assv-val
+{ swap 1 { swap first equal? } does assoc-gen-x } : assoc-val
+// (a1 .. an) e -- (e(a1) .. e(an))
+recursive list-map {
+  over null? { drop } {
+  swap uncons -rot over execute -rot list-map cons
+  } cond
+} swap !
+//
+// create Lisp-style lists using words "(" and ")"
+//
+variable ')
+'nop box constant ',
+{ ") without (" abort } ') ! 
+{ ') @ execute } : )
+anon constant dot-marker
+// m x1 ... xn t m -- (x1 ... xn . t)
+{ swap
+  { -rot 2dup eq? not }
+  { over dot-marker eq? abort"invalid dotted list"
+    swap rot cons } while 2drop
+} : list-tail-until-marker
+// m x1 ... xn m -- (x1 ... xn)
+{ null swap list-tail-until-marker } : list-until-marker
+{ over dot-marker eq? { nip 2dup eq? abort"invalid dotted list" }
+  { null swap } cond
+  list-tail-until-marker
+} : list-until-marker-ext
+{ ') @ ', @ } : ops-get
+{ ', ! ') ! } : ops-set
+{ anon dup ops-get 3 { ops-set list-until-marker-ext } does ') ! 'nop ', !
+} : (
+// test of Lisp-style lists
+// ( 42 ( `+ 9 ( `* 3 4 ) ) "test" ) .l cr
+// ( `eq? ( `* 3 4 ) 3 4 * ) .l cr
+// `alpha ( `beta `gamma `delta ) cons .l cr
+// { ( `eq? ( `* 3 5 pick ) 3 4 roll * ) } : 3*sample
+// 17 3*sample .l cr
+
+// similar syntax _( x1 .. xn ) for tuples
+{ 2 { 1+ 2dup pick eq? } until 3 - nip } : count-to-marker
+{ count-to-marker tuple nip } : tuple-until-marker
+{ anon dup ops-get 3 { ops-set tuple-until-marker } does ') ! 'nop ', ! } : _(
+// test of tuples
+// _( _( 2 "two" ) _( 3 "three" ) _( 4 "four" ) ) .dump cr
+
+// pseudo-Lisp tokenizer
+"()[]'" 34 hold constant lisp-delims
+{ lisp-delims 11 (word) } : lisp-token
+{ null cons `quote swap cons } : do-quote
+{ 1 { ', @ 2 { 2 { ', ! execute ', @ execute } does ', ! }
+      does ', ! } does
+} : postpone-prefix
+{ ', @ 1 { ', ! } does ', ! } : postpone-',
+( `( ' ( pair
+  `) ' ) pair
+  `[ ' _( pair
+  `] ' ) pair
+  `' ' do-quote postpone-prefix pair
+  `. ' dot-marker postpone-prefix pair
+  `" { char " word } pair
+  `;; { 0 word drop postpone-', } pair
+) constant lisp-token-dict
+variable eol
+{ eol @ eol 0! anon dup ') @ 'nop 3
+  { ops-set list-until-marker-ext true eol ! } does ') ! rot ', !
+  { lisp-token dup (number) dup { roll drop } {
+      drop atom dup lisp-token-dict assq { nip second execute } if
+    } cond
+    ', @ execute
+    eol @
+  } until
+  -rot eol ! execute
+} :_ List-generic(
+{ 'nop 'nop List-generic( } :_ LIST(
+// LIST((lambda (x) (+ x 1)) (* 3 4))
+// LIST('(+ 3 4))
+// LIST(2 3 "test" . 9)
+// LIST((process '[plus 3 4]))

crypto/fift/lib/Stack.fif

@@ -0,0 +1,266 @@
+library Stack  // advanced stack manupulation library
+"Lists.fif" include
+// S(a b c - a c 2 a b) would compile to code performing the requested stack manipulation
+
+// interface to low-level stack manipulation primitives
+{ (number) 1- abort"index expected" dup 0 < over 255 > or
+  abort"index 0..255 expected"
+} : (idx)
+// push(n) : a0 .. an - a0 .. an a0  equivalent to "n pick"
+// push(0) = dup, push(1) = over
+{ 0 char ) word (idx) <push> } ::_ push(
+// pop(n) : a0 a1 .. a(n-1) an - an a1 .. a(n-1)
+// pop(0) = drop, pop(1) = nip
+{ 0 char ) word (idx) <pop> } ::_ pop(
+// xchg(i,j) : equivalent to "i j exch2"
+{ 0 char , word (idx) char ) word (idx) <xchg> } ::_ xchg(
+// xchg0(i) : equivalent to "i exch" or "xchg(0,i)"
+// xchg0(1) = swap
+{ 0 char ) word (idx) 0 <xchg> } ::_ xchg0(
+forget (idx)
+
+// parser for stack notation expressions
+")" 34 hold +"  -" constant stk-delims
+anon constant stk-start
+anon constant stk-to
+variable stk-mode
+{ stk-delims 11 (word) } : stk-token
+'nop : mk-lit
+// stk-start vn ... v0 -- stk-start ... v0 i  where v[i]=v0
+{ 0 {
+  1+ 2dup 2+ pick dup stk-start eq? { 2drop drop 0 true } { eqv? } cond
+  } until
+} : stk-lookup
+// stk-start a1 .. an stk-to b1 .. bm -- [a1 .. an] [b1 .. bm]
+{ stk-mode @ 0= abort"identifier expected" } : chk-lit
+{ stk-to list-until-marker stk-mode !
+  stk-start list-until-marker stk-mode @
+  stk-mode 0!
+} : build-stk-effect
+{ stk-start stk-mode 0! {
+  stk-token dup ")" $= { drop true } {
+  dup "-" $= {
+    drop stk-mode @ abort"duplicate -" true stk-mode ! stk-to false } {
+  dup 34 chr $= { chk-lit drop char " word mk-lit false } {
+  dup (number) ?dup { chk-lit 1- { swap mk-lit -rot } if mk-lit nip false } {
+  atom dup `_ eq? { stk-mode @ abort"identifier expected" false } {
+  stk-lookup 0= stk-mode @ = {
+    stk-mode @ { atom>$ +" -?" } { atom>$ +" redefined" } cond abort } {
+  false
+  } cond } cond } cond } cond } cond } cond } until
+  stk-mode @ 0= abort"'-' expected"
+  build-stk-effect
+} :_ parse-stk-list(
+
+// stack operation list construction
+variable op-rlist
+{ op-rlist null! } : clear-op-list
+{ op-rlist @ list-reverse } : get-op-list
+{ op-rlist @ cons op-rlist ! } : issue-op
+{ minmax `xchg -rot triple } : op-xchg
+{ `push swap pair } : op-push
+{ `lit swap pair } : op-lit
+{ `pop swap pair } : op-pop
+0 op-pop constant op-drop
+{ 2dup <> { op-xchg issue-op } if } : issue-xchg
+{ op-push issue-op } : issue-push
+{ op-lit issue-op } : issue-lit
+{ op-pop issue-op } : issue-pop
+{ op-drop issue-op } : issue-drop
+{ ' issue-drop swap times } : issue-drop-#
+
+// emulated stack contents
+variable emul-stk
+{ emul-stk @ count } : emul-depth
+{ emul-depth 1- swap - } : adj-i
+{ emul-depth 1- tuck swap - swap rot - swap } : adj-ij
+// i j --
+{ adj-ij 2dup emul-stk @ tuck swap [] swap rot [] rot // i sj si j
+  emul-stk @ -rot []= swap rot []= emul-stk !
+} : emul-xchg
+{ emul-stk @ tpop drop emul-stk ! } : emul-drop
+// i --
+{ 0 emul-xchg emul-drop } : emul-pop
+// i -- s[i]
+{ emul-stk @ swap [] } : emul-stk[]
+// i -- si
+{ adj-i emul-stk[] } : emul-get
+{ 0 emul-get } : emul-tos
+// v i -- ?   Check whether s[i]=v
+{ dup emul-depth < { emul-stk[] eqv? } { 2drop false } cond } : emul[]-eq?
+// v -- i or -1   Returns maximum i with s[i]=v
+{ emul-stk @ dup count { // v s i
+  ?dup 0= { -1 true } { 1- 2dup [] 3 pick eqv? } cond  // v s i' ?
+  } until nip nip
+} : emul-stk-lookup-rev
+// i --
+{ emul-get emul-stk @ swap , emul-stk ! } : emul-push
+{ emul-stk @ swap , emul-stk ! } : emul-lit
+// show emulated stack contents similarly to .s
+{ emul-stk @ explode dup 1 reverse ' .l swap times cr } : .e
+
+// both issue an operation and emulate it
+{ 2dup issue-xchg emul-xchg } : issue-emul-xchg
+{ dup issue-push emul-push } : issue-emul-push
+{ dup issue-lit emul-lit } : issue-emul-lit
+{ dup issue-pop emul-pop } : issue-emul-pop
+{ issue-drop emul-drop } : issue-emul-drop
+{ ' issue-emul-drop swap times } : issue-emul-drop-#
+
+// b.. s -- b.. s   moves tos value to stk[s]
+{ dup emul-stk[] 2 pick cdr list-member-eqv? {
+  dup adj-i 0 issue-emul-xchg } { dup adj-i issue-emul-pop } cond
+} : move-tos-to
+
+// new s -- ops registered
+{ { over null? not } {
+  // .sl .e get-op-list .l cr 
+  // get-op-list list-length 100 > abort"too long"
+  emul-depth over >
+    { over emul-tos swap list-member-eqv? not } { false } cond {
+  // b.. s  tos unneeded
+  issue-emul-drop } {
+  over car // b.. s b1
+  2dup swap emul[]-eq? { drop swap cdr swap 1+ } {
+  dup emul-stk-lookup-rev // b.. s b1 i
+  dup 0< { // b.. s b1 i  not found, must be a literal
+    drop dup atom? abort"unavailable value"
+    issue-emul-lit } {
+  dup 3 pick < { // b.. s b1 i  found in bottom s stack values
+    nip adj-i issue-emul-push  // b.. s
+    dup emul-depth 1- < { move-tos-to } if
+  } {
+  emul-depth 1- over = { // b.. s b1 i  found in tos
+    2drop move-tos-to
+  } { // b.. s b1 i
+    nip over adj-ij issue-emul-xchg
+  } cond } cond } cond } cond } cond } while
+  nip emul-depth swap - issue-emul-drop-#
+} : generate-reorder-ops
+
+// old new -- op-list
+{ emul-stk @ op-rlist @ 2swap 
+  swap list>tuple emul-stk ! clear-op-list
+  0 generate-reorder-ops get-op-list
+  -rot op-rlist ! emul-stk !
+} : generate-reorder
+{ parse-stk-list( generate-reorder } :_ SG(
+
+// op-list rewriting according to a ruleset 
+// l f l1 l2 -- l' -1 or l f  with l' = l2 + (l - l1)
+{ push(3) rot list- { list+ nip nip true } { drop } cond
+} : try-rule
+// l f ll -- l' -1 or l f
+{ { dup null? not } { uncons 3 -roll unpair try-rule rot } while drop
+} : try-ruleset
+// l ll -- l'
+{ swap { over false swap try-ruleset 0= } until nip
+} : try-ruleset*
+// l ruleset -- l'
+recursive try-ruleset*-everywhere {
+  tuck try-ruleset* dup null? { nip } {
+    uncons rot try-ruleset*-everywhere cons } cond
+} swap !
+LIST(
+ [([xchg 0 1] [xchg 0 2]) ([rot])]
+ [([xchg 0 1] [xchg 1 2]) ([-rot])]
+ [([xchg 0 2] [xchg 1 2]) ([rot])]
+ [([xchg 0 2] [xchg 0 1]) ([-rot])]
+ [([xchg 1 2] [xchg 0 1]) ([rot])]
+ [([xchg 1 2] [xchg 0 2]) ([-rot])]
+ [([xchg 0 1] [rot]) ([xchg 0 2])]
+ [([-rot] [xchg 0 1]) ([xchg 0 2])]
+ [([xchg 0 2] [xchg 1 3]) ([2swap])]
+ [([xchg 1 3] [xchg 0 2]) ([2swap])]
+ [([push 1] [push 1]) ([2dup])]
+ [([push 3] [push 3]) ([2over])]
+ [([pop 0] [pop 0]) ([2drop])]
+ [([pop 1] [pop 0]) ([2drop])]
+ [([xchg 0 1] [push 1]) ([tuck])]
+ [([rot] [-rot]) ()]
+ [([-rot] [rot]) ()]
+) constant fift-stack-ruleset
+{ fift-stack-ruleset try-ruleset*-everywhere } : fift-ops-rewrite
+{ SG( fift-ops-rewrite } :_ SGF(
+
+// helpers for creating Fift source strings for one fift-op
+// i j -- s
+{ minmax over { "xchg(" rot (.) $+ +"," swap (.) $+ +")" }
+  { nip dup 1 = { drop "swap" } { 
+    ?dup { "xchg0(" swap (.) $+ +")" } { "" } cond
+  } cond } cond
+} : source-<xchg>
+// i -- s
+{ dup 1 = { drop "over" } {
+  ?dup { "push(" swap (.) $+ +")" } { "dup" } cond
+  } cond
+} : source-<push>
+// i -- s
+{ dup 1 = { drop "nip" } {
+  ?dup { "pop(" swap (.) $+ +")" } { "drop" } cond
+  } cond
+} : source-<pop>
+// lit -- s
+{ dup string? { char " chr swap $+ char " hold } { (.) } cond
+} : source-<lit> 
+
+// dictionary with all fift op compilation/source creation
+{ 0 swap (compile) } : fop-compile
+( _( `xchg 2 { <xchg> fop-compile } { source-<xchg> swap cons } )
+  _( `push 1 { <push> fop-compile } { source-<push> swap cons } )
+  _( `pop 1 { <pop> fop-compile } { source-<pop> swap cons } )
+  _( `lit 1 { 1 'nop (compile) } { source-<lit> swap cons } )
+  _( `rot 0 { ' rot fop-compile } { "rot" swap cons } )
+  _( `-rot 0 { ' -rot fop-compile } { "-rot" swap cons } )
+  _( `tuck 0 { ' tuck fop-compile } { "tuck" swap cons } )
+  _( `2swap 0 { ' 2swap fop-compile } { "2swap" swap cons } )
+  _( `2drop 0 { ' 2drop fop-compile } { "2drop" swap cons } )
+  _( `2dup 0 { ' 2dup fop-compile } { "2dup" swap cons } )
+  _( `2over 0 { ' 2over fop-compile } { "2over" swap cons } )
+) box constant fift-op-dict
+
+{ dup atom? { atom>$ } { drop "" } cond
+  "unknown operation " swap $+ abort
+} : report-unknown-op
+variable 'fop-entry-exec
+// process fift-op according to 'fop-entry-exec
+// ... op - ...
+{ dup first dup fift-op-dict @ assq { report-unknown-op } ifnot
+  dup second 1+ push(3) count <> abort"incorrect param count"
+  nip swap explode dup roll drop 1- roll // o2 .. on entry
+  'fop-entry-exec @ execute 
+} : process-fift-op
+
+// compile op-list into Fift wordlist
+// wl op-list -- wl'
+{ { third execute } 'fop-entry-exec !
+  swap ' process-fift-op foldl } : compile-fift-op*
+// op-list -- e
+{ fift-ops-rewrite ({) swap compile-fift-op* (}) } : ops>wdef
+
+// S(<orig-stack> - <new-stack>) compiles a "word" performing required action
+{ SG( ops>wdef 0 swap } ::_ S(
+// 1 2 3 S(a b c - c a b a) .s  would print 3 1 2 1
+
+// transform op-list into Fift source
+// ls op -- ls'
+{ fift-ops-rewrite 
+  { 3 [] execute } 'fop-entry-exec !
+  null ' process-fift-op foldl
+  dup null? { drop "" } { { +" " swap $+ } foldr-ne } cond
+} : ops>$
+{ SG( ops>$ 1 'nop } ::_ $S(
+{ SG( ops>$ type } :_ .$S(
+// $S(a b c - b c a c a c) => string "rot 2dup over"
+// S(a b c - b c a c a c) => compile/execute block { rot 2dup over }
+// $S(_ x y _ - y x) => string "drop pop(2)"
+// .$S(x1 x2 - 17 x1) => print string "drop 17 swap"
+
+// simplify/transform sequences of stack manipulation operations
+LIST(. [a b c d e f g h i j]) constant std-stack
+{ stk-start std-stack explode drop stk-to std-stack explode drop
+} : simplify<{
+{ build-stk-effect generate-reorder ops>$ } : }>stack
+// simplify<{ drop drop over over -13 }>stack => string "2drop 2dup -13"
+// simplify<{ 17 rot }>stack => string "swap 17 swap"
+// simplify<{ 5 1 reverse }>stack => string "xchg(1,5) xchg(2,4)"

crypto/fift/lib/TonUtil.fif

@@ -0,0 +1,125 @@
+library TonUtil // TON Blockchain Fift Library
+"Lists.fif" include
+
+-1 constant Masterchain
+0 constant Basechain
+
+// parse workchain id
+// ( S -- workchain )
+{ (number) 1- abort"workchain id must be an integer"
+  dup 32 fits not abort"workchain id must fit in 32 bits"
+} : parse-workchain-id
+
+{ (number) 1- abort"integer expected" } : parse-int
+
+// Private key load/generate
+// ( fname -- pubkey privkey )
+{ dup ."Loading private key from file " type cr 
+  file>B dup Blen 32 <> abort"Private key must be exactly 32 bytes long"
+  dup priv>pub swap 
+} : load-keypair
+// ( fname -- pubkey privkey )
+{ dup file-exists?
+  { load-keypair }
+  { dup newkeypair swap rot over swap B>file
+    rot ."Saved new private key to file " type cr 
+  } cond
+} : load-generate-keypair
+
+// Parse smart-contract address
+// ( S -- workchain addr bounce? )
+{ $>smca not abort"invalid smart-contract address"
+  1 and 0= 
+} : parse-smc-addr
+
+// ( wc addr -- )  Show address in <workchain>:<account> form
+{ swap ._ .":" x. } : .addr
+// ( wc addr flags -- )  Show address in base64url form
+{ smca>$ type } : .Addr
+// ( wc addr fname -- )  Save address to file in 36-byte format
+{ -rot 256 u>B swap 32 i>B B+ swap B>file } : save-address
+// ( wc addr fname -- )  Save address and print message
+{ dup ."(Saving address to file " type .")" cr save-address
+} : save-address-verbose
+
+// ( fname -- wc addr )  Load address from file
+{ file>B 32 B| 
+  dup Blen { 32 B>i@ } { drop Basechain } cond
+  swap 256 B>u@
+} : load-address
+// ( fname -- wc addr )  Load address from file and print message
+{ dup ."(Loading address from file " type .")" cr load-address
+} : load-address-verbose
+// Parse string as address or load address from file (if string is prefixed by @)
+// ( S default-bounce -- workchain addr bounce? )
+{ over $len 0= abort"empty smart-contract address"
+  swap dup 1 $| swap "@" $=
+  { nip load-address rot } { drop nip parse-smc-addr } cond
+} : parse-load-address
+
+// ( hex-str -- addr )  Parses ADNL address
+{ dup $len 64 <> abort"ADNL address must consist of exactly 64 hexadecimal characters"
+  (hex-number) 1 <> abort"ADNL address must consist of 64 hexadecimal characters"
+  dup 256 ufits not abort"invalid ADNL address"
+} : parse-adnl-address
+
+// ( b wc addr -- b' )  Serializes address into Builder b
+{ -rot 8 i, swap 256 u, } : addr, 
+
+// Gram utilities
+1000000000 constant Gram
+{ Gram swap */r } : Gram*/
+{ Gram * } : Gram*
+// ( S -- nanograms )
+{ (number) ?dup 0= abort"not a valid Gram amount"
+1- ' Gram*/ ' Gram* cond
+} : $>GR
+{ bl word $>GR 1 'nop } ::_ GR$
+// ( nanograms -- S )
+{ dup abs <# ' # 9 times char . hold #s rot sign #>
+nip -trailing0 } : (.GR)
+{ (.GR) ."GR$" type space } : .GR
+
+// b x -- b'  ( serializes a Gram amount )
+{ -1 { 1+ 2dup 8 * ufits } until
+  rot over 4 u, -rot 8 * u, } : Gram,
+// s -- x s'  ( deserializes a Gram amount )
+{ 4 u@+ swap 8 * u@+ } : Gram@+
+// s -- x
+{ 4 u@+ swap 8 * u@ } : Gram@
+
+// currency collections
+// b x --> b'  ( serializes a VarUInteger32 )
+{ -1 { 1+ 2dup 8 * ufits } until
+  rot over 5 u, -rot 8 * u, } : VarUInt32,
+// s --> x  ( deserializes a VarUInteger32 )
+{ 5 u@+ swap 8 * u@ } : VarUInt32@
+32 constant cc-key-bits
+' VarUInt32, : val,
+' VarUInt32@ : val@
+// d k v -- d'
+{ <b swap val, b> <s swap rot cc-key-bits idict! not abort"cannot add key-value to CurrencyCollection" } : +ccpair
+dictnew constant cc0   // zero currency collection
+// ( v k -- d )  Creates currency collection representing v units of currency k
+{ cc0 swap rot +ccpair } : of-cc
+{ dictnew { over null? not } { swap uncons -rot unpair +ccpair } while nip } : list>cc
+{ dup null? { ."(null) " drop } { val@ . } cond } dup : .maybeVarUInt32 : .val
+{ cc-key-bits { swap 32 1<< rmod . ."-> " .val ."; " true } dictforeach drop cr } : .cc
+{ cc-key-bits { rot . ."-> " swap .val .val ."; " true } dictdiff drop cr } : show-cc-diff
+{ cc-key-bits { val@ swap val@ + val, true } dictmerge } : cc+
+{ null swap cc-key-bits { val@ pair swap cons true } dictforeach drop } : cc>list-rev
+{ cc>list-rev list-reverse } : cc>list
+forget val,  forget val@  forget .val
+
+// Libraries
+// ( -- D )  New empty library collection
+' dictnew : Libs{
+// ( D -- D )  Return library collection as dictionary
+'nop : }Libs
+// ( D c x -- D' )  Add a public/private library c to collection D
+{ <b swap 1 u, over ref, b> <s swap hash rot 256 udict!+
+  0= abort"duplicate library in collection" } : lib+
+// ( D c -- D' )  Add private library c to collection D
+{ 0 lib+ } : private_lib
+// ( D c -- D' )  Add public library c to collection D
+{ 1 lib+ } : public_lib