ps/core.ps

   1 (in core.ps\n) print
   2
   3 % requires types.ps
   4
   5 % Errors/Exceptions
   6
   7 % data -> throw ->
   8 % Takes an arbitrary data and puts it in $error:/errorinfo. Then calls
   9 % stop to transfer control to end of nearest stopped context.
  10 /throw {
  11     $error exch /errorinfo exch put
  12     $error /command /throw put
  13     stop
  14 } def
  15
  16
  17 % sequence functions
  18
  19 % [obj list] -> cons -> new_list
  20 /cons {
  21     /args exch def
  22     /elem args 0 get def
  23     /lst args 1 get def
  24     lst length 1 add array
  25     dup 0 elem put % first element
  26     dup 1 lst putinterval % rest of the elements
  27 } def
  28
  29 % [listA listB] -> concat -> [listA... listB...]
  30 /concat { % replaces matric concat
  31     dup length 0 eq { %if just concat
  32         0 _list
  33     }{ dup length 1 eq { %elseif concat of single item
  34         0 get % noop
  35     }{ % else
  36         [] exch
  37         {
  38             concatenate
  39         } forall
  40     } ifelse } ifelse
  41 } def
  42
  43 % [obj ...] -> first -> obj
  44 /first {
  45     0 get _first
  46 } def
  47
  48 % [obj objs...] -> first -> [objs..]
  49 /rest {
  50     0 get _rest
  51 } def
  52
  53 % [function args... arg_list] -> apply -> result
  54 /apply { 1 dict begin
  55     /args exch def
  56     args 0 get callable % make sure function is callable
  57     args 1 args length 2 sub getinterval
  58     args args length 1 sub get
  59     concatenate args 0 get % stack: args function
  60     exec
  61 end } def
  62
  63 % [function list] -> _map -> new_list
  64 /map { 1 dict begin
  65     dup 0 get exch 1 get % stack: function list
  66     /args exch def
  67     callable % make sure function is callable
  68     %/new_list args length array def
  69     args {
  70         1 array astore
  71         exch dup 3 1 roll % stack: fn arg fn
  72         exec exch % stack: result fn
  73     } forall
  74     pop % remove the function
  75     args length array astore
  76 end } def
  77
  78 /conj { 5 dict begin
  79     /args exch def
  80     /src_list args 0 get def
  81     /new_len src_list length   args length 1 sub   add def
  82     /new_list new_len array def
  83     new_list   new_len src_list length sub   src_list putinterval
  84     args length 1 sub -1 1 {
  85         /idx exch def
  86         new_list   args length idx sub 1 sub   args idx get   put
  87     } for
  88     new_list
  89 end } def
  90
  91
  92 % core_ns is namespace of core functions
  93
  94 /core_ns <<
  95     (pr-str)  { ( ) true _pr_str_args }
  96     (str)     { () false _pr_str_args }
  97     (prn)     { ( ) true _pr_str_args print (\n) print null }
  98     (println) { () false _pr_str_args print (\n) print null }
  99     (=)       { dup 0 get exch 1 get _equal? }
 100     (symbol?) { 0 get _symbol? }
 101     (nil?)    { 0 get _nil? }
 102     (true?)   { 0 get _true? }
 103     (false?)  { 0 get _false? }
 104     (<)       { dup 0 get exch 1 get lt }
 105     (<=)      { dup 0 get exch 1 get le }
 106     (>)       { dup 0 get exch 1 get gt }
 107     (>=)      { dup 0 get exch 1 get ge }
 108     (+)       { dup 0 get exch 1 get add }
 109     (-)       { dup 0 get exch 1 get sub }
 110     (*)       { dup 0 get exch 1 get mul }
 111     (/)       { dup 0 get exch 1 get idiv }
 112     (throw)   { 0 get throw }
 113     (list)    { dup pop } % noop
 114     (list?)   { 0 get _list? }
 115     (cons)    { cons }
 116     (concat)  { concat }
 117     (sequential?) { 0 get _sequential? }
 118     (empty?)  { 0 get length 0 eq }
 119     (count)   { 0 get length }
 120     (nth)     { dup 0 get exch 1 get _nth }
 121     (first)   { first }
 122     (rest)    { rest }
 123     (apply)   { apply }
 124     (map)     { map }
 125     (conj)    { conj }
 126 >> def