mal/ps/types.ps

(in types.ps\n) print

% concatenate: concatenate two strings or two arrays
% From Thinking in PostScript 1990 Reid
% (string1) (string2) concatenate string3
% array1 array2 concatenate array3
/concatenate { %def
    dup type 2 index type 2 copy ne { %if
        pop pop
        errordict begin (concatentate) typecheck end
    }{ %else
        /stringtype ne exch /arraytype ne and {
            errordict begin (concatenate) typecheck end
        } if
    } ifelse
    dup length 2 index length add 1 index type
    /arraytype eq { array }{ string } ifelse
    % stack: arg1 arg2 new
    dup 0 4 index putinterval
    % stack: arg1 arg2 new
    dup 4 -1 roll length 4 -1 roll putinterval
    % stack: new
} bind def

% reverse: array1 -> reverse -> array2
/reverse {
    [ exch
    aload % push array onto stack
    length -1 0 { 1 roll } for % reverse
    ]
} bind def

/_pr_str { 4 dict begin
    /print_readably exch def
    dup
    /func? exch xcheck def % executable function
    /obj exch cvlit def
    obj _mal_function? { % if user defined function
        (<\(fn* )
        obj /params get print_readably _pr_str
        ( )
        obj /ast get print_readably _pr_str
        (\)>)
        concatenate concatenate concatenate concatenate
    }{ /arraytype obj type eq { % if list or code block
        % accumulate an array of strings
        func? { (<builtin_fn* { ) }{ (\() } ifelse
        obj ( ) print_readably _pr_str_args
        concatenate
        func? { ( } >) }{ (\)) } ifelse
        concatenate
    }{ /integertype obj type eq { % if number
        /slen obj 10 add log ceiling cvi def
        obj 10 slen string cvrs
    }{ /stringtype obj type eq { % if string
        print_readably {
            (") obj (") concatenate concatenate
        }{
            obj
        } ifelse
    }{ null obj eq { % if nil
        (nil)
    }{ true obj eq { % if true
        (true)
    }{ false obj eq { % if false
        (false)
    }{ /nametype obj type eq { % if symbol
        obj dup length string cvs
    }{
        (<unknown>) 
    } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse
end } def

% array delim print_readably -> _pr_str_args -> new_string
/_pr_str_args { 3 dict begin
    /print_readably exch def
    /delim exch def
    /args exch def
    ()
    args length 0 gt { %if any elements
        [
            args { %foreach argument in array
                print_readably _pr_str
            } forall 
        ]
        { concatenate delim concatenate } forall
        dup length delim length sub 0 exch getinterval % strip off final delim
    } if
end } def

% objA objB -> _equal? -> bool
/_equal? { 6 dict begin
    /b exch def
    /a exch def
    /ota a type def
    /otb b type def

    a type b type eq
    a _list? b _list? and
    or not { %if type mismatch and not sequential
        false
    }{
        a _list? { %if list
            /ret true def
            a length b length eq not { %if length mismatch
                /ret false def
            }{ %else (length is the same)
                0 1 a length 1 sub {
                    /idx exch def
                    a idx get b idx get _equal? not { %if not items _equal?
                        /ret false def
                        exit
                    } if
                } for
            } ifelse
            ret
        }{ %else not a list
            a b eq
        } ifelse
    } ifelse
end } def

%
% Symbols
%
/_symbol? {
    type /nametype eq
} def

%
% Functions
%
/_mal_function? {
    dup type /dicttype eq {
        /type get /_maltype_function eq
    }{
        pop false
    } ifelse
} def

% args mal_function -> fload -> ast new_env
% fload: sets up arguments on the stack for an EVAL call
/fload {
    dup /ast get 3 1 roll    % stack: ast args mal_function
    dup /env get 3 1 roll    % stack: ast env args mal_function
    /params get exch         % stack: ast env params args
    env_new                  % stack: ast new_env
} def

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

/errorinfo? {
    $error /errorinfo known { % if set
        $error /errorinfo get null ne {
            true
        }{
            false
        } ifelse
    }{
        false
    } ifelse
} def

/get_error_data {
    errorinfo? { %if
        $error /errorinfo get
    }{
        $error /errorname get 255 string cvs
        (: ) 
        $error /command get 99 string cvs
        ( at )
        $error /position get 10 99 string cvrs
        concatenate
        concatenate
        concatenate
        concatenate
    } ifelse
} def



%
% list operations
%
/_list {
    array astore
} def
/_list? {
    dup xcheck not exch type /arraytype eq and
} def
/_first { 0 get } def
/_rest { dup length 1 sub 1 exch getinterval } def
/_nth { get } def

/_cons {
    /lst exch def
    /elem exch def
    lst length 1 add array
    dup 0 elem put % first element
    dup 1 lst putinterval % rest of the elements
} def

/_concat {
    concatenate
} def


%
% Env implementation
%
% outer binds exprs -> env_new -> new_env
/env_new { 3 dict begin
    %(in env_new\n) print
    /exprs exch def
    /binds exch def
    /outer exch def
    << 
        /__outer__ outer
        0 1 binds length 1 sub {
            /idx exch def
            binds idx get (&) eq { %if &
                binds idx 1 add get % key
                exprs idx   exprs length idx sub   getinterval % value
                exit
            } if
            binds idx get % key
            exprs idx get % value
        } for
    >>
end } def

/env_find { 2 dict begin
    /key exch def
    /env exch def
    env key known { %if key in env
        env
    }{ env /__outer__ get null ne { %elseif __outer__ not null
        env /__outer__ get   key env_find
    }{ %else
        null
    } ifelse } ifelse
end } def

/env_set { 4 dict begin
    dup
    /func? exch xcheck def % executable function
    /val exch cvlit def
    /key exch def
    /env exch def
    env key val func? { cvx } if put
    val func? { cvx } if
end } def

/env_get { 2 dict begin
    /key exch def
    /env exch def
    env key env_find
    dup null eq {
        (')
        key 99 string cvs
        (' not found)
        concatenate concatenate
        throw
    }{
        key get
    } ifelse
end } def

%
% types_ns is namespace of type functions
%
/types_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? }
    (<)       { 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 }
    (list)    { dup pop } % noop
    (list?)   { 0 get _list? }
    (cons)    { dup 0 get exch 1 get _cons }
    (concat)  { dup 0 get exch 1 get _concat }
    (empty?)  { 0 get length 0 eq }
    (count)   { 0 get length }
    (nth)     { dup 0 get exch 1 get _nth }
    (first)   { 0 get _first }
    (rest)    { 0 get _rest }
>> def