@@ -92,7 +92,7 @@ (('letrec-function . body) (eval-letrec-function body env)) ;; Handle the control special forms. - (('begin . body) (eval-body body env)) + (('progn . body) (eval-body body env)) (('if . body) (eval-if body env)) (('case . body) @@ -140,30 +140,29 @@ ;; (eval-binary fields env) -> binary. ;; Construct a binary from fields. This code is taken from eval_bits.erl. -(defun eval-binary (fs env) (eval-binary fs env #b())) - -(defun eval-binary (fs env acc) - (case fs - ((f . fs) - (let ((bin (eval-field f env))) - (eval-binary fs env - (binary (acc binary (unit 1)) (bin binary (unit 1)))))) - (() acc))) +(defun eval-binary (fs env) + (let ((psps (map (lambda (f) (parse-field f env)) fs))) + (eval-fields psps env))) (defrecord spec (type 'integer) (size 'default) (unit 'default) (sign 'default) (endian 'default)) -(defun eval-field (field env) - (case field - ((val . specs) - (let* ((v (eval-expr val env)) - ((tuple ty sz un si en) (parse-bitspecs specs (make-spec) env))) - (eval-exp-field v ty sz un si en))) - (val - (let* ((v (eval-expr val env)) - ((tuple ty sz un si en) (parse-bitspecs () (make-spec) env))) - (eval-exp-field v ty sz un si en))))) +(defun parse-field (f env) + (case f + ((pat . specs) (tuple pat (parse-bitspecs specs (make-spec) env))) + (pat (tuple pat (parse-bitspecs () (make-spec) env))))) + +(defun eval-fields (psps env) + (foldl (lambda (psp acc) + (let* (((tuple val spec) psp) + (bin (eval-field val spec env))) + (binary (acc binary (unit 1)) (bin binary (unit 1))))) + #b() psps)) + +(defun eval-field (val spec env) + (let ((v (eval-expr val env))) + (eval-exp-field v spec))) ;; (parse-bitspecs specs spec env) -> (tuple type size unit sign end). @@ -220,30 +219,31 @@ (('size n) (let ((size (eval-expr n env))) (set-spec-size spec size))) - (('unit n) (when (is_integer n)) + (('unit n) (when (and (is_integer n) (> n 0))) (set-spec-unit spec n)) ;; Illegal spec. (sp (: erlang error (tuple 'illegal_bitspec sp))))) ;; (eval-exp-field value type size unit sign endian) -> binary(). -(defun eval-exp-field - ;; Integer types. - ([val 'integer sz un si en] (eval-int-field val (* sz un) si en)) - ;; Unicode types, ignore unused fields. - ([val 'utf8 _ _ _ _] (binary (val utf-8))) - ([val 'utf16 _ _ _ en] (eval-utf-16-field val en)) - ([val 'utf32 _ _ _ en] (eval-utf-32-field val en)) - ;; Float types. - ([val 'float sz un _ en] (eval-float-field val (* sz un) en)) - ;; Binary types. - ([val 'binary 'all un _ _] - (case (: erlang bit_size val) - (size (when (=:= (rem size un) 0)) - (binary (val binary (size size) (unit 1)))) - (_ (: erlang error 'bad_arg)))) - ([val 'binary sz un _ _] - (binary (val binary (size (* sz un)) (unit 1))))) +(defun eval-exp-field (val spec) + (case spec + ;; Integer types. + ((tuple 'integer sz un si en) (eval-int-field val (* sz un) si en)) + ;; Unicode types, ignore unused fields. + ((tuple 'utf8 _ _ _ _) (binary (val utf-8))) + ((tuple 'utf16 _ _ _ en) (eval-utf-16-field val en)) + ((tuple 'utf32 _ _ _ en) (eval-utf-32-field val en)) + ;; Float types. + ((tuple 'float sz un _ en) (eval-float-field val (* sz un) en)) + ;; Binary types. + ((tuple 'binary 'all un _ _) + (case (: erlang bit_size val) + (size (when (=:= (rem size un) 0)) + (binary (val binary (size size) (unit 1)))) + (_ (: erlang error 'bad_arg)))) + ((tuple 'binary sz un _ _) + (binary (val binary (size (* sz un)) (unit 1)))))) (defun eval-int-field ([val sz 'signed 'little] (binary (val (size sz) signed little-endian))) @@ -639,7 +639,7 @@ (('let . body) (eval-let body env)) ;; Handle the Core control special forms. - (('begin . b) (eval-gbody b env)) + (('progn . b) (eval-gbody b env)) (('if test t f) (eval-gif test t f env)) (('if test t) @@ -671,7 +671,7 @@ (defun eval-gbody (((e) env) (eval-gexpr e env)) (((e . es) env) - (begin (eval-gexpr e env) (eval-gbody es env))) + (eval-gexpr e env) (eval-gbody es env)) ((() env) ())) (defun eval-glet (vbs body env0) @@ -749,11 +749,6 @@ ((tuple 'yes _ _) 'no) ('no 'no)))) -(defun parse-field (f env) - (case f - ((pat . specs) (tuple pat (parse-bitspecs specs (make-spec) env))) - (pat (tuple pat (parse-bitspecs () (make-spec) env))))) - (defun match-fields (psps bin env bs) (case psps (((tuple pat specs) . psps) @@ -762,28 +757,30 @@ ('no 'no))) (() (tuple 'yes bin bs)))) -(defun match-field (pat spec bin env bs) - (let* (((tuple ty sz un si en) spec) - ((tuple val bin) (get-pat-field bin ty sz un si en))) - (case (match pat val env bs) - ((tuple 'yes bs) (tuple 'yes bin bs)) +(defun match-field (pat spec bin0 env bs0) + (let (((tuple val bin1) (get-pat-field bin0 spec))) + (case (match pat val env bs0) + ((tuple 'yes bs1) (tuple 'yes bin1 bs1)) ('no 'no)))) -(defun get-pat-field (bin ty sz un si en) - (case ty - ('integer (get-int-field bin (* sz un) si en)) - ('utf8 (let (((binary (val utf-8) (rest bitstring)) bin)) - (tuple val rest))) - ('utf16 (get-utf-16-field bin en)) - ('utf32 (get-utf-32-field bin en)) - ('float (get-float-field bin (* sz un) en)) - ('binary - (if (=:= sz 'all) - (let ((0 (rem (: erlang bit_size bin) un))) - (tuple bin #b())) - (let* ((tot-size (* sz un)) - ((binary (val bitstring (size tot-size)) (rest bitstring)) bin)) - (tuple val rest)))))) +(defun get-pat-field (bin spec) + (case spec + ;; Integer types. + ((tuple 'integer sz un si en) (get-int-field bin (* sz un) si en)) + ;; Unicode types, ignore unused fields. + ((tuple 'utf8 _ _ _ _) (get-utf-8-field bin)) + ((tuple 'utf16 _ _ _ en) (get-utf-16-field bin en)) + ((tuple 'utf32 _ _ _ en) (get-utf-32-field bin en)) + ;; Float types. + ((tuple 'float sz un _ en) (get-float-field bin (* sz un) en)) + ;; Binary types. + ((tuple 'binary 'all un _ _) + (let ((0 (rem (: erlang bit_size bin) un))) + (tuple bin #b()))) + ((tuple 'binary sz un _ _) + (let* ((tot-size (* sz un)) + ((binary (val bitstring (size tot-size)) (rest bitstring)) bin)) + (tuple val rest))))) (defun get-int-field ([bin sz 'signed 'little] @@ -811,6 +808,10 @@ (rest binary (unit 1))) bin)) (tuple val rest)))) +(defun get-utf-8-field (bin) + (let (((binary (val utf-8) (rest bitstring)) bin)) + (tuple val rest))) + (defun get-utf-16-field (bin en) (case en ('little (let (((binary (val utf-16 little-endian) (rest bitstring)) bin)) examples/lfe_eval.lfe @@ -158,24 +158,27 @@ eval_body([], _) -> []. %Empty body %% eval_binary(Fields, Env) -> Binary. %% Construct a binary from Fields. This code is taken from eval_bits.erl. -eval_binary(Fs, Env) -> eval_binary(Fs, Env, <<>>). - -eval_binary([F|Fs], Env, Acc) -> - Bin = eval_field(F, Env), - eval_binary(Fs, Env, <<Acc/binary-unit:1,Bin/binary-unit:1>>); -eval_binary([], _, Acc) -> Acc. +eval_binary(Fs, Env) -> + Vsps = map(fun (F) -> parse_field(F, Env) end, Fs), + eval_fields(Vsps, Env). -record(spec, {type=integer,size=default,unit=default, sign=default,endian=default}). -eval_field([Val|Specs], Env) -> - V = eval_expr(Val, Env), - {Ty,Sz,Un,Si,En} = parse_bitspecs(Specs, #spec{}, Env), - eval_exp_field(V, Ty, Sz, Un, Si, En); -eval_field(Val, Env) -> +parse_field([Val|Specs], Env) -> + {Val,parse_bitspecs(Specs, #spec{}, Env)}; +parse_field(Val, Env) -> + {Val,parse_bitspecs([], #spec{}, Env)}. + +eval_fields(Vsps, Env) -> + foldl(fun ({Val,Spec}, Acc) -> + Bin = eval_field(Val, Spec, Env), + <<Acc/binary-unit:1,Bin/binary-unit:1>> + end, <<>>, Vsps). + +eval_field(Val, Spec, Env) -> V = eval_expr(Val, Env), - {Ty,Sz,Un,Si,En} = parse_bitspecs([], #spec{}, Env), - eval_exp_field(V, Ty, Sz, Un, Si, En). + eval_exp_field(V, Spec). %% parse_bitspecs(Specs, Spec, Env) -> {Type,Size,Unit,Sign,End}. @@ -237,39 +240,28 @@ parse_bitspec(Spec, _, _) -> erlang:error({illegal_bitspec,Spec}). val_or_def(default, Def) -> Def; val_or_def(V, _) -> V. -%% eval_exp_field(Val, #spec{type=integer,size=Sz,unit=Un,sign=Si,endien=En}) -> -%% case {Si,En} of -%% {signed,little} -> <<Val:(Sz*Un)/little-signed>>; -%% {unsigned,little} -> <<Val:(Sz*Un)/little>>; -%% {signed,native} -> <<Val:(Sz*Un)/native-signed>>; -%% {unsigned,native} -> <<Val:(Sz*Un)/native>>; -%% {signed,big} -> <<Val:(Sz*Un)/signed>>; -%% {unsigned,big} -> <<Val:(Sz*Un)>> -%% end; -%% eval_exp_field(Val, #spec{type=integer,size=Sz,unit=Un,sign=Si,endien=En}) -> - -%% eval_exp_field(Value, Type, Size, Unit, Sign, Endian) -> Binary. - -%% Integer types. -eval_exp_field(Val, integer, Sz, Un, Si, En) -> - eval_int_field(Val, Sz*Un, Si, En); -%% Unicode types, ignore unused fields. -eval_exp_field(Val, utf8, _, _, _, _) -> <<Val/utf8>>; -eval_exp_field(Val, utf16, _, _, _, En) -> eval_utf16_field(Val, En); -eval_exp_field(Val, utf32, _, _, _, En) -> eval_utf32_field(Val, En); -%% Float types. -eval_exp_field(Val, float, Sz, Un, _, En) -> - eval_float_field(Val, Sz*Un, En); -%% Binary types. -eval_exp_field(Val, binary, all, Unit, _, _) -> - case erlang:bit_size(Val) of - Size when Size rem Unit =:= 0 -> - <<Val:Size/binary-unit:1>>; - _ -> - erlang:error(badarg) - end; -eval_exp_field(Val, binary, Size, Unit, _, _) -> - <<Val:(Size*Unit)/binary-unit:1>>. +%% eval_exp_field(Value, {Type,Size,Unit,Sign,Endian}) -> Binary. + +eval_exp_field(Val, Spec) -> + case Spec of + %% Integer types. + {integer,Sz,Un,Si,En} -> eval_int_field(Val, Sz*Un, Si, En); + %% Unicode types, ignore unused fields. + {utf8,_,_,_,_} -> <<Val/utf8>>; + {utf16,_,_,_,En} -> eval_utf16_field(Val, En); + {utf32,_,_,_,En} -> eval_utf32_field(Val, En); + %% Float types. + {float,Sz,Un,_,En} -> eval_float_field(Val, Sz*Un, En); + %% Binary types. + {binary,all,Unit,_,_} -> + case erlang:bit_size(Val) of + Size when Size rem Unit =:= 0 -> + <<Val:Size/binary-unit:1>>; + _ -> erlang:error(badarg) + end; + {binary,Size,Unit,_,_} -> + <<Val:(Size*Unit)/binary-unit:1>> + end. eval_int_field(Val, Sz, signed, little) -> <<Val:Sz/little-signed>>; eval_int_field(Val, Sz, unsigned, little) -> <<Val:Sz/little>>; @@ -402,7 +394,7 @@ eval_let_function([Fbs|Body], Env0) -> when is_atom(V) -> add_fbinding(V, length(Pats), {expr,Match,Env0}, E); (_, _) -> erlang:error({bad_form,'let-function'}) - end, Env0, Fbs), + end, Env0, Fbs), %% io:fwrite("elf: ~p\n", [{Body,Env1}]), eval_body(Body, Env1). @@ -664,7 +656,7 @@ eval_gexpr([tuple|Es], Env) -> list_to_tuple(eval_glist(Es, Env)); eval_gexpr(['let',Vbs|Body], Env) -> eval_glet(Vbs, Body, Env); %% Handle the control special forms. -eval_gexpr(['begin'|Body], Env) -> +eval_gexpr(['progn'|Body], Env) -> eval_gbody(Body, Env); eval_gexpr(['if',Test,True], Env) -> eval_gif(Test, True, [quote,false], Env); @@ -777,18 +769,13 @@ match_symb(Symb, Val, _, Bs) -> match_binary(Fs, Bin, Env, Bs0) -> Psps = map(fun (F) -> parse_field(F, Env) end, Fs), - io:format("~p\n", [Psps]), + %% io:format("~p\n", [Psps]), case catch match_fields(Psps, Bin, Env, Bs0) of {yes,<<>>,Bs1} -> {yes,Bs1}; %Matched whole binary {yes,_,_} -> no; %Matched part of binary no -> no end. -parse_field([Pat|Specs], Env) -> - {Pat,parse_bitspecs(Specs, #spec{}, Env)}; -parse_field(Pat, Env) -> - {Pat,parse_bitspecs([], #spec{}, Env)}. - match_fields([{Pat,Specs}|Psps], Bin0, Env, Bs0) -> case match_field(Pat, Specs, Bin0, Env, Bs0) of {yes,Bin1,Bs1} -> match_fields(Psps, Bin1, Env, Bs1); @@ -796,33 +783,35 @@ match_fields([{Pat,Specs}|Psps], Bin0, Env, Bs0) -> end; match_fields([], Bin, _, Bs) -> {yes,Bin,Bs}. -match_field(Pat, {Ty,Sz,Un,Si,En}, Bin0, Env, Bs0) -> - {Val,Bin1} = get_pat_field(Bin0, Ty, Sz, Un, Si, En), +match_field(Pat, Spec, Bin0, Env, Bs0) -> + {Val,Bin1} = get_pat_field(Bin0, Spec), case match(Pat, Val, Env, Bs0) of {yes,Bs1} -> {yes,Bin1,Bs1}; no -> no end. -%% Integer types. -get_pat_field(Bin, integer, Sz, Un, Si, En) -> - get_int_field(Bin, Sz*Un, Si, En); -%% Unicode types, ignore unused fields. -get_pat_field(Bin, utf8, _, _, _, _) -> - <<Val/utf8,Rest/bitstring>> = Bin, - {Val,Rest}; -get_pat_field(Bin, utf16, _, _, _, En) -> - get_utf16_field(Bin, En); -get_pat_field(Bin, utf32, _, _, _, En) -> - get_utf32_field(Bin, En); -get_pat_field(Bin, float, Sz, Un, _, En) -> - get_float_field(Bin, Sz*Un, En); -get_pat_field(Bin, binary, all, Un, _, _) -> - 0 = (erlang:bit_size(Bin) rem Un), - {Bin,<<>>}; -get_pat_field(Bin, binary, Sz, Un, _, _) -> - TotSize = Sz * Un, - <<Val:TotSize/bitstring,Rest/bitstring>> = Bin, - {Val,Rest}. +%% get_pat_field(Binary, {Type,Size,Unit,Sign,Endian}) -> {Value,RestBinary}. + +get_pat_field(Bin, Spec) -> + case Spec of + %% Integer types. + {integer,Sz,Un,Si,En} -> + get_int_field(Bin, Sz*Un, Si, En); + %% Unicode types, ignore unused fields. + {utf8,_,_,_,_} -> get_utf8_field(Bin); + {utf16,_,_,_,En} -> get_utf16_field(Bin, En); + {utf32,_,_,_,En} -> get_utf32_field(Bin, En); + %% Float types. + {float,Sz,Un,_,En} -> get_float_field(Bin, Sz*Un, En); + %% Binary types. + {binary,all,Un,_,_} -> + 0 = (erlang:bit_size(Bin) rem Un), + {Bin,<<>>}; + {binary,Sz,Un,_,_} -> + TotSize = Sz * Un, + <<Val:TotSize/bitstring,Rest/bitstring>> = Bin, + {Val,Rest} + end. get_int_field(Bin, Sz, signed, little) -> <<Val:Sz/little-signed,Rest/binary-unit:1>> = Bin, @@ -843,6 +832,10 @@ get_int_field(Bin, Sz, unsigned, big) -> <<Val:Sz/big-unsigned,Rest/binary-unit:1>> = Bin, {Val,Rest}. +get_utf8_field(Bin) -> + <<Val/utf8,Rest/bitstring>> = Bin, + {Val,Rest}. + get_utf16_field(Bin, little) -> <<Val/utf16-little,Rest/bitstring>> = Bin, {Val,Rest}; src/lfe_eval.erl 8516907b54ccba0f6ee48f2872adcdd4c6388e57 Robert Virding rvirding@gmail.com http://github.com/rvirding/lfe/commit/8388e38d5199457623ecc03ec9e0f81c2de5e45f 8388e38d5199457623ecc03ec9e0f81c2de5e45f 2009-10-13T16:10:21-07:00 2009-10-13T16:10:21-07:00 Restructured binary code. 9f07d3b9b823ec9c89269bc2aeb05e40934e7f8b Robert Virding rvirding@gmail.com