mal/impls/ps/stepA_mal.ps

/runlibfile where { pop }{ /runlibfile { run } def } ifelse % 
(types.ps) runlibfile
(reader.ps) runlibfile
(printer.ps) runlibfile
(env.ps) runlibfile
(core.ps) runlibfile

% read
/_readline { print flush (%stdin) (r) file 1024 string readline } def

/READ {
    /str exch def
    str read_str
} def


% eval
% sym ast -> starts_with -> bool
/starts_with {
    dup _list? {
        0 _nth
        eq
    }{
        pop pop false
    } ifelse
} def

% ast -> quasiquote -> new_ast
/quasiquote { 3 dict begin
    /ast exch def
    ast _sequential? not {
      ast _symbol? ast _hash_map? or {
        /quote ast 2 _list
      }{
        ast
      } ifelse
    }{
        /unquote ast starts_with {
            ast 1 _nth
        }{
            /res 0 _list def
            ast /data get aload length { % reverse traversal
                /elt exch def
                /res
                /splice-unquote elt starts_with {
                    /concat
                    elt 1 _nth
                }{
                    /cons
                    elt quasiquote
                } ifelse
                res
                3 _list
                def
            } repeat
            ast _list? {
                res
            }{
                /vec res 2 _list
            } ifelse
        } ifelse
    } ifelse
end } def

/EVAL { 7 dict begin
    { %loop (TCO)

    /env exch def
    /ast exch def

    env (DEBUG-EVAL) env_get {
        dup null ne    exch false ne    and {
            (EVAL: ) print
            ast true _pr_str print
            (\n) print
        } if
    } if

    ast _symbol? { %if symbol
        env ast env_get
        {
            exit
        }{
            (') ast
            dup length string cvs
            (' not found)
            concatenate concatenate
            _throw
        } ifelse
    } if

    ast _vector? {
        [
            ast /data get { %forall items
                env EVAL
            } forall
        ] _vector_from_array
        exit
    } if

    ast _hash_map? {
        <<
            ast /data get { %forall entries
                env EVAL
            } forall
        >> _hash_map_from_dict
        exit
    } if

    ast _list? not {
        ast
        exit
    } if

    ast _count 0 eq {
        ast
        exit
    } if

        /a0 ast 0 _nth def

        /def! a0 eq { %if def!
            ast 2 _nth    env EVAL
            env    ast 1 _nth    2 index    env_set
            exit
        } if

        /let* a0 eq { %if let*
            /a1 ast 1 _nth def
            /a2 ast 2 _nth def
            /let_env env null null env_new def
            0 2 a1 _count 1 sub { %for each pair
                /idx exch def
                let_env
                    a1 idx _nth
                    a1 idx 1 add _nth let_env EVAL
                    env_set
            } for
            a2
            let_env
            % loop
        }{

        /quote a0 eq { %if quote
            ast 1 _nth
            exit
        } if

        /quasiquote a0 eq { %if quasiquote
            ast 1 _nth quasiquote
            env
            % loop
        }{

        /defmacro! a0 eq { %if defmacro!
            ast 2 _nth    env EVAL    _macro
            env    ast 1 _nth    2 index    env_set
            exit
        } if

        /ps* a0 eq { %if ps*
            count /stackcnt exch def
            ast 1 _nth cvx exec
            count stackcnt gt { % if new operands on stack
                % return an list of new operands
                count stackcnt sub array astore
            }{
                null % return nil
            } ifelse
            exit
        } if

        /do a0 eq { %if do
            ast _count 2 gt { %if ast has more than 2 elements
                ast 1 ast _count 2 sub _slice /data get { env EVAL pop } forall
            } if
            ast ast _count 1 sub _nth % last ast becomes new ast
            env
            % loop
        }{

        /try* a0 eq { %if try*
            ast _count 2 gt { %if has catch* block
                { %try
		    2 dict begin % special dict for dict stack count
                    countdictstack /dictcnt exch def
                    count /stackcnt exch def
                    ast 1 _nth env EVAL
		    end
                } stopped { %catch
                    % clean up the dictionary stack
                    1 1 countdictstack dictcnt sub { %foreach added dict
                        %(popping dict\n) print
                        pop end % pop idx and pop dict
                        %(new ast: ) print ast true _pr_str print (\n) print
                    } for
                    % clean up the operand stack
                    count 1 exch 1 exch stackcnt sub { %foreach added operand
                        %(op stack: ) print pstack
                        pop pop % pop idx and operand
                        %(popped op stack\n) print pstack
                    } for
		    end % remove special dict
                    % get error data and reset $error dict
                    /errdata get_error_data def
                    $error /newerror false put
                    $error /errorinfo null put

                    ast _count 3 lt { %if no third (catch*) form
                        errdata throw
                    } if
                    ast 2 _nth 0 _nth (catch*) eq not { %if third form not catch*
                        (No catch* in throw form) _throw
                    } if
                    ast 2 _nth 2 _nth
                    env
                        ast 2 _nth 1 _nth 1 _list
                        errdata 1 _list
                        env_new
                    EVAL
                } if
            }{ % else no catch* block
                ast 1 _nth env EVAL
            } ifelse
            exit
        } if

        /if a0 eq { %if if
            /a1 ast 1 _nth def
            /cond a1 env EVAL def
            cond null eq cond false eq or { % if cond is nil or false
                ast _count 3 gt { %if false branch with a3
                    ast 3 _nth env
                    % loop
                }{ % else false branch with no a3
                    null
                    exit
                } ifelse
            }{ % true branch
                ast 2 _nth env
                % loop
            } ifelse
        }{

        /fn* a0 eq { %if fn*
            /a1 ast 1 _nth def
            /a2 ast 2 _nth def
            a2 env a1 _mal_function
            exit
        } if

            a0 env EVAL

            dup _mal_function? { %if user defined function
              dup /macro? get true eq {
                ast _rest exch % stack: args macro
                fload          % stack: args new_env
                EVAL           % stack: new_ast
                env            % stack: new_ast env
                % loop
              }{
                [ ast _rest /data get { env EVAL } forall ] _list_from_array exch
                fload % stack: ast new_env
                % loop
              } ifelse
            }{

            dup _function? { %else if builtin function
                [ ast _rest /data get { env EVAL } forall ] _list_from_array exch
                /data get exec
                exit
            } if

            %else (regular procedure/function)
            (cannot apply native proc!\n) print quit

            } ifelse } ifelse } ifelse } ifelse } ifelse
    } loop % TCO
end } def


% print
/PRINT {
    true _pr_str
} def


% repl
/repl_env null null null env_new def

/RE { READ repl_env EVAL } def
/REP { READ repl_env EVAL PRINT } def

% core.ps: defined using postscript
core_ns { _function    repl_env 3 1 roll env_set } forall
repl_env    (eval)    { 0 _nth repl_env EVAL } _function    env_set
repl_env    (*ARGV*)    [ ] _list_from_array    env_set

% core.mal: defined using the language itself
(\(def! *host-language* "postscript"\)) RE pop
(\(def! not \(fn* \(a\) \(if a false true\)\)\)) RE pop
(\(def! load-file \(fn* \(f\) \(eval \(read-string \(str "\(do " \(slurp f\) "\nnil\)"\)\)\)\)\)) RE pop
(\(defmacro! cond \(fn* \(& xs\) \(if \(> \(count xs\) 0\) \(list 'if \(first xs\) \(if \(> \(count xs\) 1\) \(nth xs 1\) \(throw "odd number of forms to cond"\)\) \(cons 'cond \(rest \(rest xs\)\)\)\)\)\)\)) RE pop

userdict /ARGUMENTS known { %if command line arguments
    ARGUMENTS length 0 gt { %if more than 0 arguments
        repl_env    (*ARGV*)    ARGUMENTS 1 ARGUMENTS length 1 sub getinterval
        _list_from_array env_set
        ARGUMENTS 0 get 
        (\(load-file ") exch ("\)) concatenate concatenate RE pop
        quit
    } if
} if

% repl loop
(\(println \(str "Mal [" *host-language* "]"\)\)) RE pop
{ %loop
    (user> ) _readline
    not { exit } if  % exit if EOF

    { %try
        REP print (\n) print
    } stopped {
        (Error: ) print
        get_error_data false _pr_str print (\n) print
        $error /newerror false put
        $error /errorinfo null put
        clear
        cleardictstack
    } if
} bind loop

(\n) print  % final newline before exit for cleanliness
quit