fail := λmsg . (print-s msg) (exit 1);
label-case := λk . (match k (
()
(() ())
((l r) ('_ (label-case l) (label-case r) '_))
(a (label-case-atom a))
));
debug-memory-usage-cons := ();
debug-memory-usage-atom := ();
debug-memory-usage := λ at . (if config-perf (tail(
(if debug-memory-usage-cons () (
(set debug-memory-usage-cons (i2s(show-cons-tail())))
))
(if debug-memory-usage-atom () (
(set debug-memory-usage-atom (i2s(show-atom-tail())))
))
(print-s 'CountMemory:)
(print-s at)
(print-s '\n)
(print-s 'ConsCount:)
(print-s (dump-i( (show-cons-tail()) )))
(print-s '\n)
(print-s 'AtomCount:)
(print-s (dump-i( (show-atom-tail()) )))
(print-s '\n)
()
)) ());
deep-eq := λl r . match (l r) (
()
( (() ()) True )
( ((ll lr) (rl rr)) (
if (deep-eq( ll rl )) (
(deep-eq( lr rr ))
) ()
))
( (la ra) (eq( la ra )) )
);
is-builtin := λf . (match f (
()
('show-cons-tail True)
('show-atom-tail True)
('is True)
('is-atom True)
('is-cons True)
('eq True)
('not True)
('head True)
('head-string True)
('tail-string True)
('tail True)
('inc True)
('dec True)
('add True)
('mul True)
('div True)
('mod True)
('inv True)
('is-neg True)
('digit True)
('dump-i True)
('print-s True)
('print-i True)
('print-p True)
('print-p True)
('print-d True)
('clone-rope True)
('write-file True)
('load-file True)
(_ ())
));
uuid-counter := ();
uuid := λ . (tail(
(set uuid-counter (inc uuid-counter))
(clone-rope ('uuid_ (dump-i uuid-counter)))
));
assert-not-typeof := λ loc term tt . (
(if config-debug (tail(
(set tt (parse-type tt))
(if (is-typeof( term tt )) (tail(
(print-s FailedAssertNotTypeof)(print-s \s)(print-s 'in)(print-s \s)(print-s loc)(print-s \n)
(print-s \t)(print-s tt)(print-s \n)
(print-s \t)(print-s term)(print-s \n)
(exit 1)
)) ())
)) ())
);
s2i := λs . (tail(
(local i)
(local is_neg)
(local one)
(local two)
(local three)
(local four)
(local five)
(local six)
(local seven)
(local eight)
(local nine)
(local ten)
(set one( inc() ))
(set two( inc(inc( )) ))
(set three( inc(inc(inc( ))) ))
(set four( inc(inc(inc(inc( )))) ))
(set five( inc(inc(inc(inc(inc( ))))) ))
(set six( inc( inc(inc(inc(inc(inc( ))))) ) ))
(set seven( inc(inc( inc(inc(inc(inc(inc( ))))) )) ))
(set eight( inc(inc(inc( inc(inc(inc(inc(inc( ))))) ))) ))
(set nine( inc(inc(inc(inc( inc(inc(inc(inc(inc( ))))) )))) ))
(set ten( inc(inc(inc(inc(inc( inc(inc(inc(inc(inc( ))))) ))))) ))
(if (eq( (head-string s) '- )) (tail(
(set is_neg True)
(set s (tail-string s))
)) ())
(while s (tail(
(set i (mul( i ten )))
(match (head-string s) (
()
('0 ())
('1 (set i (add( i one ))))
('2 (set i (add( i two ))))
('3 (set i (add( i three ))))
('4 (set i (add( i four ))))
('5 (set i (add( i five ))))
('6 (set i (add( i six ))))
('7 (set i (add( i seven ))))
('8 (set i (add( i eight ))))
('9 (set i (add( i nine ))))
(u (fail (InvalidDigit u)))
))
(set s (tail-string s))
)))
(if is_neg (
(mul( (dec()) i ))
) i )
));
max := λ l r . (tail(
(local li)
(set li (s2i l))
(local ri)
(set ri (s2i r))
(local return)
(while (not return) (tail(
(if (not li) (
(set return r)
) (
(if (not ri) (
(set return l)
) ())
))
(set li (dec li))
(set ri (dec ri))
)))
return
));
assert-eq := λ loc l r . (
(if config-debug (
(if (deep-eq( l r )) () (tail(
(print-s FailedAssertEqual)(print-s \s)(print-s 'in)(print-s \s)(print-s loc)(print-s \n)
(print-s \t)(print-s l)(print-s \n)
(print-s \t)(print-s r)(print-s \n)
(exit 1)
)))
) ())
);
is-variable := λv . (match (head-string v) (
()
('. ( if (eq( v '. )) () True ))
('@ True )
('[ True )
('? True )
('! True )
('= True )
('> True )
('< True )
('/ True )
('% True )
('* True )
('+ True )
('- True )
('$ True )
('& True )
('| True )
('_ True )
('a True )
('b True )
('c True )
('d True )
('e True )
('f True )
('g True )
('h True )
('i True )
('j True )
('k True )
('l True )
('m True )
('n True )
('o True )
('p True )
('q True )
('r True )
('s True )
('t True )
('u True )
('v True )
('w True )
('x True )
('y True )
('z True )
));
merge-list := λl r . (tail(if l (
(while r (tail(
(set l (l (tail r)))
(set r (head r))
)))
l
) r ));
merge-safe-list := λl r . (if l (
(while r (tail(
(set l (l (tail r)))
(set r (head r))
)))
l
) r );
is-suffix := λs suff . (tail(
(local match)
(while s (tail(
(if (eq( s suff )) (set match True) ())
(set s (tail-string s))
)))
match
));
remove-suffix := λs suff . (tail(
(local prefix)
(while s (tail(
(if (eq( s suff )) (
(set s ())
) (
(set prefix (prefix (clone-rope (head-string s))))
(set s (tail-string s))
))
)))
(clone-rope prefix)
));
reverse-list := λl . (tail(
(local r)
(while l (tail(
(set r ( (tail l) r ))
(set l (head l))
)))
r
));
is-typeof := λ term tt . (match tt (
()
( Nil (if (eq( term Nil )) True (not term)) )
( Atom (is-atom term) )
( Cons (is-cons term) )
( (List te) (
(if (is-cons term) (
(if (is-typeof( (tail term) te )) (
(is-typeof( (head term) tt ))
) ())
) (
(not term)
))
))
( (Or( ('[]( lt rt )) )) (
(if (is-typeof( term lt )) True (
(is-typeof( term rt ))
))
))
( ('[] ( lt rt )) (
(if (is-cons term) (
(if (is-typeof( (head term) lt )) (
(is-typeof( (tail term) rt ))
) ())
) ())
))
( (l r) (fail (UnknownTypeofType tt)))
( () (fail (UnknownTypeofType tt)))
( label (eq( (head term) label )) )
));
assert-typeof := λ loc term tt . (
(if config-debug (tail(
(set tt (parse-type tt))
(if (is-typeof( term tt )) () (tail(
(print-s FailedAssertTypeof)(print-s \s)(print-s 'in)(print-s \s)(print-s loc)(print-s \n)
(print-s \t)(print-s tt)(print-s \n)
(print-s \t)(print-s term)(print-s \n)
(exit 1)
)))
)) ())
);
i2s := λi . (tail(
(local ten)
(set ten( inc(inc(inc(inc(inc( inc(inc(inc(inc(inc( ))))) ))))) ))
(local sign)
(local s)
(local r)
(if (is-neg i) (tail(
(set sign '-)
(set i (inv i))
)) ())
(while i (tail(
(set r (mod(i ten)))
(set s ((clone-rope(digit r) s)))
(set i (div(i ten)))
)))
(if s () (set s 0))
(clone-rope (sign s))
));
label-case-atom := λk . (tail(
(local nk)
(while k (match (head-string k) (
()
(() ())
('- (
(set nk (nk '_))
(set k (tail-string k))
))
('+ (
(set nk (nk '_pl_))
(set k (tail-string k))
))
('= (
(set nk (nk '_eq_))
(set k (tail-string k))
))
('? (
(set nk (nk '_Q_))
(set k (tail-string k))
))
(': (
(set nk (nk '_C_))
(set k (tail-string k))
))
('< (
(set nk (nk '_LB_))
(set k (tail-string k))
))
('> (
(set nk (nk '_RB_))
(set k (tail-string k))
))
(\[ (
(set nk (nk '_LP_))
(set k (tail-string k))
))
(\] (
(set nk (nk '_RP_))
(set k (tail-string k))
))
('% (
(set nk (nk '_MD_))
(set k (tail-string k))
))
('/ (
(set nk (nk '_DV_))
(set k (tail-string k))
))
('! (
(set nk (nk '_EX_))
(set k (tail-string k))
))
('$ (
(set nk (nk '_DS_))
(set k (tail-string k))
))
(c (
(set nk (nk (clone-rope c)))
(set k (tail-string k))
))
)))
(clone-rope nk)
));
mangle-identifier := λname tt . (
(clone-rope (label-case ( name : tt )))
);
parse-type-cache := ();
parse-type := λ tt . (tail(
(local original-type)
(set original-type tt)
(local cache)
(set cache parse-type-cache)
(local found)
(while cache (tail(
(if (eq( (head(tail( cache ))) tt )) (
(set found (tail(tail cache)))
) ())
(set cache (head cache))
)))
(if found found (tail(
(local buff)
(local base-type)
(local depth)
(while tt (tail(
(match (head-string tt) (
()
('< (set depth (inc depth)))
('[ (set depth (inc depth)))
('> (set depth (dec depth)))
('] (set depth (dec depth)))
))
(if depth (
(set buff (buff (clone-rope (head-string tt))))
) (
(if (eq( (head-string tt) '+ )) (tail(
(if base-type (
(set base-type (And( base-type (parse-type-single (clone-rope buff)) )))
) (
(set base-type (parse-type-single (clone-rope buff)))
))
(set buff ())
)) (
(set buff (buff (clone-rope (head-string tt))))
))
))
(set tt (tail-string tt))
)))
(set base-type (if base-type (
(And( base-type (parse-type-single (clone-rope buff)) ))
) (
(parse-type-single (clone-rope buff))
)))
(set parse-type-cache (parse-type-cache (original-type base-type)))
base-type
)))
));
parse-type-suffix := λ base suffix . (tail(
(assert-typeof( 'parse-array-type::suffix suffix Atom ))
(local depth)
(local buff)
(local mode)
(while suffix (match (head-string suffix) (
()
( '[ (tail(
(set suffix (tail-string suffix))
(if depth (
(set buff (buff '[ ))
) (
(set mode '[)
))
(set depth (inc depth))
)))
( '< (tail(
(set suffix (tail-string suffix))
(if depth (
(set buff (buff '< ))
) (
(set mode '<)
))
(set depth (inc depth))
)))
( '] (tail(
(set depth (dec depth))
(set suffix (tail-string suffix))
(if depth (
(set buff (buff '] ))
) (
(assert-eq( 'parse-suffix::mode '[ mode ))
(if buff (
(set base (Array( base
(parse-type( clone-rope buff ))
)))
) (
(set base (Array( base '? )))
))
(set buff ())
(set mode ())
))
)))
( '> (tail(
(set depth (dec depth))
(set suffix (tail-string suffix))
(if depth (
(set buff (buff '> ))
) (
(assert-eq( 'parse-suffix::mode '< mode ))
(if buff (
(set base (
base (parse-type-comma-sep( clone-rope buff ))
))
) (
(set base (base '? ))
))
(set buff ())
(set mode ())
))
)))
( c (tail(
(set buff (buff (clone-rope c)))
(set suffix (tail-string suffix))
)))
)))
(assert-eq( 'parse-type-suffix::buff buff () ))
base
));
parse-type-comma-sep := λ tt . (tail(
(local buff)
(local base)
(local depth)
(while tt (tail(
(match (head-string tt) (
()
('< (set depth (inc depth)))
('[ (set depth (inc depth)))
('> (set depth (dec depth)))
('] (set depth (dec depth)))
))
(match (head-string tt) (
()
(', (tail(
(if depth (
(set buff (buff ',))
) (
(if base (
(set base (base (parse-type (clone-rope buff))))
) (
(set base (parse-type (clone-rope buff)))
))
(set buff ())
))
(set tt (tail-string tt))
)))
(c (tail(
(set buff (buff (clone-rope c)))
(set tt (tail-string tt))
)))
))
)))
(if base (
(set base (base (parse-type (clone-rope buff))))
) (
(set base (parse-type (clone-rope buff)))
))
base
));
parse-type-tuple := λ tt . (tail(
(assert-eq( 'parse-type-tuple::tt::head '[ (head-string tt) ))
(local depth)
(local base)
(local buff)
(while tt (match (head-string tt) (
()
( '[ (tail(
(if depth (
(set buff (buff '[))
) ())
(set depth (inc depth))
(set tt (tail-string tt))
)))
( '] (tail(
(set depth (dec depth))
(if depth (
(set buff (buff ']))
) (
(if base (
(set base ('[]( base (parse-type (clone-rope buff)) )))
) (
(set base (parse-type (clone-rope buff)))
))
))
(set tt (tail-string tt))
)))
( ', (tail(
(if (dec depth) (
(set buff (buff ',))
) (
(if base (
(set base ('[]( base (parse-type (clone-rope buff)) )))
) (
(set base (parse-type (clone-rope buff)))
))
(set buff ())
))
(set tt (tail-string tt))
)))
( c (tail(
(set buff (buff (clone-rope c)))
(set tt (tail-string tt))
)))
)))
base
));
parse-type-single := λ tt . (tail(
(local buff)
(local base)
(while tt (tail(
(match (head-string tt) (
()
('[ (tail(
(if buff (
(set base (parse-type-suffix( (clone-rope buff) tt )))
) (
(set base (parse-type-tuple tt))
))
(set tt ())
)))
('< (tail(
(set base (parse-type-suffix( (clone-rope buff) tt )))
(set tt ())
)))
(c (set buff (buff (clone-rope c)) ))
))
(set tt (tail-string tt))
)))
(if base base (clone-rope buff))
));
escape-literal-char := λc . match c (
()
( '\\ '\\\\ )
( '\\: '\: )
( '\\o '\o )
( '\\n (\\ 'n))
( '\\t '\t )
( '\\s '\s )
( '\\l '\l )
( '\\[ '\[ )
( '\\] '\] )
( c (clone-rope c) )
);
escape-escape-char := λc . match c (
()
( '[ '\[ )
( '] '\] )
( '` '' )
( '\\ '\\\\ )
( ': '\: )
( 'o '\o )
( 'n (\\ 'n))
( 't '\t )
( 's '\s )
( 'l '\l )
( _ () )
);
escape-literal := λs . (tail(
(local buff)
(while s (tail(
(if (eq( (head-string s) '\ )) (tail(
(local e)
(set e (escape-escape-char( (head-string(tail-string( s ))) )))
(if e (
(set buff (buff e))
(set s (tail-string(tail-string s)))
) (
(set buff (buff (escape-literal-char (head-string s))))
(set s (tail-string s))
))
)) (tail(
(set buff (buff (escape-literal-char (head-string s))))
(set s (tail-string s))
)))
)))
(clone-rope buff)
));
quote-s := λt . (match t (
()
( (l r) ('\[ (quote-s l) '\s (quote-s r) '\]) )
( x x )
));