mal/ps/core.ps

(in core.ps\n) print

% requires types.ps

% 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
} def


% sequence functions

% [obj list] -> cons -> new_list
/cons {
    /args exch def
    /elem args 0 get def
    /lst args 1 get def
    lst length 1 add array
    dup 0 elem put % first element
    dup 1 lst putinterval % rest of the elements
} def

% [listA listB] -> concat -> [listA... listB...]
/concat { % replaces matric concat
    dup length 0 eq { %if just concat
        0 _list
    }{ dup length 1 eq { %elseif concat of single item
        0 get % noop
    }{ % else
        [] exch
        {
            concatenate
        } forall
    } ifelse } ifelse
} def

% [obj ...] -> first -> obj
/first {
    0 get _first
} def

% [obj objs...] -> first -> [objs..]
/rest {
    0 get _rest
} 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
    exec
end } def

% [function list] -> _map -> new_list
/map { 1 dict begin
    dup 0 get exch 1 get % 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
        exec exch % stack: result fn
    } forall 
    pop % remove the function
    args length array astore
end } def

/conj { 5 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
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? }
    (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 }
    (first)   { first }
    (rest)    { rest }
    (apply)   { apply }
    (map)     { map }
    (conj)    { conj }
>> def