Skip to content

Instantly share code, notes, and snippets.

Created January 13, 2011 20:05
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save rocketnia/778492 to your computer and use it in GitHub Desktop.
Save rocketnia/778492 to your computer and use it in GitHub Desktop.
An Arc fexpr example.
; 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
; <>. 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
(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
(= 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
(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)
(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)
; 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))
(xloop (body body)
(whenlet (first . rest) body
(if rest
(do (feval first body-env)
(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)
(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)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment