An Arc fexpr example.

kernelish.arc

; kernelish.arc
;
; Copyright 2011 Ross Angle. However, you can use this for whatever
; you want. Don't bother giving me credit.
;
;
; This is an example used in reply to
; <http://arclanguage.org/reply?id=13317>. I originally posted an
; untested version with lots of bugs, but I went through and corrected
; them until it actually seemed to work. This should be a pretty
; simple starting point for a Kernel-inspired fexpr language.
;
; As in Kernel, this is a lexically scoped fexpr language in which
; each fexpr takes both a list of unevaluated operands and a calling
; environment. That way it can use the caller's lexical scope to
; evaluate the operands.
;
; This doesn't embrace other aspects of Kernel, such as core support
; for cyclic lists, etc. It's just an example!


(mac thunk body
  `(fn () ,@body))

(def fenv-get (env var)
  (case type.env
    arc-fenv       eval.var                        ; unused
    total-fenv     (car:or= rep.env.var list.nil)
    shadowed-fenv  (let (binds parent) rep.env
                     (aif do.binds.var
                       car.it
                       (fenv-get parent var)))))

(def fenv-set (env var val)
  (case type.env
    arc-fenv       (eval `(assign ,var (',thunk.val)))     ; unused
    total-fenv     (= (car:or= rep.env.var list.nil) val)
    shadowed-fenv  (let (binds parent) rep.env
                     (aif do.binds.var
                       (= car.it val)
                       (fenv-set parent var val)))))

(def shadow (binds parent)
  (annotate 'shadowed-fenv (list binds parent)))

; We ignore local bindings of '!ignored, treating them like Kernel's
; #ignored.
(def bind (vars vals)
  (w/table result
    (catch:withs
        (orig-vars vars
         orig-vals vals
         err (thunk:err:+
               "The binding of " (tostring write.orig-vars) " to "
               (tostring write.orig-vals) " failed.")
         acc (fn (var val)
               (case var '!ignored nil
                 (zap [if _ call.err list.val] do.result.var))))
      (while vars
        (if atom.vars   (throw:do.acc vars vals)
            acons.vals  (do.acc pop.vars pop.vals)
                        call.err))
      (if vals call.err))))

(= fenv-table* (table))

(= fenv* (annotate 'total-fenv fenv-table*))

; Uncomment this to access Arc variables directly. But consider this:
; If you define something basic like 'case from within the fexpr
; language, it'll override Arc's 'case and mess everything up. So the
; good vocabulary will effectively have been stolen by Arc.
;
;(= fenv* (shadow fenv-table* (annotate 'arc-fenv nil)))

(def feval (expr (o env fenv*))
  (case type.expr
    cons  (fapply (feval car.expr env) cdr.expr env)
    sym   (fenv-get env expr)
          expr))

; The 'applicative type is totally Kernel's idea.
(def fapply (op args (o env fenv*))
  (case type.op
    fexpr        (apply rep.op env args)
    applicative  (fapply funwrap.op (map [feval _ env] args) env)
                 (apply op (map [feval _ env] args))))

(def fn-fx (func)
  (annotate 'fexpr func))

(mac fx (parms env . body)
  `(fn-fx:fn ,(cons env parms) ,@body))

(def fn-fexport (var val)
  (= (car:or= fenv-table*.var list.nil) val))

(mac fexport (var val)
  `(fn-fexport ',var ,val))

(mac fdef (name parms . body)
  `(fexport ,name (fn ,parms ,@body)))

(mac ffex (name parms env . body)
  `(fexport ,name (fx ,parms ,env ,@body)))

(def call (func . args)
  (apply func args))

(mac xloop (binds . body)
  (zap pair binds)
  `((rfn next ,(map car binds) ,@body) ,@(map cadr binds)))

(ffex fx (parms env . body) lex-env
  (fx given-parms given-env
    (let body-env (shadow (bind (cons env parms)
                                (cons given-env given-parms))
                          lex-env)
      (xloop (body body)
        (whenlet (first . rest) body
          (if rest
            (do (feval first body-env)
                do.next.rest)
            (feval first body-env)))))))


; We use a singleton list so that an applicative can wrap an
; applicative. Using 'annotate does nothing to a value that's already
; of the given type.

(def fwrap (fexpr)
  (annotate 'applicative list.fexpr))

(def funwrap (applicative)
  rep.applicative.0)

(fdef wrap args (apply fwrap args))
(fdef unwrap args (apply funwrap args))


(ffex assign (var val) env
  (fenv-set env var (feval val env)))

(fdef sref args (apply sref args))

(fdef car (x) car.x)
(fdef cdr (x) cdr.x)

; This is Kernel-inspired.
;
;    (list* 1 2 3 '(4 5 6))
; => (apply apply list '(1 2 3 (4 5 6)))
; => (apply list 1 2 3 '(4 5 6))
; => (list 1 2 3 4 5 6)
;
; One exception is that it doesn't create improper lists.
;
(fdef list* args (apply apply list args))


; These both use the dynamic environment if no environment is passed.
; The optional arguments may look like the shouldn't work, but the
; 'dynenv parameters are actually put first in the Arc argument list.
; (Note that optional arguments aren't supported from within the
; language.)

(fexport eval (fwrap:fx (expr (o env dynenv)) dynenv
                (feval expr env)))

(fexport apply (fwrap:fx (func args (o env dynenv)) dynenv
                 (fapply func args env)))

(ffex if body env
  (iflet (first . rest) body
    (iflet (then . elses) rest
      (if (feval first env)
        (feval then env)
        (feval `(if ,@elses) env)))
    (feval first env)))

(ffex arc body env
  (eval `(do ,@body)))

(feval '(assign quote (fx (expr) env expr)))

(feval '(assign fn
          (fx (parms . body) env
            (wrap (eval (list* 'fx parms '!ignored body) env)))))

(feval '(assign list (fn args args)))