picolisp/step7_quote.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 is-pair (Ast)
  19    (and (memq (MAL-type Ast) '(list vector)) (MAL-value Ast) T) )
  20
  21 (de quasiquote (Ast)
  22    (if (not (is-pair Ast))
  23       (MAL-list (list (MAL-symbol 'quote) Ast))
  24       (let A (MAL-value Ast)
  25          (cond
  26             ((= (MAL-value (car A)) 'unquote)
  27              (cadr A) )
  28             ((and (is-pair (car A))
  29                 (= (MAL-value (car (MAL-value (car A)))) 'splice-unquote) )
  30              (MAL-list (list (MAL-symbol 'concat)
  31                           (cadr (MAL-value (car A)))
  32                           (quasiquote (MAL-list (cdr A))) ) ) )
  33             (T
  34                (MAL-list (list (MAL-symbol 'cons)
  35                             (quasiquote (car A))
  36                             (quasiquote (MAL-list (cdr A))) ) ) ) ) ) ) )
  37
  38 (de EVAL (Ast Env)
  39    (catch 'done
  40       (while t
  41          (if (and (= (MAL-type Ast) 'list) (MAL-value Ast))
  42             (let (Ast* (MAL-value Ast)
  43                   A0* (MAL-value (car Ast*))
  44                   A1 (cadr Ast*)
  45                   A1* (MAL-value A1)
  46                   A2 (caddr Ast*)
  47                   A3 (cadddr Ast*) )
  48                (cond
  49                   ((= A0* 'def!)
  50                    (throw 'done (set> Env A1* (EVAL A2 Env))) )
  51                   ((= A0* 'quote)
  52                    (throw 'done A1) )
  53                   ((= A0* 'quasiquote)
  54                    (setq Ast (quasiquote A1)) ) # TCO
  55                   ((= A0* 'let*)
  56                    (let Env* (MAL-env Env)
  57                       (for (Bindings A1* Bindings)
  58                          (let (Key (MAL-value (pop 'Bindings))
  59                                Value (EVAL (pop 'Bindings) Env*) )
  60                             (set> Env* Key Value) ) )
  61                       (setq Env Env* Ast A2) ) ) # TCO
  62                   ((= A0* 'do)
  63                    (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*)))
  64                    (setq Ast (last Ast*)) ) # TCO
  65                   ((= A0* 'if)
  66                    (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false)))
  67                       (setq Ast A2) # TCO
  68                       (if A3
  69                          (setq Ast A3) # TCO
  70                          (throw 'done *MAL-nil) ) ) )
  71                   ((= A0* 'fn*)
  72                    (let (Binds (mapcar MAL-value A1*)
  73                          Body A2
  74                          Fn (MAL-fn
  75                                (curry (Env Binds Body) @
  76                                   (let Env* (MAL-env Env Binds (rest))
  77                                      (EVAL Body Env*) ) ) ) )
  78                       (throw 'done (MAL-func Env Body Binds Fn)) ) )
  79                   (T
  80                      (let (Ast* (MAL-value (eval-ast Ast Env))
  81                            Fn (car Ast*)
  82                            Args (cdr Ast*) )
  83                         (if (isa '+MALFn Fn)
  84                            (throw 'done (apply (MAL-value Fn) Args))
  85                            (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args)
  86                               (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) )
  87             (throw 'done (eval-ast Ast Env)) ) ) ) )
  88
  89 (de eval-ast (Ast Env)
  90    (let Value (MAL-value Ast)
  91       (case (MAL-type Ast)
  92          (symbol (get> Env Value))
  93          (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value)))
  94          (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value)))
  95          (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value)))
  96          (T Ast) ) ) )
  97
  98 (set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv))))
  99 (set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv)))))
 100
 101 (de PRINT (Ast)
 102    (pr-str Ast T) )
 103
 104 (de rep (String)
 105    (PRINT (EVAL (READ String) *ReplEnv)) )
 106
 107 (rep "(def! not (fn* (a) (if a false true)))")
 108 (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))")
 109
 110 (load-history ".mal_history")
 111
 112 (if (argv)
 113    (rep (pack "(load-file \"" (car (argv)) "\")"))
 114    (use Input
 115       (until (=0 (setq Input (readline "user> ")))
 116          (let Output (catch 'err (rep Input))
 117             (if (isa '+MALError Output)
 118                (let Message (MAL-value Output)
 119                   (unless (= (MAL-value Message) "end of token stream")
 120                      (prinl "[error] " (pr-str Message)) ) )
 121                (prinl Output) ) ) ) ) )
 122
 123 (prinl)
 124 (bye)