Permalink
Browse files

A twisty maze of patches, all alike.

  • Loading branch information...
1 parent e040d74 commit 1d7ce6729c3631a664e495aa7d565c27d8442189 @rvirding committed Jan 26, 2010
Showing with 173 additions and 142 deletions.
  1. +1 −1 COPYRIGHT
  2. +57 −58 examples/lfe_eval.lfe
  3. +23 −0 src/ChangeLog
  4. +27 −20 src/lfe_eval.erl
  5. +3 −10 src/lfe_io.erl
  6. +52 −49 src/lfe_lint.erl
  7. +10 −4 src/lfe_macro.erl
View
@@ -1,4 +1,4 @@
-Copyright (c) 2008 Robert Virding. All rights reserved.
+Copyright (c) 2008-2010 Robert Virding. All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
View
@@ -1,4 +1,4 @@
-;; Copyright (c) 2008 Robert Virding. All rights reserved.
+;; Copyright (c) 2008-2010 Robert Virding. All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
@@ -157,7 +157,7 @@
(foldl (lambda (psp acc)
(let* (((tuple val spec) psp)
(bin (eval-field val spec env)))
- (binary (acc binary (unit 1)) (bin binary (unit 1)))))
+ (binary (acc bitstring) (bin bitstring))))
#b() psps))
(defun eval-field (val spec env)
@@ -187,42 +187,42 @@
(val-or-def sz 64) (val-or-def un 1)
(val-or-def si 'unsigned) (val-or-def en 'big)))
('binary
- (tuple 'integer
+ (tuple 'binary
(val-or-def sz 'all) (val-or-def un 8)
(val-or-def si 'unsigned) (val-or-def en 'big)))
('bitstring
(tuple 'binary
(val-or-def sz 'all) (val-or-def un 1)
(val-or-def si 'unsigned) (val-or-def en 'big)))))))
-(defun parse-bitspec (sp spec env)
- (case sp
+(defun parse-bitspec (spec sp env)
+ (case spec
;; Types.
- ('integer (set-spec-type spec 'integer))
- ('float (set-spec-type spec 'float))
- ('binary (set-spec-type spec 'binary))
- ('bytes (set-spec-type spec 'binary))
- ('bitstring (set-spec-type spec 'bitstring))
- ('bits (set-spec-type spec 'bitstring))
+ ('integer (set-spec-type sp 'integer))
+ ('float (set-spec-type sp 'float))
+ ('binary (set-spec-type sp 'binary))
+ ('bytes (set-spec-type sp 'binary))
+ ('bitstring (set-spec-type sp 'bitstring))
+ ('bits (set-spec-type sp 'bitstring))
;; Unicode types.
- ('utf-8 (set-spec-type spec 'utf8))
- ('utf-16 (set-spec-type spec 'utf16))
- ('utf-32 (set-spec-type spec 'utf32))
+ ('utf-8 (set-spec-type sp 'utf8))
+ ('utf-16 (set-spec-type sp 'utf16))
+ ('utf-32 (set-spec-type sp 'utf32))
;; Endianess.
- ('big-endian (set-spec-type spec 'big))
- ('little-endian (set-spec-type spec 'little))
- ('big-native (set-spec-type spec 'native))
+ ('big-endian (set-spec-type sp 'big))
+ ('little-endian (set-spec-type sp 'little))
+ ('big-native (set-spec-type sp 'native))
;; Sign.
- ('signed (set-spec-sign spec 'signed))
- ('unsigned (set-spec-sign spec 'unsigned))
+ ('signed (set-spec-sign sp 'signed))
+ ('unsigned (set-spec-sign sp 'unsigned))
;; Size
(('size n)
(let ((size (eval-expr n env)))
- (set-spec-size spec size)))
+ (set-spec-size sp size)))
(('unit n) (when (and (is_integer n) (> n 0)))
- (set-spec-unit spec n))
+ (set-spec-unit sp n))
;; Illegal spec.
- (sp (: erlang error (tuple 'illegal_bitspec sp)))))
+ (_ (: erlang error (tuple 'illegal_bitspec spec)))))
;; (eval-exp-field value type size unit sign endian) -> binary().
@@ -240,10 +240,10 @@
((tuple 'binary 'all un _ _)
(case (: erlang bit_size val)
(size (when (=:= (rem size un) 0))
- (binary (val binary (size size) (unit 1))))
+ (binary (val bitstring (size size))))
(_ (: erlang error 'bad_arg))))
((tuple 'binary sz un _ _)
- (binary (val binary (size (* sz un)) (unit 1))))))
+ (binary (val bitstring (size (* sz un)))))))
(defun eval-int-field
([val sz 'signed 'little] (binary (val (size sz) signed little-endian)))
@@ -274,7 +274,7 @@
;; (eval-lambda (lambda-body env)) -> val
(defun eval-lambda
- (((args . body) env)
+ ([(args . body) env]
;; This is a really ugly hack!
(case (length args)
(0 (lambda () (eval-lambda () () body env)))
@@ -362,17 +362,19 @@
(defun eval-let (body env0)
(let* (((vbs . b) body) ;Must match this
+ ;; Make sure we use the right environment.
(env (foldl (match-lambda
- (((pat e) env)
- (let* ((val (eval-expr e env0))
- ((tuple 'yes bs) (match pat val env0)))
- (add_vbindings bs env)))
- (((pat g e) env)
- (let* ((val (eval-expr e env0))
- ((tuple 'yes '() bs)
- (match-when pat val (list g) env0)))
- (add_vbindings bs env)))
- ((_ _) (: erlang error (tuple 'bad_form 'let))))
+ ([(pat e) env]
+ (let ((val (eval-expr e env0)))
+ (case (match pat val env0)
+ ((tuple 'yes bs) (add_vbindings bs env))
+ ('no (: erlang error (tuple 'badmatch val))))))
+ ([(pat (= ('when _) g) e) env]
+ (let ((val (eval-expr e env0)))
+ (case (match-when pat val (list g) env0)
+ ((tuple 'yes '() bs) (add_vbindings bs env))
+ ('no (: erlang error (tuple 'badmatch val))))))
+ ([_ _] (: erlang error (tuple 'bad_form 'let))))
env0 vbs)))
(eval-body b env)))
@@ -448,7 +450,7 @@
(eval-match-clauses es cls env))
((tuple 'letrec body fbs env)
(let ((newenv (foldl (match-lambda
- (((tuple v ar lambda) e)
+ ([(tuple v ar lambda) e]
(add_fbinding v ar
(tuple 'letrec lambda fbs env) e)))
env fbs)))
@@ -682,7 +684,7 @@
(defun eval-glet (body env0)
(let* (((vbs . b) body) ;Must match this
(env (foldl (match-lambda
- (((v e) env) (when (is_atom v))
+ ([(v e) env] (when (is_atom v))
(add_vbinding v (eval-gexpr e env0) env)))
env0 vbs)))
(eval-gbody b env)))
@@ -709,28 +711,28 @@
(defun match (pat val env) (match pat val env ()))
(defun match
- ((('quote p) val env bs)
+ ([('quote p) val env bs]
(if (=:= p val) (tuple 'yes bs) 'no))
- ((('tuple . ps) val env bs)
+ ([('tuple . ps) val env bs]
(if (is_tuple val)
(match ps (tuple_to_list val) env bs)
'no))
- ((('binary . fs) val env bs)
- (if (is_binary val)
+ ([('binary . fs) val env bs]
+ (if (is_bitstring val)
(match-binary fs val env bs)
'no))
- ((('= p1 p2) val env bs) ;Aliases
+ ([('= p1 p2) val env bs] ;Aliases
(case (match p1 val env bs)
((tuple 'yes bs) (match p2 val env bs))
('no 'no)))
- (((p . ps) (v . vs) env bs)
+ ([(p . ps) (v . vs) env bs]
(case (match p v env bs)
((tuple 'yes bs) (match ps vs env bs))
('no 'no)))
- ((() () env bs) (tuple 'yes bs))
- ((symb val env bs) (when (is_atom symb))
+ ([() () env bs] (tuple 'yes bs))
+ ([symb val env bs] (when (is_atom symb))
(match-symb symb val env bs))
- ((pat val env bs)
+ ([pat val env bs]
(if (=:= pat val)
(tuple 'yes bs)
'no)))
@@ -791,27 +793,27 @@
(defun get-int-field
([bin sz 'signed 'little]
(let (((binary (val signed little-endian (size sz))
- (rest binary (unit 1))) bin))
+ (rest bitstring)) bin))
(tuple val rest)))
([bin sz 'unsigned 'little]
(let (((binary (val unsigned little-endian (size sz))
- (rest binary (unit 1))) bin))
+ (rest bitstring)) bin))
(tuple val rest)))
([bin sz 'signed 'native]
(let (((binary (val signed native-endian (size sz))
- (rest binary (unit 1))) bin))
+ (rest bitstring)) bin))
(tuple val rest)))
([bin sz 'unsigned 'native]
(let (((binary (val unsigned native-endian (size sz))
- (rest binary (unit 1))) bin))
+ (rest bitstring)) bin))
(tuple val rest)))
([bin sz 'signed 'big]
(let (((binary (val signed big-endian (size sz))
- (rest binary (unit 1))) bin))
+ (rest bitstring)) bin))
(tuple val rest)))
([bin sz 'unsigned 'big]
(let (((binary (val unsigned big-endian (size sz))
- (rest binary (unit 1))) bin))
+ (rest bitstring)) bin))
(tuple val rest))))
(defun get-utf-8-field (bin)
@@ -839,14 +841,11 @@
(defun get-float-field (bin sz en)
(case en
('little
- (let (((binary (val float little-endian (size sz)) (rest binary (unit 1)))
- bin))
+ (let (((binary (val float little-endian (size sz)) (rest bitstring)) bin))
(tuple val rest)))
('native
- (let (((binary (val float native-endian (size sz)) (rest binary (unit 1)))
- bin))
+ (let (((binary (val float native-endian (size sz)) (rest bitstring)) bin))
(tuple val rest)))
('big
- (let (((binary (val float big-endian (size sz)) (rest binary (unit 1)))
- bin))
+ (let (((binary (val float big-endian (size sz)) (rest bitstring)) bin))
(tuple val rest)))))
View
@@ -1,3 +1,26 @@
+2010-01-26 Robert Virding <rv@stanislaw.local>
+
+ * lfe_eval.lfe: Changed (binary (unit 1)) to (bitstring)
+ everywhere.
+
+ * lfe_eval.erl: Changed /binary-unit:1 to /bitstring everywhere.
+
+ * lfe_lint.erl (check_gexpr): Restructured function.
+
+ * lfe_macro.erl (bq_expand): Fixed handling of tuples to be
+ efficient or handle splicing.
+
+2010-01-25 Robert Virding <rv@stanislaw.local>
+
+ * lfe_io.erl (print1): Don't special case standard character
+ macros in normal print, leave for prettyprint.
+
+2010-01-20 Robert Virding <rv@stanislaw.local>
+
+ * lfe_eval.lfe (eval-let): Better error reporting.
+
+ * lfe_eval.erl (eval_let): Better error reporting.
+
2009-12-14 Robert Virding <rv@stanislaw.local>
* lfe_lint.erl (bad_mod_def_error): Broke this out and added what
View
@@ -173,7 +173,7 @@ parse_field(Val, Env) ->
eval_fields(Vsps, Env) ->
foldl(fun ({Val,Spec}, Acc) ->
Bin = eval_field(Val, Spec, Env),
- <<Acc/binary-unit:1,Bin/binary-unit:1>>
+ <<Acc/bitstring,Bin/bitstring>>
end, <<>>, Vsps).
eval_field(Val, Spec, Env) ->
@@ -256,11 +256,11 @@ eval_exp_field(Val, Spec) ->
{binary,all,Unit,_,_} ->
case erlang:bit_size(Val) of
Size when Size rem Unit =:= 0 ->
- <<Val:Size/binary-unit:1>>;
+ <<Val:Size/bitstring>>;
_ -> erlang:error(badarg)
end;
{binary,Size,Unit,_,_} ->
- <<Val:(Size*Unit)/binary-unit:1>>
+ <<Val:(Size*Unit)/bitstring>>
end.
eval_int_field(Val, Sz, signed, little) -> <<Val:Sz/little-signed>>;
@@ -372,15 +372,22 @@ eval_match_clauses(Vals, [[Pats|B0]|Cls], Env) ->
end;
eval_match_clauses(_, _, _) -> erlang:error(function_clause).
+%% eval_let([PatBindings|Body], Env) -> Value.
+
eval_let([Vbs|Body], Env0) ->
+ %% Make sure we use the right environment.
Env1 = foldl(fun ([Pat,E], Env) ->
Val = eval_expr(E, Env0),
- {yes,Bs} = match(Pat, Val, Env0),
- add_vbindings(Bs, Env);
- ([Pat,G,E], Env) ->
+ case match(Pat, Val, Env0) of
+ {yes,Bs} -> add_vbindings(Bs, Env);
+ no -> erlang:error({badmatch,Val})
+ end;
+ ([Pat,['when',_]=G,E], Env) ->
Val = eval_expr(E, Env0),
- {yes,[],Bs} = match_when(Pat, Val, [G], Env0),
- add_vbindings(Bs, Env);
+ case match_when(Pat, Val, [G], Env0) of
+ {yes,[],Bs} -> add_vbindings(Bs, Env);
+ no -> erlang:error({badmatch,Val})
+ end;
(_, _) -> erlang:error({bad_form,'let'})
end, Env0, Vbs),
eval_body(Body, Env1).
@@ -391,7 +398,7 @@ eval_let_function([Fbs|Body], Env0) ->
Env1 = foldl(fun ([V,[lambda,Args|_]=Lambda], E) when is_atom(V) ->
add_fbinding(V, length(Args), {expr,Lambda,Env0}, E);
([V,['match-lambda',[Pats|_]|_]=Match], E)
- when is_atom(V) ->
+ when is_atom(V) ->
add_fbinding(V, length(Pats), {expr,Match,Env0}, E);
(_, _) -> erlang:error({bad_form,'let-function'})
end, Env0, Fbs),
@@ -580,7 +587,7 @@ eval_try_catch([['after'|B]], E, Case, Env) ->
eval_try(E, Case, Catch, After, Env) ->
try
eval_expr(E, Env)
- of
+ of
Ret ->
case Case of
{yes,Cls} -> eval_case_clauses(Ret, Cls, Env);
@@ -630,7 +637,7 @@ match_when(Pat, V, B0, Env) ->
%% Guards are fault safe.
try
eval_gexpr(G, add_vbindings(Vbs, Env))
- of
+ of
true -> {yes,B1,Vbs};
_Other -> no %Fail guard
catch
@@ -814,22 +821,22 @@ get_pat_field(Bin, Spec) ->
end.
get_int_field(Bin, Sz, signed, little) ->
- <<Val:Sz/little-signed,Rest/binary-unit:1>> = Bin,
+ <<Val:Sz/little-signed,Rest/bitstring>> = Bin,
{Val,Rest};
get_int_field(Bin, Sz, unsigned, little) ->
- <<Val:Sz/little-unsigned,Rest/binary-unit:1>> = Bin,
+ <<Val:Sz/little-unsigned,Rest/bitstring>> = Bin,
{Val,Rest};
get_int_field(Bin, Sz, signed, native) ->
- <<Val:Sz/native-signed,Rest/binary-unit:1>> = Bin,
+ <<Val:Sz/native-signed,Rest/bitstring>> = Bin,
{Val,Rest};
get_int_field(Bin, Sz, unsigned, native) ->
- <<Val:Sz/native-unsigned,Rest/binary-unit:1>> = Bin,
+ <<Val:Sz/native-unsigned,Rest/bitstring>> = Bin,
{Val,Rest};
get_int_field(Bin, Sz, signed, big) ->
- <<Val:Sz/big-signed,Rest/binary-unit:1>> = Bin,
+ <<Val:Sz/big-signed,Rest/bitstring>> = Bin,
{Val,Rest};
get_int_field(Bin, Sz, unsigned, big) ->
- <<Val:Sz/big-unsigned,Rest/binary-unit:1>> = Bin,
+ <<Val:Sz/big-unsigned,Rest/bitstring>> = Bin,
{Val,Rest}.
get_utf8_field(Bin) ->
@@ -857,11 +864,11 @@ get_utf32_field(Bin, big) ->
{Val,Rest}.
get_float_field(Bin, Sz, little) ->
- <<Val:Sz/float-little,Rest/binary-unit:1>> = Bin,
+ <<Val:Sz/float-little,Rest/bitstring>> = Bin,
{Val,Rest};
get_float_field(Bin, Sz, native) ->
- <<Val:Sz/float-native,Rest/binary-unit:1>> = Bin,
+ <<Val:Sz/float-native,Rest/bitstring>> = Bin,
{Val,Rest};
get_float_field(Bin, Sz, big) ->
- <<Val:Sz/float,Rest/binary-unit:1>> = Bin,
+ <<Val:Sz/float,Rest/bitstring>> = Bin,
{Val,Rest}.
Oops, something went wrong.

0 comments on commit 1d7ce67

Please sign in to comment.