Projects
Kolab:Winterfell
erlang-lfe
Log In
Username
Password
Overview
Repositories
Revisions
Requests
Users
Attributes
Meta
Expand all
Collapse all
Changes of Revision 2
View file
erlang-lfe.spec
Changed
@@ -1,30 +1,24 @@ %global realname lfe %global upstream rvirding -%global git_tag 0b728d4 -%global debug_package %{nil} Name: erlang-%{realname} -Version: 0.9.2 -Release: 1%{?dist} +Version: 1.0 +Release: 2%{?dist} Summary: Lisp Flavoured Erlang Group: Development/Languages License: BSD -URL: http://github.com/rvirding/lfe +URL: https://github.com/%{upstream}/%{realname} %if 0%{?el7}%{?fedora} -VCS: scm:git:https://github.com/rvirding/lfe.git +VCS: scm:git:https://github.com/%{upstream}/%{realname}.git %endif -Source0: https://github.com/rvirding/lfe/archive/v%{version}/%{realname}-%{version}.tar.gz -BuildRequires: erlang-rebar +Source0: https://github.com/%{upstream}/%{realname}/archive/%{version}/%{realname}-%{version}.tar.gz + +BuildRequires: erlang-rebar >= 2.6.1 BuildRequires: pkgconfig BuildRequires: emacs BuildRequires: emacs-el - -Requires: erlang-compiler%{?_isa} -Requires: erlang-erts%{?_isa} -Requires: erlang-kernel%{?_isa} -# Error:erlang(unicode:characters_to_list/1) in R12B and earlier -Requires: erlang-stdlib%{?_isa} >= R13B +%{?__erlang_drv_version:Requires: %{__erlang_drv_version}} %description @@ -59,48 +53,81 @@ %prep %setup -q -n %{realname}-%{version} + iconv -f iso-8859-1 -t UTF-8 examples/core-macros.lfe > examples/core-macros.lfe.utf8 mv -f examples/core-macros.lfe.utf8 examples/core-macros.lfe %build -rebar compile -v -emacs -batch -f batch-byte-compile emacs/lfe-mode.el +ERL_LIBS=. %{rebar_compile} +emacs -L emacs/ -batch -f batch-byte-compile emacs/inferior-lfe.el emacs/lfe-mode.el emacs/lfe-indent.el %install -install -p -m 0644 -D ebin/%{realname}.app %{buildroot}%{_libdir}/erlang/lib/%{realname}-%{version}/ebin/%{realname}.app -install -p -m 0644 ebin/%{realname}_*.beam %{buildroot}%{_libdir}/erlang/lib/%{realname}-%{version}/ebin +install -m 0755 -d %{buildroot}%{_libdir}/erlang/lib/%{realname}-%{version}/{bin,ebin,priv} +install -p -m 0755 -D ebin/* %{buildroot}%{_libdir}/erlang/lib/%{realname}-%{version}/ebin/ +install -p -m 0755 -D bin/* %{buildroot}%{_libdir}/erlang/lib/%{realname}-%{version}/bin/ +install -p -m 0755 priv/%{realname}_drv.so %{buildroot}%{_libdir}/erlang/lib/%{realname}-%{version}/priv/ +install -m 0755 -d %{buildroot}/%{_bindir} +ln -s %{_libdir}/erlang/lib/%{realname}-%{version}/bin/{lfe,lfec,lfescript} %{buildroot}%{_bindir}/ + mkdir -p %{buildroot}%{_emacs_sitelispdir} mkdir -p %{buildroot}%{_emacs_sitestartdir} +install -p -m 0644 emacs/inferior-lfe.el %{buildroot}%{_emacs_sitelispdir} +install -p -m 0644 emacs/inferior-lfe.elc %{buildroot}%{_emacs_sitelispdir} install -p -m 0644 emacs/lfe-mode.el %{buildroot}%{_emacs_sitelispdir} install -p -m 0644 emacs/lfe-mode.elc %{buildroot}%{_emacs_sitelispdir} +install -p -m 0644 emacs/lfe-indent.el %{buildroot}%{_emacs_sitelispdir} +install -p -m 0644 emacs/lfe-indent.elc %{buildroot}%{_emacs_sitelispdir} install -p -m 0644 emacs/lfe-start.el %{buildroot}%{_emacs_sitestartdir} %check -rm -rf test/visual/test_map_e.erl -rebar skip_deps=true eunit -v +rebar eunit -vv %files -%doc LICENSE README.md doc/ examples/ -%dir %{_libdir}/erlang/lib/%{realname}-%{version} -%dir %{_libdir}/erlang/lib/%{realname}-%{version}/ebin -%{_libdir}/erlang/lib/%{realname}-%{version}/ebin/%{realname}.app -%{_libdir}/erlang/lib/%{realname}-%{version}/ebin/%{realname}_*.beam +%if 0%{?fedora} +%license LICENSE +%else +%doc LICENSE +%endif +%doc README.md doc/ examples/ +%{_bindir}/lfe +%{_bindir}/lfec +%{_bindir}/lfescript +%{_erllibdir}/%{realname}-%{version} %files -n emacs-erlang-lfe %{_emacs_sitestartdir}/lfe-start.el +%{_emacs_sitelispdir}/inferior-lfe.elc %{_emacs_sitelispdir}/lfe-mode.elc +%{_emacs_sitelispdir}/lfe-indent.elc %files -n emacs-erlang-lfe-el +%{_emacs_sitelispdir}/inferior-lfe.el %{_emacs_sitelispdir}/lfe-mode.el +%{_emacs_sitelispdir}/lfe-indent.el %changelog +* Thu Mar 17 2016 Jeroen van Meeuwen <vanmeeuwen@kolabsys.com> - 1.0-1 +- Version 1.0 + +* Tue Mar 1 2016 Peter Lemenkov <lemenkov@gmail.com> - 0.10.1-2 +- Install CLI tools as well + +* Tue Mar 1 2016 Peter Lemenkov <lemenkov@gmail.com> - 0.10.1-1 +- Ver. 0.10.1 + +* Wed Feb 03 2016 Fedora Release Engineering <releng@fedoraproject.org> - 0.9.0-4 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_24_Mass_Rebuild + +* Wed Jun 17 2015 Fedora Release Engineering <rel-eng@lists.fedoraproject.org> - 0.9.0-3 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_23_Mass_Rebuild + * Sun Nov 16 2014 Peter Lemenkov <lemenkov@gmail.com> - 0.9.0-2 - Disable debuginfo
View file
lfe-0.9.2.tar.gz/package.exs
Deleted
@@ -1,7 +0,0 @@ -Expm.Package.new(name: "lfe", - description: "Lisp Flavored Erlang", - version: "0.10.0-dev", - keywords: ["LFE", "Lisp", "Languages", "BEAM", "Erlang VM"], - maintainers: [[name: "Robert Virding", - email: "rvirding@gmail.com"]], - repositories: [[github: "rvirding/lfe"]])
View file
lfe-0.9.2.tar.gz/.gitignore -> lfe-1.0.tar.gz/.gitignore
Changed
@@ -2,9 +2,14 @@ .DS_Store *.beam maps.mk -bin/lfeexec -src/lfe_scan.erl erl_crash.dump *.elc *.o -*.rebar +/_build/ +/c_src/*.d +/priv/ +/src/lfe_scan.erl +.rebar/* +bin/lfeexec +maps_opts.mk +ebin/*
View file
lfe-0.9.2.tar.gz/.travis.yml -> lfe-1.0.tar.gz/.travis.yml
Changed
@@ -1,10 +1,13 @@ language: erlang +before_install: echo "#!/usr/bin/env bash" > `which rebar` +script: make travis notifications: disabled: true otp_release: - - R15B02 - - R15B01 - - R15B + - 18.2 + - 18.0 + - 17.5 + - 17.1 + - R16B03 + - R15B03 - R14B04 - - R14B03 - - R14B02
View file
lfe-0.9.2.tar.gz/Dockerfile -> lfe-1.0.tar.gz/Dockerfile
Changed
@@ -1,21 +1,32 @@ # Base image # -# VERSION 0.1 -FROM debian:jessie +# VERSION 0.2 +FROM debian:latest MAINTAINER LFE Maintainers <maintainers@lfe.io> +ENV DEBIAN_FRONTEND noninteractive RUN apt-get update && apt-get install -y --no-install-recommends \ apt-utils \ build-essential \ - erlang \ ca-certificates \ libcurl4-openssl-dev \ curl \ + wget \ git +ENV ERLANG_DEB1 erlang-solutions_1.0_all.deb +ENV ERLANG_DEB2 esl-erlang_18.1-1~debian~jessie_amd64.deb +ENV ERLANG_HOST https://packages.erlang-solutions.com +ENV ERLANG_PATH erlang/esl-erlang/FLAVOUR_1_general +RUN curl -L -O $ERLANG_HOST/$ERLANG_DEB1 +RUN dpkg -i $ERLANG_DEB1 && rm $ERLANG_DEB1 +RUN apt-get update +RUN curl -L -O $ERLANG_HOST/$ERLANG_PATH/$ERLANG_DEB2 +RUN dpkg -i --force-depends $ERLANG_DEB2 && rm $ERLANG_DEB2 + ENV REBAR_REPO https://github.com/rebar/rebar.git RUN git clone $REBAR_REPO && cd rebar && \ - git checkout tags/2.5.1 && \ + git checkout tags/2.6.0 && \ ./bootstrap && \ cp rebar /usr/local/bin @@ -23,4 +34,5 @@ RUN cd /opt/erlang/lfe && make install ENV ERL_LIBS=$ERL_LIBS:/opt/erlang/lfe -CMD /usr/bin/lfe -eval "(io:format \"~p~n\" (list (* 2 (lists:foldl (lambda (n acc) (+ n acc)) 0 (lists:seq 1 6)))))" +ENV DEBIAN_FRONTEND "" +CMD /usr/bin/lfe -eval "(io:format \"~p~n\" (list (* 2 (lists:foldl #'+/2 0 (lists:seq 1 6)))))"
View file
lfe-0.9.2.tar.gz/Makefile -> lfe-1.0.tar.gz/Makefile
Changed
@@ -1,11 +1,10 @@ # Makefile for LFE -# This simple Makefile uses rebar (in Unix) or rebar.cmd (in Windows) -# to compile/clean if it exists, else does it explicitly. BINDIR = bin EBINDIR = ebin SRCDIR = src CSRCDIR = c_src +LSRCDIR = src INCDIR = include DOCDIR = doc EMACSDIR = emacs @@ -15,17 +14,16 @@ ERLCFLAGS = -W1 ERLC = erlc -EXPM=$(BINDIR)/expm +LFECFLAGS = -pa ../lfe +LFEC = $(BINDIR)/lfe $(BINDIR)/lfec +APP_SRC = lfe.app + LIB=lfe # To run erl as bash FINISH=-run init stop -noshell # Scripts to be evaluated -MAPS_MK = 'Has=erl_internal:bif(is_map,1), \ - HasMaps=if Has -> "-DHAS_MAPS=true\n" ; true -> "\n" end, \ - file:write_file("maps.mk", "HAS_MAPS = " ++ HasMaps)' \ - $(FINISH) GET_VERSION = '{ok,[App]}=file:consult("src/$(LIB).app.src"), \ V=proplists:get_value(vsn,element(3,App)), \ @@ -37,11 +35,16 @@ ESRCS = $(notdir $(wildcard $(SRCDIR)/*.erl)) XSRCS = $(notdir $(wildcard $(SRCDIR)/*.xrl)) YSRCS = $(notdir $(wildcard $(SRCDIR)/*.yrl)) +LSRCS = $(notdir $(wildcard $(LSRCDIR)/*.lfe)) EBINS = $(ESRCS:.erl=.beam) $(XSRCS:.xrl=.beam) $(YSRCS:.yrl=.beam) +LBINS = $(LSRCS:.lfe=.beam) CSRCS = $(notdir $(wildcard $(CSRCDIR)/*.c)) BINS = $(CSRCS:.c=) +EMACSRCS = $(notdir $(wildcard $(EMACSDIR)/*.el)) +ELCS = $(EMACSRCS:.el=.elc) + ## Where we install links to the LFE binaries. DESTBINDIR = $(PREFIX)$(shell dirname `which erl` 2> /dev/null || echo "/usr/local/bin" ) @@ -51,7 +54,8 @@ cc -o $@ $< $(EBINDIR)/%.beam: $(SRCDIR)/%.erl - $(ERLC) -I $(INCDIR) -o $(EBINDIR) $(HAS_MAPS) $(ERLCFLAGS) $< + @mkdir -p $(EBINDIR) + $(ERLC) -I $(INCDIR) -o $(EBINDIR) $(MAPS_OPTS) $(ERLCFLAGS) $< %.erl: %.xrl $(ERLC) -o $(SRCDIR) $< @@ -59,43 +63,45 @@ %.erl: %.yrl $(ERLC) -o $(SRCDIR) $< +$(EBINDIR)/%.beam: $(LSRCDIR)/%.lfe + $(LFEC) -I $(INCDIR) -o $(EBINDIR) $(LFECFLAGS) $< + all: compile docs -.PHONY: compile erlc_compile install docs clean +.PHONY: compile erlc-compile lfec-compile erlc-lfec emacs install docs clean docker-build docker-push docker -## Compile using rebar if it exists else using make -compile: maps.mk - if which rebar.cmd > /dev/null; \ - then rebar.cmd compile; \ - elif which rebar > /dev/null; \ - then rebar compile; \ - else $(MAKE) $(MFLAGS) erlc_compile; \ - fi +compile: maps_opts.mk + $(MAKE) $(MFLAGS) erlc-lfec ## Compile using erlc -erlc_compile: $(addprefix $(EBINDIR)/, $(EBINS)) $(addprefix $(BINDIR)/, $(BINS)) +erlc-compile: $(addprefix $(EBINDIR)/, $(EBINS)) $(addprefix $(BINDIR)/, $(BINS)) + +## Compile using lfec +lfec-compile: $(addprefix $(EBINDIR)/, $(LBINS)) -maps.mk: - erl -eval $(MAPS_MK) +$(APP_SRC): + cp src/$(APP_SRC).src $(EBINDIR)/$(APP_SRC) --include maps.mk +erlc-lfec: erlc-compile lfec-compile $(APP_SRC) + +emacs: + cd $(EMACSDIR) ; \ + emacs -L . -batch -f batch-byte-compile inferior-lfe.el lfe-mode.el lfe-indent.el + +maps_opts.mk: + escript get_maps_opts.escript + +-include maps_opts.mk install: - ln -s `pwd`/bin/lfe $(DESTBINDIR) - ln -s `pwd`/bin/lfec $(DESTBINDIR) - ln -s `pwd`/bin/lfescript $(DESTBINDIR) + ln -sf `pwd`/bin/lfe $(DESTBINDIR) + ln -sf `pwd`/bin/lfec $(DESTBINDIR) + ln -sf `pwd`/bin/lfescript $(DESTBINDIR) docs: clean: - if which rebar.cmd > /dev/null; \ - then rebar.cmd clean; \ - elif which rebar > /dev/null; \ - then rebar clean; \ - else rm -rf $(EBINDIR)/*.beam; \ - fi - rm maps.mk - rm -rf erl_crash.dump + rm -rf $(EBINDIR)/*.beam erl_crash.dump maps_opts.mk echo: @ echo $(ESRCS) @@ -103,28 +109,31 @@ @ echo $(YSRCS) @ echo $(EBINS) -$(EXPM): $(BINDIR) - curl -o $(EXPM) http://expm.co/__download__/expm - chmod +x $(EXPM) - -get-deps: $(EXPM) - if which rebar.cmd > /dev/null; \ - then rebar.cmd get-deps; \ - elif which rebar > /dev/null; \ - then rebar get-deps; \ - fi - get-version: @echo @echo "Getting version info ..." @echo @echo -n app.src: '' @erl -eval $(GET_VERSION) - @echo -n package.exs: '' - @grep version package.exs | awk '{print $$2}'| sed -e 's/,//g' -upload: get-deps get-version - @echo - @echo "Continue with upload? " - @read - $(EXPM) publish +# Target to regenerate the src/lfe_parse.erl file from its original +# src/lfe_parse.spell1 definition. You will need to have spell1 +# installed somewhere in your $ERL_LIBS path. +regenerate-parser: + erl -noshell -eval 'spell1:file("src/lfe_parse", [report,verbose,{outdir,"./src/"},{includefile,code:lib_dir(spell1,include) ++ "/spell1inc.hrl"}]), init:stop().' + +docker-build: + docker build -t lfex/lfe:latest . + +docker-run: + docker run -i -t lfex/lfe:latest lfe + +docker-push: + docker push lfex/lfe:latest + +docker: docker-build docker-push + +travis: + @echo "Building for Travis CI ..." + @make +
View file
lfe-0.9.2.tar.gz/README.md -> lfe-1.0.tar.gz/README.md
Changed
@@ -5,15 +5,9 @@ code. An LFE evaluator and shell is also included. -## Installation - -LFE can be installed in different ways depending on how it is intended -to be used: +## Building -* use [lfetool](https://github.com/lfe/lfetool) to create projects (which will - automatically have LFE as a dependency when it creates skeleton libraries, - OTP apps, etc.; or -* use LFE directly in a working dir, e.g.: +To compile LFE, simple clone it and compile: ```shell $ git clone https://github.com/rvirding/lfe.git @@ -21,9 +15,14 @@ $ make compile ``` -The second alternative compiles all the files. After this has been -done programs for starting the REPL and compiling LFE files can be -installed with: +LFE requires Erlang be installed on the system and that the ``erl`` binary is +in ``$PATH``. + + +## Installation + +Should you wish to have LFE available system-wide, you can run +the following ``make`` target: ```shell $ make install @@ -42,23 +41,18 @@ ## REPL -If you have used ``lfetool`` to set up your project, you can simply do this to -start a REPL: +If you're running LFE from a git clone working dir, you can start the REPL +like so after compiling: ```shell - $ make shell + $ ./bin/lfe Erlang 17 (erts-6.0) [source] [64-bit] [smp:8:8] ... - LFE Shell 6.0 (abort with ^G) + LFE Shell V6.0 (abort with ^G) > ``` -Note that this will recompile all the deps (often useful for projects with -changing dependencies). If you would prefer to only recompile code for the -project itself, you can use ``make shell-no-deps`` instead. - -If you're running LFE from a git clone working dir, you can start the REPL -like so: +If you have installed LFE, then you may start the REPL from any location: ```shell $ lfe @@ -68,7 +62,14 @@ > ``` -and run an LFE shell script in the same style as shell scripts with: +Likewise, you may run an LFE shell script in the same style as shell scripts +with: + +```shell + $ ./bin/lfe script-name script-arg-1 ... +``` + +or ```shell $ lfe script-name script-arg-1 ... @@ -84,7 +85,7 @@ ```cl > (* 2 (+ 1 2 3 4 5 6)) 42 - > (* 2 (lists:foldl (lambda (n acc) (+ n acc)) 0 (lists:seq 1 6))) + > (* 2 (lists:foldl #'+/2 0 (lists:seq 1 6))) 42 ``` @@ -109,7 +110,12 @@ ```bash $ docker run lfex/lfe 42 -$ docker run -t -i lfex/lfe /usr/bin/lfe + +$ docker run -i -t lfex/lfe lfe +Erlang/OTP 18 [erts-7.0] [source-4d83b58] [64-bit] [smp:8:8] ... + +LFE Shell V7.0 (abort with ^G) +> ``` That last command will dump you into the LFE REPL on a running container
View file
lfe-0.9.2.tar.gz/VERSION -> lfe-1.0.tar.gz/VERSION
Changed
@@ -1,1 +1,1 @@ -0.9.2 +1.0
View file
lfe-0.9.2.tar.gz/bin/lfe -> lfe-1.0.tar.gz/bin/lfe
Changed
@@ -20,14 +20,24 @@ cd "$(dirname "$1")" > /dev/null filename="$(basename "$1")" if [ -h "$filename" ]; then - follow_symlink "$(readlink "$filename")" + follow_symlink "$(readlink "$filename")" else - echo "`pwd -P`/$filename" + echo "$(pwd -P)/$filename" fi } +show_help () { + echo "Usage: `basename $0` [flags] file [args] + + -h | --help Print this help and exit + -e | -eval \"sexp\" Evaluates the given sexpr + -- | -extra \"switches\" Send misc configuration switches to the Erlang VM + -flag | +flag Enables/disables configuration flags to be + used by the Erlang VM" >&2 +} + SELF=$(follow_symlink "$0") -LFE_PROGNAME=`echo $0 | sed 's/.*\///'` # Basically basename +LFE_PROGNAME=$(echo "$0" | sed 's/.*\///') # Basically basename LFE_BINDIR=$(dirname "$SELF") LFE_ROOTDIR=$(dirname "$LFE_BINDIR") @@ -35,57 +45,91 @@ export LFE_BINDIR export LFE_PROGNAME -i="$#" # Counter -e="" # Eval flag/value +i="$#" # Counter +e="" # Eval flag/value # First step over the flag section adding them to the end. -while [ $i -gt 0 ]; do +while [ "$i" -gt 0 ]; do case "$1" in - -eval | -lfe_eval) # We are going to eval - e="-lfe_eval" - break ;; # delay removing this - -extra | --) # We are explicitly done - shift ; i=`expr $i - 1` - break ;; - -* | +*) # Flags - if [ "$1" = "-erl_eval" ]; then - set -- "$@" "-eval" - else - set -- "$@" "$1" - fi - shift ; i=`expr $i - 1` - while [ $i -gt 0 ]; do - case "$1" in - -* | +*) - break ;; - *) - set -- "$@" "$1" - shift ; i=`expr $i - 1` - esac - done ;; - *) # Plain argument - break ;; + -e | -eval) # We are going to eval + e="-lfe_eval" + break ;; # delay removing this + -h | --help) + $(show_help) # Show help + exit 1 ;; + -extra | --) # We are explicitly done + shift ; i=`expr $i - 1` + break ;; + -* | +*) # Flags + if [ "$1" = "-erl_eval" ]; then + set -- "$@" "-eval" + else + set -- "$@" "$1" + fi + + shift ; i=`expr $i - 1` + + while [ "$i" -gt 0 ]; do + case "$1" in + -* | +*) + break ;; + *) + set -- "$@" "$1" + shift ; i=`expr $i - 1` + esac + done ;; + *) # Plain argument + break ;; esac done # Add the middle bit to the end, a -noshell flag if there are # more arguments. -if [ $i -gt 0 ]; then +if [ "$i" -gt 0 ]; then set -- "$@" "-noshell" fi + set -- "$@" "-user" "lfe_init" "-extra" # Check if we are 'eval'ing and add -lfe_eval flag if [ "$e" != "" ]; then - shift ; i=`expr $i - 1` # Now we remove it as it has -noshell'ed + shift ; i=`expr $i - 1` # Now we remove it as it has -noshell'ed set -- "$@" "-lfe_eval" fi # Step over the arg section adding them to the end. -while [ $i -gt 0 ]; do +while [ "$i" -gt 0 ]; do set -- "$@" "$1" shift ; i=`expr $i - 1` done +# The order of precedence for LFE libraries is as follows: +# 1) The LFE_ROOTDIR for the current bin/lfe being executed is unusurpable; +# allowing anything else would leave LFE open to instabilities where it +# could be executed with libraries of a different release. +# 2) A user/developer should be allowed to override anything else by updating +# ERL_LIBS as they see fit. +# 3) A project's libraries (current directory) should be loaded automatically, +# if they exist, but not override the previous two. +# 4) If a default library is installed in ~/.lfe/libs, then that will be added +# last, in the event that the sought library is not picked up in any of the +# other locations. +# # Note that ERL_LIBS will find *either* an ebin subdir *or* lib subdir -ERL_LIBS="$HOME"/.lfe/lib:"$LFE_ROOTDIR":"$LFE_ROOTDIR"/lib:"$ERL_LIBS" exec erl "$@" + +# Find application ebin directories in lib if lib exists. + +find_libs () { + if [ -d "$1" ]; then + echo $(find "$1" -maxdepth 1 -mindepth 1 -exec printf "%s:" {} \;) + fi +} + +# The following works for rebar and erl.mk +PROJ_LIBS=$(find_libs "./deps") +# The following works for rebar3 +R3_PROJ_LIBS=$(find_libs "./_build/default/deps"):$(find_libs "./_build/default/lib") +LFE_HOME_LIBS=$(find_libs "$HOME"/.lfe/lib) +ALL_LIBS="$LFE_ROOTDIR":"$ERL_LIBS":"$PROJ_LIBS""$R3_PROJ_LIBS""$LFE_HOME_LIBS" +ERL_LIBS="$ALL_LIBS" exec erl "$@" +
View file
lfe-0.9.2.tar.gz/bin/lfe-first-try -> lfe-1.0.tar.gz/bin/lfe-first-try
Changed
@@ -15,14 +15,14 @@ follow_symlink () { if [ -h "$1" ]; then - follow_symlink $(readlink "$1") + follow_symlink "$(readlink "$1")" else - echo "$1" + echo "$1" fi } SELF=$(follow_symlink "$0") -LFE_PROGNAME=`echo $0 | sed 's/.*\///'` +LFE_PROGNAME=$(echo "$0" | sed 's/.*\///') LFE_BINDIR=$(dirname "$SELF") LFE_ROOTDIR=$(dirname "$LFE_BINDIR") @@ -65,4 +65,4 @@ lflags="-noshell $lflags" # To avoid getting a shell process fi -echo $flags $lflags -user lfe_init -extra "$@" +echo "$flags" "$lflags" -user lfe_init -extra "$@"
View file
lfe-0.9.2.tar.gz/bin/lfec -> lfe-1.0.tar.gz/bin/lfec
Changed
@@ -16,63 +16,91 @@ (defun fix-code-path () (let* ((p0 (code:get_path)) - (p1 (lists:delete "." p0))) + (p1 (lists:delete "." p0))) (code:set_path p1))) (defun parse-opts - ([(list* "-I" idir as) opts] ;Keep these in order + ([(cons "-h" as) opts] + (usage) + (tuple as opts)) + ([(list* "-I" idir as) opts] ;Keep these in order (parse-opts as (++ opts `(#(i ,idir))))) - ([(list* "-o" odir as) opts] ;Last is first + ([(list* "-o" odir as) opts] ;Last is first (parse-opts as (cons `#(outdir ,odir) opts))) ([(list* "-pa" dir as) opts] (code:add_patha dir) (parse-opts as opts)) - ([(list* "-pa" dir as) opts] + ([(list* "-pz" dir as) opts] (code:add_pathz dir) (parse-opts as opts)) ([(cons "-v" as) opts] (parse-opts as (cons 'verbose opts))) + ([(cons "-D" as) opts] + (parse-opts as (cons 'debug_print opts))) ([(cons "-Werror" as) opts] (parse-opts as (cons 'warnings_as_errors opts))) - ([(cons (++ "-W" _) as) opts] ;Ignore this here + ([(cons (++ "-W" _) as) opts] ;Ignore this here (parse-opts as opts)) + ([(cons "-D" as) opts] + (parse-opts as (cons 'debug_print opts))) ([(cons "-E" as) opts] (parse-opts as (cons 'to_exp opts))) - ([(cons "-P" as) opts] ;Ignore as no LFE counterpart - (parse-opts as opts)) + ([(cons "-L" as) opts] + (parse-opts as (cons 'to_lint opts))) ([(cons "-S" as) opts] (parse-opts as (cons 'to_asm opts))) + ([(cons "-P" as) opts] ;Ignore as no LFE counterpart + (parse-opts as opts)) ([(cons "--" as) opts] (tuple as opts)) - ([(cons (++ "+" s) as) opts] + ([(cons (cons #\+ s) as) opts] (let ((`#(ok ,t) (lfe_io:read_string s))) (parse-opts as (cons t opts)))) ([as opts] (tuple as opts))) (defun usage () - (let ((usage (++ "Usage: lfec [options] file ...\n" - "Options:\n" - "-I name Name of include directory\n" - "-o name Name of output directory\n" - "-pa path Add path to the front of LFE's code path\n" - "-pz path Add path to the end of LFE's code path\n" - "-v Verbose compiler output\n" - "-Werror Make all warnings into errors\n" - "-Wnumber Set warning level (ignored)\n" - "-E Equivalent to +to_exp\n" - "-S Equivalent to +to_asm\n" - "-- No more options, only file names follow\n" - "+term Term will be added to options\n" ))) + (let ((usage (++ "Usage: lfec [options] file ...\n\n" + "Options:\n" + "-h Print usage and exit\n" + "-I name Name of include directory\n" + "-o name Name of output directory\n" + "-pa path Add path to the front of LFE's code path\n" + "-pz path Add path to the end of LFE's code path\n" + "-v Verbose compiler output\n" + "-Werror Make all warnings into errors\n" + "-Wnumber Set warning level (ignored)\n" + "-D Equivalent to +debug_print\n" + "-L Equivalent to +to_lint\n" + "-E Equivalent to +to_exp\n" + "-S Equivalent to +to_asm\n" + "-- No more options, only file names follow\n" + "+term Term will be added to options\n\n" + "Terms include:\n\n" + "+binary, +to_exp, +to_lint, +to_core0, +to_core, +to_kernel, +to_asm\n" + "+{outdir, Dir}, +report, +return, +debug_print\n"))) (io:put_chars usage))) -;; Parse the arguments and compile the files. +(defun compile-file (file opts) + (case (lfe_comp:file file opts) ;Catch all the return values + (`#(ok ,_) 'ok) ;Just as long as it worked + (`#(ok ,_ ,_) 'ok) + ('error 'error) ;Or any error + (`#(error ,_ ,_ ,_) 'error))) + +(defun compile-files + ([(cons file files) opts] + (case (compile-file file opts) + ('ok (compile-files files opts)) + (_ 'error))) + ([() _] 'ok)) +;; Parse the arguments and compile the files. (case script-args (() (usage)) (as0 (fix-code-path) - (let ((`#(,as1 ,opts1) (parse-opts as0 ()))) - ;; (pp (list as1 opts1)) - (lists:map (lambda (a) (lfe_comp:file a (list* 'verbose 'report opts1))) - as1)))) + (let ((`#(,files ,opts1) (parse-opts as0 ()))) + (case (compile-files files (list* 'verbose 'report opts1)) + ('error (halt 1)) + ('ok 'ok)))))
View file
lfe-0.9.2.tar.gz/bin/lfescript -> lfe-1.0.tar.gz/bin/lfescript
Changed
@@ -22,14 +22,21 @@ cd "$(dirname "$1")" > /dev/null filename="$(basename "$1")" if [ -h "$filename" ]; then - follow_symlink "$(readlink "$filename")" + follow_symlink "$(readlink "$filename")" else - echo "`pwd -P`/$filename" + echo "$(pwd -P)/$filename" fi } +show_help () { + echo "Usage: `basename $0` [flags] file [args] + + -h | --help Print this help and exit + -flag Passes configuration flags to be used on startup" >&2 +} + SELF=$(follow_symlink "$0") -LFE_PROGNAME=`echo $0 | sed 's/.*\///'` # Basically basename +LFE_PROGNAME=$(echo "$0" | sed 's/.*\///') # Basically basename LFE_BINDIR=$(dirname "$SELF") LFE_ROOTDIR=$(dirname "$LFE_BINDIR") @@ -43,17 +50,20 @@ # Collect any script options starting with '-' upto the script name. # Valid script options are only flags without arguments. -i="$#" # Counter +i="$#" # Counter -while [ $i -gt 0 ]; do +while [ "$i" -gt 0 ]; do case "$1" in - -*) # Flags - arg=`echo $1 | sed 's/^-//'` - set -- "$@" "$arg" - shift ; i=`expr $i - 1` - ;; - *) # Plain argument - break ;; + -h | --help) # Help + $(show_help) + exit 1 ;; + -*) # Flags + arg=`echo $1 | sed 's/^-//'` + set -- "$@" "$arg" + shift ; i=`expr $i - 1` + ;; + *) # Plain argument + break ;; esac done @@ -64,7 +74,7 @@ set -- "$@" "-extra" # Step over the args section adding them to the end. -while [ $i -gt 0 ]; do +while [ "$i" -gt 0 ]; do set -- "$@" "$1" shift ; i=`expr $i - 1` done @@ -75,16 +85,43 @@ # Read the first three lines of the script file. if [ -z "$scriptname" ]; then echo "lfescript: Missing filename" ; exit 127 -elif [ -f "$scriptname" -a -r "$scriptname" ]; then - { read line1; read line2; read line3; } < $scriptname +elif [ -f "$scriptname" -a -r "$scriptname" ]; then + { read line1; read line2; read line3; } < "$scriptname" else echo "lfescript: Failed to open file: $scriptname" ; exit 127 fi # Search for explicit emulator flag option line. -shebangs=`expr "$line2" : '^;;! *\(.*\)'` -if [ -z "$shebangs" ] ; then shebangs=`expr "$line3" : '^;;! *\(.*\)'` ; fi +shebangs=$(expr "$line2" : '^;;! *\(.*\)') +if [ -z "$shebangs" ] ; then shebangs=$(expr "$line3" : '^;;! *\(.*\)') ; fi # Done, now just run the emulator. +# The order of precedence for LFE libraries is as follows: +# 1) The LFE_ROOTDIR for the current bin/lfe being executed is unusurpable; +# allowing anything else would leave LFE open to instabilities where it +# could be executed with libraries of a different release. +# 2) A user/developer should be allowed to override anything else by updating +# ERL_LIBS as they see fit. +# 3) A project's libraries (current directory) should be loaded automatically, +# if they exist, but not override the previous two. +# 4) If a default library is installed in ~/.lfe/libs, then that will be added +# last, in the event that the sought library is not picked up in any of the +# other locations. +# # Note that ERL_LIBS will find *either* an ebin subdir *or* lib subdir -ERL_LIBS="$HOME"/.lfe/lib:"$LFE_ROOTDIR":"$LFE_ROOTDIR"/lib:"$ERL_LIBS" exec $emulator +B -boot start_clean $shebangs "-noshell" "-run" "lfescript" "start" "$@" + +# Find application ebin directories in lib if lib exists. + +find_libs () { + if [ -d "$1" ]; then + echo $(find "$1" -maxdepth 1 -mindepth 1 -exec printf "%s:" {} \;) + fi +} + +# The following works for rebar and erl.mk +PROJ_LIBS=$(find_libs "./deps") +# The following works for rebar3 +R3_PROJ_LIBS=$(find_libs "./_build/default/deps"):$(find_libs "./_build/default/lib") +LFE_HOME_LIBS=$(find_libs "$HOME"/.lfe/lib) +ALL_LIBS="$LFE_ROOTDIR":"$ERL_LIBS":"$PROJ_LIBS""$R3_PROJ_LIBS""$LFE_HOME_LIBS" +ERL_LIBS="$ALL_LIBS" exec "$emulator" +B -boot start_clean "$shebangs" "-noshell" "-run" "lfescript" "start" "$@"
View file
lfe-0.9.2.tar.gz/c_src/lfeexec.c -> lfe-1.0.tar.gz/c_src/lfeexec.c
Changed
@@ -47,7 +47,8 @@ int main(int argc, char **argv) { char *emu; /* Emulator */ - char pa[1024]; /* Path */ + char *rootdir; /* $LFE_ROOTDIR */ + char *pa; /* Path */ char *arg; int i; int eval = 0; /* Are 'eval'ing? */ @@ -55,10 +56,15 @@ /* The erl program and the ebin directory */ emu = DEFAULT_PROGNAME; - sprintf(pa, "%s/ebin", getenv("LFE_ROOTDIR")); + rootdir = getenv("LFE_ROOTDIR"); + if (rootdir == NULL) { + error("LFE_ROOTDIR envionment variable is not set"); + } + pa = emalloc(strlen(rootdir) + 6); + sprintf(pa, "%s/ebin", rootdir); /* Allocate and initialise the erl argument array. */ - Eargv = malloc(sizeof(*argv) * (argc + 16)); + Eargv = (char **)emalloc(sizeof(*argv) * (argc + 16)); Eargc = 0; PUSH(emu); /* The program we are going to run */
View file
lfe-0.9.2.tar.gz/doc/lfe_bits.txt -> lfe-1.0.tar.gz/doc/lfe_bits.txt
Changed
@@ -1,35 +1,35 @@ MODULE - lfe_bits + lfe_bits MODULE SUMMARY - Lisp Flavoured Erlang (LFE) common binary functions + Lisp Flavoured Erlang (LFE) common binary functions DESCRIPTION - This module contains a collection of library functions for for - handling binaries. They are generally not called by the user. + This module contains a collection of library functions for for + handling binaries. They are generally not called by the user. EXPORTS parse_bitspecs(Specs) -> - {ok,Size,{Type,Unit,Sign,Endian}} | - {error,Error}. + {ok,Size,{Type,Unit,Sign,Endian}} | + {error,Error}. - Parse a bitspec and return the data. Unmentioned fields get - the value 'default'. + Parse a bitspec and return the data. Unmentioned fields get + the value 'default'. get_bitspecs(Specs) -> - {ok,Size,{Type,Unit,Sign,Endian}} | - {error,Error}. + {ok,Size,{Type,Unit,Sign,Endian}} | + {error,Error}. - Parse a bitspec, apply defaults and return the - data. Unmentioned fields get the value 'default'. + Parse a bitspec, apply defaults and return the + data. Unmentioned fields get the value 'default'. Error Information - The following error values are returned: + The following error values are returned: - {undefined_bittype,Type} - bittype_unit + {undefined_bittype,Type} + bittype_unit
View file
lfe-0.9.2.tar.gz/doc/lfe_comp.txt -> lfe-1.0.tar.gz/doc/lfe_comp.txt
Changed
@@ -1,130 +1,153 @@ MODULE - lfe_comp + lfe_comp MODULE SUMMARY - Lisp Flavoured Erlang (LFE) compiler + Lisp Flavoured Erlang (LFE) compiler DESCRIPTION - This module provides an interface to the standard LFE - compiler. It can generate either a new file which contains the - object code, or return a binary which can be loaded directly. + This module provides an interface to the standard LFE + compiler. The compiler can handle files which contain multiple + modules. It can generate either new files which contain the + object code, or return binaries which can be loaded directly. EXPORTS file(FileName) -> CompRet - Is the same as file(FileName, [report]). + Is the same as file(FileName, [report]). file(FileName, Options) -> CompRet - where - CompRet = ModRet | BinRet | ErrRet - ModRet = {ok,ModuleName} | {ok,ModuleName,Warnings} - BinRet = {ok,ModuleName,Binary} | {ok,ModuleName,Binary,Warnings} - ErrRet = error | {error,Errors,Warnings} - - Compile an LFE file, either writing the generated module to a - file or returning it as a binary. The generated module is - ready to be loaded into Erlang. - - The currently recognised options are: - - binary - Return the binary of the module and do not save it in - a file. - - 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_lint - Print a listing of the macro expanded and linted LFE - code in the file <File>.lint. 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 - Print the errors and warnings as they occur. - - return - 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]}] - - ErrorInfo is described below. When generating Errors and - Warnings the line number is the line of the start of the form - in which the error occurred. The file name has been included - here to be compatible with the Erlang compiler. As yet there - is no extra information about included files. + where + CompRet = ModRet | BinRet | ErrRet + ModRet = {ok,[ModOk]} | {ok,[ModOk],Warnings} + ModOk = {ok,ModuleName} | {ok,ModuleName,Warnings} + BinRet = {ok,[ModBin]} | {ok,[ModBin],Warnings} + ModBin = {ok,ModuleName,Binary} | {ok,ModuleName,Binary,Warnings} + ErrRet = error | {error,[ModErr],Errors,Warnings} + ModErr = {error,Errors,Warnings} + + Compile an LFE file, either writing the generated modules to + files or returning them as binaries. The generated modules are + ready to be loaded into Erlang. + + The currently recognised options are: + + binary + Return the binary of the module and do not save it in + a file. + + to_exp + 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_lint + to-lint + Print a listing of the macro expanded and linted LFE + code in the files <Module>.lint. No object files are + produced. Mainly useful for debugging and interest. + + to_core0 + to-core0 + to_core + to-core + Print a listing of the Core Erlang code before/after + being optimised in the files <Module>.core. No object + files are produced. Mainly useful for debugging and + interest. + + to_kernel + to-kernel + Print a listing of the Kernel Erlang code in the files + <Module>.kernel. No object files are produced. Mainly + useful for debugging and interest. + + to_asm + to-asm + Print a listing of the Beam code in the files + <Module>.S. No object files are produced. Mainly + useful for debugging and interest. + + {outdir,Dir} + [outdir,Dir] + Save the generated files in directory Dir instead of + the current directory. + + {i,Dir} + [i,Dir] + Add dir to the list of directories to be searched when + including a file. + + report + Print the errors and warnings as they occur. + + return + Return an extra return field containing Warnings on + success or the errors and warnings in + {error,Errors,Warnings} when there are errors. + + debug_print + debug-print + Causes the compiler to print a lot of debug + information. + + warnings_as_errors + warnings-as-errors + Causes warnings to be treated as errors. + + If the binary option is given then options that produce + listing files will cause the internal formats for that + compiler pass to be returned. + + Both Warnings and Errors have the following format: + + [{FileName,[ErrorInfo]}] + + ErrorInfo is described below. When generating Errors and + Warnings the line number is the line of the start of the form + in which the error occurred. The file name has been included + here to be compatible with the Erlang compiler. As yet there + is no extra information about included files. forms(Forms) -> CompRet - Is the same as forms(Forms, [report]). + Is the same as forms(Forms, [report]). forms(Forms, Options) -> CompRet - where - Forms = [sexpr()] - CompRet = BinRet | ErrRet - BinRet = {ok,ModuleName,Binary} | {ok,ModuleName,Binary,Warnings} - ErrRet = error | {error,Errors,Warnings} + where + Forms = [sexpr()] + CompRet = BinRet | ErrRet + BinRet = {ok,[ModBin]} | {ok,[ModBin],Warnings} + ModBin = {ok,ModuleName,Binary} | {ok,ModuleName,Binary,Warnings} + ErrRet = error | {error,[ModErr],Errors,Warnings} + ModErr = {error,Errors,Warnings} - Compile the forms as an LFE module returning a binary. This - function takes the same options as lfe_comp:file/1/2. When - generating Errors and Warnings the "line number" is the index - of the form in which the error occured. + Compile the forms as an LFE module returning a binary. This + function takes the same options as lfe_comp:file/1/2. When + generating Errors and Warnings the "line number" is the index + of the form in which the error occured. format_error(Error) -> Chars - Uses an ErrorDescriptor and returns a deep list of characters - which describes the error. This function is usually called - implicitly when an ErrorInfo structure is processed. See - below. + Uses an ErrorDescriptor and returns a deep list of characters + which describes the error. This function is usually called + implicitly when an ErrorInfo structure is processed. See + below. Error Information - The ErrorInfo mentioned above is the standard ErrorInfo - structure which is returned from all IO modules. It has the - following format: + The ErrorInfo mentioned above is the standard ErrorInfo + structure which is returned from all IO modules. It has the + following format: - {ErrorLine,Module,ErrorDescriptor} + {ErrorLine,Module,ErrorDescriptor} - A string describing the error is obtained with the following call: + A string describing the error is obtained with the following call: - apply(Module, format_error, ErrorDescriptor) + Module:format_error(ErrorDescriptor)
View file
lfe-0.9.2.tar.gz/doc/lfe_gen.txt -> lfe-1.0.tar.gz/doc/lfe_gen.txt
Changed
@@ -1,44 +1,44 @@ MODULE - lfe_gen + lfe_gen MODULE SUMMARY - Lisp Flavoured Erlang (LFE) dynamic code generator + Lisp Flavoured Erlang (LFE) dynamic code generator DESCRIPTION - This module provides an experimental interface for dynamically - generating modules. + This module provides an experimental interface for dynamically + generating modules. DATA TYPES - sexpr() - An LFE s-expression, a list structure. + sexpr() + An LFE s-expression, a list structure. EXPORTS compile_forms(Forms) -> CompRet - where - Forms = [sexpr()] - CompRet = BinRet | ErrRet - BinRet = {ok,ModuleName,Binary,Warnings} - ErrRet = {error,Errors,Warnings} + where + Forms = [sexpr()] + CompRet = BinRet | ErrRet + BinRet = {ok,ModuleName,Binary,Warnings} + ErrRet = {error,Errors,Warnings} - Compile a list of LFE forms which comprise an LFE module. For - example: + Compile a list of LFE forms which comprise an LFE module. For + example: - lfe_gen:compile_forms([[defmodule,foo,[export,[a,0]]], - [defun,a,[],[quote,yes]]]) + lfe_gen:compile_forms([[defmodule,foo,[export,[a,0]]], + [defun,a,[],[quote,yes]]]) - Both WarningList and ErrorList have the following format: + Both WarningList and ErrorList have the following format: - [{FileName,[ErrorInfo]}] + [{FileName,[ErrorInfo]}] - ErrorInfo is described below. When generating Errors and - Warnings the "line number" is the index of the form in which - the error occured. + ErrorInfo is described below. When generating Errors and + Warnings the "line number" is the index of the form in which + the error occured. new_module(Name) -> ModDef. add_exports([{Name,Arity}], ModDef) -> ModDef. @@ -47,92 +47,92 @@ print_mod(ModDef) -> iolist(). compile_mod(Mod) -> CompRet - where - CompRet = BinRet | ErrRet - BinRet = {ok,ModuleName,Binary,Warnings} - ErrRet = {error,Errors,Warnings} + where + CompRet = BinRet | ErrRet + BinRet = {ok,ModuleName,Binary,Warnings} + ErrRet = {error,Errors,Warnings} - These functions are used to incrementally create a module - which can at the end be compiled by compile_mod/1. The same - example as above could be written: + These functions are used to incrementally create a module + which can at the end be compiled by compile_mod/1. The same + example as above could be written: - M0 = lfe_gen:new_module(foo), - M1 = lfe_gen:add_exports([{a,0}], M0), - M2 = lfe_gen:add_form([defun,a,[],[quote,yes]], M1), - lfe_gen:compile_mod(M2) + M0 = lfe_gen:new_module(foo), + M1 = lfe_gen:add_exports([{a,0}], M0), + M2 = lfe_gen:add_form([defun,a,[],[quote,yes]], M1), + lfe_gen:compile_mod(M2) Example - In this example we build a module of parameters where each - parameter has a number of features which each have a value. We - will create one function for each parameter and the feature is - the functions argument. The value for each feature is - returned. + In this example we build a module of parameters where each + parameter has a number of features which each have a value. We + will create one function for each parameter and the feature is + the functions argument. The value for each feature is + returned. - We are creating code equivalent to: + We are creating code equivalent to: - -module(Name). - -export([<param1>/1,...]). + -module(Name). + -export([<param1>/1,...]). - <param1>(Feature) -> - case Feature of - <feature1> -> <value1>; - ... - _ -> erlang:error({unknown_feature,<param1>,Feature) - end. - ... + <param1>(Feature) -> + case Feature of + <feature1> -> <value1>; + ... + _ -> erlang:error({unknown_feature,<param1>,Feature) + end. + ... - but generating it and compiling it directly in memory without - generating a text file. We assume that we have collected the - data and have it in the form: + but generating it and compiling it directly in memory without + generating a text file. We assume that we have collected the + data and have it in the form: - Params = [{Parameter,[{Feature,Value}]}] + Params = [{Parameter,[{Feature,Value}]}] - The equivalent LFE code which we will be generating is: + The equivalent LFE code which we will be generating is: - (defmodule Name - (export (<param1> 1) (<param2> 1) ... )) + (defmodule Name + (export (<param1> 1) (<param2> 1) ... )) - (defun <param1> (f) - (case f - ('<feature1> '<value1>) - ... - (f (: erlang error (tuple 'unknown_feature '<param1> f))))) + (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: + The following code builds and compiles a module from the + parameter data: - make_module(Name, Params) -> - Mod0 = lfe_gen:new_module(Name), - Exps = map(fun ({F,_}) -> {F,1} end, Params), - Mod1 = lfe_gen:add_exports(Exps, Mod0), - Mod2 = make_funcs(Params, Mod1), - lfe_gen:compile_mod(Mod2). + make_module(Name, Params) -> + Mod0 = lfe_gen:new_module(Name), + Exps = map(fun ({F,_}) -> {F,1} end, Params), + Mod1 = lfe_gen:add_exports(Exps, Mod0), + Mod2 = make_funcs(Params, Mod1), + lfe_gen:compile_mod(Mod2). - make_funcs([{Param,Fs}|Ps], Mod) -> - %% Define catch-all which generates more explicit exit value. - CatchAll = [f,[':',erlang,error, - [tuple,unknown_feature,[quote,Param],f]]], - %% Build case clauses - Cls = foldr(fun ({Feature,Value}, Cls) -> - [[[quote,Feature],[quote,Value]]|Cls] - end, [CatchAll], Params), - %% Build function. - Func = [defun,Param,[f],['case',f,Cls]], - make_funcs(Ps, lfe_gen:add_form(Func, Mod)); - make_funcs([], Mod) -> Mod. %All done + make_funcs([{Param,Fs}|Ps], Mod) -> + %% Define catch-all which generates more explicit exit value. + CatchAll = [f,[':',erlang,error, + [tuple,unknown_feature,[quote,Param],f]]], + %% Build case clauses + Cls = foldr(fun ({Feature,Value}, Cls) -> + [[[quote,Feature],[quote,Value]]|Cls] + end, [CatchAll], Params), + %% Build function. + Func = [defun,Param,[f],['case',f,Cls]], + make_funcs(Ps, lfe_gen:add_form(Func, Mod)); + make_funcs([], Mod) -> Mod. %All done Error Information - The ErrorInfo mentioned above is the standard ErrorInfo - structure which is returned from all IO modules. It has the - following format: + The ErrorInfo mentioned above is the standard ErrorInfo + structure which is returned from all IO modules. It has the + following format: - {ErrorLine,Module,ErrorDescriptor} + {ErrorLine,Module,ErrorDescriptor} - A string describing the error is obtained with the following call: + A string describing the error is obtained with the following call: - apply(Module, format_error, ErrorDescriptor) + apply(Module, format_error, ErrorDescriptor)
View file
lfe-0.9.2.tar.gz/doc/lfe_io.txt -> lfe-1.0.tar.gz/doc/lfe_io.txt
Changed
@@ -42,32 +42,23 @@ Print the s-expr Sexpr to the standard output (IoDevice). -prettyprint([IoDevice,] Sexpr) -> ok - - Pretty print the s-expr Sexpr to the standard output - (IoDevice). Assume we start with no indentation. - print1(Sexpr) -> DeepCharList Return the list of characters which represent the s-expr Sexpr. -prettyprint1(Sexpr, CurrentIndentation) -> DeepCharList +prettyprint1(Sexpr) -> DeepCharList +prettyprint1(Sexpr, Depth) -> DeepCharList +prettyprint1(Sexpr, Depth, Indentation) -> DeepCharList +prettyprint1(Sexpr, Depth, Indentation, LineLength) -> DeepCharList Return the lost of characters which represents the prettyprinted s-expr Sexpr. Assume we start at indentation - CurrentIndentation. - -print1_symb(Symbol) -> DeepCharList. - - Return the list of characters needed to print the symbol Symbol. - -print1_string(String) -> DeepCharList. - - Return the list of characters needed to print the string - String as a string. + Indentation or 0. format([IoDevice,] Format, Args) -> ok +fwrite([IoDevice,] Format, Args) -> ok format1(Format, Args) -> DeepCharList +fwrite1(Format, Args) -> DeepCharList Print formatted output. The following commands are valid in the format string:
View file
lfe-0.9.2.tar.gz/doc/lfe_lib.txt -> lfe-1.0.tar.gz/doc/lfe_lib.txt
Changed
@@ -1,32 +1,32 @@ MODULE - lfe_lib + lfe_lib MODULE SUMMARY - Lisp Flavoured Erlang (LFE) library + Lisp Flavoured Erlang (LFE) library DESCRIPTION - This module contains a collection of library functions for - implementing LFE. They are generally not called by the user. + This module contains a collection of library functions for + implementing LFE. They are generally not called by the user. EXPORTS new_env() -> Environment. - Create a new environment for the evaluator. + Create a new environment for the evaluator. add_env(Env1, Env2) -> Env. - Add environment Env1 to Env2 such that Env1 shadows Env2. + Add environment Env1 to Env2 such that Env1 shadows Env2. is_erl_bif(Name, Arity) -> bool(). is_guard_bif(Name, Arity) -> bool(). - Test whether a Name/Arity is a BIF or guard BIF. This works - for functions and operators. + Test whether a Name/Arity is a BIF or guard BIF. This works + for functions and operators. is_core_form(Name) -> bool(). - Test whether Name is one the LFE core forms. + Test whether Name is one the LFE core forms.
View file
lfe-0.9.2.tar.gz/doc/lfe_macro.txt -> lfe-1.0.tar.gz/doc/lfe_macro.txt
Changed
@@ -1,65 +1,65 @@ MODULE - lfe_macro + lfe_macro MODULE SUMMARY - Lisp Flavoured Erlang (LFE) macro expander + Lisp Flavoured Erlang (LFE) macro expander DESCRIPTION - This module provides an interface to the LFE macro expander. - The expander is used by the LFE compile and in the shell but - can also be used by applications explicitly wanting to handle - a file. + This module provides an interface to the LFE macro expander. + The expander is used by the LFE compile and in the shell but + can also be used by applications explicitly wanting to handle + a file. DATA TYPES - sexpr() - An LFE s-expression, a list structure. - filesexpr() = {Sexpr,Line} - This is the format returned by lfe_io:parse_file/1 and - is used by the compiler to give better error - information. - env() - This is an macro and evaluation environment as created - by lfe_lib:new_env(). + sexpr() + An LFE s-expression, a list structure. + filesexpr() = {Sexpr,Line} + This is the format returned by lfe_io:parse_file/1 and + is used by the compiler to give better error + information. + env() + This is an macro and evaluation environment as created + by lfe_lib:new_env(). EXPORTS expand_forms([FileSexpr], Env) -> ExpRet - where - FileSexpr = filesexpr() - Env = env() - ExpRet = {yes,[FileSexpr],Env,Warnings} | {error,Errors,Warnings} + where + FileSexpr = filesexpr() + Env = env() + ExpRet = {yes,[FileSexpr],Env,Warnings} | {error,Errors,Warnings} macro_forms([FileSexpr], Env) -> {[FileSexpr],Env}. - where - FileSexpr = filesexpr() - Env = env() + where + FileSexpr = filesexpr() + Env = env() expand_expr_all(Sexpr, Env) -> Sexpr. - where - Sexpr = sexpr() - Env = env() + where + Sexpr = sexpr() + Env = env() - Expand all macros in Sexpr either using the definitions in Env - or just the default macros. Note that any eventual new macro - definitions will be lost. + Expand all macros in Sexpr either using the definitions in Env + or just the default macros. Note that any eventual new macro + definitions will be lost. expand_expr(Sexpr, Env) -> {yes,Exp} | no. expand_expr_1(Sexpr, Env) -> {yes,Exp} | no. - where - Sexpr = Exp = sexpr() - Env = env() + where + Sexpr = Exp = sexpr() + Env = env() - Test if the top s-expression here is a macro call, if so - expand it and return {yes,Expansion}, if not then return no. - expand_expr/2 will expand the top s-expression as much as - possible while expand_expr_1/2 will only try it once. These - functions use the macro definitions in the environment and the - standard pre-defined macros. + Test if the top s-expression here is a macro call, if so + expand it and return {yes,Expansion}, if not then return no. + expand_expr/2 will expand the top s-expression as much as + possible while expand_expr_1/2 will only try it once. These + functions use the macro definitions in the environment and the + standard pre-defined macros.
View file
lfe-0.9.2.tar.gz/doc/user_guide.txt -> lfe-1.0.tar.gz/doc/user_guide.txt
Changed
@@ -3,14 +3,229 @@ Note {{ ... }} is use to denote optional syntax. -Special syntactic rules ------------------------ +Literals and Special Syntactic Rules +==================================== + +Integers +~~~~~~~~ + +Integers can be written in various forms and number bases: + + +Regular decimal notation: + 1234 -123 0 +Binary notation: + #b0 #b10101 #b-1100 +Binary notation (alternative form): + #*0 #b*10101 #*-1100 +Octal notation: + #o377 #o-111 +Explicitly decimal notation: + #d1234 #d-123 #d0 +Hexadecimal notation: + #xc0ffe 0x-01 +Notation with explicit base (up to 36): + #2r1010 #8r377 #36rhelloworld +Character notation (the value is the Unicode code point of the character + #\a #\$ #\ä #\🐭 +Character notation with the value in hexadecimal: + #\x1f42d; + +In all these forms, the case of the indicating letter is not +significant, i.e. #b1010 and #B1010 are identical as are #16rf00 and +#16Rf00. + +Similarly, the case is not significant for digits beyond 9 (i.e. 'a', +'b', 'c', … for number bases larger than 10), e.g. #xabcd is the same as +#xABCD and can even be mixed in the same number, e.g. #36rHelloWorld is +valid and the same number as #36Rhelloworld and #36rHELLOWORLD. + +The character notation using hexadecimal code representation (#\x....;) +is basically the same thing as the regular hexadecimal notation +#x.... except that it conveys to the reader that a character is intended +and that it does a sanity check on the value (e.g. negative numbers and +value outside the Unicode range are not permitted). + + +Floating point numbers +~~~~~~~~~~~~~~~~~~~~~~ + +There is only one type of floating point numbers and the literals are +written in the usual way, e.g. these are all valid floating point +numbers: + 1.0 +1.0 -1.0 1.0e10 1.111e-10 + +The one thing to watch out for is that you cannot omit the the part +before or after the decimal point if it is zero. E.g. the following are +not valid forms: 100. or .125. + + +Strings +~~~~~~~ + +There are two forms of strings: list strings and binary strings. + + +List Strings +............ + +List strings are just lists of integers (where the values have to be +from a certain set of numbers that are considered valid characters) but +they have their own syntax for literals (which will also be used for +integer lists as an output representation if the list contents looks +like it is meant to be a string): "any text between double quotes where +\" and other special characters like \n can be escaped". + +As a special case you can also write out the character number in the +form \xHHH; (where "HHH" is an integer in hexadecimal notation), +e.g. "\x61;\x62;\x63;" is a complicated way of writing "abc". This can +be convenient when writing Unicode letters not easily typeable or +viewable with regular fonts. E.g. "Cat: \x1f639;" might be easier to +type (and view on output devices without a Unicode font) than "Cat: 😹". + + +Binary Strings +.............. + +Binary strings are just like list strings but they are represented +differently in the virtual machine. The simple syntax is #"...", +e.g. #"This is a binary string \n with some \"escaped\" and quoted +(\x1f639;) characters" + +You can also use the general format for creating binaries (#B(...), +described below), e.g. #B("a"), #"a", and #B(97) are all the same binary +string. + + +Character Escaping +.................. + +Certain control characters can be more readably included by using their +escaped name: + | Escaped name | Character | + |--------------+-----------------| + | \b | Backspace | + | \t | Tab | + | \n | Newline | + | \v | Vertical tab | + | \f | Form Feed | + | \r | Carriage Return | + | \e | Escape | + | \s | Space | + | \d | Delete | + +Alternatively you can also use the hexadecimal character encoding, +e.g. "a\nb" and "a\x0a;b" are the same string. + + +Binaries +~~~~~~~~ + +We have already seen binary strings, but the #B(...) syntax can be used +to create binaries with any contents. Unless the contents is a simple +integer you need to annotate it with a type and/or size. + +Example invocations are that show the various annotations: + #B(42 (42 (size 16)) (42 (size 32))) ⇨ #B(42 0 42 0 0 0 42) + #B(-42 111 (-42 (size 16)) 111 (-42 (size 32))) ⇨ + #B(-42 111 (-42 (size 16)) 111 (-42 (size 32))) + #B((42 (size 32) big-endian) (42 (size 32) little-endian)) ⇨ + #B(0 0 0 42 42 0 0 0) + #B((1.23 float) (1.23 (size 32) float) (1.23 (size 64) float)) ⇨ + #B(63 243 174 20 122 225 71 174 63 157 112 164 63 243 174 20 122 + 225 71 174) + #B((#"a" binary) (#"b" binary)) ⇨ #"ab" + #B("Cat:" #\ (128569 utf-8)) ⇨ #"Cat: 😹" + +Learn more about "segments" of binary data e.g. in "Learn You Some +Erlang" +(http://learnyousomeerlang.com/starting-out-for-real#bit-syntax). + + +Lists +~~~~~ + +Lists are formed either as ( ... ) or [ ... ] where the optional +elements of the list are separated by some form or whitespace. + +E.g. () (the empty list), (foo bar baz), or + (foo + bar + baz) + + +Tuples +~~~~~~ + +Tuples are written as #(value1 value2 ...). The empty tuple #() is also +valid. + + +Maps +~~~~ + +Maps are written as #M(key1 value1 key2 value2 ...) (again, the empty +map is also valid and written as #M(). + + +Symbols +~~~~~~~ + +Things that cannot be parsed as any of the above are usually considered +as a symbol. + +Simple examples are foo, Foo, foo-bar, :foo. But also somewhat +surprisingly 123foo and 1.23e4extra (but note that illegal digits don't +make a number a symbol when using the explicit number base notation, +e.g. #b10foo gives an error). + +Symbol names can contain a surprising breadth or characters: + +!, #, $, %, &, ', *, +, ,, -, ., /, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, :, <, +=, >, ?, @, A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, +U, V, W, X, Y, Z, \, ^, _, , a, b, c, d, e, f, g, h, i, j, k, l, m, n, +o, p, q, r, s, t, u, v, w, x, y, z, |, ~, \ , ¡, ¢, £, ¤, ¥, ¦, §, ¨, +©, ª, «, ¬, \, ®, ¯, °, ±, ², ³, ´, µ, ¶, ·, ¸, ¹, º, », ¼, ½, ¾, ¿, À, +Á, Â, Ã, Ä, Å, Æ, Ç, È, É, Ê, Ë, Ì, Í, Î, Ï, Ð, Ñ, Ò, Ó, Ô, Õ, Ö, ×, Ø, +Ù, Ú, Û, Ü, Ý, Þ, ß, à, á, â, ã, ä, å, æ, ç, è, é, ê, ë, ì, í, î, ï, ð, +ñ, ò, ó, ô, õ, ö, ÷, ø, ù, ú, û, ü, ý, þ, ÿ + +(This is basically all of the latin-1 character set without control +character, whitespace, the various brackets, double quotes and +semicolon). + +Of these, only |, \', ', ,, and # may not be the first character of the +symbol's name (but they *are* allowed as subsequent letters). + +I.e. these are all legal symbols: foo, foo,, µ#, ±1, 451°F. + +Symbols can be explicitly constructed by wrapping their name in vertical +bars, e.g. |foo|, |symbol name with spaces|. In this case the name can +contain any character of in the range from 0 to 255 (or even none, +i.e. || is a valid symbol). The vertical bar in the symbol name needs +to be escaped: |symbol with a vertical bar \| in its name| (similarly +you will obviously have to escape the escape character as well). + + +Comments +~~~~~~~~ + +Comments come in two forms: line comments and block comments. + +Line comments start with a semicolon (;) and finish with the end of the +line. + +Block comments are written as #| comment text |# where the comment text +may span multiple lines but my not contain another block comment, +i.e. it may not contain the character sequence #|. + + +Evaluation While Reading +~~~~~~~~~~~~~~~~~~~~~~~~ + +#.(... some expression ...). E.g. '#.(+ 1 1) will evaluate the (+ 1 1) +while it reads the expression and then be effectively '2. -#b #o #d #x #23r - Based integers -#(e e ... ) - Tuple constants -#b(e e ... ) - Binary constants, e ... are valid literals segments -#m(k v ... ) - Map constants, k v are keys and values -[ ... ] - Allowed as alternative to ( ... ) Supported Core forms -------------------- @@ -98,7 +313,9 @@ (fun func arity) - fun func/arity (fun mod func arity) - fun mod:func/arity (lc (qual ...) ...) - [ expr || qual ... ] +(list-comp (qual ...) ...) (bc (qual ...) ...) - << expr || qual ... >> +(binary-comp (qual ...) ...) (match-spec ...) - ets:fun2ms(fun ( ) -> end) Common Lisp inspired macros @@ -179,7 +396,7 @@ Guards ------ -Wherever a pattern occurs (let, case, receive, lc, etc.) it can be +Wherever a pattern occurs (in let, case, receive, lc, etc.) it can be followed by an optional guard which has the form (when test ...). Guard tests are the same as in vanilla Erlang and can contain the following guard expressions: @@ -224,8 +441,9 @@ (defun foo (x y) "The max function." - (flet ((m (a b) "Local comment." - (if (>= a b) a b))) + (flet ((m (a b) + "Local comment." + (if (>= a b) a b))) (m x y))) Bindings and Scoping @@ -416,8 +634,9 @@ (defun foo (x y) "The max function." - (macrolet ((m (a b) "Poor macro definition." - `(if (>= ,a ,b) ,a ,b))) + (macrolet ((m (a b) + "Poor macro definition." + `(if (>= ,a ,b) ,a ,b))) (m x y))) Extended cond @@ -571,12 +790,14 @@ list comprehensions is: (lc (qual ...) expr ... ) +(list-comp (qual ...) expr ... ) where the final expr is used to generate the elements of the list. The syntax for binary comprehensions is: (bc (qual ...) expr ... ) +(binary-comp (qual ...) expr ... ) where the final expr is a bitseg expr and is used to generate the elements of the binary. @@ -733,6 +954,131 @@ (eval `(let ((foo ,foo)) ,expr)) +Supplemental Common Lisp Functions +---------------------------------- + +LFE provides the module cl which contains the following functions +which closely mirror functions defined in the Common Lisp +Hyperspec. Note that the following functions use zero-based indices, +like Common Lisp. A major difference is that the boolean values are +the LFE 'true and 'false. Otherwise the definitions closely follow the +CL definitions and won't be documented here. + +cl:make-lfe-bool cl-value +cl:make-cl-bool lfe-bool + +cl:mapcar function list +cl:maplist function list +cl:mapc function list +cl:mapl function list + +cl:symbol-plist symbol +cl:symbol-name symbol +cl:get symbol pname +cl:get symbol pname default +cl:getl symbol pname-list +cl:putprop symbol value pname +cl:remprop symbol pname + +cl:getf plist pname +cl:getf plist pname default +cl:putf plist value pname This does not exist in CL +cl:remf plist pname +cl:get-properties plist pname-list + +cl:elt index sequence +cl:length sequence +cl:reverse sequence +cl:some predicate sequence +cl:every predicate sequence +cl:notany predicate sequence +cl:notevery predicate sequence +cl:reduce function sequence +cl:reduce function sequence 'initial-value x +cl:reduce function sequence 'from-end 'true +cl:reduce function sequence 'initial-value x 'from-end 'true + +cl:remove item sequence +cl:remove-if predicate sequence +cl:remove-if-not predicate sequence +cl:remove-duplicates sequence + +cl:find item sequence +cl:find-if predicate sequence +cl:find-if-not predicate sequence +cl:find-duplicates sequence +cl:position item sequence +cl:position-if predicate sequence +cl:position-if-not predicate sequence +cl:position-duplicates sequence +cl:count item sequence +cl:count-if predicate sequence +cl:count-if-not predicate sequence +cl:count-duplicates sequence + +cl:car list +cl:first list +cl:cdr list +cl:rest list +cl:nth index list +cl:nthcdr index list +cl:last list +cl:butlast list + +cl:subst new old tree +cl:subst-if new test tree +cl:subst-if-not new test tree +cl:sublis alist tree + +cl:member item list +cl:member-if predicate list +cl:member-if-not predicate list +cl:adjoin item list +cl:union list list +cl:intersection list list +cl:set-difference list list +cl:set-exclusive-or list list +cl:subsetp list list + +cl:acons key data alist +cl:pairlis list list +cl:pairlis list list alist +cl:assoc key alist +cl:assoc-if predicate alost +cl:assoc-if-not predicate alost +cl:rassoc key alist +cl:rassoc-if predicate alost +cl:rassoc-if-not predicate alost + +cl:type-of object +cl:coerce object type + +Furthmore, there is an include file which developers may which to utilize in +their LFE programs: (include-lib "lfe/include/cl.lfe"). Currently this offers +Common Lisp predicates, but may include other useful macros and functions in +the future. The provided predicate macros wrap the various is_* Erlang +functions; since these are expanded at compile time, they are usable in guards. +The include the following: + +(alivep x) +(atomp x) +(binaryp x) +(bitstringp x) +(boolp x) and (booleanp x) +(builtinp x) +(floatp x) +(funcp x) and (functionp x) +(intp x) and (integerp x) +(listp x) +(mapp x) +(numberp x) +(pidp x) +(process-alive-p x) +(recordp x tag) +(recordp x tag size) +(refp x) and (referencep x) +(tuplep x) + Notes -----
View file
lfe-0.9.2.tar.gz/ebin/lfe.app -> lfe-1.0.tar.gz/ebin/lfe.app
Changed
@@ -1,10 +1,11 @@ {application,lfe, [{description,"Lisp Flavored Erlang (LFE)"}, - {vsn,"0.9.2"}, - {modules,[lfe_bits,lfe_codegen,lfe_comp,lfe_env,lfe_eval, - lfe_gen,lfe_init,lfe_io,lfe_io_format,lfe_io_pretty, - lfe_lib,lfe_lint,lfe_macro,lfe_macro_include, - lfe_macro_record,lfe_ms,lfe_parse,lfe_pmod,lfe_qlc, - lfe_scan,lfe_shell,lfe_trans,lfescript]}, + {vsn,"0.10.1"}, + {modules,[cl,lfe_bits,lfe_codegen,lfe_comp,lfe_edlin_expand, + lfe_env,lfe_eval,lfe_gen,lfe_init,lfe_io, + lfe_io_format,lfe_io_pretty,lfe_io_write,lfe_lib, + lfe_lint,lfe_macro,lfe_macro_include,lfe_macro_record, + lfe_ms,lfe_parse,lfe_pmod,lfe_qlc,lfe_scan,lfe_shell, + lfe_trans,lfescript,sune]}, {registered,[]}, {applications,[kernel,stdlib,compiler]}]}.
View file
lfe-0.9.2.tar.gz/emacs/inferior-lfe.el -> lfe-1.0.tar.gz/emacs/inferior-lfe.el
Changed
@@ -1,3 +1,5 @@ +;;; inferior-lfe.el --- Inferior Lisp Flavoured Erlang mode + ;; Copyright (c) 2012-2013 Robert Virding ;; ;; Licensed under the Apache License, Version 2.0 (the "License"); @@ -12,10 +14,10 @@ ;; See the License for the specific language governing permissions and ;; limitations under the License. -;;; inferior-lfe.el --- Inferior Lisp Flavoured Erlang mode ;;; Author Robert Virding -;;; -;;; Copied from inf-lisp and modified for LFE. + +;;; Commentary: +;; Copied from inf-lisp and modified for LFE. ;;; Code: @@ -26,6 +28,7 @@ (let ((map (copy-keymap comint-mode-map))) (set-keymap-parent map lisp-mode-shared-map) (define-key map "\C-x\C-e" 'lfe-eval-last-sexp) + (define-key map "\C-c\M-o" 'inferior-lfe-clear-buffer) map) "Keymap for inferior LFE mode.") @@ -35,7 +38,7 @@ ;; (set-keymap-parent inferior-lfe-mode-map lisp-mode-shared-map) ;; (define-key inferior-lfe-mode-map "\C-x\C-e" 'lfe-eval-last-sexp)) -(define-key lfe-mode-map "\C-x\C-e" 'lfe-eval-last-sexp) ;Gnu convention +(define-key lfe-mode-map "\C-x\C-e" 'lfe-eval-last-sexp) ; GNU convention (define-key lfe-mode-map "\C-c\C-r" 'lfe-eval-region) (define-key lfe-mode-map "\C-c\C-z" 'switch-to-lfe) @@ -68,8 +71,7 @@ \\{inferior-lfe-mode-map} Customization: Entry to this mode runs the hooks on `comint-mode-hook' and -`inferior-lfe-mode-hook' (in that order). -" +`inferior-lfe-mode-hook' (in that order)." (interactive) (delay-mode-hooks (comint-mode)) (setq major-mode 'inferior-lfe-mode) @@ -78,12 +80,15 @@ (lfe-mode-variables) (use-local-map inferior-lfe-mode-map) (setq comint-prompt-regexp inferior-lfe-prompt) + (setq comint-prompt-read-only t) (setq comint-input-filter (function lfe-input-filter)) (setq comint-get-old-input (function lfe-get-old-input)) (setq comint-process-echoes t) (run-mode-hooks 'inferior-lfe-mode-hook)) (defun lfe-input-filter (str) + "Predicate for filtering additions to input history. +Return nil if `STR` matches `inferior-lfe-filter-regexp', otherwise t." (not (string-match inferior-lfe-filter-regexp str))) (defun lfe-get-old-input () @@ -95,28 +100,30 @@ ;;;###autoload (defun inferior-lfe (cmd) - "Run an inferior LFE process, input and output via a buffer `*inferior-lfe*'." -;; (interactive (list (if current-prefix-arg -;; (read-string "Run LFE: " inferior-lfe-program) -;; inferior-lfe-program))) -;; (if (not (comint-check-proc "*inferior-lfe*")) -;; (let ((cmdlist (split-string cmd))) -;; (set-buffer (apply (function make-comint) -;; "inferior-lfe" (car cmdlist) nil (cdr cmdlist))) -;; (inferior-lfe-mode))) + "Run an inferior LFE process, input and output via a buffer `*inferior-lfe*'. +If `CMD' is given, use it to start the shell, otherwise: +`inferior-lfe-program' `inferior-lfe-program-options' -env TERM vt100." + ;; (interactive (list (if current-prefix-arg + ;; (read-string "Run LFE: " inferior-lfe-program) + ;; inferior-lfe-program))) + ;; (if (not (comint-check-proc "*inferior-lfe*")) + ;; (let ((cmdlist (split-string cmd))) + ;; (set-buffer (apply (function make-comint) + ;; "inferior-lfe" (car cmdlist) nil (cdr cmdlist))) + ;; (inferior-lfe-mode))) (interactive (list (if current-prefix-arg - (read-string "Run LFE: ") - ()))) + (read-string "Run LFE: ") + ()))) (let (prog opts) (if cmd - (setq prog "sh" - opts (list "-i" "-c" cmd)) + (setq prog "sh" + opts (list "-i" "-c" cmd)) (setq prog inferior-lfe-program - opts (append inferior-lfe-program-options - '("-env" "TERM" "vt100")))) - (when (not (comint-check-proc "*inferior-lfe*")) + opts (append inferior-lfe-program-options + '("-env" "TERM" "vt100")))) + (unless (comint-check-proc "*inferior-lfe*") (set-buffer (apply (function make-comint) - "inferior-lfe" prog nil opts)) + "inferior-lfe" prog nil opts)) (inferior-lfe-mode)) (setq inferior-lfe-buffer "*inferior-lfe*") (pop-to-buffer "*inferior-lfe*"))) @@ -129,8 +136,8 @@ (defalias 'run-lfe 'inferior-lfe) (defun lfe-eval-region (start end &optional and-go) - "Send the current region to the inferior LFE process. -Prefix argument means switch to the LFE buffer afterwards." + "Send the current region (from `START' to `END') to the inferior LFE process. +`AND-GO' means switch to the LFE buffer afterwards." (interactive "r\nP") (comint-send-region (inferior-lfe-proc) start end) (comint-send-string (inferior-lfe-proc) "\n") @@ -138,37 +145,45 @@ (defun lfe-eval-last-sexp (&optional and-go) "Send the previous sexp to the inferior LFE process. -Prefix argument means switch to the LFE buffer afterwards." +`AND-GO' means switch to the LFE buffer afterwards." (interactive "P") (lfe-eval-region (save-excursion (backward-sexp) (point)) (point) and-go)) (defun switch-to-lfe (eob-p) "Switch to the inferior Lisp process buffer. -With argument, positions cursor at end of buffer." +When `EOB-P' is given, position cursor at end of buffer." (interactive "P") (if (get-buffer-process inferior-lfe-buffer) (let ((pop-up-frames - ;; Be willing to use another frame - ;; that already has the window in it. - (or pop-up-frames - (get-buffer-window inferior-lfe-buffer t)))) - (pop-to-buffer inferior-lfe-buffer)) - (run-lfe inferior-lfe-program)) + ;; Be willing to use another frame + ;; that already has the window in it. + (or pop-up-frames + (get-buffer-window inferior-lfe-buffer t)))) + (pop-to-buffer inferior-lfe-buffer)) + (run-lfe inferior-lfe-program)) (when eob-p - (push-mark) + (push-mark) (goto-char (point-max)))) +(defun inferior-lfe-clear-buffer () + "Delete the output generated by the LFE process." + (interactive) + (let ((comint-buffer-maximum-size 0)) + (comint-truncate-buffer))) + (defun inferior-lfe-proc () + "Get the LFE subprocess." (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lfe-mode) - (current-buffer) - inferior-lfe-buffer)))) + (current-buffer) + inferior-lfe-buffer)))) (or proc - (error "No LFE subprocess; see variable `inferior-lfe-buffer'")))) + (error "No LFE subprocess; see variable `inferior-lfe-buffer'")))) ;; The end. (provide 'inferior-lfe) (defvar inferior-lfe-load-hook nil - "*Functions to run when Erlang mode is loaded.") + "*Functions to run when Inferior LFE mode is loaded.") (run-hooks 'inferior-lfe-load-hook) +;;; inferior-lfe.el ends here
View file
lfe-1.0.tar.gz/emacs/lfe-indent.el
Added
@@ -0,0 +1,198 @@ +;;; lfe-indent.el --- Lisp Flavoured Erlang indent mode + +;; Copyright (c) 2015 Robert Virding +;; +;; Licensed under the Apache License, Version 2.0 (the "License"); +;; you may not use this file except in compliance with the License. +;; You may obtain a copy of the License at +;; +;; http://www.apache.org/licenses/LICENSE-2.0 +;; +;; Unless required by applicable law or agreed to in writing, software +;; distributed under the License is distributed on an "AS IS" BASIS, +;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;; See the License for the specific language governing permissions and +;; limitations under the License. + +;;; Author Robert Virding + +;;; Commentary: +;; Copied from `lisp-mode' and modified for LFE. + +;;; Code: + +(require 'lisp-mode) +(require 'lfe-mode) + +;;; Lisp indent + +(defvar calculate-lisp-indent-last-sexp) + +(defun lfe-indent-function (indent-point state) + "If this function is the value of `lisp-indent-function' then +`calculate-lisp-indent' will call it to determine if the +arguments of a LFE function call should be indented specially. + +INDENT-POINT is the position where the user typed TAB, or equivalent. +Point is located at the point to indent under; +`STATE' is the `parse-partial-sexp' state for that position. + +Copied from function `lisp-indent-function', but with gets of +lfe-indent-{function,hook} and it uses `lfe-body-indent'." + (let ((normal-indent (current-column))) + (goto-char (1+ (elt state 1))) + (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) + (if (and (elt state 2) + (not (looking-at "\\sw\\|\\s_"))) + ;; car of form doesn't seem to be a symbol + (progn + (if (not (> (save-excursion (forward-line 1) (point)) + calculate-lisp-indent-last-sexp)) + (progn (goto-char calculate-lisp-indent-last-sexp) + (beginning-of-line) + (parse-partial-sexp (point) + calculate-lisp-indent-last-sexp 0 t))) + ;; Indent under the list or under the first sexp on the same + ;; line as calculate-lisp-indent-last-sexp. Note that first + ;; thing on that line has to be complete sexp since we are + ;; inside the innermost containing sexp. + (backward-prefix-chars) + (current-column)) + (let ((function (buffer-substring (point) + (progn (forward-sexp 1) (point)))) + method) + ;; Don't use function-get here for backwards compatibility. + (setq method (or (get (intern-soft function) 'lfe-indent-function) + (get (intern-soft function) 'lfe-indent-hook))) + (cond ((or (eq method 'defun) + (and (null method) + (> (length function) 3) + (string-match "\\`def" function))) + (lfe-indent-defform state indent-point)) + ((integerp method) + (lfe-indent-specform method state + indent-point normal-indent)) + (method + (funcall method state indent-point normal-indent))))))) + +(defcustom lfe-body-indent 2 + "Number of columns to indent the second line of a `(def...)' form." + :group 'lfe + :type 'integer) +(put 'lfe-body-indent 'safe-local-variable 'integerp) + +(defun lfe-indent-specform (count state indent-point normal-indent) + (let ((containing-form-start (elt state 1)) + (i count) + body-indent containing-form-column) + ;; Move to the start of containing form, calculate indentation + ;; to use for non-distinguished forms (> count), and move past the + ;; function symbol. lfe-indent-function guarantees that there is at + ;; least one word or symbol character following open paren of containing + ;; form. + (goto-char containing-form-start) + (setq containing-form-column (current-column)) + (setq body-indent (+ lfe-body-indent containing-form-column)) + (forward-char 1) + (forward-sexp 1) + ;; Now find the start of the last form. + (parse-partial-sexp (point) indent-point 1 t) + (while (and (< (point) indent-point) + (condition-case () + (progn + (setq count (1- count)) + (forward-sexp 1) + (parse-partial-sexp (point) indent-point 1 t)) + (error nil)))) + ;; Point is sitting on first character of last (or count) sexp. + (if (> count 0) + ;; A distinguished form. If it is the first or second form use double + ;; lfe-body-indent, else normal indent. With lfe-body-indent bound + ;; to 2 (the default), this just happens to work the same with if as + ;; the older code, but it makes unwind-protect, condition-case, + ;; with-output-to-temp-buffer, et. al. much more tasteful. The older, + ;; less hacked, behavior can be obtained by replacing below with + ;; (list normal-indent containing-form-start). + (if (<= (- i count) 1) + (list (+ containing-form-column (* 2 lfe-body-indent)) + containing-form-start) + (list normal-indent containing-form-start)) + ;; A non-distinguished form. Use body-indent if there are no + ;; distinguished forms and this is the first undistinguished form, + ;; or if this is the first undistinguished form and the preceding + ;; distinguished form has indentation at least as great as body-indent. + (if (or (and (= i 0) (= count 0)) + (and (= count 0) (<= body-indent normal-indent))) + body-indent + normal-indent)))) + +(defun lfe-indent-defform (state indent-point) + (goto-char (car (cdr state))) + (forward-line 1) + (if (> (point) (car (cdr (cdr state)))) + (progn + (goto-char (car (cdr state))) + (+ lfe-body-indent (current-column))))) + +;;; Indentation rule helpers +;; Modified from `clojure-mode'. + +(defun put-lfe-indent (sym indent) + "Instruct `lfe-indent-function' to indent the body of `SYM' by `INDENT'." + (put sym 'lfe-indent-function indent)) + +(defmacro define-lfe-indent (&rest kvs) + "Call `put-lfe-indent' on a series, `KVS'." + `(progn + ,@(mapcar (lambda (x) + `(put-lfe-indent (quote ,(car x)) ,(cadr x))) + kvs))) + +;;; Special indentation rules +;; "def" anything is already fixed! + +;; (define-lfe-indent (begin 0)), say, causes begin to be indented +;; like defun if the first form is placed on the next line, otherwise +;; it is indented like any other form (i.e. forms line up under first). + +(define-lfe-indent + (: 2) + (after 1) + (bc 1) + (binary-comp 1) + (call 2) + (case 1) + (catch 0) + (do 2) + (eval-when-compile 0) + (flet 1) + (flet* 1) + (fletrec 1) + (if 1) + (lambda 1) + (let 1) + (let* 1) + (let-function 1) + (letrec-function 1) + (let-macro 1) + (lc 1) + (list-comp 1) + (macrolet 1) + (match-lambda 0) + (match-spec 0) + (prog1 1) + (prog2 2) + (progn 0) + (receive 0) + (try 1) + (when 0) + (syntaxlet 1) + + (defflavor 3) ;This doesn't behave like other def's + + ;; Old style forms. + (begin 0) + (let-syntax 1) + (syntax-rules 0) + (macro 0) + )
View file
lfe-0.9.2.tar.gz/emacs/lfe-mode.el -> lfe-1.0.tar.gz/emacs/lfe-mode.el
Changed
@@ -1,6 +1,6 @@ ;;; lfe-mode.el --- Lisp Flavoured Erlang mode -;; Copyright (c) 2012-2013 Robert Virding +;; Copyright (c) 2012-2015 Robert Virding ;; ;; Licensed under the Apache License, Version 2.0 (the "License"); ;; you may not use this file except in compliance with the License. @@ -15,13 +15,24 @@ ;; limitations under the License. ;;; Author Robert Virding -;;; -;;; Copied from lisp-mode and scheme-mode and modified for LFE. + +;;; Commentary: +;; Copied from `lisp-mode' and modified for LFE. ;;; Code: (require 'lisp-mode) +(defgroup lfe nil + "LFE support." + :group 'lisp + :group 'languages) + +(defvar prettify-symbols-alist ()) + +(defconst lfe--prettify-symbols-alist '(("lambda" . ?λ)) + "Prettfy symbols alist user in Lisp Flavoured Erlang mode.") + (defvar lfe-mode-syntax-table (let ((table (copy-syntax-table lisp-mode-syntax-table))) ;; Like scheme we allow [ ... ] as alternate parentheses. @@ -30,10 +41,6 @@ table) "Syntax table in use in Lisp Flavoured Erlang mode buffers.") -;; (setq lfe-mode-syntax-table ()) -;; (unless lfe-mode-syntax-table -;; (setq lfe-mode-syntax-table (copy-syntax-table lisp-mode-syntax-table))) - (defvar lfe-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map lisp-mode-shared-map) @@ -41,25 +48,21 @@ map) "Keymap for Lisp Flavoured Erlang mode.") -;; (unless lfe-mode-map -;; (setq lfe-mode-map (copy-keymap lisp-mode-map)) -;; (define-key lfe-mode-map "\e[" 'lfe-insert-brackets)) - -(defun lfe-insert-brackets (&optional arg) - "Enclose following ARG sexps in brackets. -Leave point after open-bracket." - (interactive "P") - (insert-pair arg ?\[ ?\])) - (defvar lfe-mode-abbrev-table () "Abbrev table used in Lisp Flavoured Erlang mode.") (defvar lfe-mode-hook nil "*Hook for customizing Inferior LFE mode.") +(defun lfe-insert-brackets (&optional arg) + "Enclose following `ARG' sexps in brackets. +Leave point after open-bracket." + (interactive "P") + (insert-pair arg ?\[ ?\])) + ;;;###autoload (defun lfe-mode () - "Major mode for editing Lisp Flavoured Erlang. It's just like lisp mode. + "Major mode for editing Lisp Flavoured Erlang. It's just like `lisp-mode'. Other commands: \\{lfe-mode-map}" @@ -69,13 +72,14 @@ (setq mode-name "LFE") (lfe-mode-variables) (use-local-map lfe-mode-map) -;; ;; For making font-lock case independant, which LFE isn't. -;; (make-local-variable 'font-lock-keywords-case-fold-search) -;; (setq font-lock-keywords-case-fold-search t) + ;; ;; For making font-lock case independent, which LFE isn't. + ;; (make-local-variable 'font-lock-keywords-case-fold-search) + ;; (setq font-lock-keywords-case-fold-search t) (setq imenu-case-fold-search t) (run-mode-hooks 'lfe-mode-hook)) (defun lfe-mode-variables () + "Variables for LFE modes." (set-syntax-table lfe-mode-syntax-table) (setq local-abbrev-table lfe-mode-abbrev-table) (make-local-variable 'paragraph-start) @@ -108,13 +112,14 @@ ;; after either a non-backslash or the line beginning. (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") (make-local-variable 'comment-add) - (setq comment-add 1) ;default to `;;' in comment-region + (setq comment-add 1) ;default to `;;' in comment-region (make-local-variable 'comment-column) (setq comment-column 40) (make-local-variable 'comment-indent-function) (setq comment-indent-function 'lisp-comment-indent) (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments t) + ;; Make lisp-indent-line call lfe-indent-line. (make-local-variable 'lisp-indent-function) (set lisp-indent-function 'lfe-indent-function) (make-local-variable 'imenu-generic-expression) @@ -123,36 +128,92 @@ (setq multibyte-syntax-as-symbol t) (make-local-variable 'font-lock-defaults) (setq font-lock-defaults - '((lfe-font-lock-keywords - lfe-font-lock-keywords-1 lfe-font-lock-keywords-2) - nil nil (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun - (font-lock-mark-block-function . mark-defun)))) + '((lfe-font-lock-keywords + lfe-font-lock-keywords-1 lfe-font-lock-keywords-2) + nil nil (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun + (font-lock-mark-block-function . mark-defun) + (font-lock-syntactic-face-function + . lisp-font-lock-syntactic-face-function))) + ;; Don't use seq-local here for backwards compatibility. + (make-local-variable 'prettify-symbols-alist) + (setq prettify-symbols-alist lfe--prettify-symbols-alist)) -;; Font locking +;;; Font locking -(defconst lfe-font-lock-keywords-1 +(defconst lfe-font-lock-basic-type-keywords + (eval-when-compile + (list + (concat + "(\\(define-\\(module\\|record\\)\\)\\>" + ;; Any whitespace and declared object. + "[ \t]*(?" + "\\(\\sw+\\)?") + '(1 font-lock-keyword-face) + '(3 font-lock-type-face nil t)) + ) + "LFE basic type definition expressions") + +(defconst lfe-font-lock-basic-function-keywords + (eval-when-compile + (list + (concat + "(\\(define\\(-function\\|-macro\\|-syntax\\)?\\)\\>" + ;; Any whitespace and declared object. + "[ \t]*(?" + "\\(\\sw+\\)?") + '(1 font-lock-keyword-face) + '(3 font-lock-function-name-face nil t)) + ) + "LFE basic function definition expressions") + +(defconst lfe-font-lock-new-type-keywords + (eval-when-compile + (list + (concat + "(\\(def\\(module\\|record\\)\\)\\>" + ;; Any whitespace and declared object. + "[ \t]*(?" + "\\(\\sw+\\)?") + '(1 font-lock-keyword-face) + '(3 font-lock-type-face nil t)) + ) + "LFE new style type expressions") + +(defconst lfe-font-lock-new-function-keywords + (eval-when-compile + (list + (concat + ;; No method here! + "(\\(def\\(un\\|macro\\|syntax\\|test\\)\\)\\>" + ;; Any whitespace and declared object. + "[ \t]*(?" + "\\(\\sw+\\)?") + '(1 font-lock-keyword-face) + '(3 font-lock-function-name-face nil t)) + ) + "LFE new style function expressions") + +(defconst lfe-font-lock-flavor-keywords (eval-when-compile (list - (list (concat "(\\(def\\(" - ;; Base forms and old style names. - "\\(ine\\(-module\\|-function\\|-macro\\|" - "-syntax\\|-record\\)?\\)\\|" - ;; New model function names - "\\(un\\|macro\\|syntax\\)\\|" - ;; New model other names - "\\(module\\)\\|" - "\\(record\\)" - "\\)\\)\\>" - ;; Any whitespace and declared object. - "[ \t]*(?" - "\\(\\sw+\\)?") - '(1 font-lock-keyword-face) - '(8 (cond ((match-beginning 3) font-lock-function-name-face) - ((match-beginning 5) font-lock-function-name-face) - ((match-beginning 6) font-lock-variable-name-face) - (t font-lock-type-face)) - nil t)) - )) + (concat + "(\\(defflavor\\|defmethod\\|endflavor\\)\\>" + ;; Any whitespace and declared object. + "[ \t]*(?" + "\\(\\sw+\\)?") + '(1 font-lock-keyword-face) + '(2 font-lock-type-face nil t)) + ) + "LFE flavor expressions") + +(defconst lfe-font-lock-keywords-1 + (eval-when-compile + (list lfe-font-lock-new-type-keywords + lfe-font-lock-new-function-keywords + lfe-font-lock-basic-type-keywords + lfe-font-lock-basic-function-keywords + lfe-font-lock-flavor-keywords + )) "Subdued expressions to highlight in LFE modes.") (eval-and-compile @@ -164,38 +225,42 @@ (defconst lfe-type-bifs '("abs" "bit_size" "byte_size" "element" "float" "hd" "iolist_size" "length" "make_ref" "setelement" ;"size" - "round" "tl" "trunc" "tuple_size") - "LFE builtin functions (BIFs)")) + "round" "tl" "trunc" "tuple_size" + "car" "cdr" "caar" "cadr" "cdar" "cddr" + ;; Just for the fun of it. + "caaar" "caadr" "cadar" "caddr" "cdaar" "cddar" "cdadr" "cdddr" + "list" "list*" "tuple" "binary" + "map" "mref" "mset" "mupd" "map-get" "map-set" "map-update") + "LFE builtin functions (BIFs) and some type macros") + (defconst lfe-basic-forms + '( + ;; Core forms. + "after" "call" "case" "catch" "define-function" "define-macro" + "funcall" "if" "lambda" + "let" "let-function" "letrec-function" "let-macro" + "match-lambda" "progn" "receive" "try" "when" + "eval-when-compile" "extend-module" + ;; Base macro forms. + "andalso" "bc" "binary-comp" "cond" "do" "flet" "flet*" "fletrec" + "fun" "lc" "list-comp" + "let*" "match-spec" "macrolet" "orelse" "qlc" + ":" "?" "++") + "LFE basic forms")) (defconst lfe-font-lock-keywords-2 - (append lfe-font-lock-keywords-1 + (append + lfe-font-lock-keywords-1 (eval-when-compile (list ;; Control structures. (cons (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" "funcall" "when" "progn" - "eval-when-compile" - ;; Default macros - "caar" "cadr" "cdar" "cddr" - "andalso" "cond" "do" "fun" "list*" "let*" "flet*" "macro" - "orelse" "syntax-rules" "lc" "bc" "flet" "fletrec" - "macrolet" "syntaxlet" "begin" "let-syntax" - ;; Should the map forms be here or as type bifs? - "map" "mref" "mset" "mupd" "map-get" "map-set" "map-update" - "match-spec" "qlc" - ":" "?" "++") t) - "\\>") '(1 font-lock-keyword-face)) + "(" (regexp-opt lfe-basic-forms t) "\\>") + '(1 font-lock-keyword-face)) ;; Type tests. (cons (concat - "(" (regexp-opt (append lfe-type-tests lfe-type-bifs) t) "\\>") + "(" (regexp-opt (append lfe-type-tests lfe-type-bifs) t) "\\>") '(1 font-lock-builtin-face)) ))) "Gaudy expressions to highlight in LFE modes.") @@ -203,92 +268,10 @@ (defvar lfe-font-lock-keywords lfe-font-lock-keywords-1 "Default expressions to highlight in LFE modes.") -(defvar calculate-lisp-indent-last-sexp) - -;; Copied from lisp-indent-function, but with gets of -;; lfe-indent-{function,hook}. -(defun lfe-indent-function (indent-point state) - (let ((normal-indent (current-column))) - (goto-char (1+ (elt state 1))) - (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) - (if (and (elt state 2) - (not (looking-at "\\sw\\|\\s_"))) - ;; car of form doesn't seem to be a symbol - (progn - (if (not (> (save-excursion (forward-line 1) (point)) - calculate-lisp-indent-last-sexp)) - (progn (goto-char calculate-lisp-indent-last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) - calculate-lisp-indent-last-sexp 0 t))) - ;; Indent under the list or under the first sexp on the same - ;; line as calculate-lisp-indent-last-sexp. Note that first - ;; thing on that line has to be complete sexp since we are - ;; inside the innermost containing sexp. - (backward-prefix-chars) - (current-column)) - (let ((function (buffer-substring (point) - (progn (forward-sexp 1) (point)))) - method) - (setq method (or (get (intern-soft function) 'lfe-indent-function) - (get (intern-soft function) 'lfe-indent-hook))) - (cond ((or (eq method 'defun) - (and (null method) - (> (length function) 3) - (string-match "\\`def" function))) - (lisp-indent-defform state indent-point)) - ((integerp method) - (lisp-indent-specform method state - indent-point normal-indent)) - (method - (funcall method state indent-point normal-indent))))))) - - -;; Special indentation rules. "def" anything is already fixed! - -;; (put 'begin 'lfe-indent-function 0), say, causes begin to be indented -;; like defun if the first form is placed on the next line, otherwise -;; it is indented like any other form (i.e. forms line up under first). - -;; Old style forms. -(put 'begin 'lfe-indent-function 0) -(put 'let-syntax 'lfe-indent-function 1) -(put 'syntax-rules 'lfe-indent-function 0) -(put 'macro 'lfe-indent-function 0) -;; New style forms. -;; Core forms. -(put 'progn 'lfe-indent-function 0) -(put 'lambda 'lfe-indent-function 1) -(put 'match-lambda 'lfe-indent-function 0) -(put 'let 'lfe-indent-function 1) -(put 'let-function 'lfe-indent-function 1) -(put 'letrec-function 'lfe-indent-function 1) -(put 'let-macro 'lfe-indent-function 1) -(put 'if 'lfe-indent-function 1) -(put 'case 'lfe-indent-function 1) -(put 'receive 'lfe-indent-function 0) -(put 'catch 'lfe-indent-function 0) -(put 'try 'lfe-indent-function 1) -(put 'after 'lfe-indent-function 1) -(put 'call 'lfe-indent-function 2) -(put 'when 'lfe-indent-function 0) -(put 'eval-when-compile 'lfe-indent-function 0) -;; Core macros. -(put ': 'lfe-indent-function 2) -(put 'let* 'lfe-indent-function 1) -(put 'flet 'lfe-indent-function 1) -(put 'flet* 'lfe-indent-function 1) -(put 'fletrec 'lfe-indent-function 1) -(put 'macrolet 'lfe-indent-function 1) -(put 'syntaxlet 'lfe-indent-function 1) -(put 'do 'lfe-indent-function 2) -(put 'lc 'lfe-indent-function 1) -(put 'bc 'lfe-indent-function 1) -(put 'match-spec 'lfe-indent-function 0) ;;;###autoload -;; Associate ".lfe" with LFE mode. -(add-to-list 'auto-mode-alist '("\\.lfe\\'" . lfe-mode) t) +;; Associate ".lfe{s,sh}?" with LFE mode. +(add-to-list 'auto-mode-alist '("\\.lfe\\(?:s\\|sh\\)\\'" . lfe-mode) t) ;;;###autoload ;; Ignore files ending in ".jam", ".vee", and ".beam" when performing
View file
lfe-0.9.2.tar.gz/emacs/lfe-start.el -> lfe-1.0.tar.gz/emacs/lfe-start.el
Changed
@@ -17,6 +17,7 @@ ;; Declare autoload functions in lfe-mode.el and inferior-lfe.el. (autoload 'lfe-mode "lfe-mode" "Major mode for editing LFE code." t) +(autoload 'lfe-indent-function "lfe-indent" "Indent LFE." t) (autoload 'inferior-lfe-mode "inferior-lfe" "Major mode for interacting with an inferior LFE process." t) (autoload 'inferior-lfe "inferior-lfe" "Run an LFE process." t)
View file
lfe-0.9.2.tar.gz/examples/core-macros.lfe -> lfe-1.0.tar.gz/examples/core-macros.lfe
Changed
@@ -1,4 +1,4 @@ -;; Copyright (c) 2008-2013 Robert Virding +;; Copyright (c) 2008-2015 Robert Virding ;; ;; Licensed under the Apache License, Version 2.0 (the "License"); ;; you may not use this file except in compliance with the License. @@ -68,7 +68,7 @@ (defmacro let* ((cons (cons vb vbs) b) `(let (,vb) (let* ,vbs . ,b))) ((cons () b) `(progn . ,b)) - ((cons vb b) `(let ,vb . b))) ;Pass error to let + ((cons vb b) `(let ,vb . b))) ;Pass error to let (defmacro flet* ((cons (cons fb fbs) b) `(flet (,fb) (flet* ,fbs . ,b))) @@ -107,7 +107,7 @@ ;; Note that we cannot *use* backquote or any macros using ;; backquote in here! It will cause us to loop. (fletrec ((bq-app ;Optimise append - ([(list '++ l) r] (bq-app l r)) ;Catch single unquote-splice + ([(list '++ l) r] (bq-app l r)) ;Catch single comma-at ([() r] r) ([l ()] l) ([(list 'list l) (cons 'list r)] (cons 'list (cons l r))) @@ -122,24 +122,24 @@ ((list 'backquote x) ;; `(list 'backquote ,(bq-expand x (+ n 1))) (list 'list (list 'quote 'backquote) (bq-expand x (+ n 1)))) - ((list 'unquote x) (when (> n 0)) - (bq-cons 'unquote (bq-expand x (- n 1)))) - ((list 'unquote x) (when (=:= n 0)) x) - ((list 'unquote-splicing . x) (when (> n 0)) - (bq-cons (list 'quote 'unquote-splicing) (bq-expand x (- n 1)))) + ((list 'comma x) (when (> n 0)) + (bq-cons (list 'quote 'comma) (bq-expand x (- n 1)))) + ((list 'comma x) (when (=:= n 0)) x) + ((cons 'comma-at x) (when (> n 0)) + (bq-cons (list 'quote 'comma-at) (bq-expand x (- n 1)))) ;; The next two cases handle splicing into a list. - (((list 'unquote . x) . y) (when (=:= n 0)) + ((cons (cons 'comma x) y) (when (=:= n 0)) (bq-app (cons 'list x) (bq-expand y 0))) - (((list 'unquote-splicing . x) . y) (when (=:= n 0)) + ((cons (cons 'comma-at x) y) (when (=:= n 0)) (bq-app (cons '++ x) (bq-expand y 0))) ((cons x y) ;The general list case (bq-cons (bq-expand x n) (bq-expand y n))) - (_ (when (is_tuple exp)) + (x (when (is_tuple x)) ;; Tuples need some smartness for efficient code to handle ;; when no splicing so as to avoid list_to_tuple. - (case (bq-expand (tuple_to_list exp) n) - (('list . es) (cons tuple es)) - ((= ('cons . _) e) (list 'list_to_tuple e)))) - (_ (when (is_atom exp)) (list 'quote exp)) - (_ exp)) ;Self quoting + (case (bq-expand (tuple_to_list x) n) + ((cons 'list es) (cons 'tuple es)) + ((= (cons 'cons _) e) (list 'list_to_tuple e)))) + (x (when (is_atom x)) (list 'quote x)) + (x x)) ;Self quoting )))
View file
lfe-0.9.2.tar.gz/examples/internal-state.lfe -> lfe-1.0.tar.gz/examples/internal-state.lfe
Changed
@@ -1,4 +1,4 @@ -;; Copyright (c) 2013 Duncan McGreggor <oubiwann@cogitat.io> +;; Copyright (c) 2013, 2015 Duncan McGreggor <oubiwann@gmail.com> ;; ;; Licensed under the Apache License, Version 2.0 (the "License"); ;; you may not use this file except in compliance with the License. @@ -22,41 +22,40 @@ ;; ;; To use the code below in LFE, do the following: ;; -;; $ cd examples -;; $ ../bin/lfe -pa ../ebin +;; $ ./bin/lfe -pa ./ebin ;; -;; > (slurp '"internal-state.lfe") +;; > (slurp "examples/internal-state.lfe") ;; #(ok internal-state) -;; > (set account (new-account '"Alice" 100.00 0.06)) +;; > (set acct (new-account "Alice" 100.00 0.06)) ;; #Fun<lfe_eval.10.53503600> -;; > (name account) +;; > (send acct 'name) ;; "Alice" -;; > (balance account) +;; > (send acct 'balance) ;; 100.0 -;; > (set account (interest account)) +;; > (set acct (send acct 'apply-interest)) ;; #Fun<lfe_eval.10.53503600> -;; > (balance account) +;; > (send acct 'balance) ;; 106.0 -;; > (set account (withdraw account 54.90)) +;; > (set acct (send acct 'withdraw 54.90)) ;; #Fun<lfe_eval.10.53503600> -;; > (set account (withdraw account 54.90)) +;; > (set acct (send acct 'withdraw 54.90)) ;; exception error: insufficient-funds ;; -;; > (balance account) +;; > (send acct 'balance) ;; 51.1 -;; > (set account (deposit account 1000)) +;; > (set acct (send acct 'deposit 1000)) ;; #Fun<lfe_eval.10.53503600> -;; > (set account (withdraw account 54.90)) +;; > (set acct (send acct 'withdraw 54.90)) ;; #Fun<lfe_eval.10.53503600> -;; > (set account (withdraw account 54.90)) +;; > (set acct (send acct 'withdraw 54.90)) ;; #Fun<lfe_eval.10.53503600> -;; > (set account (withdraw account 54.90)) +;; > (set acct (send acct 'withdraw 54.90)) ;; #Fun<lfe_eval.10.53503600> -;; > (balance account) +;; > (send acct 'balance) ;; 886.4 -;; > (set account (interest account)) +;; > (set acct (send acct 'apply-interest)) ;; #Fun<lfe_eval.10.53503600> -;; > (balance account) +;; > (send acct 'balance) ;; 939.584 (defmodule internal-state @@ -68,38 +67,85 @@ ('withdraw (lambda (amt) (if (=< amt balance) (new-account name (- balance amt) interest-rate) - (: erlang error 'insufficient-funds)))) + (error 'insufficient-funds)))) ('deposit (lambda (amt) (new-account name (+ balance amt) interest-rate))) ('balance (lambda () balance)) ('name (lambda () name)) - ('interest (lambda () + ('apply-interest (lambda () (new-account name (+ balance (* balance interest-rate)) interest-rate)))))) -(defun get-method (object command) - (funcall object command)) +(defun send (object method-name) + "This is a generic function, used to call into the given object (class + instance)." + (funcall (funcall object method-name))) -(defun send (object command arg) - (funcall (get-method object command) arg)) +(defun send (object method-name arg) + "This is a generic function, used to call into the given object (class + instance)." + (funcall (funcall object method-name) arg)) -(defun withdraw (object amt) - "Returns an updated account object." - (funcall (get-method object 'withdraw) amt)) +;; It is also possible to create functionally equivalent code using LFE +;; processes. The code below would then be used in the following manner: +;; +;; > (set acct (init-account "Alice" 1000 0.1)) +;; <0.37.0> +;; > (snd acct 'name) +;; "Alice" +;; > (snd acct 'balance) +;; 1000 +;; > (snd acct 'apply-interest) +;; 1.1e3 +;; > (snd acct 'deposit 1000) +;; 2.1e3 +;; > (snd acct 'balance) +;; 2.1e3 +;; > (snd acct 'withdraw 2000) +;; 100.0 +;; > (snd acct 'withdraw 101) +;; #(error insufficient-funds) -(defun deposit (object amt) - "Returns an updated account object." - (funcall (get-method object 'deposit) amt)) +(defun account-class (name balance interest-rate) + (receive + (`#(,method name ()) + (! method `#(ok ,name)) + (account-class name balance interest-rate)) + (`#(,method balance ()) + (! method `#(ok ,balance)) + (account-class name balance interest-rate)) + (`#(,method deposit (,amt)) + (let ((new-balance (+ balance amt))) + (! method `#(ok ,new-balance)) + (account-class name new-balance interest-rate))) + (`#(,method apply-interest ()) + (let ((new-balance (+ balance (* balance interest-rate)))) + (! method `#(ok ,new-balance)) + (account-class name new-balance interest-rate))) + (`#(,method withdraw (,amt)) + (let ((new-balance (- balance amt))) + (cond ((< new-balance 0) + (! method #(error insufficient-funds)) + (account-class name balance interest-rate)) + ('true + (! method `#(ok ,new-balance)) + (account-class name new-balance interest-rate))))))) -(defun balance (object) - "Returns a float representing the balance." - (funcall (get-method object 'balance))) +(defun init-account (name balance interest-rate) + (spawn (lambda () + (account-class name balance interest-rate)))) -(defun name (object) - "Returns a string represnting the account holder." - (funcall (get-method object 'name))) +(defun snd (object method-name) + (snd object method-name '())) -(defun interest (object) - "Returns an updated account object." - (funcall (get-method object 'interest))) +(defun snd + ((object method-name arg) (when (not (is_list arg))) + (snd object method-name `(,arg))) + ((object method-name args) + (! object `#(,(self) ,method-name ,args)) + (receive + (`#(ok ,result) + result) + (error + error))))
View file
lfe-0.9.2.tar.gz/examples/object-via-closure.lfe -> lfe-1.0.tar.gz/examples/object-via-closure.lfe
Changed
@@ -1,4 +1,4 @@ -;; Copyright (c) 2013 Duncan McGreggor <oubiwann@cogitat.io> +;; Copyright (c) 2013 Duncan McGreggor <oubiwann@gmail.com> ;; ;; Licensed under the Apache License, Version 2.0 (the "License"); ;; you may not use this file except in compliance with the License. @@ -26,49 +26,46 @@ ;; ;; To use the code below in LFE, do the following: ;; -;; $ cd examples -;; $ ../bin/lfe -pa ../ebin +;; $ .bin/lfe -pa .ebin ;; ;; Load the file and create a fish-class instance: ;; -;; > (slurp '"object-via-closure.lfe") -;; #(ok object) -;; > (set mommy-fish (fish-class '"Carp")) +;; > (slurp "examples/object-via-closure.lfe") +;; #(ok object-via-closure) +;; > (set mommy-fish (fish-class "Carp")) ;; #Fun<lfe_eval.10.91765564> ;; ;; Execute some of the basic methods: ;; -;; > (get-species mommy-fish) +;; > (send mommy-fish 'species) ;; "Carp" -;; > (move mommy-fish 17) +;; > (send mommy-fish 'move 17) ;; The Carp swam 17 feet! ;; ok -;; > (get-id mommy-fish) +;; > (send mommy-fish 'id) ;; "47eebe91a648f042fc3fb278df663de5" ;; ;; Now let's look at "modifying" state data (e.g., children counts): ;; -;; > (get-children mommy-fish) +;; > (send mommy-fish 'children) ;; () -;; > (get-children-count mommy-fish) +;; > (send mommy-fish 'children-count) ;; 0 -;; > (set (mommy-fish baby-fish-1) (reproduce mommy-fish)) +;; > (set `(,mommy-fish ,baby-fish-1) (send mommy-fish 'reproduce)) ;; (#Fun<lfe_eval.10.91765564> #Fun<lfe_eval.10.91765564>) -;; > (get-id mommy-fish) +;; > (send mommy-fish 'id) ;; "47eebe91a648f042fc3fb278df663de5" -;; > (get-id baby-fish-1) +;; > (send baby-fish-1 'id) ;; "fdcf35983bb496650e558a82e34c9935" -;; > (get-children-count mommy-fish) +;; > (send mommy-fish 'children-count) ;; 1 -;; > (set (mommy-fish baby-fish-2) (reproduce mommy-fish)) +;; > (set `(,mommy-fish ,baby-fish-2) (send mommy-fish 'reproduce)) ;; (#Fun<lfe_eval.10.91765564> #Fun<lfe_eval.10.91765564>) -;; > (get-id mommy-fish) -;; "47eebe91a648f042fc3fb278df663de5" -;; > (get-id baby-fish-2) +;; > (send baby-fish-2 'id) ;; "3e64e5c20fb742dd88dac1032749c2fd" -;; > (get-children-count mommy-fish) +;; > (send mommy-fish 'children-count) ;; 2 -;; > (get-info mommy-fish) +;; > (send mommy-fish 'info) ;; id: "47eebe91a648f042fc3fb278df663de5" ;; species: "Carp" ;; children: ["fdcf35983bb496650e558a82e34c9935", @@ -91,16 +88,15 @@ besides fish-class/1, so it's not strictly necessary. When the id isn't known, generate one." - (let* (((binary (id (size 128))) (: crypto rand_bytes 16)) + (let* (((binary (id (size 128))) (crypto:rand_bytes 16)) (formatted-id (car - (: io_lib format - '"~32.16.0b" (list id))))) + (io_lib:format "~32.16.0b" (list id))))) (fish-class species children formatted-id))) (defun fish-class (species children id) "This is the constructor used internally, once the children and fish id are known." - (let ((move-verb '"swam")) + (let ((move-verb "swam")) (lambda (method-name) (case method-name ('id @@ -111,52 +107,32 @@ (lambda (self) children)) ('info (lambda (self) - (: io format - '"id: ~p~nspecies: ~p~nchildren: ~p~n" - (list (get-id self) - (get-species self) - (get-children self))))) + (io:format "id: ~p~nspecies: ~p~nchildren: ~p~n" + `(,(send self 'id) + ,(send self 'species) + ,(send self 'children))))) ('move (lambda (self distance) - (: io format - '"The ~s ~s ~p feet!~n" - (list species move-verb distance)))) + (io:format "The ~s ~s ~p feet!~n" + `(,species ,move-verb ,distance)))) ('reproduce (lambda (self) (let* ((child (fish-class species)) - (child-id (get-id child)) - (children-ids (: lists append - (list children (list child-id)))) - (parent-id (get-id self)) + (child-id (send child 'id)) + (children-ids (lists:append children `(,child-id))) + (parent-id (send self 'id)) (parent (fish-class species children-ids parent-id))) - (list parent child)))) + `(,parent ,child)))) ('children-count (lambda (self) - (: erlang length children))))))) + (length children))))))) -(defun get-method (object method-name) +(defun send (object method-name) "This is a generic function, used to call into the given object (class instance)." - (funcall object method-name)) - -(defun get-id (object) - "Define object methods." - (funcall (get-method object 'id) object)) - -(defun get-species (object) - (funcall (get-method object 'species) object)) - -(defun get-info (object) - (funcall (get-method object 'info) object)) - -(defun move (object distance) - (funcall (get-method object 'move) object distance)) + (funcall (funcall object method-name) object)) -(defun reproduce (object) - (funcall (get-method object 'reproduce) object)) - -(defun get-children (object) - (funcall (get-method object 'children) object)) - -(defun get-children-count (object) - (funcall (get-method object 'children-count) object)) +(defun send (object method-name arg) + "This is a generic function, used to call into the given object (class + instance)." + (funcall (funcall object method-name) object arg)) \ No newline at end of file
View file
lfe-0.9.2.tar.gz/examples/object-via-process.lfe -> lfe-1.0.tar.gz/examples/object-via-process.lfe
Changed
@@ -1,4 +1,4 @@ -;; Copyright (c) 2013 Duncan McGreggor <oubiwann@cogitat.io> +;; Copyright (c) 2013 Duncan McGreggor <oubiwann@gmail.com> ;; ;; Licensed under the Apache License, Version 2.0 (the "License"); ;; you may not use this file except in compliance with the License. @@ -26,143 +26,112 @@ ;; ;; To use the code below in LFE, do the following: ;; -;; $ cd examples -;; $ ../bin/lfe -pa ../ebin +;; $ ./bin/lfe -pa ./ebin ;; ;; Load the file and create a fish-class instance: ;; -;; > (slurp '"object-via-process.lfe") +;; > (slurp "examples/object-via-process.lfe") ;; #(ok object-via-process) -;; > (set mommy-fish (fish-class '"Carp")) +;; > (set mommy-fish (init-fish "Carp")) ;; <0.33.0> ;; ;; Execute some of the basic methods: ;; -;; > (get-species mommy-fish) +;; > (send mommy-fish 'species) ;; "Carp" -;; > (move mommy-fish 17) -;; The Carp swam 17 feet! -;; ok -;; > (get-id mommy-fish) +;; > (send mommy-fish 'move 17) +;; "The Carp swam 17 feet!" +;; > (send mommy-fish 'id) ;; "47eebe91a648f042fc3fb278df663de5" ;; ;; Now let's look at modifying state data (e.g., children counts): ;; -;; > (get-children mommy-fish) +;; > (send mommy-fish 'children) ;; () -;; > (get-children-count mommy-fish) +;; > (send mommy-fish 'children-count) ;; 0 -;; > (set baby-fish-1 (reproduce mommy-fish)) +;; > (set baby-fish-1 (send mommy-fish 'reproduce)) ;; <0.34.0> -;; > (get-id mommy-fish) -;; "47eebe91a648f042fc3fb278df663de5" -;; > (get-id baby-fish-1) +;; > (send baby-fish-1 'id) ;; "fdcf35983bb496650e558a82e34c9935" -;; > (get-children-count mommy-fish) +;; > (send mommy-fish 'children-count) ;; 1 -;; > (set baby-fish-2 (reproduce mommy-fish)) +;; > (set baby-fish-2 (send mommy-fish 'reproduce)) ;; <0.35.0> -;; > (get-id mommy-fish) -;; "47eebe91a648f042fc3fb278df663de5" -;; > (get-id baby-fish-2) +;; > (send baby-fish-2 'id) ;; "3e64e5c20fb742dd88dac1032749c2fd" -;; > (get-children-count mommy-fish) +;; > (send mommy-fish 'children-count) ;; 2 -;; > (get-info mommy-fish) -;; id: 47eebe91a648f042fc3fb278df663de5 -;; species: Carp -;; children: ["fdcf35983bb496650e558a82e34c9935", -;; "3e64e5c20fb742dd88dac1032749c2fd"] -;; ok +;; > (send mommy-fish 'info) +;; (#(id "f05064ffcf92d7b3e72968fd481abbd0") +;; #(species "Carp") +;; #(children +;; ("d53a426c732c938f996a1c2520bb621f" "15fede691ab3f96e9e3df248d37b7b55"))) (defmodule object-via-process (export all)) -(defun fish-class (species) +(defun init-fish (species) "This is the constructor that will be used most often, only requiring that one pass a 'species' string. When the children are not defined, simply use an empty list." - (fish-class species ())) + (init-fish species ())) -(defun fish-class (species children) +(defun init-fish (species children) "This constructor is useful for two reasons: 1) as a way of abstracting out the id generation from the larger constructor, and 2) spawning the 'object loop' code (fish-class/3)." - (let* (((binary (id (size 128))) (: crypto rand_bytes 16)) + (let* (((binary (id (size 128))) (crypto:rand_bytes 16)) (formatted-id (car - (: io_lib format - '"~32.16.0b" (list id))))) - (spawn 'object-via-process - 'fish-class - (list species children formatted-id)))) + (io_lib:format "~32.16.0b" `(,id))))) + (spawn (lambda () + (fish-class species children formatted-id))))) (defun fish-class (species children id) "This function is intended to be spawned as a separate process which is used to track the state of a fish. In particular, fish-class/2 spawns this function (which acts as a loop, pattern matching for messages)." - (let ((move-verb '"swam")) + (let ((move-verb "swam")) (receive - ((tuple caller 'move distance) - (! caller (list species move-verb distance)) + (`#(,caller move ,distance) + (! caller (lists:flatten + (io_lib:format "The ~s ~s ~p feet!" + `(,species ,move-verb ,distance)))) (fish-class species children id)) - ((tuple caller 'species) + (`#(,caller species ()) (! caller species) (fish-class species children id)) - ((tuple caller 'children) + (`#(,caller children ()) (! caller children) (fish-class species children id)) - ((tuple caller 'children-count) + (`#(,caller children-count ()) (! caller (length children)) (fish-class species children id)) - ((tuple caller 'id) - (! caller id) + (`#(,caller id ()) + (! caller (lists:flatten id)) (fish-class species children id)) - ((tuple caller 'info) - (! caller (list id species children)) + (`#(,caller info ()) + (! caller `(#(id ,id) + #(species ,species) + #(children ,children))) (fish-class species children id)) - ((tuple caller 'reproduce) - (let* ((child (fish-class species)) - (child-id (get-id child)) - (children-ids (: lists append - (list children (list child-id))))) - (! caller child) - (fish-class species children-ids id)))))) - -(defun call-method (object method-name) + (`#(,caller reproduce ()) + (let* ((child (init-fish species)) + (child-id (send child 'id)) + (children-ids (lists:append children `(,child-id)))) + (! caller child) + (fish-class species children-ids id)))))) + +(defun send (object method-name) "This is a generic function, used to call into the given object (class instance)." - (! object (tuple (self) method-name)) - (receive - (data data))) + (send object method-name '())) -(defun call-method (object method-name arg) - "Same as above, but with an additional argument." - (! object (tuple (self) method-name arg)) +(defun send (object method-name arg) + "This is a generic function, used to call into the given object (class + instance)." + (! object `#(,(self) ,method-name ,arg)) (receive (data data))) - -(defun get-id (object) - "Define object methods." - (call-method object 'id)) - -(defun get-species (object) - (call-method object 'species)) - -(defun get-info (object) - (let ((data (call-method object 'info))) - (: io format '"id: ~s~nspecies: ~s~nchildren: ~p~n" data))) - -(defun move (object distance) - (let ((data (call-method object 'move distance))) - (: io format '"The ~s ~s ~p feet!~n" data))) - -(defun reproduce (object) - (call-method object 'reproduce)) - -(defun get-children (object) - (call-method object 'children)) - -(defun get-children-count (object) - (call-method object 'children-count))
View file
lfe-1.0.tar.gz/get_maps_opts.escript
Added
@@ -0,0 +1,28 @@ +#! /usr/bin/env escript +%% -*- mode: erlang; indent-tabs-mode: nil -*- +%% Define the makefile variables HAS_MAPS and HAS_FULL_KEYS depending +%% on whether this version of erlang has maps (17) and general map +%% keys (18), or neither. + +-define(MAP_STRING, "#{X => 1}."). +-define(HAS_OPT, "-DHAS_MAPS=true"). +-define(FULL_OPT, "-DHAS_FULL_KEYS=true"). + +main(_) -> + MapsOpts = maps_opts(), + file:write_file("maps_opts.mk", "MAPS_OPTS = " ++ MapsOpts ++ "\n"). + +maps_opts() -> + case erl_scan:string(?MAP_STRING) of + {ok,Ts,_} -> + case erl_parse:parse_exprs(Ts) of + {ok,Es} -> %We have maps! + Binds = [{'X',49}], %We need to bind X + case erl_lint:exprs(Es, Binds) of + {ok,_} -> ?HAS_OPT ++ " " ++ ?FULL_OPT; + {error,_,_} -> ?HAS_OPT + end; + {error,_} -> "" + end; + {error,_,_} -> "" + end.
View file
lfe-1.0.tar.gz/include/cl.lfe
Added
@@ -0,0 +1,99 @@ +;;; Predicates + +(defmacro alivep (x) + `(is_alive)) + +(defmacro atomp (x) + `(is_atom ,x)) + +(defmacro binaryp (x) + `(is_binary ,x)) + +(defmacro bitstringp (x) + `(is_bitstring ,x)) + +(defmacro boolp (x) + `(is_boolean ,x)) + +(defmacro booleanp (x) + `(is_boolean ,x)) + +(defmacro builtinp (mod func arity) + `(erlang:is_builtin ,mod ,func ,arity)) + +(defmacro floatp (x) + `(is_float ,x)) + +(defmacro funcp (x) + `(is_function ,x)) + +(defmacro funcp (x arity) + `(is_function ,x ,arity)) + +(defmacro functionp (x) + `(is_function ,x)) + +(defmacro functionp (x arity) + `(is_function ,x ,arity)) + +(defmacro intp (x) + `(is_integer ,x)) + +(defmacro integerp (x) + `(is_integer ,x)) + +(defmacro listp (x) + `(is_list ,x)) + +(defmacro mapp (x) + `(is_map ,x)) + +(defmacro numberp (x) + `(is_number ,x)) + +(defmacro pidp (x) + `(is_pid ,x)) + +(defmacro portp (x) + `(is_port ,x)) + +(defmacro process-alive-p (pid) + `(is_process_alive ,pid)) + +(defmacro recordp (x rec-tag) + `(is_record ,x ,rec-tag)) + +(defmacro recordp (x rec-tag size) + `(is_record ,x ,rec-tag ,size)) + +(defmacro refp (x) + `(is_reference ,x)) + +(defmacro referencep (x) + `(is_reference ,x)) + +(defmacro tuplep (x) + `(is_tuple ,x)) + +(defmacro vectorp (x) + `(is_tuple ,x)) + +(defun consp + ((`(,a . ,b)) (when (not (is_list b))) + 'true) + ((_) 'false)) + +;;; Constructors + +(defmacro vector args + `(tuple ,@args)) + +;;; List macros + +(defmacro dolist body + (let ((var (caar body)) + (items (cadar body)) + (body (cdr body))) + `(lists:foreach + (lambda (,var) (progn ,@body)) + ,items)))
View file
lfe-0.9.2.tar.gz/rebar.config.script -> lfe-1.0.tar.gz/rebar.config.script
Changed
@@ -1,17 +1,28 @@ %% -*- mode: erlang; indent-tabs-mode: nil -*- Conf0 = CONFIG, -MapOpt = [{d,'HAS_MAPS',true}], +MapString = "#{X => 1}.", +HasOpt = {d,'HAS_MAPS',true}, +FullOpt = {d,'HAS_FULL_KEYS',true}, -case erl_internal:bif(is_map, 1) of - true -> %Maps - case lists:keyfind(erl_opts, 1, Conf0) of - {erl_opts,Opts} -> %Existing erl_opts - NewOpts = {erl_opts,Opts ++ MapOpt}, - lists:keyreplace(erl_opts, 1, Conf0, NewOpts); - false -> %No erl_opts - Conf0 ++ [{erl_opts,MapOpt}] - end; - false -> %No maps - Conf0 +MapsOpts = case erl_scan:string(MapString) of + {ok,Ts,_} -> + case erl_parse:parse_exprs(Ts) of + {ok,Es} -> %We have maps! + Binds = [{'X',49}], %We need to bind X + case erl_lint:exprs(Es, Binds) of + {ok,_} -> [HasOpt,FullOpt]; + {error,_,_} -> [HasOpt] + end; + {error,_} -> [] + end; + {error,_,_} -> [] + end, + +case lists:keyfind(erl_opts, 1, Conf0) of + {erl_opts,Opts} -> %Existing erl_opts + NewOpts = {erl_opts,Opts ++ MapsOpts}, + lists:keyreplace(erl_opts, 1, Conf0, NewOpts); + false -> %No erl_opts + Conf0 ++ [{erl_opts,MapsOpts}] end.
View file
lfe-1.0.tar.gz/src/cl.lfe
Added
@@ -0,0 +1,606 @@ +;; Copyright (c) 2015 Robert Virding +;; +;; Licensed under the Apache License, Version 2.0 (the "License"); +;; you may not use this file except in compliance with the License. +;; You may obtain a copy of the License at +;; +;; http://www.apache.org/licenses/LICENSE-2.0 +;; +;; Unless required by applicable law or agreed to in writing, software +;; distributed under the License is distributed on an "AS IS" BASIS, +;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;; See the License for the specific language governing permissions and +;; limitations under the License. + +;; File : cl.lfe +;; Author : Robert Virding, Duncan McGreggor +;; Purpose : LFE Common Lisp interface library. + +(defmodule cl + (export + ;; Boolean conversion functions. + (make-lfe-bool 1) (make-cl-bool 1) + ;; Control structure. + (mapcar 2) (maplist 2) (mapc 2) (mapl 2) + ;; Symbol functions. + (symbol-plist 1) (symbol-name 1) + (get 2) (get 3) (getl 2) (putprop 3) (remprop 2) + ;; Property list functions. + (getf 2) (getf 3) (putf 3) (remf 2) (get-properties 2) + ;; Sequences. + (elt 2) (length 1) (reverse 1) (some 2) (every 2) (notany 2) (notevery 2) + (reduce 2) (reduce 4) (reduce 6) + (remove 2) (remove-if 2) (remove-if-not 2) (remove-duplicates 1) + (find 2) (find-if 2) (find-if-not 2) + (position 2) (position-if 2) (position-if-not 2) + (count 2) (count-if 2) (count-if-not 2) + ;; Lists. + (car 1) (cdr 1) (first 1) (rest 1) (nth 2) + (nthcdr 2) (last 1) (butlast 1) + ;; Substitution of expressions. + (subst 3) (subst-if 3) (subst-if-not 3) (sublis 2) + ;; Lists as sets. + (member 2) (member-if 2) (member-if-not 2) (adjoin 2) (union 2) + (intersection 2) (set-difference 2) (set-exclusive-or 2) (subsetp 2) + ;; Association list functions. + (acons 3) (pairlis 2) (pairlis 3) (assoc 2) (assoc-if 2) (assoc-if-not 2) + (rassoc 2) (rassoc-if 2) (rassoc-if-not 2) + ;; Types. + (type-of 1) (coerce 2) + ) + ;; Export CL-style if and cond, which we don't use internally. + (export-macro if cond) + ) + +;;; Boolean conversion functions. + +(defun make-lfe-bool ;Make an LFE bool from a CL value + ([()] 'false) + ([_] 'true)) ;Everything else is true + +(defun make-cl-bool ;Make a CL bool from an LFE value + (['false] ()) + (['true] 'true)) + +;; Control structure. + +(defun mapcar (func list) + (lists:map func list)) + +(defun maplist + ([func (= (cons _ rest) list)] + (cons (funcall func list) (maplist func rest))) + ([func ()] ())) + +(defun mapc (func list) + (lists:foreach func list) + list) + +(defun mapl (func list) + (fletrec ((mapl-loop + ([(= (cons _ rest) list)] + (funcall func list) + (mapl-loop rest)) + ([()] ()))) + (mapl-loop list) + list)) + +;; Symbol function functions. +;; get, getl, putprop and remprop should really only work on a +;; symbols plist not just a plist. This is coming. Hence including +;; getf, putf and remf. + +(defun ensure-plist-table () + (case (ets:info 'lfe-symbol-plist 'type) + ('undefined + (let ((init-pid (erlang:whereis 'init))) + (ets:new 'lfe-symbol-plist + (list 'set 'public 'named_table (tuple 'heir init-pid ()))))) + (_ 'ok))) + +(defun symbol-plist (symbol) + (ensure-plist-table) + (case (ets:lookup 'lfe-symbol-plist symbol) + (`(#(,_ ,plist)) plist) + (() ()))) + +(defun symbol-name (symb) + (atom_to_list symb)) + +(defun get (symbol pname) + (get symbol pname ())) + +;;(defun get (plist pname def) (getf plist pname def)) + +(defun get (symbol pname def) + (ensure-plist-table) + (let ((plist (symbol-plist symbol))) + (getf plist pname def))) + +(defun getl (symbol pnames) + (ensure-plist-table) + (let ((plist (symbol-plist symbol))) + (fletrec ((getl-loop + ([(= (list* p v plist-rest) plist) pnames] + (if (member p pnames) + plist + (getl-loop plist-rest pnames))) + ([() pnames] ()))) + (getl-loop plist pnames)))) + +;; (defun putprop (plist val pname) (putf plist val pname)) + +(defun putprop (symbol val pname) + (ensure-plist-table) + (let* ((plist (symbol-plist symbol)) + (plist (putf plist val pname))) + (ets:insert 'lfe-symbol-plist (tuple symbol plist)))) + +;; (defun getprop (plist pname) (remf plist pname)) + +(defun remprop (symbol pname) + (ensure-plist-table) + (let* ((plist (symbol-plist symbol)) + (plist (remf plist pname))) + ;; Delete element if plist empty + (if (=:= plist ()) + (ets:delete 'lfe-symbol-plist symbol) + (ets:insert 'lfe-symbol-plist (tuple symbol plist))))) + +;; Property list functions. + +(defun getf (plist pname) + (getf plist pname ())) + +(defun getf + ([(list* p v plist) pname def] (when (=:= p pname)) v) + ([(list* _ _ plist) pname def] (getf plist pname def)) + ([() pname def] def)) + +(defun putf ;This doesn't exist in CL + ([(list* p _ plist) val pname] (when (=:= p pname)) + (list* pname val plist)) + ([(list* p v plist) val pname] + (list* p v (putf plist val pname))) + ([() val pname] (list pname val))) + +(defun remf + ([(list* p _ plist) pname] (when (=:= p pname)) plist) + ([(list* p v plist) pname] + (list* p v (remf plist pname))) + ([() pname] ())) + +(defun get-properties + ([(= (list* p v plist-rest) plist) pnames] + (if (member p pnames) + (tuple p v plist) + (get-properties plist-rest pnames))) + ([() pnames] (tuple () () ()))) + +;; Arrays. + +;; (defun aref (array i j) +;; (elt j (elt i array))) + +;; Sequences. +;; Simple sequence functions. + +(defun elt + ((n seq) (when (is_list seq)) + (nth n seq)) + ((n seq) (when (is_tuple seq)) + (element (+ n 1) seq))) + +(defun length + ([seq] (when (is_list seq)) + (length seq)) + ([seq] (when (is_tuple seq)) + (tuple_size seq))) + +(defun reverse + ([seq] (when (is_list seq)) + (lists:reverse seq)) + ([seq] (when (is_tuple seq)) + (list_to_tuple (lists:reverse (tuple_to_list seq))))) + +;; Concatanation, mapping and reducing sequences. + +(defun some + ([pred seq] (when (is_list seq)) + (lists:any pred seq)) + ([pred seq] (when (is_tuple seq)) + (fletrec ((some-loop + ([i n] (when (>= i n)) 'false) + ([i n] + (if (funcall pred (element i seq)) + 'true + (some-loop (+ i 1) n))))) + (some-loop 1 (tuple_size seq))))) + +(defun every + ([pred seq] (when (is_list seq)) + (lists:all pred seq)) + ([pred seq] (when (is_tuple seq)) + (fletrec ((every-loop + ([i n] (when (>= i n)) 'false) + ([i n] + (if (funcall pred (element i seq)) + 'false + (every-loop (+ i 1) n))))) + (every-loop 1 (tuple_size seq))))) + +(defun notany (pred seq) + (every (lambda (x) (not (funcall pred x))) seq)) + +(defun notevery (pred seq) + (some (lambda (x) (not (funcall pred x))) seq)) + +(defun reduce (func seq) + (lists:foldl func '() seq)) + +(defun reduce + ((func seq 'initial-value x) + (lists:foldl func x seq)) + ((func seq 'from-end 'true) + (lists:foldr func '() seq))) + +(defun reduce + ((func seq 'from-end 'true 'initial-value x) + (lists:foldr func x seq)) + ((func seq 'initial-value x 'from-end 'true) + (lists:foldr func x seq))) + +;; Modifying sequences. + +(defun remove + ([item seq] (when (is_list seq)) + (lc ((<- x seq) (=/= x item)) x)) + ([item seq] (when (is_tuple seq)) + (list_to_tuple (remove item (tuple_to_list seq))))) + +(defun remove-if + ([pred seq] (when (is_list seq)) + (lc ((<- x seq) (not (funcall pred x))) x)) + ([pred seq] (when (is_tuple seq)) + (list_to_tuple (remove-if pred (tuple_to_list seq))))) + +(defun remove-if-not + ([pred seq] (when (is_list seq)) + (lc ((<- x seq) (funcall pred x)) x)) + ([pred seq] (when (is_tuple seq)) + (list_to_tuple (remove-if-not pred (tuple_to_list seq))))) + +(defun remove-duplicates + ([seq] (when (is_list seq)) + (fletrec ((rm-loop + ([(cons x rest)] + (if (lists:member x rest) + (rm-loop rest) + (cons x (rm-loop rest)))) + ([()] ()))) + (rm-loop seq))) + ([seq] (when (is_tuple seq)) + (list_to_tuple (remove-duplicates (tuple_to_list seq))))) + +;; Searching sequences. + +(defun find (item seq) + (fletrec ((find-loop + ([x (cons x1 xs)] (when (=:= x x1)) x) + ([x (cons x1 xs)] (find-loop x xs)) + ([x ()] ()))) + (find-loop item seq))) + +(defun find-if (pred seq) + (fletrec ((find-if-loop + ([pred (cons x xs)] + (if (funcall pred x) x (find-if-loop pred xs))) + ([pred ()] ()))) + (find-if-loop pred seq))) + +(defun find-if-not (pred seq) + (fletrec ((find-if-not-loop + ([pred (cons x xs)] + (if (funcall pred x) (find-if-not-loop pred xs) x)) + ([pred ()] ()))) + (find-if-not-loop pred seq))) + +(defun position (item seq) + (fletrec ((pos-loop + ([x n (cons x1 xs)] (when (=:= x x1)) n) + ([x n (cons x1 xs)] (pos-loop x (+ n 1) xs)) + ([x n ()] ()))) + (pos-loop item 0 seq))) + +(defun position-if (pred seq) + (fletrec ((pos-if-loop + ([pred n (cons x xs)] + (if (funcall pred x) + n + (pos-if-loop pred (+ n 1) xs))) + ([pred n ()] ()))) + (pos-if-loop pred 0 seq))) + +(defun position-if-not (pred xs) + (fletrec ((pos-if-not-loop + ([pred n (cons x xs)] + (if (funcall pred x) + (pos-if-not-loop pred (+ n 1) xs) + n)) + ([pred n ()] ()))) + (pos-if-not-loop pred 0 xs))) + +(defun count (item seq) + (fletrec ((count-loop + ([x n (cons x1 xs)] + (let ((n1 (if (=:= x x1) (+ n 1) n))) + (count-loop x n1 xs))) + ([x n ()] n))) + (count-loop item 0 seq))) + +(defun count-if (pred seq) + (fletrec ((count-if-loop + ([pred n (cons x xs)] + (let ((n1 (if (funcall pred x) (+ n 1) n))) + (count-if-loop pred n1 xs))) + ([pred n ()] n))) + (count-if-loop pred 0 seq))) + +(defun count-if-not (pred seq) + (fletrec ((count-if-not-loop + ([pred n (cons x xs)] + (let ((n1 (if (funcall pred x) n (+ n 1)))) + (count-if-not-loop pred n1 xs))) + ([pred n ()] n))) + (count-if-not-loop pred 0 seq))) + +;;; Lists + +(defun car + ([()] ()) + ([xs] (car xs))) + +(defun first (xs) + (cl:car xs)) + +(defun cdr + ([()] ()) + ([xs] (cdr xs))) + +(defun rest (xs) + (cl:cdr xs)) + +(defun nth + ([n xs] (when (< n 0)) ()) + ([n xs] + (fletrec ((nth-loop + ([n ()] ()) ;End of the list + ([0 xs] (car xs)) ;Found the one + ([n xs] (nth-loop (- n 1) (cdr xs))))) + (nth-loop n xs)))) + +(defun nthcdr (n xs) + (lists:nthtail (+ n 1) xs)) + +(defun last (list) + (lists:last list)) + +(defun butlast (list) + (lists:droplast list)) + +;; Substitution of expressions + +(defun subst + ([new old tree] (when (=:= old tree)) new) + ([new old (cons e rest)] + (cons (subst new old e) (subst new old rest))) + ([new old tree] tree)) + +(defun subst-if (new test tree) + (if (funcall test tree) new + (case tree + ((cons e rest) + (cons (subst-if new test e) (subst-if new test rest))) + (_ tree)))) + +(defun subst-if-not (new test tree) + (if (funcall test tree) + (case tree + ((cons e rest) + (cons (subst-if-not new test e) (subst-if-not new test rest))) + (_ tree)) + new)) + +(defun sublis (alist tree) + (case (assoc tree alist) + ((cons _ new) new) ;Found it + (() ;Not there + (case tree + ((cons e rest) + (cons (sublis alist e) (sublis alist rest))) + (_ tree))))) + +;; Lists as sets. + +(defun member (item list) + (lists:member item list)) + +(defun member-if + ([pred (cons e list)] + (if (funcall pred e) + 'true + (member-if pred list))) + ([pred ()] 'false)) + +(defun member-if-not + ([pred (cons e list)] + (if (funcall pred e) + (member-if-not pred list) + 'true)) + ([pred ()] 'false)) + +(defun adjoin (item list) + (if (member item list) + list + (cons item list))) + +(defun union + ([(cons e l1) l2] + (if (member e l2) + (union l1 l2) + (cons e (union l1 l2)))) + ([() l2] l2)) + +(defun intersection (l1 l2) + (lc ((<- e l1) (member e l2)) e)) + +(defun set-difference (l1 l2) + (lc ((<- e l1) (not (member e l2))) e)) + +(defun set-exclusive-or (l1 l2) + (++ (set-difference l1 l2) (set-difference l2 l1))) + +(defun subsetp + ([(cons e l1) l2] + (if (member e l2) + (subsetp l1 l2) + 'false)) + ([() l2] 'true)) + +;; Association list functions. + +(defun acons (k v alist) + (cons (cons k v) alist)) + +(defun pairlis (ks vs) + (pairlis ks vs ())) + +(defun pairlis + ([(cons k ks) (cons v vs) alist] + (cons (cons k v) (pairlis ks vs alist))) + ([() () alist] alist)) + +(defun assoc + ([k (cons (= (cons k1 v) pair) _)] (when (=:= k k1)) pair) + ([k (cons _ alist)] (assoc k alist)) + ([k ()] ())) + +(defun assoc-if + ([pred (cons (= (cons k _) pair) alist)] + (if (funcall pred k) pair + (assoc-if pred alist))) + ([pred ()] ())) + +(defun assoc-if-not + ([pred (cons (= (cons k _) pair) alist)] + (if (funcall pred k) + (assoc-if-not pred alist) + pair)) + ([pred ()] ())) + +(defun rassoc + ([v (cons (= (cons _ v1) pair) _)] (when (=:= v v1)) pair) + ([v (cons _ alist)] (assoc v alist)) + ([v ()] ())) + +(defun rassoc-if + ([pred (cons (= (cons _ v) pair) alist)] + (if (funcall pred v) + pair + (rassoc-if pred alist))) + ([pred ()] ())) + +(defun rassoc-if-not + ([pred (cons (= (cons _ v) pair) alist)] + (if (funcall pred v) + (rassoc-if-not pred alist) + pair)) + ([pred ()] ())) + +;;; Types + +(defun type-of + ((x) (when (is_boolean x)) + 'boolean) + ((x) (when (is_atom x)) + 'atom) + ((x) (when (is_tuple x)) + 'tuple) + ((x) (when (is_integer x)) + 'integer) + ((x) (when (is_float x)) + 'float) + ((x) (when (is_list x)) + (cond ((io_lib:printable_latin1_list x) 'string) + ((io_lib:printable_unicode_list x) 'unicode) + ((?= `(,a . ,b) (when (not (is_list b))) x) 'cons) + ('true 'list))) + ((x) (when (is_function x)) + 'function) + ((x) (when (is_binary x)) + 'binary) + ((x) (when (is_bitstring x)) + 'bitstring) + ((x) (when (is_pid x)) + 'pid) + ((x) (when (is_port x)) + 'port) + ((x) (when (is_reference x)) + 'reference) + ((x) + (andalso (call 'erlang 'is_map x) 'map))) + +(defun coerce + ((x 'vector) (when (is_list x)) + (list_to_tuple x)) + ((x 'tuple) (when (is_list x)) + (list_to_tuple x)) + ((x 'atom) (when (is_list x)) + (list_to_atom x)) + ((x 'list) (when (is_atom x)) + (atom_to_list x)) + ((x 'list) (when (is_tuple x)) + (tuple_to_list x)) + ((x 'list) (when (is_binary x)) + (binary_to_list x)) + ((x 'list) (when (is_bitstring x)) + (bitstring_to_list x)) + ((x 'character) (when (is_atom x)) + (car (atom_to_list x))) + ((x 'character) (when (is_list x)) + (car x)) + ((x 'integer) (when (is_float x)) + (trunc x)) + ((x 'float) (when (is_integer x)) + (list_to_float (integer_to_list x))) + ((x 'float) (when (is_list x)) + (list_to_float x)) + ((x 'float) (when (is_atom x)) + (list_to_float (atom_to_list x))) + ((x 't) + x)) + +;;; System + +(defun posix-argv () + (init:get_arguments)) + +;; Test defining CL if and cond. We need to put these last so they +;; won't be used inside this module. + +(defmacro if + ((list test if-true) `(if ,test ,if-true ())) + ((list test if-true if-false) + `(case ,test + (() ,if-false) + (_ ,if-true)))) + +(defmacro cond args + (fletrec ((exp-cond + ([(cons (list test) cond)] + `(let ((|\|-cond-test-\|| ,test)) + (if |\|-cond-test-\|| |\|-cond-test-\|| ,(exp-cond cond)))) + ([(cons (cons test body) cond)] + `(if ,test (progn . ,body) ,(exp-cond cond))) + ([()] ()))) + (exp-cond args)))
View file
lfe-0.9.2.tar.gz/src/lfe.app.src -> lfe-1.0.tar.gz/src/lfe.app.src
Changed
@@ -15,8 +15,18 @@ {application, lfe, [{description, "Lisp Flavored Erlang (LFE)"}, - {vsn, "0.9.2"}, - {modules, []}, + {vsn, "1.0"}, + {modules,[cl,lfe,lfe_bits,lfe_codegen,lfe_comp,lfe_edlin_expand, + lfe_env,lfe_eval,lfe_gen,lfe_init,lfe_io, + lfe_io_format,lfe_io_pretty,lfe_io_write,lfe_lib, + lfe_lint,lfe_macro,lfe_macro_export,lfe_macro_include, + lfe_macro_record,lfe_ms,lfe_parse,lfe_pmod,lfe_qlc, + lfe_scan,lfe_shell,lfe_trans,lfescript]}, {registered, []}, - {applications, [kernel,stdlib,compiler]} + {applications, [kernel,stdlib,compiler]}, + {maintainers, ["Robert Virding"]}, + {licenses, ["Apache"]}, + {links, [{"Github", "https://github.com/rvirding/lfe"}, + {"Main site", "http://lfe.io/"}, + {"Documentation", "http://docs.lfe.io/"}]} ]}.
View file
lfe-1.0.tar.gz/src/lfe.erl
Added
@@ -0,0 +1,71 @@ +%% Copyright (c) 2016 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : lfe.erl +%% Author : Robert Virding +%% Purpose : Lisp Flavoured Erlang standard library. + +-module(lfe). + +%% Standard lisp library. +-export([eval/1,eval/2, + 'macro-function'/1,'macro-function'/2, + macroexpand/1,macroexpand/2, + 'macroexpand-1'/1,'macroexpand-1'/2, + 'macroexpand-all'/1,'macroexpand-all'/2]). + +-export(['LFE-EXPAND-EXPORTED-MACRO'/3]). + +%% 'LFE-EXPAND-EXPORTED-MACRO'(Name, Args, Env) -> {yes,Expansion} | no. +%% A smart implementation of this where we call the lfe_macro module +%% to expand and check for us. Using an empty environment ensures +%% only predefined macros are used. + +'LFE-EXPAND-EXPORTED-MACRO'(Name, Args, _) -> + lfe_macro:expand_expr([Name|Args], lfe_env:new()). + +%% Standard lisp library functions. +%% eval(Sexpr) -> Value. +%% macro-function(Name [,Environment]) -> Macro | []. +%% macroexpand(Form [,Environment]) -> Expansion | Form. +%% macroexpand-1(Form [,Environment]) -> Expansion | Form. +%% macroexpand-all(Form [,Environment]) -> Expansion | Form. + +eval(Sexpr) -> eval(Sexpr, lfe_env:new()). %Empty environment. +eval(Sexpr, Env) -> lfe_eval:expr(Sexpr, Env). + +'macro-function'(Symb) -> 'macro-function'(Symb, lfe_env:new()). +'macro-function'(Symb, Env) -> + case lfe_env:get_mbinding(Symb, Env) of + {yes,Macro} -> + Macro; + no -> [] + end. + +macroexpand(Form) -> macroexpand(Form, lfe_env:new()). +macroexpand(Form, Env) -> + case lfe_macro:expand_expr(Form, Env) of + {yes,Exp} -> Exp; + no -> Form + end. + +'macroexpand-1'(Form) -> 'macroexpand-1'(Form, lfe_env:new()). +'macroexpand-1'(Form, Env) -> + case lfe_macro:expand_expr_1(Form, Env) of + {yes,Exp} -> Exp; + no -> Form + end. + +'macroexpand-all'(Form) -> 'macroexpand-all'(Form, lfe_env:new()). +'macroexpand-all'(Form, Env) -> lfe_macro:expand_expr_all(Form, Env).
View file
lfe-0.9.2.tar.gz/src/lfe.hrl -> lfe-1.0.tar.gz/src/lfe.hrl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2014 Robert Virding +%% Copyright (c) 2014-2015 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -19,5 +19,5 @@ %% We do a lot of quoting! -define(Q(E), [quote,E]). -define(BQ(E), [backquote,E]). --define(UQ(E), [unquote,E]). --define(UQ_S(E), ['unquote-splicing',E]). +-define(C(E), [comma,E]). +-define(C_A(E), ['comma-at',E]).
View file
lfe-0.9.2.tar.gz/src/lfe_bits.erl -> lfe-1.0.tar.gz/src/lfe_bits.erl
Changed
@@ -25,37 +25,37 @@ %% Everything default'ed. -record(spec, {type=default,size=default,unit=default, - sign=default,endian=default}). + sign=default,endian=default}). %% get_bitspecs(Specs) -> {ok,Size,{Type,Unit,Sign,End}} | {error,Error}. -%% Parse a bitspec, apply defaults and return data. The size field is -%% unevaluated. We only return the first error found. +%% Parse a bitspec, apply defaults and return data. The size field is +%% unevaluated. We only return the first error found. get_bitspecs(Specs) -> try - #spec{type=Ty0,size=Sz0,unit=Un0,sign=Si0,endian=En0} = - parse_bitspecs(Specs, #spec{}), - {Ty,Sz,Un,Si,En} = apply_defaults(Ty0, Sz0, Un0, Si0, En0), - {ok,Sz,{Ty,Un,Si,En}} + #spec{type=Ty0,size=Sz0,unit=Un0,sign=Si0,endian=En0} = + parse_bitspecs(Specs, #spec{}), + {Ty,Sz,Un,Si,En} = apply_defaults(Ty0, Sz0, Un0, Si0, En0), + {ok,Sz,{Ty,Un,Si,En}} catch - throw:Error -> Error + throw:Error -> Error end. %% parse_bitspecs(Specs) -> {ok,Size,{Type,Unit,Sign,End}} | {error,Error}. -%% Parse a bitspec and return data. Unmentioned fields get the value -%% default. We only return the first error found. +%% Parse a bitspec and return data. Unmentioned fields get the value +%% default. We only return the first error found. parse_bitspecs(Specs) -> case catch parse_bitspecs(Specs, #spec{}) of - #spec{type=Ty,size=Sz,unit=Un,sign=Si,endian=En} -> - {ok,Sz,{Ty,Un,Si,En}}; - Error -> Error + #spec{type=Ty,size=Sz,unit=Un,sign=Si,endian=En} -> + {ok,Sz,{Ty,Un,Si,En}}; + Error -> Error end. %% parse_bitspecs(Specs, #spec{}) -> #spec{}. -%% Parse a bitspec and return a #spec{} record. Unmentioned fields get -%% the value default. Errors throw the tuple {error,Error} and must be -%% caught. +%% Parse a bitspec and return a #spec{} record. Unmentioned fields +%% get the value default. Errors throw the tuple {error,Error} and +%% must be caught. parse_bitspecs(Ss, Sp0) -> foldl(fun (S, Sp) -> parse_bitspec(S, Sp) end, Sp0, Ss).
View file
lfe-0.9.2.tar.gz/src/lfe_codegen.erl -> lfe-1.0.tar.gz/src/lfe_codegen.erl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2008-2013 Robert Virding +%% Copyright (c) 2008-2015 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -27,7 +27,7 @@ -export([module/2]). -%% -compile(export_all). +-compile(export_all). -import(lists, [member/2,keysearch/3,reverse/1, all/2,map/2,foldl/3,foldr/3,mapfoldl/3,mapfoldr/3, @@ -40,7 +40,6 @@ add_ibinding/5,get_gbinding/3]). -include("lfe_comp.hrl"). --include_lib("compiler/src/core_parse.hrl"). %% Define IS_MAP/1 macro for is_map/1 bif. -ifdef(HAS_MAPS). @@ -51,7 +50,7 @@ -define(Q(E), [quote,E]). %We do a lot of quoting! --record(cg, {mod=[], %Module name +-record(cg, {module=[], %Module name exps=[], %Exports (ordsets) imps=[], %Imports (orddict) pref=[], %Prefixes @@ -67,101 +66,45 @@ fc=0 %Function counter }). -%% module(Forms, CompInfo) -> {ModuleName,CoreModule} +%% module(ModuleForms, CompInfo) -> {ModuleName,CoreModule} -module(Forms, #cinfo{opts=Opts,file=File}) -> +module(Mfs, #cinfo{opts=Opts,file=File}) -> St0 = #cg{opts=Opts,file=File}, - Core0 = #c_module{name=c_atom(none),exports=[],attrs=[],defs=[]}, - {Core1,St1} = forms(Forms, St0, Core0), - {St1#cg.mod,Core1}. + {Core,St1} = compile_module(Mfs, St0), + {St1#cg.module,Core}. -%% forms(Forms, State, CoreModule) -> {CoreModule,State}. -%% Compile the forms from the file as stored in the state record. +%% compile_module(ModuleForms, State) -> {CoreModule,State}. -forms(Forms, St0, Core0) -> - %% Collect the module definition and functions definitions. - {Fbs0,St1} = lfe_lib:proc_forms(fun collect_form/3, Forms, St0), - %% Add predefined functions and definitions. - Predefs = [{module_info,0},{module_info,1}], - Fbs1 = [{module_info, - [lambda,[], - [call,?Q(erlang),?Q(get_module_info),?Q(St1#cg.mod)]],1}, - {module_info, - [lambda,[x], - [call,?Q(erlang),?Q(get_module_info),?Q(St1#cg.mod),x]],1}| - Fbs0], - %% Make initial environment and set state. - Env = forms_env(Fbs1, St1), - St2 = St1#cg{exps=add_exports(St1#cg.exps, Predefs), - defs=Fbs1,env=Env}, - Exps = make_exports(St2#cg.exps, Fbs1), - Atts = map(fun ({N,V,L}) -> -%% Ann = line_file_anno(L, St2), - Ann = [L], - {c_lit(Ann, N),c_lit(Ann, V)} - end, St2#cg.atts), - %% Compile the functions. - {Cdefs,St3} = mapfoldl(fun (D, St) -> comp_define(D, Env, St) end, - St2, St2#cg.defs), - %% Build the final core module structure. - 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", - [(catch core_lint:module(Core1))]) - end, debug_print, St3), - debug_print("#core: ~p\n", [Core1], St3), - %% when_opt(fun () -> - %% Pp = (catch io:put_chars([core_pp:format(Core1),$\n])), - %% io:fwrite("core_pp: ~p\n", [Pp]) - %% end, debug_print, St3), - {Core1,St3}. - -forms_env(Fbs, St) -> - %% Make initial environment with imports and local functions. - Env = foldl(fun ({M,Fs}, Env) -> - foldl(fun ({{F,A},R}, E) -> - add_ibinding(M, F, A, R, E) - end, Env, Fs) - end, lfe_env:new(), St#cg.imps), - foldl(fun ({Name,Def,_}, E) -> - add_fbinding(Name, func_arity(Def), Name, E) - end, Env, Fbs). - -debug_print(Format, Args, St) -> - when_opt(fun () -> io:fwrite(Format, Args) end, debug_print, St). - -when_opt(Fun, Opt, St) -> - case member(Opt, St#cg.opts) of - true -> Fun(); - false -> ok - end. +compile_module(Mfs, St0) -> + {Fbs,St1} = collect_module(Mfs, St0), + Core = c_module(c_atom(none), [], []), + compile_forms(Fbs, St1, Core). -add_exports(all, _) -> all; -add_exports(Old, More) -> union(Old, More). +%% collect_module(ModuleForms, State) -> {Fbs,State}. +%% Collect forms and module data. Returns function bindings and puts +%% module data into state. -make_exports(all, Fbs) -> - map(fun ({F,Def,_}) -> c_fname(F, func_arity(Def)) end, Fbs); -make_exports(Exps, _) -> - map(fun ({F,A}) -> c_fname(F, A) end, Exps). +collect_module(Mfs, St0) -> + {Acc,St1} = lists:foldl(fun collect_form/2, {[],St0}, Mfs), + {lists:reverse(Acc),St1}. %% collect_form(Form, Line, State} -> {[Ret],State}. %% Collect valid forms and module data. Returns forms and put module %% data into state. -collect_form(['define-module',Mod|Mdef], L, St) -> - %% Everything into State - {[],collect_mdef(Mdef, L, St#cg{mod=Mod,anno=[L]})}; -collect_form(['extend-module'|Mdef], L, St) -> - {[],collect_mdef(Mdef, L, St#cg{anno=[L]})}; -collect_form(['define-function',Name,[lambda|_]=Lambda], L, St) -> - {[{Name,Lambda,L}],St}; -collect_form(['define-function',Name,['match-lambda'|_]=Match], L, St) -> - {[{Name,Match,L}],St}. +collect_form({['define-module',Mod|Mdef],L}, {Acc,St}) -> + %% Everything into State. + {Acc,collect_mdef(Mdef, L, St#cg{module=Mod,anno=[L]})}; +collect_form({['extend-module'|Mdef],L}, {Acc,St}) -> + %% Everything into State. + {Acc,collect_mdef(Mdef, L, St#cg{anno=[L]})}; +collect_form({['define-function',Name,[lambda|_]=Lambda],L}, {Acc,St}) -> + {[{Name,Lambda,L}|Acc],St}; +collect_form({['define-function',Name,['match-lambda'|_]=Match],L}, {Acc,St}) -> + {[{Name,Match,L}|Acc],St}. -%% collect_props(ModDef, Line, State) -> State. -%% Collect module definition and fill in the #cg state record. +%% collect_mdef(ModDef, Line, State) -> State. +%% Collect module definition and fill in the #cg state record. collect_mdef([[export,all]|Mdef], L, St) -> collect_mdef(Mdef, L, St#cg{exps=all}); @@ -186,10 +129,10 @@ collect_imp(['from',Mod|Fs], St) -> collect_imp(fun ([F,A], Imps) -> store({F,A}, F, Imps) end, - Mod, St, Fs); + Mod, St, Fs); collect_imp(['rename',Mod|Rs], St) -> collect_imp(fun ([[F,A],R], Imps) -> store({F,A}, R, Imps) end, - Mod, St, Rs); + Mod, St, Rs); collect_imp(['prefix',Mod,Pre], St) -> Pstr = atom_to_list(Pre), %Store prefix as string St#cg{pref=store(Pstr, Mod, St#cg.pref)}. @@ -199,6 +142,74 @@ Imps1 = foldl(Fun, Imps0, Fs), St#cg{imps=store(Mod, Imps1, St#cg.imps)}. +%% compile_forms(Forms, State, CoreModule) -> {CoreModule,State}. +%% Compile the forms from the file as stored in the state record. + +compile_forms(Fbs0, St0, Core0) -> + %% Add predefined functions and definitions, these are in line 0. + Predefs = [{module_info,0},{module_info,1}], + Mibs = [{module_info, + [lambda,[], + [call,?Q(erlang),?Q(get_module_info),?Q(St0#cg.module)]],0}, + {module_info, + [lambda,[x], + [call,?Q(erlang),?Q(get_module_info),?Q(St0#cg.module),x]],0}], + %% The sum of all functions. + Fbs1 = Fbs0 ++ Mibs, + %% Make initial environment and set state. + Env = forms_env(Fbs1, St0), + St1 = St0#cg{exps=add_exports(St0#cg.exps, Predefs), + defs=Fbs1,env=Env}, + Exps = make_exports(St1#cg.exps, Fbs1), + Atts = map(fun ({N,V,L}) -> + Ann = [L], + {ann_c_lit(Ann, N),ann_c_lit(Ann, V)} + end, St1#cg.atts), + %% Compile the functions. + {Cdefs,St2} = mapfoldl(fun (D, St) -> comp_define(D, Env, St) end, + St1, St1#cg.defs), + %% Build the final core module structure. + Core1 = update_c_module(Core0, c_atom(St2#cg.module), Exps, Atts, Cdefs), + %% Maybe print lots of debug info. + debug_print("#cg: ~p\n", [St2], St2), + when_opt(fun () -> io:fwrite("core_lint: ~p\n", + [(catch core_lint:module(Core1))]) + end, debug_print, St2), + debug_print("#core: ~p\n", [Core1], St2), + %% when_opt(fun () -> + %% Pp = (catch io:put_chars([core_pp:format(Core1),$\n])), + %% io:fwrite("core_pp: ~p\n", [Pp]) + %% end, debug_print, St2), + {Core1,St2}. + +forms_env(Fbs, St) -> + %% Make initial environment with imports and local functions. + Env = foldl(fun ({M,Fs}, Env) -> + foldl(fun ({{F,A},R}, E) -> + add_ibinding(M, F, A, R, E) + end, Env, Fs) + end, lfe_env:new(), St#cg.imps), + foldl(fun ({Name,Def,_}, E) -> + add_fbinding(Name, func_arity(Def), Name, E) + end, Env, Fbs). + +debug_print(Format, Args, St) -> + when_opt(fun () -> io:fwrite(Format, Args) end, debug_print, St). + +when_opt(Fun, Opt, St) -> + case member(Opt, St#cg.opts) of + true -> Fun(); + false -> ok + end. + +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)) end, Fbs); +make_exports(Exps, _) -> + map(fun ({F,A}) -> c_fname(F, A) end, Exps). + %% comp_define(DefForm, Env, State) -> {Corefunc,State}. %% Compile a top-level define. Sets current function name. Be careful %% with annotations as dialyzer then sometimes goes crazy. @@ -209,29 +220,30 @@ comp_func(Name, Def, Env, L, St#cg{func=Cf,line=L,vc=0,fc=0,anno=Ann}). %% comp_body(BodyList, Env, Line, State) -> {CoreBody,State}. -%% Compile a body list of expressions. +%% Compile a body list of expressions. comp_body([E], Env, L, St) -> comp_expr(E, Env, L, St); comp_body([E|Es], Env, L, St0) -> {Ce,St1} = comp_expr(E, Env, L, St0), {Cb,St2} = comp_body(Es, Env, L, St1), - {append_c_seq(Ce, Cb, L),St2}; %Flatten nested sequences -comp_body([], _, _, St) -> {c_nil(),St}. %Empty body returns [] + {append_c_seq(Ce, Cb, L),St2}; %Flatten nested sequences +comp_body([], _, _, St) -> {c_nil(),St}. %Empty body returns [] -append_c_seq(#c_seq{body=B}=Cseq, Cb, L) -> - Cseq#c_seq{body=append_c_seq(B, Cb, L)}; -append_c_seq(H, Cb, L) -> - c_seq([L], H, Cb). +append_c_seq(Ce, Cb, L) -> + case is_c_seq(Ce) of + true -> update_c_seq(Ce, seq_arg(Ce), seq_body(Ce)); + false -> ann_c_seq([L], Ce, Cb) + end. %% comp_expr(Expr, Env, Line, State) -> {CoreExpr,State}. -%% Compile an expression. +%% Compile an expression. %% Handle the Core data special forms. comp_expr([quote,E], _, _, St) -> {comp_lit(E),St}; comp_expr([cons,H,T], Env, L, St) -> Cons = fun ([Ch,Ct], _, _, Sta) -> {c_cons(Ch, Ct),Sta} end, comp_args([H,T], Cons, Env, L, St); -comp_expr([car,E], Env, L, St) -> %Provide lisp names +comp_expr([car,E], Env, L, St) -> %Provide lisp names comp_expr([hd,E], Env, L, St); comp_expr([cdr,E], Env, L, St) -> comp_expr([tl,E], Env, L, St); @@ -244,7 +256,7 @@ Args = fun (Args, _, _, Sta) -> {c_tuple(Args),Sta} end, comp_args(As, Args, Env, L, St); comp_expr([binary|Segs], Env, L, St) -> - comp_binary(Segs, Env, L, St); %And bitstring as well + comp_binary(Segs, Env, L, St); %And bitstring as well comp_expr([map|As], Env, L, St) -> comp_map(As, Env, L, St); comp_expr(['mref',Map,K], Env, L, St) -> @@ -253,7 +265,7 @@ comp_expr(['mset',Map|As], Env, L, St) -> comp_set_map(Map, As, Env, L, St); comp_expr(['mupd',Map|As], Env, L, St) -> - comp_update_map(Map, As, Env, L, St); + comp_upd_map(Map, As, Env, L, St); comp_expr(['map-get',Map,K], Env, L, St) -> comp_expr(['mref',Map,K], Env, L, St); comp_expr(['map-set',Map|As], Env, L, St) -> @@ -281,10 +293,10 @@ comp_case(Expr, Cls, Env, L, St); comp_expr(['receive'|Cls], Env, L, St0) -> {Ccs,Ct,Ca,St1} = rec_clauses(Cls, Env, L, St0), - {#c_receive{anno=[L],clauses=Ccs,timeout=Ct,action=Ca},St1}; + {ann_c_receive([L], Ccs, Ct, Ca),St1}; comp_expr(['catch'|Body], Env, L, St0) -> {Cb,St1} = comp_body(Body, Env, L, St0), - {#c_catch{anno=[L],body=Cb},St1}; + {ann_c_catch([L], Cb),St1}; comp_expr(['try'|B], Env, L, St) -> comp_try(B, Env, L, St); comp_expr(['funcall',F|As], Env, L, St) -> @@ -295,7 +307,7 @@ %% Call a function in another module. Call = fun ([Cm,Cn|Cas], _, Li, Sta) -> Ann = line_file_anno(Li, Sta), - {c_call(Ann, Cm, Cn, Cas),Sta} + {ann_c_call(Ann, Cm, Cn, Cas),Sta} end, comp_args([M,N|As], Call, Env, L, St); %% General function calls. @@ -306,10 +318,13 @@ Ann = line_file_anno(Li, Sta), case get_fbinding(Fun, Ar, En) of {yes,M,F} -> %Import - {c_call(Ann, c_atom(M), c_atom(F), Cas),Sta}; + {ann_c_call(Ann, c_atom(M), c_atom(F), Cas),Sta}; {yes,Name} -> %% Might have been renamed, use real function name. - {c_apply(Ann, c_fname(Name, Ar), Cas),Sta} + {ann_c_apply(Ann, c_fname(Name, Ar), Cas),Sta}; + no -> + io:format("ce: ~p\n", [{{Fun,Ar},En}]), + error(foo) end end, comp_args(As, Call, Env, L, St); @@ -343,30 +358,30 @@ false -> {Cv,St1} = new_c_var(L, St0), {Rest,St2} = simple_seq(Ces, Then, [Cv|Ses], Env, L, St1), - {c_let([L], [Cv], Ce, Rest),St2} + {ann_c_let([L], [Cv], Ce, Rest),St2} end; simple_seq([], Then, Ses, Env, L, St) -> Then(reverse(Ses), Env, L, St). -%% comp_lambda(Args, Body, Env, Line, State) -> {#c_fun{},State}. -%% Compile a (lambda (...) ...). +%% comp_lambda(Args, Body, Env, Line, State) -> {c_fun(),State}. +%% Compile a (lambda (...) ...). comp_lambda(Args, Body, Env, L, St0) -> {Cvs,Pvs,St1} = comp_lambda_args(Args, L, St0), {Cb,St2} = comp_body(Body, add_vbindings(Pvs, Env), L, St1), Ann = line_file_anno(L, St2), - {c_fun(Ann, Cvs, Cb),St2}. + {ann_c_fun(Ann, Cvs, Cb),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). + {Cv,Pvs1,St1} = pat_symb(A, L, Pvs0, St0), + {[Cv|Cvs],Pvs1,St1} + end, {[],[],St}, Args). %% lambda_arity([Args|_]) -> length(Args). -%% comp_match_lambda(Clauses, Env, Line, State) -> {#c_fun{},State}. -%% (match-lambda (Pat ...) ...). +%% comp_match_lambda(Clauses, Env, Line, State) -> {c_fun(),State}. +%% (match-lambda (Pat ...) ...). comp_match_lambda(Cls, Env, L, St0) -> Ar = match_lambda_arity(Cls), @@ -374,9 +389,9 @@ {Ccs,St2} = comp_match_clauses(Cls, Env, L, St1), {Fvs,St3} = new_c_vars(Ar, L, St2), Cf = func_fail(Fvs, L, St3), - Cb = c_case([L], c_values(Cvs), Ccs ++ [Cf]), Ann = line_file_anno(L, St3), - {c_fun(Ann, Cvs, Cb),St3}. + Cb = ann_c_case(Ann, ann_c_values(Ann, Cvs), Ccs ++ [Cf]), + {ann_c_fun(Ann, Cvs, Cb),St3}. func_fail(Fvs, L, #cg{func=F}=St) -> %% We need function_name anno to generate function_clause error. @@ -391,11 +406,11 @@ mapfoldl(fun (Cl, Sta) -> comp_match_clause(Cl, Env, L, Sta) end, St, Cls). -%% comp_match_clause(Clause, Env, L, State) -> {#c_clause{},State}. -%% (Pats [(when Guard)] . Body) -%% Pats is here a list of patterns which are the function clause -%% arguments. This must be compiled to a list of patterns not a -%% pattern with a list! +%% comp_match_clause(Clause, Env, L, State) -> {c_clause(),State}. +%% (Pats [(when Guard)] . Body) +%% Pats is here a list of patterns which are the function clause +%% arguments. This must be compiled to a list of patterns not a +%% pattern with a list! comp_match_clause([Pats|Body], Env0, L, St0) -> Pfun = fun (P, {Psvs,Sta}) -> @@ -405,12 +420,13 @@ {Cps,{Pvs,St1}} = mapfoldl(Pfun, {[],St0}, Pats), Env1 = add_vbindings(Pvs, Env0), {Cg,Cb,St2} = comp_clause_body(Body, Env1, L, St1), - {c_clause([L], Cps, Cg, Cb),St2}. + Ann = line_file_anno(L, St2), + {ann_c_clause(Ann, Cps, Cg, Cb),St2}. -%% 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 are no -%% guards, the simple case. +%% 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 are no +%% guards, the simple case. comp_let(Vbs, B, Env, L, St0) -> %% Test if this is a simple let, i.e. no matching. @@ -424,7 +440,7 @@ Efun = fun ([_,E], St) -> comp_expr(E, Env, L, St) end, {Ces,St2} = mapfoldl(Efun, St1, Vbs), {Cb,St3} = comp_body(B, add_vbindings(Pvs, Env), L, St2), - {c_let([L], Cvs, c_values(Ces), Cb),St3}; + {ann_c_let([L], Cvs, ann_c_values([L], Ces), Cb),St3}; false -> %% This would be much easier to do by building a clause %% and compiling it directly, but then we would have to @@ -448,7 +464,8 @@ {Cb,St4} = comp_body(B, Env1, L, St3), {Cvs,St5} = new_c_vars(length(Ces), L, St4), Cf = let_fail(Cvs, L, St5), - {c_case([L], c_values(Ces), [c_clause([L], Cps, Cg, Cb),Cf]), + {ann_c_case([L], ann_c_values([L], Ces), + [ann_c_clause([L], Cps, Cg, Cb),Cf]), St5} end. @@ -456,7 +473,7 @@ fail_clause(Cvs, c_tuple([c_atom(badmatch),c_tuple(Cvs)]), [], L, St). %% comp_let_function(FuncBindngs, Body, Env, Line, State) -> -%% {#c_letrec{},State}. +%% {c_letrec(),State}. %% Compile an flet. This is complicated by the fact that Core only %% has letrec so we have to some name munging of the functions to %% avoid recursive definitions. @@ -478,10 +495,10 @@ end, Env1 = foldl(Efun, Env0, Nfbs), {Cb,St3} = comp_body(B, Env1, L, St2), - {c_letrec([L], Cfs, Cb),St3}. + {ann_c_letrec([L], Cfs, Cb),St3}. %% comp_letrec_function(FuncBindngs, Body, Env, Line, State) -> -%% {#c_letrec{},State}. +%% {c_letrec(),State}. comp_letrec_function(Fbs, B, Env0, L, St0) -> %% Add local functions Env. @@ -493,7 +510,7 @@ Ffun = fun ([Name,Def], St) -> comp_func(Name, Def, Env1, L, St) end, {Cfs,St1} = mapfoldl(Ffun, St0, Fbs), {Cb,St2} = comp_body(B, Env1, L, St1), - {c_letrec([L], Cfs, Cb),St2}. + {ann_c_letrec([L], Cfs, Cb),St2}. %% func_arity(FuncDef) -> Arity. %% Return the arity of a function definition. @@ -515,7 +532,7 @@ {Cfun,St1} = comp_match_lambda(Cls, Env, L, St0), {{Cf,Cfun},St1}. -%% comp_if(IfBody, Env, Line, State) -> {#c_case{},State}. +%% comp_if(IfBody, Env, Line, State) -> {c_case(),State}. %% Compile in if form to a case testing the Test expression. comp_if([Test,True], Env, L, St) -> @@ -524,29 +541,29 @@ comp_if(Test, True, False, Env, L, St). 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 + {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_atom(true), False = c_atom(false), - Ctrue = c_clause([L], [True], Ctr), - Cfalse = c_clause([L], [False], Cfa), + Ctrue = ann_c_clause([L], [True], Ctr), + Cfalse = ann_c_clause([L], [False], Cfa), Cfail = if_fail(L, St3), - {c_case([L], Cte, [Ctrue,Cfalse,Cfail]),St3}. + {ann_c_case([L], Cte, [Ctrue,Cfalse,Cfail]),St3}. %% This produces code which is harder to optimise, strangely enough. %% 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 +%% {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 %% If = fun ([Ctest], _, _, St) -> -%% True = c_atom(true), -%% False = c_atom(false), -%% Ctrue = c_clause([L], [True], Ctr), -%% Cfalse = c_clause([L], [Fail], Cfa), -%% Cfail = if_fail(L, St), -%% {c_case([L], Ctest, [Ctrue,Cfalse,Cfail]),St} -%% end, +%% True = c_atom(true), +%% False = c_atom(false), +%% Ctrue = ann_c_clause([L], [True], Ctr), +%% Cfalse = ann_c_clause([L], [Fail], Cfa), +%% Cfail = if_fail(L, St), +%% {ann_c_case([L], Ctest, [Ctrue,Cfalse,Cfail]),St} +%% end, %% simple_seq([Cte], If, Env, L, St3). if_fail(L, St) -> @@ -559,21 +576,21 @@ fail_clause(Pats, Arg, Fann, L, St) -> Ann = line_file_anno(L, St), - c_clause([L,compiler_generated], %It is compiler generated - Pats, c_primop(Fann ++ Ann, c_atom(match_fail), [Arg])). + ann_c_clause(comp_gen_anno(L, St), %It is compiler generated + Pats, ann_c_primop(Fann ++ Ann, c_atom(match_fail), [Arg])). -%% comp_case(Expr, Clauses, Env, Line, State) -> {#c_case{},State}. -%% Compile a case. +%% comp_case(Expr, Clauses, Env, Line, State) -> {c_case(),State}. +%% Compile a case. comp_case(E, Cls, Env, L, St0) -> {Ce,St1} = comp_expr(E, Env, L, St0), {Ccs,St2} = case_clauses(Cls, Env, L, St1), Cf = case_fail(L, St2), - {c_case([L], Ce, Ccs ++ [Cf]),St2}. + {ann_c_case([L], Ce, Ccs ++ [Cf]),St2}. case_clauses(Cls, Env, L, St) -> mapfoldl(fun (Cl, Sta) -> comp_clause(Cl, Env, L, Sta) end, - St, Cls). + St, Cls). case_fail(L, St) -> Cv = c_var(omega), @@ -592,14 +609,14 @@ rec_clauses([], _, _, St) -> {[],c_atom(infinity),c_atom(true),St}. -%% comp_clause(Clause, Env, Line, State) -> {#c_clause{},State}. +%% comp_clause(Clause, Env, Line, State) -> {c_clause(),State}. %% This is a case/receive clause where the is only one pattern. comp_clause([Pat|Body], Env0, L, St0) -> {Cp,Pvs,St1} = pattern(Pat, L, St0), Env1 = add_vbindings(Pvs, Env0), {Cg,Cb,St2} = comp_clause_body(Body, Env1, L, St1), - {c_clause([L], [Cp], Cg, Cb),St2}. + {ann_c_clause([L], [Cp], Cg, Cb),St2}. comp_clause_body([['when'|Guard]|Body], Env, L, St0) -> {Cg,St1} = comp_guard(Guard, Env, L, St0), @@ -609,10 +626,10 @@ {Cb,St1} = comp_body(Body, Env, L, St0), {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 -%% one of catch or after. Complicated by the behaviour of the after -%% which means we split try with all parts into two try's. +%% comp_try(Body, Env, Line, State) -> {c_try(),State}. +%% Compile a try. We know that case is optional but must have at +%% least one of catch or after. Complicated by the behaviour of the +%% after which means we split try with all parts into two try's. comp_try([E|Body], Env, L, St) -> %% Separate try body into separate bits, none if not there. @@ -621,7 +638,7 @@ After = tag_tail(Body, 'after'), comp_try(E, Case, Catch, After, Env, L, St). %Now build the bugger -%% comp_try(Exp, Case, Catch, After, Env, L, St) -> {#c_try{},State}. +%% comp_try(Exp, Case, Catch, After, Env, L, St) -> {c_try(),State}. comp_try(E, Case, [], [], Env, L, St0) -> %% No catch or after - (try E [(case ...)]) @@ -630,54 +647,57 @@ {Cv,Cc,St2} = try_case(Case, Env, L, St1), {[_,Val,Info]=Evs,St3} = new_c_vars(3, L, St2), %Tag, Value, Info After = raise_primop([Info,Val], L, St2), - {c_try([L], Ce, [Cv], Cc, Evs, After),St3}; + Ann = line_file_anno(L, St3), + {ann_c_try(Ann, Ce, [Cv], Cc, Evs, After),St3}; comp_try(E, Case, Catch, [], Env, L, St0) -> %% No after - (try E [(case ...)] (catch ...)) {Ce,St1} = comp_expr(E, Env, L, St0), {Cv,Cc,St2} = try_case(Case, Env, L, St1), {Evs,Ecs,St3} = try_exception(Catch, Env, L, St2), - {c_try([L], Ce, [Cv], Cc, Evs, Ecs),St3}; + Ann = line_file_anno(L, St3), + {ann_c_try(Ann, Ce, [Cv], Cc, Evs, Ecs),St3}; comp_try(E, [], [], After, Env, L, St0) -> %% Just after - (try E (after ...)) {Ce,St1} = comp_expr(E, Env, L, St0), {Cv,St2} = new_c_var(L, St1), {Ca,St3} = comp_body(After, Env, L, St2), - Cb = c_seq([L], Ca, Cv), + Cb = ann_c_seq([L], Ca, Cv), {Evs,Ecs,St4} = try_after(After, Env, L, St3), - {c_try([L], Ce, [Cv], Cb, Evs, Ecs),St4}; + Ann = line_file_anno(L, St4), + {ann_c_try(Ann, Ce, [Cv], Cb, Evs, Ecs),St4}; comp_try(E, Case, Catch, After, Env, L, St) -> %% Both catch and after - (try E [(case ...)] (catch ...) (after ...)) %% The case where all options are given. Try = ['try',E,['case'|Case],['catch'|Catch]], comp_try(Try, [], [], After, Env, L, St). -%% try_case(CaseClauses, Env, Line, State) -> {Var,#c_case{}|#c_var{},State}. -%% Case is optional, no case just returns value. +%% try_case(CaseClauses, Env, Line, State) -> {Var,c_case()|c_var(),State}. +%% Case is optional, no case just returns value. -try_case([], _, L, St0) -> %No case, just return value +try_case([], _, L, St0) -> %No case, just return value {Cv,St1} = new_c_var(L, St0), {Cv,Cv,St1}; try_case(Cls, Env, L, St0) -> {Cv,St1} = new_c_var(L, St0), {Ccs,St2} = case_clauses(Cls, Env, L, St1), Cf = try_case_fail(L, St2), - {Cv,c_case([L], Cv, Ccs ++ [Cf]),St2}. + {Cv,ann_c_case([L], Cv, Ccs ++ [Cf]),St2}. try_case_fail(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}. +%% try_exception(CatchClauses, Env, L, State) -> {Vars,c_case(),State}. try_exception(Cls, Env, L, St0) -> %% Note that Tag is not needed for rethrow - it is already in Info. - {Cvs,St1} = new_c_vars(3, L, St0), %Tag, Value, Info + {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), - Fc = c_clause([L,compiler_generated], %It is compiler generated - [Arg], raise_primop([Info,Val], L, St2)), - Excp = c_case([L], Arg, Ccs ++ [Fc]), + Fc = ann_c_clause(comp_gen_anno(L, St2), %It is compiler generated + [Arg], raise_primop([Info,Val], L, St2)), + Excp = ann_c_case([L], Arg, Ccs ++ [Fc]), {Cvs,Excp,St2}. %% try_after(AfterBody, Env, L, State) -> {Vars,After,State}. @@ -686,11 +706,11 @@ %% Note that Tag is not needed for rethrow - it is already in Info. {[_,Val,Info]=Cvs,St1} = new_c_vars(3, L, St0), %Tag, Value, Info {Cb,St2} = comp_body(B, Env, L, St1), - After = c_seq([L], Cb, raise_primop([Info,Val], L, St2)), + After = ann_c_seq([L], Cb, raise_primop([Info,Val], L, St2)), {Cvs,After,St2}. raise_primop(Args, L, _) -> - c_primop([L], c_atom(raise), Args). + ann_c_primop([L], c_atom(raise), Args). tag_tail([[Tag|Tail]|_], Tag) -> Tail; tag_tail([_|Try], Tag) -> tag_tail(Try, Tag); @@ -714,10 +734,11 @@ true -> %% Expand comp_let as we need to special case body. {Cf,St1} = comp_match_lambda(Cls, Env, L, St0), - #c_fun{vars=Cvs,body=Cb} = Cf, + Cvs = fun_vars(Cf), + Cb = fun_body(Cf), Efun = fun (E, St) -> comp_expr(E, Env, L, St) end, {Ces,St2} = mapfoldl(Efun, St1, As), - {c_let([L], Cvs, c_values(Ces), Cb),St2}; + {ann_c_let([L], Cvs, ann_c_values([L], Ces), Cb),St2}; false -> %Catch arg mismatch at runtime comp_funcall_1(F, As, Env, L, St0) end; @@ -727,7 +748,7 @@ comp_funcall_1(F, As, Env, L, St0) -> App = fun ([Cf|Cas], _, Li, St) -> Ann = line_file_anno(Li, St), - {c_apply(Ann, Cf, Cas),St} + {ann_c_apply(Ann, Cf, Cas),St} end, comp_args([F|As], App, Env, L, St0). @@ -746,16 +767,16 @@ %% a string. Note that this function can prepend a list of valspecs. get_bitseg([Val|Specs]=F, Vsps) -> - case is_integer_list(F) of %Is bitseg a string? - true -> %A string - {Sz,Ty} = get_bitspecs([]), - foldr(fun (V, Vs) -> [{V,Sz,Ty}|Vs] end, Vsps, F); - false -> %A value and spec - {Sz,Ty} = get_bitspecs(Specs), - case is_integer_list(Val) of %Is val a string? - true -> foldr(fun (V, Vs) -> [{V,Sz,Ty}|Vs] end, Vsps, Val); - false -> [{Val,Sz,Ty}|Vsps] %The default - end + case is_integer_list(F) of %Is bitseg a string? + true -> %A string + {Sz,Ty} = get_bitspecs([]), + foldr(fun (V, Vs) -> [{V,Sz,Ty}|Vs] end, Vsps, F); + false -> %A value and spec + {Sz,Ty} = get_bitspecs(Specs), + case is_integer_list(Val) of %Is val a string? + true -> foldr(fun (V, Vs) -> [{V,Sz,Ty}|Vs] end, Vsps, Val); + false -> [{Val,Sz,Ty}|Vsps] %The default + end end; get_bitseg(Val, Vsps) -> {Sz,Ty} = get_bitspecs([]), @@ -771,7 +792,7 @@ is_integer_list(_) -> false. %% comp_bitsegs(ValSpecs, Env, Line, State) -> {CBitSegs,State}. -%% Compile the bitsegements sequentialising them with simple_seq. +%% Compile the bitsegements sequentialising them with simple_seq. comp_bitsegs(Vsps, Env, L, St) -> comp_bitsegs(Vsps, [], Env, L, St). @@ -780,15 +801,15 @@ {Cval,Csize,Un,Ty,Fs,St1} = comp_bitseg(Vsp, Env, L, St0), %% Sequentialise Val and Size if necessary, then do rest Next = fun ([Cv,Csz], En, Li, St) -> - Cs = c_bitseg(Cv, Csz, Un, Ty, Fs), + Cs = c_bitstr(Cv, Csz, Un, Ty, Fs), comp_bitsegs(Segs, [Cs|Csegs], En, Li, St) end, simple_seq([Cval,Csize], Next, Env, L, St1); comp_bitsegs([], Csegs, _, L, St) -> - {c_binary([L], reverse(Csegs)),St}. + {ann_c_binary([L], reverse(Csegs)),St}. %% comp_bitseg(ValSpec, Env, Line, State) -> {Cval,Csize,Unit,Type,Fs,State}. -%% Need to handle some special cases. +%% Need to handle some special cases. comp_bitseg({Val,_,{Ty,_,Si,En}}, Env, L, St0) when Ty =:= utf8 ; Ty =:= utf16 ; Ty =:= utf32 -> @@ -805,37 +826,62 @@ %% comp_map(Args, Env, Line, State) -> {Core,State}. %% comp_set_map(Map, Args, Line, State) -> {Core,State}. -%% comp_update_map(Map, Args, Line, State) -> {Core,State}. +%% comp_upd_map(Map, Args, Line, State) -> {Core,State}. -ifdef(HAS_MAPS). -comp_map(Args, Env, L, St) -> + +%% There is no need to check for HAS_FULL_KEYS here as the linter will +%% catch the limited code. The setting/updating maps operations need +%% to be wrapped with an 'if' which does an explicit test that the map +%% argument is a map. This does not have exactly the same structure +%% and annotations as a "normal" 'if'. + +comp_map(Args, Env, Line, St) -> Mapper = fun (Cas, _, L, St) -> - Pairs = comp_mappairs(Cas, assoc, L), - {#c_map{anno=[L],arg=c_lit(#{}),es=Pairs},St} + Cpairs = comp_map_pairs(Cas, assoc, L), + {ann_c_map([L], c_lit(#{}), Cpairs),St} end, - comp_args(Args, Mapper, Env, L, St). + comp_args(Args, Mapper, Env, Line, St). -comp_set_map(Map, Args, Env, L, St) -> - Mapper = fun ([Cmap|Cas], _, L, St) -> - Pairs = comp_mappairs(Cas, assoc, L), - {#c_map{anno=[L],arg=Cmap,es=Pairs},St} - end, - comp_args([Map|Args], Mapper, Env, L, St). +comp_set_map(Map, Args, Env, Line, St) -> + comp_modify_map(Map, Args, assoc, Env, Line, St). -comp_update_map(Map, Args, Env, L, St) -> - Mapper = fun ([Cmap|Cas], _, L, St) -> - Pairs = comp_mappairs(Cas, exact, L), - {#c_map{anno=[L],arg=Cmap,es=Pairs},St} +comp_upd_map(Map, Args, Env, Line, St) -> + comp_modify_map(Map, Args, exact, Env, Line, St). + +comp_modify_map(Map, Args, Key, Env, Line, St0) -> + %% Evaluate map, keys and values and build modify form. + Mapper = fun ([Cm|Cas], E, L, St) -> + Cpairs = comp_map_pairs(Cas, Key, L), + comp_map_test(Cm, Cpairs, E, L, St) end, - comp_args([Map|Args], Mapper, Env, L, St). + comp_args([Map|Args], Mapper, Env, Line, St0). -comp_mappairs([K,V|Ps], Op, L) -> - [#c_map_pair{anno=[L],op=c_lit(Op),key=K,val=V}|comp_mappairs(Ps, Op, L)]; -comp_mappairs([], _, _) -> []. +comp_map_test(Cm, Cpairs, _, L, St) -> + %% Build map type tester. + Ann = line_file_anno(L, St), + Cmap = ann_c_clause([compiler_generated|Ann], [], + ann_c_call(Ann, ann_c_atom(Ann, erlang), + ann_c_atom(Ann, is_map), [Cm]), + ann_c_map(Ann, Cm, Cpairs)), + Cfail = map_fail(Cm, L, St), + {ann_c_case(Ann, ann_c_values(Ann, []), [Cmap,Cfail]),St}. + +map_fail(Map, L, St) -> + Fann = [{eval_failure,badmap}], + fail_clause([], c_atom(badmap), Fann, L, St). +%% fail_clause([], c_tuple([c_atom(badmap),Map]), Fann, L, St). + +comp_map_pairs([K,V|Ps], Op, L) -> + [ann_c_map_pair([L], c_lit(Op), K, V)|comp_map_pairs(Ps, Op, L)]; +comp_map_pairs([], _, _) -> []. -else. +%% These are just dummy functions which will never be called as +%% lfe_lint will catch these forms. + comp_map(_, _, _, St) -> {c_lit(map),St}. comp_set_map(_, _, _, _, St) -> {c_lit(map),St}. -comp_update_map(_, _, _, _, St) -> {c_lit(map),St}. +comp_upd_map(_, _, _, _, St) -> {c_lit(map),St}. -endif. %% comp_guard(GuardTests, Env, Line, State) -> {CoreGuard,State}. @@ -845,53 +891,69 @@ comp_guard([], _, _, St) -> {c_atom(true),St}; %The empty guard comp_guard(Gts, Env, L, St0) -> - {Ce,St1} = comp_gtest(Gts, Env, L, St0), %Guard expression + {Ce,St1} = comp_guard_tests(Gts, Env, L, St0), %Guard expression %% Can hard code the rest! Cv = c_var('Try'), Evs = [c_var('T'),c_var('R')], %Why only two? False = c_atom(false), %Exception returns false - {c_try([L], Ce, [Cv], Cv, Evs, False),St1}. + Ann = line_file_anno(L, St1), + {ann_c_try(Ann, Ce, [Cv], Cv, Evs, False),St1}. -%% comp_gtest(GuardTests, Env, Line, State) -> {CoreTest,State}. +%% comp_guard_tests(GuardTests, Env, Line, State) -> {CoreTest,State}. %% Compile a guard test, making sure it returns a boolean value. We %% do this in a naive way by always explicitly comparing the result %% to 'true' and letting the optimiser clean this up. Ignore errors. -%% comp_gtest([[quote,Bool]=Test], _, _, St) when is_boolean(Bool) -> -%% io:format("We hit it: ~p\n", [Test]), -%% {c_atom(Bool),St}; -%% comp_gtest([[Op|As]=Test], Env, L, St0) -> -%% Ar = length(As), -%% case erl_internal:bool_op(Op, Ar) orelse -%% erl_internal:comp_op(Op, Ar) orelse -%% erl_internal:type_test(Op, Ar) of -%% true -> -%% io:format("We hit it: ~p\n", [Test]), -%% comp_gexpr(Test, Env, L, St0); -%% false -> -%% Call = fun (Cas, _, L, St) -> -%% Ann = line_file_anno(L, St), -%% {c_call(Ann, c_atom(erlang), c_atom('=:='), Cas),St} -%% end, -%% comp_gargs([Test,?Q(true)], Call, Env, L, St0) -%% end; -comp_gtest(Ts, Env, L, St0) -> %Not a bool test or boolean - %% Generate an explicit comparison with 'true' to give boolean. - {Cg,St1} = comp_gbody(Ts, Env, L, St0), - True = comp_lit(true), - Call = fun (Cas, _, Li, St) -> - Ann = line_file_anno(Li, St), - {c_call(Ann, c_atom(erlang), c_atom('=:='), Cas),St} - end, - simple_seq([Cg,True], Call, Env, L, St1). - -%% comp_gbody(Body, Env, Line, State) -> {CoreBody,State}. -%% Compile a guard body into a sequence of logical and tests. - -comp_gbody([], _, _, St) -> {c_atom(true),St}; -comp_gbody([T], Env, L, St) -> comp_gexpr(T, Env, L, St); -comp_gbody([T|Ts], Env, L, St) -> - comp_gif(T, [progn|Ts], ?Q(false), Env, L, St). +comp_guard_tests(Gts, Env, Line, St0) -> + {Gas,St1} = mapfoldl(fun (Gt, St) -> comp_guard_test(Gt, Env, Line, St) end, + St0, Gts), + Ands = fun guard_ands/4, + simple_seq(Gas, Ands, Env, Line, St1). + +guard_ands([Ga], _, _, St) -> {Ga,St}; +guard_ands([G1,G2], _, Line, St) -> + {ann_c_call([Line], c_atom(erlang), c_atom('and') , [G1,G2]), St}; +guard_ands([G1,G2|Gas], Env, Line, St0) -> + {Cv,St1} = new_c_var(Line, St0), + {Gr,St2} = guard_ands([Cv|Gas], Env, Line, St1), + And = ann_c_call([Line], c_atom(erlang), c_atom('and'), [G1,G2]), + {ann_c_let([Line], [Cv], And, Gr),St2}. + +%% comp_guard_test(Test, Env, Line, State) -> {CoreTest,State}. +%% Compile one test. We try to avoid generating an unnecessary true +%% test by checking the test and only adding one when we know the +%% test won't automatically return a boolean value. + +comp_guard_test([quote,Bool], _, _, St) when is_boolean(Bool) -> + {c_atom(Bool),St}; %A small optimisation +comp_guard_test([call,[quote,erlang],[quote,Op]|Args]=Test, Env, L, St) -> + comp_guard_test_1(Test, Op, Args, Env, L, St); +comp_guard_test([Op|Args]=Test, Env, L, St) -> + comp_guard_test_1(Test, Op, Args, Env, L, St); +comp_guard_test(Symb, _, L, St) when is_atom(Symb) -> + Ann = comp_gen_anno(L, St), + {ann_c_call(Ann, c_atom(erlang), c_atom('=:='), [c_var(Symb),c_atom(true)]), + St}; +comp_guard_test(_, _, _, St) -> + %% Everything else always will always fail. + {c_atom(false),St}. + +comp_guard_test_1(Test, Op, Args, Env, L, St0) -> + Ar = length(Args), + %% Check if this is a boolean test, else add a boolean test. + case erl_internal:bool_op(Op, Ar) orelse + erl_internal:comp_op(Op, Ar) orelse + erl_internal:type_test(Op, Ar) of + true -> %It's already boolean + comp_gexpr(Test, Env, L, St0); + false -> %No it's not, then make it one + Call = fun (Cas, _, Li, St) -> + Ann = comp_gen_anno(Li, St), + {ann_c_call(Ann, c_atom(erlang), c_atom('=:='), Cas), + St} + end, + comp_gargs([Test,?Q(true)], Call, Env, L, St0) + end. %% comp_gexpr(Expr, Env, Line, State) -> {CoreExpr,State}. @@ -900,7 +962,7 @@ comp_gexpr([cons,H,T], Env, L, St) -> Cons = fun ([Ch,Ct], _, _, St) -> {c_cons(Ch, Ct),St} end, comp_gargs([H,T], Cons, Env, L, St); -comp_gexpr([car,E], Env, L, St) -> %Provide lisp names +comp_gexpr([car,E], Env, L, St) -> %Provide lisp names comp_gexpr([hd,E], Env, L, St); comp_gexpr([cdr,E], Env, L, St) -> comp_gexpr([tl,E], Env, L, St); @@ -912,13 +974,13 @@ comp_gexpr([tuple|As], Env, L, St) -> comp_gargs(As, fun (Args, _, _, St) -> {c_tuple(Args),St} end, Env, L, St); comp_gexpr([binary|Segs], Env, L, St) -> - comp_binary(Segs, Env, L, St); %And bitstring as well + comp_binary(Segs, Env, L, St); %And bitstring as well comp_gexpr([map|As], Env, L, St) -> comp_map(As, Env, L, St); comp_gexpr(['mset',Map|As], Env, L, St) -> comp_set_map(Map, As, Env, L, St); comp_gexpr(['mupd',Map|As], Env, L, St) -> - comp_update_map(Map, As, Env, L, St); + comp_upd_map(Map, As, Env, L, St); comp_gexpr(['map-set',Map|As], Env, L, St) -> comp_gexpr(['mset',Map|As], Env, L, St); comp_gexpr(['map-update',Map|As], Env, L, St) -> @@ -927,18 +989,18 @@ %% (let-syntax ...) should never be seen here! %% Handle the Core control special forms. comp_gexpr(['progn'|Body], Env, L, St) -> - comp_gbody(Body, Env, L, St); + comp_guard_tests(Body, Env, L, St); comp_gexpr(['if'|Body], Env, L, St) -> comp_gif(Body, Env, L, St); comp_gexpr([call,[quote,erlang],[quote,Fun]|As], Env, L, St) -> - comp_gexpr([Fun|As], Env, L, St); %Pass the buck + comp_gexpr([Fun|As], Env, L, St); %Pass the buck %% Finally the general case. comp_gexpr([Fun|As], Env, L, St) -> Call = fun (Cas, En, Li, Sta) -> Ar = length(Cas), {yes,M,F} = get_gbinding(Fun, Ar, En), Ann = line_file_anno(Li, Sta), - {c_call(Ann, c_atom(M), c_atom(F), Cas),Sta} + {ann_c_call(Ann, c_atom(M), c_atom(F), Cas),Sta} end, comp_gargs(As, Call, Env, L, St); comp_gexpr(Symb, _, _, St) when is_atom(Symb) -> @@ -953,7 +1015,7 @@ {Cas,St1} = mapfoldl(fun (A, St) -> comp_gexpr(A, Env, L, St) end, St0, As), simple_seq(Cas, Call, Env, L, St1). -%% comp_gif(IfBody, Env, Line, State) -> {#c_case{},State}. +%% comp_gif(IfBody, Env, Line, State) -> {c_case(),State}. %% Compile in if form to a case testing the Test expression. comp_gif([Test,True], Env, L, St) -> @@ -968,10 +1030,10 @@ True = c_atom(true), False = c_atom(false), Omega = c_var(omega), - Ctrue = c_clause([L], [True], Ctr), - Cfalse = c_clause([L], [False], Cfa), - Cfail = c_clause([L,compiler_generated], [Omega], Omega), - {c_case([L], Cte, [Ctrue,Cfalse,Cfail]),St3}. + Ctrue = ann_c_clause([L], [True], Ctr), + Cfalse = ann_c_clause([L], [False], Cfa), + Cfail = ann_c_clause(comp_gen_anno(L, St3), [Omega], Omega), + {ann_c_case([L], Cte, [Ctrue,Cfalse,Cfail]),St3}. %% This produces code which is harder to optimise, strangely enough. %% comp_gif(Te, Tr, Fa, Env, L, St0) -> @@ -979,16 +1041,69 @@ %% {Ctr,St2} = comp_gexpr(Tr, Env, L, St1), %True expression %% {Cfa,St3} = comp_gexpr(Fa, Env, L, St2), %False expression %% If = fun ([Ctest], _, _, St) -> -%% True = c_atom(true), -%% False = c_atom(false), -%% Omega = c_var(omega), -%% Ctrue = c_clause([L], [True], Ctr), -%% Cfalse = c_clause([L], [False], Cfa), -%% Cfail = c_clause([L,compiler_generated], [Omega], Omega), -%% {c_case([L], Ctest, [Ctrue,Cfalse,Cfail]),St} -%% end, +%% True = c_atom(true), +%% False = c_atom(false), +%% Omega = c_var(omega), +%% Ctrue = ann_c_clause([L], [True], Ctr), +%% Cfalse = ann_c_clause([L], [False], Cfa), +%% Cfail = ann_c_clause(comp_gen_anno(L, St3), [Omega], Omega), +%% {ann_c_case([L], Ctest, [Ctrue,Cfalse,Cfail]),St} +%% end, %% simple_seq([Cte], If, Env, L, St3). +%% 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([H|T]) -> + Ch = comp_lit(H), + Ct = comp_lit(T), + %% c_cons is smart and can handle head and tail both literals. + c_cons(Ch, Ct); +comp_lit([]) -> c_nil(); +comp_lit(T) when is_tuple(T) -> + Es = comp_lit_list(tuple_to_list(T)), + %% c_tuple is smart and can handle a list of literals. + c_tuple(Es); +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), + ann_c_binary([], Bits); +comp_lit(Map) when ?IS_MAP(Map) -> + comp_lit_map(Map). + +comp_lit_list(Vals) -> [ comp_lit(V) || V <- Vals ]. + +is_lit_list(Es) -> all(fun (E) -> is_literal(E) end, Es). + +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_bitstr(c_lit(B), c_int(Sz), c_int(1), c_atom(integer), + c_lit([unsigned,big])). + +-ifdef(HAS_MAPS). +comp_lit_map(Map) -> + Pairs = comp_lit_map_pairs(maps:to_list(Map)), + ann_c_map([], c_lit(#{}), Pairs). + +comp_lit_map_pairs([{K,V}|Ps]) -> + [ann_c_map_pair([], c_lit(assoc), comp_lit(K), comp_lit(V))| + comp_lit_map_pairs(Ps)]; +comp_lit_map_pairs([]) -> []. +-else. +comp_lit_map(_) -> c_lit(map). +-endif. + %% pattern(Pattern, Line, Status) -> {CorePat,PatVars,State}. %% Compile a pattern into a Core term. Handle quoted sexprs here %% especially for symbols which then become variables instead of @@ -996,7 +1111,7 @@ pattern(Pat, L, St) -> pattern(Pat, L, [], St). -pattern([quote,E], _, Vs, St) -> {comp_lit(E),Vs,St}; +pattern([quote,E], _, Vs, St) -> {pat_lit(E),Vs,St}; pattern(['=',P1,P2], L, Vs0, St0) -> %% Core can only alias against a variable so there is wotk to do! {Cp1,Vs1,St1} = pattern(P1, L, Vs0, St0), @@ -1019,6 +1134,10 @@ pat_binary(Segs, L, Vs, St); pattern([map|As], L, Vs, St) -> pat_map(As, L, Vs, St); +%% This allows us to use ++ macro in patterns. +%% pattern([call,[quote,erlang],[quote,'++'],A1,A2], L, Vs, St) -> +%% Pat = foldr(fun (H, T) -> [cons,H,T] end, A2, A1), +%% pattern(Pat, L, Vs, St); %% Compile old no contructor list forms. pattern([H|T], L, Vs0, St0) -> {Ch,Vs1,St1} = pattern(H, L, Vs0, St0), @@ -1027,11 +1146,11 @@ pattern([], _, Vs, St) -> {c_nil(),Vs,St}; %% Literals. pattern(Bin, _, Vs, St) when is_bitstring(Bin) -> - {comp_lit(Bin),Vs,St}; + {pat_lit(Bin),Vs,St}; pattern(Tup, _, Vs, St) when is_tuple(Tup) -> - {comp_lit(Tup),Vs,St}; + {pat_lit(Tup),Vs,St}; pattern(Symb, L, Vs, St) when is_atom(Symb) -> - pat_symb(Symb, L, Vs, St); %Variable + pat_symb(Symb, L, Vs, St); %Variable pattern(Numb, _, Vs, St) when is_number(Numb) -> {c_lit(Numb),Vs,St}. pat_list([P|Ps], L, Vs0, St0) -> @@ -1048,49 +1167,63 @@ %% pat_alias(CorePat, CorePat) -> AliasPat. %% Normalise aliases. This has been taken from v3_core.erl in the -%% erlang compiler. Trap bad aliases by throwing 'nomatch'. - -pat_alias(#c_var{name=V1}, P2) -> #c_alias{var=#c_var{name=V1},pat=P2}; -pat_alias(P1, #c_var{name=V2}) -> #c_alias{var=#c_var{name=V2},pat=P1}; -pat_alias(#c_cons{}=Cons, #c_literal{anno=A,val=[H|T]}=S) -> - pat_alias(Cons, #c_cons{anno=A,hd=#c_literal{anno=A,val=H}, - tl=S#c_literal{val=T}}); -pat_alias(#c_literal{anno=A,val=[H|T]}=S, #c_cons{}=Cons) -> - pat_alias(#c_cons{anno=A,hd=#c_literal{anno=A,val=H}, - tl=S#c_literal{val=T}}, Cons); -pat_alias(#c_cons{anno=A,hd=H1,tl=T1}, #c_cons{hd=H2,tl=T2}) -> - #c_cons{anno=A,hd=pat_alias(H1, H2),tl=pat_alias(T1, T2)}; -pat_alias(#c_tuple{es=Es1}, #c_tuple{es=Es2}) -> - #c_tuple{es=pat_alias_list(Es1, Es2)}; -pat_alias(#c_binary{segments=Segs1}=Bin, #c_binary{segments=Segs2}) -> - Bin#c_binary{segments=pat_alias_list(Segs1, Segs2)}; -pat_alias(#c_bitstr{val=P1,size=Sz,unit=U,type=T,flags=F}=Bitstr, - #c_bitstr{val=P2,size=Sz,unit=U,type=T,flags=F}) -> - Bitstr#c_bitstr{val=pat_alias(P1, P2)}; -pat_alias(#c_alias{var=V1,pat=P1}, #c_alias{var=V2,pat=P2}) -> - if V1 =:= V2 -> pat_alias(P1, P2); - true -> #c_alias{var=V1,pat=#c_alias{var=V2,pat=pat_alias(P1, P2)}} - end; -pat_alias(#c_alias{var=V1,pat=P1}, P2) -> - #c_alias{var=V1,pat=pat_alias(P1, P2)}; -pat_alias(P1, #c_alias{var=V2,pat=P2}) -> - #c_alias{var=V2,pat=pat_alias(P1, P2)}; -pat_alias(P1, P2) -> - case {core_lib:set_anno(P1, []),core_lib:set_anno(P2, [])} of - {P,P} -> P; %Same pattern. - _ -> throw(nomatch) +%% erlang compiler. This is more complicated in core as we can +%% sometimes get structures as "literal". Trap bad aliases by +%% throwing 'nomatch' as these should have been caught in lfe_lint. + +pat_alias(Cp1, Cp2) -> + %% io:format("pa: ~p\n", [{Cp1,Cp2}]), + case {cerl:type(Cp1),cerl:type(Cp2)} of + {var,_} -> c_alias(Cp1, Cp2); + {_,var} -> c_alias(Cp2, Cp1); + {cons,literal} -> + pat_alias_cons(Cp1, Cp2); + {literal,cons} -> + pat_alias_cons(Cp2, Cp1); + {cons,cons} -> + c_cons(pat_alias(cons_hd(Cp1), cons_hd(Cp2)), + pat_alias(cons_tl(Cp1), cons_tl(Cp2))); + {tuple,literal} -> + pat_alias_tuple(Cp1, Cp2); + {literal,tuple} -> + pat_alias_tuple(Cp2, Cp1); + {tuple,tuple} -> + c_tuple(pat_alias_list(tuple_es(Cp1), tuple_es(Cp2))); + {alias,alias} -> + Cv1 = alias_var(Cp1), + Cv2 = alias_var(Cp2), + if Cv1 =:= Cv2 -> + pat_alias(alias_pat(Cp1), alias_pat(Cp2)); + true -> + c_alias(Cv1, c_alias(Cv2, pat_alias(alias_pat(Cp1), + alias_pat(Cp2)))) + end; + {alias,_} -> + c_alias(alias_var(Cp1), pat_alias(alias_pat(Cp1), Cp2)); + {_,alias} -> + c_alias(alias_var(Cp2), pat_alias(Cp1, alias_pat(Cp2))); + _ -> + %% Check that they are the same except for annotation. + case {set_ann(Cp1, []),set_ann(Cp2, [])} of + {P,P} -> Cp1; + _ -> throw({nomatch,Cp1,Cp2}) + end end. -%% pat_alias(Lp0, Rp0) -> -%% case {cerl:type(Lp0),cerl:type(Rp0)} of -%% {var,_} -> cerl:c_alias(Lp0, Rp0); -%% {_,var} -> cerl:c_alias(Rp0, Lp0); -%% {cons,literal} -> -%% Ann = cerl:get_ann(Rp0), -%% [H|T] = cerl:concrete(Rp0), -%% pat_alias(Lp0, cerl:ann_c_cons(Ann, cerl:ann_abstract(Ann, H), -%% cerl:ann_abstract(Ann, T))); -%% {literal,cons} +pat_alias_cons(Cc, Cl) -> + case lit_val(Cl) of + [H|T] -> + %% Must be sure to build a #c_cons{} here + pat_alias(Cc, c_cons_skel(c_lit(H), c_lit(T))); + _ -> throw(nomatch) + end. + +pat_alias_tuple(Ct, Cl) -> + case lit_val(Cl) of + Tup when is_tuple(Tup) -> + update_c_tuple(Ct, pat_alias_list(tuple_es(Ct), data_es(Cl))); + _ -> throw(nomatch) + end. %% pat_alias_list([A1], [A2]) -> [A]. @@ -1099,24 +1232,24 @@ pat_alias_list([], []) -> []; pat_alias_list(_, _) -> throw(nomatch). -%% pat_binary(Segs, Line, PatVars, State) -> {#c_binary{},PatVars,State}. +%% pat_binary(Segs, Line, PatVars, State) -> {c_binary(),PatVars,State}. pat_binary(Segs, L, Vs0, St0) -> Vsps = get_bitsegs(Segs), {Csegs,Vs1,St1} = pat_bitsegs(Vsps, L, Vs0, St0), - {c_binary([L], Csegs),Vs1,St1}. + {ann_c_binary([L], Csegs),Vs1,St1}. %% pat_bitsegs(Segs, Line, PatVars, State) -> {CBitsegs,PatVars,State}. pat_bitsegs(Segs, L, Vs0, St0) -> {Csegs,{Vs1,St1}} = - mapfoldl(fun (S, {Vsa,Sta}) -> - {Cs,Vsb,Stb} = pat_bitseg(S, L, Vsa, Sta), - {Cs,{Vsb,Stb}} - end, {Vs0,St0}, Segs), + mapfoldl(fun (S, {Vsa,Sta}) -> + {Cs,Vsb,Stb} = pat_bitseg(S, L, Vsa, Sta), + {Cs,{Vsb,Stb}} + end, {Vs0,St0}, Segs), {Csegs,Vs1,St1}. -%% pat_bitseg(Seg, Line, PatVars, State) -> {#c_bitstr{},PatVars,State}. +%% pat_bitseg(Seg, Line, PatVars, State) -> {c_bitstr(),PatVars,State}. %% ??? Should noenv be lfe_env:new() instead ??? %% ??? We know its correct so why worry? ??? @@ -1125,177 +1258,96 @@ %% Special case utf types. {Cpat,Vs1,St1} = pattern(Pat, L, Vs0, St0), Undef = c_atom(undefined), - {c_bitseg(Cpat,Undef,Undef,c_atom(Ty),c_lit([Si,En])),Vs1,St1}; + {c_bitstr(Cpat,Undef,Undef,c_atom(Ty),c_lit([Si,En])),Vs1,St1}; pat_bitseg({Pat,all,{binary,_,_,_}=Ty}, L, Vs, St) -> pat_bitseg({Pat,?Q(all),Ty}, L, Vs, St); pat_bitseg({Pat,Sz,{Ty,Un,Si,En}}, L, Vs0, St0) -> {Cpat,Vs1,St1} = pattern(Pat, L, Vs0, St0), {Csize,St2} = comp_expr(Sz, noenv, L, St1), - {c_bitseg(Cpat, Csize, c_int(Un), c_atom(Ty), c_lit([Si,En])),Vs1,St2}. + {c_bitstr(Cpat, Csize, c_int(Un), c_atom(Ty), c_lit([Si,En])),Vs1,St2}. -ifdef(HAS_MAPS). -%% pat_map(Args, Line, PatVars, State) -> {#c_map{},PatVars,State}. +%% pat_map(Args, Line, PatVars, State) -> {c_map(),PatVars,State}. pat_map(Args, L, Vs0, St0) -> {Pairs,Vs1,St1} = pat_map_pairs(Args, L, Vs0, St0), - {#c_map{anno=[L],arg=c_lit(#{}),es=Pairs},Vs1,St1}. + %% Build #c_map{} then fill it in. + Map = ann_c_map_pattern([L], Pairs), %Must us this for a pattern + {Map,Vs1,St1}. pat_map_pairs([K,V|As], L, Vs0, St0) -> Ck = pat_map_key(K), {Cv,Vs1,St1} = pattern(V, L, Vs0, St0), {Cps,Vs2,St2} = pat_map_pairs(As, L, Vs1, St1), - {[#c_map_pair{anno=[L],op=c_lit(exact),key=Ck,val=Cv}|Cps], + {[ann_c_map_pair([L], c_lit(exact), Ck, Cv)|Cps], Vs2,St2}; pat_map_pairs([], _, Vs, St) -> {[],Vs,St}. -pat_map_key([quote,L]) -> comp_lit(L); -pat_map_key(L) -> comp_lit(L). +pat_map_key([quote,L]) -> pat_lit(L); +pat_map_key(L) -> pat_lit(L). -else. pat_map(_, _, Vs, St) -> {c_lit(map),Vs,St}. -endif. -%% c_call(Anno, Module, Name, Args) -> #c_call{}. -%% c_try(Anno, Arg, Vars, Body, Evars, Handler) -> #c_try{}. -%% c_fun(Anno, Vars, Body) -> #c_fun{}. -%% c_primop(Anno, Name, Args) -> #c_primop{}. -%% c_let(Anno, Vars, Arg, Body) -> #c_let{}. -%% c_letrec(Anno, Defs, Body) -> #c_letrec{}. -%% c_case(Anno, Arg, Clauses) -> #c_case{}. -%% c_clause(Anno, Pats, Body) -> #c_clause{}. -%% c_clause(Anno, Pats, Guard, Body) -> #c_clause{}. -%% c_seq(Anno, Arg, Body) -> #c_seq{}. -%% c_fname(Name, Arity) -> #c_fname{}. -%% c_fname(Anno, Name, Arity) -> #c_fname{}. -%% c_apply(Anno, Op, Args) -> #c_apply{}. - -%% 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_lit(Anno, Value) -> #c_literal{}. -%% c_var(Name) -> #c_var{}. -%% c_binary(Anno, Segs) -> #c_binary{}. -%% c_bitseg(Value, Size, Unit, Type, Sign, Endian) -> #c_bitseg{}. -%% Constructor functions for building Core forms. - -c_call(Ann, M, F, As) -> - #c_call{anno=Ann,module=M,name=F,args=As}. - -c_try(Ann, E, Vs, B, Evs, H) -> - #c_try{anno=Ann,arg=E,vars=Vs,body=B,evars=Evs,handler=H}. - -c_fun(Ann, Vs, B) -> - #c_fun{anno=Ann,vars=Vs,body=B}. - -c_primop(Ann, N, As) -> - #c_primop{anno=Ann,name=N,args=As}. - -c_let(Ann, Vs, A, B) -> - #c_let{anno=Ann,vars=Vs,arg=A,body=B}. - -c_letrec(Ann, Defs, B) -> - #c_letrec{anno=Ann,defs=Defs,body=B}. - -c_case(Ann, A, Cs) -> - #c_case{anno=Ann,arg=A,clauses=Cs}. - -c_clause(Ann, Ps, B) -> %Default true guard - c_clause(Ann, Ps, c_atom(true), B). - -c_clause(Ann, Ps, G, B) -> - #c_clause{anno=Ann,pats=Ps,guard=G,body=B}. - -c_seq(Ann, A, B) -> - #c_seq{anno=Ann,arg=A,body=B}. - -c_fname(Ann, N, A) -> #c_var{anno=Ann,name={N,A}}. -c_fname(N, A) -> c_fname([], N, A). - -c_apply(Ann, Op, As) -> #c_apply{anno=Ann,op=Op,args=As}. - -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(Ann, Val) -> #c_literal{anno=Ann,val=Val}. %Generic literal -c_lit(Val) -> c_lit([], Val). -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_binary(Ann, Segs) -> - #c_binary{anno=Ann,segments=Segs}. -c_bitseg(Val, Sz, Un, Ty, Fs) -> - #c_bitstr{anno=[],val=Val,size=Sz,unit=Un,type=Ty,flags=Fs}. - -line_file_anno(L, St) -> - [L,{file,St#cg.file}]. - -%% 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{anno=Ann,val=H},#c_literal{val=T}} -> - c_lit(Ann, [H|T]); - {H,T} -> c_cons(H, T) - end; -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; -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([], Bits); -comp_lit(Map) when ?IS_MAP(Map) -> - comp_lit_map(Map). - -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 +%% pat_lit(Value) -> LitExpr. +%% Make a literal expression from an Erlang value. Make it as literal +%% as is required for a pattern. This function will fail if the value +%% is not expressable as a literal (for instance, a pid). + +pat_lit([H|T]) -> + Ch = pat_lit(H), + Ct = pat_lit(T), + %% c_cons is smart and can handle head and tail both literals. + c_cons(Ch, Ct); +pat_lit([]) -> c_nil(); +pat_lit(T) when is_tuple(T) -> + Es = pat_lit_list(tuple_to_list(T)), + %% c_tuple is smart and can handle a list of literals. + c_tuple(Es); +pat_lit(A) when is_atom(A) -> c_atom(A); +pat_lit(I) when is_integer(I) -> c_int(I); +pat_lit(F) when is_float(F) -> c_float(F); +pat_lit(Bin) when is_bitstring(Bin) -> + Bits = pat_lit_bitsegs(Bin), + ann_c_binary([], Bits); +pat_lit(Map) when ?IS_MAP(Map) -> + pat_lit_map(Map). + +pat_lit_list(Vals) -> [ pat_lit(V) || V <- Vals ]. + +pat_lit_bitsegs(<<B:8,Bits/bitstring>>) -> %Next byte + [c_byte_bitseg(B, 8)|pat_lit_bitsegs(Bits)]; +pat_lit_bitsegs(<<>>) -> []; %Even bytes +pat_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])). - -ifdef(HAS_MAPS). -comp_lit_map(Map) -> - Pairs = comp_lit_mappairs(maps:to_list(Map)), - #c_map{anno=[],arg=c_lit(#{}),es=Pairs}. - -comp_lit_mappairs([{K,V}|Ps]) -> - [#c_map_pair{anno=[],op=c_lit(assoc),key=comp_lit(K),val=comp_lit(V)}| - comp_lit_mappairs(Ps)]; -comp_lit_mappairs([]) -> []. +pat_lit_map(Map) -> + Pairs = pat_lit_map_pairs(maps:to_list(Map)), + ann_c_map([], c_lit(#{}), Pairs). + +pat_lit_map_pairs([{K,V}|Ps]) -> + [ann_c_map_pair([], c_lit(assoc), pat_lit(K), pat_lit(V))| + pat_lit_map_pairs(Ps)]; +pat_lit_map_pairs([]) -> []. -else. -comp_lit_map(_) -> c_lit(map). +pat_lit_map(_) -> c_lit(map). -endif. +%% line_file_anno(Line, State) -> Anno. +%% Make annotation with line number and file. + +line_file_anno(L, St) -> + [L,{file,St#cg.file}]. + +%% comp_gen_anno(Line, State) -> Anno. +%% Make annotation with line number and compiler_generated. + +comp_gen_anno(L, _) -> + [L,compiler_generated]. + %% new_symb(State) -> {Symbol,State}. %% Create a hopefully new unused symbol. @@ -1307,7 +1359,7 @@ C = St#cg.fc, {list_to_atom("'" ++ Pre ++ "~" ++ integer_to_list(C)),St#cg{fc=C+1}}. -%% new_c_var(Line, State) -> {#c_var{},State}. +%% new_c_var(Line, State) -> {c_var(),State}. %% Create a hopefully new core variable. new_c_var(_, St) -> @@ -1336,17 +1388,157 @@ %% is_simple(CoreExp) -> bool(). %% Test if CoreExp is simple, i.e. just constructs terms. -is_simple(#c_var{}) -> true; -is_simple(#c_literal{}) -> true; -is_simple(#c_cons{hd=H,tl=T}) -> - is_simple(H) andalso is_simple(T); -is_simple(#c_tuple{es=Es}) -> is_simple_list(Es); -is_simple(#c_binary{segments=Es}) -> is_simple_bin(Es); -is_simple(_) -> false. +is_simple(Ce) -> + case cerl:type(Ce) of + var -> true; + literal -> true; + cons -> + is_simple(cons_hd(Ce)) andalso is_simple(cons_tl(Ce)); + tuple -> + is_simple_list(tuple_es(Ce)); + binary -> + is_simple_bin(binary_segments(Ce)); + _ -> false + end. is_simple_list(Es) -> all(fun is_simple/1, Es). is_simple_bin(Ss) -> - all(fun (#c_bitstr{val=E,size=S}) -> - is_simple(E) andalso is_simple(S) + all(fun (Seg) -> + is_simple(bitstr_val(Seg)) andalso is_simple(bitstr_size(Seg)) end, Ss). + +%% Constructor functions for building Core forms. These now just call +%% functions in cerl. + +c_module(Name, Exp, Defs) -> + cerl:c_module(Name, Exp, Defs). + +update_c_module(Mod, Name, Exp, Atts, Defs) -> + cerl:update_c_module(Mod, Name, Exp, Atts, Defs). + +ann_c_call(Ann, M, F, As) -> + cerl:ann_c_call(Ann, M, F, As). + +ann_c_try(Ann, E, Vs, B, Evs, H) -> + cerl:ann_c_try(Ann, E, Vs, B, Evs, H). + +ann_c_fun(Ann, Vs, B) -> + cerl:ann_c_fun(Ann, Vs, B). + +fun_vars(Fun) -> cerl:fun_vars(Fun). +fun_body(Fun) -> cerl:fun_body(Fun). + +ann_c_primop(Ann, N, As) -> + cerl:ann_c_primop(Ann, N, As). + +ann_c_let(Ann, Vs, A, B) -> + cerl:ann_c_let(Ann, Vs, A, B). + +ann_c_letrec(Ann, Defs, B) -> + cerl:ann_c_letrec(Ann, Defs, B). + +ann_c_catch(Ann, Body) -> + cerl:ann_c_catch(Ann, Body). + +ann_c_receive(Ann, Cs, To, A) -> + cerl:ann_c_receive(Ann, Cs, To, A). + +ann_c_case(Ann, E, Cs) -> + cerl:ann_c_case(Ann, E, Cs). + +ann_c_clause(Ann, Ps, B) -> %Default true guard + cerl:ann_c_clause(Ann, Ps, B). + +ann_c_clause(Ann, Ps, G, B) -> + cerl:ann_c_clause(Ann, Ps, G, B). + +ann_c_seq(Ann, A, B) -> + cerl:ann_c_seq(Ann, A, B). + +update_c_seq(Node, A, B) -> + cerl:update_c_seq(Node, A, B). + +is_c_seq(Node) -> cerl:is_c_seq(Node). + +seq_arg(Seq) -> cerl:seq_arg(Seq). +seq_body(Seq) -> cerl:seq_body(Seq). + +c_fname(N, A) -> cerl:c_fname(N, A). + +ann_c_apply(Ann, Op, As) -> + cerl:ann_c_apply(Ann, Op, As). + +ann_c_values(Ann, Vs) -> cerl:ann_c_values(Ann, Vs). + +get_ann(Node) -> cerl:get_ann(Node). +set_ann(Node, Ann) -> cerl:set_ann(Node, Ann). + +c_alias(Var, Pat) -> cerl:c_alias(Var, Pat). +alias_var(Alias) -> cerl:alias_var(Alias). +alias_pat(Alias) -> cerl:alias_pat(Alias). + +c_atom(A) -> cerl:c_atom(A). +ann_c_atom(Ann, A) -> cerl:ann_c_atom(Ann, A). +c_int(I) -> cerl:c_int(I). +c_float(F) -> cerl:c_float(F). +c_nil() -> cerl:c_nil(). + +ann_c_lit(Ann, Val) -> cerl:ann_abstract(Ann, Val). %Generic literal +c_lit(Val) -> cerl:abstract(Val). +is_literal(Node) -> cerl:is_literal(Node). +lit_val(Lit) -> cerl:concrete(Lit). + +data_es(Data) -> cerl:data_es(Data). + +c_cons(Hd, Tl) -> cerl:c_cons(Hd, Tl). +c_cons_skel(Hd, Tl) -> cerl:c_cons_skel(Hd, Tl). +cons_hd(Cons) -> cerl:cons_hd(Cons). +cons_tl(Cons) -> cerl:cons_tl(Cons). + +c_tuple(Es) -> cerl:c_tuple(Es). +update_c_tuple(Tup, Es) -> + cerl:update_c_tuple(Tup, Es). +tuple_es(Tup) -> cerl:tuple_es(Tup). + +c_var(N) -> cerl:c_var(N). + +ann_c_binary(Ann, Segs) -> cerl:ann_c_binary(Ann, Segs). +update_c_binary(Bin, Segs) -> + cerl:update_c_binary(Bin, Segs). +binary_segments(Bin) -> cerl:binary_segments(Bin). + +c_bitstr(Val, Sz, Un, Ty, Fs) -> + cerl:c_bitstr(Val, Sz, Un, Ty, Fs). +update_c_bitstr(Bit, Val, Sz, Un, Ty, Fs) -> + cerl:update_c_bitstr(Bit, Val, Sz, Un, Ty, Fs). +bitstr_val(Bit) -> cerl:bitstr_val(Bit). +bitstr_size(Bit) -> cerl:bitstr_size(Bit). +bitstr_unit(Bit) -> cerl:bitstr_unit(Bit). +bitstr_type(Bit) -> cerl:bitstr_type(Bit). +bitstr_flags(Bit) -> cerl:bitstr_flags(Bit). + +-ifdef(HAS_MAPS). +ann_c_map(Ann, Arg, Ps) -> + cerl:ann_c_map(Ann, Arg, Ps). + +%% ann_c_map_pattern(Ann, Pairs) -> Map +%% This function will come first in 18. Until then this is a little +%% tricky as ann_c_map will create a literal if the map pattern is a +%% literal and this is NOT what the compiler wants. + +ann_c_map_pattern(Ann, Ps) -> + case erlang:function_exported(cerl, ann_c_map_pattern, 2) of + true -> + cerl:ann_c_map_pattern(Ann, Ps); + false -> + Map0 = ann_c_map(Ann, dummy, Ps), + update_c_map(Map0, c_lit(#{}), Ps) + end. + +update_c_map(Map, Arg, Ps) -> + cerl:update_c_map(Map, Arg, Ps). + +ann_c_map_pair(Ann, Op, Key, Val) -> + cerl:ann_c_map_pair(Ann, Op, Key, Val). +-endif.
View file
lfe-0.9.2.tar.gz/src/lfe_comp.erl -> lfe-1.0.tar.gz/src/lfe_comp.erl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2008-2013 Robert Virding +%% Copyright (c) 2008-2016 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -16,51 +16,93 @@ %%% Author : Robert Virding %%% Purpose : Lisp Flavoured Erlang compiler (to core Erlang). +%% All the code in the file is treated as one sequence of forms until +%% after the macroexpansion pass when it is split into separate +%% modules. However up until after the lint pass all errors and +%% warnings are collected together in the errors and warnings +%% fields. After this the errors become more module specific and are +%% kept together with the compiled code, both for core and the +%% following erlang formats. + -module(lfe_comp). --export([file/1,file/2,forms/1,forms/2]). +-export([file/1,file/2,forms/1,forms/2,default_options/0]). %% -compile(export_all). --import(lists, [member/2,keyfind/3,filter/2,foreach/2,all/2, +-import(lists, [member/2,keyfind/3,filter/2,foreach/2,all/2,any/2, map/2,flatmap/2,foldl/3,foldr/3,mapfoldl/3,mapfoldr/3]). -import(ordsets, [add_element/2,is_element/2,from_list/1,union/2]). -import(orddict, [store/3,find/2]). -include("lfe_comp.hrl"). --record(comp, {base="", %Base name - ldir=".", %Lisp file dir - lfile="", %Lisp file - odir=".", %Output directory - bfile="", %Beam file - cfile="", %Core file - opts=[], %User options - ipath=[], %Include path - mod=[], %Module name - ret=file, %What is returned [Val] | [] - code=none, %Code after last pass. - cinfo=none, %Common compiler info +%% The main compiler state. + +-record(comp, {base="", %Base name + ldir=".", %Lisp file dir + lfile="", %Lisp file + odir=".", %Output directory + opts=[], %User options + ipath=[], %Include path + cinfo=none, %Common compiler info + module=[], %Module name + code=[], %Code after last pass. + return=[], %What is returned [Val] | [] errors=[], warnings=[] }). +%% default_options() -> Options. +%% Return the default compiler options. + +-define(DEFAULT_OPTS, [verbose,report]). + +default_options() -> ?DEFAULT_OPTS. + %% file(Name) -> %% {ok,Mod,Warns} | {ok,Mod,Binary,Ws} | {error,Errors,Warns} | error. %% file(Name, Options) -> %% {ok,Mod,Warns} | {ok,Mod,Binary,Ws} | {error,Errors,Warns} | error. %% Compile the LFE file Name. --define(DEFAULT_OPTS, [verbose,report]). +file(Name) -> file(Name, default_options()). + +file(Name, Opts) -> do_compile({file,Name}, Opts). + +%% forms(Forms) -> {ok,Mod,Bin,Warnings} | {error,Errors,Warnings}. +%% forms(Forms, Options) -> {ok,Mod,Bin,Warnings} | {error,Errors,Warnings}. +%% Compile the LFE forms Forms, always return a binary. + +forms(Forms) -> forms(Forms, default_options()). + +forms(Forms, Opts) -> do_compile({forms,Forms}, Opts). + +do_compile(Input, Opts) -> + Ifun = fun () -> + Ret = try + internal(Input, Opts) + catch + error:Reason -> + St = erlang:get_stacktrace(), + {error,{Reason,St}} + end, + exit(Ret) + end, + {Pid,Ref} = spawn_monitor(Ifun), + receive + {'DOWN',Ref,_,Pid,Res} -> Res + end. -file(Name) -> do_file(Name, ?DEFAULT_OPTS). +%% internal(Input, Options) -> Result. -file(Name, Opts) -> do_file(Name, Opts). +internal({file,Name}, Opts) -> do_file(Name, Opts); +internal({forms,Forms}, Opts) -> do_forms(Forms, Opts). do_file(Name, Opts0) -> Opts1 = lfe_comp_opts(Opts0), - St0 = #comp{opts=Opts1}, - St1 = filenames(Name, St0), + St0 = #comp{opts=Opts1,code=[]}, %Code must be list! + St1 = filenames(Name, ".lfe", St0), St2 = include_path(St1), case lfe_io:parse_file(St2#comp.lfile) of {ok,Fs} -> @@ -69,57 +111,47 @@ {error,Error} -> do_error_return(St2#comp{errors=[Error]}) end. -%% forms(Forms) -> {ok,Mod,Bin,Warnings} | {error,Errors,Warnings}. -%% forms(Forms, Options) -> {ok,Mod,Bin,Warnings} | {error,Errors,Warnings}. -%% Compile the LFE forms Forms, always return a binary. - -forms(Forms) -> do_forms(Forms, ?DEFAULT_OPTS). - -forms(Forms, Opts) -> do_forms(Forms, Opts). - do_forms(Fs0, Opts0) -> + Source = proplists:get_value(source, Opts0, "-no-file-"), Opts1 = lfe_comp_opts(Opts0), - St0 = #comp{opts=[binary|Opts1]}, %Implicit binary option - St1 = filenames("-no-file-", St0#comp{opts=Opts1}), + St0 = #comp{opts=[binary|Opts1]}, %Implicit binary option + St1 = filenames(Source, ".lfe", St0), St2 = include_path(St1), %% Tag forms with a "line number", just use their index. {Fs1,_} = mapfoldl(fun (F, N) -> {{F,N},N+1} end, 1, Fs0), do_forms(St2#comp{code=Fs1}). -%% filenames(File, State) -> State. +%% filenames(File, Suffix, State) -> State. %% The default output dir is the current directory unless an %% explicit one has been given in the options. -filenames(File, St) -> +filenames(File, Suffix, St) -> %% Test for explicit outdir. Odir = outdir(St#comp.opts), - Dir = filename:dirname(File), - Base = filename:basename(File, ".lfe"), - Lfile = filename:join(Dir, Base ++ ".lfe"), - Bfile = Base ++ ".beam", - Cfile = Base ++ ".core", + Ldir = filename:dirname(File), + Base = filename:basename(File, Suffix), + Lfile = filename:join(Ldir, Base ++ Suffix), St#comp{base=Base, - ldir=Dir, + ldir=Ldir, lfile=Lfile, - odir=Odir, - bfile=filename:join(Odir, Bfile), - cfile=filename:join(Odir, Cfile)}. + odir=Odir + }. -outdir([{outdir,Dir}|_]) -> Dir; -outdir([[outdir,Dir]|_]) -> Dir; +outdir([{outdir,Dir}|_]) -> Dir; %Erlang way +outdir([[outdir,Dir]|_]) -> Dir; %LFE way outdir([_|Opts]) -> outdir(Opts); outdir([]) -> ".". %% include_path(State) -> State. %% Set the include path, we permit {i,Dir} and [i,Dir]. -include_path(#comp{ldir=Dir,opts=Opts}=St) -> - Ifun = fun ({i,I}, Is) -> [I|Is]; - ([i,I], Is) -> [I|Is]; +include_path(#comp{ldir=Ldir,opts=Opts}=St) -> + Ifun = fun ({i,I}, Is) -> [I|Is]; %Erlang way + ([i,I], Is) -> [I|Is]; %LFE way (_, Is) -> Is end, - %% Same ordering as in the erlang compiler - Is = [".",Dir|foldr(Ifun, [], Opts)], %Default entries + %% Same ordering as in the erlang compiler. + Is = [".",Ldir|foldr(Ifun, [], Opts)], %Default entries St#comp{ipath=Is}. %% compiler_info(State) -> CompInfo. @@ -128,10 +160,25 @@ #cinfo{file=F,opts=Os,ipath=Is}. %% lfe_comp_opts(Opts) -> Opts. -%% Check options for lfe compiler. +%% Translate from LFE to erlang standard options for lfe compiler. lfe_comp_opts(Opts) -> - filter(fun (_) -> true end, Opts). + Fun = fun ('to-split') -> to_split; + ('to-emac') -> to_emac; + ('to-exp') -> to_exp; + ('to-pmod') -> to_pmod; + ('to-lint') -> to_lint; + ('to-core0') -> to_core0; + ('to-core') -> to_core; + ('to-kernel') -> to_kernel; + ('to-asm') -> to_asm; + ('warnings-as-errors') -> warnings_as_errors; + ('report-warnings') -> report_warnings; + ('report-errors') -> report_errors; + ('debug-print') -> debug_print; + (O) -> O + end, + map(Fun, Opts). %% do_forms(State) -> %% {ok,Mod,[Core],[Warnings]} | {error,Errors,Warnings} | error. @@ -146,101 +193,54 @@ {error,St2} -> do_error_return(St2) 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(#comp{cinfo=Ci,code=Code}=St) -> - case lfe_macro:expand_forms(Code, lfe_env:new(), Ci) of - {ok,Fs,Env,Ws} -> - debug_print("mac: ~p\n", [{Fs,Env}], St), - {ok,St#comp{code=Fs,warnings=St#comp.warnings ++ Ws}}; - {error,Es,Ws} -> - {error,St#comp{errors=St#comp.errors ++ Es, - warnings=St#comp.warnings ++ Ws}} - end. - -do_lint(St) -> - case lfe_lint:module(St#comp.code, St#comp.cinfo) of - {ok,Ws} -> - {ok,St#comp{warnings=St#comp.warnings ++ Ws}}; - {error,Es,Ws} -> - {error,St#comp{errors=St#comp.errors ++ Es, - warnings=St#comp.warnings ++ Ws}} - end. - -do_lfe_codegen(#comp{cinfo=Ci,code=Fs0}=St) -> - Fs1 = lfe_pmod:module(Fs0, Ci), - {Mod,Core} = lfe_codegen:module(Fs1, Ci), - {ok,St#comp{code=Core,mod=Mod}}. - -do_erl_comp(St) -> - ErlOpts = erl_comp_opts(St), %Options to erlang compiler - Es = St#comp.errors, - Ws = St#comp.warnings, - case compile:forms(St#comp.code, ErlOpts) of - {ok,_,Result,Ews} -> - {ok,St#comp{code=Result,warnings=Ws ++ fix_erl_errors(Ews)}}; - {error,Ees,Ews} -> - {error,St#comp{errors=Es ++ fix_erl_errors(Ees), - warnings=Ws ++ fix_erl_errors(Ews)}} - end. - -%% erl_comp_opts(State) -> 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(St) -> - Os0 = St#comp.opts, - Filter = fun (report) -> false; %No reporting! - (report_warnings) -> false; - (report_errors) -> false; - ('S') -> false; %No stopping early - ('E') -> false; - ('P') -> false; - (dcore) -> false; - (to_core0) -> false; - (warnings_as_errors) -> false; %We handle this ourselves - (_) -> true %Everything else - end, - Os1 = filter(Filter, Os0), - %% Now build options for the erlang compiler. 'no_bopt' turns off - %% an optimisation in the guard which crashes our code. - [from_core, %We are compiling from core - {source,St#comp.lfile}, %Set the source file - return, %Ensure we return something - binary, %We want a binary - no_bopt|Os1]. - %% passes() -> [Pass]. %% do_passes(Passes, State) -> {ok,State} | {error,State}. -%% {when_flag,Flag,Cmd} -%% {unless_flag,Flag,Cmd} -%% {when_test,Test,Cmd} -%% {unless_test,Test,Cmd} -%% {do,Fun} -%% {done,PrintFun,Ext} +%% +%% {when_flag,Flag,Cmd} Do Cmd if Flag is or is not in the +%% {unless_flag,Flag,Cmd} option list. +%% +%% {when_test,Test,Cmd} Do Cmd if the Test function returns 'true' +%% {unless_test,Test,Cmd} or 'false'. +%% +%% {do,Fun} Call Fun and then continue. +%% +%% {listing,PrintFun} End compilation calling PrintFun to output +%% file. +%% +%% done End compilation. +%% +%% {done,PrintFun} End compilation calling PrintFun to output +%% file, unless 'binary' is specified in which +%% current code will be returned. passes() -> - [{do,fun do_macro_expand/1}, - {when_flag,to_exp,{done,fun sexpr_pp/2,"expand"}}, - {do,fun do_lint/1}, - {when_flag,to_lint,{done,fun sexpr_pp/2,"lint"}}, + [ + %% Split input file into separate modules. + {do,fun do_split_file/1}, + {when_flag,to_split,{done,fun split_pp/1}}, + %% Do per-module macro processing. + {do,fun do_export_macros/1}, + {when_flag,to_emac,{done,fun expmac_pp/1}}, + %% Now we expand and trim remaining macros. + {do,fun do_expand_macros/1}, + {when_flag,to_exp,{done,fun expand_pp/1}}, + {do,fun do_lfe_pmod/1}, + {when_flag,to_pmod,{done,fun pmod_pp/1}}, + {do,fun do_lfe_lint/1}, + {when_flag,to_lint,{done,fun lint_pp/1}}, {do,fun do_lfe_codegen/1}, - {when_flag,to_core0,{done,fun core_pp/2,"core"}}, + {when_flag,to_core0,{done,fun core_pp/1}}, {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"}}, - {unless_test,fun werror/1,{done,fun beam_write/2,"beam"}}]. %Should be last - -do_passes([{when_flag,Flag,Cmd}|Ps], St) -> - case member(Flag, St#comp.opts) of + {when_flag,to_core,{done,fun erl_core_pp/1}}, + {when_flag,to_kernel,{done,fun erl_kernel_pp/1}}, + {when_flag,to_asm,{done,fun erl_asm_pp/1}}, + {unless_test,fun werror/1,{done,fun beam_write/1}} %Should be last + ]. + +do_passes([{when_flag,Flag,Cmd}|Ps], #comp{opts=Opts}=St) -> + case member(Flag, Opts) of true -> do_passes([Cmd|Ps], St); false -> do_passes(Ps, St) end; @@ -264,40 +264,326 @@ {ok,St1} -> do_passes(Ps, St1); {error,St1} -> {error,St1} 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=[]}) +do_passes([{listing,PrintFun}|_], St) -> + PrintFun(St); +do_passes([done|_], St) -> {ok,St}; %Just end now +do_passes([{done,Fun}|_], St) -> + %% Print unless binary, in which case end. + do_passes([{unless_flag,binary,{listing,Fun}}], St); +do_passes([], St) -> {ok,St}. %Got to the end, everything ok! + +%% do_split_file(State) -> {ok,State} | {error,State}. +%% Split a file into separate modules. Everything defined before the +%% first module is available in every module, after that things are +%% local to the module in which they are defined. We need to expand +%% top-level macros in forms so we can safelt detect the start of +%% each module (with define-module form). + +do_split_file(#comp{cinfo=Ci,code=Code}=St) -> + case collect_forms(Code, Ci) of %Expand pre module forms + {Pfs,Fs,Env0,Mst0} -> + %% Expand the modules using the pre forms and environment. + case collect_modules(Fs, Pfs, Env0, Mst0) of + {ok,Ms,_Mst1} -> + {ok,St#comp{code=Ms, + warnings=St#comp.warnings}}; + {error,Es,Ws} -> + {error,St#comp{code=[], %Pseudo module list. + errors=St#comp.errors ++ Es, + warnings=St#comp.warnings ++ Ws}} + end; + {error,Es,Ws} -> + {error,St#comp{code=[], %Pseudo module list. + errors=St#comp.errors ++ Es, + warnings=St#comp.warnings ++ Ws}} + end. + +%% collect_forms(Forms, State) -> +%% {PreForms,RestForms,Env,State}. + +collect_forms(Fs, Ci) -> + Env = lfe_env:new(), + St = lfe_macro:macro_form_init(Ci), + collect_mod_forms(Fs, Env, St). + +%% collect_modules(Forms, PreForms, PreEnv, State) -> +%% {Modules,State}. +%% Collect and expand modules upto the end. Each module initially has +%% the pre environment and all pre forms are appended to it. + +collect_modules(Fs, PreFs, PreEnv, St) -> + collect_modules(Fs, [], PreFs, PreEnv, St). + +collect_modules([{['define-module',Name|_],_}=Mdef|Fs0], Ms, PreFs, PreEnv, St0) -> + %% Expand and collect all forms upto next define-module or end. + case collect_mod_forms(Fs0, PreEnv, St0) of + {Mfs0,Fs1,_,St1} -> + M = {ok,Name,[Mdef] ++ PreFs ++ Mfs0,[]}, + collect_modules(Fs1, [M|Ms], PreFs, PreEnv, St1); + Error -> Error end; -do_passes([], St) -> {ok,St}. %Got to the end, everything ok! +collect_modules([], Ms, _PreFs, _PreEnv, St) -> + {ok,lists:reverse(Ms),St}. + +%% collect_mod_forms(Forms, Env, State) -> +%% collect_mod_forms(Forms, Acc, Env, State) -> +%% {Modforms,RestForms,Env,State}. +%% Expand and collect forms upto the next define-module or end. We +%% also flatten top-level nested progn code. + +collect_mod_forms(Fs, Env0, St0) -> + case collect_mod_forms(Fs, [], Env0, St0) of + {Acc,Rest,Env1,St1} -> + {lists:reverse(Acc),Rest,Env1,St1}; + {error,_,_}=Error -> Error + end. -do_save_file(Fun, Ext, St) -> - Name = filename:join(St#comp.odir, St#comp.base ++ ["."|Ext]), - %% delayed_write useful here but plays havoc with erjang. - case file:open(Name, [write]) of - {ok,File} -> - Fun(File, St#comp.code), - ok = file:close(File), - {ok,St}; - {error,E} -> {error,St#comp{errors=[{file,E}]}} +collect_mod_forms([F0|Fs0], Acc, Env0, St0) -> + case lfe_macro:macro_fileform(F0, Env0, St0) of + {ok,{['define-module'|_],_}=F1,Env1,St1} -> + {Acc,[F1|Fs0],Env1,St1}; + {ok,{['progn'|Pfs],L},Env1,St1} -> %Flatten progn's + Fs1 = [ {F,L} || F <- Pfs ] ++ Fs0, + collect_mod_forms(Fs1, Acc, Env1, St1); + {ok,F1,Env1,St1} -> + collect_mod_forms(Fs0, [F1|Acc], Env1, St1); + {error,Es,Ws,_} -> {error,Es,Ws} + end; +collect_mod_forms([], Acc, Env, St) -> {Acc,[],Env,St}. + +%% do_export_macros(State) -> {ok,State} | {error,State}. +%% do_expand_macros(State) -> {ok,State} | {error,State}. +%% Process the macros in each module. Do_expand_macros is the last +%% pass which fully expands all remaining macros and flattens the +%% output. + +do_export_macros(#comp{cinfo=Ci,code=Ms0}=St) -> + Umac = fun ({ok,Name,Mfs0,Ws}) -> + {Mfs1,_} = lfe_macro_export:module(Mfs0, Ci), + {ok,Name,Mfs1,Ws} + end, + Ms1 = lists:map(Umac, Ms0), + {ok,St#comp{code=Ms1}}. + +do_expand_macros(#comp{cinfo=Ci,code=Ms0}=St0) -> + Emac = fun ({ok,Name,Fs0,Ws}) -> + Env = lfe_env:new(), + Mst = lfe_macro:expand_form_init(Ci), + case process_forms(fun expand_form/3, Fs0, {Env,Mst}) of + {Fs1,_} -> {ok,Name,Fs1,Ws}; + {error,_,_}=Error -> Error + end + end, + Ms1 = lists:map(Emac, Ms0), + St1 = St0#comp{code=Ms1}, + case all_ok(Ms1) of + true -> {ok,St1}; + false -> {error,St1} + end. + +expand_form(F0, L, {Env0,St0}) -> + case lfe_macro:expand_form(F0, L, Env0, St0) of + {ok,[progn|Pfs],Env1,St1} -> + process_forms(fun expand_form/3, Pfs, L, {Env1,St1}); + {ok,['eval-when-compile'|_],Env1,St1} -> + {[],{Env1,St1}}; + {ok,F1,Env1,St1} -> + {[{F1,L}],{Env1,St1}}; + {error,Es,Ws,_} -> throw({expand_form,{error,Es,Ws}}) + end. + +%% process_forms(Fun, Forms, State) -> {Forms,State} | Error. +%% process_forms(Fun, Forms, Line, State) -> {Forms,State} | Error. +%% Wrappers around lfe_lib:proc_forms which catch thrown errors. + +process_forms(Fun, Fs, St) -> + try lfe_lib:proc_forms(Fun, Fs, St) + catch + throw:{expand_form,Error} -> Error end. -%% 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. +process_forms(Fun, Fs, L, St) -> + try lfe_lib:proc_forms(Fun, Fs, L, St) + catch + throw:{expand_form,Error} -> Error + end. -sexpr_pp(File, Code) -> lfe_io:prettyprint(File, Code),io:nl(File). +%% do_lfe_pmod(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. -core_pp(File, Core) -> io:put_chars(File, [core_pp:format(Core),$\n]). +do_lfe_pmod(#comp{cinfo=Ci,code=Ms0}=St) -> + Pmod = fun ({ok,_,Mfs0,Ws}) -> + {Name,Mfs1} = lfe_pmod:module(Mfs0, Ci), + {ok,Name,Mfs1,Ws} + end, + Ms1 = lists:map(Pmod, Ms0), + {ok,St#comp{code=Ms1}}. + +do_lfe_lint(#comp{cinfo=Ci,code=Ms0}=St0) -> + Lint = fun ({ok,_,Mfs,Ws}) -> + case lfe_lint:module(Mfs, Ci) of + {ok,Name,Lws} -> {ok,Name,Mfs,Ws ++ Lws}; + {error,Les,Lws} -> {error,Les,Ws ++ Lws} + end + end, + %% Lint the modules, then check if all are ok. + Ms1 = lists:map(Lint, Ms0), + St1 = St0#comp{code=Ms1}, + case all_ok(Ms1) of + true -> {ok,St1}; + false -> {error,St1} + end. -kernel_pp(File, Kern) -> io:put_chars(File, [v3_kernel_pp:format(Kern),$\n]). +do_lfe_codegen(#comp{cinfo=Ci,code=Ms0}=St) -> + Code = fun ({ok,Name,Mfs,Ws}) -> %Name consistency check! + {Name,Core} = lfe_codegen:module(Mfs, Ci), + {ok,Name,Core,Ws} + end, + Ms1 = lists:map(Code, Ms0), + {ok,St#comp{code=Ms1}}. + +do_erl_comp(#comp{code=Ms0}=St0) -> + ErlOpts = erl_comp_opts(St0), %Options to erlang compiler + %% Compile all the modules, then if all are ok. + Ms1 = lists:map(fun (M) -> do_erl_comp_mod(M, ErlOpts) end, Ms0), + St1 = St0#comp{code=Ms1}, + case all_ok(Ms1) of + true -> {ok,St1}; + false -> {error,St1} + end. -asm_pp(File, Asm) -> beam_listing:module(File, Asm). +do_erl_comp_mod({ok,Name,Core,Ws}, ErlOpts) -> + %% lfe_io:format("~p\n", [Core]), + case compile:forms(Core, ErlOpts) of + {ok,_,Result,Ews} -> + {ok,Name,Result,Ws ++ fix_erl_errors(Ews)}; + {error,Ees,Ews} -> + {error,fix_erl_errors(Ees),fix_erl_errors(Ews)} + end. -beam_write(File, Beam) -> file:write(File, Beam). +all_ok(Res) -> + lists:all(fun ({ok,_,_,_}) -> true; + ({error,_,_}) -> false + end, Res). + +%% erl_comp_opts(State) -> 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(St) -> + Os0 = St#comp.opts, + Filter = fun (report) -> false; %No reporting! + (report_warnings) -> false; + (report_errors) -> false; + ('S') -> false; %No stopping early + ('E') -> false; + ('P') -> false; + (dcore) -> false; + (to_core0) -> false; + (warnings_as_errors) -> false; %We handle these ourselves + ({source,_}) -> false; + (_) -> true %Everything else + end, + Os1 = filter(Filter, Os0), + %% Now build options for the erlang compiler. 'no_bopt' turns off + %% an optimisation in the guard which crashes our code. + [from_core, %We are compiling from core + {source,St#comp.lfile}, %Set the source file + return, %Ensure we return something + binary, %We want a binary + no_bopt|Os1]. + +%% split_pp(State) -> {ok,State} | {error,State}. +%% expmac_pp(State) -> {ok,State} | {error,State}. +%% expand_pp(State) -> {ok,State} | {error,State}. +%% pmod_pp(State) -> {ok,State} | {error,State}. +%% lint_pp(State) -> {ok,State} | {error,State}. +%% sexpr_pp(State) -> {ok,State} | {error,State}. +%% core_pp(State) -> {ok,State} | {error,State}. +%% erl_core_pp(State) -> {ok,State} | {error,State}. +%% erl_kernel_pp(State) -> {ok,State} | {error,State}. +%% erl_asm_pp(State) -> {ok,State} | {error,State}. +%% beam_write(State) -> {ok,State} | {error,State}. +%% Output the various file types. The XXX_pp functions output with +%% the same name as the input file while beam_write outputs to the +%% module name. + +%% This just print the whole file structure. +split_pp(St) -> sexpr_pp(St, "split"). +expmac_pp(St) -> sexpr_pp(St, "expmac"). +expand_pp(St) -> sexpr_pp(St, "expand"). +pmod_pp(St) -> sexpr_pp(St, "pmod"). +lint_pp(St) -> sexpr_pp(St, "lint"). + +sexpr_pp(St, Ext) -> + Save = fun (File, {ok,_,Code,_}) -> + lfe_io:prettyprint(File, Code), io:nl(File) + end, + do_list_save_file(Save, Ext, St). + +%% These print a list of module structures. +core_pp(St) -> + Save = fun (File, {ok,_,Core,_}) -> + io:put_chars(File, [core_pp:format(Core),$\n]) + end, + do_list_save_file(Save, "core", St). + +erl_core_pp(St) -> + Save = fun (File, {ok,_,Core,_}) -> + io:put_chars(File, [core_pp:format(Core),$\n]) + end, + do_list_save_file(Save, "core", St). + +erl_kernel_pp(St) -> + Save = fun (File, {ok,_,Kern,_}) -> + io:put_chars(File, [v3_kernel_pp:format(Kern),$\n]) end, + do_list_save_file(Save, "kernel", St). + +erl_asm_pp(St) -> + Save = fun (File, {ok,_,Asm,_}) -> + beam_listing:module(File, Asm), io:nl(File) end, + do_list_save_file(Save, "S", St). + +do_list_save_file(SaveOne, Ext, St) -> + SaveAll = fun (File, Code) -> + lists:foreach(fun (C) -> SaveOne(File, C) end, Code) + end, + do_save_file(SaveAll, Ext, St). + +do_save_file(Save, Ext, St) -> + Name = filename:join(St#comp.odir, St#comp.base ++ ["."|Ext]), + %% delayed_write useful here but plays havoc with erjang. + case file:open(Name, [write]) of + {ok,File} -> + Ret = Save(File, St#comp.code), + ok = file:close(File), + case Ret of + ok -> {ok,St}; + {error,E} -> {error,St#comp{errors=[{file,E}]}} + end; + {error,E} -> {error,St#comp{errors=[{file,E}]}} + end. + +beam_write(St0) -> + Res = lists:map(fun (M) -> beam_write_module(M, St0) end, St0#comp.code), + St1 = St0#comp{code=Res}, + %% Check return status. + case lists:all(fun ({ok,_,_,_}) -> true; ({error,_,_}) -> false end, Res) of + true -> {ok,St1}; + false -> {error,St1} + end. + +beam_write_module({ok,M,Beam,_}=Mod, St) -> + Name = filename:join(St#comp.odir, lists:concat([M,".beam"])), + case file:write_file(Name, Beam) of + ok -> Mod; + {error,E} -> + {error,St#comp{errors=[{file,E}]}} + end. %% fix_erl_errors([{File,Errors}]) -> Errors. @@ -308,84 +594,96 @@ %% do_ok_return(State) -> {ok,Mod,...}. %% do_error_return(State) -> {error,...} | error. -%% Note that this handling of 'warnings_as_errors' is the same in the -%% vanilla erlang compiler 'compile'. +%% Note that this handling of 'warnings_as_errors' is the same in the +%% vanilla erlang compiler 'compile'. -do_ok_return(#comp{lfile=Lfile,opts=Opts,ret=Ret0,warnings=Ws}=St) -> +do_ok_return(#comp{code=Code,lfile=Lfile,opts=Opts,warnings=Ws}=St) -> case werror(St) of - true -> do_error_return(St); %Warnings are errors! - false -> - when_opt(report, Opts, fun () -> list_warnings(Lfile, Ws) end), - %% Fix right return. - Ret1 = case member(return, Opts) of - true -> Ret0 ++ [return_errors(Lfile, Ws)]; - false -> Ret0 - end, - list_to_tuple([ok,St#comp.mod|Ret1]) + true -> do_error_return(St); %Warnings are errors! + false -> + when_opt(report, Opts, fun () -> list_warnings(Lfile, Ws) end), + %% Fix right return. + Report = member(report, Opts), + Return = member(return, Opts), + Binary = member(binary, Opts), + RetMod = fun (M) -> + ok_return_mod(M, Report, Return, Binary, Lfile) + end, + Ret0 = lists:map(RetMod, Code), + Ret1 = if Return -> [Ret0,return_ews(Lfile, Ws)]; + true -> [Ret0] + end, + list_to_tuple([ok|Ret1]) %And build the ok tuple end. -do_error_return(#comp{lfile=Lfile,opts=Opts,errors=Es,warnings=Ws}) -> +ok_return_mod({ok,Name,Mods,Ws}, Report, Return, Binary, Lfile) -> + Report andalso list_warnings(Lfile, Ws), + Ret0 = if Return -> [return_ews(Lfile, Ws)]; + true -> [] + end, + Ret1 = if Binary -> [Mods|Ret0]; + true -> Ret0 + end, + list_to_tuple([ok,Name|Ret1]). %And build the ok tuple + +do_error_return(#comp{code=Code,lfile=Lfile,opts=Opts,errors=Es,warnings=Ws}) -> when_opt(report, Opts, fun () -> list_errors(Lfile, Es) end), when_opt(report, Opts, fun () -> list_warnings(Lfile, Ws) end), + Report = lists:member(report, Opts), + Return = lists:member(return, Opts), + Err = lists:map(fun (M) -> error_return_mod(M, Report, Return, Lfile) end, + Code), %% Fix right return. - case member(return, Opts) of - true -> {error,return_errors(Lfile, Es),return_errors(Lfile, Ws)}; - false -> error + case Return of + true -> {error,Err,return_ews(Lfile, Es),return_ews(Lfile, Ws)}; + false -> error end. -return_errors(_, []) -> []; -return_errors(Lfile, Es) -> [{Lfile,Es}]. +error_return_mod({ok,_,_,Ws}, Rep, _, Lfile) -> + Rep andalso list_warnings(Lfile, Ws), + {error,[],return_ews(Lfile, Ws)}; +error_return_mod({error,Es,Ws}, Rep, _, Lfile) -> + Rep andalso list_errors(Lfile, Es), + Rep andalso list_warnings(Lfile, Ws), + {error,return_ews(Lfile, Es),return_ews(Lfile, Ws)}. + +return_ews(_, []) -> []; +return_ews(Lfile, Es) -> [{Lfile,Es}]. 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). + 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). + 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(debug_print, St#comp.opts, - fun () -> lfe_io:format(Format, Args) end). + fun () -> lfe_io:format(Format, Args) end). %% when_opt(Option, Options, Fun) -> ok. %% unless_opt(Option, Options, Fun) -> ok. -%% Vall Fun when Option is/is not a member of Options. +%% Call Fun when Option is/is not a member of Options. when_opt(Opt, Opts, Fun) -> case member(Opt, Opts) of - true -> Fun(); - false -> ok + true -> Fun(); + false -> ok end. %% unless_opt(Opt, Opts, Fun) -> %% case member(Opt, Opts) of -%% true -> ok; -%% false -> Fun() +%% true -> ok; +%% false -> Fun() %% end. - -%% Direct translations. -%% (defmacro when-opt (fun o os) -%% `(if (member ,o ,os) (funcall ,fun) 'ok)) -%% (defmacro unless-opt (fun o os) -%% `(if (member ,o ,os) 'ok (funcall ,fun))) - -%% Lispier versions. -%% (defmacro when-opt -%% ((o os . body) -%% `(if (member ,o ,os) (progn ,@body) 'ok))) -%% (defmacro unless-opt -%% ((o os . body) -%% `(if (member ,o ,os) 'ok (progn ,@body)))) -%% (defmacro debug-print (f as st) -%% (when-opt 'debug_print (comp-opts st) (: lfe_io format f as)))
View file
lfe-0.9.2.tar.gz/src/lfe_comp.hrl -> lfe-1.0.tar.gz/src/lfe_comp.hrl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2014 Robert Virding +%% Copyright (c) 2014-2015 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -23,3 +23,8 @@ ipath=[], %Include path mod=none %Module name }). + +-record(module, {name=[], %Module name + code, %Module code + warnings=[] %Module warnings + }).
View file
lfe-1.0.tar.gz/src/lfe_edlin_expand.erl
Added
@@ -0,0 +1,247 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-2010. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +-module(lfe_edlin_expand). + +%% A default LFE expand function for edlin, expanding modules and +%% functions. It knows about LFE symbol syntax but as yet only works +%% for (mod:fun ...) and not (: mod fun ...) + +-export([expand/1, format_matches/1]). + +-import(lists, [reverse/1, nthtail/2, prefix/2]). + +%% expand(CurrentBefore) -> +%% {yes, Expansion, Matches} | {no, Expansion, Matches} +%% Try to expand the word before as either a module name or a +%% function name. CurrentBefore is reversed and over_word/3 reverses +%% the characters it finds. In certain cases possible expansions are +%% printed. + +expand(Bef0) -> + {Bef1,S1,_} = over_symbol(Bef0, [], 0), + case Bef1 of + [$:|Bef2] -> %After a ':' + {Bef3,S2,_} = over_symbol(Bef2, [], 0), + need_lparen(Bef3, fun () -> expand_function_name(S2, S1) end); + Bef2 -> + need_lparen(Bef2, fun () -> expand_module_name(S1) end) + end. + +need_lparen(Bef, Do) -> + case over_white(Bef, [], 0) of + {[$(|_],_,_} -> Do(); + {_,_,_} -> {no,[],[]} + end. + +%% expand(Bef0) -> +%% {Bef1,Word,_} = edlin:over_word(Bef0, [], 0), +%% case over_white(Bef1, [], 0) of +%% {[$:|Bef2],_White,_Nwh} -> +%% {Bef3,_White1,_Nwh1} = over_white(Bef2, [], 0), +%% {_,Mod,_Nm} = edlin:over_word(Bef3, [], 0), +%% expand_function_name(Mod, Word); +%% {_,_,_} -> +%% expand_module_name(Word) +%% end. + +expand_module_name(Prefix) -> + match(Prefix, code:all_loaded(), ":"). + +expand_function_name(ModStr, FuncPrefix) -> + case to_symbol(ModStr) of + {ok,Mod} -> + case erlang:module_loaded(Mod) of + true -> + L = Mod:module_info(), + case lists:keyfind(exports, 1, L) of + {_, Exports} -> + match(FuncPrefix, Exports, " "); + _ -> + {no,[],[]} + end; + false -> + {no,[],[]} + end; + error -> + {no,[],[]} + end. + +%% If it's a quoted symbol, atom_to_list/1 will do the wrong thing. +to_symbol(Str) -> + case lfe_scan:string(Str) of + {ok,[{symbol,_,A}],_} -> {ok,A}; + _ -> error + end. + +match(Prefix, Alts, Extra0) -> + Len = length(Prefix), + Matches = lists:sort([{S, A} || {H, A} <- Alts, + begin + S = hd(lfe_io:fwrite1("~w", [H])), + prefix(Prefix, S) + end]), + case longest_common_head([N || {N, _} <- Matches]) of + {partial, []} -> + {no, [], Matches}; %format_matches(Matches)}; + {partial, Str} -> + case nthtail(Len, Str) of + [] -> {yes,[],Matches}; %format_matches(Matches)}; + Remain -> {yes,Remain,[]} + end; + {complete, Str} -> + Extra = case {Extra0,Matches} of + {" ",[{Str,0}]} -> ")"; + {_,_} -> Extra0 + end, + {yes, nthtail(Len, Str) ++ Extra, []}; + no -> + {no,[],[]} + end. + +%% Return the list of names L in multiple columns. +format_matches(L) -> + S = format_col(lists:sort(L), []), + ["\n" | S]. + +format_col([], _) -> []; +format_col(L, Acc) -> format_col(L, field_width(L), 0, Acc). + +format_col(X, Width, Len, Acc) when Width + Len > 79 -> + format_col(X, Width, 0, ["\n" | Acc]); +format_col([A|T], Width, Len, Acc0) -> + H = case A of + %% If it's a tuple {string(), integer()}, we assume it's an + %% arity, and meant to be printed. + {H0, I} when is_integer(I) -> + H0 ++ "/" ++ integer_to_list(I); + {H1, _} -> H1; + H2 -> H2 + end, + Acc = [io_lib:format("~-*s", [Width,H]) | Acc0], + format_col(T, Width, Len+Width, Acc); +format_col([], _, _, Acc) -> + lists:reverse(Acc, "\n"). + +field_width(L) -> field_width(L, 0). + +field_width([{H,_}|T], W) -> + case length(H) of + L when L > W -> field_width(T, L); + _ -> field_width(T, W) + end; +field_width([H|T], W) -> + case length(H) of + L when L > W -> field_width(T, L); + _ -> field_width(T, W) + end; +field_width([], W) when W < 40 -> + W + 4; +field_width([], _) -> + 40. + +longest_common_head([]) -> + no; +longest_common_head(LL) -> + longest_common_head(LL, []). + +longest_common_head([[]|_], L) -> + {partial, reverse(L)}; +longest_common_head(LL, L) -> + case same_head(LL) of + true -> + [[H|_]|_] = LL, + LL1 = all_tails(LL), + case all_nil(LL1) of + true -> + {complete, reverse([H|L])}; + false -> + longest_common_head(LL1, [H|L]) + end; + false -> + {partial, reverse(L)} + end. + +same_head([[H|_]|T1]) -> same_head(H, T1). + +same_head(H, [[H|_]|T]) -> same_head(H, T); +same_head(_, []) -> true; +same_head(_, _) -> false. + +all_tails(LL) -> all_tails(LL, []). + +all_tails([[_|T]|T1], L) -> all_tails(T1, [T|L]); +all_tails([], L) -> L. + +all_nil([]) -> true; +all_nil([[] | Rest]) -> all_nil(Rest); +all_nil(_) -> false. + +%% over_symbol(Chars, InitialStack, InitialCount) -> +%% {RemainingChars,CharStack,Count} +%% over_non_symbol(Chars, InitialStack, InitialCount) -> +%% {RemainingChars,CharStack,Count} +%% Step over symbol/non-symbol characters pushing the stepped over +%% ones on the stack. + +over_symbol(Cs, Stack, N) -> + L = length([1 || $| <- Cs]), + case L rem 2 of + 0 -> over_symbol1(Cs, Stack, N); + 1 -> until_quote(Cs, Stack, N) + end. + +until_quote([$||Cs], Stack, N) -> + {Cs, [$||Stack], N+1}; +until_quote([C|Cs], Stack, N) -> + until_quote(Cs, [C|Stack], N+1). + +over_symbol1([$||Cs], Stack, N) -> + until_quote(Cs, [$||Stack], N+1); +over_symbol1(Cs, Stack, N) -> + over_symbol2(Cs, Stack, N). + +over_symbol2([C|Cs], Stack, N) -> + case symbol_char(C) of + true -> over_symbol2(Cs, [C|Stack], N+1); + false -> {[C|Cs],Stack,N} + end; +over_symbol2([], Stack, N) when is_integer(N) -> + {[],Stack,N}. + +over_non_symbol([C|Cs], Stack, N) -> + case symbol_char(C) of + true -> {[C|Cs],Stack,N}; + false -> over_non_symbol(Cs, [C|Stack], N+1) + end; +over_non_symbol([], Stack, N) -> + {[],Stack,N}. + +symbol_char($:) -> false; %We want to separate on this +symbol_char(C) -> lfe_scan:symbol_char(C). + +%% over_white(Chars, InitialStack, InitialCount) -> +%% {RemainingChars,CharStack,Count}. + +over_white([$\s|Cs], Stack, N) -> + over_white(Cs, [$\s|Stack], N+1); +over_white([$\t|Cs], Stack, N) -> + over_white(Cs, [$\t|Stack], N+1); +over_white(Cs, Stack, N) when is_list(Cs) -> + {Cs,Stack,N}.
View file
lfe-0.9.2.tar.gz/src/lfe_env.erl -> lfe-1.0.tar.gz/src/lfe_env.erl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2008-2014 Robert Virding +%% Copyright (c) 2008-2016 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -19,7 +19,8 @@ -module(lfe_env). -export([new/0,add_env/2, - get_vars/1,clr_vars/1,set_vars/2,get_funs/1,clr_funs/1,set_funs/2, + get_vars/1,clr_vars/1,set_vars/2,fold_vars/3, + get_funs/1,clr_funs/1,set_funs/2,fold_funs/3,fold_macros/3, add_vbinding/3,add_vbindings/2,is_vbound/2,get_vbinding/2, fetch_vbinding/2,del_vbinding/2, add_fbinding/4,add_fbindings/2, @@ -31,8 +32,34 @@ -import(lfe_lib, [is_bif/2,is_lfe_bif/2,is_erl_bif/2,is_guard_bif/2]). -import(lists, [reverse/1,reverse/2,map/2,foldl/3,dropwhile/2]). +%% Define access macros depending on whether we have maps. +-ifdef(HAS_MAPS). +-define(NEW(), #{}). +-define(IS_KEY(K, D), maps:is_key(K, D)). +-define(GET(K, D), maps:get(K, D)). +-define(FIND(K, D), maps:find(K, D)). +-define(PUT(K, V, D), maps:put(K, V, D)). +-define(ERASE(K, D), maps:remove(K, D)). +-define(FOLD(F, A, D), maps:fold(F, A, D)). +-define(UPDATE(K, UPD, DEF, D), %This is slightly complex + begin (fun (___K, {ok,___V}) -> + maps:put(___K, UPD(___V), D); + (___K, error) -> + maps:put(___K, DEF, D) + end)(K, maps:find(K, D)) end). +-else. +-define(NEW(), orddict:new()). +-define(IS_KEY(K, D), orddict:is_key(K, D)). +-define(GET(K, D), orddict:fetch(K, D)). +-define(FIND(K, D), orddict:find(K, D)). +-define(PUT(K, V, D), orddict:store(K, V, D)). +-define(ERASE(K, D), orddict:erase(K, D)). +-define(FOLD(F, A, D), orddict:fold(F, A, D)). +-define(UPDATE(K, UPD, DEF, D), orddict:update(K, UPD, DEF, D)). +-endif. + %% The environment structure. --record(env, {vars=[],funs=[]}). +-record(env, {vars=null,funs=null}). %% -compile([export_all]). @@ -41,9 +68,12 @@ %% get_vars(Env) -> Vars. %% clr_vars(Env) -> Env. %% set_vars(Vars, Env) -> Env. +%% fold_vars(Fun, Acc, Env) -> Acc. %% get_funs(Env) -> Funs. %% clr_funs(Env) -> Env. %% set_funs(Funs, Env) -> Env. +%% fold_funs(Fun, Acc, Env) -> Acc. +%% fold_macros(Fun, Acc, Env) -> Acc. %% add_vbinding(Name, Val, Env) -> Env. %% add_vbindings([{Name,Val}], Env) -> Env. %% is_vbound(Symb, Env) -> bool(). @@ -79,44 +109,69 @@ %% is no longer a legal guard bif but must be explicitly called with %% module erlang. -new() -> #env{vars=orddict:new(),funs=orddict:new()}. +new() -> #env{vars=?NEW(),funs=?NEW()}. +-ifdef(HAS_MAPS). +add_env(#env{vars=Vs1,funs=Fs1}, #env{vars=Vs2,funs=Fs2}) -> + #env{vars=maps:merge(Vs2, Vs1), %Always take left env + funs=maps:merge(Fs2, Fs1)}. +-else. add_env(#env{vars=Vs1,funs=Fs1}, #env{vars=Vs2,funs=Fs2}) -> Merge = fun (_, V1, _) -> V1 end, %Always take left env #env{vars=orddict:merge(Merge, Vs1, Vs2), funs=orddict:merge(Merge, Fs1, Fs2)}. +-endif. get_vars(Env) -> Env#env.vars. -clr_vars(Env) -> Env#env{vars=orddict:new()}. +clr_vars(Env) -> Env#env{vars=?NEW()}. set_vars(Vars, Env) -> Env#env{vars=Vars}. +fold_vars(Fun, Acc, Env) -> + ?FOLD(Fun, Acc, Env#env.vars). get_funs(Env) -> Env#env.funs. -clr_funs(Env) -> Env#env{funs=orddict:new()}. +clr_funs(Env) -> Env#env{funs=?NEW()}. set_funs(Funs, Env) -> Env#env{funs=Funs}. +fold_funs(Fun, Acc, Env) -> + Ofun = fun (F, {function,Fs}, Ac) -> %Function + Ffun = fun ({Ar,Def}, A) -> + Fun(F, Ar, Def, A) + end, + lists:foldl(Ffun, Ac, Fs); + (_, _, A) -> A %Macro + end, + ?FOLD(Ofun, Acc, Env#env.funs). + +fold_macros(Fun, Acc, Env) -> + Ofun = fun (F, {macro,Def}, A) -> %Macro + Fun(F, Def, A); + (_, _, A) -> A %Function + end, + ?FOLD(Ofun, Acc, Env#env.funs). + %% Variables. add_vbinding(N, V, #env{vars=Vs}=Env) -> - Env#env{vars=orddict:store(N, V, Vs)}. + Env#env{vars=?PUT(N, V, Vs)}. add_vbindings(Vbs, #env{vars=Vs0}=Env) -> - Vs1 = foldl(fun ({N,V}, Vs) -> orddict:store(N, V, Vs) end, Vs0, Vbs), + Vs1 = foldl(fun ({N,V}, Vs) -> ?PUT(N, V, Vs) end, Vs0, Vbs), Env#env{vars=Vs1}. is_vbound(N, #env{vars=Vs}) -> - orddict:is_key(N, Vs). + ?IS_KEY(N, Vs). get_vbinding(N, #env{vars=Vs}) -> - case orddict:find(N, Vs) of + case ?FIND(N, Vs) of {ok,V} -> {yes,V}; error -> no end. fetch_vbinding(N, #env{vars=Vs}) -> - orddict:fetch(N, Vs). + ?GET(N, Vs). del_vbinding(N, #env{vars=Vs}=Env) -> - Env#env{vars=orddict:erase(N, Vs)}. + Env#env{vars=?ERASE(N, Vs)}. %% Functions. @@ -130,7 +185,7 @@ {function,lists:keystore(A, 1, Fas, T)}; (_) -> Def %Overwrite macros end, - orddict:update(N, Upd, Def, Fs). + ?UPDATE(N, Upd, Def, Fs). add_fbindings(Fbs, #env{funs=Fs0}=Env) -> Fs1 = foldl(fun ({N,A,V}, Fs) -> add_fbinding_1(N, A, {A,V}, Fs) end, @@ -142,18 +197,18 @@ Env#env{funs=Fs1}. is_fbound(N, A, #env{funs=Fs}) -> - case orddict:find(N, Fs) of + case ?FIND(N, Fs) of {ok,{function,Fas}} -> - case lists:keyfind(A, 1, Fas) of - false -> is_bif(N, A); - _ -> true - end; + case lists:keyfind(A, 1, Fas) of + false -> is_bif(N, A); + _ -> true + end; {ok,_} -> false; %A macro error -> is_bif(N, A) end. get_fbinding(N, A, #env{funs=Fs}) -> - case orddict:find(N, Fs) of + case ?FIND(N, Fs) of {ok,{function,Fas}} -> case lists:keyfind(A, 1, Fas) of {A,M,F} -> {yes,M,F}; @@ -177,51 +232,51 @@ end. is_gbound(N, A, #env{funs=Fs}) -> - case orddict:find(N, Fs) of + case ?FIND(N, Fs) of {ok,{function,Fas}} -> - case lists:keyfind(A, 1, Fas) of - false -> is_guard_bif(N, A); - _ -> false - end; + case lists:keyfind(A, 1, Fas) of + false -> is_guard_bif(N, A); + _ -> false + end; {ok,_} -> false; %A macro error -> is_guard_bif(N, A) end. get_gbinding(N, A, #env{funs=Fs}) -> - case orddict:find(N, Fs) of + case ?FIND(N, Fs) of {ok,{function,Fas}} -> - case lists:keyfind(A, 1, Fas) of - false -> get_guard_bif(N, A); - _ -> no - end; - {ok,_} -> no; %A macro + case lists:keyfind(A, 1, Fas) of + false -> get_guard_bif(N, A); + _ -> no + end; + {ok,_} -> no; %A macro error -> get_guard_bif(N, A) end. get_guard_bif(N, A) -> case is_guard_bif(N, A) of - true -> {yes,erlang,N}; - false -> no + true -> {yes,erlang,N}; + false -> no end. %% Macros. add_mbinding(N, V, #env{funs=Fs}=Env) -> - Env#env{funs=orddict:store(N, {macro,V}, Fs)}. + Env#env{funs=?PUT(N, {macro,V}, Fs)}. add_mbindings(Fbs, #env{funs=Fs0}=Env) -> - Fs1 = foldl(fun ({N,V}, Fs) -> orddict:store(N, {macro,V}, Fs) end, + Fs1 = foldl(fun ({N,V}, Fs) -> ?PUT(N, {macro,V}, Fs) end, Fs0, Fbs), Env#env{funs=Fs1}. is_mbound(N, #env{funs=Fs}) -> - case orddict:find(N, Fs) of + case ?FIND(N, Fs) of {ok,{macro,_}} -> true; _ -> false end. get_mbinding(N, #env{funs=Fs}) -> - case orddict:find(N, Fs) of + case ?FIND(N, Fs) of {ok,{macro,V}} -> {yes,V}; _ -> no end.
View file
lfe-0.9.2.tar.gz/src/lfe_eval.erl -> lfe-1.0.tar.gz/src/lfe_eval.erl
Changed
@@ -120,7 +120,7 @@ Pairs = map_pairs(As, Env), maps:from_list(Pairs); eval_expr(['mref',Map,K], Env) -> - Key = map_key(K), + Key = map_key(K, Env), maps:get(Key, eval_expr(Map, Env)); eval_expr(['mset',M|As], Env) -> Map = eval_expr(M, Env), @@ -137,10 +137,10 @@ eval_expr(['map-update',M|As], Env) -> eval_expr([mupd,M|As], Env); %% Handle the Core closure special forms. -eval_expr([lambda|Body], Env) -> - eval_lambda(Body, Env); -eval_expr(['match-lambda'|Cls], Env) -> - eval_match_lambda(Cls, Env); +eval_expr([lambda|_]=Sexpr, Env) -> + eval_lambda_expr(Sexpr, Env); +eval_expr(['match-lambda'|_]=Sexpr, Env) -> + eval_lambda_expr(Sexpr, Env); eval_expr(['let'|Body], Env) -> eval_let(Body, Env); eval_expr(['let-function'|Body], Env) -> @@ -209,7 +209,8 @@ foldr(fun (S, Vs) -> get_bitseg(S, Vs) end, [], Segs). %% get_bitseg(Bitseg, ValSpecs) -> ValSpecs. -%% A bitseg is either an atomic value, a list of value and specs, or a string. +%% A bitseg is either an atomic value, a list of value and specs, or +%% a string. get_bitseg([Val|Specs]=Seg, Vsps) -> case is_posint_list(Seg) of %Is bitseg a string? @@ -259,30 +260,30 @@ eval_exp_bitseg(Val, Size, Eval, Type) -> case Type of - %% Integer types. - {integer,Un,Si,En} -> - Sz = Eval(Size), - eval_int_bitseg(Val, Sz*Un, Si, En); - %% Unicode types, ignore unused fields. - {utf8,_,_,_} -> <<Val/utf8>>; - {utf16,_,_,En} -> eval_utf16_bitseg(Val, En); - {utf32,_,_,En} -> eval_utf32_bitseg(Val, En); - %% Float types. - {float,Un,_,En} -> - Sz = Eval(Size), - eval_float_bitseg(Val, Sz*Un, En); - %% Binary types. - {binary,Unit,_,_} -> - if Size == all -> - case bit_size(Val) of - Sz when Sz rem Unit =:= 0 -> - <<Val:Sz/bitstring>>; - _ -> eval_error(badarg) - end; - true -> + %% Integer types. + {integer,Un,Si,En} -> Sz = Eval(Size), - <<Val:(Sz*Unit)/bitstring>> - end + eval_int_bitseg(Val, Sz*Un, Si, En); + %% Unicode types, ignore unused fields. + {utf8,_,_,_} -> <<Val/utf8>>; + {utf16,_,_,En} -> eval_utf16_bitseg(Val, En); + {utf32,_,_,En} -> eval_utf32_bitseg(Val, En); + %% Float types. + {float,Un,_,En} -> + Sz = Eval(Size), + eval_float_bitseg(Val, Sz*Un, En); + %% Binary types. + {binary,Unit,_,_} -> + if Size == all -> + case bit_size(Val) of + Sz when Sz rem Unit =:= 0 -> + <<Val:Sz/bitstring>>; + _ -> eval_error(badarg) + end; + true -> + Sz = Eval(Size), + <<Val:(Sz*Unit)/bitstring>> + end end. eval_int_bitseg(Val, Sz, signed, big) -> <<Val:Sz/signed>>; @@ -307,101 +308,77 @@ %% map_pairs(Args, Env) -> [{K,V}]. map_pairs([K,V|As], Env) -> - P = {map_key(K),eval_expr(V, Env)}, + P = {map_key(K, Env),eval_expr(V, Env)}, [P|map_pairs(As, Env)]; map_pairs([], _) -> []; map_pairs(_, _) -> eval_error(badarg). -%% map_key(Key) -> Value. -%% Map keys can only be literals. +%% map_key(Key, Env) -> Value. +%% A map key can only be a literal in 17 but can be anything in 18.. -map_key([quote,E]) -> E; -map_key([_|_]=L) -> +-ifdef(HAS_FULL_KEYS). +map_key(Key, Env) -> + eval_expr(Key, Env). +-else. +map_key([quote,E], _) -> E; +map_key([_|_]=L, _) -> case is_posint_list(L) of - true -> L; %Literal strings + true -> L; %Literal strings only false -> eval_error(illegal_mapkey) end; -map_key(E) when not is_atom(E) -> E; %Everything else -map_key(_) -> eval_error(illegal_mapkey). +map_key(E, _) when not is_atom(E) -> E; %Everything else +map_key(_, _) -> eval_error(illegal_mapkey). +-endif. -%% eval_lambda(LambdaBody, Env) -> Val. +%% eval_lambda_expr([lambda|LambdaBody], Env) -> Val. %% Evaluate (lambda args ...). +%% eval_lambda_expr(['match-lambda'|MatchClauses], Env) -> Val. +%% Evaluate (match-lambda cls ...). -eval_lambda([Args|Body], Env) -> +eval_lambda_expr(Sexp, Env) -> + {Arity,Apply} = + case Sexp of + [lambda,Args|Body] -> + { length(Args) + , fun (Vals) -> apply_lambda(Args, Body, Vals, Env) end }; + ['match-lambda'|Cls] -> + { match_lambda_arity(Cls) + , fun(Vals) -> apply_match_lambda(Cls, Vals, Env) end } + end, %% This is a really ugly hack! But it's the same hack as in erl_eval. - case length(Args) of - 0 -> fun () -> apply_lambda([], Body, [], Env) end; - 1 -> fun (A) -> apply_lambda(Args, Body, [A], Env) end; - 2 -> fun (A,B) -> apply_lambda(Args, Body, [A,B], Env) end; - 3 -> fun (A,B,C) -> apply_lambda(Args, Body, [A,B,C], Env) end; - 4 -> fun (A,B,C,D) -> apply_lambda(Args, Body, [A,B,C,D], Env) end; - 5 -> fun (A,B,C,D,E) -> apply_lambda(Args, Body, [A,B,C,D,E], Env) end; - 6 -> fun (A,B,C,D,E,F) -> - apply_lambda(Args, Body, [A,B,C,D,E,F], Env) end; - 7 -> fun (A,B,C,D,E,F,G) -> - apply_lambda(Args, Body, [A,B,C,D,E,F,G], Env) end; - 8 -> fun (A,B,C,D,E,F,G,H) -> - apply_lambda(Args, Body, [A,B,C,D,E,F,G,H], Env) end; - 9 -> fun (A,B,C,D,E,F,G,H,I) -> - apply_lambda(Args, Body, [A,B,C,D,E,F,G,H,I], Env) end; - 10 -> fun (A,B,C,D,E,F,G,H,I,J) -> - apply_lambda(Args, Body, [A,B,C,D,E,F,G,H,I,J], Env) end; - 11 -> fun (A,B,C,D,E,F,G,H,I,J,K) -> - apply_lambda(Args, Body, [A,B,C,D,E,F,G,H,I,J,K], Env) end; - 12 -> fun (A,B,C,D,E,F,G,H,I,J,K,L) -> - apply_lambda(Args, Body, [A,B,C,D,E,F,G,H,I,J,K,L], Env) end; - 13 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M) -> - apply_lambda(Args, Body, [A,B,C,D,E,F,G,H,I,J,K,L,M], Env) end; - 14 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N) -> - apply_lambda(Args, Body, [A,B,C,D,E,F,G,H,I,J,K,L,M,N], Env) end; - 15 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O) -> - apply_lambda(Args, Body, [A,B,C,D,E,F,G,H,I,J,K,L,M,N,O], Env) end + case Arity of + 0 -> fun () -> Apply([]) end; + 1 -> fun (A) -> Apply([A]) end; + 2 -> fun (A,B) -> Apply([A,B]) end; + 3 -> fun (A,B,C) -> Apply([A,B,C]) end; + 4 -> fun (A,B,C,D) -> Apply([A,B,C,D]) end; + 5 -> fun (A,B,C,D,E) -> Apply([A,B,C,D,E]) end; + 6 -> fun (A,B,C,D,E,F) -> Apply([A,B,C,D,E,F]) end; + 7 -> fun (A,B,C,D,E,F,G) -> Apply([A,B,C,D,E,F,G]) end; + 8 -> fun (A,B,C,D,E,F,G,H) -> Apply([A,B,C,D,E,F,G,H]) end; + 9 -> fun (A,B,C,D,E,F,G,H,I) -> Apply([A,B,C,D,E,F,G,H,I]) end; + 10 -> fun (A,B,C,D,E,F,G,H,I,J) -> Apply([A,B,C,D,E,F,G,H,I,J]) end; + 11 -> fun (A,B,C,D,E,F,G,H,I,J,K) -> Apply([A,B,C,D,E,F,G,H,I,J,K]) end; + 12 -> fun (A,B,C,D,E,F,G,H,I,J,K,L) -> + Apply([A,B,C,D,E,F,G,H,I,J,K,L]) end; + 13 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M) -> + Apply([A,B,C,D,E,F,G,H,I,J,K,L,M]) end; + 14 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N) -> + Apply([A,B,C,D,E,F,G,H,I,J,K,L,M,N]) end; + 15 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O) -> + Apply([A,B,C,D,E,F,G,H,I,J,K,L,M,N,O]) end end. apply_lambda(Args, Body, Vals, 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) -> %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. -%% eval_match_lambda(MatchClauses, Env) -> Val. -%% Evaluate (match-lambda cls ...). - -eval_match_lambda(Cls, Env) -> - %% This is a really ugly hack! But it's the same hack as in erl_eval. - case match_lambda_arity(Cls) of - 0 -> fun () -> apply_match_lambda(Cls, [], Env) end; - 1 -> fun (A) -> apply_match_lambda(Cls, [A], Env) end; - 2 -> fun (A,B) -> apply_match_lambda(Cls, [A,B], Env) end; - 3 -> fun (A,B,C) -> apply_match_lambda(Cls, [A,B,C], Env) end; - 4 -> fun (A,B,C,D) -> apply_match_lambda(Cls, [A,B,C,D], Env) end; - 5 -> fun (A,B,C,D,E) -> apply_match_lambda(Cls, [A,B,C,D,E], Env) end; - 6 -> fun (A,B,C,D,E,F) -> - apply_match_lambda(Cls, [A,B,C,D,E,F], Env) end; - 7 -> fun (A,B,C,D,E,F,G) -> - apply_match_lambda(Cls, [A,B,C,D,E,F,G], Env) end; - 8 -> fun (A,B,C,D,E,F,G,H) -> - apply_match_lambda(Cls, [A,B,C,D,E,F,G,H], Env) end; - 9 -> fun (A,B,C,D,E,F,G,H,I) -> - apply_match_lambda(Cls, [A,B,C,D,E,F,G,H,I], Env) end; - 10 -> fun (A,B,C,D,E,F,G,H,I,J) -> - apply_match_lambda(Cls, [A,B,C,D,E,F,G,H,I,J], Env) end; - 11 -> fun (A,B,C,D,E,F,G,H,I,J,K) -> - apply_match_lambda(Cls, [A,B,C,D,E,F,G,H,I,J,K], Env) end; - 12 -> fun (A,B,C,D,E,F,G,H,I,J,K,L) -> - apply_match_lambda(Cls, [A,B,C,D,E,F,G,H,I,J,K,L], Env) end; - 13 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M) -> - apply_match_lambda(Cls, [A,B,C,D,E,F,G,H,I,J,K,L,M], Env) end; - 14 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N) -> - apply_match_lambda(Cls, [A,B,C,D,E,F,G,H,I,J,K,L,M,N], Env) end; - 15 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O) -> - apply_match_lambda(Cls, [A,B,C,D,E,F,G,H,I,J,K,L,M,N,O], Env) end - end. - match_lambda_arity([[Pats|_]|_]) -> length(Pats). apply_match_lambda([[Pats|B0]|Cls], Vals, Env) -> @@ -660,35 +637,35 @@ %% We do it all in one, not so efficient but easier. eval_try(E, Case, Catch, After, Env) -> try - eval_expr(E, Env) + eval_expr(E, Env) of - Ret -> - case Case of - {yes,Cls} -> eval_case_clauses(Ret, Cls, Env); - no -> Ret - end + Ret -> + case Case of + {yes,Cls} -> eval_case_clauses(Ret, Cls, Env); + no -> Ret + end catch - Class:Error -> - %% Try does return the stacktrace here but we can't hit it - %% so we have to explicitly get it. - Stack = erlang:get_stacktrace(), - case Catch of - {yes,Cls} -> - eval_catch_clauses({Class,Error,Stack}, Cls, Env); - no -> - erlang:raise(Class, Error, Stack) - end + Class:Error -> + %% Try does return the stacktrace here but we can't hit it + %% so we have to explicitly get it. + Stack = erlang:get_stacktrace(), + case Catch of + {yes,Cls} -> + eval_catch_clauses({Class,Error,Stack}, Cls, Env); + no -> + erlang:raise(Class, Error, Stack) + end after - case After of - {yes,B} -> eval_body(B, Env); - no -> [] - end + case After of + {yes,B} -> eval_body(B, 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)); - no -> eval_catch_clauses(V, Cls, Env) + {yes,B1,Vbs} -> eval_body(B1, add_vbindings(Vbs, Env)); + no -> eval_catch_clauses(V, Cls, Env) end; eval_catch_clauses({Class,Error,Stack}, [], _) -> erlang:raise(Class, Error, Stack). @@ -743,7 +720,7 @@ eval_gexpr([quote,E], _) -> E; eval_gexpr([cons,H,T], Env) -> [eval_gexpr(H, Env)|eval_gexpr(T, Env)]; -eval_gexpr([car,E], Env) -> hd(eval_gexpr(E, Env)); %Provide lisp names +eval_gexpr([car,E], Env) -> hd(eval_gexpr(E, Env)); %Provide lisp names eval_gexpr([cdr,E], Env) -> tl(eval_gexpr(E, Env)); eval_gexpr([list|Es], Env) -> eval_glist(Es, Env); eval_gexpr([tuple|Es], Env) -> list_to_tuple(eval_glist(Es, Env)); @@ -752,7 +729,7 @@ Pairs = gmap_pairs(As, Env), maps:from_list(Pairs); %% eval_gexpr(['mref',K,Map], Env) -> -%% Key = map_key(K), +%% Key = map_key(K, Env), %% maps:get(Key, eval_gexpr(Map, Env)); eval_gexpr(['mset',M|As], Env) -> Map = eval_gexpr(M, Env), @@ -776,21 +753,21 @@ Ar = length(As), F1 = eval_gexpr(F0, Env), case get_gbinding(F1, Ar, Env) of - {yes,M,F} -> erlang:apply(M, F, eval_glist(As, Env)); - _ -> eval_error({unbound_func,{F1,Ar}}) + {yes,M,F} -> erlang:apply(M, F, eval_glist(As, Env)); + _ -> eval_error({unbound_func,{F1,Ar}}) end; eval_gexpr([Fun|Es], Env) when is_atom(Fun) -> Ar = length(Es), case get_gbinding(Fun, Ar, Env) of - {yes,M,F} -> erlang:apply(M, F, eval_glist(Es, Env)); - _ -> eval_error({unbound_func,Fun}) + {yes,M,F} -> erlang:apply(M, F, eval_glist(Es, Env)); + _ -> eval_error({unbound_func,Fun}) end; eval_gexpr([_|_], _) -> eval_error(illegal_guard); eval_gexpr(Symb, Env) when is_atom(Symb) -> case get_vbinding(Symb, Env) of - {yes,Val} -> Val; - no -> eval_error({unbound_symb,Symb}) + {yes,Val} -> Val; + no -> eval_error({unbound_symb,Symb}) end; eval_gexpr(E, _) -> E. %Atoms evaluate to themselves. @@ -808,11 +785,28 @@ %% gmap_pairs(Args, Env) -> [{K,V}]. gmap_pairs([K,V|As], Env) -> - P = {map_key(K),eval_gexpr(V, Env)}, + P = {gmap_key(K, Env),eval_gexpr(V, Env)}, [P|gmap_pairs(As, Env)]; gmap_pairs([], _) -> []; gmap_pairs(_, _) -> eval_error(badarg). +%% gmap_key(Key, Env) -> Value. +%% A map key can only be a literal in 17 but can be anything in 18.. + +-ifdef(HAS_FULL_KEYS). +gmap_key(Key, Env) -> + eval_gexpr(Key, Env). +-else. +gmap_key([quote,E], _) -> E; +gmap_key([_|_]=L, _) -> + case is_posint_list(L) of + true -> L; %Literal strings only + false -> eval_error(illegal_mapkey) + end; +gmap_key(E, _) when not is_atom(E) -> E; %Everything else +gmap_key(_, _) -> eval_error(illegal_mapkey). +-endif. + %% eval_gif(IfBody, Env) -> Val. eval_gif([Test,True], Env) -> @@ -822,8 +816,8 @@ eval_gif(Test, True, False, Env) -> case eval_gexpr(Test, Env) of - true -> eval_gexpr(True, Env); - false -> eval_gexpr(False, Env) + true -> eval_gexpr(True, Env); + false -> eval_gexpr(False, Env) end. %% match(Pattern, Value, Env) -> {yes,PatBindings} | no. @@ -870,7 +864,7 @@ {yes,Pbs1} -> match(Ps, Vs, Pbs1, Env); no -> no end; -%% match([_|_], _, _, _) -> %No constructor +%% match([_|_], _, _, _) -> %No constructor %% eval_error(illegal_pattern); match([], [], Pbs, _) -> {yes,Pbs}; match(Symb, Val, Pbs, Env) when is_atom(Symb) -> @@ -890,7 +884,7 @@ match_symb(S, Val, Pbs, _) -> %% Check if Symb already bound. case find(S, Pbs) of - {ok,_} -> eval_error({multi_var,S}); %Already bound, multiple var + {ok,_} -> eval_error({multi_var,S}); %Already bound, multiple var error -> {yes,store(S, Val, Pbs)} %Not yet bound end. @@ -910,7 +904,7 @@ no -> no end; match_bitsegs([], <<>>, _, Pbs, _) -> {yes,Pbs}; %Reached the end of both -match_bitsegs([], _, _, _, _) -> no. %More to go +match_bitsegs([], _, _, _, _) -> no. %More to go match_bitseg(Pat, Size, Type, Bin0, Bbs0, Pbs0, Env) -> Sz = get_pat_bitsize(Size, Type, Bbs0, Pbs0, Env), @@ -935,12 +929,12 @@ get_pat_bitsize(S, _, Bbs, _, Env) when is_atom(S) -> %% Variable either in environment or bound in binary. case get_vbinding(S, Env) of - {yes,V} -> V; - no -> - case find(S, Bbs) of - {ok,V} -> V; - error -> eval_error({unbound_symb,S}) - end + {yes,V} -> V; + no -> + case find(S, Bbs) of + {ok,V} -> V; + error -> eval_error({unbound_symb,S}) + end end. match_bitexpr(N, Val, Bbs, Pbs, _) when is_number(N) -> @@ -951,9 +945,9 @@ match_bitexpr(S, Val, Bbs, Pbs, _) when is_atom(S) -> %% Don't need value, just check if symbol is set. case is_key(S, Bbs) or is_key(S, Pbs) of - true -> eval_error({multi_var,S}); - false -> - {yes,store(S, Val, Bbs),store(S, Val, Pbs)} + true -> eval_error({multi_var,S}); + false -> + {yes,store(S, Val, Bbs),store(S, Val, Pbs)} end; match_bitexpr(_, _, _, _, _) -> eval_error(illegal_bitseg). @@ -963,25 +957,25 @@ get_pat_bitseg(Bin, Size, Type) -> case Type of - %% Integer types. - {integer,Un,Si,En} -> - get_int_bitseg(Bin, Size*Un, Si, En); - %% Unicode types, ignore unused bitsegs. - {utf8,_,_,_} -> get_utf8_bitseg(Bin); - {utf16,_,_,En} -> get_utf16_bitseg(Bin, En); - {utf32,_,_,En} -> get_utf32_bitseg(Bin, En); - %% Float types. - {float,Un,_,En} -> get_float_bitseg(Bin, Size*Un, En); - %% Binary types. - {binary,Un,_,_} -> - if Size == all -> - 0 = (bit_size(Bin) rem Un), - {Bin,<<>>}; - true -> - TotSize = Size * Un, - <<Val:TotSize/bitstring,Rest/bitstring>> = Bin, - {Val,Rest} - end + %% Integer types. + {integer,Un,Si,En} -> + get_int_bitseg(Bin, Size*Un, Si, En); + %% Unicode types, ignore unused bitsegs. + {utf8,_,_,_} -> get_utf8_bitseg(Bin); + {utf16,_,_,En} -> get_utf16_bitseg(Bin, En); + {utf32,_,_,En} -> get_utf32_bitseg(Bin, En); + %% Float types. + {float,Un,_,En} -> get_float_bitseg(Bin, Size*Un, En); + %% Binary types. + {binary,Un,_,_} -> + if Size == all -> + 0 = (bit_size(Bin) rem Un), + {Bin,<<>>}; + true -> + TotSize = Size * Un, + <<Val:TotSize/bitstring,Rest/bitstring>> = Bin, + {Val,Rest} + end end. get_int_bitseg(Bin, Sz, signed, big) -> @@ -1037,10 +1031,10 @@ <<Val:Sz/float-native,Rest/bitstring>> = Bin, {Val,Rest}. -%% match_map(Ps, Map, PatBindings, Env) -> {yes,PatBindings} | no. +%% match_map(Pairs, Map, PatBindings, Env) -> {yes,PatBindings} | no. match_map([K,V|Ps], Map, Pbs0, Env) -> - Pat = map_key(K), %Evaluate the key + Pat = pat_map_key(K), %Evaluate the key case maps:is_key(Pat, Map) of true -> case match(V, maps:get(Pat, Map), Pbs0, Env) of @@ -1052,6 +1046,15 @@ match_map([], _, Pbs, _) -> {yes,Pbs}; match_map(_, _, _, _) -> eval_error(illegal_pattern). +pat_map_key([quote,E]) -> E; +pat_map_key([_|_]=L) -> + case is_posint_list(L) of + true -> L; %Literal strings only + false -> eval_error(illegal_mapkey) + end; +pat_map_key(E) when not is_atom(E) -> E; %Everything else +pat_map_key(_) -> eval_error(illegal_mapkey). + %% eval_lit(Literal, Env) -> Value. %% Evaluate a literal expression. Error if invalid.
View file
lfe-0.9.2.tar.gz/src/lfe_gen.erl -> lfe-1.0.tar.gz/src/lfe_gen.erl
Changed
@@ -20,7 +20,7 @@ -export([compile_forms/1]). -export([new_module/1,add_exports/2,add_imports/2,add_form/2, - print_mod/1,compile_mod/1]). + print_mod/1,compile_mod/1]). -import(lists, [map/2,foldl/3,mapfoldl/3]). -import(ordsets, [add_element/2]). @@ -33,8 +33,8 @@ compile_forms(Fs) -> case lfe_comp:forms(Fs, [return]) of - {ok,Mod,Bin,Ws} -> {ok,Mod,Bin,Ws}; - {error,Es,Ws} -> {error,Es,Ws} + {ok,Mod,Bin,Ws} -> {ok,Mod,Bin,Ws}; + {error,Es,Ws} -> {error,Es,Ws} end. %% new_module(Name) -> Module. @@ -51,19 +51,19 @@ add_exports(Exps, Mod) -> Es0 = Mod#gen.exps, Es1 = foldl(fun ({N,Ar}, Es) when is_atom(N), is_integer(Ar) -> - add_element({N,Ar}, Es) - end, Es0, Exps), + add_element({N,Ar}, Es) + end, Es0, Exps), Mod#gen{exps=Es1}. add_imports({from,M,Is}, Mod) -> Imps0 = Mod#gen.imps, Imps1 = collect_imp(fun ({F,A}, Imps) -> store({F,A}, F, Imps) end, - M, Imps0, Is), + M, Imps0, Is), Mod#gen{imps=Imps1}; add_imports({rename,M,Is}, Mod) -> Imps0 = Mod#gen.imps, Imps1 = collect_imp(fun ({{F,A},R}, Imps) -> store({F,A}, R, Imps) end, - M, Imps0, Is), + M, Imps0, Is), Mod#gen{imps=Imps1}. add_form(Form, Mod) -> @@ -87,9 +87,9 @@ build_def(Mod) -> Exps = map(fun ({N,I}) -> [N,I] end, Mod#gen.exps), Imps = map(fun ({M,Is}) -> - [rename,M|map(fun ({{L,Ar},R}) -> [[L,Ar],R] end, - Is)] - end, Mod#gen.imps), + [rename,M|map(fun ({{L,Ar},R}) -> [[L,Ar],R] end, + Is)] + end, Mod#gen.imps), [defmodule,Mod#gen.name, [export|Exps], [import|Imps]]. @@ -98,6 +98,6 @@ safe_fetch(Key, D, Def) -> case find(Key, D) of - {ok,Val} -> Val; - error -> Def + {ok,Val} -> Val; + error -> Def end.
View file
lfe-0.9.2.tar.gz/src/lfe_init.erl -> lfe-1.0.tar.gz/src/lfe_init.erl
Changed
@@ -41,7 +41,7 @@ run_string(As); [S|As] -> %Run a script user:start(), %Start user for io - run_file([S|As]); + run_file([S|As]); [] -> %Run a shell user_drv:start(['tty_sl -c -e',{lfe_shell,start,[]}]) end. @@ -64,14 +64,14 @@ run_script(Script) -> try - Script(), - init:stop(?OK_STATUS) + Script(), + init:stop(?OK_STATUS) catch - Class:Error -> - St = erlang:get_stacktrace(), %Need to get this first - Sf = fun (_) -> false end, - Ff = fun (T, I) -> lfe_io:prettyprint1(T, 15, I, 80) end, - Cs = lfe_lib:format_exception(Class, Error, St, Sf, Ff, 1), - io:put_chars(Cs), - halt(?ERROR_STATUS) + Class:Error -> + St = erlang:get_stacktrace(), %Need to get this first + Sf = fun (_) -> false end, + Ff = fun (T, I) -> lfe_io:prettyprint1(T, 15, I, 80) end, + Cs = lfe_lib:format_exception(Class, Error, St, Sf, Ff, 1), + io:put_chars(Cs), + halt(?ERROR_STATUS) end.
View file
lfe-0.9.2.tar.gz/src/lfe_io.erl -> lfe-1.0.tar.gz/src/lfe_io.erl
Changed
@@ -18,19 +18,18 @@ %% %% The io functions have been split into the following modules: %% lfe_io - basic read and write functions -%% lfe_io_pretty - sexpr prettyprinter +%% lfe_io_write - basic write functions +%% lfe_io_pretty - basic print functions %% lfe_io_format - formatted output -module(lfe_io). --export([parse_file/1,read_file/1,read/0,read/1,read_string/1, - print/1,print/2,print1/1,print1/2]). +-export([parse_file/1,read_file/1,read/0,read/1,read_string/1]). +-export([print/1,print/2,print1/1,print1/2]). -export([prettyprint/1,prettyprint/2, - prettyprint1/1,prettyprint1/2,prettyprint1/3,prettyprint1/4]). + prettyprint1/1,prettyprint1/2,prettyprint1/3,prettyprint1/4]). -export([format/2,format/3,fwrite/2,fwrite/3, - format1/2,fwrite1/2]). - --export([print1_symb/1,print1_string/2,print1_bits/2]). + format1/2,fwrite1/2]). %% -compile(export_all). @@ -44,39 +43,39 @@ -endif. %% parse_file(FileName) -> {ok,[{Sexpr,Line}]} | {error,Error}. -%% Parse a file returning the raw sexprs (as it should be) and line -%% numbers of start of each sexpr. Handle errors consistently. +%% Parse a file returning the raw sexprs (as it should be) and line +%% numbers of start of each sexpr. Handle errors consistently. parse_file(Name) -> with_token_file(Name, fun (Ts) -> parse_file1(Ts, [], []) end). parse_file1([_|_]=Ts0, Pc0, Ss) -> case lfe_parse:sexpr(Pc0, Ts0) of - {ok,L,S,Ts1} -> parse_file1(Ts1, [], [{S,L}|Ss]); - {more,Pc1} -> - %% Need more tokens but there are none, so call again to - %% generate an error message. - {error,E,_} = lfe_parse:sexpr(Pc1, {eof,99999}), - {error,E}; - {error,E,_} -> {error,E} + {ok,L,S,Ts1} -> parse_file1(Ts1, [], [{S,L}|Ss]); + {more,Pc1} -> + %% Need more tokens but there are none, so call again to + %% generate an error message. + {error,E,_} = lfe_parse:sexpr(Pc1, {eof,99999}), + {error,E}; + {error,E,_} -> {error,E} end; parse_file1([], _, Ss) -> {ok,reverse(Ss)}. %% read_file(FileName) -> {ok,[Sexpr]} | {error,Error}. -%% Read a file returning the raw sexprs (as it should be). +%% Read a file returning the raw sexprs (as it should be). read_file(Name) -> with_token_file(Name, fun (Ts) -> read_file1(Ts, []) end). read_file1([_|_]=Ts0, Ss) -> case lfe_parse:sexpr(Ts0) of - {ok,_,S,Ts1} -> read_file1(Ts1, [S|Ss]); - {more,Pc1} -> - %% Need more tokens but there are none, so call again to - %% generate an error message. - {error,E,_} = lfe_parse:sexpr(Pc1, {eof,99999}), - {error,E}; - {error,E,_} -> {error,E} + {ok,_,S,Ts1} -> read_file1(Ts1, [S|Ss]); + {more,Pc1} -> + %% Need more tokens but there are none, so call again to + %% generate an error message. + {error,E,_} = lfe_parse:sexpr(Pc1, {eof,99999}), + {error,E}; + {error,E,_} -> {error,E} end; read_file1([], Ss) -> {ok,reverse(Ss)}. @@ -95,17 +94,24 @@ {error,Error} -> {error,{none,file,Error}} end. -%% read([IoDevice]) -> {ok,Sexpr} | {error,Error}. +%% read() -> {ok,Sexpr} | {error,Error}. +%% read(Prompt) -> {ok,Sexpr} | {error,Error}. +%% read(IoDevice, Prompt) -> {ok,Sexpr} | {error,Error}. %% A very simple read function. Line oriented and cannot handle %% tokens over line-breaks but can handle multiple lines. Anything %% remaining on last line after a sexpr is lost. Signal errors. +%% read() -> read(standard_io, ''). +%% read(Prompt) -> read(standard_io, Prompt). +%% read(Io, Prompt) -> +%% scan_and_parse(Io, Prompt, [], 1). read() -> read(standard_io). read(Io) -> - scan_and_parse(Io, [], 1). + scan_and_parse(Io, '', [], 1). -scan_and_parse(Io, Pc0, L) -> - case io:get_line(Io, '') of +scan_and_parse(Io, Prompt, Pc0, L) -> + case io:get_line(Io, Prompt) of + {error,E} -> {error,{L,lfe_parse,E}}; eof -> %% No more so must take what we have. case lfe_parse:sexpr(Pc0, {eof,L}) of @@ -116,11 +122,11 @@ case lfe_scan:string(Cs, L) of {ok,[],_} -> %% Empty line (token free) just go on. - scan_and_parse(Io, Pc0, L+1); + scan_and_parse(Io, Prompt, Pc0, L+1); {ok,Ts,_} -> case lfe_parse:sexpr(Pc0, Ts) of {ok,_,S,_} -> {ok,S}; - {more,Pc1} -> scan_and_parse(Io, Pc1, L+1); + {more,Pc1} -> scan_and_parse(Io, Prompt, Pc1, L+1); {error,E,_} -> {error,E} end; {error,E,_} -> {error,E} @@ -149,143 +155,7 @@ print(Io, S) -> io:put_chars(Io, print1(S)). print1(S) -> print1(S, -1). %All the way - -print1(_, 0) -> "..."; -print1(Symb, _) when is_atom(Symb) -> print1_symb(Symb); -print1(Numb,_ ) when is_integer(Numb) -> integer_to_list(Numb); -print1(Numb, _) when is_float(Numb) -> io_lib_format:fwrite_g(Numb); -print1(List, D) when is_list(List) -> - [$(,print1_list(List, D-1),$)]; -print1({}, _) -> "#()"; -print1(Vec, D) when is_tuple(Vec) -> - Es = tuple_to_list(Vec), - ["#(",print1_list(Es, D-1),")"]; -print1(Bit, _) when is_bitstring(Bit) -> - ["#B(",print1_bits(Bit),$)]; -print1(Map, D) when ?IS_MAP(Map) -> print1_map(Map, D); -print1(Other, D) -> %Use standard Erlang for rest - io_lib:write(Other, D). - -%% print1_symb(Symbol) -> [char()]. - -print1_symb(Symb) -> - Cs = atom_to_list(Symb), - case quote_symbol(Symb, Cs) of - true -> print1_string(Cs , $|); - false -> Cs - end. - -%% print1_bits(Bitstring) -> [char()] -%% print1_bits(Bitstring, Depth) -> [char()] -%% Print the bytes in a bitstring. Print bytes except for last which -%% we add size field if not 8 bits big. - -print1_bits(Bits) -> print1_bits(Bits, -1). %Print them all - -print1_bits(_, 0) -> "..."; -print1_bits(<<B:8>>, _) -> integer_to_list(B); %Catch last binary byte -print1_bits(<<B:8,Bits/bitstring>>, N) -> - [integer_to_list(B),$\s|print1_bits(Bits, N-1)]; -print1_bits(<<>>, _) -> []; -print1_bits(Bits, _) -> %0 < Size < 8 - N = bit_size(Bits), - <<B:N>> = Bits, - io_lib:format("(~w (size ~w))", [B,N]). - -%% print1_list(List, Depth) -> Chars. -%% Print the elements in a list. We handle the empty list and depth=0. - -print1_list([], _) -> []; -print1_list(_, 0) -> "..."; -print1_list([Car|Cdr], D) -> - [print1(Car, D)|print1_tail(Cdr, D-1)]. - -%% print1_tail(Tail, Depth) -%% Print the tail of a list decrasing the depth for each element. We -%% know about dotted pairs. - -print1_tail([], _) -> ""; -print1_tail(_, 0) -> [$\s|"..."]; -print1_tail([S|Ss], D) -> - [$\s,print1(S, D)|print1_tail(Ss, D-1)]; -print1_tail(S, D) -> [" . "|print1(S, D)]. - -%% print1_map(Map, Depth) - -print1_map(Map, D) -> - [$#,$M,$(,print1_map_body(maps:to_list(Map), D), $)]. - -print1_map_body([], _) -> []; -print1_map_body(_, D) when D =:= 0; D =:= 1 -> "..."; -print1_map_body([KV], D) -> print1_map_assoc(KV, D); -print1_map_body([KV|KVs], D) -> - Massoc = print1_map_assoc(KV, D), - [Massoc,$\s|print1_map_body(KVs, D-1)]. - -print1_map_assoc({K,V}, D) -> - [print1(K, D-1),$\s,print1(V, D-1)]. - -%% quote_symbol(Symbol, SymbChars) -> bool(). -%% Check if symbol needs to be quoted when printed. If it can read as -%% a number then it must be quoted. - -quote_symbol('.', _) -> true; %Needs quoting -quote_symbol(_, [C|Cs]=Cs0) -> - case catch {ok,list_to_float(Cs0)} of - {ok,_} -> true; - _ -> case catch {ok,list_to_integer(Cs0)} of - {ok,_} -> true; - _ -> not (start_symb_char(C) andalso symb_chars(Cs)) - end - end; -quote_symbol(_, []) -> true. - -symb_chars(Cs) -> all(fun symb_char/1, Cs). - -start_symb_char($#) -> false; -start_symb_char($`) -> false; -start_symb_char($') -> false; %' -start_symb_char($,) -> false; -start_symb_char($|) -> false; %Symbol quote character -start_symb_char(C) -> symb_char(C). - -symb_char($() -> false; -symb_char($)) -> false; -symb_char($[) -> false; -symb_char($]) -> false; -symb_char(${) -> false; -symb_char($}) -> false; -symb_char($") -> false; -symb_char($;) -> false; -symb_char(C) -> ((C > $\s) and (C =< $~)) orelse (C > $\240). - -%% print1_string([Char], QuoteChar) -> [Char] -%% Generate the list of characters needed to print a string. - -print1_string(S, Q) -> - [Q|print1_string1(S, Q)]. - -print1_string1([], Q) -> [Q]; -print1_string1([C|Cs], Q) -> - string_char(C, Q, print1_string1(Cs, Q)). - -string_char(Q, Q, Tail) -> [$\\,Q|Tail]; %Must check these first! -string_char($\\, _, Tail) -> [$\\,$\\|Tail]; -string_char(C, _, Tail) when C >= $\s, C =< $~ -> - [C|Tail]; -string_char(C, _, Tail) when C >= $\240, C =< $\377 -> - [C|Tail]; -string_char($\n, _, Tail) -> [$\\,$n|Tail]; %\n = LF -string_char($\r, _, Tail) -> [$\\,$r|Tail]; %\r = CR -string_char($\t, _, Tail) -> [$\\,$t|Tail]; %\t = TAB -string_char($\v, _, Tail) -> [$\\,$v|Tail]; %\v = VT -string_char($\b, _, Tail) -> [$\\,$b|Tail]; %\b = BS -string_char($\f, _, Tail) -> [$\\,$f|Tail]; %\f = FF -string_char($\e, _, Tail) -> [$\\,$e|Tail]; %\e = ESC -string_char($\d, _, Tail) -> [$\\,$d|Tail]; %\d = DEL -string_char(C, _, Tail) -> - %%Unicode and other control characters. - "\\x" ++ erlang:integer_to_list(C, 16) ++ ";" ++ Tail. +print1(S, D) -> lfe_io_write:term(S, D). %% prettyprint([IoDevice], Sexpr) -> ok. %% prettyprint1(Sexpr, Depth, Indentation, LineLength) -> [char()]. @@ -294,10 +164,10 @@ prettyprint(S) -> prettyprint(standard_io, S). prettyprint(Io, S) -> io:put_chars(Io, prettyprint1(S, -1)). -prettyprint1(S) -> lfe_io_pretty:print1(S). -prettyprint1(S, D) -> lfe_io_pretty:print1(S, D, 0, 80). -prettyprint1(S, D, I) -> lfe_io_pretty:print1(S, D, I, 80). -prettyprint1(S, D, I, L) -> lfe_io_pretty:print1(S, D, I, L). +prettyprint1(S) -> lfe_io_pretty:term(S). +prettyprint1(S, D) -> lfe_io_pretty:term(S, D, 0, 80). +prettyprint1(S, D, I) -> lfe_io_pretty:term(S, D, I, 80). +prettyprint1(S, D, I, L) -> lfe_io_pretty:term(S, D, I, L). %% format([IoDevice,] Format, Args) -> ok. %% fwrite([IoDevice,] Format, Args) -> ok.
View file
lfe-0.9.2.tar.gz/src/lfe_io_format.erl -> lfe-1.0.tar.gz/src/lfe_io_format.erl
Changed
@@ -81,7 +81,7 @@ field_value([C|Fmt], Args, F) when is_integer(C), C >= $0, C =< $9 -> field_value(Fmt, Args, 10*F + (C - $0)); -field_value(Fmt, Args, F) -> %Default case +field_value(Fmt, Args, F) -> %Default case {F,Fmt,Args}. pad_char([$.,$*|Fmt], [Pad|Args]) -> {Pad,Fmt,Args}; @@ -93,9 +93,9 @@ pcount(Cs) -> foldl(fun ({$p,_,_,_,_,_}, Acc) -> Acc+1; - ({$P,_,_,_,_,_}, Acc) -> Acc+1; - (_, Acc) -> Acc - end, 0, Cs). + ({$P,_,_,_,_,_}, Acc) -> Acc+1; + (_, Acc) -> Acc + end, 0, Cs). %% build([Control], Pc, Indentation) -> [Char]. %% Interpret the control structures. Count the number of print @@ -106,8 +106,8 @@ S = control(C, As, F, Ad, P, Pad, I), Pc1 = decr_pc(C, Pc0), if - Pc1 > 0 -> [S|build(Cs, Pc1, indentation(S, I))]; - true -> [S|build(Cs, Pc1, I)] + Pc1 > 0 -> [S|build(Cs, Pc1, indentation(S, I))]; + true -> [S|build(Cs, Pc1, I)] end; build([$\n|Cs], Pc, _I) -> [$\n|build(Cs, Pc, 0)]; build([$\t|Cs], Pc, I) -> [$\t|build(Cs, Pc, ((I + 8) div 8) * 8)]; @@ -161,9 +161,9 @@ %% Field widths and precisions have already been calculated. control($w, [A], F, Adj, P, Pad, _) -> - term(lfe_io:print1(A, -1), F, Adj, P, Pad); + write(lfe_io:print1(A, -1), F, Adj, P, Pad); control($W, [A,Depth], F, Adj, P, Pad, _I) when is_integer(Depth) -> - term(lfe_io:print1(A, Depth), F, Adj, P, Pad); + write(lfe_io:print1(A, Depth), F, Adj, P, Pad); control($p, [A], F, Adj, P, Pad, I) -> print(A, -1, F, Adj, P, Pad, I); control($P, [A,Depth], F, Adj, P, Pad, I) when is_integer(Depth) -> @@ -187,13 +187,13 @@ control($B, [A], F, Adj, P, Pad, _) when is_integer(A) -> unprefixed_integer(A, F, Adj, base(P), Pad, false); control($x, [A,Prefix], F, Adj, P, Pad, _) when is_integer(A), - is_atom(Prefix) -> + is_atom(Prefix) -> prefixed_integer(A, F, Adj, base(P), Pad, atom_to_list(Prefix), true); control($x, [A,Prefix], F, Adj, P, Pad, _) when is_integer(A) -> true = io_lib:deep_char_list(Prefix), %Check if Prefix a character list prefixed_integer(A, F, Adj, base(P), Pad, Prefix, true); control($X, [A,Prefix], F, Adj, P, Pad, _) when is_integer(A), - is_atom(Prefix) -> + is_atom(Prefix) -> prefixed_integer(A, F, Adj, base(P), Pad, atom_to_list(Prefix), false); control($X, [A,Prefix], F, Adj, P, Pad, _) when is_integer(A) -> true = io_lib:deep_char_list(Prefix), %Check if Prefix a character list @@ -218,52 +218,52 @@ base(none) -> 10; base(B) when is_integer(B) -> B. -%% term(TermList, Field, Adjust, Precision, PadChar) -%% Output the characters in a term. Use Precision to trim length of +%% write(CharList, Field, Adjust, Precision, PadChar) +%% Write the characters of a term. Use Precision to trim length of %% output. Adjust the characters within the field if length less %% than Max padding with PadChar. -term(T, none, _, none, _) -> T; -term(T, F, Adj, P, Pad) -> +write(T, none, _, none, _) -> T; +write(T, F, Adj, P, Pad) -> N = lists:flatlength(T), - if P =:= none -> term1(T, F, Adj, N, Pad); - P >= N -> term1(T, F, Adj, N, Pad); - true -> term1(flat_trunc(T, P), F, Adj, P, Pad) + if P =:= none -> write1(T, F, Adj, N, Pad); + P >= N -> write1(T, F, Adj, N, Pad); + true -> write1(flat_trunc(T, P), F, Adj, P, Pad) end. -term1(T, none, _, _, _) -> T; -term1(T, F, Adj, N, Pad) -> +write1(T, none, _, _, _) -> T; +write1(T, F, Adj, N, Pad) -> if F < N -> chars($*, F); F == N -> T; true -> adjust(T, chars(Pad, F-N), Adj) end. -%% print(Term, Depth, Field, Adjust, Precision, PadChar, Indentation) -%% Pretty print a term, field width is maximum line length and -%% precision is initial indentation. +%% print(CharList, Depth, Field, Adjust, Precision, PadChar, Indentation) +%% Pretty print the characters of a term, field width is maximum line +%% length and precision is initial indentation. print(T, D, none, Adj, P, Pad, I) -> print(T, D, 80, Adj, P, Pad, I); print(T, D, F, Adj, none, Pad, I) -> print(T, D, F, Adj, I, Pad, I); print(T, D, F, right, P, _, _) -> - lfe_io_pretty:print1(T, D, P, F). + lfe_io_pretty:term(T, D, P, F). %% fwrite_e(Float, Field, Adjust, Precision, PadChar) -fwrite_e(Fl, none, Adj, none, Pad) -> %Default values +fwrite_e(Fl, none, Adj, none, Pad) -> %Default values fwrite_e(Fl, none, Adj, 6, Pad); fwrite_e(Fl, none, _Adj, P, _Pad) when P >= 2 -> float_e(Fl, float_data(Fl), P); fwrite_e(Fl, F, Adj, none, Pad) -> fwrite_e(Fl, F, Adj, 6, Pad); fwrite_e(Fl, F, Adj, P, Pad) when P >= 2 -> - term(float_e(Fl, float_data(Fl), P), F, Adj, F, Pad). + write(float_e(Fl, float_data(Fl), P), F, Adj, F, Pad). -float_e(Fl, Fd, P) when Fl < 0.0 -> %Negative numbers +float_e(Fl, Fd, P) when Fl < 0.0 -> %Negative numbers [$-|float_e(-Fl, Fd, P)]; float_e(_Fl, {Ds,E}, P) -> case float_man(Ds, 1, P-1) of - {[$0|Fs],true} -> [[$1|Fs]|float_exp(E)]; - {Fs,false} -> [Fs|float_exp(E-1)] + {[$0|Fs],true} -> [[$1|Fs]|float_exp(E)]; + {Fs,false} -> [Fs|float_exp(E-1)] end. %% float_man([Digit], Icount, Dcount) -> {[Chars],CarryFlag}. @@ -276,22 +276,22 @@ {[$.|Cs],C}; float_man([D|Ds], I, Dc) -> case float_man(Ds, I-1, Dc) of - {Cs,true} when D =:= $9 -> {[$0|Cs],true}; - {Cs,true} -> {[D+1|Cs],false}; - {Cs,false} -> {[D|Cs],false} + {Cs,true} when D =:= $9 -> {[$0|Cs],true}; + {Cs,true} -> {[D+1|Cs],false}; + {Cs,false} -> {[D|Cs],false} end; -float_man([], I, Dc) -> %Pad with 0's +float_man([], I, Dc) -> %Pad with 0's {string:chars($0, I, [$.|string:chars($0, Dc)]),false}. float_man([D|_], 0) when D >= $5 -> {[],true}; float_man([_|_], 0) -> {[],false}; float_man([D|Ds], Dc) -> case float_man(Ds, Dc-1) of - {Cs,true} when D =:= $9 -> {[$0|Cs],true}; - {Cs,true} -> {[D+1|Cs],false}; - {Cs,false} -> {[D|Cs],false} + {Cs,true} when D =:= $9 -> {[$0|Cs],true}; + {Cs,true} -> {[D+1|Cs],false}; + {Cs,false} -> {[D|Cs],false} end; -float_man([], Dc) -> {string:chars($0, Dc),false}. %Pad with 0's +float_man([], Dc) -> {string:chars($0, Dc),false}. %Pad with 0's %% float_exp(Exponent) -> [Char]. %% Generate the exponent of a floating point number. Always include sign. @@ -303,14 +303,14 @@ %% fwrite_f(FloatData, Field, Adjust, Precision, PadChar) -fwrite_f(Fl, none, Adj, none, Pad) -> %Default values +fwrite_f(Fl, none, Adj, none, Pad) -> %Default values fwrite_f(Fl, none, Adj, 6, Pad); fwrite_f(Fl, none, _Adj, P, _Pad) when P >= 1 -> float_f(Fl, float_data(Fl), P); fwrite_f(Fl, F, Adj, none, Pad) -> fwrite_f(Fl, F, Adj, 6, Pad); fwrite_f(Fl, F, Adj, P, Pad) when P >= 1 -> - term(float_f(Fl, float_data(Fl), P), F, Adj, F, Pad). + write(float_f(Fl, float_data(Fl), P), F, Adj, F, Pad). float_f(Fl, Fd, P) when Fl < 0.0 -> [$-|float_f(-Fl, Fd, P)]; @@ -318,8 +318,8 @@ float_f(Fl, {string:chars($0, -E+1, Ds),1}, P); %Prepend enough 0's float_f(_Fl, {Ds,E}, P) -> case float_man(Ds, E, P) of - {Fs,true} -> "1" ++ Fs; %Handle carry - {Fs,false} -> Fs + {Fs,true} -> "1" ++ Fs; %Handle carry + {Fs,false} -> Fs end. %% float_data([FloatChar]) -> {[Digit],Exponent} @@ -343,20 +343,20 @@ fwrite_g(Fl, F, Adj, P, Pad) when P >= 1 -> A = abs(Fl), E = if A < 1.0e-1 -> -2; - A < 1.0e0 -> -1; - A < 1.0e1 -> 0; - A < 1.0e2 -> 1; - A < 1.0e3 -> 2; - A < 1.0e4 -> 3; - true -> fwrite_f - end, + A < 1.0e0 -> -1; + A < 1.0e1 -> 0; + A < 1.0e2 -> 1; + A < 1.0e3 -> 2; + A < 1.0e4 -> 3; + true -> fwrite_f + end, if P =< 1, E =:= -1; - P-1 > E, E >= -1 -> - fwrite_f(Fl, F, Adj, P-1-E, Pad); - P =< 1 -> - fwrite_e(Fl, F, Adj, 2, Pad); - true -> - fwrite_e(Fl, F, Adj, P, Pad) + P-1 > E, E >= -1 -> + fwrite_f(Fl, F, Adj, P-1-E, Pad); + P =< 1 -> + fwrite_e(Fl, F, Adj, 2, Pad); + true -> + fwrite_e(Fl, F, Adj, P, Pad) end. %% string(StringList, Field, Adjust, Precision, PadChar) @@ -383,11 +383,11 @@ unprefixed_integer(Int, F, Adj, Base, Pad, Lowercase) when Base >= 2, Base =< 1+$Z-$A+10 -> if Int < 0 -> - S = cond_lowercase(erlang:integer_to_list(-Int, Base), Lowercase), - term([$-|S], F, Adj, none, Pad); + S = cond_lowercase(erlang:integer_to_list(-Int, Base), Lowercase), + write([$-|S], F, Adj, none, Pad); true -> - S = cond_lowercase(erlang:integer_to_list(Int, Base), Lowercase), - term(S, F, Adj, none, Pad) + S = cond_lowercase(erlang:integer_to_list(Int, Base), Lowercase), + write(S, F, Adj, none, Pad) end. %% prefixed_integer(Int, Field, Adjust, Base, PadChar, Prefix, Lowercase) -> @@ -396,11 +396,11 @@ prefixed_integer(Int, F, Adj, Base, Pad, Prefix, Lowercase) when Base >= 2, Base =< 1+$Z-$A+10 -> if Int < 0 -> - S = cond_lowercase(erlang:integer_to_list(-Int, Base), Lowercase), - term([$-,Prefix|S], F, Adj, none, Pad); + S = cond_lowercase(erlang:integer_to_list(-Int, Base), Lowercase), + write([$-,Prefix|S], F, Adj, none, Pad); true -> - S = cond_lowercase(erlang:integer_to_list(Int, Base), Lowercase), - term([Prefix|S], F, Adj, none, Pad) + S = cond_lowercase(erlang:integer_to_list(Int, Base), Lowercase), + write([Prefix|S], F, Adj, none, Pad) end. %% base_prefix(Base, Lowercase) -> [Char].
View file
lfe-0.9.2.tar.gz/src/lfe_io_pretty.erl -> lfe-1.0.tar.gz/src/lfe_io_pretty.erl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2008-2014 Robert Virding +%% Copyright (c) 2008-2015 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -18,7 +18,7 @@ -module(lfe_io_pretty). --export([print1/1,print1/2,print1/3,print1/4]). +-export([term/1,term/2,term/3,term/4]). -compile(export_all). @@ -31,99 +31,115 @@ -define(IS_MAP(T), false). -endif. -%% print1(Sexpr) -> [char()]. -%% print1(Sexpr, Depth) -> [char()]. -%% print1(Sexpr, Depth, Indentation, LineLength) -> [char()]. +%% term(Sexpr [, Depth [, Indentation [, LineLength]]]) -> [char()]. %% A relatively simple pretty print function, but with some %% customisation. N.B. We know about the standard character macros %% and use them instead of their expanded forms. -print1(S) -> print1(S, -1, 0, 80). +term(S) -> term(S, -1, 0, 80). -print1(S, D) -> print1(S, D, 0, 80). +term(S, D) -> term(S, D, 0, 80). -print1(S, D, I) -> print1(S, D, I, 80). +term(S, D, I) -> term(S, D, I, 80). -print1(_, 0, _, _) -> "..."; -print1(Symb, _, _, _) when is_atom(Symb) -> lfe_io:print1_symb(Symb); -print1(Numb, _, _, _) when is_integer(Numb) -> integer_to_list(Numb); -print1(Numb, _, _, _) when is_float(Numb) -> io_lib_format:fwrite_g(Numb); +term(_, 0, _, _) -> "..."; +term(Symb, _, _, _) when is_atom(Symb) -> lfe_io_write:symbol(Symb); +term(Numb, _, _, _) when is_integer(Numb) -> integer_to_list(Numb); +term(Numb, _, _, _) when is_float(Numb) -> io_lib_format:fwrite_g(Numb); %% Handle some default special cases, standard character macros. These %% don't increase depth as they really should. -print1([quote,E], D, I, L) -> ["'",print1(E, D, I+1, L)]; -print1([backquote,E], D, I, L) -> ["`",print1(E, D, I+1, L)]; -print1([unquote,E], D, I, L) -> [",",print1(E, D, I+1, L)]; -print1(['unquote-splicing',E], D, I, L) -> [",@",print1(E, D, I+2, L)]; -print1([Car|_]=List, D, I, L) -> +term([quote,E], D, I, L) -> ["'",term(E, D, I+1, L)]; +term([backquote,E], D, I, L) -> ["`",term(E, D, I+1, L)]; +term([comma,E], D, I, L) -> [",",term(E, D, I+1, L)]; +term(['comma-at',E], D, I, L) -> [",@",term(E, D, I+2, L)]; +term([map|MapBody], D, I, L) -> + Mcs = map_body(MapBody, D, I+5, L), + ["(map ",Mcs,$)]; +term([Car|_]=List, D, I, L) -> %% Handle printable lists specially. - case io_lib:printable_list(List) of - true -> lfe_io:print1_string(List, $"); %" + case io_lib:printable_unicode_list(List) of + true -> lfe_io_write:string(List, $"); %" false -> - case print1_list_max(List, D-1, I+1, L-1) of + case list_max(List, D-1, I+1, L-1) of {yes,Print} -> ["(",Print,")"]; no -> %% Customise printing of lists. case indent_type(Car) of none -> %Normal lists. - ["(",print1_list(List, D-1, I+1, L-1),")"]; + ["(",list(List, D-1, I+1, L-1),")"]; defun -> %Special case for defuns - print1_defun(List, D, I, L); + defun(List, D, I, L); N when is_integer(N) -> %Special N first elements - print1_type(List, D, I, L, N) + type(List, D, I, L, N) end end end; -print1([], _, _, _) -> "()"; -print1({}, _, _, _) -> "#()"; -print1(Tup, D, I, L) when is_tuple(Tup) -> +term([], _, _, _) -> "()"; +term({}, _, _, _) -> "#()"; +term(Tup, D, I, L) when is_tuple(Tup) -> Es = tuple_to_list(Tup), - case print1_list_max(Es, D-1, I+2, L-1) of + case list_max(Es, D-1, I+2, L-1) of {yes,Print} -> ["#(",Print,")"]; - no -> ["#(",print1_list(Es, D-1, I+2, L),")"] + no -> ["#(",list(Es, D-1, I+2, L),")"] end; -print1(Bit, D, _, _) when is_bitstring(Bit) -> - ["#B(",lfe_io:print1_bits(Bit, D),$)]; %First D bytes -print1(Map, D, I, L) when ?IS_MAP(Map) -> - print1_map(Map, D, I, L); -print1(Other, _, _, _) -> - lfe_io:print1(Other). %Use standard LFE for rest - -%% print1_defun(List, Depth, Indentation, LineLength) -> [char()]. -%% Print a defun depending on whether it is traditional or matching. - -print1_defun([Def,Name,Args|Rest], D, I, L) when - is_atom(Name), (D > 3) or (D < 0) -> +term(Bit, D, _, _) when is_bitstring(Bit) -> + bitstring(Bit, D); %First D bytes +term(Map, D, I, L) when ?IS_MAP(Map) -> + Fun = fun (K, V, Acc) -> [K,V|Acc] end, + Mcs = map_body(maps:fold(Fun, [], Map), D, I+3, L), + ["#M(",Mcs,$)]; +term(Other, _, _, _) -> + lfe_io_write:term(Other). %Use standard LFE for rest + +%% bitstring(Bitstring, Depth) -> [char()] +%% Print the bytes in a bitstring. Print bytes except for last which +%% we add size field if not 8 bits big. + +bitstring(Bit, D) -> + try + Chars = unicode:characters_to_list(Bit, utf8), + true = io_lib:printable_unicode_list(Chars), + [$#|lfe_io_write:string(Chars, $")] + catch + _:_ -> + lfe_io_write:bitstring(Bit, D) + end. + +%% defun(List, Depth, Indentation, LineLength) -> [char()]. +%% Print a defun depending on whether it is traditional or matching. + +defun([Def,Name,Args|Rest], D, I, L) when is_atom(Name), (D > 3) or (D < 0) -> Dcs = atom_to_list(Def), %Might not actually be defun Ncs = atom_to_list(Name), case lfe_lib:is_symb_list(Args) of true -> %Traditional - Acs = print1(Args, D-2, I + length(Dcs) + length(Ncs) + 3, L), - Tcs = print1_tail(Rest, D-3, I+2, L), + Acs = term(Args, D-2, I + length(Dcs) + length(Ncs) + 3, L), + Tcs = list_tail(Rest, D-3, I+2, L), ["(",Dcs," ",Ncs," ",Acs,Tcs,")"]; false -> %Matching - Tcs = print1_tail([Args|Rest], D-2, I+2, L), + Tcs = list_tail([Args|Rest], D-2, I+2, L), ["(",Dcs," ",Ncs,Tcs,")"] end; -print1_defun(List, D, I, L) -> +defun(List, D, I, L) -> %% Too short to get worked up about, or not a "proper" defun or %% not enough depth. - ["(",print1_list(List, D-1, I+1, L),")"]. + ["(",list(List, D-1, I+1, L),")"]. -%% print1_type(List, Depth, Indentation, LineLength, TypeCount) -> [char()]. -%% Print a special type form indenting first TypeCount elements afer -%% type and rest indented 2 steps. +%% type(List, Depth, Indentation, LineLength, TypeCount) -> [char()]. +%% Print a special type form indenting first TypeCount elements afer +%% type and rest indented 2 steps. -print1_type([Car|Cdr], D, I, L, N) when (D > 2) or (D < 0) -> +type([Car|Cdr], D, I, L, N) when (D > 2) or (D < 0) -> %% Handle special lists, we KNOW Car is an atom. Cs = atom_to_list(Car), NewI = I + length(Cs) + 2, {Spec,Rest} = split(N, Cdr), - Tcs = [print1_list(Spec, D-1, NewI, L), - print1_tail(Rest, D-2, I+2, L)], + Tcs = [list(Spec, D-1, NewI, L), + list_tail(Rest, D-2, I+2, L)], ["(" ++ Cs," ",Tcs,")"]; -print1_type(List, D, I, L, _) -> +type(List, D, I, L, _) -> %% Too short to get worked up about or not enough depth. - [$(,print1_list(List, D-1, I+1, L),$)]. + [$(,list(List, D-1, I+1, L),$)]. %% split(N, List) -> {List1,List2}. %% Split a list into two lists, the first containing the first N @@ -135,73 +151,72 @@ {H1,T1} = split(N-1, T), {[H|H1],T1}. -%% print1_list_max(List, Depth, Indentation, LineLength) -> {yes,Chars} | no. +%% 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([], _, _, _) -> {yes,[]}; -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-1, I + flatlength(Cs), L, [Cs]). +list_max([], _, _, _) -> {yes,[]}; +list_max(_, 0, _, _) -> {yes,"..."}; +list_max([Car|Cdr], D, I, L) -> + Cs = term(Car, D, 0, 99999), %Never break the line + tail_max(Cdr, D-1, I + flatlength(Cs), L, [Cs]). -%% print1_tail_max(Tail, Depth, Indentation, LineLength) -> {yes,Chars} | no. +%% 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 more room - no; -print1_tail_max([], _, _, _, Acc) -> {yes,reverse(Acc)}; -print1_tail_max(_, 0, _, _, Acc) -> {yes,reverse(Acc, [" ..."])}; -print1_tail_max([Car|Cdr], D, I, L, Acc) -> - Cs = print1(Car, D, 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, 0, 99999), %Never break the line - print1_tail_max([], D-1, I + flatlength(Cs) + 3, L, [Cs," . "|Acc]). - -%% print1_list(List, Depth, Indentation, LineLength) +tail_max(_, _, I, L, _) when I >= L -> no; %No more room +tail_max([], _, _, _, Acc) -> {yes,reverse(Acc)}; +tail_max(_, 0, _, _, Acc) -> {yes,reverse(Acc, [" ..."])}; +tail_max([Car|Cdr], D, I, L, Acc) -> + Cs = term(Car, D, 0, 99999), %Never break the line + tail_max(Cdr, D-1, I + flatlength(Cs) + 1, L, [Cs," "|Acc]); +tail_max(S, D, I, L, Acc) -> + Cs = term(S, D, 0, 99999), %Never break the line + tail_max([], D-1, I + flatlength(Cs) + 3, L, [Cs," . "|Acc]). + +%% list(List, Depth, Indentation, LineLength) %% Print a list, one element per line but print multiple atomic %% elements on one line. No leading/trailing (). -print1_list([], _, _, _) -> []; -print1_list(_, 0, _, _) -> "..."; -print1_list([Car|Cdr], D, I, L) -> - case print1_element(Car, I, D, I, L) of +list([], _, _, _) -> []; +list(_, 0, _, _) -> "..."; +list([Car|Cdr], D, I, L) -> + case list_element(Car, I, D, I, L) of {join,Ccs,Cl} -> %Atomic that fits - [Ccs|print1_tail(Cdr, I+Cl, D, I, L)]; + [Ccs|list_tail(Cdr, I+Cl, D, I, L)]; {break,Ccs,_} -> %Atomic that does not fit - [Ccs|print1_tail(Cdr, L, D, I, L)]; + [Ccs|list_tail(Cdr, L, D, I, L)]; {break,Ccs} -> %Non-atomic %% Force a break after not an atomic. - [Ccs|print1_tail(Cdr, L, D, I, L)] + [Ccs|list_tail(Cdr, L, D, I, L)] end. -%% print1_tail(Tail, Depth, Indentation, LineLength) -%% print1_tail(Tail, CurrentLength, Depth, Indentation, LineLength) +%% list_tail(Tail, Depth, Indentation, LineLength) +%% list_tail(Tail, CurrentLength, Depth, Indentation, LineLength) %% Print the tail of a list decreasing the depth for each element. We %% print multiple atomic elements on one line and we know about %% dotted pairs. -print1_tail(Tail, D, I, L) -> - print1_tail(Tail, L, D, I, L). %Force a break +list_tail(Tail, D, I, L) -> + list_tail(Tail, L, D, I, L). %Force a break -print1_tail([], _, _, _, _) -> ""; -print1_tail(_, _, 0, _, _) -> " ..."; -print1_tail([Car|Cdr], CurL, D, I, L) -> - case print1_element(Car, CurL+1, D, I, L) of +list_tail([], _, _, _, _) -> ""; +list_tail(_, _, 0, _, _) -> " ..."; +list_tail([Car|Cdr], CurL, D, I, L) -> + case list_element(Car, CurL+1, D, I, L) of {join,Ccs,Cl} -> %Atomic that fits - [$\s,Ccs,print1_tail(Cdr, CurL+1+Cl, D-1, I, L)]; + [$\s,Ccs,list_tail(Cdr, CurL+1+Cl, D-1, I, L)]; {break,Ccs,Cl} -> %Atomic that does not fit - [newline(I, Ccs),print1_tail(Cdr, I+Cl, D-1, I, L)]; + [newline(I, Ccs),list_tail(Cdr, I+Cl, D-1, I, L)]; {break,Ccs} -> %Non-atomic %% Force a break after not an atomic. - [newline(I, Ccs),print1_tail(Cdr, L, D-1, I, L)] + [newline(I, Ccs),list_tail(Cdr, L, D-1, I, L)] end; -print1_tail(Cdr, CurL, D, I, L) -> - case print1_element(Cdr, CurL+3, D, I, L) of +list_tail(Cdr, CurL, D, I, L) -> + case list_element(Cdr, CurL+3, D, I, L) of {join,Ccs,_} -> [" . "|Ccs]; %Atomic that fits {break,Ccs,_} -> %Atomic that does not fit [" .\n",blanks(I, Ccs)]; @@ -209,20 +224,20 @@ [" .\n",blanks(I, Ccs)] end. -print1_element(E, CurL, D, _, L) when is_number(E); - is_atom(E); - is_pid(E); - is_reference(E); - is_port(E); - is_function(E); - E =:= [] -> - Ecs = lfe_io:print1(E, D), +list_element(E, CurL, D, _, L) when is_number(E); + is_atom(E); + is_pid(E); + is_reference(E); + is_port(E); + is_function(E); + E =:= [] -> + Ecs = lfe_io_write:term(E, D), El = flatlength(Ecs), if CurL+El =< L - 10 -> {join,Ecs,El}; %Don't make the line too wide true -> {break,Ecs,El} end; -print1_element(E, _, D, I, L) -> - {break,print1(E, D, I, L)}. +list_element(E, _, D, I, L) -> + {break,term(E, D, I, L)}. blanks(N, Tail) -> string:chars($\s, N, Tail). @@ -238,8 +253,6 @@ %% Old style forms. indent_type('define') -> 1; -indent_type('define-module') -> 1; -indent_type('extend-module') -> 0; indent_type('define-syntax') -> 1; indent_type('define-record') -> 1; indent_type('begin') -> 0; @@ -252,6 +265,7 @@ indent_type('defmacro') -> defun; indent_type('defsyntax') -> 1; indent_type('defrecord') -> 1; +indent_type('deftest') -> 1; %% Core forms. indent_type('progn') -> 0; indent_type('lambda') -> 1; @@ -267,12 +281,14 @@ indent_type('try') -> 1; indent_type('funcall') -> 1; indent_type('call') -> 2; +indent_type('eval-when-compile') -> 0; indent_type('define-function') -> 1; indent_type('define-macro') -> 1; -indent_type('eval-when-compile') -> 0; +indent_type('define-module') -> 1; +indent_type('extend-module') -> 0; %% Core macros. indent_type(':') -> 2; -indent_type('cond') -> 999; %All following forms +indent_type('cond') -> 999; %All following forms indent_type('let*') -> 1; indent_type('flet') -> 1; indent_type('flet*') -> 1; @@ -280,62 +296,80 @@ indent_type(macrolet) -> 1; indent_type(syntaxlet) -> 1; indent_type('do') -> 2; -indent_type('lc') -> 1; %List comprehensions -indent_type('bc') -> 1; %Binary comprehensions +indent_type('lc') -> 1; %List comprehensions +indent_type('list-comp') -> 1; +indent_type('bc') -> 1; %Binary comprehensions +indent_type('binary-comp') -> 1; indent_type('match-spec') -> 0; indent_type(_) -> none. -%% print1_map(Map, Depth, Indentation, LineLength). -%% Print a map, one key value pair per line. +%% map(KVs, Depth, Indentation, LineLength). +%% map_body(KVs, CurrentLineIndent, Depth, Indentation, LineLength) -print1_map(Map, D, I, L) -> - [$#,$M,$(,print1_map_body(maps:to_list(Map), I+3, D, I+3, L-1),$)]. +map_body(KVs, D, I, L) -> + map_body(KVs, I, D, I, L-1). -print1_map_body([], _, _, _, _) -> []; -print1_map_body([{K,V}|KVs], CurL, D, I, L) -> - case print1_map_assoc(K, V, CurL, D, I, L) of - {join,KVcs,KVl} -> - [KVcs,print1_map_rest(KVs, CurL+KVl, D-1, I, L)]; - {break,KVcs,KVl} -> - [KVcs,print1_map_rest(KVs, I+KVl, D-1, I, L)]; - {break,KVcs} -> +map_body([K,V|KVs], CurL, D, I, L) -> + case map_assoc(K, V, CurL, D, I, L) of + {both_fit,KVcs,KVl} -> %Both fit on this line + [KVcs,map_rest(KVs, CurL+KVl, D-1, I, L)]; + {both_line,KVcs,KVl} -> %Both fit on single line + [KVcs,map_rest(KVs, I+KVl, D-1, I, L)]; + {break,KVcs} -> %On separate lines %% Force a break after K/V split. - [KVcs,print1_map_rest(KVs, L, D-1, I, L)] - end. - -print1_map_rest([], _, _, _, _) -> ""; -print1_map_rest(_, _, 0, _, _) -> " ..."; -print1_map_rest([{K,V}|KVs], CurL, D, I, L) -> - case print1_map_assoc(K, V, CurL+1, D, I, L) of - {join,KVcs,KVl} -> - [$\s,KVcs,print1_map_rest(KVs, CurL+KVl+1, D-1, I, L)]; - {break,KVcs,KVl} -> - [newline(I, KVcs),print1_map_rest(KVs, I+KVl, D-1, I, L)]; - {break,KVcs} -> + [KVcs,map_rest(KVs, L, D-1, I, L)] + end; +map_body(E, CurL, D, I, L) -> + map_last(E, CurL, D, I, L). + +%% map_rest(KVs, Depth, Indentation, LineLength) +%% map_rest(KVs, CurrentLineIndent, Depth, Indentation, LineLength) + +map_rest(KVs, D, I, L) -> + map_rest(KVs, I, D, I, L-1). + +map_rest([], _, _, _, _) -> ""; +map_rest(_, _, 0, _, _) -> " ..."; +map_rest([K,V|KVs], CurL, D, I, L) -> + case map_assoc(K, V, CurL+1, D, I, L) of + {both_fit,KVcs,KVl} -> %Both fit on this line + [$\s,KVcs,map_rest(KVs, CurL+KVl+1, D-1, I, L)]; + {both_line,KVcs,KVl} -> %Both fit on single line + [newline(I, KVcs),map_rest(KVs, I+KVl, D-1, I, L)]; + {break,KVcs} -> %On separate lines %% Force a break after K/V split. - [newline(I, KVcs),print1_map_rest(KVs, L, D-1, I, L)] - end. + [newline(I, KVcs),map_rest(KVs, L, D-1, I, L)] + end; +map_rest(E, CurL, D, I, L) -> + map_last(E, CurL, D, I, L). -print1_map_assoc(K, V, CurL, D, I, L) -> - Kcs = print1(K, D, 0, 99999), %Never break the line +map_last(Tail, CurL, D, I, L) -> + list_tail(Tail, CurL, D, I, L). + +map_assoc(K, V, CurL, D, I, L) -> + Kcs = term(K, D, 0, 99999), %Never break the line Kl = flatlength(Kcs), - Vcs = print1(V, D, 0, 99999), %Never break the line + Vcs = term(V, D, 0, 99999), %Never break the line Vl = flatlength(Vcs), if CurL+Kl+Vl < L-10 -> %Both fit together here - {join,[Kcs,$\s,Vcs],Kl+1+Vl}; + {both_fit,[Kcs,$\s,Vcs],Kl+1+Vl}; I+Kl+Vl < L-10 -> %Both fit on single line - {break,[Kcs,$\s,Vcs],Kl+1+Vl}; + {both_line,[Kcs,$\s,Vcs],Kl+1+Vl}; true -> %On separate lines %% Try to reuse flat prints if they fit on one line. Ks = if I+Kl < L-10 -> Kcs; - true -> print1(K, D, I, L) + true -> term(K, D, I, L) end, Vs = if I+Vl < L-10 -> Vcs; - true -> print1(V, D, I, L) + true -> term(V, D, I, L) end, {break,[Ks,newline(I, Vs)]} end. +%% last_length(Chars) -> Length. +%% last_length(Chars, CurrentLine) -> Length. +%% Return the length of the last line in the text. + last_length(S) -> last_length(S, 0). last_length([H|T], L0) when is_list(H) ->
View file
lfe-1.0.tar.gz/src/lfe_io_write.erl
Added
@@ -0,0 +1,155 @@ +%% Copyright (c) 2008-2015 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : lfe_io_write.erl +%% Author : Robert Virding +%% Purpose : Basic write functions for Lisp Flavoured Erlang. + +-module(lfe_io_write). + +-export([term/1,term/2,symbol/1,string/2,bitstring/2]). + +%% -compile(export_all). + +%% Define IS_MAP/1 macro for is_map/1 bif. +-ifdef(HAS_MAPS). +-define(IS_MAP(T), is_map(T)). +-else. +-define(IS_MAP(T), false). +-endif. + +%% print([IoDevice], Sexpr) -> ok. +%% print1(Sexpr) -> [char()]. +%% print1(Sexpr, Depth) -> [char()]. +%% A simple print function. Does not pretty-print but stops at Depth. + +term(S) -> term(S, -1). %All the way + +term(_, 0) -> "..."; +term(Symb, _) when is_atom(Symb) -> symbol(Symb); +term(Numb,_ ) when is_integer(Numb) -> integer_to_list(Numb); +term(Numb, _) when is_float(Numb) -> io_lib_format:fwrite_g(Numb); +term(List, D) when is_list(List) -> + [$(,list(List, D-1),$)]; +term({}, _) -> "#()"; +term(Vec, D) when is_tuple(Vec) -> + Es = tuple_to_list(Vec), + ["#(",list(Es, D-1),")"]; +term(Bit, _) when is_bitstring(Bit) -> + bitstring(Bit); +term(Map, D) when ?IS_MAP(Map) -> map(Map, D); +term(Other, D) -> %Use standard Erlang for rest + io_lib:write(Other, D). + +%% symbol(Symbol) -> [char()]. + +symbol(Symb) -> + Cs = atom_to_list(Symb), + case quote_symbol(Symb, Cs) of + true -> string(Cs , $|); + false -> Cs + end. + +%% bitstring(Bitstring) -> [char()] +%% bitstring(Bitstring, Depth) -> [char()] +%% Print the bytes in a bitstring. Print bytes except for last which +%% we add size field if not 8 bits big. + +bitstring(Bit) -> bitstring(Bit, -1). + +bitstring(Bit, D) -> + ["#B(",bytes(Bit, D),$)]. + +bytes(_, 0) -> "..."; +bytes(<<B:8>>, _) -> integer_to_list(B); %Catch last binary byte +bytes(<<B:8,Bs/bitstring>>, N) -> + [integer_to_list(B),$\s|bytes(Bs, N-1)]; +bytes(<<>>, _) -> []; +bytes(Bits, _) -> %0 < Size < 8 + N = bit_size(Bits), + <<B:N>> = Bits, + io_lib:format("(~w (size ~w))", [B,N]). + +%% list(List, Depth) -> Chars. +%% Print the elements in a list. We handle the empty list and depth=0. + +list([], _) -> []; +list(_, 0) -> "..."; +list([Car|Cdr], D) -> + [term(Car, D)|list_tail(Cdr, D-1)]. + +%% list_tail(Tail, Depth) +%% Print the tail of a list decrasing the depth for each element. We +%% know about dotted pairs. + +list_tail([], _) -> ""; +list_tail(_, 0) -> [$\s|"..."]; +list_tail([S|Ss], D) -> + [$\s,term(S, D)|list_tail(Ss, D-1)]; +list_tail(S, D) -> [" . "|term(S, D)]. + +%% map(Map, Depth) + +map(Map, D) -> + [$#,$M,$(,map_body(maps:to_list(Map), D), $)]. + +map_body([], _) -> []; +map_body(_, D) when D =:= 0; D =:= 1 -> "..."; +map_body([KV], D) -> map_assoc(KV, D); +map_body([KV|KVs], D) -> + Massoc = map_assoc(KV, D), + [Massoc,$\s|map_body(KVs, D-1)]. + +map_assoc({K,V}, D) -> + [term(K, D-1),$\s,term(V, D-1)]. + +%% quote_symbol(Symbol, SymbChars) -> bool(). +%% Check if symbol needs to be quoted when printed. If it can read as +%% a number then it must be quoted. + +quote_symbol('.', _) -> true; %Needs quoting +quote_symbol(_, [C|Cs]=Cs0) -> + case catch {ok,list_to_float(Cs0)} of + {ok,_} -> true; + _ -> case catch {ok,list_to_integer(Cs0)} of + {ok,_} -> true; + _ -> not (lfe_scan:start_symbol_char(C) andalso + symbol_chars(Cs)) + end + end; +quote_symbol(_, []) -> true. + +symbol_chars(Cs) -> lists:all(fun lfe_scan:symbol_char/1, Cs). + +%% string([Char], QuoteChar) -> [Char] +%% Generate the list of characters needed to print a string. + +string(S, Q) -> + [Q,string_chars(S, Q)]. + +string_chars([], Q) -> [Q]; +string_chars([C|Cs], Q) -> + string_char(C, Q, string_chars(Cs, Q)). + +string_char(Q, Q, Tail) -> [$\\,Q|Tail]; %Must check these first! +string_char($\\, _, Tail) -> [$\\,$\\|Tail]; +string_char($\b, _, Tail) -> [$\\,$b|Tail]; %\b = BS +string_char($\t, _, Tail) -> [$\\,$t|Tail]; %\t = TAB +string_char($\n, _, Tail) -> [$\\,$n|Tail]; %\n = LF +string_char($\v, _, Tail) -> [$\\,$v|Tail]; %\v = VT +string_char($\f, _, Tail) -> [$\\,$f|Tail]; %\f = FF +string_char($\r, _, Tail) -> [$\\,$r|Tail]; %\r = CR +string_char($\e, _, Tail) -> [$\\,$e|Tail]; %\e = ESC +string_char($\d, _, Tail) -> [$\\,$d|Tail]; %\d = DEL +string_char(C, _, Tail) -> [C|Tail].
View file
lfe-0.9.2.tar.gz/src/lfe_lib.erl -> lfe-1.0.tar.gz/src/lfe_lib.erl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2008-2013 Robert Virding +%% Copyright (c) 2008-2016 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -23,7 +23,7 @@ -export([is_symb/1,is_symb_list/1,is_proper_list/1,is_core_form/1]). --export([proc_forms/3]). +-export([proc_forms/3,proc_forms/4]). %% Standard lisp library. -export([is_lfe_bif/2, @@ -47,7 +47,7 @@ %% is_bif(Name, Arity) -> bool(). %% is_erl_bif(Name, Arity) -> bool(). %% is_guard_bif(Name, Arity) -> bool(). -%% Collected tests for valid BIFs in guards and expressions. +%% Collected tests for valid BIFs in guards and expressions. is_bif(Name, Ar) -> is_lfe_bif(Name, Ar) orelse is_erl_bif(Name, Ar). @@ -75,7 +75,7 @@ is_symb_list([S|Ss]) when is_atom(S) -> is_symb_list(Ss); is_symb_list([]) -> true; -is_symb_list(_) -> false. %Might not be a proper list +is_symb_list(_) -> false. %Might not be a proper list is_proper_list([_|Ss]) -> is_proper_list(Ss); is_proper_list([]) -> true; @@ -106,9 +106,6 @@ is_core_form('let-function') -> true; is_core_form('letrec-function') -> true; is_core_form('let-macro') -> true; -is_core_form('eval-when-compile') -> true; -is_core_form('define-function') -> true; -is_core_form('define-macro') -> true; %% Core control special forms. is_core_form('progn') -> true; is_core_form('if') -> true; @@ -118,50 +115,61 @@ is_core_form('try') -> true; is_core_form('funcall') -> true; is_core_form(call) -> true; -%% Everything else is not special. +%% Core definition special forms. +is_core_form('eval-when-compile') -> true; +is_core_form('define-function') -> true; +is_core_form('define-macro') -> true; +is_core_form('define-module') -> true; +is_core_form('extend-module') -> true; +%% Everything else is not a core form. is_core_form(_) -> false. %% proc_forms(FormFun, Forms, State) -> {Forms,State}. +%% proc_forms(FormFun, Forms, Line, State) -> {Forms,State}. %% Process a (progn ... ) nested list of forms where top level list %% has elements {Form,LineNumber}. Return a flat list of results and %% passes through State. All the elements are processed left to %% right. The accumulator is in reverse order! -proc_forms(Fun, Fs, St) -> proc_forms(Fun, Fs, [], St). +proc_forms(Fun, Fs, St) -> proc_top_forms(Fun, Fs, [], St). + +proc_forms(Fun, Fs, L, St0) -> + {Rs,St1} = proc_progn_forms(Fun, Fs, L, [], St0), + {reverse(Rs),St1}. -proc_forms(Fun, [{['progn'|Bs],L}|Fs], Rs0, St0) -> - {Rs1,St1} = proc_forms_progn(Fun, Bs, L, Rs0, St0), - proc_forms(Fun, Fs, Rs1, St1); -proc_forms(Fun, [{F,L}|Fs], Rs, St0) -> +proc_top_forms(Fun, [{['progn'|Bs],L}|Fs], Rs0, St0) -> + {Rs1,St1} = proc_progn_forms(Fun, Bs, L, Rs0, St0), + proc_top_forms(Fun, Fs, Rs1, St1); +proc_top_forms(Fun, [{F,L}|Fs], Rs, St0) -> {Frs,St1} = Fun(F, L, St0), - proc_forms(Fun, Fs, reverse(Frs, Rs), St1); -proc_forms(_, [], Rs, St) -> {reverse(Rs),St}. + proc_top_forms(Fun, Fs, reverse(Frs, Rs), St1); +proc_top_forms(_, [], Rs, St) -> {reverse(Rs),St}. -proc_forms_progn(Fun, [['progn'|Bbs]|Bs], L, Rs0, St0) -> - {Rs1,St1} = proc_forms_progn(Fun, Bbs, L, Rs0, St0), - proc_forms_progn(Fun, Bs, L, Rs1, St1); -proc_forms_progn(Fun, [B|Bs], L, Rs, St0) -> +proc_progn_forms(Fun, [['progn'|Bbs]|Bs], L, Rs0, St0) -> + {Rs1,St1} = proc_progn_forms(Fun, Bbs, L, Rs0, St0), + proc_progn_forms(Fun, Bs, L, Rs1, St1); +proc_progn_forms(Fun, [B|Bs], L, Rs, St0) -> {Frs,St1} = Fun(B, L, St0), - proc_forms_progn(Fun, Bs, L, reverse(Frs, Rs), St1); -proc_forms_progn(_, [], _, Rs, St) -> + proc_progn_forms(Fun, Bs, L, reverse(Frs, Rs), St1); +proc_progn_forms(_, [], _, Rs, St) -> {Rs,St}. -%% proc_forms(Fun, [{['progn'|Bs],L}|Fs], Rs, St) -> -%% proc_forms_progn(Fun, Bs, L, [], Fs, Rs, St); -%% proc_forms(Fun, [{F,L}|Fs], Rs, St0) -> +%% proc_top_forms(Fun, [{['progn'|Bs],L}|Fs], Rs, St) -> +%% proc_progn_forms(Fun, Bs, L, [], Fs, Rs, St); +%% proc_top_forms(Fun, [{F,L}|Fs], Rs, St0) -> %% {Frs,St1} = Fun(F, L, St0), -%% proc_forms(Fun, Fs, reverse(Frs, Rs), St1); -%% proc_forms(_, [], Rs, St) -> {reverse(Rs),St}. +%% proc_top_forms(Fun, Fs, reverse(Frs, Rs), St1); +%% proc_top_forms(_, [], Rs, St) -> {reverse(Rs),St}. -%% proc_forms_progn(Fun, [['progn'|Bs1]|Bs], L, Bss, Fs, Rs, St) -> -%% proc_forms_progn(Fun, Bs1, L, [Bs|Bss], Fs, Rs, St); -%% proc_forms_progn(Fun, [B|Bs], L, Bss, Fs, Rs, St0) -> +%% proc_progn_forms(Fun, [['progn'|Bs1]|Bs], L, Bss, Fs, Rs, St) -> +%% proc_progn_forms(Fun, Bs1, L, [Bs|Bss], Fs, Rs, St); +%% proc_progn_forms(Fun, [B|Bs], L, Bss, Fs, Rs, St0) -> %% {Frs,St1} = Fun(B, L, St0), -%% proc_forms_progn(Fun, Bs, L, Bss, Fs, reverse(Frs, Rs), St1); -%% proc_forms_progn(Fun, [], L, [Bs|Bss], Fs, Rs, St) -> -%% proc_forms_progn(Fun, Bs, L, Bss, Fs, Rs, St); -%% proc_forms_progn(Fun, [], _, [], Fs, Rs, St) -> -%% proc_forms(Fun, Fs, Rs, St). +%% proc_progn_forms(Fun, Bs, L, Bss, Fs, reverse(Frs, Rs), St1); +%% proc_progn_forms(Fun, [], L, [Bs|Bss], Fs, Rs, St) -> +%% proc_progn_forms(Fun, Bs, L, Bss, Fs, Rs, St); +%% proc_progn_forms(Fun, [], _, [], Fs, Rs, St) -> +%% proc_top_forms(Fun, Fs, Rs, St). %% Standard lisp library functions. %% is_lfe_bif(Name, Arity) -> bool(). @@ -298,7 +306,7 @@ end end. -eval(Sexpr) -> eval(Sexpr, lfe_env:new()). %Empty environment. +eval(Sexpr) -> eval(Sexpr, lfe_env:new()). %Empty environment. eval(Sexpr, Env) -> lfe_eval:expr(Sexpr, Env). 'macro-function'(Symb) -> 'macro-function'(Symb, lfe_env:new()). @@ -335,7 +343,7 @@ %% used to format terms; and Indentation is the current column. format_exception(Cl, Error0, St0, Sf, Ff, I) -> - Cs = case Cl of %Class type as string + Cs = case Cl of %Class type as string throw -> "throw"; exit -> "exit"; error -> "error" @@ -344,7 +352,7 @@ true -> {Error0,St0}; false -> {{Error0,St0},[]} end, - P = "exception " ++ Cs ++ ": ", %Class description string + P = "exception " ++ Cs ++ ": ", %Class description string [P,lfe_io:prettyprint1(Error1, 10, length(P)+I-1),"\n", format_stacktrace(St1, Sf, Ff)].
View file
lfe-0.9.2.tar.gz/src/lfe_lint.erl -> lfe-1.0.tar.gz/src/lfe_lint.erl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2008-2013 Robert Virding +%% Copyright (c) 2008-2015 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -18,8 +18,8 @@ -module(lfe_lint). --export([module/1,module/2,form/1,expr/1,expr/2,pattern/1,pattern/2, - format_error/1]). +-export([module/1,module/2,form/1,expr/1,expr/2, + pattern/1,pattern/2,format_error/1]). -import(lfe_env, [new/0,is_vbound/2,is_fbound/3,is_gbound/3, add_vbinding/3,add_fbinding/4,add_ibinding/5]). @@ -36,20 +36,18 @@ -include("lfe_comp.hrl"). --record(lint, {module=[], %Module name - pars=none, %Module parameters - extd=[], %Extends - exps=[], %Exports - imps=[], %Imports - pref=[], %Prefixes - funcs=[], %Defined functions - env=[], %Top-level environment - line=[], %Current line - func=[], %Current function - file="nofile", %File name - opts=[], %Compiler options - errors=[], %Errors - warnings=[] %Warnings +-record(lint, {module=[], %Module name + exps=[], %Exports + imps=[], %Imports + pref=[], %Prefixes + funcs=[], %Defined functions + env=[], %Top-level environment + line=[], %Current line + func=[], %Current function + file="nofile", %File name + opts=[], %Compiler options + errors=[], %Errors + warnings=[] %Warnings }). %% Errors. @@ -114,25 +112,24 @@ return_status(St1). %% form(Form) -> {ok,[Warning]} | {error,[Error],[Warning]}. +%% Create a dummy module then test the form a function. form(F) -> - module([{['define-module',dummy],1}, - {F,2}]). + module([{['define-module',dummy],1},{F,2}]). -%% module(Forms) -> {ok,[Warning]} | {error,[Error],[Warning]}. -%% module(Forms, CompInfo) -> {ok,[Warning]} | {error,[Error],[Warning]}. -%% Lint the forms in a module. +%% module(ModuleForms) -> +%% {ok,ModuleName,[Warning]} | {error,[Error],[Warning]}. +%% module(ModuleForms, CompInfo) -> +%% {ok,ModuleName,[Warning]} | {error,[Error],[Warning]}. +%% Lint the forms in one module file. -module(Fs) -> module(Fs, #cinfo{file="nofile",opts=[]}). +module(Ms) -> module(Ms, #cinfo{file="nofile",opts=[]}). -module(Fs0, #cinfo{file=F,opts=Os}) -> - %% Predefined functions - St0 = #lint{file=F,opts=Os}, - %% Collect forms and fill in module infor in state. - {Fs1,St1} = lfe_lib:proc_forms(fun collect_form/3, Fs0, St0), - St2 = check_module(Fs1, St1), - debug_print("#lint: ~p\n", [St2], Os), - return_status(St2). +module(Ms, #cinfo{file=F,opts=Os}) -> + St0 = #lint{file=F,opts=Os}, %Initialise the lint record + St1 = check_module(Ms, St0), + debug_print("#lint: ~p\n", [St1], Os), + return_status(St1). debug_print(Format, Args, Opts) -> case member(debug_print, Opts) of @@ -140,43 +137,56 @@ false -> ok end. -return_status(#lint{errors=[]}=St) -> - {ok,St#lint.warnings}; +return_status(#lint{module=M,errors=[]}=St) -> + {ok,M,St#lint.warnings}; return_status(St) -> {error,St#lint.errors,St#lint.warnings}. -%% collect_form(Form, Line, State) -> {[Ret],State}. -%% Collect valid forms and module data. Returns forms and put module -%% data into state. Flag unknown forms and define-module not first. +%% check_module(ModuleForms, State) -> State. +%% Do all the actual work checking a module. -collect_form(['define-module',Mod|Mdef], L, St0) -> - %% Check normal module or parameterised module. - case is_symb_list(Mod) of %Parameterised module - true -> - {Vs,St1} = check_lambda_args(tl(Mod), L, St0), - %% Everything into State. - {[],check_mdef(Mdef, L, St1#lint{module=hd(Mod),pars=Vs})}; - false when is_atom(Mod) -> %Normal module +check_module(Mfs, St0) -> + {Fbs0,St1} = collect_module(Mfs, St0), + %% Make an initial environment and set up state. + {Predefs,Env0,St2} = init_state(St1), + Fbs1 = Predefs ++ Fbs0, + %% Now check definitions. + {Fs,Env1,St3} = check_letrec_bindings(Fbs1, Env0, St2), + %% Save functions and environment and test exports. + St4 = St3#lint{funcs=Fs,env=Env1}, + check_exports(St4#lint.exps, Fs, St4). + +%% collect_module(ModuleForms, State) -> {Fbs,State}. +%% Collect valid forms and module data. Returns function bindings and +%% puts module data into state. Flag unknown forms and define-module +%% not first. + +collect_module(Mfs, St0) -> + {Acc,St1} = lists:foldl(fun collect_form/2, {[],St0}, Mfs), + {lists:reverse(Acc),St1}. + +collect_form({['define-module',Mod|Mdef],L}, {Acc,St0}) -> + if is_atom(Mod) -> %Normal module %% Everything into State. - {[],check_mdef(Mdef, L, St0#lint{module=Mod,pars=none})}; - false -> %Bad module name - {[],bad_mdef_error(L, name, St0)} + {Acc,check_mdef(Mdef, L, St0#lint{module=Mod})}; + true -> %Bad module name + {Acc,bad_mdef_error(L, name, St0)} end; -collect_form(_, L, #lint{module=[]}=St) -> +collect_form({_,L}, {Acc,#lint{module=[]}=St}) -> %% Set module name so this only triggers once. - {[],bad_mdef_error(L, name, St#lint{module='-no-module-'})}; -collect_form(['extend-module'|Mdef], L, St) -> - {[],check_mdef(Mdef, L, St)}; -collect_form(['define-function',Func,Body], L, St) -> + {Acc,bad_mdef_error(L, name, St#lint{module='-no-module-'})}; +collect_form({['extend-module'|Mdef],L}, {Acc,St}) -> + {Acc,check_mdef(Mdef, L, St)}; +collect_form({['define-function',Func,Body],L}, {Acc,St}) -> case Body of [lambda|_] when is_atom(Func) -> - {[{Func,Body,L}],St}; + {[{Func,Body,L}|Acc],St}; ['match-lambda'|_] when is_atom(Func) -> - {[{Func,Body,L}],St}; - _ -> {[],bad_form_error(L, 'define-function', St)} + {[{Func,Body,L}|Acc],St}; + _ -> {Acc,bad_form_error(L, 'define-function', St)} end; -collect_form(_, L, St) -> - {[],add_error(L, unknown_form, St)}. +collect_form({_,L}, {Acc,St}) -> + {Acc,add_error(L, unknown_form, St)}. check_mdef([[export,all]|Mdef], L, St) -> %Pass 'all' along check_mdef(Mdef, L, St#lint{exps=all}); @@ -191,12 +201,6 @@ check_mdef([[import|Is]|Mdef], L, St0) -> St1 = check_imports(Is, L, St0), check_mdef(Mdef, L, St1); -check_mdef([[extends,M]|Mdef], L, St) -> - if is_atom(M) -> - check_mdef(Mdef, L, St#lint{extd=M}); - true -> - check_mdef(Mdef, L, add_error(L, bad_extends, St)) - end; 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 @@ -248,19 +252,6 @@ is_flist([], Funcs) -> {yes,Funcs}; is_flist(_, _) -> no. -%% check_module(FuncBindings, State) -> State. -%% Do all the actual work checking a module. - -check_module(Fbs0, St0) -> - %% Make an initial environment and set up state. - {Predefs,Env0,St1} = init_state(St0), - Fbs1 = Predefs ++ Fbs0, - %% Now check definitions. - {Fs,Env1,St2} = check_letrec_bindings(Fbs1, Env0, St1), - %% Save functions and environment and test exports. - St3 = St2#lint{funcs=Fs,env=Env1}, - check_exports(St3#lint.exps, Fs, St3). - %% init_state(State) -> {Predefs,Env,State}. %% Setup the initial predefines and state. Build dummies for %% predefined module_info and parameteried module functions, which @@ -277,30 +268,7 @@ Predefs0 = [{module_info,[lambda,[],[quote,dummy]],1}, {module_info,[lambda,[x],[quote,dummy]],1}], Exps0 = [{module_info,0},{module_info,1}], - %% Now handle parameterised module. - case St#lint.pars of - none -> %Normal module - {Predefs0,Env0, - St#lint{exps=add_exports(St#lint.exps, Exps0)}}; - Ps0 -> %Parameterised module - {Ps1,Predefs1,Exps1} = para_defs(Ps0, Predefs0, Exps0, St), - {Predefs1, - add_vbindings([this|Ps1], Env0), - St#lint{exps=add_exports(St#lint.exps, Exps1)}} - end. - -para_defs(Ps, Predefs0, Exps0, St) -> - Ar = length(Ps), - Predefs1 = [{new,[lambda,Ps,[quote,dummy]],1}|Predefs0], - Exps1 = add_element({new,Ar}, Exps0), - case St#lint.extd of - [] -> - {Ps,[{instance,[lambda,Ps,[quote,dummy]],1}|Predefs1], - add_element({instance,Ar},Exps1)}; - _ -> - {[base|Ps],[{instance,[lambda,[base|Ps],[quote,dummy]],1}|Predefs1], - add_element({instance,Ar+1},Exps1)} - end. + {Predefs0,Env0,St#lint{exps=add_exports(St#lint.exps, Exps0)}}. check_exports(all, _, St) -> St; %All is all check_exports(Exps, Fs, St) -> @@ -314,7 +282,6 @@ %% add_exports(Old, More) -> New. add_exports(all, _) -> all; -add_exports(_, all) -> all; add_exports(Old, More) -> union(Old, More). %% check_expr(Expr, Env, Line, State) -> State. @@ -522,8 +489,12 @@ check_expr(V, Env, L, St1). %% map_key(Key, Env, L, State) -> State. -%% A map key can currently only be a literal. +%% A map key can only be a literal in 17 but can be anything in 18. +-ifdef(HAS_FULL_KEYS). +map_key(Key, Env, L, St) -> + check_expr(Key, Env, L, St). +-else. map_key(Key, _, L, St) -> case is_map_key(Key) of true -> St; @@ -534,6 +505,8 @@ is_map_key([_|_]=L) -> is_posint_list(L); %Literal strings only is_map_key(E) when is_atom(E) -> false; is_map_key(Lit) -> is_literal(Lit). +-endif. + -else. expr_map(Ps, _, L, St) -> add_error(L, {unbound_func,{map,safe_length(Ps)}}, St). @@ -615,7 +588,8 @@ bad_form_error(L, 'let', St). %% check_let_vb(VarBind, Env, Line, State) -> {Env,State}. -%% Check a variable binding of form [Pat,[when,Guard],Val] or [Pat,Val]. +%% Check a variable binding of form [Pat,[when,Guard],Val] or +%% [Pat,Val]. check_let_vb(Vb, Env, L, St0) -> %% Get the environments right here! @@ -726,7 +700,7 @@ bad_form_error(L, 'if', St). %% check_case(CaseBody, Env, Line, State) -> State. -%% Check form (case Expr Clause ...), must be at least one clause. +%% Check form (case Expr Clause ...), must be at least one clause. check_case([E|[_|_]=Cls], Env, L, St0) -> St1 = check_expr(E, Env, L, St0), @@ -755,9 +729,9 @@ check_clause(_, _, L, St) -> bad_form_error(L, clause, St). %% check_try(TryBody, Env, Line, State) -> State. -%% Check a (try ...) form making sure that the right combination of -%% options are present. Case is optional, but we must have at least -%% one of catch and after. +%% Check a (try ...) form making sure that the right combination of +%% options are present. Case is optional, but we must have at least +%% one of catch and after. check_try([E,['case'|Cls]|Catch], Env, L, St0) -> St1 = check_expr(E, Env, L, St0), @@ -797,7 +771,7 @@ check_guard(G, Env, L, St) -> check_gbody(G, Env, L, St). %% check_gbody(Body, Env, Line, State) -> State. -%% Check guard expressions in a body +%% Check guard expressions in a body check_gbody([E|Es], Env, L, St0) -> St1 = check_gexpr(E, Env, L, St0), @@ -806,7 +780,7 @@ check_gbody(_, _, L, St) -> illegal_guard_error(L, St). %% check_gexpr(Call, Env, Line, State) -> State. -%% Check a guard expression. This is a restricted body expression. +%% Check a guard expression. This is a restricted body expression. %% Check the Core data special cases. check_gexpr([quote,Lit], Env, L, St) -> literal(Lit, Env, L, St); @@ -865,7 +839,7 @@ %% check_gargs(Args, Env, Line, State) -> State. %% check_gexprs(Exprs, Env, Line, State) -> State. -%% The guard counter parts. Check_gexprs assumes a proper list. +%% The guard counter parts. Check_gexprs assumes a proper list. check_gargs(Args, Env, L, St) -> case is_proper_list(Args) of @@ -877,7 +851,7 @@ foldl(fun (E, S) -> check_gexpr(E, Env, L, S) end, St, Es). %% check_gif(IfBody, Env, Line, State) -> State. -%% Check guard form (if Test True [False]). +%% Check guard form (if Test True [False]). check_gif([Test,True,False], Env, L, St) -> check_gexprs([Test,True,False], Env, L, St); @@ -918,8 +892,28 @@ bad_form_error(L, map, St). gexpr_map_assoc(K, V, Env, L, St0) -> - St1 = map_key(K, Env, L, St0), + St1 = gmap_key(K, Env, L, St0), check_gexpr(V, Env, L, St1). + +%% gmap_key(Key, Env, L, State) -> State. +%% A map key can only be a literal in 17 but can be anything in 18. + +-ifdef(HAS_FULL_KEYS). +gmap_key(Key, Env, L, St) -> + check_gexpr(Key, Env, L, St). +-else. +gmap_key(Key, _, L, St) -> + case is_gmap_key(Key) of + true -> St; + false -> add_error(L, illegal_mapkey, St) + end. + +is_gmap_key([quote,Lit]) -> is_literal(Lit); +is_gmap_key([_|_]=L) -> is_posint_list(L); %Literal strings only +is_gmap_key(E) when is_atom(E) -> false; +is_gmap_key(Lit) -> is_literal(Lit). +-endif. + -else. gexpr_map(Ps, _, L, St) -> add_error(L, {unbound_func,{map,safe_length(Ps)}}, St). @@ -973,9 +967,14 @@ pattern([map|As], Pvs, Env, L, St) -> pat_map(As, Pvs, Env, L, St); %% Check old no contructor list forms. -pattern([_|_]=List, Pvs0, Env, L, St0) -> - St1 = add_warning(L, {deprecated,"pattern"}, St0), - pat_list(List, Pvs0, Env, L, St1); +pattern([H|T]=List, Pvs0, Env, L, St0) -> + case is_posint_list(List) of + true -> {Pvs0,St0}; %A string + false -> %Illegal pattern + St1 = add_warning(L, {deprecated,"pattern"}, St0), + {Pvs1,St2} = pattern(H, Pvs0, Env, L, St1), + pattern(T, Pvs1, Env, L, St2) + end; %% pattern([_|_], Pvs, _, L, St) -> %% {Pvs,add_error(L, illegal_pattern, St)}; pattern([], Pvs, _, _, St) -> {Pvs,St}; @@ -1125,8 +1124,22 @@ {Pvs,bad_form_error(L, map, St)}. pat_map_assoc(K, V, Pvs, Env, L, St0) -> - St1 = map_key(K, Env, L, St0), + St1 = pat_map_key(K, Env, L, St0), pattern(V, Pvs, Env, L, St1). + +%% pat_map_key(Key, Env, L, State) -> State. +%% A pattern map key can currently only be a literal. + +pat_map_key(Key, _, L, St) -> + case is_pat_map_key(Key) of + true -> St; + false -> add_error(L, illegal_mapkey, St) + end. + +is_pat_map_key([quote,Lit]) -> is_literal(Lit); +is_pat_map_key([_|_]=L) -> is_posint_list(L); %Literal strings only +is_pat_map_key(E) when is_atom(E) -> false; +is_pat_map_key(Lit) -> is_literal(Lit). -else. pat_map(_, Pvs, _, L, St) -> {Pvs,add_error(L, illegal_pattern, St)}.
View file
lfe-0.9.2.tar.gz/src/lfe_macro.erl -> lfe-1.0.tar.gz/src/lfe_macro.erl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2008-2013 Robert Virding +%% Copyright (c) 2008-2016 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -21,37 +21,53 @@ -module(lfe_macro). --compile(export_all). +%% -compile(export_all). %% These work on individual expressions. -export([expand_expr/2,expand_expr_1/2,expand_expr_all/2]). %% These work on list of forms in "file format". --export([expand_forms/2,macro_forms/2]). +-export([expand_forms/2,expand_forms/3,macro_forms/2,macro_forms/3]). +-export([macro_form_init/1,macro_form/4,macro_fileform/3]). +-export([expand_form_init/1,expand_form/4,expand_fileform/3]). -export([format_error/1]). -export([mbe_syntax_rules_proc/4,mbe_syntax_rules_proc/5, - mbe_match_pat/3,mbe_get_bindings/3,mbe_expand_pattern/3]). + mbe_match_pat/3,mbe_get_bindings/3,mbe_expand_pattern/3]). %% -compile([export_all]). --import(lfe_env, [new/0,add_fbinding/4,is_fbound/3, - add_mbinding/3,is_mbound/2,get_mbinding/2]). +-import(lfe_env, [new/0,add_vbinding/3,is_vbound/2, + add_fbinding/4,is_fbound/3, + add_mbinding/3,is_mbound/2,get_mbinding/2]). -import(lfe_lib, [is_symb_list/1,is_proper_list/1]). -import(lists, [any/2,all/2,map/2,foldl/3,foldr/3,mapfoldl/3, - reverse/1,reverse/2,member/2,concat/1]). --import(orddict, [find/2,store/3]). --import(ordsets, [add_element/2,is_element/2]). + reverse/1,reverse/2,member/2,concat/1]). -include("lfe_comp.hrl"). -include("lfe_macro.hrl"). +%% Bloody useful +-define(IF(Test,True,False), case Test of + true -> True; + false -> False + end). + +%% Define IS_MAP/1 macro for is_map/1 bif. +-ifdef(HAS_MAPS). +-define(IS_MAP(T), is_map(T)). +-else. +-define(IS_MAP(T), false). +-endif. + %% Errors format_error({bad_form,Type}) -> lfe_io:format1("bad form: ~w", [Type]); +format_error({bad_env_form,Type}) -> + lfe_io:format1("bad environment form: ~w", [Type]); format_error({expand_macro,Call,_}) -> %% Can be very big so only print limited depth. lfe_io:format1("error expanding ~P", [Call,10]). @@ -62,7 +78,7 @@ %% or as far as it can go. expand_expr_1([Name|_]=Call, Env) when is_atom(Name) -> - St = default_state(false), + St = default_state(false, false), case exp_macro(Call, Env, St) of {yes,Exp,_} -> {yes,Exp}; no -> no @@ -70,7 +86,7 @@ expand_expr_1(_, _) -> no. expand_expr([Name|_]=Call, Env) when is_atom(Name) -> - St0 = default_state(false), + St0 = default_state(false, false), case exp_macro(Call, Env, St0) of {yes,Exp0,St1} -> {Exp1,_} = expand_expr_loop(Exp0, Env, St1), @@ -90,196 +106,258 @@ %% Expand all the macros in an expression. expand_expr_all(F, Env) -> - {Ef,_} = exp_form(F, Env, default_state(true)), + {Ef,_} = exp_form(F, Env, default_state(true, false)), Ef. %% expand_forms(FileForms, Env) -> %% expand_forms(FileForms, Env, CompInfo) -> %% {ok,FileForms,Env,Warnings} | {error,Errors,Warnings}. -%% Expand forms in "file format", {Form,LineNumber}. +%% Collect macro definitions in file forms, completely expand all +%% macros and only keep all functions. expand_forms(Fs, Env) -> - St = default_state(true), + St = default_state(true, false), do_forms(Fs, Env, St). -expand_forms(Fs, Env, #cinfo{file=F,opts=Os,ipath=Is}) -> - St = #mac{expand=true,file=F,opts=Os,ipath=Is}, +expand_forms(Fs, Env, Ci) -> + St = default_state(Ci, true, false), do_forms(Fs, Env, St). %% macro_forms(FileForms, Env) -> %% macro_forms(FileForms, Env, CompInfo) -> %% {ok,FileForms,Env,Warnings} | {error,Errors,Warnings}. -%% Collect, and remove, all macro definitions in a list of forms. All -%% top level macro calls are also expanded and any new macro -%% definitions are collected. +%% Collect macro definitions in file forms, expand top-level macros +%% and keep all forms. macro_forms(Fs, Env) -> - St = default_state(false), + St = default_state(false, true), do_forms(Fs, Env, St). -macro_forms(Fs, Env, #cinfo{file=F,opts=Os,ipath=Is}) -> - St = #mac{expand=false,file=F,opts=Os,ipath=Is}, +macro_forms(Fs, Env, Ci) -> + St = default_state(Ci, false, true), do_forms(Fs, Env, St). do_forms(Fs0, Env0, St0) -> - {Fs1,Env1,St1} = pass(Fs0, Env0, St0), + {Fs1,Env1,St1} = pass_fileforms(Fs0, Env0, St0), case St1#mac.errors of [] -> {ok,Fs1,Env1,St1#mac.warnings}; %No errors Es -> {error,Es,St1#mac.warnings} end. -default_state(Expand) -> - #mac{expand=Expand,line=1,file="-nofile-",opts=[],ipath=["."]}. - -%% pass(FileForms, Env, State) -> {FileForms,Env,State}. -%% Pass over a list of fileforms, {Form,Line}, collecting and -%% removing all macro defintions. All forms must be expanded at -%% top-level to check form, but all can be expanded to full depth. -%% Nesting of forms by progn is preserved. - -pass([{['progn'|Pfs0],L}|Fs0], Env0, St0) -> - {Pfs1,Env1,St1} = pass_progn(Pfs0, Env0, St0#mac{line=L}), - {Fs1,Env2,St2} = pass(Fs0, Env1, St1), - {[{['progn'|Pfs1],L}|Fs1],Env2,St2}; -pass([{['eval-when-compile'|Ewcs0],L}|Fs0], Env0, St0) -> - {Ecws1,Env1,St1} = pass_ewc(Ewcs0, Env0, St0#mac{line=L}), - {Fs1,Env2,St2} = pass(Fs0, Env1, St1), - {[{['progn'|Ecws1],L}|Fs1],Env2,St2}; -pass([{['define-macro'|Def]=F,L}|Fs0], Env0, St0) -> - case pass_define_macro(Def, Env0, St0#mac{line=L}) of - {yes,Env1,St1} -> pass(Fs0, Env1, St1); - {no,St1} -> - %% Ignore it and pass it on to generate error later. - {Fs1,Env1,St2} = pass(Fs0, Env0, St1), - {[{F,L}|Fs1],Env1,St2} - end; -pass([{F,L}|Fs0], Env0, St0) -> - %% First expand enough to test top form, else maybe expand all. - case pass_expand_expr(F, Env0, St0#mac{line=L}, St0#mac.expand) of - {yes,Exp,St1} -> %Top form expanded - pass([{Exp,L}|Fs0], Env0, St1); - {no,F1,St1} -> %Expanded all if flag set - {Fs1,Env1,St2} = pass(Fs0, Env0, St1), - {[{F1,L}|Fs1],Env1,St2} - end; -pass([], Env, St) -> {[],Env,St}. +default_state(Expand, Keep) -> + #mac{expand=Expand,keep=Keep,line=1,file="-nofile-",opts=[],ipath=["."]}. + +default_state(#cinfo{file=File,opts=Os,ipath=Is}, Expand, Keep) -> + #mac{expand=Expand,keep=Keep,line=1,file=File,opts=Os,ipath=Is}. + +%% expand_form_init(CompInfo) -> State. +%% expand_form(Form, Line, Env, State) -> {Form,Env,State}. +%% expand_fileform(Form, Env, State) -> {Form,Env,State}. +%% Collect macro definitions in a (file)form, completely expand all +%% macros and only keep all functions. + +expand_form_init(Ci) -> + default_state(Ci, true, false). + +expand_form(F0, L, E0, St0) -> + {F1,E1,St1} = pass_form(F0, E0, St0#mac{line=L}), + return_status(F1, E1, St1). + +expand_fileform({F0,L}, E0, St0) -> + {F1,E1,St1} = pass_form(F0, E0, St0#mac{line=L}), + return_status({F1,L}, E1, St1). + +%% macro_form_init(CompInfo) -> State. +%% macro_form(Form, Line, Env, State) -> {Form,Env,State}. +%% macro_fileform(Form, Env, State) -> {FileForm,Env,State}. +%% Collect macro definitions in a (file)form, expand top-level macros +%% and keep all forms. + +macro_form_init(Ci) -> + default_state(Ci, false, true). + +macro_form(F0, L, E0, St0) -> + {F1,E1,St1} = pass_form(F0, E0, St0#mac{line=L}), + return_status(F1, E1, St1). + +macro_fileform({F0,L}, E0, St0) -> + {F1,E1,St1} = pass_form(F0, E0, St0#mac{line=L}), + return_status({F1,L}, E1, St1). + +return_status(Ret, Env, #mac{errors=[]}=St) -> + {ok,Ret,Env,St}; +return_status(_, _, #mac{errors=Es,warnings=Ws}=St) -> + {error,Es,Ws,St}. -%% pass_progn(Forms, Env, State) -> {Forms,Env,State}. -%% Pass over a list of forms collecting and removing all macro +%% pass_fileforms(FileForms, Env, State) -> {FileForms,Env,State}. +%% pass_forms(Forms, Env, State) -> {Forms,Env,State}. +%% Pass over a list of fileforms/forms collecting and removing all macro %% defintions. All forms must be expanded at top-level to check form, %% but all can be expanded to full depth. Nesting of forms by progn %% is preserved. -pass_progn([['progn'|Pfs0]|Fs0], Env0, St0) -> - {Pfs1,Env1,St1} = pass_progn(Pfs0, Env0, St0), - {Fs1,Env2,St2} = pass_progn(Fs0, Env1, St1), - {[['progn'|Pfs1]|Fs1],Env2,St2}; -pass_progn([['eval-when-compile'|Ewcs0]|Fs0], Env0, St0) -> - {Ecws1,Env1,St1} = pass_ewc(Ewcs0, Env0, St0), - {Fs1,Env2,St2} = pass_progn(Fs0, Env1, St1), - {[['progn'|Ecws1]|Fs1],Env2,St2}; -pass_progn([['define-macro'|Def]=F|Fs0], Env0, St0) -> +pass_fileforms(Ffs, Env, St) -> + mapfoldl2(fun ({F0,L}, E0, S0) -> + {F1,E1,S1} = pass_form(F0, E0, S0#mac{line=L}), + {{F1,L},E1,S1} + end, Env, St, Ffs). + +pass_forms(Fs, Env, St) -> + mapfoldl2(fun (F0, E0, S0) -> pass_form(F0, E0, S0) end, Env, St, Fs). + +%% pass_form(Form, Env, State) -> {Form,Env,State}. +%% Do a form collecting and removing all macro defintions. The form +%% must be expanded at top-level to check it, but it can be expanded +%% to full depth. Nesting of forms by progn is preserved. + +pass_form(['progn'|Pfs0], Env0, St0) -> + {Pfs1,Env1,St1} = pass_forms(Pfs0, Env0, St0), + {['progn'|Pfs1],Env1,St1}; +pass_form(['eval-when-compile'|Efs0], Env0, St0) -> + {Efs1,Env1,St1} = pass_ewc(Efs0, Env0, St0), + {['eval-when-compile'|Efs1],Env1,St1}; +pass_form(['define-macro'|Def]=M, Env0, St0) -> case pass_define_macro(Def, Env0, St0) of - {yes,Env1,St1} -> pass_progn(Fs0, Env1, St1); - {no,St1} -> - %% Ignore it and pass it on to generate error later. - {Fs1,Env1,St2} = pass_progn(Fs0, Env0, St1), - {[F|Fs1],Env1,St2} + {yes,Env1,St1} -> + Ret = ?IF(St1#mac.keep, M, [progn]), + {Ret,Env1,St1}; %Must return a valid form + no -> + St1 = add_error({bad_form,macro}, St0), + {['progn'],Env0,St1} %Must return a valid form end; -pass_progn([F|Fs0], Env0, St0) -> +pass_form(F, Env, St0) -> %% First expand enough to test top form, if so process again. - case pass_expand_expr(F, Env0, St0, St0#mac.expand) of - {yes,Exp,St1} -> %Top form expanded - pass_progn([Exp|Fs0], Env0, St1); - {no,F1,St1} -> %Expanded all if flag set - {Fs1,Env1,St2} = pass_progn(Fs0, Env0, St1), - {[F1|Fs1],Env1,St2} + case pass_expand_expr(F, Env, St0, St0#mac.expand) of + {yes,Exp,St1} -> %Top form expanded + pass_form(Exp, Env, St1); + {no,F1,St1} -> %Expanded all if flag set + {F1,Env,St1} + end. + +%% pass_ewc(Forms, Env, State) -> {Env,State}. +%% Pass over the list of forms which evaluate at compile +%% time. Function and macro definitions are collected in the +%% environment and other experssions are evaluated. The shell set +%% forms are also specially recognised and the variables are bound +%% and kept in the environment as well. The functions and macrso +%% behave as in the shell. + +pass_ewc(Fs, Env, St) -> + mapfoldl2(fun (F, E, S) -> pass_ewc_form(F, E, S) end, Env, St, Fs). + +pass_ewc_form(['progn'|Pfs0], Env0, St0) -> + {Pfs1,Env1,St1} = pass_ewc(Pfs0, Env0, St0), + {['progn'|Pfs1],Env1,St1}; +pass_ewc_form(['eval-when-compile'|Efs0], Env0, St0) -> + {Efs1,Env1,St1} = pass_ewc(Efs0, Env0, St0), + {['progn'|Efs1],Env1,St1}; +pass_ewc_form(['define-macro'|Def]=M, Env0, St0) -> + %% Do we really want this? It behaves as a top-level macro def. + case pass_define_macro(Def, Env0, St0) of + {yes,Env1,St1} -> + Ret = ?IF(St1#mac.keep, M, [progn]), + {Ret,Env1,St1}; %Don't macro expand now + no -> + St1 = add_error({bad_env_form,macro}, St0), + {[progn],Env0,St1} %Just throw it away end; -pass_progn([], Env, St) -> {[],Env,St}. - -%% pass_ewc(Forms, Env, State) -> {Forms,Env,State}. -%% Pass over a list of forms collecting and removing all function -%% defintions. All forms must be expanded at top-level to check -%% form. Nesting of forms by progn is preserved. All functions are -%% put into one letrec structure in environment so they are mutally -%% recursive, while unrecognised forms are returned. They can call -%% functions in previously defined eval-when-compile's. - -pass_ewc(Fs0, Env0, St0) -> - {Fs1,Fbs,Env1,St1} = pass_ewc(Fs0, [], Env0, St0), - Env2 = lfe_eval:make_letrec_env(Fbs, Env1), - {Fs1,Env2,St1}. - -pass_ewc([['progn'|Pfs0]|Fs0], Fbs0, Env0, St0) -> - {Pfs1,Fbs1,Env1,St1} = pass_ewc(Pfs0, Fbs0, Env0, St0), - {Fs1,Fbs2,Env2,St2} = pass_ewc(Fs0, Fbs1, Env1, St1), - {[['progn'|Pfs1]|Fs1],Fbs2,Env2,St2}; -pass_ewc([['eval-when-compile'|Ewcs0]|Fs0], Fbs0, Env0, St0) -> - {Ecws1,Fbs1,Env1,St1} = pass_ewc(Ewcs0, Fbs0, Env0, St0), - {Fs1,Fbs2,Env2,St2} = pass_ewc(Fs0, Fbs1, Env1, St1), - {[['progn'|Ecws1]|Fs1],Fbs2,Env2,St2}; -%% Do we want macros here??? -%% pass_ewc([['define-macro'|Def]=F|Fs0], Fbs0, Env0, St0) -> -%% case pass_define_macro(Def, Env0, St0) of -%% {yes,Env1,St1} -> pass_ewc(Fs0, Fbs0, Env1, St1); -%% {no,St1} -> -%% %% Ignore it and pass it on to generate error later. -%% {Fs1,Fbs1,Env1,St2} = pass_ewc(Fs0, Fbs0, Env0, St1), -%% {[F|Fs1],Fbs1,Env1,St2} -%% end; -pass_ewc([['define-function',Name,Def]=F|Fs0], Fbs0, Env0, St0) -> - case func_arity(Def) of - {yes,Ar} -> %Definition not too bad - Fb = {Name,Ar,Def}, - %% Env1 = lfe_eval:add_expr_func(Name, Ar, Def, Env0), - pass_ewc(Fs0, [Fb|Fbs0], Env0, St0); - no -> %Definition really bad - %% Ignore it and pass it on to generate error later. - {Fs1,Fbs1,Env1,St1} = pass_ewc(Fs0, Fbs0, Env0, St0), - {[F|Fs1],Fbs1,Env1,St1} +pass_ewc_form(['define-function',Name,Def]=F, Env0, St0) -> + case function_arity(Def) of + {yes,Ar} -> %Definition not too bad + Env1 = lfe_eval:add_dynamic_func(Name, Ar, Def, Env0), + Ret = ?IF(St0#mac.keep, F, [progn]), + {Ret,Env1,St0}; %Don't macro expand now + no -> %Definition really bad + St1 = add_error({bad_env_form,function}, St0), + {[progn],Env0,St1} %Just throw it away end; -pass_ewc([F|Fs0], Fbs0, Env0, St0) -> +pass_ewc_form([set|Args], Env, St) -> + pass_eval_set(Args, Env, St); +pass_ewc_form(F0, Env, St0) -> %% First expand enough to test top form, if so process again. - case pass_expand_expr(F, Env0, St0, false) of - {yes,Exp,St1} -> %Top form expanded - pass_ewc([Exp|Fs0], Fbs0, Env0, St1); - {no,F1,St1} -> %Not expanded - {Fs1,Fbs1,Env1,St2} = pass_ewc(Fs0, Fbs0, Env0, St1), - {[F1|Fs1],Fbs1,Env1,St2} - end; -pass_ewc([], Fbs, Env, St) -> {[],Fbs,Env,St}. + case pass_expand_expr(F0, Env, St0, false) of + {yes,F1,St1} -> %Top form expanded + pass_ewc_form(F1, Env, St1); + {no,F1,St1} -> %Not expanded + try + lfe_eval:expr(F1, Env), + {['progn'],Env,St1} %Ignore the value + catch + _:_ -> + {['progn'],Env,add_error({bad_env_form,expression}, St1)} + end + end. -func_arity([lambda,Args|_]) -> - case is_symb_list(Args) of - true -> {yes,length(Args)}; - false -> no - end; -func_arity(['match-lambda',[Pat|_]|_]) -> +function_arity([lambda,Args|_]) -> + ?IF(is_symb_list(Args), {yes,length(Args)}, no); +function_arity(['match-lambda',[Pat|_]|_]) -> case is_proper_list(Pat) of - true -> {yes,length(Pat)}; - false -> no + true -> {yes,length(Pat)}; + false -> no end; -func_arity(_) -> no. +function_arity(_) -> no. + +%% pass_eval_set(Args, Env, State) -> {Set,Env,State}. +%% Evaluate the set form. + +pass_eval_set(Args, Env, St) -> + try + pass_eval_set_1(Args, Env, St) + catch + _:_ -> %Catch everything + {[progn],Env,add_error({bad_env_form,'set'}, St)} + end. + +pass_eval_set_1(Args, Env, St0) -> + case exp_form(['let'|Args], Env, St0) of + {['let',Pat,G,Exp],St1} -> + pass_eval_set_1(Pat, [G], Exp, Env, St1); + {['let',Pat,Exp],St1} -> + pass_eval_set_1(Pat, [], Exp, Env, St1) + end. %Just crash here + +pass_eval_set_1(Pat, Guard, Exp, Env0, St) -> + Val = lfe_eval:expr(Exp, Env0), + {yes,_,Bs} = lfe_eval:match_when(Pat, Val, Guard, Env0), + Env1 = foldl(fun ({N,V}, E) -> add_vbinding(N, V, E) end, Env0, Bs), + Sets = ?IF(St#mac.keep, [ [set,N,V] || {N,V} <- Bs ], []), + %% Sets = case St#mac.keep of + %% true -> [ [set,N,V] || {N,V} <- Bs ]; + %% false -> [] + %% end, + {['progn'|Sets],Env1,St}. %% pass_expand_expr(Expr, Env, State, ExpandFlag) -> %% {yes,Exp,State} | {no,State}. -%% Try to macro expand Expr, catch errors and return them in State. -%% Only try to expand list expressions. +%% Try to macro expand Expr, catch errors and return them in State. +%% Only try to expand list expressions. pass_expand_expr([_|_]=E0, Env, St0, Expand) -> try - case exp_macro(E0, Env, St0) of - {yes,_,_}=Yes -> Yes; - no when Expand -> %Expand all if flag set. - {E1,St1} = exp_form(E0, Env, St0), - {no,E1,St1}; - no -> {no,E0,St0} - end + case exp_macro(E0, Env, St0) of + {yes,_,_}=Yes -> Yes; + no when Expand -> %Expand all if flag set. + {E1,St1} = exp_form(E0, Env, St0), + {no,E1,St1}; + no -> {no,E0,St0} + end catch - _:Error -> {no,E0,add_error(Error, St0)} + _:Error -> {no,E0,add_error(Error, St0)} end; pass_expand_expr(E, _, St, _) -> {no,E,St}. +%% pass_define_macro([Name,Def], Line, Env, State) -> +%% {yes,Env,State} | no. +%% Add the macro definition to the environment. We do a small format +%% check. + +pass_define_macro([Name,Def], Env, St) -> + case Def of + ['lambda'|_] -> {yes,add_mbinding(Name, Def, Env),St}; + ['match-lambda'|_] -> {yes,add_mbinding(Name, Def, Env),St}; + _ -> no + end. + %% add_error(Error, State) -> State. %% add_error(Line, Error, State) -> State. %% add_warning(Warning, State) -> State. @@ -294,69 +372,65 @@ %% add_warning(L, W, St) -> %% St#mac{warnings=St#mac.warnings ++ [{L,?MODULE,W}]}. -%% pass_define_macro([Name,Def], Line, Env, State) -> -%% {yes,Env,State} | {no,State}. -%% Add the macro definition to the environment. We do a small format -%% check. - -pass_define_macro([Name,Def], Env, St) -> - case Def of - ['lambda'|_] -> {yes,add_mbinding(Name, Def, Env),St}; - ['match-lambda'|_] -> {yes,add_mbinding(Name, Def, Env),St}; - _ -> {no,add_error({bad_form,macro}, St)} - end. - %% exp_form(Form, Env, State) -> {Form,State}. + %% Completely expand a form using expansions in Env and pre-defined %% macros. N.B. builtin core forms cannot be overidden and are -%% handled here first. The core forms also are particular about how -%% their bodies are to be expanded. +%% handled here first. Some core forms also are particular about how +%% their bodies are to be expanded and we handle these specially +%% here. The rest we just expand the tail at the end. -%% Known Core forms which cannot be overidden. +%% Known Core forms which need special handling. exp_form([quote,_]=Q, _, St) -> {Q,St}; exp_form([cons,H0,T0], Env, St0) -> {H1,St1} = exp_form(H0, Env, St0), {T1,St2} = exp_form(T0, Env, St1), {[cons,H1,T1],St2}; -exp_form([car,E0], Env, St0) -> %Catch these to prevent - {E1,St1} = exp_form(E0, Env, St0), %redefining them +exp_form([car,E0], Env, St0) -> %Catch these to prevent + {E1,St1} = exp_form(E0, Env, St0), %redefining them {[car,E1],St1}; exp_form([cdr,E0], Env, St0) -> {E1,St1} = exp_form(E0, Env, St0), {[cdr,E1],St1}; -exp_form([list|As0], Env, St0) -> - {As1,St1} = exp_tail(As0, Env, St0), - {[list|As1],St1}; -exp_form([tuple|As0], Env, St0) -> - {As1,St1} = exp_tail(As0, Env, St0), - {[tuple|As1],St1}; -exp_form([binary|As0], Env, St0) -> - {As1,St1} = exp_tail(As0, Env, St0), - {[binary|As1],St1}; -exp_form(['lambda',Head|B0], Env, St0) -> - {B1,St1} = exp_tail(B0, Env, St0), - {['lambda',Head|B1],St1}; +exp_form([list|As], Env, St) -> + exp_normal_core(list, As, Env, St); +exp_form([tuple|As], Env, St) -> + exp_normal_core(tuple, As, Env, St); +exp_form([binary|As], Env, St) -> + exp_normal_core(binary, As, Env, St); +exp_form([map|As], Env, St) -> + exp_normal_core(map, As, Env, St); +exp_form([mref|As], Env, St) -> + exp_normal_core(mref, As, Env, St); +exp_form([mset|As], Env, St) -> + exp_normal_core(mset, As, Env, St); +exp_form([mupd|As], Env, St) -> + exp_normal_core(mupd, As, Env, St); +exp_form(['map-get'|As], Env, St) -> + exp_normal_core('map-get', As, Env, St); +exp_form(['map-set'|As], Env, St) -> + exp_normal_core('map-set', As, Env, St); +exp_form(['map-update'|As], Env, St) -> + exp_normal_core('map-update', As, Env, St); +%% Core closure special forms. +exp_form([lambda,Head|B], Env, St) -> + exp_head_tail(lambda, Head, B, Env, St); exp_form(['match-lambda'|B0], Env, St0) -> {B1,St1} = exp_ml_clauses(B0, Env, St0), {['match-lambda'|B1],St1}; -exp_form(['let',Vbs0|B0], Env, St0) -> - %% We don't really have to syntax check very strongly here so we - %% can use normal clause expansion. Lint will catch errors. - {Vbs1,St1} = exp_clauses(Vbs0, Env, St0), - {B1,St2} = exp_tail(B0, Env, St1), - {['let',Vbs1|B1],St2}; +exp_form(['let',Vbs|B], Env, St) -> + exp_let(Vbs, B, Env, St); exp_form(['let-function',Fbs|B], Env, St) -> exp_let_function(Fbs, B, Env, St); exp_form(['letrec-function',Fbs|B], Env, St) -> exp_letrec_function(Fbs, B, Env, St); exp_form(['let-macro',Mbs|B], Env, St) -> exp_let_macro(Mbs, B, Env, St); -exp_form(['progn'|B0], Env, St0)-> - {B1,St1} = exp_tail(B0, Env, St0), - {['progn'|B1],St1}; -exp_form(['if'|B0], Env, St0) -> - {B1,St1} = exp_tail(B0, Env, St0), - {['if'|B1],St1}; +%% Core control special forms. +exp_form([progn|As], Env, St) -> + exp_normal_core(progn, As, Env, St); +exp_form(['if'|As], Env, St) -> + exp_normal_core('if', As, Env, St); exp_form(['case',E0|Cls0], Env, St0) -> {E1,St1} = exp_form(E0, Env, St0), {Cls1,St2} = exp_clauses(Cls0, Env, St1), @@ -369,29 +443,42 @@ {['catch'|B1],St1}; exp_form(['try',E|B], Env, St) -> exp_try(E, B, Env, St); -exp_form(['funcall'|As0], Env, St0) -> - {As1,St1} = exp_tail(As0, Env, St0), - {['funcall'|As1],St1}; -exp_form(['call'|As0], Env, St0) -> - {As1,St1} = exp_tail(As0, Env, St0), - {['call'|As1],St1}; -exp_form(['define-function',Head|B0], Env, St0) -> - %% Needs to be handled specially to protect Head. - {B1,St1} = exp_tail(B0, Env, St0), - {['define-function',Head|B1],St1}; +exp_form([funcall|As], Env, St) -> + exp_normal_core(funcall, As, Env, St); +exp_form([call|As], Env, St) -> + exp_normal_core(call, As, Env, St); +%% Core definition special forms. +exp_form(['eval-when-compile'|B], Env, St) -> + exp_normal_core('eval-when-compile', B, Env, St); +exp_form(['define-function',Head|B], Env, St) -> + exp_head_tail('define-function', Head, B, Env, St); +exp_form(['define-macro',Head|B], Env, St) -> + exp_head_tail('define-macro', Head, B, Env, St); +exp_form(['define-module',Head|B], Env, St) -> + exp_head_tail('define-module', Head, B, Env, St); +exp_form(['extend-module'|B], Env, St) -> + exp_normal_core('extend-module', B, Env, St); %% Now the case where we can have macros. exp_form([Fun|_]=Call, Env, St0) when is_atom(Fun) -> %% Expand top macro as much as possible. case exp_macro(Call, Env, St0) of - {yes,Exp,St1} -> exp_form(Exp, Env, St1); - no -> exp_tail(Call, Env, St0) + {yes,Exp,St1} -> exp_form(Exp, Env, St1); + no -> exp_tail(Call, Env, St0) end; -exp_form([_|_]=Call, Env, St) -> exp_tail(Call, Env, St); +exp_form([_|_]=Form, Env, St) -> exp_tail(Form, Env, St); exp_form(Tup, _, St) when is_tuple(Tup) -> %% Should we expand this? We assume implicit quote here. {Tup,St}; %% Everything else is atomic. -exp_form(F, _, St) -> {F,St}. %Atomic +exp_form(F, _, St) -> {F,St}. %Atomic + +exp_normal_core(Name, As0, Env, St0) -> + {As1,St1} = exp_tail(As0, Env, St0), + {[Name|As1],St1}. + +exp_head_tail(Name, Head, B0, Env, St0) -> + {B1,St1} = exp_tail(B0, Env, St0), + {[Name,Head|B1],St1}. %% exp_list(Exprs, Env, State) -> {Exps,State}. %% Expand a proper list of exprs. @@ -411,7 +498,7 @@ {Es1,St2} = exp_tail(Fun, Es0, Env, St1), {[E1|Es1],St2}; exp_tail(_, [], _, St) -> {[],St}; -exp_tail(Fun, E, Env, St) -> Fun(E, Env, St). %Same on improper tail. +exp_tail(Fun, E, Env, St) -> Fun(E, Env, St). %Same on improper tail. %% exp_clauses(Clauses, Env, State) -> {ExpCls,State}. %% exp_ml_clauses(Clauses, Env, State) -> {ExpCls,State}. @@ -448,38 +535,43 @@ {[Ps1|B1],St2}; exp_ml_clause(Other, Env, St) -> exp_form(Other, Env, St). +%% exp_let(VarBindings, Body, Env, State) -> {Expansion,State}. +%% We only do limited syntax checking here. + +exp_let(Vbs0, B0, Env, St0) -> + {Vbs1,St1} = exp_clauses(Vbs0, Env, St0), + {B1,St2} = exp_tail(B0, Env, St1), + {['let',Vbs1|B1],St2}. + %% exp_let_function(FuncBindings, Body, Env, State) -> {Expansion,State}. %% exp_letrec_function(FuncBindings, Body, Env, State) -> {Expansion,State}. -%% Expand a let/letrec-function. Here we are only interested in -%% marking functions as bound in the env and not what they are bound -%% to, we will not be calling them. We only want to shadow macros of -%% the same name. +%% Expand a let/letrec-function. We do add them to the environment as +%% they might be used when expanding macros. exp_let_function(Fbs0, B0, Env, St0) -> - {Fbs1,B1,St1} = do_exp_let_function(Fbs0, B0, Env, St0), + {Fbs1,B1,St1} = do_exp_let_function('let-function', Fbs0, B0, Env, St0), {['let-function',Fbs1|B1],St1}. exp_letrec_function(Fbs0, B0, Env, St0) -> - {Fbs1,B1,St1} = do_exp_let_function(Fbs0, B0, Env, St0), + {Fbs1,B1,St1} = do_exp_let_function('letrec-function', Fbs0, B0, Env, St0), {['letrec-function',Fbs1|B1],St1}. -do_exp_let_function(Fbs0, B0, Env0, St0) -> +do_exp_let_function(Type, Fbs0, B0, Env0, St0) -> %% Only very limited syntax checking here (see above). - Env1 = foldl(fun ([V,['lambda',Args|_]], Env) when is_atom(V) -> - case is_proper_list(Args) of - true -> add_fbinding(V, length(Args), dummy, Env); - false -> Env - end; - ([V,['match-lambda',[Pats|_]|_]], Env) when is_atom(V) -> - case is_proper_list(Pats) of - true -> add_fbinding(V, length(Pats), dummy, Env); - false -> Env - end; - (_, Env) -> Env - end, Env0, Fbs0), - {Fbs1,St1} = exp_clauses(Fbs0, Env1, St0), - {B1,St2} = exp_tail(B0, Env1, St1), - {Fbs1,B1,St2}. + Efun = fun ([V,Def], {Env,St}) when is_atom(V) -> + case function_arity(Def) of + {yes,Ar} -> + {lfe_eval:add_dynamic_func(V, Ar, Def, Env),St}; + no -> + {Env,add_error(St#mac.line, {bad_form,Type}, St)} + end; + (_, {Env,St}) -> + {Env,add_error(St#mac.line, {bad_form,Type}, St)} + end, + {Env1,St1} = foldl(Efun, {Env0,St0}, Fbs0), + {Fbs1,St2} = exp_clauses(Fbs0, Env1, St1), + {B1,St3} = exp_tail(B0, Env1, St2), + {Fbs1,B1,St3}. %% exp_let_macro(MacroBindings, Body, Env, State) -> {Expansion,State}. %% Expand a let_syntax. We add the actual macro binding to the env as @@ -488,27 +580,27 @@ exp_let_macro(Mbs, B0, Env0, St0) -> %% Add the macro defs from expansion and return body in a progn. Env1 = foldl(fun ([Name,['lambda'|_]=Def], Env) when is_atom(Name) -> - add_mbinding(Name, Def, Env); - ([Name,['match-lambda'|_]=Def], Env) when is_atom(Name) -> - add_mbinding(Name, Def, Env); - (_, Env) -> Env %Ignore mistakes - end, Env0, Mbs), - {B1,St1} = exp_tail(B0, Env1, St0), %Expand the body + add_mbinding(Name, Def, Env); + ([Name,['match-lambda'|_]=Def], Env) when is_atom(Name) -> + add_mbinding(Name, Def, Env); + (_, Env) -> Env %Ignore mistakes + end, Env0, Mbs), + {B1,St1} = exp_tail(B0, Env1, St0), %Expand the body {['progn'|B1],St1}. exp_try(E0, B0, Env, St0) -> {E1,St1} = exp_form(E0, Env, St0), {B1,St2} = exp_tail(fun (['case'|Cls0], E, Sta) -> - {Cls1,Stb} = exp_clauses(Cls0, E, Sta), - {['case'|Cls1],Stb}; - (['catch'|Cls0], E, Sta) -> - {Cls1,Stb} = exp_clauses(Cls0, E, Sta), - {['catch'|Cls1],Stb}; - (['after'|A0], E, Sta) -> - {A1,Stb} = exp_tail(A0, E, Sta), - {['after'|A1],Stb}; - (Other, _, St) -> {Other,St} - end, B0, Env, St1), + {Cls1,Stb} = exp_clauses(Cls0, E, Sta), + {['case'|Cls1],Stb}; + (['catch'|Cls0], E, Sta) -> + {Cls1,Stb} = exp_clauses(Cls0, E, Sta), + {['catch'|Cls1],Stb}; + (['after'|A0], E, Sta) -> + {A1,Stb} = exp_tail(A0, E, Sta), + {['after'|A1],Stb}; + (Other, _, St) -> {Other,St} + end, B0, Env, St1), {['try',E1|B1],St2}. %% exp_macro(Call, Env, State) -> {yes,Exp,State} | no. @@ -516,16 +608,16 @@ exp_macro([Name|_]=Call, Env, St) -> case lfe_lib:is_core_form(Name) of - true -> no; %Never expand core forms - false -> - case get_mbinding(Name, Env) of - {yes,Def} -> - %% User macro bindings. - exp_userdef_macro(Call, Def, Env, St); - no -> - %% Default macro bindings. - exp_predef_macro(Call, Env, St) - end + true -> no; %Never expand core forms + false -> + case get_mbinding(Name, Env) of + {yes,Def} -> + %% User macro bindings. + exp_userdef_macro(Call, Def, Env, St); + no -> + %% Default macro bindings. + exp_predef_macro(Call, Env, St) + end end. %% exp_userdef_macro(Call, Def, Env, State) -> {yes,Exp,State}. @@ -537,13 +629,21 @@ %%lfe_io:format("udef: ~p\n", [[Mac|Args]]), %%lfe_io:format("macro: ~p\n", [Def0]), try - {Def1,St1} = exp_form(Def0, Env, St0), %Expand definition - Exp = lfe_eval:apply(Def1, [Args,Env], Env), - {yes,Exp,St1} + {Def1,St1} = exp_form(Def0, Env, St0), %Expand definition + Exp = lfe_eval:apply(Def1, [Args,Env], Env), + {yes,Exp,St1} catch - error:Error -> - Stack = erlang:get_stacktrace(), - erlang:error({expand_macro,[Mac|Args],{Error,Stack}}) + %% error:no_Error -> boom + %% error:Error -> + %% Stack = erlang:get_stacktrace(), + %% erlang:error({expand_macro,[Mac|Args],{Error,Stack}}) + error:Error -> + Stack = erlang:get_stacktrace(), + erlang:raise(error, {expand_macro,[Mac|Args],Error}, Stack) + %% error:Error -> + %% Stack0 = erlang:get_stacktrace(), + %% Stack1 = trim_stacktrace(Stack0), + %% erlang:error({expand_macro,[Mac|Args],{Error,Stack1}}) end. %% exp_predef_macro(Call, Env, State) -> {yes,Exp,State} | no. @@ -554,16 +654,28 @@ try exp_predef(Call, Env, St) catch + %% error:Error -> + %% Stack = erlang:get_stacktrace(), + %% erlang:raise({expand_macro,Call,{Error,Stack}}) error:Error -> Stack = erlang:get_stacktrace(), - erlang:error({expand_macro,Call,{Error,Stack}}) + erlang:raise(error, {expand_macro,Call,Error}, Stack) + %% error:Error -> + %% Stack0 = erlang:get_stacktrace(), + %% Stack1 = trim_stacktrace(Stack0), + %% erlang:error({expand_macro,Call,{Error,Stack1}}) end. +trim_stacktrace([{lfe_macro,_,_,_}=S|_]) -> [S]; %R15 and later +trim_stacktrace([{lfe_macro,_,_}|_]=S) -> [S]; %Pre R15 +trim_stacktrace([S|Stk]) -> [S|trim_stacktrace(Stk)]; +trim_stacktrace([]) -> []. + %% exp_predef(Form, Env, State) -> {yes,Form,State} | no. -%% Handle the builtin predefined macros but only one at top-level and -%% only once. Expand must be called on result to fully expand -%% macro. This is basically doing exactly the same as if they were -%% user defined. +%% Expand the built-in predefined macros completely at top-level +%% without returning a new predefined top-level macro. This make the +%% macros "safe" even if they have been redefined as it is this +%% definition which is used. %% Builtin default macro expansions. exp_predef([caar,E], _, St) -> {yes,[car,[car,E]],St}; @@ -628,18 +740,19 @@ {Exp,St1} = exp_arith(Es, '/', St0), {yes,Exp,St1} end; -exp_predef([Op|Es], _, St0) %Logical operators +%% Comparison operators. +exp_predef(['!='|Es], Env, St) -> exp_predef(['/='|Es], Env, St); +exp_predef(['==='|Es], Env, St) -> exp_predef(['=:='|Es], Env, St); +exp_predef(['!=='|Es], Env, St) -> exp_predef(['=/='|Es], Env, St); +exp_predef([Op|Es], _, St0) when Op == '/=' ; Op == '=/=' -> + {Exp,St1} = exp_nequal(Es, Op, St0), + {yes,Exp,St1}; +exp_predef([Op|Es], _, St0) when Op == '>'; Op == '>='; Op == '<'; Op == '=<'; - Op == '=='; Op == '/='; Op == '!='; Op == '=:='; Op == '==='; Op == '=/='; Op == '!==' -> - case Op of - '!=' -> EOp = '/='; - '===' -> EOp = '=:='; - '!==' -> EOp = '=/='; - _ -> EOp = Op - end, + Op == '=='; Op == '=:=' -> case Es of [_|_] -> - {Exp,St1} = exp_comp(Es, EOp, St0), + {Exp,St1} = exp_comp(Es, Op, St0), {yes,Exp,St1} end; exp_predef([backquote,Bq], _, St) -> %We do this here. @@ -647,47 +760,28 @@ exp_predef(['++'|Abody], _, St) -> Exp = exp_append(Abody), {yes,Exp,St}; -exp_predef([':',M,F|As], _, St) -> - {yes,['call',?Q(M),?Q(F)|As], St}; +exp_predef(['++*'|Abody], _, St) -> + Exp = exp_prefix(Abody), + {yes,Exp,St}; exp_predef(['?'|As], _, St) -> + Omega = [omega,omega], Exp = case As of - [To,Def] -> ['receive',['omega','omega'],['after',To,Def]]; - [To] -> ['?',To,[exit,?Q(timeout)]]; - [] -> ['receive',['omega','omega']] + [To,Def] -> ['receive',Omega,['after',To,Def]]; + [To] -> ['receive',Omega,['after',To,[exit,?Q(timeout)]]]; + [] -> ['receive',Omega] end, {yes,Exp, St}; exp_predef(['list*'|As], _, St) -> - Exp = case As of - [E] -> E; - [E|Es] -> [cons,E,['list*'|Es]]; - [] -> [] - end, + Exp = exp_list_star(As), {yes,Exp,St}; exp_predef(['let*'|Lbody], _, St) -> - 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, + Exp = exp_let_star(Lbody), {yes,Exp,St}; exp_predef(['flet*'|Lbody], _, St) -> - Exp = case Lbody of - [[Fb|Fbs]|B] -> ['flet',[Fb],['flet*',Fbs|B]]; - [[]|B] -> ['progn'|B]; - [Fb|B] -> ['flet',Fb|B] %Pass error to flet for lint. - end, + Exp = exp_flet_star(Lbody), {yes,Exp,St}; exp_predef(['cond'|Cbody], _, St) -> - 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, + Exp = exp_cond(Cbody), {yes,Exp,St}; exp_predef(['do'|Dbody], _, St0) -> %% (do ((v i c) ...) (test val) . body) but of limited use as it @@ -708,27 +802,25 @@ {Exp,St1} = lc_te(Es, Qs, St0), {yes,Exp,St1}; %% Add an alias for lc. -exp_predef(['list-comp'|Lbody], _, St) -> {yes,[lc|Lbody],St}; +exp_predef(['list-comp'|Lbody], _, St0) -> + [Qs|Es] = Lbody, + {Exp,St1} = lc_te(Es, Qs, St0), + {yes,Exp,St1}; exp_predef([bc|Bbody], _, St0) -> %% (bc (qual ...) e ...) [Qs|Es] = Bbody, {Exp,St1} = bc_te(Es, Qs, St0), {yes,Exp,St1}; %% Add an alias for bc. -exp_predef(['binary-comp'|Lbody], _, St) -> {yes,[bc|Lbody],St}; +exp_predef(['binary-comp'|Bbody], _, St0) -> + [Qs|Es] = Bbody, + {Exp,St1} = bc_te(Es, Qs, St0), + {yes,Exp,St1}; exp_predef(['andalso'|Abody], _, St) -> - Exp = case Abody of - [E] -> E; %Let user check last call - [E|Es] -> ['if',E,['andalso'|Es],?Q(false)]; - [] -> ?Q(true) - end, + Exp = exp_andalso(Abody), {yes,Exp,St}; exp_predef(['orelse'|Obody], _, St) -> - Exp = case Obody of - [E] -> E; %Let user check last call - [E|Es] -> ['if',E,?Q(true),['orelse'|Es]]; - [] -> ?Q(false) - end, + Exp = exp_orelse(Obody), {yes,Exp,St}; %% The fun forms assume M, F and Ar are atoms and integer. exp_predef(['fun',F,Ar], _, St0) -> @@ -798,13 +890,16 @@ Mdefs = map(fun ([Name|Rules]) -> exp_rules(Name, [], Rules) end, Defs), {yes,['let-macro',Mdefs|Body],St}; exp_predef([prog1|Body], _, St0) -> + %% We do a simple optimisation here. + case Body of %Catch bad form here + [Expr] -> {yes,Expr,St0}; + [First|Rest] -> + {V,St1} = new_symb(St0), + {yes,['let',[[V,First]]|Rest ++ [V]],St1} + end; +exp_predef([prog2|Body], _, St) -> [First|Rest] = Body, %Catch bad form here - {V,St1} = new_symb(St0), - {yes,['let',[[V,First]]|Rest ++ [V]],St1}; -exp_predef([prog2|Body], _, St0) -> - [First,Second|Rest] = Body, %Catch bad form here - {V,St1} = new_symb(St0), - {yes,['let',[[V,[progn,First,Second]]]|Rest ++ [V]],St1}; + {yes,[progn,First,[prog1|Rest]],St}; %% This has to go here for the time being so as to be able to macro %% expand body. exp_predef(['match-spec'|Body], Env, St0) -> @@ -820,15 +915,58 @@ {yes,?Q(St#mac.module),St}; exp_predef(['LINE'], _, St) -> {yes,?Q(St#mac.line),St}; +exp_predef([':',M,F|As], Env, St0) when is_atom(M), is_atom(F) -> + case exp_call_macro(M, F, As, Env, St0) of + {yes,_,_}=Yes -> Yes; %{yes,Exp,St} + {no,St1} -> %Use the default expansion + {yes,['call',?Q(M),?Q(F)|As], St1} + end; +exp_predef([':',M,F|As], _, St) -> + %% Catch the other junk here. + {yes,['call',?Q(M),?Q(F)|As], St}; exp_predef([Fun|As], _, St) when is_atom(Fun) -> case string:tokens(atom_to_list(Fun), ":") of [M,F] -> - {yes,[call,?Q(list_to_atom(M)),?Q(list_to_atom(F))|As],St}; + {yes,[':',list_to_atom(M),list_to_atom(F)|As],St}; _ -> no %This will also catch a:b:c end; %% This was not a call to a predefined macro. exp_predef(_, _, _) -> no. +%% exp_call_macro(Module, Name, Args, Env, State) -> +%% {yes,From,State} | {no,State}. +%% Expand macro in Module if it exists. Try to be smart and avoid +%% loading a module, and trying to load a module, unneccessarily. + +exp_call_macro(M, F, As, Env, St) -> + case erlang:function_exported(M, 'LFE-EXPAND-EXPORTED-MACRO', 3) of + true -> + case M:'LFE-EXPAND-EXPORTED-MACRO'(F, As, Env) of + {yes,Exp} -> {yes,Exp,St}; + no -> {no,St} + end; + false -> + %% Slightly faster code:ensure_loaded/1. + case erlang:module_loaded(M) of + true -> {no,St}; %Module loaded but no macros + false -> + Unl = St#mac.unloadable, + case lists:member(M, Unl) of + true -> {no,St}; %Can't load this module + false -> + %% Try loading file and try again. + case code:load_file(M) of + {module,_} -> exp_call_macro(M, F, As, Env, St); + {error,_} -> + %% Echo modules we couldn't load + lfe_io:format("ecp: ~p\n", [{M,Unl}]), + St1 = St#mac{unloadable=[M|Unl]}, + {no,St1} + end + end + end + end. + %% exp_qlc(LC, Opts, Env, State) -> {yes,Expansion,State}. %% Expand a Query List Comprehension returning a call to qlc:q/2. We %% first convert the LC into vanilla erlang AST, expand it using in @@ -840,17 +978,17 @@ %% structure. {Eqs,St1} = exp_qlc_quals(Qs, Env, St0), {Ees,St2} = exp_list(Es, Env, St1), - %%lfe_io:format("Q0 = ~p\n", [[lc,Eqs|Ees]]), + %% lfe_io:format("Q0 = ~p\n", [[lc,Eqs|Ees]]), %% Now translate to vanilla AST, call qlc expand and then convert %% back to LFE. lfe_qlc:expand/2 wants a list of conversions not %% a conversion of a list. Vlc = lfe_trans:to_expr([lc,Eqs|Ees], 42), Vos = map(fun (O) -> lfe_trans:to_expr(O, 42) end, Opts), - %% io:put_chars([erl_pp:expr(Vlc),"\n"]), + %% io:put_chars(["E0 = ",erl_pp:expr(Vlc, 5, []),"\n"]), {ok,Vexp} = lfe_qlc:expand(Vlc, Vos), - %%io:put_chars([erl_pp:expr(Vexp),"\n"]), + %% io:put_chars([erl_pp:expr(Vexp),"\n"]), Exp = lfe_trans:from_expr(Vexp), - %%lfe_io:format("Q1 = ~p\n", [Exp]), + %% lfe_io:format("Q1 = ~p\n", [Exp]), {yes,Exp,St2}. exp_qlc_quals(Qs, Env, St) -> @@ -872,37 +1010,56 @@ exp_bif(B, As) -> [call,?Q(erlang),?Q(B)|As]. %% exp_args(Args, State) -> {LetBinds,State}. -%% Expand Args into a list of let bindings suitable for a let* or -%% nested lets to force sequential left-to-right evaluation. +%% Expand Args into a list of let bindings suitable for a let* or +%% nested lets to force sequential left-to-right evaluation. exp_args(As, St) -> mapfoldl(fun (A, St0) -> {V,St1} = new_symb(St0), {[V,A],St1} end, St, As). %% exp_arith(Args, Op, State) -> {Exp,State}. -%% Expand arithmetic call strictly forcing evaluation of all -%% arguments. Note that single argument version may need special -%% casing. +%% Expand arithmetic call strictly forcing evaluation of all +%% arguments. Note that single argument version may need special +%% casing. exp_arith([A], Op, St) -> {exp_bif(Op, [A]),St}; exp_arith([A,B], Op, St) -> {exp_bif(Op, [A,B]),St}; exp_arith(As, Op, St0) -> {Ls,St1} = exp_args(As, St0), B = foldl(fun ([V,_], Acc) -> exp_bif(Op, [Acc,V]) end, hd(hd(Ls)), tl(Ls)), - {['let*',Ls,B],St1}. + {exp_let_star([Ls,B]),St1}. %% exp_comp(Args, Op, State) -> {Exp,State}. -%% Expand comparison test strictly forcing evaluation of all -%% arguments. Note that single argument version may need special -%% casing. +%% Expand comparison test strictly forcing evaluation of all +%% arguments. Note that single argument version may need special +%% casing. exp_comp([A], _, St) -> %Force evaluation - {['let',[['_',A]],?Q(true)],St}; + {[progn,A,?Q(true)],St}; exp_comp([A,B], Op, St) -> {exp_bif(Op, [A,B]),St}; exp_comp(As, Op, St0) -> {Ls,St1} = exp_args(As, St0), - {Ts,_} = mapfoldl(fun ([V,_], Acc) -> {exp_bif(Op, [Acc,V]),V} end, - hd(hd(Ls)), tl(Ls)), - {['let*',Ls,['andalso'|Ts]],St1}. + Ts = op_pairs(Ls, Op), + {exp_let_star([Ls,exp_andalso(Ts)]),St1}. + +op_pairs([[V,_]|Ls], Op) -> + element(1, mapfoldl(fun ([V,_], Acc) -> {exp_bif(Op, [Acc,V]),V} end, + V, Ls)). + +%% exp_nequal(Args, Op, State) -> {Exp,State}. +%% Expand not equal test strictly forcing evaluation of all +%% arguments. We need to compare all the arguments with each other. + +exp_nequal([A], _, St) -> %Force evaluation + {[progn,A,?Q(true)],St}; +exp_nequal([A,B], Op, St) -> {exp_bif(Op, [A,B]),St}; +exp_nequal(As, Op, St0) -> + {Ls,St1} = exp_args(As, St0), + Ts = op_all_pairs(Ls, Op), + {exp_let_star([Ls,exp_andalso(Ts)]),St1}. + +op_all_pairs([], _) -> []; +op_all_pairs([[V,_]|Ls], Op) -> + [ exp_bif(Op, [V,V1]) || [V1,_] <- Ls] ++ op_all_pairs(Ls, Op). %% exp_append(Args) -> Expansion. %% Expand ++ in such a way as to allow its use in patterns. There are @@ -910,24 +1067,85 @@ exp_append(Args) -> case Args of - %% Cases with quoted lists. - [?Q([A|As])|Es] -> [cons,?Q(A),['++',?Q(As)|Es]]; - [?Q([])|Es] -> ['++'|Es]; - %% Cases with explicit cons/list/list*. - [['list*',A]|Es] -> ['++',A|Es]; - [['list*',A|As]|Es] -> [cons,A,['++',['list*'|As]|Es]]; - [[list,A|As]|Es] -> [cons,A,['++',[list|As]|Es]]; - [[list]|Es] -> ['++'|Es]; - [[cons,H,T]|Es] -> [cons,H,['++',T|Es]]; - [[]|Es] -> ['++'|Es]; - %% Cases with lists of numbers (strings). - [[N|Ns]|Es] when is_number(N) -> [cons,N,['++',Ns|Es]]; - %% Default cases with unquoted arg. - [E] -> E; %Last arg not checked - [E|Es] -> exp_bif('++', [E,['++'|Es]]); - [] -> [] + %% Cases with quoted lists. + [?Q([A|As])|Es] -> [cons,?Q(A),exp_append([?Q(As)|Es])]; + [?Q([])|Es] -> exp_append(Es); + %% Cases with explicit cons/list/list*. + [['list*',A]|Es] -> exp_append([A|Es]); + [['list*',A|As]|Es] -> [cons,A,exp_append([['list*'|As]|Es])]; + [[list,A|As]|Es] -> [cons,A,exp_append([[list|As]|Es])]; + [[list]|Es] -> exp_append(Es); + [[cons,H,T]|Es] -> [cons,H,exp_append([T|Es])]; + [[]|Es] -> exp_append(Es); + %% Cases with lists of numbers (strings). + %% [[N|Ns]|Es] when is_number(N) -> [cons,N,exp_append([Ns|Es])]; + %% Default cases with unquoted arg. + [E] -> E; %Last arg not checked + [E|Es] -> exp_bif('++', [E,exp_append(Es)]); + [] -> [] end. +%% exp_prefix(Args) -> Expansion. +%% Expand ++* in such a way as to allow its use in patterns. +%% Handle lists of numbers (strings) explicitly, otherwise +%% default to exp_append/1. + +exp_prefix([['list*',A]|Es]) -> exp_prefix([A|Es]); +exp_prefix([['list*',A|As]|Es]) -> [cons,A,exp_prefix([['list*'|As]|Es])]; +exp_prefix([[list,A|As]|Es]) -> [cons,A,exp_prefix([[list|As]|Es])]; +exp_prefix([[list]|Es]) -> exp_prefix(Es); +exp_prefix([[cons,H,T]|Es]) -> [cons,H,exp_prefix([T|Es])]; +exp_prefix([[N|Ns]|Es]) when is_number(N) -> [cons,N,exp_prefix([Ns|Es])]; +exp_prefix([[]|Es]) -> exp_prefix(Es); +exp_prefix(Args) -> exp_append(Args). + +%% exp_list_star(ListBody) -> Cons. + +exp_list_star([E]) -> E; +exp_list_star([E|Es]) -> + [cons,E,exp_list_star(Es)]; +exp_list_star([]) -> []. + +%% exp_let_star(FletBody) -> Flets. + +exp_let_star([[Vb|Vbs]|B]) -> + ['let',[Vb],exp_let_star([Vbs|B])]; +exp_let_star([[]|B]) -> [progn|B]; +exp_let_star([Vb|B]) -> ['let',Vb|B]. %Pass error to let for lint. + +%% exp_flet_star(FletBody) -> Flets. + +exp_flet_star([[Fb|Fbs]|B]) -> + [flet,[Fb],exp_flet_star([Fbs|B])]; +exp_flet_star([[]|B]) -> [progn|B]; +exp_flet_star([Fb|B]) -> [flet,Fb|B]. %Pass error to flet for lint + +%% exp_cond(CondBody) -> Tests. +%% Expand a cond body to a sequence of if/case tests. + +exp_cond([['else'|B]]) -> [progn|B]; +exp_cond([[['?=',P,E]|B]|Cond]) -> + ['case',E,[P|B],['_',exp_cond(Cond)]]; +exp_cond([[['?=',P,['when'|_]=G,E]|B]|Cond]) -> + ['case',E,[P,G|B],['_',exp_cond(Cond)]]; +exp_cond([[Test|B]|Cond]) -> %Test and body + ['if',Test,[progn|B],exp_cond(Cond)]; +exp_cond([Test|Cond]) -> %Naked test + ['if',Test,?Q(true),exp_cond(Cond)]; +exp_cond([]) -> ?Q(false). + +%% exp_andalso(AndAlsoBody) -> Ifs. +%% exp_orelse(OrElseBody) -> Ifs. + +exp_andalso([E]) -> E; %Let user check last call +exp_andalso([E|Es]) -> + ['if',E,exp_andalso(Es),?Q(false)]; +exp_andalso([]) -> ?Q(true). + +exp_orelse([E]) -> E; %Let user check last call +exp_orelse([E|Es]) -> ['if',E,?Q(true),exp_orelse(Es)]; +exp_orelse([]) -> ?Q(false). + %% exp_defun(Name, Def) -> Lambda | Match-Lambda. %% Educated guess whether traditional (defun name (a1 a2 ...) ...) %% or matching (defun name (patlist1 ...) (patlist2 ...)) @@ -1048,37 +1266,48 @@ %% exp_backquote(Exp) -> Exp. %% Not very efficient quasiquote expander, but very compact code. Is -%% R6RS compliant and can handle unquote and unquote-splicing with -%% more than one argument properly. Actually with simple cons/append -%% optimisers code now quite good. +%% R6RS compliant and can handle comma (unquote) and comma-at +%% (unquote-splicing) with more than one argument properly. Actually +%% with simple cons/append optimisers code now quite good. exp_backquote(Exp) -> exp_backquote(Exp, 0). exp_backquote([backquote,X], N) -> [list,[quote,backquote],exp_backquote(X, N+1)]; -exp_backquote([unquote|X], N) when N > 0 -> - exp_bq_cons([quote,unquote], exp_backquote(X, N-1)); -exp_backquote([unquote,X], 0) -> X; -exp_backquote(['unquote-splicing'|X], N) when N > 0 -> - exp_bq_cons([quote,'unquote-splicing'], exp_backquote(X, N-1)); +exp_backquote([comma|X], N) when N > 0 -> + exp_bq_cons([quote,comma], exp_backquote(X, N-1)); +exp_backquote([comma,X], 0) -> X; +exp_backquote(['comma-at'|X], N) when N > 0 -> + exp_bq_cons([quote,'comma-at'], exp_backquote(X, N-1)); %% Next 2 handle case of splicing into a list. -exp_backquote([[unquote|X]|Y], 0) -> +exp_backquote([[comma|X]|Y], 0) -> exp_bq_append([list|X], exp_backquote(Y, 0)); -exp_backquote([['unquote-splicing'|X]|Y], 0) -> +exp_backquote([['comma-at'|X]|Y], 0) -> exp_bq_append(['++'|X], exp_backquote(Y, 0)); -exp_backquote([X|Y], N) -> %The general list case +exp_backquote([X|Y], N) -> %The general list case exp_bq_cons(exp_backquote(X, N), exp_backquote(Y, N)); exp_backquote(X, N) when is_tuple(X) -> - %% Straight [list_to_tuple,exp_backquote(tuple_to_list(X), N)] inefficient - %% and [tuple|tl(exp_backquote(tuple_to_list(X), N))] can't handle splicing! + %% Straight [list_to_tuple,exp_backquote(tuple_to_list(X), N)] + %% inefficient and [tuple|tl(exp_backquote(tuple_to_list(X), N))] + %% can't handle splicing! case exp_backquote(tuple_to_list(X), N) of - [list|Es] -> [tuple|Es]; %No splicing - [cons|_]=E -> [list_to_tuple,E] %Have splicing + [list|Es] -> [tuple|Es]; %No splicing + [cons|_]=E -> [list_to_tuple,E]; %Have splicing + [] -> [tuple] %The empty tuple + end; +exp_backquote(X, N) when ?IS_MAP(X) -> + %% Splicing at top-level almost meaningless here, with [list|...] + %% we have no splicing, while with [cons|...] we have splicing + case exp_bq_map_pairs(maps:to_list(X), N) of + [list|KVs] -> [map|KVs]; %No splicing + %% [cons|_]=E -> %Have splicing + %% [call,?Q(maps),?Q(from_list)|E]; + [] -> [map] %The empty map end; exp_backquote(X, _) when is_atom(X) -> [quote,X]; -exp_backquote(X, _) -> X. %Self quoting +exp_backquote(X, _) -> X. %Self quoting -exp_bq_append(['++',L], R) -> %Catch single unquote-splice +exp_bq_append(['++',L], R) -> %Catch single comma-at exp_bq_append(L, R); exp_bq_append([], R) -> R; exp_bq_append(L, []) -> L; @@ -1094,6 +1323,14 @@ exp_bq_cons(L, []) -> [list,L]; exp_bq_cons(L, R) -> [cons,L,R]. +-ifdef(HAS_MAPS). +exp_bq_map_pairs(Ps, N) -> + KVs = foldr(fun ({K,V}, Acc) -> [K,V|Acc] end, [], Ps), + exp_backquote(KVs, N). +-else. +exp_bq_map_pairs(_, _) -> [list]. +-endif. + new_symb(St) -> C = St#mac.vc, {list_to_atom("|-" ++ integer_to_list(C) ++ "-|"),St#mac{vc=C+1}}. @@ -1134,32 +1371,32 @@ mbe_match_pat([quote,P], E, _) -> P =:= E; mbe_match_pat([tuple|Ps], [tuple|Es], Ks) -> %Match tuple constructor mbe_match_pat(Ps, Es, Ks); -mbe_match_pat([tuple|Ps], E, Ks) -> %Match literal tuple +mbe_match_pat([tuple|Ps], E, Ks) -> %Match literal tuple case is_tuple(E) of - true -> mbe_match_pat(Ps, tuple_to_list(E), Ks); - false -> false + true -> mbe_match_pat(Ps, tuple_to_list(E), Ks); + false -> false end; mbe_match_pat(?mbe_ellipsis(Pcar, _), E, Ks) -> case is_proper_list(E) of - true -> - all(fun (X) -> mbe_match_pat(Pcar, X, Ks) end, E); - false -> false + true -> + all(fun (X) -> mbe_match_pat(Pcar, X, Ks) end, E); + false -> false end; mbe_match_pat([Pcar|Pcdr], E, Ks) -> case E of - [Ecar|Ecdr] -> - mbe_match_pat(Pcar, Ecar, Ks) andalso - mbe_match_pat(Pcdr, Ecdr, Ks); - _ -> false + [Ecar|Ecdr] -> + mbe_match_pat(Pcar, Ecar, Ks) andalso + mbe_match_pat(Pcdr, Ecdr, Ks); + _ -> false end; mbe_match_pat(Pat, E, Ks) -> case is_mbe_symbol(Pat) of - true -> - case member(Pat, Ks) of - true -> Pat =:= E; - false -> true - end; - false -> Pat =:= E + true -> + case member(Pat, Ks) of + true -> Pat =:= E; + false -> true + end; + false -> Pat =:= E end. mbe_get_ellipsis_nestings(Pat, Ks) -> @@ -1173,12 +1410,12 @@ m_g_e_n(Pcar, Ks) ++ m_g_e_n(Pcdr, Ks); m_g_e_n(Pat, Ks) -> case is_mbe_symbol(Pat) of - true -> - case member(Pat, Ks) of - true -> []; - false -> [Pat] - end; - false -> [] + true -> + case member(Pat, Ks) of + true -> []; + false -> [Pat] + end; + false -> [] end. mbe_ellipsis_sub_envs(Nestings, R) -> @@ -1191,18 +1428,18 @@ %% Return first value of F applied to elements in list which is not false. ormap(F, [H|T]) -> case F(H) of - false -> ormap(F, T); - V -> V + false -> ormap(F, T); + V -> V end; ormap(_, []) -> false. mbe_intersect(V, Y) -> case is_mbe_symbol(V) orelse is_mbe_symbol(Y) of - true -> V =:= Y; - false -> - any(fun (V0) -> - any(fun (Y0) -> mbe_intersect(V0, Y0) end, Y) - end, V) + true -> V =:= Y; + false -> + any(fun (V0) -> + any(fun (Y0) -> mbe_intersect(V0, Y0) end, Y) + end, V) end. %% mbe_get_bindings(Pattern, Expression, Keywords) -> Bindings. @@ -1217,15 +1454,15 @@ map(fun (X) -> mbe_get_bindings(Pcar, X, Ks) end, E)]]; mbe_get_bindings([Pcar|Pcdr], [Ecar|Ecdr], Ks) -> mbe_get_bindings(Pcar, Ecar, Ks) ++ - mbe_get_bindings(Pcdr, Ecdr, Ks); + mbe_get_bindings(Pcdr, Ecdr, Ks); mbe_get_bindings(Pat, E, Ks) -> case is_mbe_symbol(Pat) of - true -> - case member(Pat, Ks) of - true -> []; - false -> [[Pat|E]] - end; - false -> [] + true -> + case member(Pat, Ks) of + true -> []; + false -> [[Pat|E]] + end; + false -> [] end. %% mbe_expand_pattern(Pattern, Bindings, Keywords) -> Form. @@ -1244,16 +1481,16 @@ mbe_expand_pattern(Pcdr, R, Ks)]; mbe_expand_pattern(Pat, R, Ks) -> case is_mbe_symbol(Pat) of - true -> - case member(Pat, Ks) of - true -> Pat; - false -> - case lfe_lib:assoc(Pat, R) of - [_|Cdr] -> Cdr; - [] -> Pat - end - end; - false -> Pat + true -> + case member(Pat, Ks) of + true -> Pat; + false -> + case lfe_lib:assoc(Pat, R) of + [_|Cdr] -> Cdr; + [] -> Pat + end + end; + false -> Pat end. %% mbe_syntax_rules_proc(Name, Keywords, Rules, Argsym, Keywordsym) -> @@ -1268,34 +1505,35 @@ %% Don't prepend the macro name to the arguments! ['let',[[Ksym,[quote,Ks]]], ['cond'] ++ - map(fun (C) -> - Inpat = hd(C), - Outpat = hd(tl(C)), - [[':',lfe_macro,mbe_match_pat,[quote,Inpat], Argsym, Ksym], - ['let', - [[r,[':',lfe_macro,mbe_get_bindings, - [quote,Inpat],Argsym,Ksym]]], - [':',lfe_macro,mbe_expand_pattern,[quote,Outpat],r,Ksym]]] - end, Cls) ++ - [[[quote,true],[':',erlang,error, - [tuple, - [quote,expand_macro], - [cons,[quote,Name],Argsym], %??? Must check this - [quote,macro_clause]]]]]]. + map(fun (C) -> + Inpat = hd(C), + Outpat = hd(tl(C)), + [[':',lfe_macro,mbe_match_pat,[quote,Inpat], Argsym, Ksym], + ['let', + [[r,[':',lfe_macro,mbe_get_bindings, + [quote,Inpat],Argsym,Ksym]]], + [':',lfe_macro,mbe_expand_pattern, + [quote,Outpat],r,Ksym]]] + end, Cls) ++ + [[[quote,true],[':',erlang,error, + [tuple, + [quote,expand_macro], + [cons,[quote,Name],Argsym], %??? Must check this + [quote,macro_clause]]]]]]. %% Do it all directly. mbe_syntax_rules_proc(Name, Ks0, Cls, Args) -> Ks = [Name|Ks0], case ormap(fun ([Pat,Exp]) -> - case mbe_match_pat(Pat, Args, Ks) of - true -> - R = mbe_get_bindings(Pat, Args, Ks), - [mbe_expand_pattern(Exp, R, Ks)]; - false -> false - end - end, Cls) of - [Res] -> Res; - false -> erlang:error({expand_macro,[Name|Args],macro_clause}) + case mbe_match_pat(Pat, Args, Ks) of + true -> + R = mbe_get_bindings(Pat, Args, Ks), + [mbe_expand_pattern(Exp, R, Ks)]; + false -> false + end + end, Cls) of + [Res] -> Res; + false -> erlang:error({expand_macro,[Name|Args],macro_clause}) end. %% lc_te(Exprs, Qualifiers, State) -> {Exp,State}. @@ -1312,14 +1550,14 @@ %%bc_te(Es, Qs, St) -> bc_tq(Es, Qs, <<>>, St). bc_te(Es, Qs, St) -> c_tq(fun (E, S) -> - %% Separate last form to be binary segment. - case reverse(Es) of - [R] -> {[binary,R,[E,bitstring]],S}; - [R|Rs] -> {['progn'|reverse(Rs)] ++ - [[binary,R,[E,bitstring]]],S}; - [] -> {E,S} - end - end, Qs, <<>>, St). + %% Separate last form to be binary segment. + case reverse(Es) of + [R] -> {[binary,R,[E,bitstring]],S}; + [R|Rs] -> {['progn'|reverse(Rs)] ++ + [[binary,R,[E,bitstring]]],S}; + [] -> {E,S} + end + end, Qs, <<>>, St). %% c_tq(BuildExp, Qualifiers, End, State) -> {Exp,State}. @@ -1351,18 +1589,18 @@ %% pattern and guard guaranteed to match. Keeps compiler quiet. Cs0 = [ [[[]],End] ], %End of list Cs1 = case is_atom(P) and (G == []) of %No match, skip - true -> Cs0; - false -> [ [[[cons,'_',Us]],[H,Us]] |Cs0] - end, + true -> Cs0; + false -> [ [[[cons,'_',Us]],[H,Us]] |Cs0] + end, Cs2 = [ [[[cons,P,Us]],['when'|G],Rest] |Cs1], %Matches pattern and guard {['letrec-function', [[H,['match-lambda'|Cs2]]], [H,Gen]],St3}. c_b_tq(Exp, P, G, Gen, Qs, End, St0) -> - {H,St1} = new_fun_name("bc", St0), %Function name - {B,St2} = new_symb(St1), %Bin variable - {Rest,St3} = c_tq(Exp, Qs, [H,B], St2), %Do rest of qualifiers + {H,St1} = new_fun_name("bc", St0), %Function name + {B,St2} = new_symb(St1), %Bin variable + {Rest,St3} = c_tq(Exp, Qs, [H,B], St2), %Do rest of qualifiers Brest = [B,bitstring,'big-endian',unsigned,[unit,1]], %,[size,all] %% Build the match and nomatch/end clauses. MatchC = [[[binary,P,Brest]],['when'|G],Rest], %Matches pattern and guard @@ -1392,3 +1630,12 @@ %% [[[binary,P,Brest]],Rest], %Matches pattern %% [[[binary,Brest]],End]]]], %No match %% [H,Gen]],St3}; + +%% mapfoldl2(Fun, Acc1, Acc2, List) -> {List,Acc1,Acc2}. +%% Like normal mapfoldl but with 2 accumulators. + +mapfoldl2(Fun, A0, B0, [E0|Es0]) -> + {E1,A1,B1} = Fun(E0, A0, B0), + {Es1,A2,B2} = mapfoldl2(Fun, A1, B1, Es0), + {[E1|Es1],A2,B2}; +mapfoldl2(_, A, B, []) -> {[],A,B}.
View file
lfe-0.9.2.tar.gz/src/lfe_macro.hrl -> lfe-1.0.tar.gz/src/lfe_macro.hrl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2013 Robert Virding +%% Copyright (c) 2013-2015 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -19,18 +19,20 @@ %% We do a lot of quoting! -define(Q(E), [quote,E]). -define(BQ(E), [backquote,E]). --define(UQ(E), [unquote,E]). --define(UQ_S(E), ['unquote-splicing',E]). +-define(C(E), [comma,E]). +-define(C_A(E), ['comma-at',E]). %% Macro expander state. --record(mac, {expand=true, %Expand everything - module='-no-module', %Current module - line=1, %Line no of current form - vc=0, %Variable counter - fc=0, %Function counter - file=[], %File name - opts=[], %Compiler options - ipath=[], %Include path - errors=[], %Errors - warnings=[] %Warnings - }). +-record(mac, {expand=true, %Expand everything + keep=true, %Keep all forms + module='-no-module', %Current module + line=1, %Line no of current form + vc=0, %Variable counter + fc=0, %Function counter + file=[], %File name + opts=[], %Compiler options + ipath=[], %Include path + errors=[], %Errors + warnings=[], %Warnings + unloadable=[] %Macro modules we can't load + }).
View file
lfe-1.0.tar.gz/src/lfe_macro_export.erl
Added
@@ -0,0 +1,228 @@ +%% Copyright (c) 2016 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : lfe_macro_export.erl +%% Author : Robert Virding +%% Purpose : Lisp Flavoured Erlang macro export function builder. + +%% Build the LFE-EXPAND-EXPORTED-MACRO function which exports macros +%% so they can be found by the macro expander without needing to +%% inlcude them. If the module foo exports macro bar then it can be +%% called by doing (foo:bar ...). +%% +%% This version expands the macros when the defining module is +%% compiled so they are expanded in the context when that module is +%% compiled, not when they are called. This is easy and makes it easy +%% to access all macros in the defining module. +%% +%% An alternative would be to expand the macros when they are called +%% but then it becomes difficult to access all the macros within the +%% defining module. This might be easy if we accept exporting all +%% macros not just specific ones. +%% +%% The matching is done in two steps: first we test whether the call +%% name is one of our known macros; if so we test whether the +%% arguments match against the argument patterns in the macro +%% definition. Doing it like this gives us the same failure handling +%% as when expanding local calls to macros. + +%% (defun LFE-EXPAND-EXPORTED-MACRO (name args $ENV) +%% (let ((var-1 val-1) ;Eval-when-compile variables +%% ...) +%% (fletrec ((fun-1 ...) ;Eval-when-compile functions +%% ...) +%% (case name ;Macro name without module +%% ('mac-1 ...) ;Already exported local macros +%% (case args ;Match against args +%% (arg-pat ...) +%% ...)) +%% ('mac-2 ...) +%% ... +%% (_ 'no))))) + +-module(lfe_macro_export). + +%%-compile(export_all). + +-include("lfe_comp.hrl"). + +-export([module/2]). + +-import(lists, [reverse/1,reverse/2,member/2,filter/2]). + +%% We do a lot of quoting! +-define(Q(E), [quote,E]). +-define(BQ(E), [backquote,E]). +-define(C(E), [comma,E]). +-define(C_A(E), ['comma-at',E]). + +-record(umac, {mline=[],expm=[],env=[]}). + +%% We need these variables to have a funny name. +-define(NAMEVAR, '|- MACRO NAME -|'). +-define(ARGSVAR, '|- CALL ARGS -|'). + +%% module(ModuleForms, CompState) -> {ModuleForms,CompState}. +%% module(ModuleDef, ModuleForms, UmacState, CompState) -> +%% {ModuleForms,CompState}. + +module([Mdef|Fs], Cst) -> + Mst = collect_macros(Fs, #umac{env=lfe_env:new()}), + %% io:format("m: ~p\n", [Umac]), + module(Mdef, Fs, Mst, Cst). + +module({['define-module',Name|Mdef],L}, Fs0, Mst0, Cst) -> + Mst1 = collect_mdef(Mdef, Mst0#umac{mline=L}), + Fs1 = add_huf(L, Fs0), + Umac = build_user_macro(Mst1), + %% We need to export the expansion function but leave the rest. + Exp = [export,['LFE-EXPAND-EXPORTED-MACRO',3], + ['$handle_undefined_function',2]], + Md1 = {['define-module',Name,Exp|Mdef],L}, + {[Md1|Fs1 ++ [{Umac,L}]],Cst}. + +collect_macros(Fs, Mst) -> + lists:foldl(fun collect_macro/2, Mst, Fs). + +collect_macro({['define-macro',Name,Def],_}, #umac{env=Env0}=Mst) -> + Env1 = lfe_env:add_mbinding(Name, Def, Env0), + Mst#umac{env=Env1}; +collect_macro({['eval-when-compile'|Fs],_}, Mst) -> + lists:foldl(fun collect_ewc_macro/2, Mst, Fs); +collect_macro({['extend-module'|Mdef],_}, Mst) -> + collect_mdef(Mdef, Mst); +collect_macro(_, Mst) -> Mst. + +collect_ewc_macro([set,Name,Val], #umac{env=Env0}=Mst) -> + Env1 = lfe_env:add_vbinding(Name, Val, Env0), + Mst#umac{env=Env1}; +collect_ewc_macro(['define-function',Name,Def], #umac{env=Env0}=Mst) -> + Ar = function_arity(Def), + Env1 = lfe_env:add_fbinding(Name, Ar, Def, Env0), + Mst#umac{env=Env1}; +collect_ewc_macro([progn|Fs], Mst) -> + lists:foldl(fun collect_ewc_macro/2, Mst, Fs). + +function_arity([lambda,As|_]) -> length(As); +function_arity(['match-lambda',[Pats|_]|_]) -> length(Pats). + +%% collect_mdef(ModuleDef, MacroState) -> MacroState. +%% We are only interested in which macros are exported. + +collect_mdef([['export-macro'|Ms]|Mdef], #umac{expm=Expm0}=Mst) -> + Expm1 = add_exports(Expm0, Ms), + collect_mdef(Mdef, Mst#umac{expm=Expm1}); +collect_mdef([_|Mdef], Mst) -> collect_mdef(Mdef, Mst); +collect_mdef([], Mst) -> Mst. + +%% add_exports(Old, More) -> New. +%% exported_macro(Name, State) -> true | false. + +add_exports(all, _) -> all; +add_exports(_, all) -> all; +add_exports(Old, More) -> + ordsets:union(Old, lists:usort(More)). + +exported_macro(_, #umac{expm=all}) -> true; %All are exported +exported_macro(Name, #umac{expm=Expm}) -> + member(Name, Expm). + +%% build_user_macro(MacroState) -> UserMacFunc. +%% Take the forms in the eval-when-compile and build the +%% LFE-EXPAND-EXPORTED-MACRO function. In this version we expand the +%% macros are compile time. + +build_user_macro(#umac{expm=[]}) -> %No macros to export + empty_leum(); +build_user_macro(#umac{env=Env}=Mst) -> + Vfun = fun (N, V, Acc) -> [[N,V]|Acc] end, + Sets = lfe_env:fold_vars(Vfun, [], Env), + %% Collect the local functions. + Ffun = fun (N, _, Def, Acc) -> + %% [[N,lfe_macro:expand_expr_all(Def, Env)]|Acc] + [[N,Def]|Acc] + end, + Funs = lfe_env:fold_funs(Ffun, [], Env), + %% Collect the local macros. + Mfun = fun (N, Def0, Acc) -> + case exported_macro(N, Mst) of + true -> + %% Def1 = lfe_macro:expand_expr_all(Def0, Env), + [macro_case_clause(N, Def0)|Acc]; + false -> Acc + end + end, + %% Get the macros to export as case clauses. + case lfe_env:fold_macros(Mfun, [], Env) of + [] -> empty_leum(); %No macros to export + Macs -> + %% Build case, flet and let. + Case = ['case',?NAMEVAR|Macs ++ [['_',?Q(no)]]], + Flr = ['letrec-function',Funs,Case], + Fl = ['let',Sets,Flr], + ['define-function','LFE-EXPAND-EXPORTED-MACRO', + [lambda,[?NAMEVAR,?ARGSVAR,'$ENV'],Fl]] + end. + +empty_leum() -> + ['define-function','LFE-EXPAND-EXPORTED-MACRO', + [lambda,['_','_','_'],?Q(no)]]. + +%% add_huf(ModLine, Forms) -> Forms. +%% Add the $handle_undefined_function/2 function to catch run-time +%% macro calls. Scan through forms to check if there is an +%% $handle_undefined_function/2 function already defined. If so use +%% that as default when not a macro, otherwise just generate the +%% standard undef error. + +add_huf(L, [{['define-function','$handle_undefined_function',Def],Lf}=F|Fs]) -> + case function_arity(Def) of + 2 -> [{make_huf(Def),Lf}|Fs]; %Found the right $huf + _ -> [F|add_huf(L, Fs)] + end; +add_huf(L, [F|Fs]) -> + [F|add_huf(L, Fs)]; +add_huf(L, []) -> %No $huf, so make one. + %% Use the default undef exception handler. + Excep = [lambda,[a,b], + [':',error_handler,raise_undef_exception,['MODULE'],a,b]], + [{make_huf(Excep),L}]. + +make_huf(Huf) -> + [defun,'$handle_undefined_function',[f,as], + ['case',['LFE-EXPAND-EXPORTED-MACRO',f,as,[':',lfe_env,new]], + [[tuple,?Q(yes),exp],[':',lfe_eval,expr,exp]], + [?Q(no),[funcall,Huf,f,as]]]]. + +%% macro_case_clause(Name, Def) -> CaseClause. +%% Build a case clause for expanding macr Name. + +macro_case_clause(Name, Def) -> + Cls = get_macro_cls(Def), + Ccls = [ macro_clause(Args, B) || {Args,B} <- Cls ], + [?Q(Name),['case',?ARGSVAR|Ccls]]. %Don't catch errors + +%% get_macro_cls(MacroDef) -> [{ArgPat,Body}]. +%% Build a list of arg pattern and body for each clause. In the +%% definition arguments the first is the argument pattern, the second +%% is the environment variable $ENV. Be nice. + +get_macro_cls(['lambda',[Arg|_]|B]) -> + [{Arg,B}]; %Only one clause here +get_macro_cls(['match-lambda'|Cls]) -> + [ {Arg,B} || [[Arg|_]|B] <- Cls ]; +get_macro_cls(_) -> []. %Ignore bad formed macros + +macro_clause(Args, Body) -> + [Args,[tuple,?Q(yes),[progn|Body]]].
View file
lfe-0.9.2.tar.gz/src/lfe_macro_include.erl -> lfe-1.0.tar.gz/src/lfe_macro_include.erl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2013 Robert Virding +%% Copyright (c) 2013-2015 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -31,13 +31,13 @@ read_hrl_file_1(Name) -> case epp:open(Name, []) of - {ok,Epp} -> - %% These are two undocumented functions of epp. - Fs = epp:parse_file(Epp), - Ms = epp:macro_defs(Epp), - epp:close(Epp), %Now we close epp - {ok,Fs,Ms}; - {error,E} -> {error,E} + {ok,Epp} -> + %% These are two undocumented functions of epp. + Fs = epp:parse_file(Epp), + Ms = epp:macro_defs(Epp), + epp:close(Epp), %Now we close epp + {ok,Fs,Ms}; + {error,E} -> {error,E} end. %% Errors. @@ -136,15 +136,15 @@ read_file(Name, St) -> case lists:suffix(".hrl", Name) of - true -> read_hrl_file(Name, St); %Read file as .hrl file - false -> read_lfe_file(Name, St) + true -> read_hrl_file(Name, St); %Read file as .hrl file + false -> read_lfe_file(Name, St) end. read_lfe_file(Name, St) -> %% Read the file as an LFE file. case lfe_io:read_file(Name) of - {ok,Fs} -> {ok,Fs,St}; - {error,E} -> {error,E} + {ok,Fs} -> {ok,Fs,St}; + {error,E} -> {error,E} end. %% read_hrl_file(FileName, State) -> {ok,Forms,State} | {error,Error}. @@ -153,13 +153,13 @@ read_hrl_file(Name, St) -> case epp:open(Name, []) of - {ok,Epp} -> - %% These are two undocumented functions of epp. - Fs = epp:parse_file(Epp), %This must be called first - Ms = epp:macro_defs(Epp), % then this! - epp:close(Epp), %Now we close epp - parse_hrl_file(Fs, Ms, St); - {error,E} -> {error,E} + {ok,Epp} -> + %% These are two undocumented functions of epp. + Fs = epp:parse_file(Epp), %This must be called first + Ms = epp:macro_defs(Epp), % then this! + epp:close(Epp), %Now we close epp + parse_hrl_file(Fs, Ms, St); + {error,E} -> {error,E} end. %% parse_hrl_file(Forms, Macros, State) -> {ok,Forms,State} | {error,Error}. @@ -178,9 +178,9 @@ trans_forms([{attribute,_,record,{Name,Fields}}|Fs], St0) -> {As,Lfs,St1} = trans_forms(Fs, St0), case catch {ok,trans_record(Name, Fields)} of - {ok,Lrec} -> {As,[Lrec|Lfs],St1}; - {'EXIT',_} -> %Something went wrong - {As,Lfs,add_warning({notrans_record,Name}, St1)} + {ok,Lrec} -> {As,[Lrec|Lfs],St1}; + {'EXIT',_} -> %Something went wrong + {As,Lfs,add_warning({notrans_record,Name}, St1)} end; trans_forms([{attribute,_,export,Es}|Fs], St0) -> {As,Lfs,St1} = trans_forms(Fs, St0), @@ -196,14 +196,14 @@ trans_forms([{function,_,Name,Arity,Cls}|Fs], St0) -> {As,Lfs,St1} = trans_forms(Fs, St0), case catch {ok,trans_function(Name, Arity, Cls)} of - {ok,Lfunc} -> {As,[Lfunc|Lfs],St1}; - {'EXIT',_} -> %Something went wrong - {As,Lfs,add_warning({notrans_function,Name,Arity}, St1)} + {ok,Lfunc} -> {As,[Lfunc|Lfs],St1}; + {'EXIT',_} -> %Something went wrong + {As,Lfs,add_warning({notrans_function,Name,Arity}, St1)} end; -trans_forms([{error,_}|Fs], St) -> %What should we do with these? +trans_forms([{error,_}|Fs], St) -> %What should we do with these? + trans_forms(Fs, St); +trans_forms([_|Fs], St) -> %Ignore everything else trans_forms(Fs, St); -trans_forms([_|Fs], St) -> %Ignore everything else - trans_forms(Fs, St); trans_forms([], St) -> {[],[],St}. trans_farity(Es) -> @@ -218,9 +218,9 @@ record_fields(Fs) -> [ record_field(F) || F <- Fs ]. -record_field({record_field,_,F}) -> %Just the field name +record_field({record_field,_,F}) -> %Just the field name lfe_trans:from_lit(F); -record_field({record_field,_,F,Def}) -> %Field name and default value +record_field({record_field,_,F,Def}) -> %Field name and default value Fd = lfe_trans:from_lit(F), Ld = lfe_trans:from_expr(Def), [Fd,Ld]. @@ -239,23 +239,23 @@ trans_macros([{{atom,Mac},Defs}|Ms], St0) -> {Lms,St1} = trans_macros(Ms, St0), case catch trans_macro(Mac, Defs, St1) of - {'EXIT',_} -> %It crashed - {Lms,add_warning({notrans_macro,Mac}, St1)}; - {none,St2} -> {Lms,St2}; %No definition, ignore - {Mdef,St2} -> {[Mdef|Lms],St2} + {'EXIT',_} -> %It crashed + {Lms,add_warning({notrans_macro,Mac}, St1)}; + {none,St2} -> {Lms,St2}; %No definition, ignore + {Mdef,St2} -> {[Mdef|Lms],St2} end; trans_macros([], St) -> {[],St}. -trans_macro(_, undefined, St) -> {none,St}; %Undefined macros -trans_macro(_, {none,_}, St) -> {none,St}; %Predefined macros +trans_macro(_, undefined, St) -> {none,St}; %Undefined macros +trans_macro(_, {none,_}, St) -> {none,St}; %Predefined macros trans_macro(Mac, Defs0, St) -> Defs1 = order_macro_defs(Defs0), case trans_macro_defs(Defs1) of - [] -> {none,St}; %No definitions - Lcls -> {[defmacro,Mac|Lcls],St} + [] -> {none,St}; %No definitions + Lcls -> {[defmacro,Mac|Lcls],St} end. -order_macro_defs([{none,Ds}|Defs]) -> %Put the no arg version last +order_macro_defs([{none,Ds}|Defs]) -> %Put the no arg version last Defs ++ [{none,Ds}]; order_macro_defs(Defs) -> Defs. @@ -287,8 +287,8 @@ Ts1 = trans_qm(Ts0), {ok,[E]} = erl_parse:parse_exprs(Ts1 ++ [{dot,0}]), Le0 = lfe_trans:from_expr(E), - %% Wrap variables in arg list with an (unquote ...) call. - Alist = [ [A|[unquote,A]] || A <- As ], + %% Wrap variables in arg list with an (comma ...) call. + Alist = [ [A|[comma,A]] || A <- As ], Le1 = lfe_lib:sublis(Alist, Le0), %% Le1 = unquote_vars(Alist, Le0), [?BQ(Le1)].
View file
lfe-0.9.2.tar.gz/src/lfe_macro_record.erl -> lfe-1.0.tar.gz/src/lfe_macro_record.erl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2008-2013 Robert Virding +%% Copyright (c) 2008-2015 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -41,27 +41,27 @@ define(Name, Fdefs, Env, St) -> %% Get field names, default values and indices. Fields = map(fun ([F,_]) when is_atom(F) -> F; - (F) when is_atom(F) -> F - end, Fdefs), + (F) when is_atom(F) -> F + end, Fdefs), Defs = map(fun ([F,D])when is_atom(F) -> ?Q(D); - (F) when is_atom(F) -> ?Q(?Q(undefined)) - end, Fdefs), + (F) when is_atom(F) -> ?Q(?Q(undefined)) + end, Fdefs), Findexs = field_indexes(Fields), %% Make names for helper functions. Fi = list_to_atom(concat([Name,'-',field,'-',index])), Fu = list_to_atom(concat([Name,'-',field,'-',update])), %% Build helper functions. Funs = [index_function(Name, Fi, Findexs), - update_function(Name, Fu, Fi)], + update_function(Name, Fu, Fi)], %% Make access macros. - Macs = [make_macro(Name, Defs, Fu), %make-Name - match_macro(Name, Fields, Fu), %match-Name - test_macro(Name, Fields), %is-Name - set_macro(Name, Fi), %set-Name - emp_macro(Name, Fields, Fu), %emp-Name - field_macro(Name, Fields) %fields-Name - | - field_macros(Name, Fields)], %Name-F,set-Name-F + Macs = [make_macro(Name, Defs, Fu), %make-Name + match_macro(Name, Fields, Fu), %match-Name + test_macro(Name, Fields), %is-Name + set_macro(Name, Fi), %set-Name + emp_macro(Name, Fields, Fu), %emp-Name + field_macro(Name, Fields) %fields-Name + | + field_macros(Name, Fields)], %Name-F,set-Name-F Type = type_information(Name, Fdefs, St), %% We can always add type information here as it is stripped later. Forms = [['extend-module',Type]|Macs], @@ -74,21 +74,21 @@ [{F,N}|field_indexes(Fs, N+1)]; field_indexes([], _) -> []. -index_function(Name, Fi, Fxs) -> %Get index of field +index_function(Name, Fi, Fxs) -> %Get index of field [defun,Fi| map(fun ({F,I}) -> [[?Q(F)],I] end, Fxs) ++ - [[[f],[':',erlang,error,[tuple,?Q(undefined_field),?Q(Name),f]]]]]. + [[[f],[':',erlang,error,[tuple,?Q(undefined_field),?Q(Name),f]]]]]. -update_function(Name, Fu, Fi) -> %Update field list +update_function(Name, Fu, Fi) -> %Update field list [defun,Fu,[is,def], %% Convert default list to tuple to make setting easier. [fletrec,[[l, - [[[cons,f,[cons,v,is]],i], - [l,is,[setelement,['-',[Fi,f],1],i,v]]], - [[[list,f],'_'], - [':',erlang,error, - [tuple,?Q(missing_value),?Q(Name),f]]], - [[[],i],i]]], + [[[cons,f,[cons,v,is]],i], + [l,is,[setelement,['-',[Fi,f],1],i,v]]], + [[[list,f],'_'], + [':',erlang,error, + [tuple,?Q(missing_value),?Q(Name),f]]], + [[[],i],i]]], ['let',[[i,[l,is,[list_to_tuple,def]]]], [tuple_to_list,i]]]]. @@ -96,64 +96,64 @@ Make = list_to_atom(concat(['make','-',Name])), ['defmacro',Make,fds, ['let',[[def,[list|Defs]]], - ?BQ([tuple,?Q(Name),?UQ_S([Fu,fds,def])])]]. + ?BQ([tuple,?Q(Name),?C_A([Fu,fds,def])])]]. match_macro(Name, Fs, Fu) -> Match = list_to_atom(concat(['match','-',Name])), ['defmacro',Match,fds, ['let',[[def,[list|lists:duplicate(length(Fs),?Q('_'))]]], - ?BQ([tuple,?Q(Name),?UQ_S([Fu,fds,def])])]]. + ?BQ([tuple,?Q(Name),?C_A([Fu,fds,def])])]]. test_macro(Name, Fs) -> Test = list_to_atom(concat(['is','-',Name])), ['defmacro',Test,[rec], - ?BQ(['is_record',?UQ(rec),?Q(Name),length(Fs)+1])]. + ?BQ(['is_record',?C(rec),?Q(Name),length(Fs)+1])]. set_macro(Name, Fi) -> Set = list_to_atom(concat(['set','-',Name])), ['defmacro',Set, [[cons,rec,fds], [fletrec,[[l, - [[[cons,f,[cons,v,is]],r], - %% Force evaluation left-to-right. - [l,is,[list,[quote,setelement],[Fi,f],r,v]]], - [[[list,f],'_'], - [':',erlang,error, - [tuple,?Q(missing_value),?Q(Name),f]]], - [[[],i],i]]], + [[[cons,f,[cons,v,is]],r], + %% Force evaluation left-to-right. + [l,is,[list,[quote,setelement],[Fi,f],r,v]]], + [[[list,f],'_'], + [':',erlang,error, + [tuple,?Q(missing_value),?Q(Name),f]]], + [[[],i],i]]], [l,fds,rec]]]]. emp_macro(Name, Fs, Fu) -> EMP = list_to_atom(concat(['emp','-',Name])), ['defmacro',EMP,fds, ['let',[[def,[list|lists:duplicate(length(Fs),?Q(?Q('_')))]]], - ?BQ([tuple,?Q(Name),?UQ_S([Fu,fds,def])])]]. + ?BQ([tuple,?Q(Name),?C_A([Fu,fds,def])])]]. field_macro(Name, Fs) -> Recfields = list_to_atom(concat(['fields','-',Name])), ['defmacro',Recfields,[],?BQ(?Q(Fs))]. field_macros(Name, Fs) -> - Fis = field_indexes(Fs), %Calculate indexes + Fis = field_indexes(Fs), %Calculate indexes foldr(fun ({F,N}, Fas) -> - Get = list_to_atom(concat([Name,'-',F])), - Set = list_to_atom(concat(['set-',Name,'-',F])), - [[defmacro,Get, - [[],N], - [[list,rec],?BQ([element,N,?UQ(rec)])]], - [defmacro,Set,[rec,new], - ?BQ([setelement,N,?UQ(rec),?UQ(new)])]| - Fas] - end, [], Fis). + Get = list_to_atom(concat([Name,'-',F])), + Set = list_to_atom(concat(['set-',Name,'-',F])), + [[defmacro,Get, + [[],N], + [[list,rec],?BQ([element,N,?C(rec)])]], + [defmacro,Set,[rec,new], + ?BQ([setelement,N,?C(rec),?C(new)])]| + Fas] + end, [], Fis). type_information(Name, Fdefs, #mac{line=L}) -> %% Only field names which will result in default type any(). %% Adding types greatly complicates things. If we add defaults %% then they would have to be expanded here. Fs = map(fun ([F,_D]) -> - %% De = lfe_trans:to_expr(D, L), - {record_field,L,{atom,L,F}}; - (F) -> - {record_field,L,{atom,L,F}} - end, Fdefs), + %% De = lfe_trans:to_expr(D, L), + {record_field,L,{atom,L,F}}; + (F) -> + {record_field,L,{atom,L,F}} + end, Fdefs), [type,[{record,Name},Fs,[]]].
View file
lfe-0.9.2.tar.gz/src/lfe_ms.erl -> lfe-1.0.tar.gz/src/lfe_ms.erl
Changed
@@ -37,21 +37,21 @@ format_error(match_spec_head) -> "Illegal number of head arguments". --define(Q(E), [quote,E]). %We do a lot of quoting! +-define(Q(E), [quote,E]). %We do a lot of quoting! --record(ms, {dc=1, %Dollar variable count from 1 - bs=[], %Variable/$var bindings - where=guard %Where in spec head/guard/body - }). +-record(ms, {dc=1, %Dollar variable count from 1 + bs=[], %Variable/$var bindings + where=guard %Where in spec head/guard/body + }). %% expand(MSBody) -> Expansion. -%% Expand the match spec body. +%% Expand the match spec body. expand(Cls) -> case catch clauses(Cls, #ms{}) of - {error,E} -> error(E); %Signals errors - {'EXIT',E} -> error(E); %Signals errors - {Exp,_} -> Exp %Hurrah it worked + {error,E} -> error(E); %Signals errors + {'EXIT',E} -> error(E); %Signals errors + {Exp,_} -> Exp %Hurrah it worked end. %% clauses(MSClauses, State) -> {Patterns,State}. @@ -77,24 +77,24 @@ {[tuple,H1,[],B1],St3}. %% head(Patterns, State) -> {Pattern,State}. -%% Expand a head which can only consist of one argument. Only allow -%% aliasing at the top-level and only to a variable. +%% Expand a head which can only consist of one argument. Only allow +%% aliasing at the top-level and only to a variable. head(Pats, St0) -> - St1 = St0#ms{where=head}, %We are now in the head - case Pats of %Test for top-level aliasing - [['=',S,Pat]] when is_atom(S) -> - St2 = new_binding(S, '$_', St1), - pattern(Pat, St2); - [['=',Pat,S]] when is_atom(S) -> - St2 = new_binding(S, '$_', St1), - pattern(Pat, St2); - [Pat] -> pattern(Pat, St1); - _ -> throw({error,match_spec_head}) %Wrong size + St1 = St0#ms{where=head}, %We are now in the head + case Pats of %Test for top-level aliasing + [['=',S,Pat]] when is_atom(S) -> + St2 = new_binding(S, '$_', St1), + pattern(Pat, St2); + [['=',Pat,S]] when is_atom(S) -> + St2 = new_binding(S, '$_', St1), + pattern(Pat, St2); + [Pat] -> pattern(Pat, St1); + _ -> throw({error,match_spec_head}) %Wrong size end. pattern('_', St) -> {?Q('_'),St}; -pattern(Symb, St0) when is_atom(Symb) -> %Variable +pattern(Symb, St0) when is_atom(Symb) -> %Variable {Dv,St1} = pat_binding(Symb, St0), {?Q(Dv),St1}; pattern([quote,_]=E, St) -> {E,St}; @@ -113,26 +113,26 @@ {H1,St1} = pattern(H0, St0), {T1,St2} = pattern(T0, St1), {[H1,T1],St2}; -pattern(E, St) -> {E,St}. %Atomic +pattern(E, St) -> {E,St}. %Atomic pat_list(Ps, St) -> mapfoldl(fun pattern/2, St, Ps). %% pat_binding(Var, Status) -> {DVar,Status}. -%% Get dollar var for variable, creating a new one if neccessary. +%% Get dollar var for variable, creating a new one if neccessary. pat_binding(Var, St0) -> case find_binding(Var, St0) of - {ok,Dv} -> {Dv,St0}; - error -> - {Dv,St1} = new_dollar(St0), - {Dv,new_binding(Var, Dv, St1)} + {ok,Dv} -> {Dv,St0}; + error -> + {Dv,St1} = new_dollar(St0), + {Dv,new_binding(Var, Dv, St1)} end. %% guard(Tests, State) -> {Tests,State}. %% body(Tests, State) -> {Tests,State}. -%% The expression translation in the same except for which -%% expressions/tests are allowed. We use the same functions but carry -%% a 'where' field in the State to separate them. +%% The expression translation in the same except for which +%% expressions/tests are allowed. We use the same functions but carry +%% a 'where' field in the State to separate them. guard(Ts, St0) -> St1 = St0#ms{where=guard}, @@ -153,13 +153,13 @@ expr(S, St) when is_atom(S) -> %Variable case find_binding(S, St) of - {ok,Dv} -> {?Q(Dv),St}; %Head variable - error -> {S,St} %Free variable, need binding + {ok,Dv} -> {?Q(Dv),St}; %Head variable + error -> {S,St} %Free variable, need binding end; expr([quote,A]=E, St) when is_atom(A) -> %Atom case atom_to_list(A) of - [$$|_] -> {[tuple,?Q(const),E],St}; %Catch dollar variables - _ -> {E,St} + [$$|_] -> {[tuple,?Q(const),E],St}; %Catch dollar variables + _ -> {E,St} end; expr([quote,T], St) when is_tuple(T) -> %Must tuple tuples {[tuple,T],St}; @@ -184,18 +184,18 @@ expr([call,?Q(erlang),?Q(Op)|Es0], St0) when is_atom(Op) -> Ar = length(Es0), case is_ms_erlang_func(Op, Ar) of - true -> - {Es1,St1} = expr_list(Es0, St0), - {[tuple,?Q(Op)|Es1],St1}; - false -> throw({error,{illegal_ms_func,{erlang,Op,Ar}}}) + true -> + {Es1,St1} = expr_list(Es0, St0), + {[tuple,?Q(Op)|Es1],St1}; + false -> throw({error,{illegal_ms_func,{erlang,Op,Ar}}}) end; expr([Op|Es0], St0) when is_atom(Op) -> Ar = length(Es0), case is_ms_func(Op, Ar, St0#ms.where) of %Need to know where we are! - true -> - {Es1,St1} = expr_list(Es0, St0), - {[tuple,?Q(Op)|Es1],St1}; - false -> throw({error,{illegal_ms_func,{Op,Ar}}}) + true -> + {Es1,St1} = expr_list(Es0, St0), + {[tuple,?Q(Op)|Es1],St1}; + false -> throw({error,{illegal_ms_func,{Op,Ar}}}) end; expr([_|_], _) -> throw({error,illegal_ms_call}); expr([], St) -> {[],St}; @@ -209,25 +209,25 @@ expr_bitseg([Val0|Specs0]=F, St0) -> case is_integer_list(F) of - true -> {F,St0}; - false -> - {Specs1,St1} = expr_bitspecs(Specs0, St0), - case is_integer_list(Val0) of - true -> {[Val0|Specs1],St1}; + true -> {F,St0}; false -> - {Val1,St2} = expr(Val0, St1), - {[Val1|Specs1],St2} - end + {Specs1,St1} = expr_bitspecs(Specs0, St0), + case is_integer_list(Val0) of + true -> {[Val0|Specs1],St1}; + false -> + {Val1,St2} = expr(Val0, St1), + {[Val1|Specs1],St2} + end end; expr_bitseg(Val, St) -> expr(Val, St). expr_bitspecs(Specs, St) -> mapfoldl(fun ([size,Sz0], S0) -> - {Sz1,S1} = expr(Sz0, S0), - {[size,Sz1],S1}; - (Sp, S) -> {Sp,S} - end, St, Specs). + {Sz1,S1} = expr(Sz0, S0), + {[size,Sz1],S1}; + (Sp, S) -> {Sp,S} + end, St, Specs). is_integer_list([I|Is]) when is_integer(I) -> is_integer_list(Is);
View file
lfe-0.9.2.tar.gz/src/lfe_parse.erl -> lfe-1.0.tar.gz/src/lfe_parse.erl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2008-2013 Robert Virding +%% Copyright (c) 2009-2015 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -12,313 +12,272 @@ %% See the License for the specific language governing permissions and %% limitations under the License. -%% File : lfe_parse.erl -%% Author : Robert Virding -%% Purpose : A simple Sexpr parser. -%% A simple sexpr parser. It is both re-entrant and returns excess -%% tokens. The main engine is pretty naively coded at the moment. - -module(lfe_parse). --export([sexpr/1,sexpr/2,format_error/1]). +-export([format_error/1]). --import(lists, [reverse/1,reverse/2]). +%% The root symbol entry points +-export([form/1,form/2]). -%% Define IS_MAP/1 macro for is_map/1 bif. --ifdef(HAS_MAPS). --define(IS_MAP(T), is_map(T)). --else. --define(IS_MAP(T), false). --endif. +%% User code. This is placed here to allow extra attributes. -%% We define the syntax as an LL(1) and write/generate a parser for -%% it. We also define the grammar with the same form as for yecc even -%% though we have no automatic generator. -%% -%% Terminals -%% symbol number string fun '(' ')' '[' ']' '.' '\'' ',' '@' ',@' '`' '#(' -%% '#B(' '#M(' '#\''. -%% -%% Nonterminals form sexpr list list_tail proper_list . -%% -%% 0 form -> sexpr : '$1'. -%% 1 sexpr -> symbol : val('$1'). -%% 2 sexpr -> number : val('$1'). -%% 3 sexpr -> string : val('$1'). -%% 4 sexpr -> '#\'' : make_fun(val('$1')). -%% 5 sexpr -> '\'' sexpr : [quote,'$2']. -%% 6 sexpr -> '`' sexpr : [backquote,'$2']. -%% 7 sexpr -> ',' sexpr : [unquote,'$2']. -%% 8 sexpr -> ',@' sexpr : ['unquote-splicing','$2']. -%% 9 sexpr -> ( list ) : '$2'. -%% 10 sexpr -> [ list ] : '$2'. -%% 11 sexpr -> '#(' proper_list ')' : list_to_tuple('$2'). -%% 12 sexpr -> '#B(' proper_list ')' : -%% case catch lfe_eval:expr([binary|'$2']) of -%% Bin when is_bitstring(Bin) -> Bin; -%% _ -> return_error(line('$1')) -%% end -%% 13 sexpr -> '#M(' proper_list ')' : -%% case catch maps:from_list(pair_list('$2')) of -%% Map when is_map(Map) -> Map; -%% _ -> return_error(line('$1')) -%% end -%% 14 list -> sexpr list_tail : ['$1'|'$2]. -%% 15 list -> empty : []. -%% 16 list_tail -> sexpr list_tail : ['$1'|'$2']. -%% 17 list_tail -> . sexpr : '$2'. -%% 18 list_tail -> empty : []. -%% 19 proper_list -> sexpr proper_list : ['$1'|'$2']. -%% 20 proper_list -> empty : []. - -%% The computed First and Follow sets for the productions. This is the -%% only really tricky bit. -%% -%% First(f) = {symbol number string #' ( [ ' ` , ,@ #( #B( #M(} -%% First(s) = {symbol number string #' ( [ ' ` , ,@ #( #B( #M(} -%% First(l) = {symbol number string #' ( [ ' ` , ,@ #( #B( #M( empty} -%% First(t) = {symbol number string #' ( [ . ' ` , ,@ #( #B( #M( empty} -%% First(p) = {symbol number string #' ( [ ' ` , ,@ #( #B( #M( empty} -%% Follow(f) = empty -%% Follow(s) = {symbol number string #' ( [ ) ] ' ` , ,@ #( #B( #M(} -%% Follow(l) = {symbol number string #' ( [ ) ] ' ` , ,@ #( #B( #M(} -%% Follow(t) = {symbol number string #' ( [ ) ] ' ` , ,@ #( #B( #M(} -%% Follow(p) = {symbol number string #' ( [ ) ] ' ` , ,@ #( #B( #M(} - -%% The table (tedious). -%% Top symbol ( ) [ ] . '`,,@ #(#B(#M( -%% f f->s f->s f->s f->s f->s -%% s s->sym s->( l ) s->[ s ] s->' s s->( p ) -%% l l->s t l->s t l->e l->s t l->e l->s t l->s t -%% t t->s t t->s t t->e t->s t t->e t->. s t->s t t->s t -%% p p->s p p->s p p->e p->s p p->e p->s p p->s p - -%% The non-terminal types. --define(FORM, 0). --define(EXPR, 1). --define(LIST, 2). --define(TAIL, 3). --define(PROP, 4). - -%% Start non-terminal state. -start() -> ?FORM. +-define(CATCH(E, Error), try E catch _:_ -> Error end). -%% The reductions, we are naive and straight forward here. -reduce(0, Vs) -> Vs; %f->s -reduce(1, [T|Vs]) -> [val(T)|Vs]; %s->symbol -reduce(2, [T|Vs]) -> [val(T)|Vs]; %s->number -reduce(3, [T|Vs]) -> [val(T)|Vs]; %s->string -reduce(4, [T|Vs]) -> %s->fun - [make_fun(val(T))|Vs]; -reduce(5, [S,_|Vs]) -> [[quote,S]|Vs]; %s->' s -reduce(6, [S,_|Vs]) -> [[backquote,S]|Vs]; %s->` s -reduce(7, [S,_|Vs]) -> [[unquote,S]|Vs]; %s->, s -reduce(8, [S,_|Vs]) -> %s->,@ s - [['unquote-splicing',S]|Vs]; -reduce(9, [_,L,_|Vs]) -> [L|Vs]; %s->( s ) -reduce(10, [_,L,_|Vs]) -> [L|Vs]; %s->[ s ] -reduce(11, [_,L,_|Vs]) -> %s->#( p ) - [list_to_tuple(L)|Vs]; -reduce(12, [_,L,B|Vs]) -> %s->#B( p ) - case catch lfe_eval:literal([binary|L]) of - Bin when is_bitstring(Bin) -> [Bin|Vs]; - _ -> {error,line(B),{illegal,binary}} - end; -reduce(13, [_,L,B|Vs]) -> %s->#M( p ) - case catch maps:from_list(pair_list(L)) of - Map when ?IS_MAP(Map) -> [Map|Vs]; - _ -> {error,line(B),{illegal,map}} - end; -reduce(14, [T,H|Vs]) -> [[H|T]|Vs]; %l->s t -reduce(15, Vs) -> [[]|Vs]; %l->empty -reduce(16, [T,H|Vs]) -> [[H|T]|Vs]; %t->s t -reduce(17, [T,_|Vs]) -> [T|Vs]; %t->. s -reduce(18, Vs) -> [[]|Vs]; %t->empty -reduce(19, [T,H|Vs]) -> [[H|T]|Vs]; %p->s t -reduce(20, Vs) -> [[]|Vs]. %p->empty - -%% The table, this gets pretty big but is very straight forward. -table(?FORM, symbol) -> [?EXPR]; -table(?FORM, number) -> [?EXPR]; -table(?FORM, string) -> [?EXPR]; -table(?FORM, '#\'') -> [?EXPR]; -table(?FORM, '\'') -> [?EXPR]; -table(?FORM, '`') -> [?EXPR]; -table(?FORM, ',') -> [?EXPR]; -table(?FORM, ',@') -> [?EXPR]; -table(?FORM, '(') -> [?EXPR]; -table(?FORM, '[') -> [?EXPR]; -table(?FORM, '#(') -> [?EXPR]; -table(?FORM, '#B(') -> [?EXPR]; -table(?FORM, '#M(') -> [?EXPR]; - -table(?EXPR, symbol) -> [symbol,{reduce,1}]; -table(?EXPR, number) -> [number,{reduce,2}]; -table(?EXPR, string) -> [string,{reduce,3}]; -table(?EXPR, '#\'') -> ['#\'',{reduce,4}]; -table(?EXPR, '\'') -> ['\'',?EXPR,{reduce,5}]; -table(?EXPR, '`') -> ['`',?EXPR,{reduce,6}]; -table(?EXPR, ',') -> [',',?EXPR,{reduce,7}]; -table(?EXPR, ',@') -> [',@',?EXPR,{reduce,8}]; -table(?EXPR, '(') -> ['(',?LIST,')',{reduce,9}]; -table(?EXPR, '[') -> ['[',?LIST,']',{reduce,10}]; -table(?EXPR, '#(') -> ['#(',?PROP,')',{reduce,11}]; -table(?EXPR, '#B(') -> ['#B(',?PROP,')',{reduce,12}]; -table(?EXPR, '#M(') -> ['#M(',?PROP,')',{reduce,13}]; - -table(?LIST, symbol) -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, number) -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, string) -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, '#\'') -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, '\'') -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, '`') -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, ',') -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, ',@') -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, '(') -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, '[') -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, '#(') -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, '#B(') -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, '#M(') -> [?EXPR,?TAIL,{reduce,14}]; -table(?LIST, ')') -> [{reduce,15}]; -table(?LIST, ']') -> [{reduce,15}]; - -table(?TAIL, symbol) -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, number) -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, string) -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, '#\'') -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, '\'') -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, '`') -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, ',') -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, ',@') -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, '(') -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, '[') -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, '#(') -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, '#B(') -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, '#M(') -> [?EXPR,?TAIL,{reduce,16}]; -table(?TAIL, '.') -> ['.',?EXPR,{reduce,17}]; -table(?TAIL, ')') -> [{reduce,18}]; -table(?TAIL, ']') -> [{reduce,18}]; - -table(?PROP, symbol) -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, number) -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, string) -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, '#\'') -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, '\'') -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, '`') -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, ',') -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, ',@') -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, '(') -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, '[') -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, '#(') -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, '#B(') -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, '#M(') -> [?EXPR,?PROP,{reduce,19}]; -table(?PROP, ')') -> [{reduce,20}]; -table(?PROP, ']') -> [{reduce,20}]; +%% For backwards compatibility +-export([sexpr/1,sexpr/2]). -table(_, _) -> error. +sexpr(Ts) -> form(Ts). +sexpr(Cont, Ts) -> form(Cont, Ts). -%% sexpr(Tokens) -> -%% {ok,Line,Sexpr,Rest} | {more,Continuation} | {error,Error,Rest}. -%% sexpr(Continuation, Tokens) -> -%% {ok,Line,Sexpr,Rest} | {more,Continuation} | {error,Error,Rest}. +%% make_fun(String) -> FunList. +%% Convert a fun string to a fun sexpr. +%% "F/A" -> ['fun', F, A]. +%% "M:F/A" -> ['fun', M, F, A]. -sexpr(Ts) -> sexpr([], Ts). %Start with empty state +make_fun("=:=/2") -> + ['fun', '=:=', 2]; +make_fun(FunStr) -> + J = string:rchr(FunStr, $/), + A = list_to_integer(string:substr(FunStr, J + 1)), + case string:chr(FunStr, $:) of + 0 -> + F = list_to_atom(string:substr(FunStr, 1, J - 1)), + ['fun', F, A]; + I -> + F = list_to_atom(string:substr(FunStr, I + 1, J - I - 1)), + M = list_to_atom(string:substr(FunStr, 1, I - 1)), + ['fun', M, F, A] + end. -sexpr(Cont, Ts) -> parse1(Cont, Ts). +%% make_bin(Line, Segments) -> Binary. +%% Make a binary from the segments. --record(lp, {l=none,st=[],vs=[]}). %Line, States, Values +make_bin(Line, Segs) -> + ?CATCH(lfe_eval:expr([binary|Segs]), + return_error(Line, "bad binary")). + +%% make_map(Line, Elements) -> Map. +%% Make a map from the key/value elements. + +make_map(Line, Es) -> + ?CATCH(maps:from_list(pair_list(Es)), + return_error(Line, "bad map")). + +%% pair_list(List) -> [{A,B}]. +%% Generate a list of tuple pairs from the elements. An error if odd +%% number of elements in list. + +pair_list([A,B|L]) -> [{A,B}|pair_list(L)]; +pair_list([]) -> []. + +%% eval_expr(Line, Expr) -> Val. +%% Evaluate #. expression. + +eval_expr(Line, Expr) -> + ?CATCH(lfe_eval:expr(Expr), + return_error(Line, "bad #. expression")). + +-record(spell1, {line=none,st=[],vs=[]}). %Line, States, Values -%% parse1(Tokens) -> -%% {ok,Line,Sexpr,Rest} | {more,Continuation} | {error,Error,Rest}. %% parse1(Continuation, Tokens) -> %% {ok,Line,Sexpr,Rest} | {more,Continuation} | {error,Error,Rest}. -%% This is the opt-level of the LL engine. It -%% initialises/packs/unpacks the continuation information. - -parse1([], Ts) -> %First call - Start = start(), %The start state. - parse1(#lp{l=none,st=[Start],vs=[]}, Ts); -parse1(#lp{l=none}=Lp, [T|_]=Ts) -> %Guarantee a start line - parse1(Lp#lp{l=line(T)}, Ts); -parse1(#lp{l=L,st=St0,vs=Vs0}, Ts) -> - case parse2(Ts, St0, Vs0) of - {done,Rest,[],[V]} -> {ok,L,V,Rest}; - {more,[],St1,Vs1} -> {more,#lp{l=L,st=St1,vs=Vs1}}; - {error,Line,Error,Rest,_,_} -> - %% Can't really continue from errors here. - {error,{Line,?MODULE,Error},Rest} +%% This is the opt-level of the LL engine. It +%% initialises/packs/unpacks the continuation information. + +parse1([], Ts) -> %First call + Start = start(), %The start state. + parse1(#spell1{line=none,st=[Start],vs=[]}, Ts); +parse1(#spell1{line=none}=Lp, [T|_]=Ts) -> %Guarantee a start line + parse1(Lp#spell1{line=line(T)}, Ts); +parse1(#spell1{line=L,st=St0,vs=Vs0}, Ts) -> + try + parse2(Ts, St0, Vs0) of + {done,Rest,[],[V]} -> {ok,L,V,Rest}; + {more,[],St1,Vs1} -> {more,#spell1{line=L,st=St1,vs=Vs1}}; + {error,Line,Error,Rest,_,_} -> + %% Can't really continue from errors here. + {error,{Line,?MODULE,Error},Rest} + catch + throw:{spell1_error,Error} -> + {error,Error,[]} end. %% parse2(Tokens, StateStack, ValueStack) -> %% {done,Ts,Sstack,Vstack} | {more,Ts,Sstack,Vstack} | %% {error,Line,Error,Ts,Sstack,Vstack}. -%% Main loop of the parser engine. Handle any reductions on the top of -%% the StateStack, then try to match type of next token with top -%% state. If we have a match, it is a terminal, then push token onto -%% value stack, else try to find new state(s) from table using current -%% state and token type and push them onto state stack. Continue until -%% no states left. +%% Main loop of the parser engine. Handle any reductions on the top +%% of the StateStack, then try to match type of next token with top +%% state. If we have a match, it is a terminal, then push token onto +%% value stack, else try to find new state(s) from table using +%% current state and token type and push them onto state +%% stack. Continue until no states left. parse2(Ts, [{reduce,R}|St], Vs0) -> - %% io:fwrite("p: ~p\n", [{R,Vs}]), + %% io:fwrite("p1: ~p\n", [{Ts,R,Vs0}]), %% Try to reduce values and push value on value stack. case reduce(R, Vs0) of - {error,L,E} -> {error,L,E,Ts,St,Vs0}; - Vs1 -> parse2(Ts, St, Vs1) + {error,L,E} -> {error,L,E,Ts,St,Vs0}; + Vs1 -> parse2(Ts, St, Vs1) end; parse2(Ts, [], Vs) -> {done,Ts,[],Vs}; %All done parse2([T|Ts]=Ts0, [S|St]=St0, Vs) -> - %% io:fwrite("p: ~p\n", [{St0,Ts0}]), + %% io:fwrite("p3: ~p\n", [{Ts0,St0,Vs}]), %% Try to match token type against state on stack. case type(T) of - S -> parse2(Ts, St, [T|Vs]); %Match - Type -> %Try to predict - case table(S, Type) of - error -> {error,line(T),{illegal,Type},Ts0,St0,Vs}; - Top -> parse2(Ts0, Top ++ St, Vs) - end + S -> parse2(Ts, St, [T|Vs]); %Match + Type -> %Try to predict + case table(S, Type) of + error -> {error,line(T),{illegal,Type},Ts0,St0,Vs}; + Top -> parse2(Ts0, Top ++ St, Vs) + end end; parse2([], St, Vs) -> %Need more tokens {more,[],St,Vs}; parse2({eof,L}=Ts, St, Vs) -> %No more tokens - {error,L,{missing,token},Ts,St,Vs}. + {error,L,missing_token,Ts,St,Vs}. %% Access the fields of a token. +-compile({nowarn_unused_function, type/1}). +-compile({nowarn_unused_function, line/1}). +-compile({nowarn_unused_function, value/1}). type(T) -> element(1, T). line(T) -> element(2, T). -val(T) -> element(3, T). - -%% make_fun(String) -> FunList. -%% Convert a fun string to a fun sexpr. -%% "F/A" -> ['fun', F, A]. -%% "M:F/A" -> ['fun', M, F, A]. - -make_fun("=:=/2") -> - ['fun', '=:=', 2]; -make_fun(FunStr) -> - J = string:rchr(FunStr, $/), - A = list_to_integer(string:substr(FunStr, J + 1)), - case string:chr(FunStr, $:) of - 0 -> - F = list_to_atom(string:substr(FunStr, 1, J - 1)), - ['fun', F, A]; - I -> - F = list_to_atom(string:substr(FunStr, I + 1, J - I - 1)), - M = list_to_atom(string:substr(FunStr, 1, I - 1)), - ['fun', M, F, A] - end. - -%% pair_list(List) -> [{A,B}]. -%% Generate a list of tuple pairs from the elements. An error if odd -%% number of elements in list. +value(T) -> element(3, T). + +%% The root symbol entry points. +form(Ts) -> parse1([], Ts). +form(Cont, Ts) -> parse1(Cont, Ts). + +%% The table. +start() -> form. + +table(list_tail, '#\'') -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, '#(') -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, '#.') -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, '#B(') -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, '#M(') -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, ')') -> [{reduce,20}]; +table(list_tail, ']') -> [{reduce,20}]; +table(list_tail, '\'') -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, '(') -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, ',') -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, ',@') -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, '.') -> ['.',sexpr,{reduce,19}]; +table(list_tail, '[') -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, '`') -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, binary) -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, number) -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, string) -> [sexpr,list_tail,{reduce,18}]; +table(list_tail, symbol) -> [sexpr,list_tail,{reduce,18}]; +table(sexpr, '#\'') -> ['#\'',{reduce,5}]; +table(sexpr, '#(') -> ['#(',proper_list,')',{reduce,13}]; +table(sexpr, '#.') -> ['#.',sexpr,{reduce,6}]; +table(sexpr, '#B(') -> ['#B(',proper_list,')',{reduce,14}]; +table(sexpr, '#M(') -> ['#M(',proper_list,')',{reduce,15}]; +table(sexpr, '\'') -> ['\'',sexpr,{reduce,7}]; +table(sexpr, '(') -> ['(',list,')',{reduce,11}]; +table(sexpr, ',') -> [',',sexpr,{reduce,9}]; +table(sexpr, ',@') -> [',@',sexpr,{reduce,10}]; +table(sexpr, '[') -> ['[',list,']',{reduce,12}]; +table(sexpr, '`') -> ['`',sexpr,{reduce,8}]; +table(sexpr, binary) -> [binary,{reduce,4}]; +table(sexpr, number) -> [number,{reduce,2}]; +table(sexpr, string) -> [string,{reduce,3}]; +table(sexpr, symbol) -> [symbol,{reduce,1}]; +table(list, '#\'') -> [sexpr,list_tail,{reduce,16}]; +table(list, '#(') -> [sexpr,list_tail,{reduce,16}]; +table(list, '#.') -> [sexpr,list_tail,{reduce,16}]; +table(list, '#B(') -> [sexpr,list_tail,{reduce,16}]; +table(list, '#M(') -> [sexpr,list_tail,{reduce,16}]; +table(list, ')') -> [{reduce,17}]; +table(list, ']') -> [{reduce,17}]; +table(list, '\'') -> [sexpr,list_tail,{reduce,16}]; +table(list, '(') -> [sexpr,list_tail,{reduce,16}]; +table(list, ',') -> [sexpr,list_tail,{reduce,16}]; +table(list, ',@') -> [sexpr,list_tail,{reduce,16}]; +table(list, '[') -> [sexpr,list_tail,{reduce,16}]; +table(list, '`') -> [sexpr,list_tail,{reduce,16}]; +table(list, binary) -> [sexpr,list_tail,{reduce,16}]; +table(list, number) -> [sexpr,list_tail,{reduce,16}]; +table(list, string) -> [sexpr,list_tail,{reduce,16}]; +table(list, symbol) -> [sexpr,list_tail,{reduce,16}]; +table(form, '#\'') -> [sexpr,{reduce,0}]; +table(form, '#(') -> [sexpr,{reduce,0}]; +table(form, '#.') -> [sexpr,{reduce,0}]; +table(form, '#B(') -> [sexpr,{reduce,0}]; +table(form, '#M(') -> [sexpr,{reduce,0}]; +table(form, '\'') -> [sexpr,{reduce,0}]; +table(form, '(') -> [sexpr,{reduce,0}]; +table(form, ',') -> [sexpr,{reduce,0}]; +table(form, ',@') -> [sexpr,{reduce,0}]; +table(form, '[') -> [sexpr,{reduce,0}]; +table(form, '`') -> [sexpr,{reduce,0}]; +table(form, binary) -> [sexpr,{reduce,0}]; +table(form, number) -> [sexpr,{reduce,0}]; +table(form, string) -> [sexpr,{reduce,0}]; +table(form, symbol) -> [sexpr,{reduce,0}]; +table(proper_list, '#\'') -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, '#(') -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, '#.') -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, '#B(') -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, '#M(') -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, ')') -> [{reduce,22}]; +table(proper_list, '\'') -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, '(') -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, ',') -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, ',@') -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, '[') -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, '`') -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, binary) -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, number) -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, string) -> [sexpr,proper_list,{reduce,21}]; +table(proper_list, symbol) -> [sexpr,proper_list,{reduce,21}]; +table(_, _) -> error. -pair_list([A,B|L]) -> [{A,B}|pair_list(L)]; -pair_list([]) -> []. +%% The reductions, we are naive and straight forward here. +reduce(0, [__1|__Vs]) -> [ begin __1 end | __Vs]; +reduce(1, [__1|__Vs]) -> [ begin value (__1) end | __Vs]; +reduce(2, [__1|__Vs]) -> [ begin value (__1) end | __Vs]; +reduce(3, [__1|__Vs]) -> [ begin value (__1) end | __Vs]; +reduce(4, [__1|__Vs]) -> [ begin value (__1) end | __Vs]; +reduce(5, [__1|__Vs]) -> [ begin make_fun (value (__1)) end | __Vs]; +reduce(6, [__2,__1|__Vs]) -> [ begin eval_expr (line (__1), __2) end | __Vs]; +reduce(7, [__2,__1|__Vs]) -> [ begin [quote, __2] end | __Vs]; +reduce(8, [__2,__1|__Vs]) -> [ begin [backquote, __2] end | __Vs]; +reduce(9, [__2,__1|__Vs]) -> [ begin [comma, __2] end | __Vs]; +reduce(10, [__2,__1|__Vs]) -> [ begin ['comma-at', __2] end | __Vs]; +reduce(11, [__3,__2,__1|__Vs]) -> [ begin __2 end | __Vs]; +reduce(12, [__3,__2,__1|__Vs]) -> [ begin __2 end | __Vs]; +reduce(13, [__3,__2,__1|__Vs]) -> [ begin list_to_tuple (__2) end | __Vs]; +reduce(14, [__3,__2,__1|__Vs]) -> [ begin make_bin (line (__1), __2) end | __Vs]; +reduce(15, [__3,__2,__1|__Vs]) -> [ begin make_map (line (__1), __2) end | __Vs]; +reduce(16, [__2,__1|__Vs]) -> [ begin [__1 | __2] end | __Vs]; +reduce(17, __Vs) -> [ begin [] end | __Vs]; +reduce(18, [__2,__1|__Vs]) -> [ begin [__1 | __2] end | __Vs]; +reduce(19, [__2,__1|__Vs]) -> [ begin __2 end | __Vs]; +reduce(20, __Vs) -> [ begin [] end | __Vs]; +reduce(21, [__2,__1|__Vs]) -> [ begin [__1 | __2] end | __Vs]; +reduce(22, __Vs) -> [ begin [] end | __Vs]; +reduce(_, _) -> error(function_clause). %% format_error(Error) -> String. %% Format errors to printable string. -format_error({missing,Tok}) -> - io_lib:fwrite("missing ~p", [Tok]); +format_error(missing_token) -> "missing token"; format_error({illegal,What}) -> - io_lib:fwrite("illegal ~p", [What]). + io_lib:fwrite("illegal ~p", [What]); +format_error(Message) -> + case io_lib:deep_char_list(Message) of + true -> Message; + false -> io_lib:write(Message) + end. + +%% return_error(Error). +%% To be used in grammar files to throw an error message to the +%% parser toplevel. Doesn't have to be exported! + +-compile({nowarn_unused_function, return_error/2}). +-spec return_error(integer(), any()) -> no_return(). + +return_error(Line, Message) -> + throw({spell1_error, {Line, ?MODULE, Message}}).
View file
lfe-1.0.tar.gz/src/lfe_parse.spell1
Added
@@ -0,0 +1,109 @@ +%% -*- mode: erlang -*- +%% Copyright (c) 2008-2015 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% We define the grammar with the same form as for yecc. + +Terminals + symbol number string binary fun '(' ')' '[' ']' '.' '\'' '`' ',' ',@' + '#(' '#B(' '#M(' '#.' '#\''. + +Nonterminals form sexpr list list_tail proper_list . + +Rootsymbol form. + +form -> sexpr : '$1'. +sexpr -> symbol : value('$1'). +sexpr -> number : value('$1'). +sexpr -> string : value('$1'). +sexpr -> binary : value('$1'). +sexpr -> '#\'' : make_fun(value('$1')). +sexpr -> '#.' sexpr : eval_expr(line('$1'), '$2'). +sexpr -> '\'' sexpr : [quote,'$2']. +sexpr -> '`' sexpr : [backquote,'$2']. +sexpr -> ',' sexpr : [comma,'$2']. +sexpr -> ',@' sexpr : ['comma-at','$2']. +sexpr -> '(' list ')' : '$2'. +sexpr -> '[' list ']' : '$2'. +sexpr -> '#(' proper_list ')' : list_to_tuple('$2'). +sexpr -> '#B(' proper_list ')' : + make_bin(line('$1'), '$2'). +sexpr -> '#M(' proper_list ')' : + make_map(line('$1'), '$2'). +list -> sexpr list_tail : ['$1'|'$2']. +list -> '$empty' : []. +list_tail -> sexpr list_tail : ['$1'|'$2']. +list_tail -> '.' sexpr : '$2'. +list_tail -> '$empty' : []. +proper_list -> sexpr proper_list : ['$1'|'$2']. +proper_list -> '$empty' : []. + +%% Extra Erlang code. +Erlang code. + +-define(CATCH(E, Error), try E catch _:_ -> Error end). + +%% For backwards compatibility +-export([sexpr/1,sexpr/2]). + +sexpr(Ts) -> form(Ts). +sexpr(Cont, Ts) -> form(Cont, Ts). + +%% make_fun(String) -> FunList. +%% Convert a fun string to a fun sexpr. +%% "F/A" -> ['fun', F, A]. +%% "M:F/A" -> ['fun', M, F, A]. + +make_fun("=:=/2") -> + ['fun', '=:=', 2]; +make_fun(FunStr) -> + J = string:rchr(FunStr, $/), + A = list_to_integer(string:substr(FunStr, J + 1)), + case string:chr(FunStr, $:) of + 0 -> + F = list_to_atom(string:substr(FunStr, 1, J - 1)), + ['fun', F, A]; + I -> + F = list_to_atom(string:substr(FunStr, I + 1, J - I - 1)), + M = list_to_atom(string:substr(FunStr, 1, I - 1)), + ['fun', M, F, A] + end. + +%% make_bin(Line, Segments) -> Binary. +%% Make a binary from the segments. + +make_bin(Line, Segs) -> + ?CATCH(lfe_eval:expr([binary|Segs]), + return_error(Line, "bad binary")). + +%% make_map(Line, Elements) -> Map. +%% Make a map from the key/value elements. + +make_map(Line, Es) -> + ?CATCH(maps:from_list(pair_list(Es)), + return_error(Line, "bad map")). + +%% pair_list(List) -> [{A,B}]. +%% Generate a list of tuple pairs from the elements. An error if odd +%% number of elements in list. + +pair_list([A,B|L]) -> [{A,B}|pair_list(L)]; +pair_list([]) -> []. + +%% eval_expr(Line, Expr) -> Val. +%% Evaluate #. expression. + +eval_expr(Line, Expr) -> + ?CATCH(lfe_eval:expr(Expr), + return_error(Line, "bad #. expression")).
View file
lfe-0.9.2.tar.gz/src/lfe_pmod.erl -> lfe-1.0.tar.gz/src/lfe_pmod.erl
Changed
@@ -1,4 +1,4 @@ -%% Copyright (c) 2008-2013 Robert Virding +%% Copyright (c) 2008-2015 Robert Virding %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -23,109 +23,111 @@ %% -compile(export_all). -import(lists, [member/2,keysearch/3, - all/2,map/2,foldl/3,foldr/3,mapfoldl/3,mapfoldr/3, - concat/1]). + all/2,map/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]). -import(lfe_env, [new/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]). + add_fbinding/4,add_fbindings/2,get_fbinding/3, + add_ibinding/5,get_gbinding/3]). -include("lfe_comp.hrl"). --define(Q(E), [quote,E]). %For quoting +-define(Q(E), [quote,E]). %For quoting --record(param, {mod=[], %Module name - pars=[], %Module parameters - extd=[], %Extends - this=[], %This match pattern - env=[]}). %Environment +-record(param, {mod=[], %Module name + pars=[], %Module parameters + extd=[], %Extends + this=[], %This match pattern + env=[]}). %Environment -%% module(Forms, CompInfo) -> Forms. +%% module(ModuleForms, CompInfo) -> {ModuleName,ModuleForms}. %% Expand the forms to handle parameterised modules if necessary, %% otherwise just pass forms straight through. -module([{['define-module',[_|_]|_],_}|_]=Fs, Ci) -> - expand_module(Fs, Ci#cinfo.opts); -module(Fs, _) -> Fs. %Normal module, do nothing +module([{['define-module',[Mod|_]|_],_}|_]=Fs, Ci) -> + {Mod,expand_module(Fs, Ci#cinfo.opts)}; +module([{['define-module',Mod|_],_}|_]=Fs, _) -> + %% Normal module, do nothing. + {Mod,Fs}; +module(Fs, _) -> {[],Fs}. %Not a module, do nothing expand_module(Fs0, Opts) -> St0 = #param{env=lfe_env:new()}, - {Fs1,St1} = lfe_lib:proc_forms(fun exp_form/3, Fs0, St0), + {Acc,St1} = lists:foldl(fun exp_form/2, {[],St0}, Fs0), + Fs1 = lists:reverse(Acc), debug_print("#param: ~p\n", [{Fs1,St1}], Opts), %% {ok,_} = lfe_lint:module(Fs1, Opts), Fs1. -exp_form(['define-module',[Mod|Ps]|Mdef0], L, St0) -> +exp_form({['define-module',[Mod|Ps]|Mdef0],L}, {Acc,St0}) -> %% Save the good bits and define new/N and instance/N. St1 = St0#param{mod=Mod,pars=Ps}, {Mdef1,St2} = exp_mdef(Mdef0, St1), {Nl,Il} = case St2#param.extd of - [] -> - {[lambda,Ps,[instance|Ps]], - [lambda,Ps,[tuple,?Q(Mod)|Ps]]}; - Ex -> - {[lambda,Ps,[instance,[call,?Q(Ex),?Q(new)|Ps]|Ps]], - [lambda,[base|Ps],[tuple,?Q(Mod),base|Ps]]} - end, + [] -> + {[lambda,Ps,[instance|Ps]], + [lambda,Ps,[tuple,?Q(Mod)|Ps]]}; + Ex -> + {[lambda,Ps,[instance,[call,?Q(Ex),?Q(new)|Ps]|Ps]], + [lambda,[base|Ps],[tuple,?Q(Mod),base|Ps]]} + end, New = ['define-function',new,Nl], Inst = ['define-function',instance,Il], %% Fix this match pattern depending on extends. St3 = case St2#param.extd of - [] -> St2#param{this=['=',this,[tuple,'_'|Ps]]}; - _ -> St2#param{this=['=',this,[tuple,'_',base|Ps]]} - end, - {[{['define-module',Mod|Mdef1],L}, - {New,L},{Inst,L}],St3}; -exp_form(['define-function',F,Def0], L, St) -> + [] -> St2#param{this=['=',this,[tuple,'_'|Ps]]}; + _ -> St2#param{this=['=',this,[tuple,'_',base|Ps]]} + end, + {[{{New,L},{Inst,L},['define-module',Mod|Mdef1],L}|Acc],St3}; +exp_form({['define-function',F,Def0],L}, {Acc,St}) -> Def1 = exp_function(Def0, St), - {[{['define-function',F,Def1],L}],St}; -exp_form(F, L, St) -> - {[{F,L}],St}. + {[{['define-function',F,Def1],L}|Acc],St}; +exp_form({F,L}, {Acc,St}) -> + {[{F,L}|Acc],St}. debug_print(Format, Args, Opts) -> case member(debug_print, Opts) of - true -> lfe_io:format(Format, Args); - false -> ok + true -> lfe_io:format(Format, Args); + false -> ok end. exp_mdef(Mdef0, St0) -> %% Pre-scan to pick up 'extends'. St1 = foldl(fun ([extends,M], S) -> S#param{extd=M}; - (_, S) -> S - end, St0, Mdef0), + (_, S) -> S + end, St0, Mdef0), %% Now do "real" processing. {Mdef1,St2} = mapfoldl(fun ([export,all], S) -> {[export,all],S}; - ([export|Es0], S) -> - %% Add 1 for this to each export. - Es1 = map(fun ([F,A]) -> [F,A+1] end, Es0), - {[export|Es1],S}; - ([import|Is], S0) -> - S1 = collect_imps(Is, S0), - {[import|Is],S1}; - (Md, S) -> {Md,S} - end, St1, Mdef0 ++ [[abstract,true]]), + ([export|Es0], S) -> + %% Add 1 for this to each export. + Es1 = map(fun ([F,A]) -> [F,A+1] end, Es0), + {[export|Es1],S}; + ([import|Is], S0) -> + S1 = collect_imps(Is, S0), + {[import|Is],S1}; + (Md, S) -> {Md,S} + end, St1, Mdef0 ++ [[abstract,true]]), %% Add export for new/N and instance/N. Ar = length(St2#param.pars), Iar = case St2#param.extd of - [] -> Ar; - _ -> Ar+1 - end, + [] -> Ar; + _ -> Ar+1 + end, {[[export,[new,Ar],[instance,Iar]]|Mdef1],St2}. collect_imps(Is, St) -> foldl(fun (['from',M|Fs], S) -> - Env = foldl(fun ([F,Ar], E) -> - add_ibinding(M, F, Ar, F, E) end, - S#param.env, Fs), - S#param{env=Env}; - (['rename',M|Fs], S) -> - Env = foldl(fun ([[F,Ar],R], E) -> - add_ibinding(M, F, Ar, R, E) end, - S#param.env, Fs), - S#param{env=Env} - end, St, Is). + Env = foldl(fun ([F,Ar], E) -> + add_ibinding(M, F, Ar, F, E) end, + S#param.env, Fs), + S#param{env=Env}; + (['rename',M|Fs], S) -> + Env = foldl(fun ([[F,Ar],R], E) -> + add_ibinding(M, F, Ar, R, E) end, + S#param.env, Fs), + S#param{env=Env} + end, St, Is). %% exp_function(Lambda, State) -> Lambda. %% The resultant code matches the arguments in two steps: first the @@ -195,12 +197,12 @@ exp_expr([Fun|Es], Env) when is_atom(Fun) -> Ar = length(Es), case get_fbinding(Fun, Ar, Env) of - {yes,_,_} -> [Fun|exp_list(Es, Env)]; %Imported or Bif - {yes,local} -> [Fun|exp_list(Es, Env)]; %Local function - _ -> [Fun|exp_list(Es, Env) ++ [this]] + {yes,_,_} -> [Fun|exp_list(Es, Env)]; %Imported or Bif + {yes,local} -> [Fun|exp_list(Es, Env)]; %Local function + _ -> [Fun|exp_list(Es, Env) ++ [this]] end; exp_expr(E, _) when is_atom(E) -> E; -exp_expr(E, _) -> E. %Atoms expand to themselves. +exp_expr(E, _) -> E. %Atoms expand to themselves. exp_list(Es, Env) -> map(fun (E) -> exp_expr(E, Env) end, Es). @@ -214,8 +216,8 @@ exp_bitseg([N|Specs0], Env) -> %% The only bitspec that needs expanding is size. Specs1 = map(fun ([size,S]) -> [size,exp_expr(S, Env)]; - (S) -> S - end, Specs0), + (S) -> S + end, Specs0), [exp_expr(N, Env)|Specs1]; exp_bitseg(N, Env) -> exp_expr(N, Env). @@ -233,8 +235,8 @@ exp_let([Vbs|Body], Env) -> Evbs = map(fun ([P,E]) -> [P,exp_expr(E, Env)]; - ([P,G,E]) -> [P,G,exp_expr(E, Env)] - end, Vbs), + ([P,G,E]) -> [P,G,exp_expr(E, Env)] + end, Vbs), [Evbs|exp_body(Body, Env)]. %% exp_let_function(FletBody, Env) -> FletBody. @@ -244,14 +246,14 @@ exp_let_function([Fbs|Body], Env0) -> Efbs = map(fun ([F,Def]) -> [F,exp_expr(Def, Env0)] end, Fbs), Env1 = foldl(fun ([F,Def], E) -> - add_fbinding(F,lambda_arity(Def),local,E) - end, Env0, Fbs), + add_fbinding(F,lambda_arity(Def),local,E) + end, Env0, Fbs), [Efbs|exp_body(Body, Env1)]. exp_letrec_function([Fbs|Body], Env0) -> Env1 = foldl(fun ([F,Def], E) -> - add_fbinding(F,lambda_arity(Def),local,E) - end, Env0, Fbs), + add_fbinding(F,lambda_arity(Def),local,E) + end, Env0, Fbs), Efbs = map(fun ([F,Def]) -> [F,exp_expr(Def, Env1)] end, Fbs), [Efbs|exp_body(Body, Env1)]. @@ -273,9 +275,9 @@ exp_try([E|Body], Env) -> [exp_expr(E, Env)| map(fun (['case'|Cls]) -> ['case'|exp_clauses(Cls, Env)]; - (['catch'|Cls]) -> ['catch'|exp_clauses(Cls, Env)]; - (['after'|B]) -> ['after'|exp_body(B, Env)] - end, Body)]. + (['catch'|Cls]) -> ['catch'|exp_clauses(Cls, Env)]; + (['after'|B]) -> ['after'|exp_body(B, Env)] + end, Body)]. exp_call([M,F|As], Env) -> [exp_expr(M, Env),exp_expr(F, Env)|exp_list(As, Env)].
View file
lfe-0.9.2.tar.gz/src/lfe_scan.xrl -> lfe-1.0.tar.gz/src/lfe_scan.xrl
Changed
@@ -21,73 +21,87 @@ O = [0-7] D = [0-9] H = [0-9a-fA-F] -B36 = [0-9a-zA-Z] +B36 = [0-9a-zA-Z] U = [A-Z] L = [a-z] A = ({U}|{L}) -DEL = [][()}{";\000-\s] -SYM = [^][()}{";\000-\s] -SSYM = [^][()}{|";#`',\000-\s] -WS = ([\000-\s]|;[^\n]*) +DEL = [][()}{";\000-\s] +SYM = [^][()}{";\000-\s\177-\237] +SSYM = [^][()}{"|;#`',\000-\s\177-\237] +WS = ([\000-\s]|;[^\n]*) Rules. %% Bracketed Comments using #| foo |# -#\|[^\|]*\|+([^#\|][^\|]*\|+)*# : block_comment(string:substr(TokenChars, 3)). +#{D}*\|[^\|]*\|+([^#\|][^\|]*\|+)*# : + block_comment(string:substr(TokenChars, 3)). + %% Separators -#[bB]\( : {token,{'#B(',TokenLine}}. -#[mM]\( : {token,{'#M(',TokenLine}}. -#\( : {token,{'#(',TokenLine}}. -#` : {token,{'#`',TokenLine}}. -#; : {token,{'#;',TokenLine}}. -#, : {token,{'#,',TokenLine}}. -#,@ : {token,{'#,@',TokenLine}}. ' : {token,{'\'',TokenLine}}. ` : {token,{'`',TokenLine}}. , : {token,{',',TokenLine}}. ,@ : {token,{',@',TokenLine}}. \. : {token,{'.',TokenLine}}. [][()}{] : {token,{list_to_atom(TokenChars),TokenLine}}. + +#{D}*[bB]\( : {token,{'#B(',TokenLine}}. +#{D}*[mM]\( : {token,{'#M(',TokenLine}}. +#{D}*\( : {token,{'#(',TokenLine}}. +#{D}*\. : {token,{'#.',TokenLine}}. + +#{D}*` : {token,{'#`',TokenLine}}. +#{D}*; : {token,{'#;',TokenLine}}. +#{D}*, : {token,{'#,',TokenLine}}. +#{D}*,@ : {token,{'#,@',TokenLine}}. + %% Characters -#\\(x{H}+|.) : char_token(string:substr(TokenChars, 3), TokenLine). +#{D}*\\(x{H}+|.) : char_token(skip_past(TokenChars, $\\, $\\), TokenLine). + +%% Based numbers +#{D}*\*{SYM}+ : base_token(skip_past(TokenChars, $*, $*), 2, TokenLine). +#{D}*[bB]{SYM}+ : base_token(skip_past(TokenChars, $b, $B), 2, TokenLine). +#{D}*[oO]{SYM}+ : base_token(skip_past(TokenChars, $o, $O), 8, TokenLine). +#{D}*[dD]{SYM}+ : base_token(skip_past(TokenChars, $d, $D), 10, TokenLine). +#{D}*[xX]{SYM}+ : base_token(skip_past(TokenChars, $x, $X), 16, TokenLine). +#{D}*[rR]{SYM}+ : + %% Scan over digit chars to get base. + {Base,[_|Ds]} = base1(tl(TokenChars), 10, 0), + base_token(Ds, Base, TokenLine). + %% String -"(\\x{H}+;|\\.|[^"])*" : - %% Strip quotes. - S = string:substr(TokenChars, 2, TokenLen - 2), - {token,{string,TokenLine,chars(S)}}. +"(\\x{H}+;|\\.|[^"\\])*" : + %% Strip quotes. + S = string:substr(TokenChars, 2, TokenLen - 2), + {token,{string,TokenLine,chars(S)}}. +%% Binary string +#"(\\x{H}+;|\\.|[^"\\])*" : + %% Strip quotes. + S = string:substr(TokenChars, 3, TokenLen - 3), + Bin = unicode:characters_to_binary(chars(S), utf8, utf8), + {token,{binary,TokenLine,Bin}}. %% Symbols -\|(\\x{H}+;|\\.|[^|])*\| : - %% Strip quotes. - S = string:substr(TokenChars, 2, TokenLen - 2), - symbol_token(chars(S), TokenLine). +\|(\\x{H}+;|\\.|[^|\\])*\| : + %% Strip quotes. + S = string:substr(TokenChars, 2, TokenLen - 2), + symbol_token(chars(S), TokenLine). %% Funs -#'{SSYM}{SYM}*/{D}+ : - %% Strip sharpsign single-quote. - FunStr = string:substr(TokenChars,3), - {token,{'#\'',TokenLine,FunStr}}. -%% Based numbers -#[bB]{B}+ : base_token(string:substr(TokenChars, 3), 2, TokenLine). -#[oO]{O}+ : base_token(string:substr(TokenChars, 3), 8, TokenLine). -#[dD]{D}+ : base_token(string:substr(TokenChars, 3), 10, TokenLine). -#[xX]{H}+ : base_token(string:substr(TokenChars, 3), 16, TokenLine). -#([0]?[2-9]|[12][0-9]|3[0-6])[rR]{B36}+ : - %% Have to scan all possible digit chars and fail if wrong. - {Base,[_|Ds]} = base1(string:substr(TokenChars, 2), 10, 0), - base_token(Ds, Base, TokenLine). - +#'{SSYM}{SYM}*/{D}+ : + %% Strip sharpsign single-quote. + FunStr = string:substr(TokenChars,3), + {token,{'#\'',TokenLine,FunStr}}. %% Atoms -[+-]?{D}+ : - case catch {ok,list_to_integer(TokenChars)} of - {ok,I} -> {token,{number,TokenLine,I}}; - _ -> {error,"illegal integer"} - end. +[+-]?{D}+ : + case catch {ok,list_to_integer(TokenChars)} of + {ok,I} -> {token,{number,TokenLine,I}}; + _ -> {error,"illegal integer"} + end. [+-]?{D}+\.{D}+([eE][+-]?{D}+)? : - case catch {ok,list_to_float(TokenChars)} of - {ok,F} -> {token,{number,TokenLine,F}}; - _ -> {error,"illegal float"} - end. + case catch {ok,list_to_float(TokenChars)} of + {ok,F} -> {token,{number,TokenLine,F}}; + _ -> {error,"illegal float"} + end. {SSYM}{SYM}* : - symbol_token(TokenChars, TokenLine). -{WS}+ : skip_token. + symbol_token(TokenChars, TokenLine). +{WS}+ : skip_token. Erlang code. %% Copyright (c) 2008-2013 Robert Virding @@ -108,25 +122,54 @@ %% Author : Robert Virding %% Purpose : Token definitions for Lisp Flavoured Erlang. +-export([start_symbol_char/1,symbol_char/1]). + -import(string, [substr/2,substr/3]). +%% start_symbol_char(Char) -> true | false. +%% symbol_char(Char) -> true | false. +%% Define start symbol chars and symbol chars. + +start_symbol_char($#) -> false; +start_symbol_char($`) -> false; +start_symbol_char($') -> false; %' +start_symbol_char($,) -> false; +start_symbol_char($|) -> false; %Symbol quote character +start_symbol_char(C) -> symbol_char(C). + +symbol_char($() -> false; +symbol_char($)) -> false; +symbol_char($[) -> false; +symbol_char($]) -> false; +symbol_char(${) -> false; +symbol_char($}) -> false; +symbol_char($") -> false; +symbol_char($;) -> false; +symbol_char(C) -> ((C > $\s) and (C =< $~)) orelse (C > $\240). + %% symbol_token(Chars, Line) -> {token,{symbol,Line,Symbol}} | {error,E}. -%% Build a symbol from list of legal characters, else error. +%% Build a symbol from list of legal characters, else error. symbol_token(Cs, L) -> case catch {ok,list_to_atom(Cs)} of - {ok,S} -> {token,{symbol,L,S}}; - _ -> {error,"illegal symbol"} + {ok,S} -> {token,{symbol,L,S}}; + _ -> {error,"illegal symbol"} end. %% base_token(Chars, Base, Line) -> Integer. -%% Convert a string of Base characters into a number. We know that -%% the strings only contain the correct character. +%% Convert a string of Base characters into a number. We only allow +%% base betqeen 2 and 36, and an optional sign character first. + +base_token(_, B, _) when B < 2; B > 36 -> + {error,"illegal number base"}; +base_token([$+|Cs], B, L) -> base_token(Cs, B, +1, L); +base_token([$-|Cs], B, L) -> base_token(Cs, B, -1, L); +base_token(Cs, B, L) -> base_token(Cs, B, +1, L). -base_token(Cs, B, L) -> +base_token(Cs, B, S, L) -> case base1(Cs, B, 0) of - {N,[]} -> {token,{number,L,N}}; - {_,_} -> {error,"illegal based number"} + {N,[]} -> {token,{number,L,S*N}}; + {_,_} -> {error,"illegal based number"} end. base1([C|Cs], Base, SoFar) when C >= $0, C =< $9, C < Base + $0 -> @@ -135,65 +178,79 @@ base1([C|Cs], Base, SoFar) when C >= $a, C =< $z, C < Base + $a - 10 -> Next = SoFar * Base + (C - $a + 10), base1(Cs, Base, Next); - base1([C|Cs], Base, SoFar) when C >= $A, C =< $Z, C < Base + $A - 10 -> Next = SoFar * Base + (C - $A + 10), base1(Cs, Base, Next); base1([C|Cs], _Base, SoFar) -> {SoFar,[C|Cs]}; base1([], _Base, N) -> {N,[]}. +-define(IS_UNICODE(C), ((C >= 0) and (C =< 16#10FFFF))). + %% char_token(InputChars, Line) -> {token,{number,L,N}} | {error,E}. -%% Convert an input string into the corresponding character. We know -%% that the input string is correct. +%% Convert an input string into the corresponding character. For a +%% sequence of hex characters we check resultant is code is in the +%% unicode range. char_token([$x,C|Cs], L) -> case base1([C|Cs], 16, 0) of - {N,[]} -> {token,{number,L,N}}; - _ -> {error,"illegal character"} + {N,[]} when ?IS_UNICODE(N) -> {token,{number,L,N}}; + _ -> {error,"illegal character"} end; char_token([C], L) -> {token,{number,L,C}}. %% chars(InputChars) -> Chars. -%% Convert an input string into the corresponding string -%% characters. We know that the input string is correct. +%% Convert an input string into the corresponding string characters. +%% We know that the input string is correct. chars([$\\,$x,C|Cs0]) -> case hex_char(C) of - true -> - case base1([C|Cs0], 16, 0) of - {N,[$;|Cs1]} -> [N|chars(Cs1)]; - _Other -> [escape_char($x)|chars([C|Cs0])] - end; - false -> [escape_char($x)|chars([C|Cs0])] + true -> + case base1([C|Cs0], 16, 0) of + {N,[$;|Cs1]} -> [N|chars(Cs1)]; + _Other -> [escape_char($x)|chars([C|Cs0])] + end; + false -> [escape_char($x)|chars([C|Cs0])] end; chars([$\\,C|Cs]) -> [escape_char(C)|chars(Cs)]; chars([C|Cs]) -> [C|chars(Cs)]; chars([]) -> []. -%% Block Comment: -%% Provide a sensible error when people attempt to include nested -%% comments because currently the parser cannot process them without -%% a rebuild. But simply exploding on a '#|' is not going to be -%% that helpful. -block_comment(TokenChars) -> - %% Check we're not opening another comment block. - case string:str(TokenChars, "#|") of - 0 -> skip_token; %% No nesting found - _ -> {error, "illegal nested block comment"} - end. - hex_char(C) when C >= $0, C =< $9 -> true; hex_char(C) when C >= $a, C =< $f -> true; hex_char(C) when C >= $A, C =< $F -> true; hex_char(_) -> false. -escape_char($n) -> $\n; %\n = LF -escape_char($r) -> $\r; %\r = CR +escape_char($b) -> $\b; %\b = BS escape_char($t) -> $\t; %\t = TAB +escape_char($n) -> $\n; %\n = LF escape_char($v) -> $\v; %\v = VT -escape_char($b) -> $\b; %\b = BS escape_char($f) -> $\f; %\f = FF +escape_char($r) -> $\r; %\r = CR escape_char($e) -> $\e; %\e = ESC escape_char($s) -> $\s; %\s = SPC escape_char($d) -> $\d; %\d = DEL escape_char(C) -> C. + +%% Block Comment: +%% Provide a sensible error when people attempt to include nested +%% comments because currently the parser cannot process them without +%% a rebuild. But simply exploding on a '#|' is not going to be that +%% helpful. + +block_comment(TokenChars) -> + %% Check we're not opening another comment block. + case string:str(TokenChars, "#|") of + 0 -> skip_token; %% No nesting found + _ -> {error, "illegal nested block comment"} + end. + +%% skip_until(String, Char1, Char2) -> String. +%% skip_past(String, Char1, Char2) -> String. + +%% skip_until([C|_]=Cs, C1, C2) when C =:= C1 ; C =:= C2 -> Cs; +%% skip_until([_|Cs], C1, C2) -> skip_until(Cs, C1, C2); +%% skip_until([], _, _) -> []. + +skip_past([C|Cs], C1, C2) when C =:= C1 ; C =:= C2 -> Cs; +skip_past([_|Cs], C1, C2) -> skip_past(Cs, C1, C2); +skip_past([], _, _) -> [].
View file
lfe-0.9.2.tar.gz/src/lfe_shell.erl -> lfe-1.0.tar.gz/src/lfe_shell.erl
Changed
@@ -30,13 +30,13 @@ run_script/2,run_script/3,run_string/2,run_string/3]). %% The shell commands which generally callable. --export([c/1,c/2,cd/1,ec/1,ec/2,help/0,i/0,i/1,l/1,ls/1,m/0,m/1, - pid/3,p/1,pp/1,pwd/0,q/0,regs/0,exit/0]). +-export([c/1,c/2,cd/1,ec/1,ec/2,help/0,i/0,i/1,l/1,ls/1,clear/0,m/0,m/1, + pid/3,p/1,pp/1,pwd/0,q/0,flush/0,regs/0,exit/0]). -import(lfe_env, [new/0,add_env/2, add_vbinding/3,add_vbindings/2,is_vbound/2,get_vbinding/2, fetch_vbinding/2,del_vbinding/2, - add_fbinding/4,add_fbindings/3,get_fbinding/3,add_ibinding/5, + add_fbinding/4,add_fbindings/2,get_fbinding/3,add_ibinding/5, get_gbinding/3,add_mbinding/3]). -import(orddict, [store/3,find/2]). @@ -45,6 +45,12 @@ -include("lfe.hrl"). +%% Colours for the LFE banner +-define(RED(Str), "\e[31m" ++ Str ++ "\e[0m"). +-define(GRN(Str), "\e[1;32m" ++ Str ++ "\e[0m"). +-define(YLW(Str), "\e[1;33m" ++ Str ++ "\e[0m"). +-define(BLU(Str), "\e[1;34m" ++ Str ++ "\e[0m"). + %% -compile([export_all]). %% Implement our own lists functions to get around stacktrace printing @@ -89,11 +95,12 @@ server(lfe_env:new()); server(Env) -> process_flag(trap_exit, true), %Must trap exists - io:fwrite("LFE Shell V~s (abort with ^G)\n", - [erlang:system_info(version)]), + io:fwrite(get_banner()), %% Create a default base env of predefined shell variables with %% default nil bindings and basic shell macros. St = new_state("lfe", [], Env), + %% Set shell io to use LFE expand in edlin, ignore error. + io:setopts([{expand_fun,fun (B) -> lfe_edlin_expand:expand(B) end}]), Eval = start_eval(St), %Start an evaluator server_loop(Eval, St). %Run the loop @@ -186,6 +193,28 @@ read_expression_1(Rdr, start_eval(St), St) end. +get_banner() -> + [io_lib:format( + ?GRN(" ..-~~") ++ ?YLW(".~~_") ++ ?GRN("~~---..") ++ "\n" ++ + ?GRN(" ( ") ++ ?YLW("\\\\") ++ ?GRN(" )") ++ " | A Lisp-2+ on the Erlang VM\n" ++ + ?GRN(" |`-.._") ++ ?YLW("/") ++ ?GRN("_") ++ ?YLW("\\\\") ++ ?GRN("_.-';") ++ " | Type " ++ ?GRN("(help)") ++ " for usage info.\n" ++ + ?GRN(" | ") ++ ?RED("g") ++ ?GRN(" (_ \\") ++ " | \n" ++ + ?GRN(" | ") ++ ?RED("n") ++ ?GRN(" | |") ++ " | Docs: " ++ ?BLU("http://docs.lfe.io/") ++ " \n" ++ + ?GRN(" ( ") ++ ?RED("a") ++ ?GRN(" / /") ++ " | Source: " ++ ?BLU("http://github.com/rvirding/lfe") ++ "\n" ++ + ?GRN(" \\ ") ++ ?RED("l") ++ ?GRN(" (_/") ++ " | \n" ++ + ?GRN(" \\ ") ++ ?RED("r") ++ ?GRN(" /") ++ " | LFE v~s ~s\n" ++ + ?GRN(" `-") ++ ?RED("E") ++ ?GRN("___.-'") ++ "\n\n", [get_lfe_version(), get_abort_message()])]. + +get_abort_message() -> + %% We can update this later to check for env variable settings for + %% shells that require a different control character to abort, such + %% as jlfe. + "(abort with ^G)". + +get_lfe_version() -> + {ok, [App]} = file:consult(code:where_is_file("lfe.app")), + proplists:get_value(vsn, element(3, App)). + %% new_state(ScriptName, Args [,Env]) -> State. %% Generate a new shell state with all the default functions, macros %% and variables. @@ -221,16 +250,17 @@ add_vbinding('$ENV', Env2, Env2). add_shell_functions(Env0) -> - Fs = [{help,0,[lambda,[],[':',lfe_shell,help]]}, + Fs = [{cd,1,[lambda,[d],[':',lfe_shell,cd,d]]}, + {help,0,[lambda,[],[':',lfe_shell,help]]}, {i,0,[lambda,[],[':',lfe_shell,i]]}, {i,1,[lambda,[ps],[':',lfe_shell,i,ps]]}, - %% {m,0,[lambda,[],[':',lfe_shell,m]]}, - %% {m,1,[lambda,[ms],[':',lfe_shell,m,ms]]}, + {clear,0,[lambda,[],[':',lfe_shell,clear]]}, {pid,3,[lambda,[i,j,k],[':',lfe_shell,pid,i,j,k]]}, {p,1,[lambda,[e],[':',lfe_shell,p,e]]}, {pp,1,[lambda,[e],[':',lfe_shell,pp,e]]}, {pwd,0,[lambda,[],[':',lfe_shell,pwd]]}, {q,0,[lambda,[],[':',lfe_shell,exit]]}, + {flush,0,[lambda,[],[':',lfe_shell,flush]]}, {regs,0,[lambda,[],[':',lfe_shell,regs]]}, {exit,0,[lambda,[],[':',lfe_shell,exit]]} ], @@ -242,13 +272,13 @@ add_shell_macros(Env0) -> %% We write macros in LFE and expand them with macro package. - Ms = [{c,[lambda,[args,'$ENV'],?BQ([':',lfe_shell,c,?UQ_S(args)])]}, - {ec,[lambda,[args,'$ENV'],?BQ([':',lfe_shell,ec,?UQ_S(args)])]}, - {l,[lambda,[args,'$ENV'],?BQ([':',lfe_shell,l,[list|?UQ(args)]])]}, - {ls,[lambda,[args,'$ENV'],?BQ([':',lfe_shell,ls,[list|?UQ(args)]])]}, + Ms = [{c,[lambda,[args,'$ENV'],?BQ([':',lfe_shell,c,?C_A(args)])]}, + {ec,[lambda,[args,'$ENV'],?BQ([':',lfe_shell,ec,?C_A(args)])]}, + {l,[lambda,[args,'$ENV'],?BQ([':',lfe_shell,l,[list|?C(args)]])]}, + {ls,[lambda,[args,'$ENV'],?BQ([':',lfe_shell,ls,[list|?C(args)]])]}, {m,['match-lambda', [[[],'$ENV'],?BQ([':',lfe_shell,m])], - [[ms,'$ENV'],?BQ([':',lfe_shell,m,[list|?UQ(ms)]])]]} + [[ms,'$ENV'],?BQ([':',lfe_shell,m,[list|?C(ms)]])]]} ], %% Any errors here will crash shell startup! Env1 = lfe_env:add_mbindings(Ms, Env0), @@ -286,7 +316,7 @@ {Value,St1} = eval_form(Form, St0#state{curr=Ce1}), %% Print the result, but only to depth 30. VS = lfe_io:prettyprint1(Value, 30), - io:requests([{put_chars,VS},nl]), + io:requests([{put_chars,unicode,VS},nl]), %% Update bindings. Ce2 = update_shell_vars(Form, Value, St1#state.curr), St2 = St1#state{curr=Ce2}, @@ -331,6 +361,9 @@ {[],St}, Eforms); eval_form_1(['extend-module'|_], St) -> %Maybe from macro expansion {[],St}; +eval_form_1(['eval-when-compile'|_], St) -> %Maybe from macro expansion + %% We can happily ignore this. + {[],St}; eval_form_1([set|Rest], St0) -> {Value,St1} = set(Rest, St0), {Value,St1}; @@ -378,39 +411,35 @@ Epat = lfe_macro:expand_expr_all(Pat, Ce), %Expand macros in pattern %% Special case to lint pattern. case lfe_lint:pattern(Epat, Ce) of - {ok,Ws} -> list_warnings(Ws); + {ok,_,Ws} -> list_warnings(Ws); {error,Es,Ws} -> list_errors(Es), list_warnings(Ws) end, - set_1([Epat|Rest], St). + set_1(Epat, Rest, St). -set_1([Pat,['when'|_]=G,Exp], #state{curr=Ce0}=St) -> +set_1(Pat, [['when'|_]=G,Exp], St) -> + set_1(Pat, [G], Exp, St); %Just the guard +set_1(Pat, [Exp], St) -> + set_1(Pat, [], Exp, St); %Empty body +set_1(_, _, _) -> erlang:error({bad_form,'set'}). + +set_1(Pat, Guard, Exp, #state{curr=Ce0}=St) -> Val = lfe_eval:expr(Exp, Ce0), %Evaluate expression - case lfe_eval:match_when(Pat, Val, [G], Ce0) of + case lfe_eval:match_when(Pat, Val, Guard, Ce0) of {yes,_,Bs} -> Ce1 = foldl(fun ({N,V}, E) -> add_vbinding(N, V, E) end, Ce0, Bs), {Val,St#state{curr=Ce1}}; no -> erlang:error({badmatch,Val}) - end; -set_1([Pat,Exp], #state{curr=Ce0}=St) -> - Val = lfe_eval:expr(Exp, Ce0), %Evaluate expression - case lfe_eval:match(Pat, Val, Ce0) of - {yes,Bs} -> - Ce1 = foldl(fun ({N,V}, E) -> add_vbinding(N, V, E) end, - Ce0, Bs), - {Val,St#state{curr=Ce1}}; - no -> erlang:error({badmatch,Val}) - end; -set_1(_, _) -> erlang:error({bad_form,'set'}). + end. %% unslurp(State) -> {ok,State}. %% slurp(File, State) -> {{ok,Mod},State}. -%% 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 current environment. We could not use the -%% compiler here as we need the macro environment. +%% Load in a file making all functions available. We call the +%% compiler directly and only add defined functions, macros are +%% lost. Any exported macros will be available in the +%% LFE-EXPAND-EXPORTED-MACRO/3 function. -record(slurp, {mod,imps=[]}). %For slurping @@ -426,48 +455,47 @@ slurp([File], St0) -> {ok,#state{curr=Ce0}=St1} = unslurp(St0), %Reset the environment Name = lfe_eval:expr(File, Ce0), %Get file name - case slurp_1(Name, Ce0) of + case slurp_file(Name, Ce0) of {ok,Mod,Ce1} -> %Set the new environment {{ok,Mod},St1#state{save=Ce0,curr=Ce1,slurp=true}}; error -> {error,St1} end. -slurp_1(Name, Ce) -> - case slurp_file(Name) of %Parse, expand and lint file - {ok,Fs,Fenv0,Ws} -> - slurp_warnings(Name, Ws), - Sl0 = #slurp{mod='-no-mod-',imps=[]}, +slurp_file(Name, Ce0) -> + case lfe_comp:file(Name, [binary,to_lint,return]) of + {ok,[{ok,Mod,Fs,Mws}|_],Ws} -> %Only do first module + slurp_warnings(Ws), + slurp_warnings(Mws), + Sl0 = #slurp{mod=Mod,imps=[]}, {Fbs,Sl1} = lfe_lib:proc_forms(fun collect_form/3, Fs, Sl0), %% Add imports to environment. - Fenv1 = foldl(fun ({M,Is}, Env) -> - foldl(fun ({{F,A},R}, E) -> - add_ibinding(M, F, A, R, E) - end, Env, Is) - end, Fenv0, Sl1#slurp.imps), - %% Get a new environment with all functions defined. - Fenv2 = lfe_eval:make_letrec_env(Fbs, Fenv1), - {ok,Sl1#slurp.mod,add_env(Fenv2, Ce)}; - {error,Es,Ws} -> - slurp_errors(Name, Es), - slurp_warnings(Name, Ws), + Ce1 = foldl(fun ({M,Is}, Env) -> + foldl(fun ({{F,A},R}, E) -> + add_ibinding(M, F, A, R, E) + end, Env, Is) + end, Ce0, Sl1#slurp.imps), + %% Add functions to environment. + Ce2 = foldl(fun ({N,Ar,Def}, Env) -> + lfe_eval:add_dynamic_func(N, Ar, Def, Env) + end, Ce1, Fbs), + {ok,Mod,Ce2}; + {error,Mews,Es,Ws} -> + slurp_errors(Es), + slurp_warnings(Ws), + %% Now the errors and warnings for each module. + foreach(fun ({error,Mes,Mws}) -> + slurp_errors(Mes), + slurp_warnings(Mws) + end, Mews), error end. -slurp_file(Name) -> - %% Parse, expand macros and lint file. - case lfe_io:parse_file(Name) of - {ok,Fs0} -> - case lfe_macro:expand_forms(Fs0, lfe_env:new()) of - {ok,Fs1,Fenv,_} -> - case lfe_lint:module(Fs1) of - {ok,Ws} -> {ok,Fs1,Fenv,Ws}; - {error,_,_}=Error -> Error - end; - {error,_,_}=Error -> Error - end; - {error,E} -> {error,[E],[]} - end. +slurp_errors(Errors) -> + foreach(fun ({File,Es}) -> slurp_errors(File, Es) end, Errors). + +slurp_warnings(Warnings) -> + foreach(fun ({File,Ws}) -> slurp_warnings(File, Ws) end, Warnings). slurp_errors(File, Es) -> slurp_ews(File, "~s:~w: ~s\n", Es). @@ -485,6 +513,9 @@ collect_form(['extend-module'|Mdef], _, St0) -> St1 = collect_mdef(Mdef, St0), {[],St1}; +collect_form(['eval-when-compile'|_], _, St) -> + %% Can safely ignore this, everything already in environment. + {[],St}; collect_form(['define-function',F,Def], _, St) -> Ar = function_arity(Def), {[{F,Ar,Def}],St}. @@ -590,23 +621,38 @@ %% c(File [,Args]) -> {ok,Module} | error. %% Compile and load an LFE file. -c(F) -> c(F, []). +c(File) -> c(File, []). + +c(File, Opts0) -> + Opts1 = [report,verbose|Opts0], %Always report verbosely + case lfe_comp:file(File, Opts1) of + Ok when element(1, Ok) =:= ok -> %Compilation successful + Return = lists:member(return, Opts1), + Binary = lists:member(binary, Opts1), + OutDir = outdir(Opts1), + load_files(Ok, Return, Binary, OutDir); + Error -> Error + end. -c(F, Os0) -> - Os1 = [report,verbose|Os0], %Always report verbosely - Loadm = fun ([]) -> {module,[]}; - (Mod) -> - Base = filename:basename(F, ".lfe"), - code:purge(Mod), - R = code:load_abs(Base), - R - end, - case lfe_comp:file(F, Os1) of - {ok,Mod,_} -> Loadm(Mod); - {ok,Mod} -> Loadm(Mod); - Other -> Other +load_files(Ok, _, true, _) -> Ok; %Binary output +load_files(Ok, Ret, _, Out) -> %Beam files created. + Mods = element(2, Ok), + lists:map(fun (M) -> load_file(M, Ret, Out) end, Mods). + +load_file(Ok, _, Out) -> + case element(2, Ok) of + [] -> Ok; %No module file to load + Mod -> %We have a module name + Bfile = filename:join(Out, atom_to_list(Mod)), + code:purge(Mod), + code:load_abs(Bfile, Mod) %Undocumented end. +outdir([{outdir,Dir}|_]) -> Dir; %Erlang way +outdir([[outdir,Dir]|_]) -> Dir; %LFE way +outdir([_|Opts]) -> outdir(Opts); +outdir([]) -> ".". + %% cd(Dir) -> ok. cd(Dir) -> c:cd(Dir). @@ -621,20 +667,39 @@ %% help() -> ok. help() -> - io:put_chars(<<"(c File) -- compile and load code in <File>\n" - "(cd Dir) -- change working directory\n" - "(ec File) -- compile and load code in erlang <File>\n" + io:put_chars(<<"\nLFE shell built-in functions\n\n" + "(c file) -- compile and load code in <file>\n" + "(cd dir) -- change working directory to <dir>\n" + "(ec file) -- compile and load code in erlang <file>\n" + "(exit) -- quit - an alias for (q)\n" "(help) -- help info\n" "(i) -- information about the system\n" - "(l Module) -- load or reload module\n" + "(l module) -- load or reload <module>\n" "(ls) -- list files in the current directory\n" - "(ls Dir) -- list files in directory <Dir>\n" + "(clear) -- clear the the REPL output\n" + "(ls dir) -- list files in directory <dir>\n" "(m) -- which modules are loaded\n" - "(m Mod) -- information about module <Mod>\n" - "(pid X Y Z) -- convert X,Y,Z to a Pid\n" + "(m mod) -- information about module <mod>\n" + "(pid x y z) -- convert <x>, <y> and <z> to a pid\n" "(pwd) -- print working directory\n" - "(q) -- quit - shorthand for init:stop()\n" - "(regs) -- information about registered processes\n" + "(q) -- quit - shorthand for init:stop/0\n" + "(flush) -- flushes all messages sent to the shell\n" + "(regs) -- information about registered processes\n\n" + "LFE shell built-in commands\n\n" + "(reset-environment) -- resets the environment to its initial state\n" + "(set pattern expr)\n" + "(set pattern (when guard) expr) -- evaluate <expr> and match the result with\n" + " pattern binding\n" + "(slurp file) -- slurp in a LFE source <file> and makes\n" + " everything available in the shell\n" + "(unslurp) -- revert back to the state before the last\n" + " slurp\n" + "(run file) -- execute all the shell commands in a <file>\n\n" + "LFE shell built-in variables\n\n" + "+/++/+++ -- the tree previous expressions\n" + "*/**/*** -- the values of the previous expressions\n" + "- -- the current expression output\n" + "$ENV -- the current LFE environment\n\n" >>). %% i([Pids]) -> ok. @@ -653,6 +718,10 @@ ls(Dir) -> apply(c, ls, Dir). +%% clear() -> ok. + +clear() -> io:format("\e[H\e[J"). + %% m([Modules]) -> ok. %% Print module information. @@ -686,6 +755,10 @@ q() -> c:q(). +%% flush() -> ok. + +flush() -> c:flush(). + %% regs() -> ok. regs() -> c:regs().
View file
lfe-0.9.2.tar.gz/src/lfe_trans.erl -> lfe-1.0.tar.gz/src/lfe_trans.erl
Changed
@@ -27,14 +27,14 @@ -module(lfe_trans). -export([from_expr/1,from_expr/2,from_body/1,from_body/2,from_lit/1, - to_expr/2,to_lit/2]). + to_expr/2,to_lit/2]). -import(lists, [map/2,foldl/3,mapfoldl/3,foldr/3,splitwith/2]). -define(Q(E), [quote,E]). %We do a lot of quoting -record(from, {vc=0 %Variable counter - }). + }). %% from_expr(AST) -> Sexpr. %% from_expr(AST, Variables) -> {Sexpr,Variables}. @@ -52,7 +52,7 @@ S. from_expr(E, Vs0) -> - Vt0 = ordsets:from_list(Vs0), %We are clean + Vt0 = ordsets:from_list(Vs0), %We are clean {S,Vt1,_} = from_expr(E, Vt0, #from{}), {S,ordsets:to_list(Vt1)}. @@ -61,18 +61,18 @@ [progn|Les]. from_body(Es, Vs0) -> - Vt0 = ordsets:from_list(Vs0), %We are clean + Vt0 = ordsets:from_list(Vs0), %We are clean {Les,Vt1,_} = from_body(Es, Vt0, #from{}), {[progn|Les],ordsets:to_list(Vt1)}. %% from_expr(AST, VarTable, State) -> {Sexpr,VarTable,State}. -from_expr({var,_,V}, Vt, St) -> {V,Vt,St}; %Unquoted atom +from_expr({var,_,V}, Vt, St) -> {V,Vt,St}; %Unquoted atom from_expr({nil,_}, Vt, St) -> {[],Vt,St}; from_expr({integer,_,I}, Vt, St) -> {I,Vt,St}; from_expr({float,_,F}, Vt, St) -> {F,Vt,St}; -from_expr({atom,_,A}, Vt, St) -> {?Q(A),Vt,St}; %Quoted atom -from_expr({string,_,S}, Vt, St) -> {?Q(S),Vt,St}; %Quoted string +from_expr({atom,_,A}, Vt, St) -> {?Q(A),Vt,St}; %Quoted atom +from_expr({string,_,S}, Vt, St) -> {?Q(S),Vt,St}; %Quoted string from_expr({cons,_,H,T}, Vt0, St0) -> {Car,Vt1,St1} = from_expr(H, Vt0, St0), {Cdr,Vt2,St2} = from_expr(T, Vt1, St1), @@ -120,11 +120,11 @@ {Lqs,Vt1,St1} = from_lc_quals(Qs, Vt0, St0), {Le,Vt2,St2} = from_expr(E, Vt1, St1), {[lc,Lqs,Le],Vt2,St2}; -from_expr({record,_,R,Fs}, Vt0, St0) -> %Create a record +from_expr({record,_,R,Fs}, Vt0, St0) -> %Create a record MR = list_to_atom("make-" ++ atom_to_list(R)), {Lfs,Vt1,St1} = from_rec_fields(Fs, Vt0, St0), {[MR|Lfs],Vt1,St1}; -from_expr({record,_,E,R,Fs}, Vt0, St0) -> %Set fields in record +from_expr({record,_,E,R,Fs}, Vt0, St0) -> %Set fields in record SR = list_to_atom("set-" ++ atom_to_list(R)), {Le,Vt1,St1} = from_expr(E, Vt0, St0), {Lfs,Vt2,St2} = from_rec_fields(Fs, Vt1, St1), @@ -133,18 +133,18 @@ RF = list_to_atom(atom_to_list(R) ++ "-" ++ atom_to_list(F)), {Le,Vt1,St1} = from_expr(E, Vt0, St0), {[RF,Le],Vt1,St1}; -from_expr({record_field,_,_,_}=M, Vt, St) -> %Pre R16 packages +from_expr({record_field,_,_,_}=M, Vt, St) -> %Pre R16 packages from_package_module(M, Vt, St); %% Function calls. -from_expr({call,_,{remote,_,M,F},As}, Vt0, St0) -> %Remote function call +from_expr({call,_,{remote,_,M,F},As}, Vt0, St0) -> %Remote function call {Lm,Vt1,St1} = from_expr(M, Vt0, St0), {Lf,Vt2,St2} = from_expr(F, Vt1, St1), {Las,Vt3,St3} = from_expr_list(As, Vt2, St2), {[call,Lm,Lf|Las],Vt3,St3}; -from_expr({call,_,{atom,_,F},As}, Vt0, St0) -> %Local function call +from_expr({call,_,{atom,_,F},As}, Vt0, St0) -> %Local function call {Las,Vt1,St1} = from_expr_list(As, Vt0, St0), {[F|Las],Vt1,St1}; -from_expr({call,_,F,As}, Vt0, St0) -> %F not an atom or remote +from_expr({call,_,F,As}, Vt0, St0) -> %F not an atom or remote {Lf,Vt1,St1} = from_expr(F, Vt0, St0), {Las,Vt2,St2} = from_expr_list(As, Vt1, St1), {[funcall,Lf|Las],Vt2,St2}; @@ -368,11 +368,11 @@ from_pat({bin,_,Segs}, Vt0, St0) -> {Ss,Eqt,Vt1,St1} = from_pat_bitsegs(Segs, Vt0, St0), {[binary|Ss],Eqt,Vt1,St1}; -from_pat({record,_,R,Fs}, Vt0, St0) -> %Match a record +from_pat({record,_,R,Fs}, Vt0, St0) -> %Match a record MR = list_to_atom("match-" ++ atom_to_list(R)), - {Sfs,Eqt,Vt1,St1} = from_rec_fields(Fs, Vt0, St0), + {Sfs,Eqt,Vt1,St1} = from_pat_rec_fields(Fs, Vt0, St0), {[MR|Sfs],Eqt,Vt1,St1}; -from_pat({match,_,P1,P2}, Vt0, St0) -> %Aliases +from_pat({match,_,P1,P2}, Vt0, St0) -> %Aliases {Lp1,Eqt1,Vt1,St1} = from_pat(P1, Vt0, St0), {Lp2,Eqt2,Vt2,St2} = from_pat(P2, Vt1, St1), {['=',Lp1,Lp2],Eqt1++Eqt2,Vt2,St2}; @@ -388,6 +388,20 @@ {[Lp|Lps],Eqt++Eqts,Vt2,St2}; from_pat_list([], Vt, St) -> {[],[],Vt,St}. +%% from_pat_rec_fields(Recfields, VarTable, State) -> +%% {Recfields,EqTable,VarTable,State}. + +from_pat_rec_fields([{record_field,_,{atom,_,F},P}|Fs], Vt0, St0) -> + {Lp,Eqt,Vt1,St1} = from_pat(P, Vt0, St0), + {Lfs,Eqts,Vt2,St2} = from_pat_rec_fields(Fs, Vt1, St1), + {[F,Lp|Lfs],Eqt++Eqts,Vt2,St2}; +from_pat_rec_fields([{record_field,_,{var,_,F},P}|Fs], Vt0, St0) -> + %% Special case!! + {Lp,Eqt,Vt1,St1} = from_pat(P, Vt0, St0), + {Lfs,Eqts,Vt2,St2} = from_pat_rec_fields(Fs, Vt1, St1), + {[F,Lp|Lfs],Eqt++Eqts,Vt2,St2}; +from_pat_rec_fields([], Vt, St) -> {[],[],Vt,St}. + %% from_pat_bitsegs(Segs, VarTable, State) -> {Segs,EqTable,VarTable,State}. from_pat_bitsegs([{bin_element,_,Seg,Size,Type}|Segs], Vt0, St0) -> @@ -457,7 +471,7 @@ {{cons,L,Ee,Tail},St1} end, foldr(Fun, {{nil,L},St}, Es); -to_expr(['list*'|Es], L, Vt, St) -> %Macro +to_expr(['list*'|Es], L, Vt, St) -> %Macro to_expr_list_s(fun to_expr/4, L, Vt, St, Es); to_expr([tuple|Es], L, Vt, St0) -> {Ees,St1} = to_expr_list(Es, L, Vt, St0), @@ -605,7 +619,7 @@ {Ep,Vt1,St2} = to_pat(P, L, Vt0, St1), {Eg,St3} = to_body(G, L, Vt1, St2), {{'case',L,Ee,[{clause,L,[Ep],Eg,[Ep]}]},Vt1,St3} - end, + end, mapfoldl2(Fun, Vt, St, Lbs). %% to_icrt_cls(Clauses, LineNumber, VarTable, State) -> {Clauses,State}.
View file
lfe-0.9.2.tar.gz/src/lfescript.erl -> lfe-1.0.tar.gz/src/lfescript.erl
Changed
@@ -42,24 +42,24 @@ start(Lopts) -> try - process_flag(trap_exit, false), - case init:get_plain_arguments() of - [File|Args] -> - parse_check_run(File, Args, Lopts); - [] -> - lfe_io:format("lfescript: Missing filename\n", []), - halt(?ERROR_STATUS) - end + process_flag(trap_exit, false), + case init:get_plain_arguments() of + [File|Args] -> + parse_check_run(File, Args, Lopts); + [] -> + lfe_io:format("lfescript: Missing filename\n", []), + halt(?ERROR_STATUS) + end catch - %% Catch program errors. - throw:Str -> - lfe_io:format("lfescript: ~s\n", [Str]), - halt(?ERROR_STATUS); - _:Reason -> - Stack = erlang:get_stacktrace(), %Need to get this first - lfe_io:format("lfescript: Internal error: ~p\n", [Reason]), - lfe_io:format("~p\n", [Stack]), - halt(?ERROR_STATUS) + %% Catch program errors. + throw:Str -> + lfe_io:format("lfescript: ~s\n", [Str]), + halt(?ERROR_STATUS); + _:Reason -> + Stack = erlang:get_stacktrace(), %Need to get this first + lfe_io:format("lfescript: Internal error: ~p\n", [Reason]), + lfe_io:format("~p\n", [Stack]), + halt(?ERROR_STATUS) end. %% parse_check_run(FileName, Args, Options) -> no_return(). @@ -102,34 +102,34 @@ parse_file(File, _, _) -> case parse_file(File) of - {ok,Fs} -> Fs; - {error,Error} -> - error_exit(File, [Error], []) + {ok,Fs} -> Fs; + {error,Error} -> + error_exit(File, [Error], []) end. parse_file(File) -> case file:open(File, [read]) of - {ok,F} -> - io:get_line(F, ''), %Skip first line - case io:request(F, {get_until,'',lfe_scan,tokens,[2]}) of - {ok,Ts,_} -> - Ret = parse_file1(Ts, [], []), - file:close(F), - Ret; - {error,Error,_} -> {error,Error} - end; - {error,Error} -> {error,{none,file,Error}} + {ok,F} -> + io:get_line(F, ''), %Skip first line + case io:request(F, {get_until,'',lfe_scan,tokens,[2]}) of + {ok,Ts,_} -> + Ret = parse_file1(Ts, [], []), + file:close(F), + Ret; + {error,Error,_} -> {error,Error} + end; + {error,Error} -> {error,{none,file,Error}} end. parse_file1([_|_]=Ts0, Pc0, Ss) -> case lfe_parse:sexpr(Pc0, Ts0) of - {ok,L,S,Ts1} -> parse_file1(Ts1, [], [{S,L}|Ss]); - {more,Pc1} -> - %% Need more tokens but there are none, so call again to - %% generate an error message. - {error,E,_} = lfe_parse:sexpr(Pc1, {eof,99999}), - {error,E}; - {error,E,_} -> {error,E} + {ok,L,S,Ts1} -> parse_file1(Ts1, [], [{S,L}|Ss]); + {more,Pc1} -> + %% Need more tokens but there are none, so call again to + %% generate an error message. + {error,E,_} = lfe_parse:sexpr(Pc1, {eof,99999}), + {error,E}; + {error,E,_} -> {error,E} end; parse_file1([], _, Ss) -> {ok,lists:reverse(Ss)}. @@ -137,10 +137,10 @@ expand_macros(Fs0, File, _, _) -> case lfe_macro:expand_forms(Fs0, lfe_env:new()) of - {ok,Fs1,Fenv,Ws} -> - list_warnings(File, Ws), - {Fs1,Fenv}; - {error,Es,Ws} -> error_exit(File, Es, Ws) + {ok,Fs1,Fenv,Ws} -> + list_warnings(File, Ws), + {Fs1,Fenv}; + {error,Es,Ws} -> error_exit(File, Es, Ws) end. %% check_code(Forms, File, Args, Lopts) -> ok. @@ -150,7 +150,7 @@ check_code(Fs, File, _, _) -> Module = [{['define-module',dummy,[export,[main,1]]],1}|Fs], case lfe_lint:module(Module) of - {ok,Ws} -> + {ok,dummy,Ws} -> list_warnings(File, Ws); {error,Es,Ws} -> error_exit(File, Es, Ws) end. @@ -172,14 +172,14 @@ eval_code(Fenv, _, Args, _) -> try - lfe_eval:expr([main,[quote,Args]], Fenv) + lfe_eval:expr([main,[quote,Args]], Fenv) catch - %% Catch all exceptions in the code. - Class:Error -> - St = erlang:get_stacktrace(), %Need to get this first - Sf = fun (_) -> false end, - Ff = fun (T, I) -> lfe_io:prettyprint1(T, 15, I, 80) end, - Cs = lfe_lib:format_exception(Class, Error, St, Sf, Ff, 1), - io:put_chars(Cs), - halt(?ERROR_STATUS) + %% Catch all exceptions in the code. + Class:Error -> + St = erlang:get_stacktrace(), %Need to get this first + Sf = fun (_) -> false end, + Ff = fun (T, I) -> lfe_io:prettyprint1(T, 15, I, 80) end, + Cs = lfe_lib:format_exception(Class, Error, St, Sf, Ff, 1), + io:put_chars(Cs), + halt(?ERROR_STATUS) end.
View file
lfe-0.9.2.tar.gz/test/eval_SUITE.lfe -> lfe-1.0.tar.gz/test/eval_SUITE.lfe
Changed
@@ -68,32 +68,34 @@ (line (test-pat f14-64 (eval `(binary (,f14-64 binary))))) (line (test-pat f14-64 (eval `(binary (,f14-64 binary (size all)))))) (line (test-pat (tuple 17 47) - (eval `(let (((binary (b1 bits (size 17)) (b2 bits)) ,f14-64)) - (tuple (bit_size b1) (bit_size b2)))))) + (eval `(let (((binary (b1 bits (size 17)) (b2 bits)) + ,f14-64)) + (tuple (bit_size b1) (bit_size b2)))))) ) ;; Matching out values to use as size. (line (test-pat (tuple 2 #b("AB") #b("CD")) - (eval `(let (((binary s (b binary (size s)) (rest binary)) - #b(2 "AB" "CD"))) - (tuple s b rest))))) + (eval `(let (((binary s (b binary (size s)) (rest binary)) + #b(2 "AB" "CD"))) + (tuple s b rest))))) (line (test-pat (tuple 2 #b("AB") #b("CD")) - (eval '(flet ((a ([(binary s - (b binary (size s)) - (rest binary))] - (tuple s b rest)))) - (a #b(2 "AB" "CD")))))) - + (eval '(flet ((a ([(binary s + (b binary (size s)) + (rest binary))] + (tuple s b rest)))) + (a #b(2 "AB" "CD")))))) 'ok)) (defun binding_1 (['suite] ()) (['doc] '"Test function bindings.") ([config] (when (is_list config)) - (let (((1 2) - (funcall (: lfe_eval expr - '(lambda () (foo 1 2)) - ;; We evaluate the above lambda form in a new environment that - ;; contains a binding for the function foo/2. - (: lfe_eval add_expr_func 'foo 2 (lambda (a b) (list a b)) - (: lfe_lib new_env)))))) - 'ok))) + (let (((1 2) + (funcall (: lfe_eval expr + '(lambda () (foo 1 2)) + ;; We evaluate the above lambda form in a new + ;; environment that contains a binding for the + ;; function foo/2. + (: lfe_eval add_lexical_func + 'foo 2 (lambda (a b) (list a b)) + (: lfe_env new)))))) + 'ok)))
View file
lfe-0.9.2.tar.gz/test/test_server.lfe -> lfe-1.0.tar.gz/test/test_server.lfe
Changed
@@ -16,7 +16,7 @@ (defmacro eif (args (fletrec ((r ([(t v . as)] `((_ (when ,t) ,v) . ,(r as))) - ([()] ()))) + ([()] ()))) `(case 1 . ,(r args))))) (defmacro test-pat (pat expr)
View file
lfe-0.9.2.tar.gz/test/visual/test_bin.lfe -> lfe-1.0.tar.gz/test/visual/test_bin.lfe
Changed
@@ -3,13 +3,13 @@ ;;; Purpose : Test binaries. (defmodule test_bin - (export (a 0) (a 1) (af 2) (afp 2) (a 3) ;Constructors - (p1 1) (p2 1) (p2p 1) (p3 1) (p4 0)) ;Patterns - (export (b 1) (b 2) (bb1 2) (bb2 2)) ;Binaries/bitstrings - (export (u 1) (u 2)) ;Unicode types - (export (vs1 2) (vs2 2) (vs3 2)) ;Value and size expressions - (export (d1 0) (d2 0) (d3 0)) ;Binary constants - (export (sl1 0) (sl1 1) (sl2 0) (sl2 1)) ;String literals + (export (a 0) (a 1) (af 2) (afp 2) (a 3) ;Constructors + (p1 1) (p2 1) (p2p 1) (p3 1) (p4 0)) ;Patterns + (export (b 1) (b 2) (bb1 2) (bb2 2)) ;Binaries/bitstrings + (export (u 1) (u 2)) ;Unicode types + (export (vs1 2) (vs2 2) (vs3 2)) ;Value and size expressions + (export (d1 0) (d2 0) (d3 0)) ;Binary constants + (export (sl1 0) (sl1 1) (sl2 0) (sl2 1)) ;String literals ) ;; Binary constructors. @@ -21,7 +21,7 @@ (defun af (x y) (binary (x float (size 32)) (y float (size 64)))) -(defun afp (x y) ;This will cause an error! +(defun afp (x y) ;This will cause an error! (binary (x float (size 32)) (y float (size 40)))) (defun a (x y z) @@ -33,12 +33,12 @@ (case b ((binary (x (size 24)) (zz binary)) (list x zz)))) -(define (p2 b) ;Old style +(define (p2 b) ;Old style (case b ((binary (x float (size 32)) (y float (size 64)) (zz bitstring)) (list x y zz)))) -(defun p2p (b) ;This will cause an error! +(defun p2p (b) ;This will cause an error! (case b ((binary (x float (size 32)) (y float (size 40)) (zz bitstring)) (list x y zz)))) @@ -46,7 +46,7 @@ (defun p3 (b) (case b ((binary (x unsigned) (y (size 16) big-endian) (z (size 3) little-endian) - (zz bitstring)) + (zz bitstring)) (list x y z zz)))) (defun p4 () @@ -64,7 +64,7 @@ (defun b (bin) (binary (bin binary) (bin (size 16) bitstring) (bin binary))) -(define (b b1 b2) ;Old style +(define (b b1 b2) ;Old style (binary (b1 bitstring) (b2 (size 3) bitstring signed) (b2 bitstring))) (defun bb1 (b n) @@ -75,7 +75,7 @@ (defun bb2 (b n) (case b ((binary (b1 bitstring (size n)) (b2 (size 3) bitstring signed) - (b3 bitstring)) + (b3 bitstring)) (list b1 b2 b3)))) ;; Unicode types. @@ -85,24 +85,24 @@ (defun u (x y) (binary (x utf-8 big-endian) (y utf-32 little-endian) - (x utf-16 signed little-endian))) + (x utf-16 signed little-endian))) ;; Value and size expressions (defun vs1 (x y) (tuple (let ((y1 (+ y 1))) - (binary (x (size y)) (y (size y1)))) - (binary (x (size y)) (y (size (+ y 1)))))) + (binary (x (size y)) (y (size y1)))) + (binary (x (size y)) (y (size (+ y 1)))))) (defun vs2 (x y) - (tuple (binary ((* 2 x) (size y))) ;Just value expr - (binary (x (size (+ y 8)))) ;Just size expr - (binary ((* 2 x) (size (+ y 8)))))) ;Both value and size expr + (tuple (binary ((* 2 x) (size y))) ;Just value expr + (binary (x (size (+ y 8)))) ;Just size expr + (binary ((* 2 x) (size (+ y 8)))))) ;Both value and size expr (defun vs3 (x y) - (binary ((* 2 x) (size y)) ;Just value expr - (x (size (+ y 8))) ;Just size expr - ((* 2 x) (size (+ y 8))))) ;Both value and size expr + (binary ((* 2 x) (size y)) ;Just value expr + (x (size (+ y 8))) ;Just size expr + ((* 2 x) (size (+ y 8))))) ;Both value and size expr ;; Binary constants
View file
lfe-0.9.2.tar.gz/test/visual/test_bin_e.erl -> lfe-1.0.tar.gz/test/visual/test_bin_e.erl
Changed
@@ -4,13 +4,13 @@ -module(test_bin_e). --export([a/0,a/1,af/2,afp/2,a/3]). %Constructors --export([p1/1,p2/1,p2p/1,p3/1,p4/0]). %Patterns --export([b/1,b/2,bb1/2,bb2/2]). %Binaries/bitstrings --export([u/1,u/2]). %Unicode types --export([vs1/2,vs2/2,vs3/2]). %Value and size expressions --export([d1/0,d2/0,d3/0]). %Binary constants --export([sl1/0,sl1/1]). %String literals +-export([a/0,a/1,af/2,afp/2,a/3]). %Constructors +-export([p1/1,p2/1,p2p/1,p3/1,p4/0]). %Patterns +-export([b/1,b/2,bb1/2,bb2/2]). %Binaries/bitstrings +-export([u/1,u/2]). %Unicode types +-export([vs1/2,vs2/2,vs3/2]). %Value and size expressions +-export([d1/0,d2/0,d3/0]). %Binary constants +-export([sl1/0,sl1/1]). %String literals %% Binary constructors. @@ -20,7 +20,7 @@ af(X, Y) -> <<X:32/float,Y:64/float>>. -afp(X, Y) -> <<X:32/float,Y:40/float>>. %This will cause an error! +afp(X, Y) -> <<X:32/float,Y:40/float>>. %This will cause an error! a(X, Y, Z) -> <<X/unsigned,Y:16/big,Z:3/little>>. @@ -28,23 +28,23 @@ p1(B) -> case B of - <<X:24,ZZ/binary>> -> [X,ZZ] + <<X:24,ZZ/binary>> -> [X,ZZ] end. p2(B) -> case B of - <<X:32/float,Y:64/float,ZZ/bitstring>> -> [X,Y,ZZ] + <<X:32/float,Y:64/float,ZZ/bitstring>> -> [X,Y,ZZ] end. p2p(B) -> - case B of %This will cause an error! - <<X:32/float,Y:40/float,ZZ/bitstring>> -> [X,Y,ZZ] + case B of %This will cause an error! + <<X:32/float,Y:40/float,ZZ/bitstring>> -> [X,Y,ZZ] end. p3(B) -> case B of - <<X/unsigned,Y:16/big,Z:3/little,ZZ/bitstring>> -> - [X,Y,Z,ZZ] + <<X/unsigned,Y:16/big,Z:3/little,ZZ/bitstring>> -> + [X,Y,Z,ZZ] end. p4() -> @@ -73,8 +73,8 @@ bb2(B, N) -> case B of - <<B1:N/bitstring,B2:3/bitstring-signed,B3/bitstring>> -> - [B1,B2,B3] + <<B1:N/bitstring,B2:3/bitstring-signed,B3/bitstring>> -> + [B1,B2,B3] end. %% Unicode types. @@ -92,15 +92,15 @@ {<<X:Y,Y:Y1>>,<<X:Y,Y:(Y+1)>>}. vs2(X, Y) -> - {<<(2*X):Y>>, %Just value expr - <<X:(Y+8)>>, %Just size expr - <<(2*X):(Y+8)>> %Both value and size expr + {<<(2*X):Y>>, %Just value expr + <<X:(Y+8)>>, %Just size expr + <<(2*X):(Y+8)>> %Both value and size expr }. vs3(X, Y) -> - <<(2*X):Y, %Just value expr - X:(Y+8), %Just size expr - (2*X):(Y+8)>>. %Both value and size expr + <<(2*X):Y, %Just value expr + X:(Y+8), %Just size expr + (2*X):(Y+8)>>. %Both value and size expr %% Binary constants
View file
lfe-0.9.2.tar.gz/test/visual/test_flet.lfe -> lfe-1.0.tar.gz/test/visual/test_flet.lfe
Changed
@@ -6,20 +6,20 @@ (export (a 2) (b-1 1) (b-2 1) (c 1) (d 1) (e 1) (f 1) (f 2) (g 2) (h 1)) ;; (export (t2 2)) (import (from lists (reverse 1) (reverse 2)) - (from ordsets (is_element 2)) - (rename ordsets ((is_element 2) in)))) + (from ordsets (is_element 2)) + (rename ordsets ((is_element 2) in)))) ;; Test multiply defined functions. ;; (defun t1 (x y) ;; (flet ((o (a) (+ x a)) -;; (o (a b) (+ (+ a b) x)) -;; (o (c) (* 100 (* c y)))) +;; (o (a b) (+ (+ a b) x)) +;; (o (c) (* 100 (* c y)))) ;; (list (o x) (o y) (o x y)))) ;; (defun t2 (x y) ;; (fletrec ((o (a) (+ x a)) -;; (o (a b) (+ (+ a b) x)) -;; (o (c) (* 100 (* c y)))) +;; (o (a b) (+ (+ a b) x)) +;; (o (c) (* 100 (* c y)))) ;; (list (o x) (o y) (o x y)))) (defun a (x y) @@ -29,14 +29,14 @@ ;; Which (o 1) do we get in the "recursive" call? (defun b-1 (n) (flet ((o (n) - (if (=< n 1) 1 - (* n (o (- n 1)))))) + (if (=< n 1) 1 + (* n (o (- n 1)))))) (o n))) (defun b-2 (n) (fletrec ((o (n) - (if (=< n 1) 1 - (* n (o (- n 1)))))) + (if (=< n 1) 1 + (* n (o (- n 1)))))) (o n))) (defun o (n) (- 0 n)) @@ -44,11 +44,11 @@ ;; Mutually recursive functions in fletrec. (defun c (n) (fletrec ((o1 (n) - (if (=< n 1) 1 - (* n (o2 (- n 1))))) - (o2 (n) - (if (=< n 1) 1 - (* n (o1 (- n 1)))))) + (if (=< n 1) 1 + (* n (o2 (- n 1))))) + (o2 (n) + (if (=< n 1) 1 + (* n (o1 (- n 1)))))) (o1 n))) ;; Check we get the RIGHT binding for o in fletrec. @@ -56,25 +56,25 @@ (let ((o n)) (list o (fletrec ((o (n) - (if (=< n 1) 1 - (* n (o (- n 1)))))) + (if (=< n 1) 1 + (* n (o (- n 1)))))) (o n))))) ;; These are different f's, f/1 and f/2! (defun e (n) - (fletrec ((f ((x) (+ x n))) ;Generate match-lambda here - (f (x y) (+ x (+ y n)))) + (fletrec ((f ((x) (+ x n))) ;Generate match-lambda here + (f (x y) (+ x (+ y n)))) (list (f n) (f n 10)))) (defun f (n) - (flet ((f ((x) (+ x n))) ;Generate match-lambda here - (f (x y) (+ x (+ y n)))) + (flet ((f ((x) (+ x n))) ;Generate match-lambda here + (f (x y) (+ x (+ y n)))) (list (f n) (f n 10)))) (defun g (x y) (flet* ((f (a) (list a y)) - (f ((a) (list a (f a)))) - (f (a) (list a (f a)))) + (f ((a) (list a (f a)))) + (f (a) (list a (f a)))) (f x))) (defun f
View file
lfe-0.9.2.tar.gz/test/visual/test_guard.lfe -> lfe-1.0.tar.gz/test/visual/test_guard.lfe
Changed
@@ -1,14 +1,14 @@ (defmodule test_guard - (export (b 1) (c 2) (e 2) (f 2) (if-test 2))) + (export all)) (defun b (x) x) -(define (b) '"a string") ;Old style +(define (b) '"a string") ;Old style (defun c (x y) (case (b x) ((tuple 'ok z) (when (> z 5)) (d '|(> z 5)| z)) - ((tuple 'ok z) (when z) (d 'z z)) + ;;((tuple 'ok z) (when z) (d 'z z)) ((tuple 'ok z) (when (+ z z)) (d '|(+ z z)| z)) ((tuple 'ok z) (when (== z 'true)) (d '|(== z true)| z)) ((tuple 'ok z) (when (and z 'true)) (d '|(and z true)| z)) @@ -26,8 +26,8 @@ (case (b x) (#(ok z) (d '|#(ok z)| 'z)) ((tuple 'ok z) (when (andalso (> (+ z 1) 5) - (orelse x (> (+ z 1) 3)) - (/= z 7))) + (orelse x (> (+ z 1) 3)) + (/= z 7))) (d 'andalso z)))) (defun f (x y) @@ -37,5 +37,29 @@ (defun if-test ([x y] (when (if (> (+ x y) 10) 'true - 'false)) 1) + 'false)) 1) ([x y] 2)) + +(defun seq + ([x y z] (when (> x 0) (is_integer z)) 1) + ([x y z] (when (> x 0) (=:= (element y z) 10)) + 2) + ([x y z] (when (> x 0) (=:= (element y z) 10) (=:= (element (+ y 1) z) 10)) + 3) + ([x y z] (when (and (> x 0) + (and (=:= (element y z) 10) + (=:= (element (+ y 1) z) 10)))) + 4) + ([x y z] 999)) + +(defun lit + ([x y z] (when 'true) 1) + ([x y z] (when 'false) 2) + ([x y z] (when 'x 'y) 3) + ([x y z] (when (and x y)) 4) + ([x y z] (when '67 'z) 5) + ([x y z] (when (and '67 'z)) 6) + ([x y z] (when 'x '89 'z) 7) + ([x y z] (when x 89 #(z)) 8) + ([x y z] (when (and x (and 89 z))) 9) + ([x y z] 999))
View file
lfe-1.0.tar.gz/test/visual/test_guard_e.erl
Added
@@ -0,0 +1,23 @@ +-module(test_guard_e). + +-compile([export_all]). + +seq(X, Y, Z) when X > 0, is_integer(Z) -> 1; +seq(X, Y, Z) when X > 0, element(Y, Z) =:= 10 -> + 2; +seq(X, Y, Z) when X > 0, element(Y, Z) =:= 10, element(Y+1, Z) =:= 10 -> + 3; +seq(X, Y, Z) when (X > 0) and ((element(Y, Z) =:= 10) and (element(Y+1, Z) =:= 10)) -> + 4; +seq(X, Y, Z) -> 999. + +lit(X, Y, Z) when true -> 1; +lit(X, Y, Z) when false -> 2; +lit(X, Y, Z) when 'X', 'Y' -> 3; +lit(X, Y, Z) when (X and Y) -> 4; +lit(X, Y, Z) when 67, 'Z' -> 5; +lit(X, Y, Z) when 67 and 'Z' -> 6; +lit(X, Y, Z) when 'X', 89, 'Z' -> 7; +lit(X, Y, Z) when X, 89, {'Z'} -> 8; +lit(X, Y, Z) when X and (89 and Z) -> 9; +lit(X, Y, Z) -> 999.
View file
lfe-0.9.2.tar.gz/test/visual/test_hash_quote.lfe -> lfe-1.0.tar.gz/test/visual/test_hash_quote.lfe
Changed
@@ -1,16 +1,16 @@ (defmodule test_hash_quote - (export (run_all 0)) + (export (run-all 0)) (export (a 0) (b 0) (c 0) (d 0) (e 0) (f 0) (g 0) (h 0) (i 0) (j 0) (k 0)) - (export (foo:bar42 1) (foo/baz42 1))) + (export (foo/bar42 1) (foo/baz42 1))) -(defun run_all () +(defun run-all () (: lists map (lambda (f) (: io format '"~p~n" (list (funcall f)))) (list (fun a 0) (fun b 0) (fun c 0) (fun d 0) (fun e 0) (fun f 0) (fun g 0) - (fun h 0) (fun i 0) (fun j 0) (fun k 0)))) + #'h/0 #'i/0 #'j/0 #'k/0))) (defun a () - (let (((1 2 3) (: lists sort #'</2 '(2 1 3)))) + (let (((list 1 2 3) (: lists sort #'</2 '(2 1 3)))) 'ok)) (defun b () @@ -18,15 +18,15 @@ 'ok)) (defun c () - (let (((-1 2) (: lists map #'-/1 '(1 -2)))) + (let (((list -1 2) (: lists map #'-/1 '(1 -2)))) 'ok)) (defun d () - (let (((1 2) (: lists map #'abs/1 '(-1 2)))) + (let (((list 1 2) (: lists map #'abs/1 '(-1 2)))) 'ok)) (defun e () - (let ((("foobar") (: lists map #'string:to_lower/1 '("fooBar")))) + (let (((list "foobar") (: lists map #'string:to_lower/1 '("fooBar")))) 'ok)) (defun f () @@ -35,28 +35,30 @@ 'ok)) (defun g () - (let (((42 42) (: lists map #'test_hash_quote:foo:bar42/1 '(1 2)))) + (let (((list 42 42) (: lists map #'test_hash_quote:foo/bar42/1 '(1 2)))) 'ok)) (defun h () - (let (((42 42) (: lists map #'foo/baz42/1 '(1 2)))) + (let (((list 42 42) (: lists map #'foo/baz42/1 '(1 2)))) 'ok)) (defun i () - (let (((42 42) (: lists map #'test_hash_quote:foo/baz42/1 '(1 2)))) + (let (((list 42 42) (: lists map #'test_hash_quote:foo/baz42/1 '(1 2)))) 'ok)) (defun j () - (let ((('false 'true 'false) (: lists zipwith #'=:=/2 '(1 2 3) '(3 2 1)))) + (let (((list 'false 'true 'false) + (: lists zipwith #'=:=/2 '(1 2 3) '(3 2 1)))) 'ok)) (defun k () - (let ((('true 'false 'true) (: lists zipwith #'=/=/2 '(1 2 3) '(3 2 1)))) + (let (((list 'true 'false 'true) + (: lists zipwith #'=/=/2 '(1 2 3) '(3 2 1)))) 'ok)) ;;;; -(defun foo:bar42 (_) +(defun foo/bar42 (_) 42) (defun foo/baz42 (_)
View file
lfe-0.9.2.tar.gz/test/visual/test_lc.lfe -> lfe-1.0.tar.gz/test/visual/test_lc.lfe
Changed
@@ -8,18 +8,18 @@ (defun b (x y) (lc ((<- v x) - (?= (y . z) v)) ;Match bind variables + (?= (cons y z) v)) ;Match bind variables (list v y z))) (defun c (x y) - (lc ((<= (b float) y) ;Only bitseg needed, no wrapping + (lc ((<= (b float) y) ;Only bitseg needed, no wrapping (<- (tuple v) x)) (tuple b v))) (defun d (x y) - (bc ((<= b y) ;Only bitseg needed, no wrapping + (bc ((<= b y) ;Only bitseg needed, no wrapping (<- (tuple v) x)) - ((* b v) (size 16)))) ;Only bitseg needed, no wrapping + ((* b v) (size 16)))) ;Only bitseg needed, no wrapping ;; (defun d (x y) ;; (bc ((<= (b float) y)
View file
lfe-0.9.2.tar.gz/test/visual/test_lc_e.erl -> lfe-1.0.tar.gz/test/visual/test_lc_e.erl
Changed
@@ -4,7 +4,7 @@ a(X, Y) -> [ V || V <- X, - V /= Y ]. + V /= Y ]. c(X, Y) -> [ {B,V} || <<B/float>> <= Y, {V} <- X ].
View file
lfe-0.9.2.tar.gz/test/visual/test_let.lfe -> lfe-1.0.tar.gz/test/visual/test_let.lfe
Changed
@@ -3,28 +3,33 @@ ;; Purpose : Test cases for let, let* and funcall. (defmodule test_let - (export (a 1) (b 2) (c 2) (d 2) (e 2) (f 2) (g 2)) + (export (flip 2) (a 1) (b 2) (c 2) (d 2) (e 2) (f 2) (g 2)) (import (from lists (reverse 1) (reverse 2)) - (from ordsets (is_element 2)) - (rename ordsets ((is_element 2) in)))) + (from ordsets (is_element 2)) + (rename ordsets ((is_element 2) in)))) + +(defun flip (x y) + (let ((x y) + (y x)) + (list x y))) (defun a (x) (let* ((a (list x)) - (a (cons x a)) - (a (cons x a))) + (a (cons x a)) + (a (cons x a))) a)) (defun b (x y) (let ((m (+ x y)) - (n (xxx)) - (o (yyy x y))) + (n (xxx)) + (o (yyy x y))) (list m n o))) ;; Test multiply defined variables. -;; (defun (t1 x y) +;; (defun t1 (x y) ;; (let ((m (list x y)) -;; (n (cons x z)) -;; ((n o) (list x y))) +;; (n (cons x z)) +;; ((list n o) (list x y))) ;; (list m n o))) (defun c (x y) @@ -42,15 +47,15 @@ (funcall (lambda (a b) (list a b)) (* x y) (+ x y)) (list x y))) -(defun f (x y) ;Arg mismatch, push error to runtime +(defun f (x y) ;Arg mismatch, push error to runtime (funcall (lambda (a b c) (list a b)) (* x y))) (defun g (x y) (funcall (match-lambda - (('a n) (tuple 'a n)) - (('b n) (tuple 'b n)) - ((m n) (when (> m n)) 'bigger)) - x (* y 2))) + (('a n) (tuple 'a n)) + (('b n) (tuple 'b n)) + ((m n) (when (> m n)) 'bigger)) + x (* y 2))) (defun xxx () '"a string")
View file
lfe-0.9.2.tar.gz/test/visual/test_macro.lfe -> lfe-1.0.tar.gz/test/visual/test_macro.lfe
Changed
@@ -4,8 +4,8 @@ ) (defmacro let@ - (((vb . vbs) . b) `(let (,vb) (let@ ,vbs . ,b))) - ((() . b) `(begin . ,b))) + ((cons (cons vb vbs) b) `(let (,vb) (let@ ,vbs . ,b))) + ((cons () b) `(begin . ,b))) (defsyntax let& ([(vb . vbs) . b] [let (vb) (let& vbs . b)]) @@ -37,8 +37,8 @@ (defun ab (x y) (let@ ((o (e x)) - (p (e-1 y))) - (tuple o p))) + (p (e-1 y))) + (tuple o p))) (defun ac (x y) (and-also (e x) (e-1 y) (aa x y)) @@ -50,17 +50,17 @@ (defun ae (x y) (c-ond ((p-1 x) (e-1 y) (list x y)) - ((?= (p . ps) (e-1 x)) ;Match (p . ps) or fail + ((?= (cons p ps) (e-1 x)) ;Match (p . ps) or fail (list p ps)) ((p-2 x) (e y) (tuple x y)) (else (e y)))) (defun af (x y) (cond ((p-1 x) (e-1 y) (list x y)) - ((?= (p . ps) (e-1 x)) ;Match (p . ps) or fail - (list p ps)) - ((p-2 x) (e y) (tuple x y)) - (else (e y)))) + ((?= (p . ps) (e-1 x)) ;Match (p . ps) or fail + (list p ps)) + ((p-2 x) (e y) (tuple x y)) + (else (e y)))) (defun e (x) (list 'e x)) @@ -85,7 +85,7 @@ (fletrec ((e (a) (aa a a))) (e x)))) -(define-syntax tmac ;Old style still valid +(define-syntax tmac ;Old style still valid (macro ((e) `(tuple 'ok ,e)) ((e . es) `(tuple 'ok (tuple ,e . ,es))))) @@ -93,7 +93,7 @@ (defun t1 (x y) (list (tmac x) (tmac x 1 y 2))) -(define-syntax d-o ;Old style still valid +(define-syntax d-o ;Old style still valid (syntax-rules ([((v i c) ...) (t r) b ...] (fletrec ((f (v ...)
View file
lfe-0.9.2.tar.gz/test/visual/test_map.lfe -> lfe-1.0.tar.gz/test/visual/test_map.lfe
Changed
@@ -6,9 +6,16 @@ (defun make (x y z) (tuple (map 'a x 'b y 'c (tuple 'ok (: test_map foo z))) - (map 'b y 'c (tuple 'ok (: test_map foo z)) 'a x) - (map #b(1 2 3) x) - (map #b((1 (size 16)) ("åäö" utf-8)) y))) + (map 'b y 'c (tuple 'ok (: test_map foo z)) 'a x) + (map #b(1 2 3) x) + (map #b((1 (size 16)) ("åäö" utf-8)) y))) + +(defun lit-make + ([1] (map)) + ([2] (map 'a 1)) + ([3] (map 'a 1 'b 2)) + ([4] (map 'a #(1 2))) + ([5] (map #(1 2) 'a))) ;; (defun get (map) ;; (map-get map 'a)) @@ -33,16 +40,26 @@ (defun update (map v1 v2) (mupd map 'a v1 'b (: test_map foo v2))) +(defun mixed (map v1 v2) + (mupd (mset map 'a v1 'c 3) 'b (: test_map foo v2))) + (defun guard ([map x] (when (== (map 'a x) map)) 1) ([map x] (when (== (mset map 'a 1) x)) 2) ([map x] (when (== (mupd map 'a 1) x)) 3)) (defun match - ([(map 'a x)] x) ([(map 'a 1 'b y)] y) + ([(map 'a x)] x) ([(map 'c (tuple x y))] (tuple x y)) ([(map #(d e) z)] z)) +(defun lit-match + ([(map 'a 1 'b 2)] 1) + ([(map 'a 1)] 2) + ([(map 'a #(1 2))] 3) + ([(map #(1 2) 'z)] 4) + ([(map)] 5)) ;Catch-all + (defun foo (x) (list x x))
View file
lfe-0.9.2.tar.gz/test/visual/test_map_e.erl -> lfe-1.0.tar.gz/test/visual/test_map_e.erl
Changed
@@ -2,29 +2,44 @@ -compile(export_all). +literal() -> + #{a => 1, b => [2,3,4], c => {a,b}}. + make(X,Y,Z) -> {#{a => X, b => Y, c => {ok,test_map_e:foo(Z)}}, #{b => Y, c => {ok,test_map_e:foo(Z)}, a => X}, #{<<1,2,3>> => X}, #{<<1:16,"åäö"/utf8>> => Y}}. +lit_make(1) -> #{}; +lit_make(2) -> #{a => 1}; +lit_make(3) -> #{a => 1, b => 2}; +lit_make(4) -> #{a => {1,2}}; +lit_make(5) -> #{{1,2} => a}. + set(Map, V1, V2) -> - M = Map#{a => V1, b => test_map_e:foo(V2)}. + Map#{a => V1, b => test_map_e:foo(V2)}. update(Map, V1, V2) -> - M = Map#{a := V1, b := test_map_e:foo(V2)}. + Map#{a := V1, b := test_map_e:foo(V2)}. mixed(Map, V1, V2) -> - M = Map#{a => V1, b := test_map_e:foo(V2), c => 3}. + Map#{a => V1, b := test_map_e:foo(V2), c => 3}. guard(Map, X) when #{a=>X} == Map -> 1; guard(Map, X) when Map#{a=>1} == X -> 2; guard(Map, X) when Map#{a:=1} == X -> 3. -match(#{a := X}) -> X; match(#{a := 1, b := Y}) -> Y; +match(#{a := X}) -> X; match(#{c := {X,Y}}) -> {X,Y}; match(#{{d,e} := Z}) -> Z. +lit_match(#{a := 1, b := 2}) -> 1; +lit_match(#{a := 1}) -> 2; +lit_match(#{a := {1,2}}) -> 3; +lit_match(#{{1,2} := z}) -> 4; +lit_match(#{}) -> 5. %Catch-all + foo(X) -> [X,X].
View file
lfe-0.9.2.tar.gz/test/visual/test_pat.lfe -> lfe-1.0.tar.gz/test/visual/test_pat.lfe
Changed
@@ -3,7 +3,7 @@ ;;; Purpose : Test patterns. (defmodule test_pat - (export (a 2) (b 2) (c 2) (d 2) (f 2) (g 2))) + (export (a 2) (b 2) (c 1) (c 2) (d 2) (f 2) (g 2))) (defsyntax make-foo (fs (tuple 'sune . fs))) @@ -35,6 +35,10 @@ (('a _) (tuple 2 'a 'anything)) ((_ _) (tuple 3 'anything))) +(defun c + (("1234") 'string) + ((_) 'other)) + ;; Macro expansion in patterns. (defun c (x y) (let ((foo (make-foo x y))) @@ -58,11 +62,11 @@ ((list 'a m) (tuple 1 'new 'a m)) ((m . n) (tuple 2 'old m n)) ((cons m n) (tuple 2 'new m n)) - ((m n . o) (tuple 3 'old m n o)) - ((cons m (cons n o)) ;(list* m n o) + ;((m n . o) (tuple 3 'old m n o)) + ((cons m (cons n o)) ;(list* m n o) (tuple 3 'new m n o)) ;; cons/list become "reserved words" like tuple/binary. - ((m cons n o) (tuple 4 'old m n o)) ;(cons m (cons n o)) + ((m cons n o) (tuple 4 'old m n o)) ;(cons m (cons n o)) ((m list n o) (tuple 5 'old m n o)) ;(cons m (list n o)) ))
View file
lfe-0.9.2.tar.gz/test/visual/test_pat_e.erl -> lfe-1.0.tar.gz/test/visual/test_pat_e.erl
Changed
@@ -1,35 +1,41 @@ -module(test_pat_e). --export([a/2,b/2,e/2,g/2]). +-export([a/2,b/2,c/1,e/2,g/2]). a(1,_) -> F = fun ([1,_]) -> 1; - ([a,4]) -> {1,a,4} - end, + ([a,4]) -> {1,a,4} + end, {1,F}; a(X, Y) -> case [X,Y] of - [a,4] -> {1,a,4}; - [a,_]=[P1|Ps] -> {2,a,P1,Ps}; - [_,_] -> {3,anything} + [a,4] -> {1,a,4}; + [a,_]=[P1|Ps] -> {2,a,P1,Ps}; + [_,_] -> {3,anything} end. b(a, 4) -> {1,a,4}; b(a, _) -> {2,a,anything}; b(_, _) -> {3,anything}. +c(X) -> + case X of + "1234" -> string; + _ -> other + end. + e(X, Y) -> case [X|Y] of - [a,M] -> {1,old,a,M}; - [M|N] -> {2,old,M,N}; - [M,N|O] -> {3,old,M,N,O}; - [M|[N|O]] -> {4,old,M,N,O}; - [M|[N,O]] -> {5,old,M,N,O} + [a,M] -> {1,old,a,M}; + [M|N] -> {2,old,M,N}; + [M,N|O] -> {3,old,M,N,O}; + [M|[N|O]] -> {4,old,M,N,O}; + [M|[N,O]] -> {5,old,M,N,O} end. g(X, Y) -> case [X|Y] of - [a,M]=[a,M] -> {1,'old/old',M}; - [M|N]=[N|M] -> {2,'old/old',M,N}; - [M1,N1|O1]=[M2,N2|O2] -> {3,'old/old',M1,N1,O1} + [a,M]=[a,M] -> {1,'old/old',M}; + [M|N]=[N|M] -> {2,'old/old',M,N}; + [M1,N1|O1]=[M2,N2|O2] -> {3,'old/old',M1,N1,O1} end.
View file
lfe-0.9.2.tar.gz/test/visual/test_slurp.lfe -> lfe-1.0.tar.gz/test/visual/test_slurp.lfe
Changed
@@ -1,8 +1,8 @@ (defmodule test_slurp (export ) (import (from lists (map 2)) - (rename ordsets ((add_element 2) os-add)))) -;; (rename lists ((map 2) foldl)))) + (rename ordsets ((add_element 2) os-add)))) +;; (rename lists ((map 2) foldl)))) (defun fac (n) (if (> n 0) @@ -10,11 +10,11 @@ 1)) (defun funny (x) - (list 'funny x -)) ;Value of - when function defined + (list 'funny x -)) ;Value of - when function defined (defun fac1 (n) (fletrec ((f (n) - (if (> n 0) - (* (f (- n 1)) n) - 1))) + (if (> n 0) + (* (f (- n 1)) n) + 1))) (f n)))
View file
lfe-0.9.2.tar.gz/test/visual/test_sr.lfe -> lfe-1.0.tar.gz/test/visual/test_sr.lfe
Changed
@@ -14,8 +14,8 @@ (defsyntax dodo ([((a b c) ...) (t v) e ...] [fletrec ((-sune- (a ...) - (if t v - (begin e ... (-sune- c ...))))) + (if t v + (begin e ... (-sune- c ...))))) (-sune- b ...)])) (defmacro aaa @@ -37,14 +37,14 @@ ;; This will not compile, but we are interested in expansion. (defun c (x) - (ccc #((m m1) (n n1) (o o1))) ;Should we take tuple literals? + (ccc #((m m1) (n n1) (o o1))) ;Should we take tuple literals? (ccc (tuple (m m1) (n n1) (o o1)))) (defun e-1 (m) (dodo ((i 1 (+ 1 i)) - (acc 1 (* acc i))) - ((> i m) acc) - '(i))) + (acc 1 (* acc i))) + ((> i m) acc) + '(i))) (defun e-2 (m) (do ((l m (cdr l))
View file
lfe-0.9.2.tar.gz/test/visual/test_try.lfe -> lfe-1.0.tar.gz/test/visual/test_try.lfe
Changed
@@ -5,7 +5,7 @@ (defmodule test_try (export (a 2) (b 1) (b 2) (c 2) (d 2) (e 2) (f 2) (g 2) (h 2)) (import (from lists (reverse 1) (reverse 2)) - (from ordsets (is_element 2)))) + (from ordsets (is_element 2)))) (defun a (x y) (catch (+ x y) (b y))) @@ -14,36 +14,36 @@ ;; Testing just catch. (defun b (x y) (try - (progn - (yyy x y) - (zzz y)) + (progn + (yyy x y) + (zzz y)) (catch - ;; Pattern MUST be tuple of 3 elements here! - ;; (tuple TYPE VALUE IGNORE-THIS) - ((tuple 'error n o) (tuple 'this-is-error n)) - ((tuple 'throw n o) (tuple 'this-is-throw n)) - ((tuple _ n o) (tuple 'this-is-default n))))) + ;; Pattern MUST be tuple of 3 elements here! + ;; (tuple TYPE VALUE IGNORE-THIS) + ((tuple 'error n o) (tuple 'this-is-error n)) + ((tuple 'throw n o) (tuple 'this-is-throw n)) + ((tuple _ n o) (tuple 'this-is-default n))))) ;; Testing using case and catch. (defun c (x y) (try (progn - (yyy x y) - (zzz y)) - (case - ('sune #(value sune)) - ('bert #(value bert))) - (catch - ;; Pattern MUST be tuple of 3 elements here! - ;; (tuple TYPE VALUE IGNORE-THIS) - ((tuple 'error n o) (tuple 'this-is-error n)) - ((tuple 'throw n o) (tuple 'this-is-throw n)) - ((tuple _ n o) (tuple 'this-is-default n))))) + (yyy x y) + (zzz y)) + (case + ('sune #(value sune)) + ('bert #(value bert))) + (catch + ;; Pattern MUST be tuple of 3 elements here! + ;; (tuple TYPE VALUE IGNORE-THIS) + ((tuple 'error n o) (tuple 'this-is-error n)) + ((tuple 'throw n o) (tuple 'this-is-throw n)) + ((tuple _ n o) (tuple 'this-is-default n))))) (defun d (x y) (try (progn - (yyy x y) - (zzz y)) - (after ))) + (yyy x y) + (zzz y)) + (after ))) ;; Testing just after. (defun e (x y) @@ -52,26 +52,26 @@ (yyy x y) (zzz y)) (after (yyy 'this-is-after (list x y)) - 'this-is-after))) + 'this-is-after))) ;; Testing using case and after. (defun f (x y) (try - (progn - (yyy x y) - (zzz y)) + (progn + (yyy x y) + (zzz y)) (case - ('sune #(value sune)) + ('sune #(value sune)) ('bert #(value bert))) (after (yyy 'this-is-after (list x y)) - 'this-is-after))) + 'this-is-after))) ;; Testing using catch and after. (defun g (x y) (try - (progn - (yyy x y) - (zzz y)) + (progn + (yyy x y) + (zzz y)) (catch ;; Pattern MUST be tuple of 3 elements here! ;; (tuple TYPE VALUE IGNORE-THIS) @@ -79,16 +79,16 @@ ((tuple 'throw n o) (tuple 'this-is-throw n)) ((tuple _ n o) (tuple 'this-is-default n))) (after (yyy 'this-is-after (list x y)) - 'this-is-after))) + 'this-is-after))) ;; Testing using all case, catch and after. (defun h (x y) (try - (progn - (yyy x y) - (zzz y)) + (progn + (yyy x y) + (zzz y)) (case - ('sune #(value sune)) + ('sune #(value sune)) ('bert #(value bert))) (catch ;; Pattern MUST be tuple of 3 elements here! @@ -97,7 +97,7 @@ ((tuple 'throw n o) (tuple 'this-is-throw n)) ((tuple _ n o) (tuple 'this-is-default n))) (after (yyy 'this-is-after (list x y)) - 'this-is-after))) + 'this-is-after))) (defun b (x) '"a string")
Locations
Projects
Search
Status Monitor
Help
Open Build Service
OBS Manuals
API Documentation
OBS Portal
Reporting a Bug
Contact
Mailing List
Forums
Chat (IRC)
Twitter
Open Build Service (OBS)
is an
openSUSE project
.