Browse files

Add first version of match specification generator

This is definitely a first version and contains practically no
checking at all of the input data. The LFE prettyprinter now knows
about match-spec as does emacs LFE mode. Also removed all tabs
user_guide.txt.
  • Loading branch information...
1 parent c067cc5 commit 0d6faf38bd115b1459b4721b96b3e53e5608c838 @rvirding committed Jun 8, 2011
Showing with 332 additions and 105 deletions.
  1. +118 −99 doc/user_guide.txt
  2. +3 −1 emacs/lfe-mode.el
  3. BIN emacs/lfe-mode.elc
  4. +4 −0 src/ChangeLog
  5. +1 −0 src/lfe.app.src
  6. +2 −1 src/lfe_io_pretty.erl
  7. +11 −4 src/lfe_macro.erl
  8. +193 −0 src/lfe_ms.erl
View
217 doc/user_guide.txt
@@ -1,15 +1,15 @@
- Lisp Flavoured Erlang
- =====================
+ Lisp Flavoured Erlang
+ =====================
Note {{ ... }} is use to denote optional syntax.
Special syntactic rules
-----------------------
-#b #o #d #x #23r - Based integers
-#(e e ... ) - Tuple constants
-#b(e e ... ) - Binary constant, e ... are valid literals segments
-[ ... ] - Allowed as alternative to ( ... )
+#b #o #d #x #23r - Based integers
+#(e e ... ) - Tuple constants
+#b(e e ... ) - Binary constant, e ... are valid literals segments
+[ ... ] - Allowed as alternative to ( ... )
Supported Core forms
--------------------
@@ -22,20 +22,20 @@ Supported Core forms
(tuple e ... )
(binary seg ... )
(lambda (arg ...) ...)
-(match-lambda - Matches clauses
- ((arg ... ) {{(when e ...)}} ...)
+(match-lambda
+ ((arg ... ) {{(when e ...)}} ...) - Matches clauses
... )
(let ((pat {{(when e ...)}} e)
...)
... )
-(let-function ((name lambda|match-lambda) - Only define local functions
- ... )
+(let-function ((name lambda|match-lambda) - Only define local functions
+ ... )
... )
-(letrec-function ((name lambda|match-lambda) - Only define local functions
- ... )
+(letrec-function ((name lambda|match-lambda) - Only define local functions
+ ... )
... )
-(let-macro ((name lambda-match-lambda) - Only define local macros
- ...)
+(let-macro ((name lambda-match-lambda) - Only define local macros
+ ...)
...)
(progn ... )
(if test true-expr {{false-expr}})
@@ -50,47 +50,48 @@ Supported Core forms
(try
e
{{(case ((pat {{(when e ...)}} ... )
- ... ))}}
+ ... ))}}
{{(catch
(((tuple type value ignore) {{(when e ...)}}
- - Must be tuple of length 3 here!
+ - Must be tuple of length 3 here!
... )
... )}}
{{(after ... )}})
(funcall func arg ... )
-(call mod func arg ... ) - Call to Mod:Func(Arg, ... )
+(call mod func arg ... ) - Call to Mod:Func(Arg, ... )
(define-function name lambda|match-lambda)
(define-macro name lambda|match-lambda)
- Define functions/macros at top-level.
+ Define functions/macros at top-level.
Supported macro forms
---------------------
(: mod func arg ... ) =>
- (call 'mod 'func arg ... )
-(? {{timeout {{default}} }}) - Receive next message,
- optional timeout and default value
+ (call 'mod 'func arg ... )
+(? {{timeout {{default}} }}) - Receive next message,
+ optional timeout and default value
(++ ... )
(list* ...)
-(let* (...) ... ) - Sequential let's
+(let* (...) ... ) - Sequential let's
(flet ((name (arg ...) ...)
...)
...)
-(flet* (...) ... ) - Sequential flet's
+(flet* (...) ... ) - Sequential flet's
(fletrec ((name (arg ...) ...)
- ...)
+ ...)
...)
- Define local functions, this will expand to lambda or
- match-lambda depending on structure as with defun.
-(cond ... ) - The normal cond, with (?= pat expr)
+ Define local functions, this will expand to lambda or
+ match-lambda depending on structure as with defun.
+(cond ... ) - The normal cond, with (?= pat expr)
(andalso ... )
(orelse ... )
-(fun func arity) - fun func/arity
-(fun mod func arity) - fun mod:func/arity
-(lc (qual ...) ...) - [ expr || qual ... ]
-(bc (qual ...) ...) - << expr || qual ... >>
+(fun func arity) - fun func/arity
+(fun mod func arity) - fun mod:func/arity
+(lc (qual ...) ...) - [ expr || qual ... ]
+(bc (qual ...) ...) - << expr || qual ... >>
+(match-spec ...) - ets:fun2ms(fun ( ) -> end)
Common Lisp inspired macros
---------------------------
@@ -99,27 +100,27 @@ Common Lisp inspired macros
(defun name
((argpat ...) ...)
...)
- Define a toplevel function, this will expand to lambda or
- match-lambda depending on structure.
+ Define a toplevel function, this will expand to lambda or
+ match-lambda depending on structure.
(defmacro name (arg ...) ...)
(defmacro name arg ...)
(defmacro name
((argpat ...) ...)
...)
- Define a top-level macro, this will expand to lambda or
- match-lambda depending on structure.
+ Define a top-level macro, this will expand to lambda or
+ match-lambda depending on structure.
(defsyntax name
(pat exp)
...)
- Define a top-level macro using Scheme inspired syntax-rules
- format.
+ Define a top-level macro using Scheme inspired syntax-rules
+ format.
(macrolet ((name (arg ...) ...)
- ...)
+ ...)
...)
(syntaxlet ((name (pat exp) ...)
- ...)
+ ...)
...)
- Define local macros in macro or syntax-rule format.
+ Define local macros in macro or syntax-rule format.
(defmodule name ...)
(defrecord name ...)
@@ -131,7 +132,7 @@ Older Scheme inspired macros
(define-syntax name
(syntax-rules (pat exp) ...)|(macro (pat body) ...))
(let-syntax ((name ...)
- ...)
+ ...)
...)
(begin ...)
(define-module name ...)
@@ -143,11 +144,11 @@ Patterns
Written as normal data expressions where symbols are variables and use
quote to match explicit values. Binaries and tuples have special syntax.
-{ok,X} -> (tuple 'ok x)
-error -> 'error
-{yes,[X|Xs]} -> (tuple 'yes (cons x xs))
-<<34,F/float>> -> (binary 34 (f float))
-[P|Ps]=All -> (= (cons p ps) all)
+{ok,X} -> (tuple 'ok x)
+error -> 'error
+{yes,[X|Xs]} -> (tuple 'yes (cons x xs))
+<<34,F/float>> -> (binary 34 (f float))
+[P|Ps]=All -> (= (cons p ps) all)
Repeated variables are *NOT* supported in patterns, there is no
automatic comparison of values. It must explicitly be done in a
@@ -180,11 +181,11 @@ following guard expressions:
(list gexpr ...)
(tuple gexpr ...)
(binary ...)
-(progn gtest ...) - Sequence of guard tests
+(progn gtest ...) - Sequence of guard tests
(if gexpr gexpr gexpr)
(type-test e)
-(guard-bif ...) - Guard BIFs, arithmetic,
- boolean and comparison operators
+(guard-bif ...) - Guard BIFs, arithmetic,
+ boolean and comparison operators
An empty guard, (when), always succeeds as there is no test which
fails. This simplifies writing macros which handle guards.
@@ -216,11 +217,11 @@ Function shadowing
Unqualified functions shadow as stated above which results in the
following order within a module, outermost to innermost:
- Predefined BIFs (same as in vanilla Erlang)
- Predefined LFE BIFs
- Imports
- Top-level defines
- Flet/fletrec
+ Predefined BIFs (same as in vanilla Erlang)
+ Predefined LFE BIFs
+ Imports
+ Top-level defines
+ Flet/fletrec
This means that it is perfectly legal to shadow BIFs by imports,
BIFs/imports by top-level functions and BIFs/imports/top-level by
@@ -239,10 +240,10 @@ Module definition
(defmodule name
(export (f 2) (g 1) ... )
- (export all) ;Export all functions
+ (export all) ;Export all functions
(import (from mod (f1 2) (f2 1) ... )
- (rename mod ((f1 2) sune) ((f2 1) kurt) ... ))
- (import (prefix mod mod-prefix)) - NYI
+ (rename mod ((f1 2) sune) ((f2 1) kurt) ... ))
+ (import (prefix mod mod-prefix)) - NYI
(attr-1 value-1 value-2)
... )
@@ -387,37 +388,37 @@ field-name value to get non-default values. E.g. for
(make-person name '"Robert" age 54)
- Will create a new person record with the name field set to
- "Robert", the age field set to 54 and the address field set to
- the default "".
+ Will create a new person record with the name field set to
+ "Robert", the age field set to 54 and the address field set to
+ the default "".
(match-person name name age 55)
- Will match a person with age 55 and bind the variable name to
- the name field of the record. Can use any variable name here.
+ Will match a person with age 55 and bind the variable name to
+ the name field of the record. Can use any variable name here.
(is-person john)
- Test if john is a person record.
+ Test if john is a person record.
(emp-person age '$1)
- Create an ets/mnesia match pattern for record person where the
- age field is set to $1 and all other fields are set to '_.
+ Create an ets/mnesia match pattern for record person where the
+ age field is set to $1 and all other fields are set to '_.
(person-address john)
- Return the address field of the person record john.
+ Return the address field of the person record john.
(set-person-address john '"back street")
- Sets the address field of the person record john to
- "back street".
+ Sets the address field of the person record john to
+ "back street".
(set-person john age 35 address '"front street")
- In the person record john set the age field to 35 and the
- address field to "front street".
+ In the person record john set the age field to 35 and the
+ address field to "front street".
Binaries/bitstrings
-------------------
@@ -427,12 +428,12 @@ A binary is
(binary seg ... )
where seg is
- byte
- string
- (val integer|float|binary|bitstring|bytes|bits
- (size n) (unit n)
- big-endian|little-endian|native-endian|little|native|big
- signed|unsigned)
+ byte
+ string
+ (val integer|float|binary|bitstring|bytes|bits
+ (size n) (unit n)
+ big-endian|little-endian|native-endian|little|native|big
+ signed|unsigned)
Val can also be a string in which case the specifiers will be applied
to every character in the string. As strings are just lists of
@@ -458,11 +459,11 @@ elements of the binary.
The supported qualifiers, in both list/binary comprehensions are:
-(<- pat {{guard}} list-expr) - Extract elements from a list expression
+(<- pat {{guard}} list-expr) - Extract elements from a list expression
(<= bin-pat {{guard}} binary-expr) - Extract elements from a binary/bits
- expression
-(?= pat {{guard}} expr) - Match test and bind variables in pat
-expr - Normal boolean test
+ expression
+(?= pat {{guard}} expr) - Match test and bind variables in pat
+expr - Normal boolean test
Some examples:
@@ -473,10 +474,10 @@ Some examples:
returns a list of all the even elements of the list l1 which are
greater than 5.
-(bc ((<= (f float (size 32)) b1) ;No wrapping, only bitseg needed
+(bc ((<= (f float (size 32)) b1) ;No wrapping, only bitseg needed
(> f 10.0))
(: io fwrite '"~p\n" (list f))
- (f float (size 64))) ;No wrapping, only bitseg needed
+ (f float (size 64))) ;No wrapping, only bitseg needed
returns a binary of floats of size 64 of floats which are larger than
10.0 from the binary b1 and of size 32. The returned numbers are first
@@ -492,42 +493,60 @@ stop extraction. Using a guard is probably not what you want!
Normal vanilla Erlang does the same thing but does not allow guards.
+ETS and Mnesia
+--------------
+
+Apart from (emp-record ...) macros for ETS/Mnesia match patterns LFE
+also supports match specifications and Query List Comprehensions. The
+syntax for a match specification is the same as for match-lambdas:
+
+(match-spec
+ ((arg ... ) {{(when e ...)}} ...) - Matches clauses
+ ... )
+
+It is a macro which creates the match specification structure which is
+used in ets:select and mnesia:select. The same restrictions as to what
+can be done apply as for vanilla match specifications.
+
+(: ets select db (match-spec
+ ([(tuple _ a b)] (when (> a 3)) (tuple 'ok b))))
+
Predefined LFE functions
------------------------
The following more or less standard lisp functions are pre-defined:
(<arith_op> expr ...)
(<comp_op> expr ...)
- The standard arithmentic operators, + - * /, and comparison
- operators, > >= < =< == /= =:= =/= , can take multiple
- arguments the same as their standard lisp counterparts. This
- is still experimental and implemented using macros. They do,
- however, behave like normal functions and evaluate ALL their
- arguments before doing the arithmetic/comparisons operations.
+ The standard arithmentic operators, + - * /, and comparison
+ operators, > >= < =< == /= =:= =/= , can take multiple
+ arguments the same as their standard lisp counterparts. This
+ is still experimental and implemented using macros. They do,
+ however, behave like normal functions and evaluate ALL their
+ arguments before doing the arithmetic/comparisons operations.
(acons key value list)
(assoc key list)
(rassoc value list)
- The standard association list functions.
+ The standard association list functions.
(subst new old tree)
(subst-if new test tree)
(subst-if-not new test tree)
- The standard substituition functions.
+ The standard substituition functions.
(eval expr)
- Evaluate the expression expr. Note that only the pre-defined
- lisp functions, erlang BIFs and exported functions can be
- called. Also no local variables can be accessed. To access
- local variables the expr to be evaluated can be wrapped in a
- let defining these.
+ Evaluate the expression expr. Note that only the pre-defined
+ lisp functions, erlang BIFs and exported functions can be
+ called. Also no local variables can be accessed. To access
+ local variables the expr to be evaluated can be wrapped in a
+ let defining these.
- For example if the data we wish to evaluate is in the variable
- expr and it assumes there is a local variable "foo" which it
- needs to access then we could evaluate it by calling:
+ For example if the data we wish to evaluate is in the variable
+ expr and it assumes there is a local variable "foo" which it
+ needs to access then we could evaluate it by calling:
- (eval `(let ((foo ,foo)) ,expr))
+ (eval `(let ((foo ,foo)) ,expr))
Notes
-----
View
4 emacs/lfe-mode.el
@@ -108,7 +108,7 @@ Leave point after open-bracket."
(eval-when-compile
(list
(list (concat "(\\(def\\("
- ;; Base forms and old model names.
+ ;; Base forms and old style names.
"\\(ine\\(-module\\|-function\\|-macro\\|"
"-syntax\\|-record\\)?\\)\\|"
;; New model function names
@@ -161,6 +161,7 @@ Leave point after open-bracket."
"andalso" "cond" "do" "fun" "list*" "let*" "flet*" "macro"
"orelse" "syntax-rules" "lc" "bc" "flet" "fletrec"
"macrolet" "syntaxlet" "begin" "let-syntax"
+ "match-spec"
":" "?" "++") t)
"\\>") '(1 font-lock-keyword-face))
;; Type tests.
@@ -255,6 +256,7 @@ Leave point after open-bracket."
(put 'do 'lfe-indent-function 2)
(put 'lc 'lfe-indent-function 1)
(put 'bc 'lfe-indent-function 1)
+(put 'match-spec 'lfe-indent-function 0)
;; The end.
(provide 'lfe-mode)
View
BIN emacs/lfe-mode.elc
Binary file not shown.
View
4 src/ChangeLog
@@ -1,3 +1,7 @@
+2011-06-08 Robert Virding <rv@renat.local>
+
+ * lfe_macro.erl (exp_predef): Add match-spec macro.
+
2011-06-05 Robert Virding <rv@renat.local>
* lfe_macro.erl (exp_predef): Add simple include-lib macro.
View
1 src/lfe.app.src
@@ -14,6 +14,7 @@
lfe_lib,
lfe_lint,
lfe_macro,
+ lfe_ms,
lfe_parse,
lfe_pmod,
lfe_scan,
View
3 src/lfe_io_pretty.erl
@@ -1,4 +1,4 @@
-%% Copyright (c) 2008-2010 Robert Virding. All rights reserved.
+%% Copyright (c) 2008-2011 Robert Virding. All rights reserved.
%%
%% Redistribution and use in source and binary forms, with or without
%% modification, are permitted provided that the following conditions
@@ -222,4 +222,5 @@ indent_type(syntaxlet) -> 1;
indent_type('do') -> 2;
indent_type('lc') -> 1; %List comprehensions
indent_type('bc') -> 1; %Binary comprehensions
+indent_type('match-spec') -> 0;
indent_type(_) -> none.
View
15 src/lfe_macro.erl
@@ -1,4 +1,4 @@
-%% Copyright (c) 2008-2010 Robert Virding. All rights reserved.
+%% Copyright (c) 2008-2011 Robert Virding. All rights reserved.
%%
%% Redistribution and use in source and binary forms, with or without
%% modification, are permitted provided that the following conditions
@@ -747,9 +747,18 @@ exp_predef([macrolet,Defs|Body], _, St) ->
exp_predef([syntaxlet,Defs|Body], _, St) ->
Mdefs = map(fun ([Name|Rules]) -> exp_rules(Name, [], Rules) end, Defs),
{yes,['let-macro',Mdefs|Body],St};
+%% This has to go here for the time being so as to be able to macro
+%% expand body.
+exp_predef(['match-spec'|Body], Env, St0) ->
+ %% Expand it like a match-lambda.
+ {Exp,St1} = expand_ml_clauses(Body, Env, St0),
+ MS = lfe_ms:expand(Exp),
+ {yes,MS,St1};
%% This was not a call to a predefined macro.
exp_predef(_, _, _) -> no.
+%% exp_bif(Bif, Args) -> Expansion.
+
exp_bif(B, As) -> [call,?Q(erlang),?Q(B)|As].
%% exp_args(Args, State) -> {LetBinds,State}.
@@ -803,12 +812,10 @@ exp_append(Args) ->
[[]|Es] -> ['++'|Es];
%% Default cases with unquoted arg.
[E] -> E; %Last arg not checked
- [E|Es] -> exp_append(E, Es);
+ [E|Es] -> exp_bif('++', [E,['++'|Es]]);
[] -> []
end.
-exp_append(E, Es) -> [call,?Q(erlang),?Q('++'),E,['++'|Es]].
-
%% exp_defun(Name, Def) -> Lambda | Match-Lambda.
%% Educated guess whether traditional (defun name (a1 a2 ...) ...)
%% or matching (defun name (patlist1 ...) (patlist2 ...))
View
193 src/lfe_ms.erl
@@ -0,0 +1,193 @@
+%% Copyright (c) 2011 Robert Virding. All rights reserved.
+%%
+%% Redistribution and use in source and binary forms, with or without
+%% modification, are permitted provided that the following conditions
+%% are met:
+%%
+%% 1. Redistributions of source code must retain the above copyright
+%% notice, this list of conditions and the following disclaimer.
+%% 2. Redistributions in binary form must reproduce the above copyright
+%% notice, this list of conditions and the following disclaimer in the
+%% documentation and/or other materials provided with the distribution.
+%%
+%% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+%% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+%% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+%% FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+%% COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+%% INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+%% BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+%% LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+%% CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+%% LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+%% ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+%% POSSIBILITY OF SUCH DAMAGE.
+
+%%% File : lfe_ms.erl
+%%% Author : Robert Virding
+%%% Purpose : Lisp Flavoured Erlang match specification expander.
+
+%%% Expand match specification into vanilla compatible data
+%%% structure. We assume that all macros in the match spec have
+%%% already been expanded. These functions are intended to be used
+%%% within macros so they return code which when evaluated return the
+%%% match-spec.
+
+-module(lfe_ms).
+
+-export([expand/1,format_error/1]).
+
+-import(lists, [mapfoldl/3]).
+
+%% ets:test_ms/2.
+
+%% format_error(Error) -> ErrorString.
+
+format_error(E) -> erlang:error({unknown_error,E}). %Remove later!
+
+-define(Q(E), [quote,E]). %We do a lot of quoting!
+
+-record(ms, {dc=0, %Dollar variable count
+ bs=[] %Variable/$var bindings
+ }).
+
+%% expand(MSBody) -> Expansion.
+%% Expand the match spec body.
+
+expand(Cls) ->
+ {Exp,_} = clauses(Cls, #ms{}),
+ Exp.
+
+%% clauses(MSClauses, State) -> {Patterns,State}.
+
+clauses([Cl0|Cls0], St0) ->
+ {Cl1,St1} = clause(Cl0, St0),
+ {Cls1,St2} = clauses(Cls0, St1),
+ {[cons,Cl1,Cls1],St2};
+clauses([], St) -> {[],St}.
+
+%% clause(ClauseBody, State) -> {{Head,Guard,Body},State}.
+
+clause([H0,['when'|G0]|B0], St0) ->
+ St1 = St0#ms{dc=0,bs=[]}, %Reset clause local data
+ {H1,St2} = head(H0, St1),
+ {G1,St3} = guard(G0, St2),
+ {B1,St4} = body(B0, St3),
+ {[tuple,H1,G1,B1],St4};
+clause([H0|B0], St0) ->
+ {H1,St1} = head(H0, St0),
+ {B1,St2} = body(B0, St1),
+ {[tuple,H1,[],B1],St2}.
+
+%% head(Patterns, State) -> {Pattern,State}.
+%% Expand a head which can only consist of one argument. Only allow
+%% aliasing at the top-level and only to a variable.
+
+head([['=',S,Pat]], St0) when is_atom(S) ->
+ St1 = new_binding(S, '$_', St0),
+ pattern(Pat, St1);
+head([['=',Pat,S]], St0) when is_atom(S) ->
+ St1 = new_binding(S, '$_', St0),
+ pattern(Pat, St1);
+%% head([Pat], St0) when is_atom(Pat) -> %WRONG!!
+%% St1 = new_binding(Pat, '$_', St0),
+%% pattern(Pat, St1);
+head([Pat], St) ->
+ pattern(Pat, St).
+
+pattern('_', St) -> {?Q('_'),St};
+pattern(Symb, St0) when is_atom(Symb) ->
+ {Dv,St1} = pat_binding(Symb, St0),
+ {?Q(Dv),St1};
+pattern([quote,_]=E, St) -> {E,St};
+pattern([cons,H0,T0], St0) ->
+ {H1,St1} = pattern(H0, St0),
+ {T1,St2} = pattern(T0, St1),
+ {[cons,H1,T1],St2};
+pattern([list|Ps0], St0) ->
+ {Ps1,St1} = pat_list(Ps0, St0),
+ {[list|Ps1],St1};
+pattern([tuple|Ps0], St0) ->
+ {Ps1,St1} = pat_list(Ps0, St0),
+ {[tuple|Ps1],St1};
+%% Support old no constructor style list forms.
+pattern([H0|T0], St0) ->
+ {H1,St1} = pattern(H0, St0),
+ {T1,St2} = pattern(T0, St1),
+ {[H1,T1],St2};
+pattern(E, St) -> {E,St}. %Atomic
+
+pat_list(Ps, St) -> mapfoldl(fun pattern/2, St, Ps).
+
+%% pat_binding(Var, Status) -> {DVar,Status}.
+%% Get dollar var for variable, creating a new one if neccessary.
+
+pat_binding(Var, St0) ->
+ case find_binding(Var, St0) of
+ {ok,Dv} -> {Dv,St0};
+ error ->
+ {Dv,St1} = new_dollar(St0),
+ {Dv,new_binding(Var, Dv, St1)}
+ end.
+
+guard([T0|Ts0], St0) ->
+ {T1,St1} = test(T0, St0),
+ {Ts1,St2} = guard(Ts0, St1),
+ {[cons,T1,Ts1],St2};
+guard([], St) -> {[],St}.
+
+test(T, St) -> expr(T, St). %Nothing special here yet
+
+body([E0|Es0], St0) ->
+ {E1,St1} = expr(E0, St0),
+ {Es1,St2} = body(Es0, St1),
+ {[cons,E1,Es1],St2};
+body([], St) -> {[],St}.
+
+expr(S, St) when is_atom(S) ->
+ case find_binding(S, St) of
+ {ok,Dv} -> {?Q(Dv),St};
+ error -> {[tuple,?Q(const),?Q(S)],St}
+ end;
+expr([quote,_]=E, St) -> {E,St};
+expr([cons,H0,T0], St0) ->
+ {H1,St1} = expr(H0, St0),
+ {T1,St2} = expr(T0, St1),
+ {[cons,H1,T1],St2};
+expr([list|Es0], St0) ->
+ {Es1,St1} = expr_list(Es0, St0),
+ {[list|Es1],St1};
+expr([tuple|Es0], St0) ->
+ {Es1,St1} = expr_list(Es0, St0),
+ {[tuple,[tuple|Es1]],St1}; %Yes this is what it is
+%% Special match spec calls.
+expr([bindings], St) -> {?Q('$*'),St}; %Special calls
+expr([object], St) -> {?Q('$_'),St};
+%% General function calls.
+expr([call,?Q(erlang),?Q(Op)|Es], St) when is_atom(Op) ->
+ expr([Op|Es], St); %No checking!
+expr([Op|Es0], St0) when is_atom(Op) ->
+ {Es1,St1} = expr_list(Es0, St0), %No checking!
+ {[tuple,?Q(Op)|Es1],St1};
+expr(T, St) when is_tuple(T) -> %Constant
+ {[tuple,T],St}; %???
+expr(E, St) -> {E,St}. %Atomic
+
+expr_list(Es, St) -> mapfoldl(fun expr/2, St, Es).
+
+%% new_binding(Name, Value, State) -> State.
+%% find_binding(Name, State) -> {ok,Value} | error.
+%% fetch_binding(Name, State) -> Value.
+
+new_binding(Var, Val, #ms{bs=Bs}=St) ->
+ St#ms{bs=orddict:store(Var, Val, Bs)}.
+
+find_binding(Var, #ms{bs=Bs}) ->
+ orddict:find(Var, Bs).
+
+fetch_binding(Var, #ms{bs=Bs}) ->
+ orddict:fetch(Var, Bs).
+
+new_dollar(St) ->
+ C = St#ms.dc,
+ {list_to_atom("$" ++ integer_to_list(C)),St#ms{dc=C+1}}.

0 comments on commit 0d6faf3

Please sign in to comment.