test/test_bin_e.erl @@ -36,31 +36,48 @@ file(FileName, Options) -> CompRet Return the binary of the module and do not save it in a file. - dcore - Print out the Core Erlang forms generated by the LFE - compiler. Mainly useful for debugging and interest. + to_exp + Print a listing of the macro expanded LFE code in the + file <File>.expand. No object file is produced. Mainly + useful for debugging and interest. + + to_core0 + to_core + Print a listing of the Core Erlang code before/after + being optimised in the file <File>.core. No object + file is produced. Mainly useful for debugging and + interest. + + to_kernel + Print a listing of the Kernel Erlang code in the file + <File>.kernel. No object file is produced. Mainly + useful for debugging and interest. + + to_asm + Print a listing of the Beam code in the file + <File>.S. No object file is produced. Mainly + useful for debugging and interest. {outdir,Dir} Save the generated files in directory Dir instead of the current directory. report - Do not return the errors and warnings but print them - out insted. This is the default. + Print the errors and warnings as they occur. return - Return the errors and warnings instead of printing - them. - - to_core - Print out the Core Erlang forms after the LFE forms - have been optimised by the Erlang compiler. Mainly - useful for debugging and interest. + Return an extra return field containing Warnings on + success or the errors and warnings in + {error,Errors,Warnings} when there are errors. debug_print Causes the compiler to print a lot of debug information. + If the binary option is given then options that produce a + listing file will cause the internal format for that compiler + pass to be returned. + Both Warnings and Errors have the following format: [{FileName,[ErrorInfo]}] doc/lfe_comp.txt @@ -86,7 +86,20 @@ Example generating a text file. We assume that we have collected the data and have it in the form: - Params = [{Parameter,[{Field,Value}]}] + Params = [{Parameter,[{Feature,Value}]}] + + The equivalent LFE code which we will be generating is: + + (defmodule Name + (export (<param1> 1) (<param2> 1) ... )) + + (defun <param1> (f) + (case f + ('<feature1> '<value1>) + ... + (f (: erlang error (tuple 'unknown_feature '<param1> f))))) + + ... The following code builds and compiles a module from the parameter data: @@ -103,8 +116,8 @@ Example CatchAll = [f,[':',erlang,error, [tuple,unknown_feature,[quote,Param],f]]], %% Build case clauses - Cls = foldr(fun ({Feat,Value}, Cls) -> - [[Feat,[quote,Value]]|Cls] + Cls = foldr(fun ({Feature,Value}, Cls) -> + [[[quote,Feature],[quote,Value]]|Cls] end, [CatchAll], Params), %% Build function. Func = [defun,Param,[f],['case',f,Cls]], doc/lfe_gen.txt @@ -39,6 +39,11 @@ DESCRIPTION Remove all function and macro definitions except the default ones. + (set Pattern Expr) + Evaluate Expr ad match the result with Pattern binding + variables in it. These variables can then be used in + the shell and also rebound in another set. + (: c Command Arg ...) All the commands in the standard Erlang shell can be reached in this way. @@ -71,16 +76,19 @@ DESCRIPTION Starting the LFE shell + The best way is probably to start Erlang directly running the + LFE shell with: + + erl -noshell -noinput -s lfe_boot start + + This can easily be put in a shell script. + From a normal Erlang shell the best way to start the shell is by calling: 17> lfe_shell:server(). - A modified user_drv.erl from the standard Erlang distribution - has been provided which allows to start a specific local - shell, not just the default Erlang shell. If this version of - user_drv.beam is placed in the standard load path then giving - the user switch commands: + Giving the user switch commands: --> s lfe_shell --> c doc/lfe_shell.txt @@ -19,9 +19,9 @@ Supported Core forms (tuple e ... ) (binary seg ... ) where seg is byte or - (val integer|float|binary|bitstring + (val integer|float|binary|bitstring|bytes|bits (size n) (unit n) - big-endian|little-endian|native-endian + big-endian|little-endian|native-endian|little|native|big signed|unsigned) (lambda (arg ...) ...) (match-lambda - Matches clauses @@ -73,6 +73,7 @@ Supported macro forms (call 'mod 'func arg ... ) (?) - Receive next message (++ ... ) +(list* ...) (let* (...) ... ) - Sequential let's (flet ((name (arg ...) ...) ...) @@ -219,7 +220,7 @@ Module definition (import (from mod (f1 2) (f2 1) ... ) (rename mod ((f1 2) sune) ((f2 1) kurt) ... )) (import (prefix mod mod-prefix)) - NYI - (attr-1 value-1) + (attr-1 value-1 value-2) ... ) Can have multiple export and import declarations within module @@ -342,6 +343,7 @@ field-name value to get non-default values. E.g. for => (make-person {{field value}} ... ) (match-person {{field value}} ... ) + (is-person r) (set-person r {{field value}} ... ) (person-name r) (set-person-name r name) @@ -359,7 +361,7 @@ field-name value to get non-default values. E.g. for (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 + the name field of the record. Can use any variable name here. (set-person john age 35 address "front street") doc/user_guide.txt ebin/lfe_codegen.beam ebin/lfe_comp.beam ebin/lfe_eval.beam ebin/lfe_io.beam ebin/lfe_io_format.beam ebin/lfe_io_pretty.beam ebin/lfe_lib.beam ebin/lfe_lint.beam ebin/lfe_macro.beam ebin/lfe_parse.beam ebin/lfe_pmod.beam ebin/lfe_shell.beam @@ -129,17 +129,18 @@ (concat "(" (regexp-opt '(;; Core forms. + "cons" "car" "cdr" "list" "tuple" "binary" "after" "call" "case" "catch" "if" "lambda" "let" "let-function" "letrec-function" "let-macro" "match-lambda" "receive" "try" "when" "progn" "eval-when-compile" ;; Default macros - "andalso" "cond" "do" "fun" "let*" "flet*" "macro" + "andalso" "cond" "do" "fun" "list*" "let*" "flet*" "macro" "orelse" "syntax-rules" "lc" "bc" "flet" "fletrec" "macrolet" "syntaxlet" "begin" "let-syntax" ":" "?" "++") t) - "\\>") 1) + "\\>") '(1 font-lock-keyword-face)) ))) "Gaudy expressions to highlight in LFE modes.") emacs/lfe-mode.el emacs/lfe-mode.elc @@ -30,14 +30,30 @@ ;;; We cannot use macros here as macros need the evaluator! (defmodule lfe_eval - (export (eval 1) (eval 2) (eval_list 2) (apply 2) (apply 3) - (make_letrec_env 2) (add_expr_func 4) (match 3)) + (export (expr 1) (expr 2) (gexpr 1) (gexpr 2) (apply 2) (apply 3) + (make_letrec_env 2) (add_expr_func 4) (match 3) + (eval 1) (eval 2) (eval_list 2)) (import (from lfe_lib (new_env 0) (add_vbinding 3) (add_vbindings 2) (get_vbinding 2) (add_fbinding 4) (add_fbindings 2) (get_fbinding 3) (add_ibinding 5) (get_gbinding 3)) (from lists (reverse 1) (map 2) (foldl 3)) - (from orddict (find 2) (store 3)))) + (from orddict (find 2) (store 3))) + (deprecated #(eval 1) #(eval 2))) + +(defun eval (e) (eval e (new_env))) + +(defun eval (e env) (eval-expr e env)) + +(defun eval_list (es env) (eval-list es env)) + +(defun expr (e) (expr e (new_env))) + +(defun expr (e env) (eval-expr e env)) + +(defun gexpr (e) (gexpr e (new_env))) + +(defun gexpr (e env) (eval-gexpr e env)) (defun apply (f args) (let ((env (new_env))) @@ -46,12 +62,6 @@ (defun apply (f args env) (lfe-apply (tuple 'expr f env) args env)) -(defun eval (e) (eval e (new_env))) - -(defun eval (e env) (eval-expr e env)) - -(defun eval_list (es env) (eval-list es env)) - ;; (eval-expr Sexpr Environment) -> Value. ;; Evaluate a sexpr in the current environment. Try to catch core ;; forms by just name and check arguments arguments later. Otherwise @@ -82,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) @@ -130,111 +140,138 @@ ;; (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) (eval-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) (eval-bitspecs () (make-spec) env))) - (eval-exp-field v ty sz un si en))))) - -;; (eval-bitspecs specs spec env) -> (tuple type size unit sign end). - -(defun eval-bitspecs (specs spec env) - (case specs - ((('size n) . ss) +(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). + +(defun parse-bitspecs (ss spec0 env) + (let* ((spec1 (foldl (lambda (s spec) (parse-bitspec s spec env)) spec0 ss)) + ((match-spec type ty size sz unit un sign si endian en) spec1)) + ;; Adjust values depending on type and given value. + (flet ((val-or-def (v def) (if (=:= v 'default) def v))) + (case ty + ('integer + (tuple 'integer + (val-or-def sz 8) (val-or-def un 1) + (val-or-def si 'unsigned) (val-or-def en 'big))) + ;; Ignore unused fields in utf types! + ('utf8 (tuple 'utf8 'undefined 'undefined 'undefined 'undefined)) + ('utf16 + (tuple 'utf16 'undefined 'undefined 'undefined (val-or-def en 'big))) + ('utf32 + (tuple 'utf32 'undefined 'undefined 'undefined (val-or-def en 'big))) + ('float + (tuple 'float + (val-or-def sz 64) (val-or-def un 1) + (val-or-def si 'unsigned) (val-or-def en 'big))) + ('binary + (tuple 'integer + (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 + ;; 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)) + ;; Unicode types. + ('utf-8 (set-spec-type spec 'utf8)) + ('utf-16 (set-spec-type spec 'utf16)) + ('utf-32 (set-spec-type spec 'utf32)) + ;; Endianess. + ('big-endian (set-spec-type spec 'big)) + ('little-endian (set-spec-type spec 'little)) + ('big-native (set-spec-type spec 'native)) + ;; Sign. + ('signed (set-spec-sign spec 'signed)) + ('unsigned (set-spec-sign spec 'unsigned)) + ;; Size + (('size n) (let ((size (eval-expr n env))) - (eval-bitspecs ss (set-spec-size spec size) env))) - ((('unit n) . ss) (when (is_integer n)) - (eval-bitspecs ss (set-spec-unit spec n) env)) - (('integer . ss) - (eval-bitspecs ss (set-spec-type spec 'integer) env)) - (('float . ss) - (eval-bitspecs ss (set-spec-type spec 'float) env)) - (('binary . ss) - (eval-bitspecs ss (set-spec-type spec 'binary) env)) - (('bitstring . ss) - (eval-bitspecs ss (set-spec-type spec 'bitstring) env)) - (('signed . ss) - (eval-bitspecs ss (set-spec-sign spec 'signed) env)) - (('unsigned . ss) - (eval-bitspecs ss (set-spec-sign spec 'unsigned) env)) - (('big-endian . ss) - (eval-bitspecs ss (set-spec-endian spec 'big) env)) - (('little-endian . ss) - (eval-bitspecs ss (set-spec-endian spec 'little) env)) - (('native-endian . ss) - (eval-bitspecs ss (set-spec-endian spec 'native) env)) - (() - (let (((match-spec type ty size sz unit un sign si endian en) spec)) - ;; Adjust values depending on type and given value. - (flet ((val-or-def (v def) (if (=:= v 'default) def v))) - (case ty - ('integer - (tuple 'integer - (val-or-def sz 8) (val-or-def un 1) - (val-or-def si 'unsigned) (val-or-def en 'big))) - ('float - (tuple 'float - (val-or-def sz 64) (val-or-def un 1) - (val-or-def si 'unsigned) (val-or-def en 'big))) - ('binary - (tuple 'integer - (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))))))))) + (set-spec-size spec size))) + (('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 'signed 'little] - (binary (val (size (* sz un)) signed little-endian))) - ([val 'integer sz un 'unsigned 'little] - (binary (val (size (* sz un)) unsigned little-endian))) - ([val 'integer sz un 'signed 'native] - (binary (val (size (* sz un)) signed native-endian))) - ([val 'integer sz un 'unsigned 'native] - (binary (val (size (* sz un)) unsigned native-endian))) - ([val 'integer sz un 'signed 'big] - (binary (val (size (* sz un)) signed big-endian))) - ([val 'integer sz un 'unsigned 'big] - (binary (val (size (* sz un)) unsigned big-endian))) - ;; Float types. - ([val 'float sz un _ 'little] - (binary (val float (size (* sz un)) little-endian))) - ([val 'float sz un _ 'native] - (binary (val float (size (* sz un)) native-endian))) - ([val 'float sz un _ 'big] - (binary (val float (size (* sz un)) big-endian))) - ;; 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))) + ([val sz 'unsigned 'little] (binary (val (size sz) unsigned little-endian))) + ([val sz 'signed 'native] (binary (val (size sz) signed native-endian))) + ([val sz 'unsigned 'native] (binary (val (size sz) unsigned native-endian))) + ([val sz 'signed 'big] (binary (val (size sz) signed big-endian))) + ([val sz 'unsigned 'big] (binary (val (size sz) unsigned big-endian)))) + +(defun eval-utf-16-field (val en) + (case en + ('little (binary (val utf-16 little-endian))) + ('native (binary (val utf-16 native-endian))) + ('big (binary (val utf-16 big-endian))))) + +(defun eval-utf-32-field (val en) + (case en + ('little (binary (val utf-32 little-endian))) + ('native (binary (val utf-32 native-endian))) + ('big (binary (val utf-32 big-endian))))) + +(defun eval-float-field (val sz en) + (case en + ('little (binary (val float (size sz) little-endian))) + ('native (binary (val float (size sz) native-endian))) + ('big (binary (val float (size sz) big-endian))))) + +;; (eval-lambda (lambda-body env)) -> val (defun eval-lambda (((args . body) env) @@ -269,13 +306,13 @@ ))) (defun eval-lambda (vals args body env) - (let ((env (bind-args args vals env))) - (eval-body body env))) - -(defun bind-args - (((a . as) (e . es) env) (when (is_atom a)) - (bind-args as es (add_vbinding a e env))) - ((() () env) env)) + (fletrec ((bind-args + ([('_ . as) (_ . es) env] ;Ignore don't care variables + (bind-args as es env)) + ([(a . as) (e . es) env] (when (is_atom a)) + (bind-args as es (add_vbinding a e env))) + ([() () env] env))) + (eval-body body (bind-args args vals env)))) (defun eval-match-lambda (cls env) ;; This is a really ugly hack! @@ -313,12 +350,13 @@ (defun eval-match-clauses (as cls env) (case cls - (((pats . body) . cls) + ([(pats . body) . cls] (if (== (length as) (length pats)) (case (match-when pats as body env) ((tuple 'yes body1 vbs) (eval-body body1 (add_vbindings vbs env))) ('no (eval-match-clauses as cls env))) - (eval-match-clauses as cls env))))) + (: erlang error 'badarity))) + ([_ _] (: erlang error 'function_clause)))) ;; (eval-let (PatBindings . Body) Env) -> Value. @@ -352,7 +390,7 @@ ((_ _) (: erlang error (tuple 'bad_form 'let-function)))) env0 fbs))) (eval-body body env))) - + ;; (eval-letrec-function (FuncBindings . Body) Env) -> Value. ;; This is a tricky one. But we dynamically update the environment ;; each time we are called. @@ -490,7 +528,7 @@ (merge-queue ms) (eval-body tb env))))) (statistics 'runtime) - (rec_clauses t []))) + (rec_clauses t []))) ;; Merge the already received messages back into the process message ;; queue in the right order. Do this by first receiving the rest of @@ -601,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) @@ -633,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) @@ -699,88 +737,110 @@ ('error (tuple 'yes (store symb val bs)))))) ;; (match-binary fields binary env bindings) -> (tuple 'yes bindings) | 'no. -;; Match Fields against Binary. This code is taken from eval_bits.erl. -;; Use catch to trap bad matches when getting value, errors become -;; no match. +;; Match Fields against Binary. This code is taken from +;; eval_bits.erl. Use catch to trap bad matches when getting value, +;; errors become no match. Split into two passes so as to throw error +;; on bitspec error and return no on all no matches. (defun match-binary (fs bin env bs) - (case fs - ((f . fs) - (case (catch (match-field f bin env bs)) - ((tuple 'yes bs bin) (match-binary fs bin env bs)) - ('no 'no) - (_ 'no))) ;Catch errors - (() - (if (=:= bin #b()) - (tuple 'yes bs) - 'no)))) - -(defun match-field (f bin env bs) - (case f - ((pat . specs) - (let ((spec-t (eval-bitspecs specs (make-spec) env))) - (match-field pat spec-t bin env bs))) - (pat - (let ((spec-t (eval-bitspecs '() (make-spec) env))) - (match-field pat spec-t bin env bs))))) - -(defun match-field (pat spec bin env bs) - (let* (((match-spec type ty size sz unit un sign si endian en) spec) - ((tuple val bin) (get-value bin ty sz un si en))) - (case (match pat val env bs) - ((tuple 'yes bs1) (tuple 'yes bs bin)) + (let ((psps (map (lambda (f) (parse-field f env)) fs))) + (case (catch (match-fields psps bin env bs)) + ((tuple 'yes #b() bs) (tuple 'yes bs)) + ((tuple 'yes _ _) 'no) ('no 'no)))) -(defun get-value (bin ty sz un si en) - (case ty - ('integer (get-integer bin (* sz un) si en)) - ('float (get-float 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-integer (bin sz si en) - (case (tuple si en) - ((tuple 'signed 'little-endian) - (let (((binary (val signed little-endian (size sz)) - (rest binary (unit 1))) bin)) - (tuple val rest))) - ((tuple 'unsigned 'little-endian) - (let (((binary (val unsigned little-endian (size sz)) - (rest binary (unit 1))) bin)) - (tuple val rest))) - ((tuple 'signed 'native-endian) - (let (((binary (val signed native-endian (size sz)) - (rest binary (unit 1))) bin)) - (tuple val rest))) - ((tuple 'unsigned 'native-endian) - (let (((binary (val unsigned native-endian (size sz)) - (rest binary (unit 1))) bin)) - (tuple val rest))) - ((tuple 'signed 'bin-endian) - (let (((binary (val signed big-endian (size sz)) - (rest binary (unit 1))) bin)) - (tuple val rest))) - ((tuple 'unsigned 'big-endian) - (let (((binary (val unsigned big-endian (size sz)) - (rest binary (unit 1))) bin)) +(defun match-fields (psps bin env bs) + (case psps + (((tuple pat specs) . psps) + (case (match-field pat specs bin env bs) + ((tuple 'yes bin bs) (match-fields psps bin env bs)) + ('no 'no))) + (() (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 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-float (bin sz en) +(defun get-int-field + ([bin sz 'signed 'little] + (let (((binary (val signed little-endian (size sz)) + (rest binary (unit 1))) bin)) + (tuple val rest))) + ([bin sz 'unsigned 'little] + (let (((binary (val unsigned little-endian (size sz)) + (rest binary (unit 1))) bin)) + (tuple val rest))) + ([bin sz 'signed 'native] + (let (((binary (val signed native-endian (size sz)) + (rest binary (unit 1))) bin)) + (tuple val rest))) + ([bin sz 'unsigned 'native] + (let (((binary (val unsigned native-endian (size sz)) + (rest binary (unit 1))) bin)) + (tuple val rest))) + ([bin sz 'signed 'big] + (let (((binary (val signed big-endian (size sz)) + (rest binary (unit 1))) bin)) + (tuple val rest))) + ([bin sz 'unsigned 'big] + (let (((binary (val unsigned big-endian (size sz)) + (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)) + (tuple val rest))) + ('native (let (((binary (val utf-16 native-endian) (rest bitstring)) bin)) + (tuple val rest))) + ('big (let (((binary (val utf-16 big-endian) (rest bitstring)) bin)) + (tuple val rest))))) + +(defun get-utf-32-field (bin en) + (case en + ('little (let (((binary (val utf-32 little-endian) (rest bitstring)) bin)) + (tuple val rest))) + ('native (let (((binary (val utf-32 native-endian) (rest bitstring)) bin)) + (tuple val rest))) + ('big (let (((binary (val utf-32 big-endian) (rest bitstring)) bin)) + (tuple val rest))))) + +(defun get-float-field (bin sz en) (case en - ('little-endian + ('little (let (((binary (val float little-endian (size sz)) (rest binary (unit 1))) bin)) (tuple val rest))) - ('native-endian + ('native (let (((binary (val float native-endian (size sz)) (rest binary (unit 1))) bin)) (tuple val rest))) - ('big-endian + ('big (let (((binary (val float big-endian (size sz)) (rest binary (unit 1))) bin)) (tuple val rest))))) examples/lfe_eval.lfe @@ -1,3 +1,74 @@ +2009-10-14 Robert Virding <rv@stanislaw.local> + + * lfe_macro.erl (exp_predef): Added macro list* and restructured + code a little. + +2009-10-13 Robert Virding <rv@stanislaw.local> + + * lfe_eval.lfe (eval-binary, match-binary): Restructured code. + + * lfe_eval.erl (eval_binary, match_binary): Restructured code. + +2009-10-06 Robert Virding <rv@stanislaw.local> + + * lfe_codegen.erl (comp_args, comp_call): Sequentialised + evaluation of arguments enforcing left-to-right semantics. + +2009-10-02 Robert Virding <rv@stanislaw.local> + + * lfe_codegen.erl: Cleaned up handling of literals. + +2009-09-26 Robert Virding <rv@stanislaw.local> + + * lfe_eval.lfe (eval-binary, match-binary): Cleaned up handling of + binaries. + + * lfe_eval.erl (eval_binary, match_binary): Cleaned up handling of + binaries. + + * lfe-eval.lfe (get-integer, get-float): Got endian names right + internally. + + * lfe_shell.erl (set): New shell command to set variables in + shell. + +2009-09-25 Robert Virding <rv@stanislaw.local> + + * lfe-eval.lfe (eval-bitspec, eval-exp-field, get-value): Added + unicode types. + +2009-09-18 Robert Virding <rv@stanislaw.local> + + * lfe_lint.erl (check_mdef): Fixed handling of attributes. + + * lfe_codegen.erl (collect_mdef): Fixed handling of attributes. + +2009-09-16 Robert Virding <rv@stanislaw.local> + + * lfe_eval.erl (eval-lambda): Lambda args can now hold don't care + variable. + + * lfe_lint.erl (check_lambda_args): Lambda args can now hold don't + care variable. + + * lfe_codegen.erl (comp_lambda): Lambda args can now hold don't + care variable. + (comp_let): Simple lets without matching can now hold don't care + variables. + +2009-08-31 Robert Virding <rv@stanislaw.local> + + * lfe_io_pretty.erl (print1_list_max, print1_tail_max): Get it + right when depth = 0. + + * lfe_comp.erl (passes, do_passes): Add an explicit pass driven + style to compiler. + +2009-08-30 Robert Virding <rv@stanislaw.local> + + * lfe_io_pretty.erl (print1_list_max, print1_tail_max): Bit more + efficient pretty printing on the rest of the line. + 2009-08-13 Robert Virding <rv@stanislaw.local> * lfe_comp.erl (list_warnings, list_errors): Use lfe_io format. src/ChangeLog @@ -76,11 +76,11 @@ forms(Forms, St0, Core0) -> Fbs1 = [{module_info, [lambda,[], [call,[quote,erlang],[quote,get_module_info], - [quote,St1#cg.mod]]],0}, + [quote,St1#cg.mod]]],1}, {module_info, [lambda,[x], [call,[quote,erlang],[quote,get_module_info], - [quote,St1#cg.mod],x]],0}| + [quote,St1#cg.mod],x]],1}| Fbs0], %% Make initial environment and set state Env0 = foldl(fun ({M,Fs}, Env) -> @@ -95,19 +95,19 @@ forms(Forms, St0, Core0) -> defs=Fbs1,env=Env1}, Exps = make_exports(St2#cg.exps, Fbs1), Atts = map(fun ({N,V}) -> - {make_literal(N),make_literal(V)} + {comp_lit(N),comp_lit(V)} end, St2#cg.atts), %% Compile the functions. {Cdefs,St3} = mapfoldl(fun (D, St) -> comp_define(D, Env1, St) end, St2, St2#cg.defs), %% Build the final core module structure. - Core1 = Core0#c_module{name=c_lit(St3#cg.mod, 1), + Core1 = Core0#c_module{name=c_atom(St3#cg.mod), exports=Exps, attrs=Atts, defs=Cdefs}, %% Maybe print lots of debug info. debug_print("#cg: ~p\n", [St3], St3), - when_opt(fun () -> io:fwrite("core_lint: ~p\n", + when_opt(fun () -> io:fwrite("core_lint: ~p\n", [(catch core_lint:module(Core1))]) end, debug_print, St3), when_opt(fun () -> @@ -131,9 +131,9 @@ add_exports(_, all) -> all; add_exports(Old, More) -> union(Old, More). make_exports(all, Fbs) -> - map(fun ({F,Def,_}) -> c_fname(F, func_arity(Def), 1) end, Fbs); + map(fun ({F,Def,_}) -> c_fname(F, func_arity(Def)) end, Fbs); make_exports(Exps, _) -> - map(fun ({F,A}) -> c_fname(F, A, 1) end, Exps). + map(fun ({F,A}) -> c_fname(F, A) end, Exps). %% collect_form(Form, Line, State} -> {[Ret],State}. %% Collect valid forms and module data. Returns forms and put module @@ -163,8 +163,8 @@ collect_mdef([[export|Es]|Mdef], St) -> end; collect_mdef([[import|Is]|Mdef], St) -> collect_mdef(Mdef, collect_imps(Is, St)); -collect_mdef([[N,V]|Mdef], St) -> - As = St#cg.atts ++ [{N,V}], %Probably not many +collect_mdef([[N|Vs]|Mdef], St) -> + As = St#cg.atts ++ [{N,Vs}], %Probably not many collect_mdef(Mdef, St#cg{atts=As}); collect_mdef([], St) -> St. @@ -191,7 +191,7 @@ collect_imp(Fun, Mod, St, Fs) -> %% Compile a top-level define. Sets current function name. comp_define({Name,Def,L}, Env, St) -> - Cf = c_fname(Name, func_arity(Def), L), %Could be useful + Cf = c_fname(Name, func_arity(Def)), %Could be useful comp_func(Name, Def, Env, L, St#cg{func=Cf,vc=0,fc=0}). %% comp_body(BodyList, Env, Line, State) -> {CoreBody,State}. @@ -202,48 +202,51 @@ comp_body([E|Es], Env, L, St0) -> {Ce,St1} = comp_expr(E, Env, L, St0), {Ces,St2} = comp_body(Es, Env, L, St1), {#c_seq{anno=[L],arg=Ce,body=Ces},St2}; -comp_body([], _, L, St) -> {c_nil(L),St}. %Empty body - +comp_body([], _, _, St) -> {c_nil(),St}. %Empty body + %% comp_expr(Expr, Env, Line, State) -> {CoreExpr,State}. %% Compile an expression. comp_expr([_|_]=Call, Env, L, St) -> comp_call(Call, Env, L, St); -comp_expr([], _, L, St) -> {c_nil(L),St}; %Self evaluating +comp_expr([], _, _, St) -> {c_nil(),St}; %Self evaluating comp_expr(Tup, _, _, St) when is_tuple(Tup) -> %% This just builds a tuple constant. - {make_literal(Tup),St}; -comp_expr(Symb, _, L, St) when is_atom(Symb) -> - {c_var(Symb, L),St}; + {comp_lit(Tup),St}; +comp_expr(Symb, _, _, St) when is_atom(Symb) -> + {c_var(Symb),St}; comp_expr(Numb, _, _, St) when is_number(Numb) -> - {make_literal(Numb),St}; + {comp_lit(Numb),St}; comp_expr(Bin, _, _, St) when is_binary(Bin) -> - {make_literal(Bin),St}. + {comp_lit(Bin),St}. %% comp_call(Call, Env, Line, State) -> {CoreCall,State}. %% Handle the Core data special forms. -comp_call([quote,E], _, _, St) -> {make_literal(E),St}; -comp_call([cons,H,T], Env, L, St0) -> - {Ch,St1} = comp_expr(H, Env, L, St0), - {Ct,St2} = comp_expr(T, Env, L, St1), - {c_cons(Ch, Ct, L),St2}; +comp_call([quote,E], _, _, St) -> {comp_lit(E),St}; +comp_call([cons,H,T], Env, L, St) -> + Call = fun ([Ch,Ct], _, _, St) -> {c_cons(Ch, Ct),St} end, + comp_args([H,T], Call, Env, L, St); +%% {Ch,St1} = comp_expr(H, Env, L, St0), +%% {Ct,St2} = comp_expr(T, Env, L, St1), +%% {c_cons(Ch, Ct),St2}; comp_call([car,E], Env, L, St) -> %Provide lisp names comp_call([hd,E], Env, L, St); comp_call([cdr,E], Env, L, St) -> comp_call([tl,E], Env, L, St); comp_call([list|Es], Env, L, St) -> - foldr(fun (E, {T,St0}) -> - {Ce,St1} = comp_expr(E, Env, L, St0), - {c_cons(Ce, T, L),St1} - end, {c_nil(L),St}, Es); -comp_call([tuple|As], Env, L, St0) -> - {Cas,St1} = comp_args(As, Env, L, St0), - sequentialise_args(Cas, fun (Args, _, L, St) -> - {c_tuple(Args, L),St} - end, [], Env, L, St1); + Call = fun (Ces, _, _, St) -> + {foldr(fun (E, T) -> c_cons(E, T) end, c_nil(), Ces),St} + end, + comp_args(Es, Call, Env, L, St); +%% foldr(fun (E, {T,St0}) -> +%% {Ce,St1} = comp_expr(E, Env, L, St0), +%% {c_cons(Ce, T),St1} +%% end, {c_nil(),St}, Es); +comp_call([tuple|As], Env, L, St) -> + comp_args(As, fun (Args, _, _, St) -> {c_tuple(Args),St} end, Env, L, St); %% {Cas,St1} = comp_args(As, Env, L, St0), -%% {c_tuple(Cas, L),St1}; +%% {c_tuple(Cas),St1}; comp_call([binary|Segs], Env, L, St) -> comp_binary(Segs, Env, L, St); %And bitstring as well %% Handle the Core closure special forms. @@ -279,72 +282,85 @@ comp_call(['funcall',F|As], Env, L, St) -> comp_funcall(F, As, Env, L, St); %%comp_call([call,[quote,erlang],[quote,primop]|As], Env, L, St) -> %% An interesting thought to open up system. -comp_call([call,M,N|As], Env, L, St0) -> +comp_call([call,M,N|As], Env, L, St) -> %% Call a function in another module. - {Cm,St1} = comp_expr(M, Env, L, St0), - {Cn,St2} = comp_expr(N, Env, L, St1), - {Cas,St3} = comp_args(As, Env, L, St2), - {#c_call{anno=[L],module=Cm,name=Cn,args=Cas},St3}; + Call = fun ([Cm,Cn|Cas], _, L, St) -> + {#c_call{anno=[L],module=Cm,name=Cn,args=Cas},St} + end, + comp_args([M,N|As], Call, Env, L, St); +%% {[Cm,Cn|Cas],St1} = comp_args([M,N|As], Env, L, St0), +%% {#c_call{anno=[L],module=Cm,name=Cn,args=Cas},St1}; %% General function calls. -comp_call([Fun|As], Env, L, St0) when is_atom(Fun) -> +comp_call([Fun|As], Env, L, St) when is_atom(Fun) -> %% Fun is a symbol which is either a known BIF or function. - {Cas,St1} = comp_args(As, Env, L, St0), - Call = fun (Args, Env, L, St) -> - Ar = length(Args), + Call = fun (Cas, Env, L, St) -> + Ar = length(Cas), case get_fbinding(Fun, Ar, Env) of {yes,M,F} -> %Import - {#c_call{anno=[L],module=c_lit(M, L), - name=c_lit(F, L),args=Args}, - St}; + {#c_call{anno=[L],module=c_atom(M), + name=c_atom(F),args=Cas},St}; {yes,Name} -> %% Might have been renamed, use real function name. - {#c_apply{anno=[L],op=c_fname(Name, Ar, L), - args=Args},St} + {#c_apply{anno=[L],op=c_fname(Name, Ar), + args=Cas},St} end end, - sequentialise_args(Cas, Call, [], Env, L, St1). - + comp_args(As, Call, Env, L, St). + +%% {Cas,St1} = comp_args(As, Env, L, St), %% Ar = length(As), %% case get_fbinding(Fun, Ar, Env) of %% {yes,M,F} -> %Import -%% {#c_call{anno=[L],module=c_lit(M, L),name=c_lit(F, L),args=Cas}, +%% {#c_call{anno=[L],module=c_atom(M),name=c_atom(F),args=Cas}, %% St1}; %% {yes,Name} -> %% %% Might have been renamed, use real function name. -%% {#c_apply{anno=[L],op=c_fname(Name, Ar, L),args=Cas},St1} +%% {#c_apply{anno=[L],op=c_fname(Name, Ar),args=Cas},St1} %% end. -%% sequentialise_args(CompiledArgs, Call, Env, Line, State) -> -%% {CoreCall,State}. +%% comp_args(Args, Env, Line, State) -> {ArgList,State}. + +comp_args(As, Env, L, St) -> + mapfoldl(fun (A, Sta) -> comp_expr(A, Env, L, Sta) end, St, As). + +%% comp_args(Args, CallFun, Env, Line, State) -> {Call,State}. +%% Sequentialise the evaluation of Args building the Call at the +%% bottom. For non-simple arguments use let to break the arg +%% evaluation out from the main call. Cannot use foldr as we pass +%% data both in an out. -sequentialise_args([Ca|Cas], Call, Sas, Env, L, St0) -> +comp_args(As, Call, Env, L, St) -> + comp_args(As, Call, [], Env, L, St). + +comp_args([A|As], Call, Cas, Env, L, St0) -> + {Ca,St1} = comp_expr(A, Env, L, St0), %% Use erlang core compiler lib which does what we want. case core_lib:is_simple(Ca) of - true -> sequentialise_args(Cas, Call, [Ca|Sas], Env, L, St0); + true -> comp_args(As, Call, [Ca|Cas], Env, L, St1); false -> - {Var,St1} = new_c_var(L, St0), - {Rest,St2} = sequentialise_args(Cas, Call, [Var|Sas], Env, L, St1), + {Cv,St2} = new_c_var(L, St1), + {Rest,St3} = comp_args(As, Call, [Cv|Cas], Env, L, St2), {#c_let{anno=[L], - vars=[Var], + vars=[Cv], arg=Ca, - body=Rest},St2} + body=Rest},St3} end; -sequentialise_args([], Call, Sas, Env, L, St) -> - Call(reverse(Sas), Env, L, St). - -%% comp_args(Args, Env, Line, State) -> {ArgList,State}. - -comp_args(As, Env, L, St) -> - mapfoldl(fun (A, Sta) -> comp_expr(A, Env, L, Sta) end, St, As). +comp_args([], Call, Cas, Env, L, St) -> + Call(reverse(Cas), Env, L, St). %% comp_lambda(Args, Body, Env, Line, State) -> {#c_fun{},State}. %% Compile a (lambda (...) ...). comp_lambda(Args, Body, Env, L, St0) -> - Pvs = foldl(fun (A, Pvs) -> add_element(A, Pvs) end, [], Args), - Cvs = map(fun (A) -> c_var(A, L) end, Args), - {Cb,St1} = comp_body(Body, add_vbindings(Pvs, Env), L, St0), - {c_fun(Cvs, Cb, L),St1}. + {Cvs,Pvs,St1} = comp_lambda_args(Args, L, St0), + {Cb,St2} = comp_body(Body, add_vbindings(Pvs, Env), L, St1), + {c_fun(Cvs, Cb, L),St2}. + +comp_lambda_args(Args, L, St) -> + foldr(fun (A, {Cvs,Pvs0,St0}) -> + {Cv,Pvs1,St1} = pat_symb(A, L, Pvs0, St0), + {[Cv|Cvs],Pvs1,St1} + end, {[],[],St}, Args). lambda_arity([Args|_]) -> length(Args). @@ -356,9 +372,9 @@ comp_match_lambda(Cls, Env, L, St0) -> {Cvs,St1} = new_c_vars(Ar, L, St0), {Ccs,St2} = comp_match_clauses(Cls, Env, L, St1), {Fvs,St3} = new_c_vars(Ar, L, St2), - Cf = fail_clause(Fvs,c_tuple([c_lit(function_clause, L)|Fvs],L), L, St3), + Cf = fail_clause(Fvs,c_tuple([c_atom(function_clause)|Fvs]), L, St3), Cb = #c_case{anno=[L], - arg=c_values(Cvs, L), + arg=c_values(Cvs), clauses=Ccs ++ [Cf]}, {c_fun(Cvs, Cb, L),St3}. @@ -387,7 +403,7 @@ comp_match_clause([Pats|Body], Env0, L, St0) -> %% comp_let(VarBindings, Body, Env, L, State) -> {#c_let{}|#c_case{},State}. %% Compile a let expr. We are a little cunning in that we specialise -%% the the case where all the patterns are variables and there a re no +%% the the case where all the patterns are variables and there are no %% guards, the simple case. comp_let(Vbs, B, Env, L, St0) -> @@ -398,15 +414,14 @@ comp_let(Vbs, B, Env, L, St0) -> case Simple of true -> %% This is not really necessary, but fun. - Pvs = foldl(fun ([V|_], Pvs) -> add_element(V, Pvs) end, [], Vbs), - Cvs = map(fun ([V|_]) -> c_var(V, L) end, Vbs), - {Ces,St1} = mapfoldl(fun ([_,E], St) -> comp_expr(E, Env, L, St) end, - St0, Vbs), - {Cb,St2} = comp_body(B, add_vbindings(Pvs, Env), L, St1), + {Cvs,Pvs,St1} = comp_lambda_args([ V || [V|_] <- Vbs ], L, St0), + {Ces,St2} = mapfoldl(fun ([_,E], St) -> comp_expr(E, Env, L, St) end, + St1, Vbs), + {Cb,St3} = comp_body(B, add_vbindings(Pvs, Env), L, St2), {#c_let{anno=[L], vars=Cvs, - arg=c_values(Ces, L), - body=Cb},St2}; + arg=c_values(Ces), + body=Cb},St3}; false -> %% This would be much easier to do by building a clause %% and compiling it directly. but then we would have to @@ -429,13 +444,13 @@ comp_let(Vbs, B, Env, L, St0) -> {Cb,St4} = comp_body(B, Env1, L, St3), {Cvs,St5} = new_c_vars(length(Ces), L, St4), Cf = fail_clause(Cvs, - c_tuple([c_lit(badmatch, L),c_tuple(Cvs, L)],L), + c_tuple([c_atom(badmatch),c_tuple(Cvs)]), L, St5), {#c_case{anno=[L], - arg=c_values(Ces, L), + arg=c_values(Ces), clauses=[#c_clause{anno=[L],pats=Cps,guard=Cg,body=Cb},Cf]}, St5} - end. + end. %% comp_let_function(FuncBindngs, Body, Env, Line, State) -> %% {#c_letrec{},State}. @@ -490,11 +505,11 @@ func_arity(['match-lambda'|Cls]) -> %% comp_func(FuncName, FuncDef, Env, L, State) -> {{Fname,Cfun},State}. comp_func(Name, [lambda,Args|Body], Env, L, St0) -> - Cf = c_fname(Name, length(Args), L), + Cf = c_fname(Name, length(Args)), {Cfun,St1} = comp_lambda(Args, Body, Env, L, St0), {{Cf,Cfun},St1}; comp_func(Name, ['match-lambda'|Cls], Env, L, St0) -> - Cf = c_fname(Name, match_lambda_arity(Cls), L), + Cf = c_fname(Name, match_lambda_arity(Cls)), {Cfun,St1} = comp_match_lambda(Cls, Env, L, St0), {{Cf,Cfun},St1}. @@ -505,8 +520,8 @@ comp_if(Te, Tr, Fa, Env, L, St0) -> {Cte,St1} = comp_expr(Te, Env, L, St0), %Test expression {Ctr,St2} = comp_expr(Tr, Env, L, St1), %True expression {Cfa,St3} = comp_expr(Fa, Env, L, St2), %False expression - True = c_lit(true, L), - False = c_lit(false, L), + True = c_atom(true), + False = c_atom(false), Cf = if_fail(L, St3), {#c_case{anno=[L], arg=Cte, @@ -515,8 +530,8 @@ comp_if(Te, Tr, Fa, Env, L, St0) -> Cf]},St3}. if_fail(L, St) -> - Cv = c_var(omega, L), - fail_clause([Cv], c_lit(if_clause, L), L, St). + Cv = c_var(omega), + fail_clause([Cv], c_atom(if_clause), L, St). %% fail_clause(Pats, Arg, L, State) -> Clause. %% Build a general failure clause. @@ -524,8 +539,8 @@ if_fail(L, St) -> fail_clause(Pats, Arg, L, _) -> #c_clause{anno=[L,compiler_generated], %It is compiler generated! pats=Pats, - guard=c_lit(true, L), - body=c_primop(c_lit(match_fail, L), [Arg], L)}. + guard=c_atom(true), + body=c_primop(c_atom(match_fail), [Arg], L)}. %% comp_case(Expr, Clauses, Env, Line, State) -> {#c_case{},State}. %% Compile a case. @@ -541,8 +556,8 @@ case_clauses(Cls, Env, L, St) -> St, Cls). case_fail(L, St) -> - Cv = c_var(omega, L), - fail_clause([Cv], c_tuple([c_lit(case_clause, L),Cv], L), L, St). + Cv = c_var(omega), + fail_clause([Cv], c_tuple([c_atom(case_clause),Cv]), L, St). %% rec_clauses(RecClauses, Env, Line, State) -> {Clause,Timeout,After,State}. @@ -554,8 +569,8 @@ rec_clauses([Cl|Cls], Env, L, St0) -> {Cc,St1} = comp_clause(Cl, Env, L, St0), {Ccs,Ct,Ca,St2} = rec_clauses(Cls, Env, L, St1), {[Cc|Ccs],Ct,Ca,St2}; -rec_clauses([], _, L, St) -> - {[],c_lit(infinity, L),c_lit(true, L),St}. +rec_clauses([], _, _, St) -> + {[],c_atom(infinity),c_atom(true),St}. %% comp_clause(Clause, Env, Line, State) -> {#c_clause{},State}. %% This is a case/receive clause where the is only one pattern. @@ -572,7 +587,7 @@ comp_clause_body([['when',Guard]|Body], Env, L, St0) -> {Cg,Cb,St2}; comp_clause_body(Body, Env, L, St0) -> {Cb,St1} = comp_body(Body, Env, L, St0), - {c_lit(true, L),Cb,St1}. + {c_atom(true),Cb,St1}. %% comp_try(Body, Env, Line, State) -> {#c_try{},State}. %% Compile a try. We know that case is optional but must have at least @@ -638,8 +653,8 @@ try_case(Cls, Env, L, St0) -> {Cv,#c_case{anno=[L],arg=Cv,clauses=Ccs ++ [Cf]},St2}. try_case_fail(L, St) -> - Cv = c_var(omega, L), - fail_clause([Cv], c_tuple([c_lit(try_clause, L),Cv], L), L, St). + Cv = c_var(omega), + fail_clause([Cv], c_tuple([c_atom(try_clause),Cv]), L, St). %% try_exception(CatchClauses, Env, L, State) -> {Vars,#c_case{},State}. @@ -648,15 +663,15 @@ try_exception(Cls, Env, L, St0) -> {Cvs,St1} = new_c_vars(3, L, St0), %Tag, Value, Info {Ccs,St2} = case_clauses(Cls, Env, L, St1), [_,Val,Info] = Cvs, - Arg = c_tuple(Cvs, L), + Arg = c_tuple(Cvs), Fc = #c_clause{anno=[L,compiler_generated], pats=[Arg], - guard=c_lit(true, L), + guard=c_atom(true), body=raise_primop([Info,Val], L, St2)}, Excp = #c_case{anno=[L], arg=Arg, clauses=Ccs ++ [Fc]}, - {Cvs,Excp,St2}. + {Cvs,Excp,St2}. %% try_after(AfterBody, Env, L, State) -> {Vars,After,State}. @@ -670,7 +685,7 @@ try_after(B, Env, L, St0) -> {Cvs,After,St2}. raise_primop(Args, L, _) -> - c_primop(c_lit(raise, L), Args, L). + c_primop(c_atom(raise), Args, L). tag_tail([[Tag|Tail]|_], Tag) -> Tail; tag_tail([_|Try], Tag) -> tag_tail(Try, Tag); @@ -698,7 +713,7 @@ comp_funcall(['match-lambda'|Cls]=F, As, Env, L, St0) -> St1, As), {#c_let{anno=[L], vars=Cvs, - arg=c_values(Ces, L), + arg=c_values(Ces), body=Cb},St2}; false -> %Catch arg mismatch at runtime comp_funcall_1(F, As, Env, L, St0) @@ -707,9 +722,8 @@ comp_funcall(F, As, Env, L, St0) -> comp_funcall_1(F, As, Env, L, St0). %Naively just do it. comp_funcall_1(F, As, Env, L, St0) -> - {Cf,St1} = comp_expr(F, Env, L, St0), - {Cas,St2} = comp_args(As, Env, L, St1), - {#c_apply{anno=[L],op=Cf,args=Cas},St2}. + {[Cf|Cas],St1} = comp_args([F|As], Env, L, St0), + {#c_apply{anno=[L],op=Cf,args=Cas},St1}. %% comp_binary(Segs, Env, Line, State) -> {#c_binary{},State}. @@ -730,19 +744,16 @@ comp_bitsegs(Segs, Env, L, St0) -> comp_bitseg([Val|Specs], Env, L, St0) -> {Cv,St1} = comp_expr(Val, Env, L, St0), {{Ty,Sz,Un,Si,En},St2} = comp_bitspecs(Specs, #spec{}, Env, L, St1), - {c_bitseg(Cv, Sz, Un, Ty, Si, En, L),St2}; + {c_bitseg(Cv, Sz, c_int(Un), c_atom(Ty), c_lit([Si,En])),St2}; comp_bitseg(Val, Env, L, St0) -> {Cv,St1} = comp_expr(Val, Env, L, St0), %% Create default segment. {{Ty,Sz,Un,Si,En},St2} = comp_bitspecs([], #spec{}, Env, L, St1), - {c_bitseg(Cv, Sz, Un, Ty, Si, En, L),St2}. - -c_bitseg(Val, Sz, Un, Ty, Si, En, L) -> - #c_bitstr{anno=[L],val=Val,size=Sz,unit=Un,type=Ty, - flags=c_cons(Si, c_cons(En, c_nil(L), L), L)}. + {c_bitseg(Cv, Sz, c_int(Un), c_atom(Ty), c_lit([Si,En])),St2}. %% comp_bitspecs(Specs, Spec, Env, Line, State) -> %% {{Type,Size,Unit,Sign,End},State}. +%% Only Size is already in Core form as it can be an expression. comp_bitspecs(Ss, Sp0, Env, L, St0) -> {Sp1,St1} = foldl(fun (S, {Sp,St}) -> comp_bitspec(S, Sp, Env, L, St) end, @@ -751,30 +762,26 @@ comp_bitspecs(Ss, Sp0, Env, L, St0) -> #spec{type=Type,size=Csize,unit=Cunit,sign=Csign,endian=Cend} = Sp1, case Type of integer -> - {{c_lit(integer, L), - val_or_def(Csize, 8, L),val_or_def(Cunit, 1, L), - val_or_def(Csign, unsigned, L),val_or_def(Cend, big, L)},St1}; + {{integer,val_or_def(Csize, c_int(8)),val_or_def(Cunit, 1), + val_or_def(Csign, unsigned),val_or_def(Cend, big)},St1}; float -> - {{c_lit(float, L), - val_or_def(Csize, 64, L),val_or_def(Cunit, 1, L), - val_or_def(Csign, unsigned, L),val_or_def(Cend, big, L)},St1}; + {{float,val_or_def(Csize, c_int(64)),val_or_def(Cunit, 1), + val_or_def(Csign, unsigned),val_or_def(Cend, big)},St1}; utf8 -> %Ignore unused fields! - {{c_lit(utf8, L),c_lit(undefined, L),c_lit(undefined, L), - val_or_def(Csign, unsigned, L),val_or_def(Cend, big, L)},St1}; + {{utf8,c_lit(undefined),undefined, + val_or_def(Csign, unsigned),val_or_def(Cend, big)},St1}; utf16 -> %Ignore unused fields! - {{c_lit(utf16, L),c_lit(undefined, L),c_lit(undefined, L), - val_or_def(Csign, unsigned, L),val_or_def(Cend, big, L)},St1}; + {{utf16,c_lit(undefined),undefined, + val_or_def(Csign, unsigned),val_or_def(Cend, big)},St1}; utf32 -> %Ignore unused fields! - {{c_lit(utf32, L),c_lit(undefined, L),c_lit(undefined, L), - val_or_def(Csign, unsigned, L),val_or_def(Cend, big, L)},St1}; + {{utf32,c_lit(undefined),undefined, + val_or_def(Csign, unsigned),val_or_def(Cend, big)},St1}; binary -> - {{c_lit(binary, L), - val_or_def(Csize, all, L),val_or_def(Cunit, 8, L), - val_or_def(Csign, unsigned, L),val_or_def(Cend, big, L)},St1}; + {{binary,val_or_def(Csize, c_atom(all)),val_or_def(Cunit, 8), + val_or_def(Csign, unsigned),val_or_def(Cend, big)},St1}; bitstring -> - {{c_lit(binary, L), - val_or_def(Csize, all, L),val_or_def(Cunit, 1, L), - val_or_def(Csign, unsigned, L),val_or_def(Cend, big, L)},St1} + {{binary,val_or_def(Csize, c_atom(all)),val_or_def(Cunit, 1), + val_or_def(Csign, unsigned),val_or_def(Cend, big)},St1} end. %% Types. @@ -789,23 +796,23 @@ comp_bitspec('utf-8', Sp, _, _, St) -> {Sp#spec{type=utf8},St}; comp_bitspec('utf-16', Sp, _, _, St) -> {Sp#spec{type=utf16},St}; comp_bitspec('utf-32', Sp, _, _, St) -> {Sp#spec{type=utf32},St}; %% Endianness. -comp_bitspec('big-endian', Sp, _, L, St) -> - {Sp#spec{endian=c_lit(big, L)},St}; -comp_bitspec('little-endian', Sp, _, L, St) -> - {Sp#spec{endian=c_lit(little, L)},St}; -comp_bitspec('native-endian', Sp, _, L, St) -> - {Sp#spec{endian=c_lit(native, L)},St}; +comp_bitspec('big-endian', Sp, _, _, St) -> + {Sp#spec{endian=big},St}; +comp_bitspec('little-endian', Sp, _, _, St) -> + {Sp#spec{endian=little},St}; +comp_bitspec('native-endian', Sp, _, _, St) -> + {Sp#spec{endian=native},St}; %% Sign. -comp_bitspec(signed, Sp, _, L, St) -> {Sp#spec{sign=c_lit(signed, L)},St}; -comp_bitspec(unsigned, Sp, _, L, St) -> {Sp#spec{sign=c_lit(unsigned, L)},St}; +comp_bitspec(signed, Sp, _, _, St) -> {Sp#spec{sign=signed},St}; +comp_bitspec(unsigned, Sp, _, _, St) -> {Sp#spec{sign=unsigned},St}; %% Size. -comp_bitspec([unit,N], Sp, _, L, St) -> {Sp#spec{unit=c_lit(N, L)},St}; +comp_bitspec([unit,N], Sp, _, _, St) -> {Sp#spec{unit=N},St}; comp_bitspec([size,N], Sp, Env, L, St0) -> {Csz,St1} = comp_expr(N, Env, L, St0), {Sp#spec{size=Csz},St1}. -val_or_def(default, Def, L) -> c_lit(Def, L); -val_or_def(V, _, _) -> V. +val_or_def(default, Def) -> Def; +val_or_def(V, _) -> V. %% comp_guard(Guard, Env, Line, State) -> {Guard,State}. %% Should really do some special handling here. @@ -820,7 +827,7 @@ comp_guard(G, Env, L, St) -> comp_pat(Pat, L, St) -> comp_pat(Pat, L, [], St). -comp_pat([quote,E], _, Vs, St) -> {make_literal(E),Vs,St}; +comp_pat([quote,E], _, Vs, St) -> {comp_lit(E),Vs,St}; comp_pat([binary|Segs], L, Vs, St) -> pat_binary(Segs, L, Vs, St); comp_pat([tuple|Ps], L, Vs0, St0) -> @@ -828,7 +835,7 @@ comp_pat([tuple|Ps], L, Vs0, St0) -> {Cp,Vsb,Stb} = comp_pat(P, L, Vsa, Sta), {Cp,{Vsb,Stb}} end, {Vs0,St0}, Ps), - {c_tuple(Cps, L),Vs1,St1}; + {c_tuple(Cps),Vs1,St1}; comp_pat(['=',P1,P2], L, Vs0, St0) -> %% Core can only alias against a variable so there is wotk to do! {Cp1,Vs1,St1} = comp_pat(P1, L, Vs0, St0), @@ -838,19 +845,22 @@ comp_pat(['=',P1,P2], L, Vs0, St0) -> comp_pat([H|T], L, Vs0, St0) -> {Ch,Vs1,St1} = comp_pat(H, L, Vs0, St0), {Ct,Vs2,St2} = comp_pat(T, L, Vs1, St1), - {c_cons(Ch, Ct, L),Vs2,St2}; -comp_pat([], L, Vs, St) -> {c_nil(L),Vs,St}; + {c_cons(Ch, Ct),Vs2,St2}; +comp_pat([], _, Vs, St) -> {c_nil(),Vs,St}; +%% Literals. +comp_pat(Bin, _, Vs, St) when is_bitstring(Bin) -> + {comp_lit(Bin),Vs,St}; comp_pat(Tup, _, Vs, St) when is_tuple(Tup) -> - {make_literal(Tup),Vs,St}; + {comp_lit(Tup),Vs,St}; comp_pat(Symb, L, Vs, St) when is_atom(Symb) -> pat_symb(Symb, L, Vs, St); %Variable -comp_pat(Numb, L, Vs, St) when is_number(Numb) -> {c_lit(Numb, L),Vs,St}. +comp_pat(Numb, _, Vs, St) when is_number(Numb) -> {c_lit(Numb),Vs,St}. pat_symb('_', L, Vs, St0) -> %Don't care variable. {Cv,St1} = new_c_var(L, St0), {Cv,Vs,St1}; %Not added to variables -pat_symb(Symb, L, Vs, St) -> - {c_var(Symb, L),add_element(Symb, Vs),St}. +pat_symb(Symb, _, Vs, St) -> + {c_var(Symb),add_element(Symb, Vs),St}. %% pat_alias(CorePat, CorePat) -> AliasPat. @@ -916,72 +926,92 @@ pat_bitsegs(Segs, L, Vs0, St0) -> %% ??? We know its correct so why worry? ??? pat_bitseg([Pat|Specs], L, Vs0, St0) -> - {Cv,Vs1,St1} = comp_pat(Pat, L, Vs0, St0), + {Cp,Vs1,St1} = comp_pat(Pat, L, Vs0, St0), {{Ty,Sz,Un,Si,En},St2} = comp_bitspecs(Specs, #spec{}, noenv, L, St1), - {c_bitseg(Cv, Sz, Un, Ty, Si, En, L),Vs1,St2}; + {c_bitseg(Cp, Sz, c_int(Un), c_atom(Ty), c_lit([Si,En])),Vs1,St2}; pat_bitseg(Pat, L, Vs0, St0) -> - {Cv,Vs1,St1} = comp_pat(Pat, L, Vs0, St0), + {Cp,Vs1,St1} = comp_pat(Pat, L, Vs0, St0), %% Create default segment. {{Ty,Sz,Un,Si,En},St2} = comp_bitspecs([], #spec{}, noenv, L, St1), - {c_bitseg(Cv, Sz, Un, Ty, Si, En, L),Vs1,St2}. + {c_bitseg(Cp, Sz, c_int(Un), c_atom(Ty), c_lit([Si,En])),Vs1,St2}. %% c_fun(Vars, Body, Line) -> #c_fun{}. -%% c_fname(Name, Arity, Line) -> #c_fname{}. -%% c_values(Values, Line) -> #c_values{}. -%% c_cons(Head, Tail, Line) -> #c_cons{}. -%% c_nil(Line) -> #c_literal{}. -%% c_tuple(Elements, Line) -> #c_tuple{}. -%% c_lit(Value, Line) -> #c_literal{}. -%% c_var(Name, Line) -> #c_var{}. %% c_primop(Name, Args, Line) -> #c_primop{}. +%% c_fname(Name, Arity) -> #c_fname{}. +%% c_values(Values) -> #c_values{}. +%% c_cons(Head, Tail) -> #c_cons{}. +%% c_tuple(Elements) -> #c_tuple{}. +%% c_atom(Value) -> #c_literal{}. +%% c_int(Value) -> #c_literal{}. +%% c_float(Value) -> #c_literal{}. +%% c_nil() -> #c_literal{}. +%% c_lit(Value) -> #c_literal{}. +%% c_var(Name) -> #c_var{}. +%% c_bitseg(Value, Size, Unit, Type, Sign, Endian) -> #c_bitseg{}. c_fun(Vs, B, L) -> #c_fun{anno=[L],vars=Vs,body=B}. -%% R12B/R13B fix, choose one of following depending on version. -%%c_fname(N, A, _) -> #c_fname{anno=[],id=N,arity=A}. %R12B -c_fname(N, A, _) -> #c_var{anno=[],name={N,A}}. %R13B -c_values([V], _) -> V; %An optimisation -c_values(Vs, L) -> #c_values{anno=[L],es=Vs}. -c_cons(Hd, Tl, L) -> #c_cons{anno=[L],hd=Hd,tl=Tl}. -c_nil(_) -> #c_literal{anno=[],val=[]}. -c_tuple(Es, L) -> #c_tuple{anno=[L],es=Es}. -c_lit(Val, _) -> #c_literal{anno=[],val=Val}. %Enough with line numbers -c_var(N, _) -> #c_var{anno=[],name=N}. c_primop(N, As, L) -> #c_primop{anno=[L],name=N,args=As}. - -%% make_literal(Value) -> LitExpr. -%% Make a literal expression from an Erlang value. This function -%% will fail if the value is not expressable as a literal -%% (for instance, a pid). - -make_literal([]) -> #c_literal{val=[]}; -make_literal([H0|T0]) -> - case {make_literal(H0),make_literal(T0)} of +%% R12B/R13B fix, choose one of following depending on version. +%%c_fname(N, A) -> #c_fname{anno=[],id=N,arity=A}. %R12B +c_fname(N, A) -> #c_var{anno=[],name={N,A}}. %R13B +c_values([V]) -> V; %An optimisation +c_values(Vs) -> #c_values{anno=[],es=Vs}. +c_atom(A) -> #c_literal{anno=[],val=A}. +c_int(I) -> #c_literal{anno=[],val=I}. +c_float(F) -> #c_literal{anno=[],val=F}. +c_nil() -> #c_literal{anno=[],val=[]}. +c_lit(Val) -> #c_literal{anno=[],val=Val}. %Generic literal +c_cons(Hd, Tl) -> #c_cons{anno=[],hd=Hd,tl=Tl}. +c_tuple(Es) -> #c_tuple{anno=[],es=Es}. +c_var(N) -> #c_var{anno=[],name=N}. +c_bitseg(Val, Sz, Un, Ty, Fs) -> + #c_bitstr{anno=[],val=Val,size=Sz,unit=Un,type=Ty,flags=Fs}. + +%% comp_lit(Value) -> LitExpr. +%% Make a literal expression from an Erlang value. Try to make it as +%% literal as possible. This function will fail if the value is not +%% expressable as a literal (for instance, a pid). + +comp_lit([H0|T0]) -> + case {comp_lit(H0),comp_lit(T0)} of {#c_literal{val=H},#c_literal{val=T}} -> - #c_literal{val=[H|T]}; - {H,T} -> - #c_cons{hd=H,tl=T} + c_lit([H|T]); + {H,T} -> c_cons(H, T) end; -make_literal(I) when is_integer(I) -> #c_literal{val=I}; -make_literal(F) when is_float(F) -> #c_literal{val=F}; -make_literal(A) when is_atom(A) -> #c_literal{val=A}; -make_literal(T0) when is_tuple(T0) -> - T = make_literal_list(tuple_to_list(T0)), - case core_lib:is_literal_list(T) of - false -> #c_tuple{es=T}; - true -> #c_literal{val=list_to_tuple(concrete_list(T))} +comp_lit([]) -> c_nil(); +comp_lit(T) when is_tuple(T) -> + Es = comp_lit_list(tuple_to_list(T)), + case is_lit_list(Es) of + true -> c_lit(list_to_tuple(concrete_list(Es))); + false -> c_tuple(Es) end; -make_literal(Bs) when is_binary(Bs) -> - case bit_size(Bs) of - Bitsize when Bitsize rem 8 =:= 0 -> - #c_literal{val=Bs} - end. +comp_lit(A) when is_atom(A) -> c_atom(A); +comp_lit(I) when is_integer(I) -> c_int(I); +comp_lit(F) when is_float(F) -> c_float(F); +comp_lit(Bin) when is_bitstring(Bin) -> + Bits = comp_lit_bitsegs(Bin), + #c_binary{anno=[],segments=Bits}. -make_literal_list(Vals) -> [make_literal(V) || V <- Vals]. +comp_lit_list(Vals) -> [ comp_lit(V) || V <- Vals ]. + +is_lit_list(Es) -> all(fun (E) -> is_record(E, c_literal) end, Es). concrete_list([#c_literal{val=V}|T]) -> [V|concrete_list(T)]; concrete_list([]) -> []. +comp_lit_bitsegs(<<B:8,Bits/bitstring>>) -> %Next byte + [c_byte_bitseg(B, 8)|comp_lit_bitsegs(Bits)]; +comp_lit_bitsegs(<<>>) -> []; %Even bytes +comp_lit_bitsegs(Bits) -> %Size < 8 + N = bit_size(Bits), + <<B:N>> = Bits, + [c_byte_bitseg(B, N)]. + +c_byte_bitseg(B, Sz) -> + c_bitseg(c_lit(B), c_int(Sz), c_int(1), c_atom(integer), + c_lit([unsigned,big])). + %% new_symb(State) -> {Symbol,State}. %% Create a hopefully new unused symbol. @@ -996,10 +1026,10 @@ new_fun_name(Pre, St) -> %% new_c_var(Line, State) -> {#c_var{},State}. %% Create a hopefully new core variable. -new_c_var(L, St) -> +new_c_var(_, St) -> C = St#cg.vc, Name = list_to_atom(integer_to_list(C)), - {c_var(Name, L),St#cg{vc=C+1}}. + {c_var(Name),St#cg{vc=C+1}}. new_c_vars(N, L, St) -> new_c_vars(N, L, St, []). src/lfe_codegen.erl @@ -33,8 +33,8 @@ %% -compile(export_all). --import(lists, [member/2,keysearch/3, - all/2,map/2,foldl/3,foldr/3,mapfoldl/3,mapfoldr/3, +-import(lists, [member/2,keysearch/3,filter/2,foreach/2, + all/2,map/2,flatmap/2,foldl/3,foldr/3,mapfoldl/3,mapfoldr/3, concat/1]). -import(ordsets, [add_element/2,is_element/2,from_list/1,union/2]). -import(orddict, [store/3,find/2]). @@ -44,12 +44,16 @@ -include_lib("compiler/src/core_parse.hrl"). -record(comp, {base="", %Base name + odir=".", %Output directory lfile="", %Lisp file bfile="", %Beam file cfile="", %Core file opts=[], %User options mod=[], %Module name - ret=file %Return file|dcore|tcore|bin + ret=file, %What is returned [Val] | [] + code=none, %Code after last pass. + errors=[], + warnings=[] }). %% file(Name) -> @@ -61,16 +65,14 @@ file(Name) -> file(Name, [verbose,report]). %Default options file(Name, Opts0) -> - {Opts1,St0} = lfe_comp_opts(Opts0, #comp{}), - St1 = filenames(Name, St0#comp{opts=Opts1}), + Opts1 = lfe_comp_opts(Opts0), + St0 = #comp{opts=Opts1}, + St1 = filenames(Name, St0), case lfe_io:parse_file(St1#comp.lfile) of {ok,Fs} -> %% Do the actual compilation work. - case do_forms(Fs, St1) of - {ok,Core,Ws,St2} -> erl_comp(Core, Ws, St2); - {error,Es,Ws,St2} -> do_error_return(Es, Ws, St2) - end; - {error,Error} -> do_error_return([Error], [], St1) + do_forms(St1#comp{code=Fs}); + {error,Error} -> do_error_return(St1#comp{errors=[Error]}) end. %% forms(Forms) -> {ok,Mod,Bin,Warnings} | {error,Errors,Warnings}. @@ -80,137 +82,202 @@ file(Name, Opts0) -> forms(Forms) -> forms(Forms, [verbose,report]). %Default options forms(Fs0, Opts0) -> - {Opts1,St0} = lfe_comp_opts(Opts0, #comp{}), + Opts1 = lfe_comp_opts(Opts0), + St0 = #comp{opts=[binary|Opts1]}, %Implicit binary option St1 = filenames("-no-file-", St0#comp{opts=Opts1}), %% Tag forms with a "line number", just use their index. {Fs1,_} = mapfoldl(fun (F, N) -> {{F,N},N+1} end, 1, Fs0), - case do_forms(Fs1, St1) of - {ok,Core,Ws,St2} -> erl_comp(Core, Ws, St2); - {error,Es,Ws,St2} -> do_error_return(Es, Ws, St2) - end. + do_forms(St1#comp{code=Fs1}). %% filenames(File, State) -> State. %% The default output dir is the current directory unless an %% explicit one has been given in the options. -filenames(File, St0) -> +filenames(File, St) -> + %% Test for explicit outdir. + Odir = case keysearch(outdir, 1, St#comp.opts) of + {value,{outdir,D}} -> D; + false -> "." + end, Dir = filename:dirname(File), Base = filename:basename(File, ".lfe"), Lfile = filename:join(Dir, Base ++ ".lfe"), Bfile = Base ++ ".beam", Cfile = Base ++ ".core", - St1 = St0#comp{lfile=Lfile}, - %% Test for explicit out dir. - case keysearch(outdir, 1, St1#comp.opts) of - {value,{outdir,D}} -> - St1#comp{bfile=filename:join(D, Bfile), - cfile=filename:join(D, Cfile)}; - _ -> - St1#comp{bfile=Bfile,cfile=Cfile} - end. + St#comp{base=Base, + lfile=Lfile, + odir=Odir, + bfile=filename:join(Odir, Bfile), + cfile=filename:join(Odir, Cfile)}. -%% lfe_comp_opts(Opts, State) -> {Opts,State}. -%% Check options for return type (dcore/tcore/binary), trim options -%% and set options in state. +%% lfe_comp_opts(Opts) -> Opts. +%% Check options for lfe compiler. -lfe_comp_opts(Opts, St) -> - foldr(fun(dcore, {Os,S}) -> {Os,S#comp{ret=dcore}}; - (to_core, {Os,S}) -> {Os,S#comp{ret=to_core}}; - (binary, {Os,S}) -> {Os,S#comp{ret=binary}}; - (file, {Os,S}) -> {Os,S#comp{ret=file}}; - (Opt, {Os,S}) -> {[Opt|Os],S} - end, {[],St#comp{ret=file}}, Opts). +lfe_comp_opts(Opts) -> + filter(fun (_) -> true end, Opts). -%% do_forms(Forms, State) -> -%% {ok,Core,Warnings,State} | {error,Errors,Warnings,State}. +%% do_forms(State) -> +%% {ok,Mod,[Core],[Warnings]} | {error,Errors,Warnings} | error. %% Run the actual LFE compiler passes. -do_forms(Fs0, St) -> - %% First macro expand forms. - {Fs1,Env} = lfe_macro:expand_forms(Fs0, new_env()), - debug_print("mac: ~p\n", [{Fs1,Env}], St), - %% Lint and then compile if ok. - case lfe_lint:module(Fs1, St#comp.opts) of +do_forms(St0) -> + Ps = passes(), + case do_passes(Ps, St0) of + {ok,St1} -> do_ok_return(St1); + {error,St1} -> do_error_return(St1) + end. + +%% do_macro_expand(State) -> {ok,State} | {error,State}. +%% do_lint(State) -> {ok,State} | {error,State}. +%% do_lfe_codegen(State) -> {ok,State} | {error,State}. +%% do_erl_comp(State) -> {ok,State} | {error,State}. +%% The actual compiler passes. + +do_macro_expand(St) -> + {Fs,Env} = lfe_macro:expand_forms(St#comp.code, new_env()), + debug_print("mac: ~p\n", [{Fs,Env}], St), + {ok,St#comp{code=Fs}}. + +do_lint(St) -> + case lfe_lint:module(St#comp.code, St#comp.opts) of {ok,Ws} -> - Fs2 = lfe_pmod:module(Fs1, St#comp.opts), - {Mod,Core1} = lfe_codegen:forms(Fs2, St#comp.opts), - {ok,Core1,Ws,St#comp{mod=Mod}}; + {ok,St#comp{warnings=Ws}}; {error,Es,Ws} -> - {error,Es,Ws,St} + {error,St#comp{errors=Es,warnings=Ws}} end. -%% erl_comp(Core, Warnings, State) -> -%% {ok,Mod[,Binary][,Warnings]}. -%% Run the erlang compiler on the core module. - -erl_comp(Core, Warns, St) -> - Eopts = erl_comp_opts(St#comp.opts), %Fix options for compiler - %% Do work and fix returns accordingly. - Ret = case St#comp.ret of - dcore -> - ok = file:write_file(St#comp.cfile, [core_pp:format(Core),$\n]), - {ok,[],[]}; - to_core -> - case compile:forms(Core, [from_core,to_core|Eopts]) of - {ok,_,Cfr,Ews} -> - Cpp = [core_pp:format(Cfr),$\n], - ok = file:write_file(St#comp.cfile, Cpp), - {ok,[],Ews}; - Error -> Error - end; - binary -> - case compile:forms(Core, [from_core,binary|Eopts]) of - {ok,_,Bin,Ews} -> {ok,[Bin],Ews}; - Error -> Error - end; - file -> - case compile:forms(Core, [from_core,binary|Eopts]) of - {ok,_,Bin,Ews} -> - ok = file:write_file(St#comp.bfile, Bin), - {ok,[],Ews}; - Error -> Error - end - end, - case Ret of - {ok,Stuff,Ews1} -> - do_ok_return(Stuff, Warns ++ fix_erl_errors(Ews1), St); - {error,Ees,Ews1} -> - do_error_return(fix_erl_errors(Ees), - Warns ++ fix_erl_errors(Ews1), St) +do_lfe_codegen(#comp{code=Fs0}=St) -> + Opts = lfe_comp_opts(St#comp.opts), + Fs1 = lfe_pmod:module(Fs0, Opts), + {Mod,Core} = lfe_codegen:forms(Fs1, Opts), + {ok,St#comp{code=Core,mod=Mod}}. + +do_erl_comp(St) -> + Opts = erl_comp_opts(St#comp.opts), + Es = St#comp.errors, + Ws = St#comp.warnings, + case compile:forms(St#comp.code, [from_core,binary|Opts]) of + {ok,_,Result,Ews} -> + {ok,St#comp{code=Result,warnings=Ws ++ fix_erl_errors(Ews)}}; + {error,Ees,Ews} -> + {error,St#comp{warnings=Es ++ fix_erl_errors(Ees), + errors=Ws ++ fix_erl_errors(Ews)}} end. -%% fix_erl_errors([{File,Errors}]) -> Errors. +%% passes() -> [Pass]. +%% do_passes(Passes, State) -> {ok,State} | {error,State}. +%% {when_flag,Flag,Cmd} +%% {unless_flag,Flag,Cmd} +%% {do,Fun} +%% {pass,Fun} +%% {done,PrintFun,Ext} + +passes() -> + [{do,fun do_macro_expand/1}, + {when_flag,to_exp,{done,fun sexpr_pp/2,"expand"}}, + {do,fun do_lint/1}, + {do,fun do_lfe_codegen/1}, + {when_flag,to_core0,{done,fun core_pp/2,"core"}}, + {do,fun do_erl_comp/1}, + %% These options will have made erl compiler return internal form + %% after pass. + {when_flag,to_core,{done,fun core_pp/2,"core"}}, + {when_flag,to_kernel,{done,fun kernel_pp/2,"kernel"}}, + {when_flag,to_asm,{done,fun asm_pp/2,"S"}}, + {done,fun beam_write/2,"beam"}]. %Should be last + +do_passes([{do,Fun}|Ps], St0) -> + case Fun(St0) of + {ok,St1} -> do_passes(Ps, St1); + {error,St1} -> {error,St1} + end; +do_passes([{when_flag,Flag,Cmd}|Ps], St) -> + case member(Flag, St#comp.opts) of + true -> do_passes([Cmd|Ps], St); + false -> do_passes(Ps, St) + end; +do_passes([{unless_flag,Flag,Cmd}|Ps], St) -> + case member(Flag, St#comp.opts) of + true -> do_passes(Ps, St); + false -> do_passes([Cmd|Ps], St) + end; +do_passes([{when_test,Test,Cmd}|Ps], St) -> + case Test(St) of + true -> do_passes([Cmd|Ps], St); + false -> do_passes(Ps, St) + end; +do_passes([{unless_test,Test,Cmd}|Ps], St) -> + case Test(St) of + true -> do_passes(Ps, St); + false -> do_passes([Cmd|Ps], St) + end; +do_passes([{done,Fun,Ext}|_], St) -> + %% Either return code as value or print out file. + case member(binary, St#comp.opts) of + true -> {ok,St#comp{ret=[St#comp.code]}}; + false -> do_save_file(Fun, Ext, St#comp{ret=[]}) + end; +do_passes([], St) -> {ok,St}. %Got to the end, everything ok! + +do_save_file(Fun, Ext, St) -> + Name = filename:join(St#comp.odir, St#comp.base ++ ["."|Ext]), + case file:open(Name, [write,delayed_write]) of + {ok,File} -> + Fun(File, St#comp.code), + ok = file:close(File), + {ok,St}; + {error,E} -> {error,St#comp{errors=[{file,E}]}} + end. -fix_erl_errors([{_,Es}|Fes]) -> Es ++ fix_erl_errors(Fes); -fix_erl_errors([]) -> []. +%% sexpr_pp(File, Sexprs) -> ok. +%% core_pp(File, Sexprs) -> ok. +%% kernel_pp(File, Sexprs) -> ok. +%% asm_pp(File, Sexprs) -> ok. +%% beam_write(File, Beamcode) -> ok. -%% erl_comp_opts(Options) -> Options. -%% Strip out report options and make sure erlang compiler returns -%% errors and warnings. +sexpr_pp(File, Code) -> lfe_io:prettyprint(File, Code),io:nl(File). + +core_pp(File, Core) -> io:put_chars(File, [core_pp:format(Core),$\n]). + +kernel_pp(File, Kern) -> io:put_chars(File, [v3_kernel_pp:format(Kern),$\n]). -erl_comp_opts([report|Os]) -> erl_comp_opts(Os); -erl_comp_opts([report_warnings|Os]) -> erl_comp_opts(Os); -erl_comp_opts([report_errors|Os]) -> erl_comp_opts(Os); -erl_comp_opts([O|Os]) -> [O|erl_comp_opts(Os)]; -erl_comp_opts([]) -> [return]. %Ensure return! +asm_pp(File, Asm) -> beam_listing:module(File, Asm). -%% do_ok_return(Ret, Warnings, State) -> {ok,Mod,...}. -%% do_error_return(Errors, Warnings, State) -> {error,...} | error. +beam_write(File, Beam) -> file:write(File, Beam). + +%% fix_erl_errors([{File,Errors}]) -> Errors. -do_ok_return(Ret0, Warns, St) -> - Lfile = St#comp.lfile, - Opts = St#comp.opts, - when_opt(fun () -> list_warnings(Lfile, Warns) end, report, Opts), +fix_erl_errors(Fes) -> flatmap(fun ({_,Es}) -> Es end, Fes). + +%% erl_comp_opts(Options) -> Options. +%% Strip out report options and make sure erlang compiler returns +%% errors and warnings. Also remove other options which might cause +%% strange behaviour. + +erl_comp_opts(Os) -> + filter(fun (report) -> false; %No reporting! + (report_warnings) -> false; + (report_errors) -> false; + ('S') -> false; + ('E') -> false; + (dcore) -> false; + (to_core0) -> false; + (_) -> true %Everything else + end, [return|Os]). %Ensure return! + +%% do_ok_return(State) -> {ok,Mod,...}. +%% do_error_return(State) -> {error,...} | error. + +do_ok_return(#comp{lfile=Lfile,opts=Opts,ret=Ret0,warnings=Ws}=St) -> + when_opt(fun () -> list_warnings(Lfile, Ws) end, report, Opts), %% Fix right return. Ret1 = case member(return, Opts) of - true -> Ret0 ++ [return_errors(Lfile, Warns)]; + true -> Ret0 ++ [return_errors(Lfile, Ws)]; false -> Ret0 end, list_to_tuple([ok,St#comp.mod|Ret1]). -do_error_return(Es, Ws, St) -> - Lfile = St#comp.lfile, - Opts = St#comp.opts, +do_error_return(#comp{lfile=Lfile,opts=Opts,errors=Es,warnings=Ws}) -> when_opt(fun () -> list_errors(Lfile, Es) end, report, Opts), when_opt(fun () -> list_warnings(Lfile, Ws) end, report, Opts), %% Fix right return. @@ -222,21 +289,23 @@ do_error_return(Es, Ws, St) -> return_errors(_, []) -> []; return_errors(Lfile, Es) -> [{Lfile,Es}]. -list_warnings(F, [{Line,Mod,Warn}|Ws]) -> - lfe_io:format("~s:~w: Warning: ~s\n", [F,Line,Mod:format_error(Warn)]), - list_warnings(F, Ws); -list_warnings(F, [{Mod,Warn}|Ws]) -> - lfe_io:format("~s: Warning: ~s\n", [F,Mod:format_error(Warn)]), - list_warnings(F, Ws); -list_warnings(_, []) -> []. - -list_errors(F, [{Line,Mod,Error}|Ws]) -> - lfe_io:format("~s:~w: ~s\n", [F,Line,Mod:format_error(Error)]), - list_errors(F, Ws); -list_errors(F, [{Mod,Error}|Ws]) -> - lfe_io:format("~s: ~s\n", [F,Mod:format_error(Error)]), - list_errors(F, Ws); -list_errors(_, []) -> []. +list_warnings(F, Ws) -> + foreach(fun ({Line,Mod,Warn}) -> + Cs = Mod:format_error(Warn), + lfe_io:format("~s:~w: Warning: ~s\n", [F,Line,Cs]); + ({Mod,Warn}) -> + Cs = Mod:format_error(Warn), + lfe_io:format("~s: Warning: ~s\n", [F,Cs]) + end, Ws). + +list_errors(F, Es) -> + foreach(fun ({Line,Mod,Error}) -> + Cs = Mod:format_error(Error), + lfe_io:format("~s:~w: ~s\n", [F,Line,Cs]); + ({Mod,Error}) -> + Cs = Mod:format_error(Error), + lfe_io:format("~s: ~s\n", [F,Cs]) + end, Es). debug_print(Format, Args, St) -> when_opt(fun () -> lfe_io:format(Format, Args) end, src/lfe_comp.erl @@ -31,9 +31,11 @@ -module(lfe_eval). --export([eval/1,eval/2,eval_list/2,apply/2,apply/3, +-export([expr/1,expr/2,gexpr/1,gexpr/2,apply/2,apply/3, make_letrec_env/2,add_expr_func/4,match/3]). +-export([eval/1,eval/2,eval_list/2]). + -import(lfe_lib, [new_env/0,add_vbinding/3,add_vbindings/2,get_vbinding/2, add_fbinding/4,add_fbindings/2,get_fbinding/3, add_ibinding/5,get_gbinding/3]). @@ -41,8 +43,31 @@ -import(lists, [reverse/1,map/2,foldl/3]). -import(orddict, [find/2,store/3]). +-deprecated([eval/1,eval/2]). + %% -compile([export_all]). +%% eval(Sexpr) -> Value. +%% eval(Sexpr, Env) -> Value. + +eval(E) -> eval(E, new_env()). + +eval(E, Env) -> eval_expr(E, Env). + +%% expr(Sexpr) -> Value. +%% expr(Sexpr, Env) -> Value. + +expr(E) -> expr(E, new_env()). + +expr(E, Env) -> eval_expr(E, Env). + +%% expr(Sexpr) -> Value. +%% expr(Sexpr, Env) -> Value. + +gexpr(E) -> gexpr(E, new_env()). + +gexpr(E, Env) -> eval_gexpr(E, Env). + %% apply(Function, Args) -> Expr. %% apply(Function, Args, Env) -> Expr. %% This is applying interpreted Erlang functions, for applying funs @@ -56,13 +81,6 @@ apply(F, Args) -> apply(F, Args, Env) -> eval_apply({expr,F,Env}, Args, Env). %Env at function def -%% eval(Sexpr) -> Value. -%% eval(Sexpr, Env) -> Value. - -eval(E) -> eval(E, new_env()). - -eval(E, Env) -> eval_expr(E, Env). - %% eval_expr(Sexpr, Environment) -> Value. %% Evaluate a sexpr in the current environment. Try to catch core %% forms by just name and check arguments arguments later. Otherwise @@ -121,10 +139,10 @@ eval_expr([Fun|Es]=Call, Env) when is_atom(Fun) -> end; eval_expr([_|_], _) -> erlang:error({bad_form,application}); -eval_expr(E, Env) when is_atom(E) -> - case get_vbinding(E, Env) of +eval_expr(Symb, Env) when is_atom(Symb) -> + case get_vbinding(Symb, Env) of {yes,Val} -> Val; - no -> erlang:error({unbound_symb,E}) + no -> erlang:error({unbound_symb,Symb}) end; eval_expr(E, _) -> E. %Atoms evaluate to themselves. @@ -136,33 +154,36 @@ eval_body([E|Es], Env) -> eval_expr(E, Env), eval_body(Es, Env); 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} = eval_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} = eval_bitspecs([], #spec{}, Env), - eval_exp_field(V, Ty, Sz, Un, Si, En). + eval_exp_field(V, Spec). -%% eval_bitspecs(Specs, Spec, Env) -> {Type,Size,Unit,Sign,End}. +%% parse_bitspecs(Specs, Spec, Env) -> {Type,Size,Unit,Sign,End}. -eval_bitspecs(Ss, Sp0, Env) -> - Sp1 = foldl(fun (S, Sp) -> eval_bitspec(S, Sp, Env) end, Sp0, Ss), +parse_bitspecs(Ss, Sp0, Env) -> + Sp1 = foldl(fun (S, Sp) -> parse_bitspec(S, Sp, Env) end, Sp0, Ss), %% Adjust the values depending on type and given value. #spec{type=Type,size=Csize,unit=Cunit,sign=Csign,endian=Cend} = Sp1, case Type of @@ -191,84 +212,75 @@ eval_bitspecs(Ss, Sp0, Env) -> end. %% Types. -eval_bitspec(integer, Sp, _) -> Sp#spec{type=integer}; -eval_bitspec(float, Sp, _) -> Sp#spec{type=float}; -eval_bitspec(binary, Sp, _) -> Sp#spec{type=binary}; -eval_bitspec(bytes, Sp, _) -> Sp#spec{type=binary}; -eval_bitspec(bitstring, Sp, _) -> Sp#spec{type=bitstring}; -eval_bitspec(bits, Sp, _) -> Sp#spec{type=bitstring}; +parse_bitspec(integer, Sp, _) -> Sp#spec{type=integer}; +parse_bitspec(float, Sp, _) -> Sp#spec{type=float}; +parse_bitspec(binary, Sp, _) -> Sp#spec{type=binary}; +parse_bitspec(bytes, Sp, _) -> Sp#spec{type=binary}; +parse_bitspec(bitstring, Sp, _) -> Sp#spec{type=bitstring}; +parse_bitspec(bits, Sp, _) -> Sp#spec{type=bitstring}; %% Unicode types. -eval_bitspec('utf-8', Sp, _) -> Sp#spec{type=utf8}; -eval_bitspec('utf-16', Sp, _) -> Sp#spec{type=utf16}; -eval_bitspec('utf-32', Sp, _) -> Sp#spec{type=utf32}; +parse_bitspec('utf-8', Sp, _) -> Sp#spec{type=utf8}; +parse_bitspec('utf-16', Sp, _) -> Sp#spec{type=utf16}; +parse_bitspec('utf-32', Sp, _) -> Sp#spec{type=utf32}; %% Endianness. -eval_bitspec('big-endian', Sp, _) -> Sp#spec{endian=big}; -eval_bitspec('little-endian', Sp, _) -> Sp#spec{endian=little}; -eval_bitspec('native-endian', Sp, _) -> Sp#spec{endian=native}; +parse_bitspec('big-endian', Sp, _) -> Sp#spec{endian=big}; +parse_bitspec('little-endian', Sp, _) -> Sp#spec{endian=little}; +parse_bitspec('native-endian', Sp, _) -> Sp#spec{endian=native}; %% Sign. -eval_bitspec(signed, Sp, _) -> Sp#spec{sign=signed}; -eval_bitspec(unsigned, Sp, _) -> Sp#spec{sign=unsigned}; +parse_bitspec(signed, Sp, _) -> Sp#spec{sign=signed}; +parse_bitspec(unsigned, Sp, _) -> Sp#spec{sign=unsigned}; %% Size. -eval_bitspec([size,N], Sp, Env) -> +parse_bitspec([size,N], Sp, Env) -> Size = eval_expr(N, Env), Sp#spec{size=Size}; -eval_bitspec([unit,N], Sp, _) when is_integer(N), N > 0 -> Sp#spec{unit=N}; -eval_bitspec(Spec, _, _) -> erlang:error({illegal_bitspec,Spec}). +parse_bitspec([unit,N], Sp, _) when is_integer(N), N > 0 -> Sp#spec{unit=N}; +%% Illegal spec. +parse_bitspec(Spec, _, _) -> erlang:error({illegal_bitspec,Spec}). val_or_def(default, Def) -> Def; val_or_def(V, _) -> V. -%% eval_exp_field(Value, Type, Size, Unit, Sign, Endian) -> Binary. - -%% 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}) -> - -%% Integer types. -eval_exp_field(Val, integer, Size, Unit, signed, little) -> - <<Val:(Size*Unit)/little-signed>>; -eval_exp_field(Val, integer, Size, Unit, unsigned, little) -> - <<Val:(Size*Unit)/little>>; -eval_exp_field(Val, integer, Size, Unit, signed, native) -> - <<Val:(Size*Unit)/native-signed>>; -eval_exp_field(Val, integer, Size, Unit, unsigned, native) -> - <<Val:(Size*Unit)/native>>; -eval_exp_field(Val, integer, Size, Unit, signed, big) -> - <<Val:(Size*Unit)/signed>>; -eval_exp_field(Val, integer, Size, Unit, unsigned, big) -> - <<Val:(Size*Unit)>>; -%% Unicode types, ignore unused fields. -eval_exp_field(Val, utf8, _, _, _, _) -> <<Val/utf8>>; -eval_exp_field(Val, utf16, _, _, _, little) -> <<Val/utf16-little>>; -eval_exp_field(Val, utf16, _, _, _, native) -> <<Val/utf16-native>>; -eval_exp_field(Val, utf16, _, _, _, big) -> <<Val/utf16-big>>; -eval_exp_field(Val, utf32, _, _, _, little) -> <<Val/utf32-little>>; -eval_exp_field(Val, utf32, _, _, _, native) -> <<Val/utf32-native>>; -eval_exp_field(Val, utf32, _, _, _, big) -> <<Val/utf32-big>>; -%% Float types. -eval_exp_field(Val, float, Size, Unit, _, little) -> - <<Val:(Size*Unit)/float-little>>; -eval_exp_field(Val, float, Size, Unit, _, native) -> - <<Val:(Size*Unit)/float-native>>; -eval_exp_field(Val, float, Size, Unit, _, big) -> - <<Val:(Size*Unit)/float>>; -%% 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>>; +eval_int_field(Val, Sz, signed, native) -> <<Val:Sz/native-signed>>; +eval_int_field(Val, Sz, unsigned, native) -> <<Val:Sz/native>>; +eval_int_field(Val, Sz, signed, big) -> <<Val:Sz/signed>>; +eval_int_field(Val, Sz, unsigned, big) -> <<Val:Sz>>. + +eval_utf16_field(Val, little) -> <<Val/utf16-little>>; +eval_utf16_field(Val, native) -> <<Val/utf16-native>>; +eval_utf16_field(Val, big) -> <<Val/utf16-big>>. + +eval_utf32_field(Val, little) -> <<Val/utf32-little>>; +eval_utf32_field(Val, native) -> <<Val/utf32-native>>; +eval_utf32_field(Val, big) -> <<Val/utf32-big>>. + +eval_float_field(Val, Sz, little) -> <<Val:Sz/float-little>>; +eval_float_field(Val, Sz, native) -> <<Val:Sz/float-native>>; +eval_float_field(Val, Sz, big) -> <<Val:Sz/float>>. %% eval_lambda(LambdaBody, Env) -> Val. %% Evaluate (lambda args ...). @@ -308,6 +320,8 @@ eval_lambda(Vals, Args, Body, Env0) -> Env1 = bind_args(Args, Vals, Env0), eval_body(Body, Env1). +bind_args(['_'|As], [_|Es], Env) -> %Ignore don't care variables + bind_args(As, Es, Env); bind_args([A|As], [E|Es], Env) when is_atom(A) -> bind_args(As, Es, add_vbinding(A, E, Env)); bind_args([], [], Env) -> Env. @@ -354,8 +368,9 @@ eval_match_clauses(Vals, [[Pats|B0]|Cls], Env) -> {yes,B1,Vbs} -> eval_body(B1, add_vbindings(Vbs, Env)); no -> eval_match_clauses(Vals, Cls, Env) end; - true -> eval_match_clauses(Vals, Cls, Env) - end. + true -> erlang:error(badarity) + end; +eval_match_clauses(_, _, _) -> erlang:error(function_clause). eval_let([Vbs|Body], Env0) -> Env1 = foldl(fun ([Pat,E], Env) -> @@ -379,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). @@ -482,7 +497,7 @@ eval_receive(Body, Env) -> infinity -> receive_clauses(Cls, Env, []); T -> receive_clauses(T, Tb, Cls, Env) end. - + split_receive([['after',T|B]], Rcls) -> {reverse(Rcls),T,B}; split_receive([Cl|Cls], Rcls) -> @@ -499,7 +514,7 @@ receive_clauses(Cls, Env, Ms) -> eval_body(B, add_vbindings(Vbs, Env)); no -> receive_clauses(Cls, Env, [Msg|Ms]) end - end. + end. %% receive_clauses(Timeout, TimeoutBody, Clauses) -> Value. %% Recurse down message queue until timeout. We are never called with @@ -588,7 +603,7 @@ eval_try(E, Case, Catch, After, Env) -> no -> [] end end. - + eval_catch_clauses(V, [[Pat|B0]|Cls], Env) -> case match_when(Pat, V, B0, Env) of {yes,B1,Vbs} -> eval_body(B1, add_vbindings(Vbs, Env)); @@ -606,7 +621,7 @@ eval_call([M0,F0|As0], Env) -> %% match_when(Pattern, Value, Body, Env) -> {yes,RestBody,Bindings} | no. %% Try to match pattern and evaluate guard. - + match_when(Pat, V, B0, Env) -> case match(Pat, V, Env) of {yes,Vbs} -> @@ -641,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); @@ -737,7 +752,7 @@ match(Symb, Val, Env, Bs) when is_atom(Symb) -> match_symb(Symb, Val, Env, Bs); match(Val, Val, _, Bs) -> {yes,Bs}; match(_, _, _, _) -> no. - + match_symb('_', _, _, Bs) -> {yes,Bs}; %Don't care variable. match_symb(Symb, Val, _, Bs) -> %% Check if Symb already bound. @@ -747,98 +762,106 @@ match_symb(Symb, Val, _, Bs) -> end. %% match_binary(Fields, Binary, Env, Bindings) -> {yes,Bindings} | no. -%% Match Fields against Binary. This code is taken from eval_bits.erl. -%% Use catch to trap bad matches when getting value, errors become -%% no match. - -match_binary([F|Fs], Bin0, Env, Bs0) -> - case catch match_field(F, Bin0, Env, Bs0) of - {yes,Bs1,Bin1} -> match_binary(Fs, Bin1, Env, Bs1); - no -> no; - _Error -> no +%% Match Fields against Binary. This code is taken from +%% eval_bits.erl. Use catch to trap bad matches when getting value, +%% errors become no match. Split into two passes so as to throw error +%% on bitspec error and return no on all no matches. + +match_binary(Fs, Bin, Env, Bs0) -> + Psps = map(fun (F) -> parse_field(F, Env) end, Fs), + %% 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. + +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); + no -> no end; -match_binary([], <<>>, _, Bs) -> {yes,Bs}; -match_binary([], _, _, _) -> no. - -match_field([Pat|Specs], Bin, Env, Bs) -> - SpecT = eval_bitspecs(Specs, #spec{}, Env), - match_field(Pat, SpecT, Bin, Env, Bs); -match_field(Pat, Bin, Env, Bs) -> - SpecT = eval_bitspecs([], #spec{}, Env), - match_field(Pat, SpecT, Bin, Env, Bs). - -match_field(Pat, {Ty,Sz,Un,Si,En}, Bin0, Env, Bs0) -> - {Val,Bin1} = get_value(Bin0, Ty, Sz, Un, Si, En), +match_fields([], Bin, _, Bs) -> {yes,Bin,Bs}. + +match_field(Pat, Spec, Bin0, Env, Bs0) -> + {Val,Bin1} = get_pat_field(Bin0, Spec), case match(Pat, Val, Env, Bs0) of - {yes,Bs1} -> {yes,Bs1,Bin1}; + {yes,Bs1} -> {yes,Bin1,Bs1}; no -> no end. -get_value(Bin, integer, Sz, Un, Si, En) -> - get_integer(Bin, Sz*Un, Si, En); -%% Unicode types, ignore unused fields. -get_value(Bin, utf8, _, _, _, _) -> - <<Val/utf8,Rest/bitstring>> = Bin, - {Val,Rest}; -get_value(Bin, utf16, _, _, _, En) -> - get_utf16(Bin, En); -get_value(Bin, utf32, _, _, _, En) -> - get_utf32(Bin, En); -get_value(Bin, float, Sz, Un, _, En) -> - get_float(Bin, Sz*Un, En); -get_value(Bin, binary, all, Un, _, _) -> - 0 = (erlang:bit_size(Bin) rem Un), - {Bin,<<>>}; -get_value(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_integer(Bin, Sz, signed, little) -> +get_int_field(Bin, Sz, signed, little) -> <<Val:Sz/little-signed,Rest/binary-unit:1>> = Bin, {Val,Rest}; -get_integer(Bin, Sz, unsigned, little) -> +get_int_field(Bin, Sz, unsigned, little) -> <<Val:Sz/little-unsigned,Rest/binary-unit:1>> = Bin, {Val,Rest}; -get_integer(Bin, Sz, signed, native) -> +get_int_field(Bin, Sz, signed, native) -> <<Val:Sz/native-signed,Rest/binary-unit:1>> = Bin, {Val,Rest}; -get_integer(Bin, Sz, unsigned, native) -> +get_int_field(Bin, Sz, unsigned, native) -> <<Val:Sz/native-unsigned,Rest/binary-unit:1>> = Bin, {Val,Rest}; -get_integer(Bin, Sz, signed, big) -> +get_int_field(Bin, Sz, signed, big) -> <<Val:Sz/big-signed,Rest/binary-unit:1>> = Bin, {Val,Rest}; -get_integer(Bin, Sz, unsigned, big) -> +get_int_field(Bin, Sz, unsigned, big) -> <<Val:Sz/big-unsigned,Rest/binary-unit:1>> = Bin, {Val,Rest}. -get_utf16(Bin, little) -> +get_utf8_field(Bin) -> + <<Val/utf8,Rest/bitstring>> = Bin, + {Val,Rest}. + +get_utf16_field(Bin, little) -> <<Val/utf16-little,Rest/bitstring>> = Bin, {Val,Rest}; -get_utf16(Bin, native) -> +get_utf16_field(Bin, native) -> <<Val/utf16-native,Rest/bitstring>> = Bin, {Val,Rest}; -get_utf16(Bin, big) -> +get_utf16_field(Bin, big) -> <<Val/utf16-big,Rest/bitstring>> = Bin, {Val,Rest}. -get_utf32(Bin, little) -> +get_utf32_field(Bin, little) -> <<Val/utf32-little,Rest/bitstring>> = Bin, {Val,Rest}; -get_utf32(Bin, native) -> +get_utf32_field(Bin, native) -> <<Val/utf32-native,Rest/bitstring>> = Bin, {Val,Rest}; -get_utf32(Bin, big) -> +get_utf32_field(Bin, big) -> <<Val/utf32-big,Rest/bitstring>> = Bin, {Val,Rest}. -get_float(Bin, Sz, little) -> +get_float_field(Bin, Sz, little) -> <<Val:Sz/float-little,Rest/binary-unit:1>> = Bin, {Val,Rest}; -get_float(Bin, Sz, native) -> +get_float_field(Bin, Sz, native) -> <<Val:Sz/float-native,Rest/binary-unit:1>> = Bin, {Val,Rest}; -get_float(Bin, Sz, big) -> +get_float_field(Bin, Sz, big) -> <<Val:Sz/float,Rest/binary-unit:1>> = Bin, {Val,Rest}. src/lfe_eval.erl @@ -30,6 +30,7 @@ %% The io functions have been split into the following modules: %% lfe_io - basic read and write functions %% lfe_io_pretty - sexpr prettyprinter +%% lfe_io_format - formatted output -module(lfe_io). @@ -116,7 +117,7 @@ scan_and_parse(Io, Ts0) -> E -> exit(E) end end. - + %% print([IoDevice], Sexpr) -> ok. %% print1(Sexpr) -> [char()]. %% print1(Sexpr, Depth) -> [char()]. @@ -188,7 +189,7 @@ print1_bits(Bits, _) -> %0 < Size < 8 %% Print the tail of a list. We know about dotted pairs. print1_tail([], _) -> ""; -print1_tail(_, 1) -> " ..."; +print1_tail(_, 1) -> " ..."; print1_tail([S|Ss], D) -> [$\s,print1(S, D-1)|print1_tail(Ss, D-1)]; print1_tail(S, D) -> [" . "|print1(S, D-1)]. src/lfe_io.erl @@ -31,14 +31,14 @@ -export([print1/1,print1/2,print1/3,print1/4]). -%% -compile(export_all). +-compile(export_all). --import(lists, [flatlength/1]). +-import(lists, [reverse/1,reverse/2,flatlength/1]). %% print1(Sexpr) -> [char()]. %% print1(Sexpr, Depth) -> [char()]. %% print1(Sexpr, Depth, Indentation, LineLength) -> [char()]. -%% An relatively simple pretty print function, but with some +%% A relatively simple pretty print function, but with some %% customisation. print1(S) -> print1(S, -1, 0, 80). @@ -60,12 +60,11 @@ print1(['unquote-splicing',E], D, I, L) -> [",@",print1(E, D, I+2, L)]; print1([Car|Cdr]=List, D, I, L) -> %% Handle printable lists specially. case io_lib:printable_list(List) of - true -> lfe_io:print1_string(List, 34); %" + true -> lfe_io:print1_string(List, $"); %" false -> - Print = lfe_io:print1(List, D), %Raw printing - case flatlength(Print) of - Len when Len + I < L -> Print; - _ -> + case print1_list_max(List, D, I+2, L) of + {yes,Print} -> ["(",Print,")"]; + no -> %% Customise printing of lists. case indent_type(Car) of none -> @@ -85,12 +84,10 @@ print1([Car|Cdr]=List, D, I, L) -> print1([], _, _, _) -> "()"; print1({}, _, _, _) -> "#()"; print1(Tup, D, I, L) when is_tuple(Tup) -> - Print = lfe_io:print1(Tup, D), - case flatlength(Print) of - Len when Len + I < L -> Print; - _ -> - Es = tuple_to_list(Tup), - ["#(",print1_list(Es, D-1, I+2, L),")"] + Es = tuple_to_list(Tup), + case print1_list_max(Es, D-1, I+3, L) of + {yes,Print} -> ["#(",Print,")"]; + no -> ["#(",print1_list(Es, D-1, I+2, L),")"] end; print1(Bit, _, _, _) when is_bitstring(Bit) -> ["#B(",lfe_io:print1_bits(Bit, 30),$)]; %First 30 bytes @@ -107,18 +104,47 @@ split(N, [H|T]) -> {H1,T1} = split(N-1, T), {[H|H1],T1}. +%% print1_list_max(List, Depth, Indentation, LineLength) -> {yes,Chars} | no. +%% Maybe print a list on one line, but abort if it goes past +%% LineLength. + +print1_list_max(_, 0, _, _) -> {yes,"..."}; +print1_list_max([Car|Cdr], D, I, L) -> + Cs = print1(Car, D, 0, 99999), %Never break the line + print1_tail_max(Cdr, D, I + flatlength(Cs), L, [Cs]); +print1_list_max([], _, _, _) -> {yes,[]}. + +%% print1_tail_max(Tail, Depth, Indentation, LineLength) -> {yes,Chars} | no. +%% Maybe print the tail of a list on one line, but abort if it goes +%% past LineLength. We know about dotted pairs. When we reach depth 0 +%% we just quit as we know necessary "..." will have come from an +%% earlier print1 at same depth. + +print1_tail_max(_, _, I, L, _) when I >= L -> no; %No more room +print1_tail_max(_, 0, _, _, Acc) -> {yes,reverse(Acc)}; +print1_tail_max([], _, _, _, Acc) -> {yes,reverse(Acc)}; +print1_tail_max([Car|Cdr], D, I, L, Acc) -> + Cs = print1(Car, D-1, 0, 99999), %Never break the line + print1_tail_max(Cdr, D-1, I + flatlength(Cs) + 1, L, [Cs," "|Acc]); +print1_tail_max(S, D, I, L, Acc) -> + Cs = print1(S, D-1, 0, 99999), %Never break the line + print1_tail_max([], D, I + flatlength(Cs) + 3, L, [Cs," . "|Acc]). + %% print1_list(List, Depth, Indentation, LineLength) %% Print a list, one element per line. No leading/trailing (). +print1_list(_, 0, _, _) -> "..."; print1_list([Car|Cdr], D, I, L) -> [print1(Car, D, I, L),print1_tail(Cdr, D, I, L)]; print1_list([], _, _, _) -> []. %% print1_tail(Tail, Depth, Indentation, LineLength) -%% Print the tail of a list. We know about dotted pairs. +%% Print the tail of a list. We know about dotted pairs. When we +%% reach depth 0 we just quit as we know necessary "..." will have +%% come from an earlier print1 at same depth. +print1_tail(_, 0, _, _) -> ""; print1_tail([], _, _, _) -> ""; -print1_tail(_, 1, _, _) -> " ..."; print1_tail([Car|Cdr], D, I, L) -> ["\n",blanks(I, []),print1(Car, D-1, I, L),print1_tail(Cdr, D-1, I, L)]; print1_tail(S, D, I, L) -> src/lfe_io_pretty.erl @@ -135,7 +135,7 @@ is_fbound(N, A, [{function,N,A,_,_}|_]) -> true; is_fbound(N, _, [{macro,N,_}|_]) -> false; %Macros shadow is_fbound(N, A, [_|Env]) -> is_fbound(N, A, Env); is_fbound(N, A, []) -> is_bif(N, A). %Known BIF, LFE or erlang - + get_fbinding(N, A, [{function,N,A,V}|_]) -> {yes,V}; get_fbinding(N, A, [{function,N,A,M,F}|_]) -> {yes,M,F}; %Import get_fbinding(N, _, [{macro,N,_}|_]) -> no; %Macros shadow @@ -175,7 +175,7 @@ is_mbound(N, [{function,N,_,_,_}|_]) -> false; %Functions shadow is_mbound(N, [{macro,N,_}|_]) -> true; is_mbound(N, [_|Env]) -> is_mbound(N, Env); is_mbound(_, []) -> false. - + get_mbinding(N, [{function,N,_,_}|_]) -> no; %Functions shadow get_mbinding(N, [{function,N,_,_,_}|_]) -> no; %Functions shadow get_mbinding(N, [{macro,N,V}|_]) -> {yes,V}; @@ -355,8 +355,8 @@ subst(_, _, Tree) -> Tree. _ -> Tree end end. - -eval(Sexpr) -> lfe_eval:eval(Sexpr, new_env()). %Empty environment. + +eval(Sexpr) -> lfe_eval:expr(Sexpr, new_env()). %Empty environment. %% Miscellaneous useful LFE functions. src/lfe_lib.erl @@ -69,6 +69,8 @@ format_error(bad_funcs) -> "bad function list"; format_error(bad_body) -> "bad body"; format_error(bad_clause) -> "bad clause"; format_error(bad_args) -> "bad arguments"; +format_error({bad_attribute,A}) -> + lfe_io:format1("bad attribute: ~w", [A]); format_error({bad_form,Type}) -> lfe_io:format1("bad form: ~w", [Type]); format_error({unbound_symb,S}) -> @@ -159,9 +161,12 @@ check_mdef([[extends,M]|Mdef], L, St) -> true -> check_mdef(Mdef, L, add_error(L, bad_extends, St)) end; -check_mdef([[Name,_]|Mdef], L, St) when is_atom(Name) -> - %% Other attributes. - check_mdef(Mdef, L, St); +check_mdef([[Name|Vals]|Mdef], L, St) -> + %% Other attributes, must be list and have symbol name. + case is_atom(Name) and is_proper_list(Vals) of + true -> check_mdef(Mdef, L, St); + false -> check_mdef(Mdef, L, add_error(L, {bad_attribute,Name}, St)) + end; check_mdef([], _, St) -> St; check_mdef(_, L, St) -> add_error(L, bad_mod_def, St). @@ -403,13 +408,9 @@ check_lambda([Args|Body], Env, L, St0) -> check_lambda(_, _, L, St) -> bad_form_error(L, lambda, St). check_lambda_args(Args, L, St) -> - %% Check for multiple variables - Check = fun (A, {As,S}) -> - case is_element(A, As) of - true -> {As,multi_var_error(L, A, S)}; - false -> {add_element(A, As),S} - end - end, + %% Check for multiple variables but allow don't care variables, + %% same rules as for pattern symbols. + Check = fun (A, {As,S}) -> pat_symb(A, As, L, S) end, case is_symb_list(Args) of true -> foldl(Check, {[],St}, Args); false -> {[],bad_form_error(L, lambda, St)} @@ -606,7 +607,7 @@ check_try_catch([['catch'|Cls],['after'|B]], Env, L, St0) -> check_body(B, Env, L, St1); check_try_catch([['after'|B]], Env, L, St) -> check_body(B, Env, L, St); -check_try_catch(C, _, L, St) -> bad_form_error(L, {'try',C}, St). +check_try_catch(_, _, L, St) -> bad_form_error(L, 'try', St). %% check_pat_guard([Pat{,Guard}|Body, Env, L, State) -> %% {Body,PatVars,Env,State}. src/lfe_lint.erl @@ -293,7 +293,7 @@ def_record(Name, Fdefs, Env, St0) -> [[rec],['is_record',rec,[quote,Name],length(Fields)+1]]], ['defmacro',Match, [fds, - ['let',[[def,[list|lists:duplicate(length(Fields), ?Q('_'))]]], + ['let',[[def,[list|lists:duplicate(length(Fields),?Q('_'))]]], [backquote, [tuple,?Q(Name),['unquote-splicing',[Fu,fds,def]]]]]]], ['defmacro',Set, @@ -569,38 +569,49 @@ exp_macro([Mac|Args], Def0, Env, St0) -> exp_predef([backquote,Bq], _, St) -> {yes,bq_expand(Bq),St}; exp_predef(['++'|Abody], _, St) -> - case Abody of - [E] -> {yes,E,St}; - [E|Es] -> {yes,[call,?Q(erlang),?Q('++'),E,['++'|Es]],St}; - [] -> {yes,[],St} - end; + Exp = case Abody of + [E] -> E; + [E|Es] -> [call,?Q(erlang),?Q('++'),E,['++'|Es]]; + [] -> [] + end, + {yes,Exp,St}; exp_predef([':',M,F|As], _, St) -> {yes,['call',?Q(M),?Q(F)|As], St}; exp_predef(['?'], _, St) -> {yes,['receive',['omega','omega']], St}; +exp_predef(['list*'|As], _, St) -> + Exp = case As of + [E] -> E; + [E|Es] -> [cons,E,['list*'|Es]]; + [] -> [] + end, + {yes,Exp,St}; exp_predef(['let*'|Lbody], _, St) -> - case Lbody of - [[Vb|Vbs]|B] -> {yes,['let',[Vb],['let*',Vbs|B]], St}; - [[]|B] -> {yes,['progn'|B], St}; - [Vb|B] -> {yes,['let',Vb|B], St} %Pass error to let for lint. - end; + Exp = case Lbody of + [[Vb|Vbs]|B] -> ['let',[Vb],['let*',Vbs|B]]; + [[]|B] -> ['progn'|B]; + [Vb|B] -> ['let',Vb|B] %Pass error to let for lint. + end, + {yes,Exp,St}; exp_predef(['flet*'|Lbody], _, St) -> - case Lbody of - [[Vb|Vbs]|B] -> {yes,['flet',[Vb],['flet*',Vbs|B]], St}; - [[]|B] -> {yes,['progn'|B], St}; - [Vb|B] -> {yes,['flet',Vb|B], St} %Pass error to flet for lint. - end; + Exp = case Lbody of + [[Vb|Vbs]|B] -> ['flet',[Vb],['flet*',Vbs|B]]; + [[]|B] -> ['progn'|B]; + [Vb|B] -> ['flet',Vb|B] %Pass error to flet for lint. + end, + {yes,Exp,St}; exp_predef(['cond'|Cbody], _, St) -> - case Cbody of - [['else'|B]] -> {yes,['progn'|B], St}; - [[['?=',P,E]|B]|Cond] -> - {yes,['case',E,[P|B],['_',['cond'|Cond]]], St}; - [[['?=',P,['when',_]=G,E]|B]|Cond] -> - {yes,['case',E,[P,G|B],['_',['cond'|Cond]]], St}; - [[Test|B]|Cond] -> - {yes,['if',Test,['progn'|B],['cond'|Cond]], St}; - [] -> {yes,?Q(false),St} - end; + Exp = case Cbody of + [['else'|B]] -> ['progn'|B]; + [[['?=',P,E]|B]|Cond] -> + ['case',E,[P|B],['_',['cond'|Cond]]]; + [[['?=',P,['when',_]=G,E]|B]|Cond] -> + ['case',E,[P,G|B],['_',['cond'|Cond]]]; + [[Test|B]|Cond] -> + ['if',Test,['progn'|B],['cond'|Cond]]; + [] -> ?Q(false) + end, + {yes,Exp,St}; exp_predef(['do'|Dbody], _, St0) -> %% (do ((v i c) ...) (test val) . body) but of limited use as it %% stands as we have to everything in new values. @@ -625,21 +636,21 @@ exp_predef([bc|Bbody], _, St0) -> {Exp,St1} = bc_te(E, Qs, St0), {yes,Exp,St1}; exp_predef(['andalso'|Abody], _, St) -> - case Abody of - [E] -> {yes,E,St}; - [E|Es] -> - Exp = ['case',E,[?Q(true),['andalso'|Es]],[?Q(false),?Q(false)]], - {yes,Exp,St}; - [] -> {yes,?Q(true),St} - end; + Exp = case Abody of + [E] -> E; %Let user check last call + [E|Es] -> + ['case',E,[?Q(true),['andalso'|Es]],[?Q(false),?Q(false)]]; + [] -> ?Q(true) + end, + {yes,Exp,St}; exp_predef(['orelse'|Obody], _, St) -> - case Obody of - [E] -> {yes,E,St}; %Let user check last call - [E|Es] -> - Exp = ['case',E,[?Q(true),?Q(true)],[?Q(false),['orelse'|Es]]], - {yes,Exp,St}; - [] -> {yes,?Q(false),St} - end; + Exp = case Obody of + [E] -> E; %Let user check last call + [E|Es] -> + ['case',E,[?Q(true),?Q(true)],[?Q(false),['orelse'|Es]]]; + [] -> ?Q(false) + end, + {yes,Exp,St}; exp_predef(['fun',F,Ar], _, St0) when is_atom(F), is_integer(Ar), Ar >= 0 -> {Vs,St1} = new_symbs(Ar, St0), {yes,['lambda',Vs,[F|Vs]],St1}; @@ -659,13 +670,14 @@ exp_predef(['include-file'|Ibody], _, St) -> exp_predef(['begin'|Body], _, St) -> {yes,['progn'|Body],St}; exp_predef(['define',Head|Body], _, St) -> - case is_symb_list(Head) of - true -> - {yes,['define-function',hd(Head),[lambda,tl(Head)|Body]],St}; - false -> - %% Let next step catch errors here. - {yes,['define-function',Head|Body],St} - end; + Exp = case is_symb_list(Head) of + true -> + ['define-function',hd(Head),[lambda,tl(Head)|Body]]; + false -> + %% Let next step catch errors here. + ['define-function',Head|Body] + end, + {yes,Exp,St}; exp_predef(['define-record'|Def], _, St) -> {yes,[defrecord|Def],St}; exp_predef(['define-syntax',Name,Def], _, St) -> @@ -724,11 +736,11 @@ expand_defun(Name, [Args|Rest]) -> %% N.B. New macro definition is function of 1 argument, whole %% argument list of macro call. -expand_defmacro(Name, [Args|Rest]) -> +expand_defmacro(Name, [Args|Rest]=Cls) -> case is_symb_list(Args) of true -> [Name,['match-lambda',[[Args]|Rest]]]; false -> - Mcls = map(fun ([Head|Body]) -> [[Head]|Body] end, [Args|Rest]), + Mcls = map(fun ([Head|Body]) -> [[Head]|Body] end, Cls), [Name,['match-lambda'|Mcls]] end. src/lfe_macro.erl @@ -84,7 +84,7 @@ sexpr1([{'#B(',_}|Ts0]) -> case proper_list(Ts0) of {List,[{')',_}|Ts1]} -> %% Build and eval a binary sexpr. - case catch lfe_eval:eval([binary|List]) of + case catch lfe_eval:expr([binary|List]) of Bin when is_bitstring(Bin) -> {Bin,Ts1}; _ -> throw({error,{illegal,binary},Ts1}) end; src/lfe_parse.erl @@ -136,9 +136,17 @@ collect_imps(Is, St) -> S#param{env=Env} end, St, Is). +%% exp_function(Lambda, State) -> Lambda. +%% The resultant code matches the arguments in two steps: first the +%% THIS arguemnt is matched and then the expanded function body +%% ((match-)lambda) is funcalled. We KNOW that funcall of a +%% (match-)lambda is inline expanded into a let or case so this is +%% efficient. + exp_function(Lambda, #param{this=Th,env=Env}) -> As = new_args(lambda_arity(Lambda)), ['match-lambda',[As ++ [Th],[funcall,exp_expr(Lambda, Env)|As]]]. + %% exp_function(['match-lambda'|Cls0], #param{this=Th,env=Env}) -> %% Cls1 = map(fun ([As|Body]) -> %% exp_clause([As ++ [Th]|Body], Env) src/lfe_pmod.erl @@ -32,7 +32,7 @@ -export([start/0,start/1,server/0,server/1]). -import(lfe_lib, [new_env/0,add_env/2, - add_vbinding/3,add_vbindings/2,get_vbinding/2, + add_vbinding/3,add_vbindings/2,is_vbound/2,get_vbinding/2, fetch_vbinding/2,update_vbinding/3, add_fbinding/4,add_fbindings/3,get_fbinding/3,add_ibinding/5, get_gbinding/3,add_mbinding/3]). @@ -67,8 +67,9 @@ server_loop(Env0, BaseEnv) -> Env1 = update_vbinding('-', Form, Env0), %% Macro expand and evaluate it. {Value,Env2} = eval_form(Form, Env1, BaseEnv), - %% Print the result. - lfe_io:prettyprint(Value), io:nl(), + %% Print the result, but only to depth 30. + VS = lfe_io:prettyprint1(Value, 30), + io:requests([{put_chars,VS},nl]), %% Update bindings. Env3 = update_shell_vars(Form, Value, Env2), %% lfe_io:prettyprint({Env1,Env2}), io:nl(), @@ -105,7 +106,7 @@ update_shell_vars(Form, Value, Env) -> {'+',Form}, {'***',fetch_vbinding('**', Env)}, {'**',fetch_vbinding('*', Env)}, - {'*',Value}]). + {'*',Value}]). add_shell_macros(Env0) -> %% We write macros in LFE and expand them with macro package. @@ -125,7 +126,7 @@ eval_form(Form, Env0, Benv) -> {yes,Value,Env1} -> {Value,Env1}; no -> %% Normal evaluation of form. - {lfe_eval:eval(Eform, Env0),Env0} + {lfe_eval:expr(Eform, Env0),Env0} end. %% eval_internal(Form, EvalEnv, BaseEnv) -> {yes,Value,Env} | no. @@ -150,6 +151,8 @@ eval_internal(['macroexpand-1',S], Eenv, Benv) -> macroexpand_1(S, Eenv, Benv); eval_internal(['macroexpand-all',S], Eenv, Benv) -> macroexpand_all(S, Eenv, Benv); +eval_internal([set|Args], Eenv, Benv) -> %Set variables in shell + set(Args, Eenv, Benv); eval_internal(_, _, _) -> no. %Not an internal function %% c(Args, EvalEnv, BaseEnv) -> {yes,Res,Env}. @@ -157,8 +160,8 @@ eval_internal(_, _, _) -> no. %Not an internal function c([F], Eenv, Benv) -> c([F,[]], Eenv, Benv); c([F,Os], Eenv, _) -> - Name = lfe_eval:eval(F, Eenv), %Evaluate arguments - Opts = lfe_eval:eval(Os, Eenv), + Name = lfe_eval:expr(F, Eenv), %Evaluate arguments + Opts = lfe_eval:expr(Os, Eenv), Loadm = fun (Mod) -> Base = filename:basename(Name, ".lfe"), code:purge(Mod), @@ -177,8 +180,8 @@ c(_, _, _) -> no. %Unknown function, ec([F], Eenv, Benv) -> ec([F,[]], Eenv, Benv); ec([F,Os], Eenv, _) -> - Name = lfe_eval:eval(F, Eenv), %Evaluate arguments - Opts = lfe_eval:eval(Os, Eenv), + Name = lfe_eval:expr(F, Eenv), %Evaluate arguments + Opts = lfe_eval:expr(Os, Eenv), {yes,c:c(Name, Opts),Eenv}; ec(_, _, _) -> no. %Unknown function @@ -186,14 +189,14 @@ ec(_, _, _) -> no. %Unknown function %% Load the modules in Args. l(Args, Eenv, _) -> - {yes,map(fun (M) -> c:l(lfe_eval:eval(M, Eenv)) end, Args), Eenv}. + {yes,map(fun (M) -> c:l(lfe_eval:expr(M, Eenv)) end, Args), Eenv}. %% m(Args, EvalEnv, BaseEnv) -> {yes,Res,Env}. %% Module info. m([], Eenv, _) -> {yes,c:m(),Eenv}; m(Args, Eenv, _) -> - {yes,map(fun (M) -> c:m(lfe_eval:eval(M, Eenv)) end, Args), Eenv}. + {yes,map(fun (M) -> c:m(lfe_eval:expr(M, Eenv)) end, Args), Eenv}. %% macroexpand(Sexpr, EvalEnv, BaseEnv) -> {yes,Res,Env}. %% macroexpand_1(Sexpr, EvalEnv, BaseEnv) -> {yes,Res,Env}. @@ -201,30 +204,44 @@ m(Args, Eenv, _) -> %% We special case these at shell level so as to get shell environment. macroexpand(S, Eenv, _) -> - case lfe_macro:expand_macro(lfe_eval:eval(S, Eenv), Eenv) of + case lfe_macro:expand_macro(lfe_eval:expr(S, Eenv), Eenv) of {yes,Exp} -> {yes,Exp,Eenv}; no -> {yes,S,Eenv} end. macroexpand_1(S, Eenv, _) -> - case lfe_macro:expand_macro_1(lfe_eval:eval(S, Eenv), Eenv) of + case lfe_macro:expand_macro_1(lfe_eval:expr(S, Eenv), Eenv) of {yes,Exp} -> {yes,Exp,Eenv}; no -> {yes,S,Eenv} end. macroexpand_all(S, Eenv, _) -> - Exp = lfe_macro:expand_form(lfe_eval:eval(S, Eenv), Eenv), + Exp = lfe_macro:expand_form(lfe_eval:expr(S, Eenv), Eenv), {yes,Exp,Eenv}. -%% slurp(File, EvalEnv, BaseEnv) -> {yes,{mod,Mod},Env}. +%% set(Args, EvalEnv, BaseEnv) -> {yes,Result,Env} | no. + +set([Pat,Exp], Eenv, _) -> + Val = lfe_eval:expr(Exp, Eenv), %Evaluate expression + case lfe_eval:match(Pat, Val, Eenv) of + {yes,Bs} -> + Env1 = foldl(fun ({N,V}, E) -> add_upd_vbinding(N, V, E) end, + Eenv, Bs), + {yes,Val,Env1}; + no -> erlang:error({badmatch,Val}) + end; +%% set([Pat,['when',G],Exp], Eenv, _) -> +set(_, _, _) -> no. + +%% slurp(File, EvalEnv, BaseEnv) -> {yes,{mod,Mod},Env} | no. %% Load in a file making all functions available. The module is %% loaded in an empty environment and that environment is finally %% added to the standard base environment. -record(slurp, {mod,imps=[]}). %For slurping - + slurp([File], Eenv, Benv) -> - Name = lfe_eval:eval(File, Eenv), %Get file name + Name = lfe_eval:expr(File, Eenv), %Get file name {ok,Fs0} = lfe_io:parse_file(Name), St0 = #slurp{mod='-no-mod-',imps=[]}, {Fs1,Fenv0} = lfe_macro:macro_forms(Fs0, new_env()), @@ -237,7 +254,8 @@ slurp([File], Eenv, Benv) -> end, Fenv0, St1#slurp.imps), %% Get a new environment with all functions defined. Fenv2 = lfe_eval:make_letrec_env(Fbs, Fenv1), - {yes,{ok,St1#slurp.mod},add_env(Fenv2, Benv)}. + {yes,{ok,St1#slurp.mod},add_env(Fenv2, Benv)}; +slurp(_, _, _) -> no. collect_form(['define-module',Mod|Mdef], _, St0) when is_atom(Mod) -> St1 = collect_mdef(Mdef, St0), @@ -276,6 +294,14 @@ collect_imp(Fun, Mod, St, Fs) -> Imps1 = foldl(Fun, Imps0, Fs), St#slurp{imps=store(Mod, Imps1, St#slurp.imps)}. +%% add_upd_vbinding(Name, Val, Env) -> Env. + +add_upd_vbinding(N, V, Env) -> + case is_vbound(N, Env) of + true -> update_vbinding(N, V, Env); + false -> add_vbinding(N, V, Env) + end. + %% safe_fetch(Key, Dict, Default) -> Value. safe_fetch(Key, D, Def) -> @@ -283,7 +309,7 @@ safe_fetch(Key, D, Def) -> {ok,Val} -> Val; error -> Def end. - + %% (defsyntax safe_fetch %% ((key d def) %% (case (find key d) src/lfe_shell.erl test/test_bin.erl 02bb0888be1b5f5a0ae3fcd4db2b244fb4379878 2c2bac32e75027192b9c4d043b27fa259ca7cbbd Robert Virding rvirding@gmail.com http://github.com/rvirding/lfe/commit/dc6b0b74b21a0c0bf3f5ed246b33e2fca3be0975 dc6b0b74b21a0c0bf3f5ed246b33e2fca3be0975 2009-10-18T17:11:08-07:00 2009-10-18T17:10:43-07:00 Merge branch 'develop'. This is v0.5. 34345baaeab6e4be0bfb5823b5754887f3b824b2 Robert Virding rvirding@gmail.com