picolisp/step6_file.l

   1 (de load-relative (Path)
   2    (load (pack (car (file)) Path)) )
   3
   4 (load-relative "readline.l")
   5 (load-relative "types.l")
   6 (load-relative "reader.l")
   7 (load-relative "printer.l")
   8 (load-relative "env.l")
   9 (load-relative "func.l")
  10 (load-relative "core.l")
  11
  12 (de READ (String)
  13    (read-str String) )
  14
  15 (def '*ReplEnv (MAL-env NIL))
  16 (for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind)))
  17
  18 (de EVAL (Ast Env)
  19    (catch 'done
  20       (while t
  21          (if (and (= (MAL-type Ast) 'list) (MAL-value Ast))
  22             (let (Ast* (MAL-value Ast)
  23                   A0* (MAL-value (car Ast*))
  24                   A1 (cadr Ast*)
  25                   A1* (MAL-value A1)
  26                   A2 (caddr Ast*)
  27                   A3 (cadddr Ast*) )
  28                (cond
  29                   ((= A0* 'def!)
  30                    (throw 'done (set> Env A1* (EVAL A2 Env))) )
  31                   ((= A0* 'let*)
  32                    (let Env* (MAL-env Env)
  33                       (for (Bindings A1* Bindings)
  34                          (let (Key (MAL-value (pop 'Bindings))
  35                                Value (EVAL (pop 'Bindings) Env*) )
  36                             (set> Env* Key Value) ) )
  37                       (setq Env Env* Ast A2) ) ) # TCO
  38                   ((= A0* 'do)
  39                    (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*)))
  40                    (setq Ast (last Ast*)) ) # TCO
  41                   ((= A0* 'if)
  42                    (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false)))
  43                       (setq Ast A2) # TCO
  44                       (if A3
  45                          (setq Ast A3) # TCO
  46                          (throw 'done *MAL-nil) ) ) )
  47                   ((= A0* 'fn*)
  48                    (let (Binds (mapcar MAL-value A1*)
  49                          Body A2
  50                          Fn (MAL-fn
  51                                (curry (Env Binds Body) @
  52                                   (let Env* (MAL-env Env Binds (rest))
  53                                      (EVAL Body Env*) ) ) ) )
  54                       (throw 'done (MAL-func Env Body Binds Fn)) ) )
  55                   (T
  56                      (let (Ast* (MAL-value (eval-ast Ast Env))
  57                            Fn (car Ast*)
  58                            Args (cdr Ast*) )
  59                         (if (isa '+MALFn Fn)
  60                            (throw 'done (apply (MAL-value Fn) Args))
  61                            (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args)
  62                               (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) )
  63             (throw 'done (eval-ast Ast Env)) ) ) ) )
  64
  65 (de eval-ast (Ast Env)
  66    (let Value (MAL-value Ast)
  67       (case (MAL-type Ast)
  68          (symbol (get> Env Value))
  69          (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value)))
  70          (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value)))
  71          (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value)))
  72          (T Ast) ) ) )
  73
  74 (set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv))))
  75 (set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv)))))
  76
  77 (de PRINT (Ast)
  78    (pr-str Ast T) )
  79
  80 (de rep (String)
  81    (PRINT (EVAL (READ String) *ReplEnv)) )
  82
  83 (rep "(def! not (fn* (a) (if a false true)))")
  84 (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))")
  85
  86 (load-history ".mal_history")
  87
  88 (if (argv)
  89    (rep (pack "(load-file \"" (car (argv)) "\")"))
  90    (use Input
  91       (until (=0 (setq Input (readline "user> ")))
  92          (let Output (catch 'err (rep Input))
  93             (if (isa '+MALError Output)
  94                (let Message (MAL-value Output)
  95                   (unless (= (MAL-value Message) "end of token stream")
  96                      (prinl "[error] " (pr-str Message)) ) )
  97                (prinl Output) ) ) ) ) )
  98
  99 (prinl)
 100 (bye)