diff options
Diffstat (limited to 'ps/core.ps')
| -rw-r--r-- | ps/core.ps | 261 |
1 files changed, 198 insertions, 63 deletions
@@ -5,122 +5,257 @@ % Errors/Exceptions % data -> throw -> -% Takes an arbitrary data and puts it in $error:/errorinfo. Then calls -% stop to transfer control to end of nearest stopped context. -/throw { - $error exch /errorinfo exch put - $error /command /throw put - stop +% Takes arbitrary data and throws it as an exception. +/throw { 0 _nth _throw } def + + +% Hash Map functions + +% [hashmap key val ...] -> assoc -> new_hashmap +/assoc { 4 dict begin + /args exch def + /src_dict args 0 _nth /data get def + /new_dict src_dict + dup length args _count 1 sub 2 idiv add % new length + dict % new dict of that length + copy def + 1 2 args _count 1 sub { %for each key idx + /idx exch def + new_dict args idx _nth args idx 1 add _nth put + } for + new_dict _hash_map_from_dict +end } def + +% [hashmap key...] -> dissoc -> new_hashmap +/dissoc { 4 dict begin + /args exch def + /src_dict args 0 _nth /data get def + /new_dict src_dict dup length dict copy def + 1 1 args _count 1 sub { %for each key idx + /idx exch def + new_dict args idx _nth undef + } for + new_dict _hash_map_from_dict +end } def + +% [hashmap key] -> hash_map_get -> value +/hash_map_get { + dup 0 _nth /data get % stack: args dict + exch 1 _nth % stack: dict key + 2 copy known { %if has key + get + }{ + pop pop null + } ifelse +} def + +% [hashmap key] -> contains? -> bool +/contains? { + dup 0 _nth /data get % stack: args dict + exch 1 _nth % stack: dict key + known +} def + +% [hashmap] -> keys -> key_list +/keys { + 0 _nth /data get + [ exch { pop dup length string cvs } forall ] + _list_from_array +} def + +% [hashmap] -> vals -> val_list +/vals { + 0 _nth /data get + [ exch { exch pop } forall ] + _list_from_array } def % sequence functions % [obj list] -> cons -> new_list -/cons { +/cons { 3 dict begin /args exch def - /elem args 0 get def - /lst args 1 get def - lst length 1 add array + /elem args 0 _nth def + /lst args 1 _nth def + lst _count 1 add array dup 0 elem put % first element - dup 1 lst putinterval % rest of the elements -} def + dup 1 lst /data get putinterval % rest of the elements + _list_from_array +end } def % [listA listB] -> concat -> [listA... listB...] /concat { % replaces matric concat - dup length 0 eq { %if just concat + dup _count 0 eq { %if just concat 0 _list - }{ dup length 1 eq { %elseif concat of single item - 0 get % noop + }{ dup _count 1 eq { %elseif concat of single item + 0 _nth % noop }{ % else [] exch - { - concatenate + /data get { + /data get concatenate } forall + _list_from_array } ifelse } ifelse } def % [obj ...] -> first -> obj /first { - 0 get _first + 0 _nth _first } def % [obj objs...] -> first -> [objs..] /rest { - 0 get _rest + 0 _nth _rest } def +% [vect elem...] -> conj -> new_vect +% [list elem...] -> conj -> new_list +/conj { 5 dict begin + /args exch def + /src_arr args 0 _nth /data get def + /new_len src_arr length args _count 1 sub add def + /new_arr new_len array def + args 0 _nth _list? { %if list + new_arr new_len src_arr length sub src_arr putinterval + args _count 1 sub -1 1 { + /idx exch def + new_arr args _count idx sub 1 sub args idx _nth put + } for + new_arr _list_from_array + }{ %else vector + src_arr new_arr copy + 1 1 args _count 1 sub { + /idx exch def + new_arr src_arr length idx add 1 sub args idx _nth put + } for + new_arr _vector_from_array + } ifelse +end } def + % [function args... arg_list] -> apply -> result /apply { 1 dict begin /args exch def - args 0 get callable % make sure function is callable - args 1 args length 2 sub getinterval - args args length 1 sub get - concatenate args 0 get % stack: args function + args 0 _nth callable % make sure function is callable + args /data get 1 args _count 2 sub getinterval % get args slice + args args _count 1 sub _nth /data get % get arg_list array + concatenate _list_from_array exch % stack: args function exec end } def % [function list] -> _map -> new_list /map { 1 dict begin - dup 0 get exch 1 get % stack: function list + dup 0 _nth exch 1 _nth % stack: function list /args exch def callable % make sure function is callable %/new_list args length array def - args { - 1 array astore - exch dup 3 1 roll % stack: fn arg fn + args /data get { %foreach arg + 1 array astore _list_from_array % stack: fn arglist + exch dup 3 1 roll % stack: fn arglist fn exec exch % stack: result fn } forall pop % remove the function - args length array astore + args _count array astore + _list_from_array end } def -/conj { 5 dict begin + +% Metadata functions + +% [obj meta] -> with_meta -> new_obj +/with_meta { + dup 1 _nth exch 0 _nth % stack: meta obj + dup length dict copy % stack: meta new_obj + dup 3 -1 roll % stack: new_obj new_obj meta + /meta exch put +} def + +% [obj] -> meta -> meta +/meta { + 0 _nth /meta get +} def + + +% Atom functions + +/deref { + 0 _nth /data get +} def + +% [atm val] -> reset! -> val +/reset! { + dup 0 _nth exch 1 _nth % stack: atm val + dup 3 1 roll % stack: val atm val + /data exch put +} def + +% [atm f args...] -> swap! -> new_val +/swap! { 3 dict begin /args exch def - /src_list args 0 get def - /new_len src_list length args length 1 sub add def - /new_list new_len array def - new_list new_len src_list length sub src_list putinterval - args length 1 sub -1 1 { - /idx exch def - new_list args length idx sub 1 sub args idx get put - } for - new_list + /atm args 0 _nth def + [ atm /data get ] + args 2 args _count 2 sub _slice /data get + concatenate _list_from_array + args 1 _nth callable % make sure function is callable + exec + /new_val exch def + atm /data new_val put + new_val end } def % core_ns is namespace of core functions /core_ns << - (pr-str) { ( ) true _pr_str_args } - (str) { () false _pr_str_args } - (prn) { ( ) true _pr_str_args print (\n) print null } - (println) { () false _pr_str_args print (\n) print null } - (=) { dup 0 get exch 1 get _equal? } - (symbol?) { 0 get _symbol? } - (nil?) { 0 get _nil? } - (true?) { 0 get _true? } - (false?) { 0 get _false? } - (<) { dup 0 get exch 1 get lt } - (<=) { dup 0 get exch 1 get le } - (>) { dup 0 get exch 1 get gt } - (>=) { dup 0 get exch 1 get ge } - (+) { dup 0 get exch 1 get add } - (-) { dup 0 get exch 1 get sub } - (*) { dup 0 get exch 1 get mul } - (/) { dup 0 get exch 1 get idiv } - (throw) { 0 get throw } - (list) { dup pop } % noop - (list?) { 0 get _list? } + (=) { dup 0 _nth exch 1 _nth _equal? } + (throw) { throw } + (nil?) { 0 _nth _nil? } + (true?) { 0 _nth _true? } + (false?) { 0 _nth _false? } + (symbol?) { 0 _nth _symbol? } + (pr-str) { /data get ( ) true _pr_str_args } + (str) { /data get () false _pr_str_args } + (prn) { /data get ( ) true _pr_str_args print (\n) print null } + (println) { /data get () false _pr_str_args print (\n) print null } + (<) { dup 0 _nth exch 1 _nth lt } + (<=) { dup 0 _nth exch 1 _nth le } + (>) { dup 0 _nth exch 1 _nth gt } + (>=) { dup 0 _nth exch 1 _nth ge } + (+) { dup 0 _nth exch 1 _nth add } + (-) { dup 0 _nth exch 1 _nth sub } + (*) { dup 0 _nth exch 1 _nth mul } + (/) { dup 0 _nth exch 1 _nth idiv } + + (list) { /data get _list_from_array } + (list?) { 0 _nth _list? } + (vector) { /data get _vector_from_array } + (vector?) { 0 _nth _vector? } + (hash-map) { /data get _hash_map_from_array } + (map?) { 0 _nth _hash_map? } + (assoc) { assoc } + (dissoc) { dissoc } + (get) { hash_map_get } + (contains?) { contains? } + (keys) { keys } + (vals) { vals } + + (sequential?) { 0 _nth _sequential? } (cons) { cons } (concat) { concat } - (sequential?) { 0 get _sequential? } - (empty?) { 0 get length 0 eq } - (count) { 0 get length } - (nth) { dup 0 get exch 1 get _nth } + (nth) { dup 0 _nth exch 1 _nth _nth } (first) { first } (rest) { rest } + (empty?) { 0 _nth _count 0 eq } + (count) { 0 _nth _count } + (conj) { conj } (apply) { apply } (map) { map } - (conj) { conj } + + (with-meta) { with_meta } + (meta) { meta } + (atom) { 0 _nth _atom } + (atom?) { 0 _nth _atom? } + (deref) { deref } + (reset!) { reset! } + (swap!) { swap! } >> def |