From 54eea5426e3150657122392141bf0de5c183c135 Mon Sep 17 00:00:00 2001 From: Anders Hoff Date: Sat, 19 Oct 2024 15:14:02 +0200 Subject: [PATCH] refactor evl. tests. docs. code generator prototype. wip. basic condition handling and/or with tests. rename evl/evl* primitive generator experiment more syntax checks/evl-error handling compile script import values macros from veq generator utilities promising generator macro . . . i. . --- .github/workflows/dockerimage.yml | 17 + Dockerfile | 35 + README.md | 2 +- compile.sh | 9 + compile.sh.txt | 93 + docs/evl-code.md | 26 + docs/evl.md | 697 +++++ evl.asd | 16 +- ex.lisp | 69 + ex/ex.lisp | 61 - generator.lisp | 51 + make-docs.lisp | 21 + src/code-factory.lisp | 50 + src/config.lisp | 76 + src/docs.lisp | 53 + src/evl-gen.lisp | 65 + src/interp.lisp | 337 ++- src/packages.lisp | 31 +- src/utils.lisp | 33 +- test/evl-2.lisp | 69 + test/evl-generator.lisp | 95 + test/{test-evl-evl.lisp => evl-self.lisp} | 56 +- test/evl-values.lisp | 78 + test/{test-evl.lisp => evl.lisp} | 88 +- test/run.lisp | 33 +- tmp.svg | 3033 +++++++++++++++++++++ 26 files changed, 4891 insertions(+), 303 deletions(-) create mode 100644 .github/workflows/dockerimage.yml create mode 100644 Dockerfile create mode 100755 compile.sh create mode 100644 compile.sh.txt create mode 100644 docs/evl-code.md create mode 100644 docs/evl.md create mode 100755 ex.lisp delete mode 100755 ex/ex.lisp create mode 100755 generator.lisp create mode 100755 make-docs.lisp create mode 100644 src/code-factory.lisp create mode 100644 src/config.lisp create mode 100644 src/docs.lisp create mode 100644 src/evl-gen.lisp create mode 100644 test/evl-2.lisp create mode 100644 test/evl-generator.lisp rename test/{test-evl-evl.lisp => evl-self.lisp} (57%) create mode 100644 test/evl-values.lisp rename test/{test-evl.lisp => evl.lisp} (54%) create mode 100644 tmp.svg diff --git a/.github/workflows/dockerimage.yml b/.github/workflows/dockerimage.yml new file mode 100644 index 0000000..0b49347 --- /dev/null +++ b/.github/workflows/dockerimage.yml @@ -0,0 +1,17 @@ +name: Docker Image for Testing + +on: [pull_request] + +jobs: + + build: + + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v1 + - name: Build the Docker image + run: docker build . --file ./Dockerfile --tag tests:latest + - name: Run tests + run: docker run tests:latest + diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..8afe0a2 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,35 @@ +# This image is only intended to run the tests + +FROM ubuntu:24.04 AS base + +RUN apt-get -qq update &&\ + apt-get -qq install -y sbcl curl gcc git + +WORKDIR /opt +RUN curl -s 'https://beta.quicklisp.org/quicklisp.lisp' > /opt/quicklisp.lisp +RUN sbcl --noinform --load /opt/quicklisp.lisp\ + --eval '(quicklisp-quickstart:install :path "/opt/quicklisp")'\ + --eval '(sb-ext:quit)' + +RUN echo '(load "/opt/quicklisp/setup.lisp")' > /root/.sbclrc +RUN mkdir -p quicklisp +RUN mkdir -p /opt/data +RUN apt-get -qq remove curl -y &&\ + apt-get -qq autoremove -y &&\ + apt-get -qq autoclean -y + +from base AS build + +WORKDIR /opt +ADD src quicklisp/local-projects/evl/src +ADD test quicklisp/local-projects/evl/test +ADD evl.asd quicklisp/local-projects/evl +ADD run-tests.sh quicklisp/local-projects/evl/run-tests.sh +RUN mkdir -p ~/quicklisp/ && ln -s /opt/quicklisp/setup.lisp ~/quicklisp/setup.lisp + +RUN git clone https://github.com/inconvergent/cl-veq.git quicklisp/local-projects/veq +RUN git clone https://github.com/inconvergent/lqn.git quicklisp/local-projects/lqn + +WORKDIR /opt/quicklisp/local-projects/evl/ + +CMD ["bash", "./run-tests.sh"] diff --git a/README.md b/README.md index 54099d7..2ef679b 100644 --- a/README.md +++ b/README.md @@ -14,7 +14,7 @@ #'env)))) ``` -more examples in [ex/ex.lisp](ex/ex.lisp). +more examples in [/ex.lisp](/ex.lisp). ## Resources diff --git a/compile.sh b/compile.sh new file mode 100755 index 0000000..cbdb2eb --- /dev/null +++ b/compile.sh @@ -0,0 +1,9 @@ +#!/bin/bash + +set -e +touch ./evl.asd +time sbcl --quit \ + --eval '(load "evl.asd")'\ + --eval '(handler-case (time (ql:quickload :evl :verbose t)) + (error (c) (print c) (sb-ext:quit :unix-status 2)))'\ + >compile.sh.txt 2>&1 diff --git a/compile.sh.txt b/compile.sh.txt new file mode 100644 index 0000000..fb97caa --- /dev/null +++ b/compile.sh.txt @@ -0,0 +1,93 @@ +This is SBCL 2.4.4, an implementation of ANSI Common Lisp. +More information about SBCL is available at . + +SBCL is free software, provided as is, with absolutely no warranty. +It is mostly in the public domain; some portions are provided under +BSD-style licenses. See the CREDITS and COPYING files in the +distribution for more information. +To load "evl": + Load 1 ASDF system: + evl +; Loading "evl" +; compiling file "/data/x/evl/src/packages.lisp" (written 29 OCT 2024 09:48:09 PM): +[package evl]..................................... +[package evl/code] + +; wrote /home/anders/.cache/common-lisp/sbcl-2.4.4-linux-x64/data/x/evl/src/packages-tmpGHU3ALSV.fasl +; compilation finished in 0:00:00.002 +; compiling file "/data/x/evl/src/utils.lisp" (written 29 OCT 2024 09:48:09 PM): +. +; file: /data/x/evl/src/utils.lisp +; in: DEFUN MATCH-PREF +; (STRING= EVL::PREF EVL::S :END2 (LENGTH EVL::PREF)) +; +; note: unable to +; optimize +; due to type uncertainty: +; The first argument is a STRING, not a SIMPLE-BASE-STRING. +; The second argument is a STRING, not a SIMPLE-BASE-STRING. +; +; note: unable to +; optimize +; due to type uncertainty: +; The first argument is a STRING, not a (SIMPLE-ARRAY CHARACTER (*)). +; The second argument is a STRING, not a (SIMPLE-ARRAY CHARACTER (*)). + + +; wrote /home/anders/.cache/common-lisp/sbcl-2.4.4-linux-x64/data/x/evl/src/utils-tmpAAURSO1.fasl +; compilation finished in 0:00:00.016 +; compiling file "/data/x/evl/src/docs.lisp" (written 29 OCT 2024 09:48:09 PM): +. +; file: /data/x/evl/src/docs.lisp +; in: DEFVAR *DOCSTRING-MAP* +; (LIST) +; +; note: deleting unreachable code + + +; wrote /home/anders/.cache/common-lisp/sbcl-2.4.4-linux-x64/data/x/evl/src/docs-tmp5GEXGEG5.fasl +; compilation finished in 0:00:00.013 +; compiling file "/data/x/evl/src/config.lisp" (written 29 OCT 2024 09:48:09 PM): + +; wrote /home/anders/.cache/common-lisp/sbcl-2.4.4-linux-x64/data/x/evl/src/config-tmpAR3FSGEY.fasl +; compilation finished in 0:00:00.008 +; compiling file "/data/x/evl/src/evl-gen.lisp" (written 29 OCT 2024 11:37:52 PM): +. + +; wrote /home/anders/.cache/common-lisp/sbcl-2.4.4-linux-x64/data/x/evl/src/evl-gen-tmpJAIDFZTC.fasl +; compilation finished in 0:00:00.012 +; compiling file "/data/x/evl/src/interp.lisp" (written 29 OCT 2024 09:48:09 PM): +... + +; wrote /home/anders/.cache/common-lisp/sbcl-2.4.4-linux-x64/data/x/evl/src/interp-tmp8V3J6PE9.fasl +; compilation finished in 0:00:00.090 +; compiling file "/data/x/evl/src/code-factory.lisp" (written 29 OCT 2024 09:48:09 PM): + +; file: /data/x/evl/src/code-factory.lisp +; in: DEFUN GEN +; (COND +; ((AND (LISTP EVL/CODE::V) (> (LENGTH EVL/CODE::V) 1)) +; `(VALUES ,@EVL/CODE::V)) +; ((LISTP EVL/CODE::V) (CAR EVL/CODE::V)) (T EVL/CODE::V)) +; --> IF THE +; ==> +; EVL/CODE::V +; +; note: deleting unreachable code + + +; wrote /home/anders/.cache/common-lisp/sbcl-2.4.4-linux-x64/data/x/evl/src/code-factory-tmp9V47YWQF.fasl +; compilation finished in 0:00:00.011 +; +; compilation unit finished +; printed 4 notes + +Evaluation took: + 0.229 seconds of real time + 0.230028 seconds of total run time (0.169029 user, 0.060999 system) + 100.44% CPU + 671 forms interpreted + 1,081 lambdas converted + 977,572,080 processor cycles + 80,134,368 bytes consed + diff --git a/docs/evl-code.md b/docs/evl-code.md new file mode 100644 index 0000000..bace70e --- /dev/null +++ b/docs/evl-code.md @@ -0,0 +1,26 @@ +## `evl/code:gen` +``` + ; EVL/CODE:GEN + ; [symbol] + ; + ; GEN names a compiled function: + ; Lambda-list: (SIGNS S) + ; Derived type: (FUNCTION (T T) (VALUES T &OPTIONAL)) + ; Documentation: + ; generate new expressions using these + ; Source file: /data/x/evl/src/code-factory.lisp +``` + +## `evl/code:signatures` +``` +:missing: + + ; EVL/CODE:SIGNATURES + ; [symbol] + ; + ; SIGNATURES names a compiled function: + ; Lambda-list: (EXPRS &AUX (HT (MAKE-HASH-TABLE TEST (FUNCTION EQUAL)))) + ; Derived type: (FUNCTION (T) (VALUES HASH-TABLE &OPTIONAL)) + ; Source file: /data/x/evl/src/code-factory.lisp +``` + diff --git a/docs/evl.md b/docs/evl.md new file mode 100644 index 0000000..90c72c1 --- /dev/null +++ b/docs/evl.md @@ -0,0 +1,697 @@ +## `evl:*act*` +``` +:missing: + + ; EVL:*ACT* + ; [symbol] + ; + ; *ACT* names a special variable: + ; Declared type: FUNCTION + ; Value: # +``` + +## `evl:+std-env+` +``` + ; EVL:+STD-ENV+ + ; [symbol] + ; + ; +STD-ENV+ names a special variable: + ; Value: ((CAR? . CAR?) (ENV/EMPTY . ENV/EMPTY) (ENV/NEW . ENV/NEW) + ; (ENV/EXTEND-ALIST . ENV/EXTEND-ALIST) + ; (ENV/EXTEND-PAIR . ENV/EXTEND-PAIR) (DEV/DO-OR . DEV/DO-OR) + ; (DEV/DO-AND . DEV/DO-AND) (G/ITR/1 . G/ITR/1) + ; (G/ITR/N . G/ITR/N) (G/ITR/ALL . G/ITR/ALL) + ; (DEV/EVAL-DSB . DEV/EVAL-DSB) (DEV/EVAL-MVB . DEV/EVAL-MVB) + ; (DEV/EVAL-LAMBDA . DEV/EVAL-LAMBDA) + ; (DEV/EVAL-COERCE-VALUES . DEV/EVAL-COERCE-VALUES) + ; (DEV/DO-LABELS . DEV/DO-LABELS) (DEV/DO-LET . DEV/DO-LET) + ; (DEV/DO-COND . DEV/DO-COND) (+ . +) (- . -) (/ . /) (* . *) + ; (1+ . 1+) (1- . 1-) (T . T) (= . =) (< . <) (<= . <=) (> . >) + ; (>= . >=) (EVENP . EVENP) (ODDP . ODDP) (ABS . ABS) + ; (MIN . MIN) (MAX . MAX) (SIGNUM . SIGNUM) (FLOOR . FLOOR) + ; (ROUND . ROUND) (TRUNCATE . TRUNCATE) (FLOAT . FLOAT) + ; (CEILING . CEILING) (SQRT . SQRT) (EXP . EXP) (EXPT . EXPT) + ; (LOG . LOG) (MOD . MOD) (REM . REM) (GCD . GCD) (LCM . LCM) + ; (SIN . SIN) (COS . COS) (TAN . TAN) (ASIN . ASIN) + ; (ACOS . ACOS) (ATAN . ATAN) (SINH . SINH) (COSH . COSH) + ; (TANH . TANH) (PI . 3.1415927) (PII . 6.2831855) + ; (PI5 . 1.5707964) (EQUAL . EQUAL) (NOT . NOT) (ZEROP . ZEROP) + ; (VALUES . VALUES) (VALUES-LIST . VALUES-LIST) + ; (IDENTITY . IDENTITY) + ; (MULTIPLE-VALUE-CALL . MULTIPLE-VALUE-CALL) + ; (MVC . MULTIPLE-VALUE-CALL) (FUNCALL . FUNCALL) + ; (MAPCAR . MAPCAR) (MAPC . MAPC) (APPLY . APPLY) + ; (PRINT . PRINT) (PRINC . PRINC) (FORMAT . FORMAT) + ; (LENGTH . LENGTH) (SUBSEQ . SUBSEQ) (STRING= . STRING=) + ; (REVERSE . REVERSE) (LIST . LIST) (CAR . CAR) (CADR . CADR) + ; (CDR . CDR) (CONS . CONS) (CDAR . CDAR) (ASSOC . ASSOC) + ; (PAIRLIS . PAIRLIS) (ACONS . ACONS) (FIRST . FIRST) + ; (LAST . LAST) (SECOND . SECOND) (THIRD . THIRD) (NTH . NTH) + ; (INTERSECTION . INTERSECTION) + ; (SET-DIFFERENCE . SET-DIFFERENCE) (FIND . FIND) + ; (FIND-IF . FIND-IF) (MEMBER . MEMBER) (UNION . UNION) + ; (REMOVE-IF . REMOVE-IF) (MAP . MAP) (MAPCAN . MAPCAN) + ; (EVERY . EVERY) (SOME . SOME) (APPEND . APPEND) + ; (CONCATENATE . CONCATENATE) (ATOM . ATOM) (NULL . NULL) + ; (STRINGP . STRINGP) (SYMBOLP . SYMBOLP) (KEYWORDP . KEYWORDP) + ; (LISTP . LISTP) (CONSP . CONSP) (NUMBERP . NUMBERP) + ; (FUNCTIONP . FUNCTIONP) (ATOM? . ATOM) (NULL? . NULL) + ; (EVEN? . EVENP) (ODD? . ODDP) (STR? . STRINGP) + ; (SYMBOL? . SYMBOLP) (KEYWORD? . KEYWORDP) (ZERO? . ZEROP) + ; (SOME? . SOME) (EVERY? . EVERY) (LIST? . LISTP) + ; (CONS? . CONSP) (NUM? . NUMBERP) (FUNCTION? . FUNCTIONP) + ; (MEMBER? . MEMBER)) + ; Documentation: + ; convenient standard environment (CL) functions and constant for evl. + ; none of them are required. +``` + +## `evl:car?` +``` + ; EVL:CAR? + ; [symbol] + ; + ; CAR? names a compiled function: + ; Lambda-list: (L &REST SS) + ; Derived type: (FUNCTION (T &REST T) (VALUES LIST &OPTIONAL)) + ; Documentation: + ; t if consp and car is a symbol in ss + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:cons?` +``` +:missing: + + ; EVL:CONS? + ; [symbol] +``` + +## `evl:dev/do-and` +``` + ; EVL:DEV/DO-AND + ; [symbol] + ; + ; DEV/DO-AND names a compiled function: + ; Lambda-list: (EXPR EVL* ENV*) + ; Derived type: (FUNCTION (LIST FUNCTION FUNCTION) *) + ; Documentation: + ; evaluate (and ...) expression with evl* in env*. + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:dev/do-cond` +``` + ; EVL:DEV/DO-COND + ; [symbol] + ; + ; DEV/DO-COND names a compiled function: + ; Lambda-list: (CND X BODY EVL* ENV*) + ; Derived type: (FUNCTION (T T LIST FUNCTION FUNCTION) *) + ; Documentation: + ; recursively evaluate these conds. + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:dev/do-labels` +``` + ; EVL:DEV/DO-LABELS + ; [symbol] + ; + ; DEV/DO-LABELS names a compiled function: + ; Lambda-list: (PAIRS BODY EVL* ENV*) + ; Derived type: (FUNCTION (T LIST FUNCTION FUNCTION) *) + ; Documentation: + ; evaluate this body in an env with these labels (functions). + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:dev/do-let` +``` + ; EVL:DEV/DO-LET + ; [symbol] + ; + ; DEV/DO-LET names a compiled function: + ; Lambda-list: (VARS BODY EVL* ENV*) + ; Derived type: (FUNCTION (T LIST FUNCTION FUNCTION) *) + ; Documentation: + ; evaluate body in an env with these named variables. + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:dev/do-or` +``` + ; EVL:DEV/DO-OR + ; [symbol] + ; + ; DEV/DO-OR names a compiled function: + ; Lambda-list: (EXPR EVL* ENV*) + ; Derived type: (FUNCTION (LIST FUNCTION FUNCTION) *) + ; Documentation: + ; evaluate (or ...) expression with evl* in env*. + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:dev/eval-coerce-values` +``` + ; EVL:DEV/EVAL-COERCE-VALUES + ; [symbol] + ; + ; DEV/EVAL-COERCE-VALUES names a compiled function: + ; Lambda-list: (EXPR EVL* ENV*) + ; Derived type: (FUNCTION (T FUNCTION FUNCTION) *) + ; Documentation: + ; evaluate ~; coerce all values. + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:dev/eval-dsb` +``` + ; EVL:DEV/EVAL-DSB + ; [symbol] + ; + ; DEV/EVAL-DSB names a compiled function: + ; Lambda-list: (ARGS IN EXPR EVL* ENV*) + ; Derived type: (FUNCTION (LIST T T FUNCTION FUNCTION) *) + ; Documentation: + ; get dsb argument values of (evl* in) as a list (l) of quoted values. then do: + ; (evl* '((lambda (,@args*) expr) ,@lst)) + ; requires that evl* implements (quote ...) and ((lambda ...) ...). + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:dev/eval-lambda` +``` + ; EVL:DEV/EVAL-LAMBDA + ; [symbol] + ; + ; DEV/EVAL-LAMBDA names a compiled function: + ; Lambda-list: (ARGS BODY EVL* ENV*) + ; Derived type: (FUNCTION (T T FUNCTION FUNCTION) *) + ; Documentation: + ; use CL eval to build a function with these args and body. + ; requires that evl* implements (progn ...) + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:dev/eval-mvb` +``` + ; EVL:DEV/EVAL-MVB + ; [symbol] + ; + ; DEV/EVAL-MVB names a compiled function: + ; Lambda-list: (ARGS IN EXPR EVL* ENV*) + ; Derived type: (FUNCTION (LIST T T FUNCTION FUNCTION) *) + ; Documentation: + ; get dsb argument values of (evl* in) as a list (l) of quoted values. then do: + ; (evl* '((lambda (,@args*) expr) ,@lst)) + ; requires that evl* implements (quote ...) and ((lambda ...) ...). + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:dsb` +``` +:missing: + + ; EVL:DSB + ; [symbol] + ; + ; DSB names a macro: + ; Lambda-list: (&REST ARGS) + ; Source file: /data/x/evl/src/utils.lisp +``` + +## `evl:env/empty` +``` +:missing: + + ; EVL:ENV/EMPTY + ; [symbol] + ; + ; ENV/EMPTY names a compiled function: + ; Lambda-list: () + ; Derived type: (FUNCTION NIL *) + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:env/extend-alist` +``` + ; EVL:ENV/EXTEND-ALIST + ; [symbol] + ; + ; ENV/EXTEND-ALIST names a compiled function: + ; Lambda-list: (A &OPTIONAL (ENV (ENV/NEW))) + ; Derived type: (FUNCTION (LIST &OPTIONAL FUNCTION) + ; (VALUES FUNCTION &OPTIONAL)) + ; Documentation: + ; new env function extended with this alist. + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:env/extend-pair` +``` + ; EVL:ENV/EXTEND-PAIR + ; [symbol] + ; + ; ENV/EXTEND-PAIR names a compiled function: + ; Lambda-list: (KK VV &OPTIONAL (ENV (ENV/NEW))) + ; Derived type: (FUNCTION (LIST LIST &OPTIONAL FUNCTION) *) + ; Documentation: + ; new env function extended with these names (kk) and values (vv). + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:env/merge` +``` +:missing: + + ; EVL:ENV/MERGE + ; [symbol] + ; + ; ENV/MERGE names a compiled function: + ; Lambda-list: (A B &AUX (S (GENSYM))) + ; Derived type: (FUNCTION (T T) (VALUES FUNCTION &OPTIONAL)) + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:env/new` +``` + ; EVL:ENV/NEW + ; [symbol] + ; + ; ENV/NEW names a compiled function: + ; Lambda-list: (&OPTIONAL (A +STD-ENV+)) + ; Derived type: (FUNCTION (&OPTIONAL LIST) (VALUES FUNCTION &OPTIONAL)) + ; Documentation: + ; create new environment (function) for EVL with this alist. + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:even?` +``` +:missing: + + ; EVL:EVEN? + ; [symbol] +``` + +## `evl:every?` +``` +:missing: + + ; EVL:EVERY? + ; [symbol] +``` + +## `evl:evl` +``` + ; EVL:EVL + ; [symbol] + ; + ; EVL names a compiled function: + ; Lambda-list: (EXPR &OPTIONAL (ENV (ENV/NEW))) + ; Derived type: (FUNCTION (T &OPTIONAL FUNCTION) *) + ; Documentation: + ; evaluate an EVL expression in env. + ; + ; arguments: + ; - expr: the expression that should be evaluated. + ; - env: a funcion used to lookup a variable in scope. see: (evl:env/new) + ; + ; supports CL syntax: + ; - if, and, or, cond, when, unless, progn + ; - lambda (lmb), labels (lbl), + ; - let, quote, values, multiple-value-list (mvl), + ; - destructuring-bind (dsb), multiple-value-bind (mvb), + ; + ; non CL syntax: + ; - (~ ...) coerce value packs to a single values. + ; - (~~ fx ...) coerce all values and apply fx. + ; + ; deviations from regular CL syntax: + ; - there is no function name space; variables and functions in environment are + ; indistinguishable. + ; - inconsistent (left to right) argument evaluation (TODO: check). + ; - &optional, &key and &rest are supported as arguments in lambda, labels, + ; destructuring-bind. but default values in optional/key are not supported (yet), + ; so all defaults are nil. + ; - &aux is not supported. + ; + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:evl*` +``` + ; EVL:EVL* + ; [symbol] + ; + ; EVL* names a compiled function: + ; Lambda-list: (EXPR ENV) + ; Derived type: (FUNCTION (T FUNCTION) *) + ; Documentation: + ; evaluate expr in env without error handling. see evl:evl for full docs. + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:evl-error` +``` + ; EVL:EVL-ERROR + ; [symbol] + ; + ; EVL-ERROR names a compiled function: + ; Lambda-list: (EXPR MSG) + ; Derived type: (FUNCTION (T T) NIL) + ; Documentation: + ; raise evl-error condition. + ; Source file: /data/x/evl/src/config.lisp + ; + ; EVL-ERROR names the condition-class #: + ; Documentation: + ; EVL evaluation error for this expr w/msg.~& + ; Class precedence-list: EVL-ERROR, CONDITION, SB-PCL::SLOT-OBJECT, T + ; Direct superclasses: CONDITION + ; No subclasses. + ; Direct slots: + ; EXPR + ; Initargs: :EXPR + ; Readers: EXPR + ; MSG + ; Initargs: :MSG + ; Readers: MSG +``` + +## `evl:function?` +``` +:missing: + + ; EVL:FUNCTION? + ; [symbol] +``` + +## `evl:g/acc/all` +``` + ; EVL:G/ACC/ALL + ; [symbol] + ; + ; G/ACC/ALL names a compiled function: + ; Lambda-list: (GEN-FX &OPTIONAL (ACC (FUNCTION CONS)) ACT RES) + ; Derived type: (FUNCTION (T &OPTIONAL FUNCTION T T) + ; (VALUES NULL T &OPTIONAL)) + ; Documentation: + ; accumulate all. + ; Source file: /data/x/evl/src/evl-gen.lisp +``` + +## `evl:g/acc/n` +``` + ; EVL:G/ACC/N + ; [symbol] + ; + ; G/ACC/N names a compiled function: + ; Lambda-list: (GEN-FX &OPTIONAL (N 1) (ACC (FUNCTION CONS)) ACT RES) + ; Derived type: (FUNCTION (T &OPTIONAL FIXNUM FUNCTION T T) + ; (VALUES T T &OPTIONAL)) + ; Documentation: + ; accumulate at most n times. + ; Source file: /data/x/evl/src/evl-gen.lisp +``` + +## `evl:g/acc/until` +``` + ; EVL:G/ACC/UNTIL + ; [symbol] + ; + ; G/ACC/UNTIL names a compiled function: + ; Lambda-list: (GEN-FX &OPTIONAL (UNTIL (FUNCTION IDENTITY)) + ; (ACC (FUNCTION CONS)) ACT RES) + ; Derived type: (FUNCTION (T &OPTIONAL FUNCTION FUNCTION T T) + ; (VALUES (OR NULL FUNCTION) T &OPTIONAL)) + ; Documentation: + ; accumulate until. + ; Source file: /data/x/evl/src/evl-gen.lisp +``` + +## `evl:g/g` +``` + ; EVL:G/G + ; [symbol] + ; + ; G/G names a macro: + ; Lambda-list: (RULE-NAME VAL-EXPR) + ; Documentation: + ; new generator with this rule and expression. + ; Source file: /data/x/evl/src/evl-gen.lisp +``` + +## `evl:g/itr/all` +``` + ; EVL:G/ITR/ALL + ; [symbol] + ; + ; G/ITR/ALL names a compiled function: + ; Lambda-list: (GEN-FX &OPTIONAL ACT RES) + ; Derived type: (FUNCTION (T &OPTIONAL T T) *) + ; Documentation: + ; iterate all. + ; Source file: /data/x/evl/src/evl-gen.lisp +``` + +## `evl:g/itr/n` +``` + ; EVL:G/ITR/N + ; [symbol] + ; + ; G/ITR/N names a compiled function: + ; Lambda-list: (GEN-FX &OPTIONAL (N 1) ACT RES) + ; Derived type: (FUNCTION (T &OPTIONAL FIXNUM T T) *) + ; Documentation: + ; iterate at most n times. + ; Source file: /data/x/evl/src/evl-gen.lisp +``` + +## `evl:g/itr/until` +``` + ; EVL:G/ITR/UNTIL + ; [symbol] + ; + ; G/ITR/UNTIL names a compiled function: + ; Lambda-list: (GEN-FX &OPTIONAL (UNTIL (FUNCTION IDENTITY)) ACT RES) + ; Derived type: (FUNCTION (T &OPTIONAL FUNCTION T T) *) + ; Documentation: + ; iterate until. + ; Source file: /data/x/evl/src/evl-gen.lisp +``` + +## `evl:g/with-rules` +``` +:missing: + + ; EVL:G/WITH-RULES + ; [symbol] + ; + ; G/WITH-RULES names a macro: + ; Lambda-list: (RULES &BODY BODY) + ; Source file: /data/x/evl/src/evl-gen.lisp +``` + +## `evl:keyword?` +``` +:missing: + + ; EVL:KEYWORD? + ; [symbol] +``` + +## `evl:later` +``` + ; EVL:LATER + ; [symbol] + ; + ; LATER names a macro: + ; Lambda-list: (EXPR) + ; Documentation: + ; wrap expression in (lambda () ...). + ; Source file: /data/x/evl/src/utils.lisp +``` + +## `evl:lbl` +``` +:missing: + + ; EVL:LBL + ; [symbol] +``` + +## `evl:list?` +``` +:missing: + + ; EVL:LIST? + ; [symbol] +``` + +## `evl:lmb` +``` + ; EVL:LMB + ; [symbol] + ; + ; LMB names a macro: + ; Lambda-list: (&REST REST) + ; Documentation: + ; alias for lambda + ; Source file: /data/x/evl/src/utils.lisp +``` + +## `evl:lst` +``` + ; EVL:LST + ; [symbol] + ; + ; LST names a macro: + ; Lambda-list: (&BODY BODY) + ; Documentation: + ; get all (values ... ) in body as a list. + ; almost like multiple-value-list, except it handles multiple arguments. + ; Source file: /data/x/evl/src/utils.lisp +``` + +## `evl:member?` +``` +:missing: + + ; EVL:MEMBER? + ; [symbol] +``` + +## `evl:mvb` +``` +:missing: + + ; EVL:MVB + ; [symbol] + ; + ; MVB names a macro: + ; Lambda-list: (&REST ARGS) + ; Source file: /data/x/evl/src/utils.lisp +``` + +## `evl:mvl` +``` +:missing: + + ; EVL:MVL + ; [symbol] + ; + ; MVL names a macro: + ; Lambda-list: (&REST ARGS) + ; Source file: /data/x/evl/src/utils.lisp +``` + +## `evl:null?` +``` +:missing: + + ; EVL:NULL? + ; [symbol] +``` + +## `evl:num?` +``` +:missing: + + ; EVL:NUM? + ; [symbol] +``` + +## `evl:odd?` +``` +:missing: + + ; EVL:ODD? + ; [symbol] +``` + +## `evl:some?` +``` +:missing: + + ; EVL:SOME? + ; [symbol] +``` + +## `evl:str?` +``` +:missing: + + ; EVL:STR? + ; [symbol] +``` + +## `evl:symbol?` +``` +:missing: + + ; EVL:SYMBOL? + ; [symbol] +``` + +## `evl:v?` +``` + ; EVL:V? + ; [symbol] + ; + ; V? names a compiled function: + ; Lambda-list: (&OPTIONAL (SILENT T) &AUX + ; (V + ; (SLOT-VALUE (FIND-SYSTEM (QUOTE EVL)) + ; (QUOTE VERSION)))) + ; Derived type: (FUNCTION (&OPTIONAL T) (VALUES T &OPTIONAL)) + ; Documentation: + ; return/print evl version. + ; Source file: /data/x/evl/src/utils.lisp +``` + +## `evl:with-env` +``` + ; EVL:WITH-ENV + ; [symbol] + ; + ; WITH-ENV names a macro: + ; Lambda-list: ((&OPTIONAL (ENV (ENV/NEW))) &BODY BODY) + ; Documentation: + ; evaluate '(progn ,@body) in env with error handling. + ; Source file: /data/x/evl/src/interp.lisp +``` + +## `evl:zero?` +``` +:missing: + + ; EVL:ZERO? + ; [symbol] +``` + +## `evl:~` +``` + ; EVL:~ + ; [symbol] + ; + ; ~ names a macro: + ; Lambda-list: (&REST REST) + ; Documentation: + ; wraps rest in (mvc #'values ...). + ; Source file: /data/x/evl/src/utils.lisp +``` + +## `evl:~~` +``` + ; EVL:~~ + ; [symbol] + ; + ; ~~ names a macro: + ; Lambda-list: (FX &REST REST) + ; Documentation: + ; (mvc fx (~ ,@rest)). + ; Source file: /data/x/evl/src/utils.lisp +``` + diff --git a/evl.asd b/evl.asd index 07a0718..70cf107 100644 --- a/evl.asd +++ b/evl.asd @@ -1,16 +1,22 @@ (asdf:defsystem #:evl :description "Meta-circular Lisp Evaluator" - :version "0.0.1" + :version "0.7.0" :author "anders hoff / @inconvergent / inconvergent@gmail.com" :in-order-to ((asdf:test-op (asdf:test-op #:evl/tests))) :licence "MIT" :pathname "src/" :serial nil + :depends-on (#:lqn #:veq) :components ((:file "packages") - (:file "utils") - (:file "interp"))) + (:file "utils" :depends-on ("packages")) + (:file "docs" :depends-on ("utils")) + (:file "config" :depends-on ("docs")) + (:file "evl-gen" :depends-on ("config")) + (:file "interp" :depends-on ("evl-gen")) + (:file "code-factory" :depends-on ("interp")) + )) (asdf:defsystem #:evl/tests - :depends-on (#:evl #:prove #:uiop #:asdf) - :version "0.0.1" + :depends-on (#:prove #:uiop #:asdf #:evl #:lqn #:veq) + :version "0.7.0" :perform (asdf:test-op (o s) (uiop:symbol-call ':evl-tests '#:run-tests)) :pathname "test/" :serial t :components ((:file "run"))) diff --git a/ex.lisp b/ex.lisp new file mode 100755 index 0000000..c5a0d05 --- /dev/null +++ b/ex.lisp @@ -0,0 +1,69 @@ +#!/usr/local/bin/sbcl --script + +(load "~/quicklisp/setup.lisp") +(ql:quickload :evl) ; must be available locally. eg. in ~/common-lisp/evl +(in-package :evl) + +(defmacro prt (a &aux (a* (gensym "A"))) + "print expression (a) and the corresponding output. returns the result" + `(let ((,a* ,a)) (format t "~&>> ~a~%;; ~a~%" ',a ,a*) ,a*)) + +(defun main () + (let ((kv `((s . 104) (k . 107) ; custom var + (myfx . ,(lambda (k) (+ (sin k) (cos (- k))))) ; custom fx + ,@+std-env+))) + (labels ((env (x &aux (res (assoc x kv))) + (if res (cdr res) (error "EVL: undefined variable: ~a" x))) + (evl. (a) (evl a #'env))) ; always use env + + (prt (evl. '1)) + (prt (evl. 's)) + (prt (evl. '(+ s k))) + (prt (evl. '(myfx 1))) + + (prt (evl. '(quote (+ 1 2)))) + (prt (evl. '(quote 1))) + (prt (evl. '(quote s))) + + (prt (evl. '(list s k))) + (prt (evl. '(progn s k :progn))) + + (prt (evl. '(if (< 4 1) 2 3))) + (prt (evl. '(if (< 4 1) 2))) + + (prt (funcall (evl. '(lambda (x) x)) 99)) + + (prt (evl. '((lambda (x) (+ s x -10000)) 888))) + (prt (evl. '((lambda (x y) (+ s x y)) 888 999))) + (prt (evl. '((lambda () 77)))) + + (prt (evl. '(let ((a 1) (b 20)) (+ a b)))) + (prt (evl. '(let ((a 1) (b 20)) (+ a b) (- a b)))) + + (prt (evl. '(let ((fx (lambda (x) (+ 1 x)))) + (fx (fx 1))))) + + (prt (evl. '(labels ((fact (x) (if (= x 0) + 1 + (* x (fact (1- x)))))) + (fact 7)))) + + (prt (evl. '(labels ((add0 (x) (add1 (sub1 x))) + (add1 (x) (1+ x)) + (sub1 (x) (1- x))) + (add0 7)))) + + (prt (evl. '(cond ((< 2 1) 7) + ((< 1 2) 8) + (t :aa)))) + + (prt (evl. '((lambda (&rest rest) rest) 999 333))) + + (evl. '(labels ((fib (n s) (if (>= (length s) n) s + (fib n (cons (apply + (subseq s 0 2)) + (print s)))))) + (fib 10 (list 1 0)))) + ))) + +(main) + diff --git a/ex/ex.lisp b/ex/ex.lisp deleted file mode 100755 index 16da6e9..0000000 --- a/ex/ex.lisp +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/local/bin/sbcl --script - -(load "~/quicklisp/setup.lisp") -(ql:quickload :evl) ; must be available locally. eg. in ~/common-lisp/evl -(in-package :evl) - -; xprt prints the expression and the output - -(defun main () - (let ((kv `((s . 104) (k . 107) ; custom var - (myfx . ,(lambda (k) (+ (sin k) (cos (- k))))) ; custom fx - ,@+std-env+))) - (labels ((env (x &aux (res (assoc x kv))) - (if res (cdr res) (error "EVL: undefined variable: ~a" x))) - (evl. (a) (evl a #'env))) ; always use env - - (xprt (evl. '1)) - (xprt (evl. 's)) - (xprt (evl. '(+ s k))) - (xprt (evl. '(myfx 1))) - - (xprt (evl. '(quote (+ 1 2)))) - (xprt (evl. '(quote 1))) - (xprt (evl. '(quote s))) - - (xprt (evl. '(list s k))) - (xprt (evl. '(progn s k :progn))) - - (xprt (evl. '(if (< 4 1) 2 3))) - (xprt (evl. '(if (< 4 1) 2))) - - (xprt (funcall (evl. '(lambda (x) x)) 99)) - - (xprt (evl. '((lambda (x) (+ s x -10000)) 888))) - (xprt (evl. '((lambda (x y) (+ s x y)) 888 999))) - (xprt (evl. '((lambda () 77)))) - - (xprt (evl. '(let ((a 1) (b 20)) (+ a b)))) - (xprt (evl. '(let ((a 1) (b 20)) (+ a b) (- a b)))) - - (xprt (evl. '(let ((fx (lambda (x) (+ 1 x)))) - (fx (fx 1))))) - - (xprt (evl. '(labels ((fact (x) (if (= x 0) - 1 - (* x (fact (1- x)))))) - (fact 7)))) - - (xprt (evl. '(labels ((add0 (x) (add1 (sub1 x))) - (add1 (x) (1+ x)) - (sub1 (x) (1- x))) - (add0 7)))) - - (xprt (evl. '(cond ((< 2 1) 7) - ((< 1 2) 8) - (t :aa)))) - - (xprt (evl. '((lambda (&rest rest) rest) 999 333)))))) - -(main) - diff --git a/generator.lisp b/generator.lisp new file mode 100755 index 0000000..92c3322 --- /dev/null +++ b/generator.lisp @@ -0,0 +1,51 @@ +(load "~/quicklisp/setup.lisp") + +(ql:quickload :evl) +(in-package :evl) + +; (veq:fvdef main () +; (g/with-rules +; ((rule-a i (cond ((< i 5) (values i (g/g rule-a (1+ i)))) +; ((= i 5) (values i (g/g rule-b (1+ i)))))) +; (rule-b i (cond ((< i 10) (values i (g/g rule-b (+ i 0.5)) )) +; ((= i 10) (values i (g/g rule-a 0)))))) + +; (let* ((g (g/g rule-a 0)) ; init rule-a with value 0 +; (ga (g/itr/n 13 g (lambda (s) (lqn:out "hi ~a~%" s))))) ; iterate 13 times + +; ; resume at ga, 3 times +; (g/itr/n 3 ga (lambda (s) (lqn:out "hi again ~a.~%" s))) +; ; resume at ga again, 7 times +; (g/itr/n 7 ga (lambda (s) (lqn:out "hi ABC ~a.~%" s)))))) + + + +(veq:fvdef main () + ; select fizz/buzz + (g/with-rules + ((gx i (values i (if (< i 20) (g/g gx (1+ i)) t)))) + (let* ((gg (g/g gx 0))) + ; (g/itr/all gg #'princ) + + ; (time (print (mvl (g/acc/n 10 gg)))) + ; (time (print (mvl (g/acc/until gg + ; (lambda (i) (= i 10)) + ; #'cons + ; )))) + + (mvb (g v) (g/itr/until gg (lambda (i) (= i 10))) + (list (functionp g) v)) + (mvb (g v) (g/itr/until gg (lambda (i) (= i 100))) + (list (functionp g) v) + ) + (mvb (g v) (g/itr/n gg 10) + (list (functionp g) v) + ) + (mvb (g v) (g/itr/n gg 100) + (list (functionp g) v) + ) + + ))) + +(time (main)) + diff --git a/make-docs.lisp b/make-docs.lisp new file mode 100755 index 0000000..f3154a1 --- /dev/null +++ b/make-docs.lisp @@ -0,0 +1,21 @@ +#!/usr/local/bin/sbcl --script + +(load "~/quicklisp/setup.lisp") +(ql:quickload :evl :silent t) +(in-package :evl) + +(defun import-all (fn) + (with-open-file (f (mkstr fn ".lisp") :direction :input) + (loop for o = (read f nil) while o collect o))) +(defun internal-path (path) (namestring (asdf:system-relative-pathname :evl path))) + +(defun make-docs () + (loop for (o . rest) in (import-all (internal-path "src/packages")) + for pkg = (mkstr (car rest)) + for fn = (internal-path (format nil "docs/~(~a~).md" (veq::repl pkg "/" "-"))) + if (eq o 'defpackage) + do (format t "~&~a~%" fn) + (with-open-file (f fn :direction :output :if-exists :supersede) + (princ (-outstr (ext-symbols? pkg :pretty)) f)))) +(make-docs) + diff --git a/src/code-factory.lisp b/src/code-factory.lisp new file mode 100644 index 0000000..f1c4030 --- /dev/null +++ b/src/code-factory.lisp @@ -0,0 +1,50 @@ + +(in-package :evl/code) + +(defun rndi (a) + (declare (fixnum a)) "random fixnum in range (0 a]." + (the fixnum (random a))) + +(defun rndget (l) + (declare (sequence l)) "get random item from sequence l." + (etypecase l (list (nth (rndi (length (the list l))) l)) + (vector (aref l (rndi (length l)))))) + +; (veq:fvdef trunc (v &optional (s 10000.0)) (veq:fclamp* v (- s) s)) +; (defun rnd (a &aux (a* (abs a))) +; (if (zerop a*) 0f0 (rnd:rnd* a*))) + +(defun signatures (exprs &aux (ht (make-hash-table :test #'equal))) + (labels ((add-fx (s fx-args) + (setf (gethash s ht) (push fx-args (gethash s ht (list)))))) + (lqn:qry exprs #((add-fx (car _) (second _)))) + ht)) + +(defun !signp (c) (and (symbolp c) (lqn:pref? (lqn:str! c) "!"))) ; t if ! prefix + +(defun @resym (s) (lqn:sym! "@" (lqn:seq (lqn:str! s) 1))) ; strip first char + +(defun gen (signs s) + "generate new expressions using these " + (labels ((do-eval (c) + (handler-case (eval `(veq:fvprogn ,(rndget (gethash (@resym c) signs)))) + (error (e) (error "DO-EVAL ERROR for ~a:~% err:~% ~a" c e)))) + (eval-values (c &aux (v (veq:lst (do-eval c)))) + (cond ((and (listp v) (> (length v) 1)) `(values ,@v)) + ((listp v) (car v)) + (t v))) ; unreachable + (rec (c &optional (d 0)) + (cond ((> d 10) c) + ((null c) c) + ((!signp c) (rec (rndget (gethash c signs)) (1+ d))) + ((symbolp c) c) ((numberp c) c) ((vectorp c) c) + ((listp c) (cons (rec (car c) (1+ d)) + (rec (cdr c) (1+ d)))))) + (rec/fill-vals (c) + (cond ((null c) c) + ((!signp c) (eval-values c)) + ((symbolp c) c) ((numberp c) c) ((vectorp c) c) + ((listp c) (cons (rec/fill-vals (car c)) + (rec/fill-vals (cdr c))))))) + (rec/fill-vals (rec (rndget (gethash s signs)))))) + diff --git a/src/config.lisp b/src/config.lisp new file mode 100644 index 0000000..305a4d5 --- /dev/null +++ b/src/config.lisp @@ -0,0 +1,76 @@ +(in-package #:evl) + +(defvar *ctx* nil) + +(declaim (function *act*)) +; (defvar *act* #'(lambda (s) (lqn:out "~&(identity:~a)~&" s))) +(defvar *act* #'identity) + + +(define-condition evl-error (condition) + ((expr :initarg :expr :reader expr) + (msg :initarg :msg :reader msg)) + (:report (lambda (c s) (format s "██ expr:~%~s~%██ full msg:~%~a.~&" (expr c) (msg c)))) + (:documentation "EVL evaluation error for this expr w/msg.~&")) + +(defun evl-error (expr msg) + "raise evl-error condition." + (error 'evl-error :expr expr :msg msg)) + +(defmacro evl/err/ctx (expr &body body) + "evaluate body or raise evl-error condition" + (with-gensyms (e) + `(handler-case (progn ,@body) + (error (,e) (evl-error ,expr ,e))))) + +(defmacro evl/err/ctx-handle (expr &body body) + (with-gensyms (e) + `(handler-case (progn ,@body) + (evl-error (,e) (warn "~%██████ EVL failed to evaluate:~%~s~%~a~&" ,expr ,e)) + (error (,e) (error "~%██████ EVL FATAL ERROR on:~%---~%~s~%---~%~a~&" ,expr ,e)) + ))) + +(defun preproc-env (a) + (declare (list)) + (mapcar (lambda (x) (etypecase x (cons x) (symbol `(,x . ,x)))) a)) + +(defparameter +evl-dev-env+ + (preproc-env `(car? + env/empty env/new env/extend-alist env/extend-pair + dev/do-or dev/do-and + g/itr/1 g/itr/n g/itr/all + dev/eval-dsb dev/eval-mvb dev/eval-lambda dev/eval-coerce-values + dev/do-labels dev/do-let dev/do-cond)) + "convenient functions when implementing evl in evl.") + +(defparameter +evl-math-env+ + (preproc-env + `(+ - / * 1+ 1- t = < <= > >= evenp oddp + abs min max signum floor round truncate float ceiling + sqrt exp expt log mod rem gcd lcm sin cos tan asin acos atan sinh cosh tanh + (pi . ,veq:fpi) (pii . ,veq:fpii) (pi5 . ,veq:fpi5))) + "CL mathematical functions") + +(defparameter +evl-cl-env+ + (preproc-env + `(equal not zerop values values-list identity + multiple-value-call (mvc . multiple-value-call) funcall mapcar mapc apply + print princ format length subseq string= reverse list car cadr cdr cons + cdar assoc pairlis acons first last second third nth intersection + set-difference find find-if member union remove-if map mapcan every some + append concatenate atom null stringp symbolp keywordp listp consp numberp + functionp))) + +(defparameter +evl-extra-env+ + (preproc-env + `((atom? . atom) (null? . null) (even? . evenp) (odd? . oddp) + (str? . stringp) (symbol? . symbolp) (keyword? . keywordp) + (zero? . zerop) (some? . some) (every? . every) + (list? . listp) (cons? . consp) (num? . numberp) + (function? . functionp) (member? . member)))) + +(defparameter +std-env+ + `(,@+evl-dev-env+ ,@+evl-math-env+ ,@+evl-cl-env+ ,@+evl-extra-env+) + "convenient standard environment (CL) functions and constant for evl. +none of them are required.") + diff --git a/src/docs.lisp b/src/docs.lisp new file mode 100644 index 0000000..97c48dd --- /dev/null +++ b/src/docs.lisp @@ -0,0 +1,53 @@ +(in-package :evl) + +; (declaim (list *docstring-map*)) +(defvar *docstring-map* (list)) + +(defmacro -outstr (body) `(with-output-to-string (*standard-output*) ,body)) +(defun -strsrt (l) (sort l #'string-lessp :key #'car)) + +(defun desc (sym) (declare (symbol sym)) + (apply #'mkstr (mapcar (lambda (s) (format nil " ; ~a~%" s)) + (butlast (veq::split-string #\Newline (-outstr (describe sym))))))) +(defun docstrings (sym) (declare (symbol sym)) + (apply #'mkstr (mapcar (lambda (o) (mkstr o #\Newline)) + (remove-if-not #'identity + (mapcar (lambda (ty) (documentation sym ty)) + '(variable function setf)))))) +(defun select-docs (sym) (declare (symbol sym)) + (let* ((docs (find-if (lambda (c) (eq sym c)) *docstring-map* :key #'car)) + (idocs (docstrings sym)) + (skip (find :skip docs)) + (desc (unless (find :nodesc docs) (desc sym)))) + (values + (cond (docs (format nil "~&~a~@[~&~%~a~&~]~&" (cadr docs) desc)) + ((and idocs (> (length idocs) 0)) + (format nil "~&~a~@[~&~%~a~&~]~&" desc nil)) + (t (format nil "~&:missing:~%~@[~&~%~a~&~]~&" desc))) + skip))) + +(defmacro pckgs (pkg) + (with-gensyms (sym) + `(-strsrt (loop for ,sym being the external-symbols of (find-package ,pkg) + collect (list (mkstr ,sym) ,sym))))) + +(defmacro ext-symbols? (pkg &optional mode) + "list all external symbols in pkg. use :verbose to inlcude docstring. +use :pretty to print verbose output to stdout in a readable form." + (with-gensyms (str sym doc skip) + (case mode + (:pretty + `(loop for (,str ,sym) in (pckgs ,pkg) + do (multiple-value-bind (,doc ,skip) + (select-docs ,sym) + (unless ,skip (format t "~&## `~(~a:~a~)`~&```~&~a~&```~%~&~%" + (mkstr ,pkg) ,str ,doc))))) + (:pairs `(loop for (,str ,sym) in (pckgs ,pkg) + collect (list ,str (select-docs ,sym)))) + (otherwise `(loop for (,str ,sym) in (pckgs ,pkg) collect ,str))))) + +(defun map-docstring (&rest rest) (declare (list rest)) + "register docs info associated with symbol (car rest). internal." + (setf *docstring-map* (remove-if (lambda (cand) (eq (car cand) (car rest))) + *docstring-map*)) + (push rest *docstring-map*)) diff --git a/src/evl-gen.lisp b/src/evl-gen.lisp new file mode 100644 index 0000000..5a2537a --- /dev/null +++ b/src/evl-gen.lisp @@ -0,0 +1,65 @@ +(in-package #:evl) + + +(defun g/make-rule (rule-name arg rule-expr) + "create rule label with name, argument and rule/condition." + `((,rule-name (val-fx) + (declare (function val-fx)) + (lambda (&optional act) + (mvb (val nxt) (funcall (lambda (,arg) ,rule-expr) (funcall val-fx)) + (cond ((and nxt (functionp nxt)) + (values nxt (funcall (the function (or act *act*)) val))) + (nxt (values nil (funcall (the function (or act *act*)) val))) + (t (values nil nil)))))))) + +(defmacro g/with-rules (rules &body body) + (declare (list rules)) + `(labels (,@(loop for (rule-name arg rule-expr) + of-type (symbol symbol t) + in rules + nconc (g/make-rule rule-name arg rule-expr))) + ,@body)) + +(defmacro g/g (rule-name val-expr) + "new generator with this rule and expression." + `(,rule-name (later ,val-expr))) + +;; ITR ALL + +(defun g/acc/all (gen-fx &optional (acc #'cons) act res) + (declare (optimize speed) (function acc)) "accumulate all." + (if gen-fx (mvb (nxt val) (funcall (the function gen-fx) act) + (g/acc/all nxt acc act (funcall acc val res))) + (values nil res))) + +(defun g/itr/all (gen-fx &optional act res) + (declare (optimize speed)) "iterate all." + (g/acc/all gen-fx #'values act res)) + +;; ITR N + +(defun g/acc/n (gen-fx &optional (n 1) (acc #'cons) act res) + (declare (optimize speed) (fixnum n) (function acc)) "accumulate at most n times." + (if (and gen-fx (> n 0)) + (mvb (nxt val) (funcall (the function gen-fx) act) + (g/acc/n nxt (1- n) acc act (funcall acc val res))) + (values gen-fx res))) + +(defun g/itr/n (gen-fx &optional (n 1) act res) + (declare (optimize speed) (fixnum n)) "iterate at most n times." + (g/acc/n gen-fx n #'values act res)) + +;; ITR UNTIL + +(defun g/acc/until (gen-fx &optional (until #'identity) (acc #'cons) act res) + (declare (optimize speed) (function until acc)) "accumulate until." + (if gen-fx (mvb (nxt val) (funcall (the function gen-fx) act) + (if (not (funcall until val)) + (g/acc/until nxt until acc act (funcall acc val res)) + (values gen-fx (funcall acc val res)))) + (values nil res))) + +(defun g/itr/until (gen-fx &optional (until #'identity) act res) + (declare (optimize speed) (function until)) "iterate until." + (g/acc/until gen-fx until #'values act res)) + diff --git a/src/interp.lisp b/src/interp.lisp index 55217d6..c7fa7ff 100644 --- a/src/interp.lisp +++ b/src/interp.lisp @@ -1,63 +1,48 @@ (in-package :evl) ; TODO: argument count guards +; TODO: optional symbol pass through +; TODO: &optional defaults does not work. see flat-arg-list -(defparameter +evl-env+ - '((car-is . car-is) ' (car-is-in . car-is-in) - (evl/extenv . evl/extenv) - (evl/eval-dsb . evl/eval-dsb) - (evl/eval-lambda . evl/eval-lambda) - (evl/do-labels . evl/do-labels) - (evl/do-let . evl/do-let) - (evl/do-cond . evl/do-cond)) - "convenient functions when implementing evl in evl.") - -(defparameter +std-env+ - `(,@+evl-env+ - (+ . +) (- . -) (/ . /) (* . *) (1+ . 1+) (1- . 1-) - (t . t) (= . =) (< . <) (> . >) (equal . equal) - (atom . atom) (null . null) (evenp . evenp) (oddp . oddp) - (pi . ,pi) (pii . ,(* 2.0 pi)) - (stringp . stringp) (symbolp . symbolp) (keywordp . keywordp) - (numberp . numberp) (functionp . functionp) - (first . first) (last . last) (second . second) (third . third) (nth . nth) - (funcall . funcall) (mapcar . mapcar) (apply . apply) - (find . find) (member . member) (union . union) - (intersection . intersection) (set-difference . set-difference) - (car . car) (cadr . cadr) (cdr . cdr) (cons . cons) - (assoc . assoc) (pairlis . pairlis) (acons . acons) - (print . print) (list . list) (listp . listp) (consp . consp) - (signum . signum) (floor . floor) (round . round) - (truncate . truncate) (float . float) (ceiling . ceiling) - (abs . abs) (min . min) (max . max) - (sqrt . sqrt) (exp . exp) (expt . expt) (log . log) - (mod . mod) (rem . rem) (gcd . gcd) (lcm . lcm) - (sin . sin) (cos . cos) (tan . tan) - (asin . asin) (acos . acos) (atan . atan) - (sinh . sinh) (cosh . cosh) (tanh . tanh)) - "convenient standard environment functions for evl. -none of them are required.") - -(defun new-env (&optional (kv +std-env+)) - (declare (speed 3)) - (lambda (k &aux (res (assoc k kv))) - (declare (symbol k)) - (if res (cdr res) (error "[EVL] undefined variable: ~a" k)))) - -(defun car-is-in (l ss) - (declare (optimize (speed 3)) (list ss)) - (and (consp l) (member (car l) ss :test #'eq))) -(defun car-is (l s) - (declare (optimize (speed 3)) (symbol s)) - "t if consp and car is s" - (and (consp l) (equal (car l) s))) -(defun evl/extenv (env kk vv) +(defun env/empty () (env/new nil)) + +(defun env/new (&optional (a +std-env+)) + (declare (optimize (speed 3)) (list a)) + "create new environment (function) for EVL with this alist." + (labels ((env/new/get-var (k &aux (res (assoc k a))) + (declare (symbol k)) + (if res (cdr res) + (evl-error k (lqn:fmt "~&undefined variable: ~s~%" k))))) + #'env/new/get-var)) + +; TODO: this is inefficient. we only have to check a if there is a hit in a +(defun env/merge (a b &aux (s (gensym))) + (labels ((handle (fx k) (handler-case (funcall fx k) (evl-error (e) (declare (ignore e)) s))) + (env/merge/get-var (k &aux (ra (handle a k)) + (rb (handle b k))) + (cond ((and #1=(equal ra s) (equal rb s)) + (evl-error k (lqn:fmt "~&undefined variable: ~s~%" k))) + (#1# rb) (t ra)))) + #'env/merge/get-var)) + +(defun env/extend-alist (a &optional (env (env/new))) + (declare (optimize (speed 3)) (list a) (function env)) + "new env function extended with this alist." + (labels ((env/extend/get-var (y &aux (res (assoc y a))) + (declare (symbol y)) + (if res (cdr res) (funcall env y)))) + #'env/extend/get-var)) + +(defun env/extend-pair (kk vv &optional (env (env/new))) (declare (optimize (speed 3)) (function env) (list kk vv)) - "new env function extended with these names (kk) and values (vv)" - (let ((kv (mapcar #'list kk vv))) - (lambda (y) (let ((res (find y kv :key #'car))) - (if res (second res) - (funcall env y)))))) + "new env function extended with these names (kk) and values (vv)." + (env/extend-alist (loop for k in kk and v in vv collect `(,k . ,v)) env)) + +(defun car? (l &rest ss) + (declare (optimize speed) (list ss)) + "t if consp and car is a symbol in ss" + (and (consp l) (member (car l) ss :test #'eq))) + (defun flat-arg-list (args) (declare (optimize (speed 3)) (list args)) @@ -65,108 +50,216 @@ none of them are required.") (remove-if (lambda (s) (match-pref (mkstr s) "&")) (flatten args))) -(defun evl/eval-dsb (args in expr evl* env*) - (declare (list args) (function evl* env*)) +(defun dev/eval-dsb (args in expr evl* env*) + (declare (optimize debug) (list args) (function evl* env*)) "get dsb argument values of (evl* in) as a list (l) of quoted values. then do: (evl* '((lambda (,@args*) expr) ,@lst)) requires that evl* implements (quote ...) and ((lambda ...) ...)." - (funcall evl* `((lambda ,#1=(flat-arg-list args) ,@expr) - ; quote the elements in the list. so they will not be evaluated by evl* - ,@(mapcar (lambda (x) `(quote ,x)) - ; use CL dsb to get variables as a list - (eval `(destructuring-bind ,args ',(funcall evl* in env*) - (list ,@#1#))))) - env*)) + (evl/err/ctx `(destructuring-bind ,args ,in ,@expr) + (funcall evl* `((lambda ,#1=(flat-arg-list args) ,@expr) + ; quote the elements in the list. so they will not be evaluated by evl* + ,@(mapcar (lambda (x) `(quote ,x)) + ; use CL dsb to get variables as a list + (eval `(destructuring-bind ,args ',(funcall evl* in env*) + (list ,@#1#))))) + env*))) + +(defun dev/eval-mvb (args in expr evl* env*) + (declare (optimize debug) (list args) (function evl* env*)) + "get dsb argument values of (evl* in) as a list (l) of quoted values. then do: +(evl* '((lambda (,@args*) expr) ,@lst)) +requires that evl* implements (quote ...) and ((lambda ...) ...)." + (evl/err/ctx `(mvb ,args ,in ,@expr) + (funcall evl* `((lambda ,(flat-arg-list args) ,@expr) + ,@(mapcar (lambda (x) `(quote ,x)) + (multiple-value-list (funcall evl* in env*)))) + env*))) -(defun evl/eval-lambda (args body evl* env*) - (declare (function evl* env*)) +(defun dev/eval-lambda (args body evl* env*) + (declare (optimize debug) (function evl* env*)) "use CL eval to build a function with these args and body. requires that evl* implements (progn ...)" - (eval `(lambda (,@args) - (funcall ,evl* '(progn ,@body) - (evl/extenv ,env* ',(flat-arg-list args) - (list ,@(flat-arg-list args))))))) + (evl/err/ctx `(lambda (,@args) (progn ,@body)) + (eval `(lambda (,@args) + (funcall ,evl* '(progn ,@body) + (env/extend-pair ',#1=(flat-arg-list args) + (list ,@#1#) ,env*)))))) -(defun evl/do-labels (pairs body evl* env*) - (declare (list body) (function evl* env*)) +(defun dev/do-labels (pairs body evl* env*) + (declare (optimize debug) (list body) (function evl* env*)) "evaluate this body in an env with these labels (functions)." (labels ((wrp (k) (let ((res (find k pairs :key #'car))) (if res (funcall evl* `(lambda ,@(cdr res)) #'wrp) (funcall env* k))))) - (funcall evl* `(progn ,@body) #'wrp))) + (funcall evl* `(progn ,@body) #'wrp))) -(defun evl/do-let (vars body evl* env*) - (declare (list body) (function evl* env*)) - "evaluate body in an env with these named variables" - (funcall evl* `((lambda ,(mapcar #'car vars) (progn ,@body)) +(defun dev/do-let/coerce-list (vars) + (mapcar (lambda (x) (etypecase x (list x) (symbol `(,x nil)))) vars)) +(defun dev/do-let (vars body evl* env*) + (declare (optimize debug) (list body) (function evl* env*)) + "evaluate body in an env with these named variables." + (let ((vars (dev/do-let/coerce-list vars))) + (funcall evl* `((lambda ,(mapcar #'car vars) (progn ,@body)) ,@(mapcar #'second vars)) - env*)) + env*))) -(defun evl/do-cond (cnd x body evl* env*) - (declare (list body) (function evl* env*)) +(defun dev/do-cond (cnd x body evl* env*) + (declare (optimize debug) (list body) (function evl* env*)) "recursively evaluate these conds." - (funcall evl* `(if ,cnd ,x (cond ,@body)) env*)) + (if (not x) + (values (funcall evl* cnd env*)) ; only one value returned + (funcall evl* `(if ,cnd ,x (cond ,@body)) env*))) -; TODO: optional symbol pass through -; TODO: &optional defaults does not work. see flat-arg-list -(defun evl (expr env) - (declare (function env)) - "evaluate an EVL expression in env. +(defun dev/eval-coerce-values (expr evl* env*) + (declare (optimize debug) (function evl* env*)) + "evaluate ~; coerce all values." + (funcall evl* `(values ,@(mapcar (lambda (x) `(quote ,x)) + (mapcan (lambda (x) (multiple-value-list + (funcall evl* x env*))) + expr))) + env*)) + +(defun dev/eval-coerce-apply-values (fx expr evl* env*) + (declare (optimize debug) (function evl* env*)) + "evaluate ~~; apply function to all coerce values." + (multiple-value-call (funcall evl* fx env*) + (dev/eval-coerce-values expr evl* env*))) -supports quote, lambda (lmb), labels (lbl), let, destructuring-bind (dsb) - progn, if, cond. -there is no function name space; variables and functions in environment are - indistinguishable. +(defun dev/do-and (expr evl* env*) + (declare (optimize debug) (list expr) (function evl* env*)) + "evaluate (and ...) expression with evl* in env*." + (evl/err/ctx `(and ,@expr) + (if expr (loop for e in expr for v = (multiple-value-list (funcall evl* e env*)) + if (not (car v)) do (return-from dev/do-and nil) + finally (return-from dev/do-and (values-list v))) + t))) -&optional, &key and &rest are supported as arguments in lambda, labels, - destructuring-bind. but default values in optional/key are not supported (yet), - so all defaults are nil. +(defun dev/do-or (expr evl* env*) + (declare (optimize debug) (list expr) (function evl* env*)) + "evaluate (or ...) expression with evl* in env*." + (evl/err/ctx `(or ,@expr) + (loop for e in expr for v = (multiple-value-list (funcall evl* e env*)) + if (car v) do (return-from dev/do-or (values-list v)) + finally (return-from dev/do-or nil)))) -expr is the quoted expression that should be evaluated. -env is a funcion used to lookup a variable in the local scope." - (cond ((null expr) expr) ; explicitly eval atoms to themselves +(defun evl* (expr env) + (declare (optimize debug) (function env)) + "evaluate expr in env without error handling. see evl:evl for full docs." + (let ((*ctx* expr)) + (cond ((null expr) expr) ((stringp expr) expr) ((numberp expr) expr) ((functionp expr) expr) ((keywordp expr) expr) - ((symbolp expr) (funcall env expr)) ; get symbol from env + ((symbolp expr) (funcall env expr)) ; get var from env - ((car-is expr 'quote) (cadr expr)) ; don't evaluate + ((car? expr 'declare) nil) ; ignore - ((car-is expr 'progn) ; evaluate all exprs and return the last result - (first (last (mapcar (lambda (e) (evl e env)) (cdr expr))))) + ((car? expr 'quote) + (if (= (length expr) 2) (cadr expr) + (evl-error expr "quote expects 1 argument"))) - ((car-is expr 'if) ; if - (destructuring-bind (test then &optional else) (cdr expr) - (if (evl test env) (evl then env) (evl else env)))) + ((car? expr 'cl-user::~ 'evl:~ 'veq:~) ; coerce value packs + (dev/eval-coerce-values (cdr expr) #'evl* env)) + + ((car? expr 'and) (dev/do-and (cdr expr) #'evl env)) + ((car? expr 'or) (dev/do-or (cdr expr) #'evl env)) + + ((car? expr 'cl-user::~~ '~~) ; coerce apply fx to values + (destructuring-bind (fx &rest rest) (cdr expr) + (dev/eval-coerce-apply-values fx rest #'evl* env))) + + ((car? expr 'values) + (values-list (mapcar (lambda (x) (evl* x env)) (cdr expr)))) + + ((car? expr 'progn) + (destructuring-bind (&optional a &rest rest) (cdr expr) + (if rest (progn (evl* a env) (evl* (cons 'progn rest) env)) + (evl* a env)))) - ((car-is-in expr '(lambda lmb)) ; lambda + ((car? expr 'lambda 'lmb) (destructuring-bind (kk &rest rest) (cdr expr) - (evl/eval-lambda kk rest #'evl env))) + (dev/eval-lambda kk rest #'evl* env))) - ((car-is expr 'let) ; define local vars + ((car? expr 'let) (destructuring-bind (vars &rest body) (cdr expr) - (evl/do-let vars body #'evl env))) + (dev/do-let vars body #'evl* env))) + + ((car? expr 'if) + (destructuring-bind (test then &optional else) (cdr expr) + (if (evl* test env) (evl* then env) (evl* else env)))) + + ((car? expr 'when) + (destructuring-bind (cnd &rest rest) (cdr expr) + (evl* `(if ,cnd (progn ,@rest)) env))) + + ((car? expr 'unless) + (destructuring-bind (cnd &rest rest) (cdr expr) + (evl* `(if (not ,cnd) (progn ,@rest)) env))) + + ((car? expr 'cond) + (evl/err/ctx `(,@expr) + (when (cdr expr) + (destructuring-bind ((cnd &optional x) &rest rest) + (cdr expr) + (dev/do-cond cnd x rest #'evl* env))))) - ((car-is-in expr '(destructuring-bind dsb)) ; dsb + ((car? expr 'destructuring-bind 'dsb) (destructuring-bind (vars in &rest rest) (cdr expr) - (evl/eval-dsb vars in rest #'evl env))) + (dev/eval-dsb vars in rest #'evl* env))) - ((car-is expr 'cond) ; if else-if ... else - (destructuring-bind ((cnd x) &rest rest) (cdr expr) - (evl/do-cond cnd x rest #'evl env))) + ((car? expr 'multiple-value-bind 'mvb 'veq:mvb) + (destructuring-bind (vars in &rest rest) (cdr expr) + (dev/eval-mvb vars in rest #'evl* env))) + + ((car? expr 'multiple-value-list 'mvl) + (multiple-value-list (evl* (cadr expr) env))) - ((car-is-in expr '(labels lbl)) ; define local functions + ((car? expr 'labels 'lbl) (destructuring-bind (pairs &rest body) (cdr expr) - (evl/do-labels pairs body #'evl env))) + (dev/do-labels pairs body #'evl* env))) + + ((consp expr) ; (apply (fx/lambda) ...) + (evl/err/ctx `(,@expr) + (apply (evl* (car expr) env) + (mapcar (lambda (x) (evl* x env)) + (cdr expr))))) + (t (error "~&-->>~%invalid expression:~% ~s <<--~&" + expr))))) + + +(defun evl (expr &optional (env (env/new))) + (declare (optimize debug) (function env)) + "evaluate an EVL expression in env. + +arguments: + - expr: the expression that should be evaluated. + - env: a funcion used to lookup a variable in scope. see: (evl:env/new) + +supports CL syntax: + - if, and, or, cond, when, unless, progn + - lambda (lmb), labels (lbl), + - let, quote, values, multiple-value-list (mvl), + - destructuring-bind (dsb), multiple-value-bind (mvb), + +non CL syntax: + - (~ ...) coerce value packs to a single values. + - (~~ fx ...) coerce all values and apply fx. - ((consp expr) ; (apply fx/lambda ...) - (apply (evl (car expr) env) - (mapcar (lambda (x) (evl x env)) - (cdr expr)))) - (t (error "~&-->>~%[EVL]: invalid expression:~% ~a <<--~&" - expr)))) +deviations from regular CL syntax: + - there is no function name space; variables and functions in environment are + indistinguishable. + - inconsistent (left to right) argument evaluation (TODO: check). + - &optional, &key and &rest are supported as arguments in lambda, labels, + destructuring-bind. but default values in optional/key are not supported (yet), + so all defaults are nil. + - &aux is not supported. + " + (evl/err/ctx-handle expr (evl* expr env))) -(defun evl* (expr &optional (env (new-env))) - (evl expr env)) +(defmacro with-env ((&optional (env (env/new))) &body body) + "evaluate '(progn ,@body) in env with error handling." + (with-gensyms (env*) + `(let ((,env* ,env)) (declare (function ,env*)) + (evl '(progn ,@body) ,env*)))) diff --git a/src/packages.lisp b/src/packages.lisp index bca7430..edbf30a 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -1,12 +1,27 @@ (defpackage #:evl (:use #:common-lisp) (:nicknames #:cl-evl) - (:export #:+std-env+ #:evl #:xprt - #:evl #:evl* #:evl/env #:evl/extenv - #:evl/do-cond - #:evl/do-labels - #:evl/do-let - #:evl/eval-dsb #:evl/eval-lambda - #:car-is #:car-is-in - #:dsb #:lbl #:lmb)) + (:export #:v? #:+std-env+ + #:evl #:evl* *act* #:with-env #:evl-error + ; language + #:str? #:num? #:function? #:keyword? #:symbol? #:null? #:list? #:cons? + #:even? #:odd? #:some? #:every? #:zero? #:member? #:car? + #:~ #:~~ #:dsb #:lbl #:lmb #:mvb #:mvl #:lst + #:g/with-rules #:g/g #:later + #:g/itr/all + #:g/acc/all + #:g/acc/n + #:g/acc/until + #:g/itr/n + #:g/itr/until + ; utils + #:later + #:env/extend-pair #:env/extend-alist #:env/empty #:env/new #:env/merge + #:dev/do-or #:dev/do-and + #:dev/do-cond #:dev/do-labels #:dev/do-let + #:dev/eval-dsb #:dev/eval-mvb #:dev/eval-lambda #:dev/eval-coerce-values)) + +(defpackage #:evl/code + (:use #:common-lisp) + (:export #:gen #:signatures)) diff --git a/src/utils.lisp b/src/utils.lisp index 748daf5..f643328 100644 --- a/src/utils.lisp +++ b/src/utils.lisp @@ -1,10 +1,25 @@ (in-package :evl) -(defmacro xprt (a &aux (a* (gensym "A"))) - "print expression (a) and the corresponding output. returns the result" - `(let ((,a* ,a)) - (format t "~&>> ~a~%;; ~a~%" ',a ,a*) - ,a*)) +(defmacro abbrev (short long) `(defmacro ,short (&rest args) `(,',long ,@args))) +(defmacro ~ (&rest rest) "wraps rest in (mvc #'values ...)." + `(mvc #'values ,@rest)) + +(defmacro ~~ (fx &rest rest) "(mvc fx (~ ,@rest))." + `(mvc #',fx (~ ,@rest))) ; TODO: fx namespace? + +(defmacro lst (&body body) + "get all (values ... ) in body as a list. +almost like multiple-value-list, except it handles multiple arguments." + `(mvc #'list (~ ,@body))) + +(abbrev mvc multiple-value-call) +(abbrev mvb multiple-value-bind) +(abbrev mvl multiple-value-list) +(abbrev dsb destructuring-bind) + +(defun v? (&optional (silent t) + &aux (v (slot-value (asdf:find-system 'evl) 'asdf:version))) + "return/print evl version." (unless silent (format t "~&EVL version: ~a~%." v)) v) (defun flatten (x) (declare (optimize (speed 3)) (list x)) @@ -16,9 +31,17 @@ (defun mkstr (&rest args) (with-output-to-string (s) (dolist (a args) (princ a s)))) +(defmacro with-gensyms (syms &body body) + `(let ,(mapcar #'(lambda (s) `(,s (gensym ,(symbol-name s)))) syms) ,@body)) + (defun match-pref (s pref &optional d) (declare (optimize (speed 3)) (string s pref)) "s if s starts with pref; or d" (if (and (<= (length pref) (length s)) (string= pref s :end2 (length pref))) s d)) +(defmacro lmb (&rest rest) "alias for lambda" `(lambda ,@rest)) +(defmacro later (expr) + "wrap expression in (lambda () ...)." + `(lambda () ,expr)) + diff --git a/test/evl-2.lisp b/test/evl-2.lisp new file mode 100644 index 0000000..5508ddf --- /dev/null +++ b/test/evl-2.lisp @@ -0,0 +1,69 @@ + +(in-package #:evl-tests) + +(plan 1) + +(subtest "test evl-2" + + (is (evl '(cond ((< 2 1) 7) ((< 1 2) 8) (t :aa))) 8) + (is (evl '(cond ((< 1 2) 7) ((< 2 1) 8) (t :aa))) 7) + (is (evl '(cond ((< 2 1) 7) ((< 3 1) 8) (t :aa))) :aa) + + (is (evl '(cond ((< 1 3)))) t) + (is (evl '(cond ((member :a '(:b :a :c))))) '(:a :c)) + (is (evl '(cond ((member :x '(:b :a :c))))) nil) + + (is (evl '(let (a (b 20)) (list a b))) (list nil 20)) + (is (evl '(let ((a 1) (b 20)) (+ a b))) (+ 1 20)) + (is (evl '(let ((a 1) (b 20)) (+ a b) (- a b))) (- 1 20)) + + (is-error (evl '(let ((a 1) (b (1+ a))) + (list a b))) + 'warning) + + (is (evl '(let ((fx (lambda (x) (+ 1 x)))) + (fx (fx 1)))) + 3) + + (is (evl '(labels ((fact (x) (if (zerop x) + 1 + (* x (fact (1- x)))))) + (fact 7))) + 5040) + (is (evl '(labels ((add0 (x) (add1 (sub1 x))) + (add1 (x) (1+ x)) + (sub1 (x) (1- x))) + (list 333) + (add0 7))) + 7) + + (is (evl '(destructuring-bind ((xxx yyy) &rest zzz) + '((:a :b) :c :d) + (list :ok yyy xxx zzz))) + '(:ok :b :a (:c :d))) + (is (evl '(destructuring-bind ((xxx yyy) &rest zzz) + (list (list :a :b) :c :d (1+ 1)) + (list xxx) + (list :ok xxx yyy zzz))) + '(:ok :a :b (:c :d 2))) + + (is (evl '(dsb (aa &optional b&b) + (list 2) + (list :ok aa b&b 3))) + '(:ok 2 nil 3)) + + (is (evl '(labels ((fib (n s) + (if (>= (length s) n) s + (fib n (cons (apply + (subseq s 0 2)) + s))))) + (reverse (fib 10 (list 1 0))))) + '(0 1 1 2 3 5 8 13 21 34)) + (is (evl '(let ((kk (labels ((yx (b) (1+ b)) + (fx (a) (yx a))) + fx))) + (kk 33))) + 34)) + +(unless (finalize) (error "error in test evl-2")) + + diff --git a/test/evl-generator.lisp b/test/evl-generator.lisp new file mode 100644 index 0000000..6d82a7b --- /dev/null +++ b/test/evl-generator.lisp @@ -0,0 +1,95 @@ + +(in-package #:evl-tests) + +(plan 2) + +(subtest "test generator" + (g/with-rules + ((gx i (cond ((< i 4) (values i (g/g gx (1+ i))))))) + (let ((evl:*act* (lambda (s) (lqn:out "hi~a |>" s)))) + (is (lqn:stdstr (let ((gg (g/g gx 0))) + (g/itr/all gg #'princ) + (g/itr/all gg))) + "0123hi0 |>hi1 |>hi2 |>hi3 |>"))) + + + (g/with-rules + ((gx i (cond ((< i 10) (values i (g/g gx (progn (princ :/exec) + (1+ i)))))))) + (is (lqn:stdstr (let ((gg (g/g gx 0))) + (g/itr/n gg 3 #'princ))) + "0/EXEC1/EXEC2")) + + (g/with-rules + ((gen-a i (cond ((< i 4) (values i (g/g gen-a (1+ i)))) + ((< i 14) (values i (g/g gen-a (+ 3 i)))))) + (gen-b l (cond ((and l (cdr l)) (values (car l) (g/g gen-b (cdr l)))) + ((car l) (values (car l) t))))) + (is (lqn:stdstr + (let* ((gint (g/g gen-a 0)) + (gintb1 (g/itr/n gint 3 (lambda (s) (lqn:out "hi ~a" s)))) + (gintb2 (g/itr/n gint 5 (lambda (s) (lqn:out "hi again ~a." s)))) + (gintc (g/itr/n gintb1 2 (lambda (s) (lqn:out "hello ~a." s))))) + (declare (ignorable gintb2)) + (print :--) + (g/itr/n gintc 100 (lambda (s) (lqn:out "oh no ~a." s))))) + "hi 0hi 1hi 2hi again 0.hi again 1.hi again 2.hi again 3.hi again 4.hello 3.hello 4. +:-- oh no 7.oh no 10.oh no 13.")) + + (g/with-rules + ((gx i (values i (if (< i 4) (g/g gx (1+ i)) t)))) + (let* ((gg (g/g gx 0))) + ; (g/itr/all gg #'princ) + + (is (mvl (g/acc/all gg)) '(nil (4 3 2 1 0)) ) + (is (mvb (g* val) (g/acc/n gg 2) (list val (functionp g*))) '((1 0) t)) + + (is (mvl (g/acc/all gg #'cons (lambda (s) (lqn:fmt "~a/" s)))) + '(nil ("4/" "3/" "2/" "1/" "0/"))) + (is (mvb (g* val) (g/acc/until gg (lambda (o) (> o 3))) + (list val (functionp g*))) + '((4 3 2 1 0) T)))) + + (g/with-rules + ((gx i (values i (if (< i 20) (g/g gx (1+ i)) t)))) + (let* ((gg (g/g gx 0))) + (mvb (g v) (g/itr/until gg (lambda (i) (= i 10))) + (is (list (functionp g) v) '(t 10))) + (mvb (g v) (g/itr/until gg (lambda (i) (= i 100))) + (is (list (functionp g) v) '(nil 20))) + (mvb (g v) (g/itr/n gg 10) + (is (list (functionp g) v) '(t 9))) + (mvb (g v) (g/itr/n gg 100) + (is (list (functionp g) v) '(nil 20))) + (mvb (g v) (g/itr/all gg) + (is (list (functionp g) v) '(nil 20)))))) + + +(subtest "test generator fizzbuzz" + (labels ((which? (i) (cond ((and #1=(zerop (mod i 3)) + #2=(zerop (mod i 5))) :fizzbuzz) + (#1# :fizz) + (#2# :buzz) + (t i)))) + + (g/with-rules ((gx l (let ((i (car l))) + (values l (g/g gx (list (1+ i) + (which? (1+ i)))))))) + (is (lqn:stdstr + (let ((gg (g/g gx `(1 ,(which? 1))))) + (g/itr/n gg 20 #3=(lambda (s) + (typecase (second s) + (number (lqn:out " ~a" (second s))) + (t (lqn:out "~%~a" (second s)))))))) + " 1 2 +FIZZ 4 +BUZZ +FIZZ 7 8 +FIZZ +BUZZ 11 +FIZZ 13 14 +FIZZBUZZ 16 17 +FIZZ 19 +BUZZ")))) + +(unless (finalize) (error "error in test generator")) diff --git a/test/test-evl-evl.lisp b/test/evl-self.lisp similarity index 57% rename from test/test-evl-evl.lisp rename to test/evl-self.lisp index 91e475a..e6b6471 100644 --- a/test/test-evl-evl.lisp +++ b/test/evl-self.lisp @@ -4,58 +4,60 @@ (let ((kv `((mfx . ,(lambda (x) (* 1000 x))) (xx . 12) (yy . 13) - ,@+std-env+))) + ,@evl:+std-env+))) (subtest "evl-evl" (labels ((env (x) (let ((res (assoc x kv))) (if res (cdr res) (error "[EVL]: undefined variable: ~a" x))))) - (is (evl + (is (evl:evl `(labels ((env. (x) (let ((res (assoc x '((yy . 13000) ,@kv)))) (if res (cdr res) (error "[*EVL*]: undefined variable: ~a" x)))) (evl. (expr env.) + ; simplified implementation of EVL in EVL (cond ((null expr) expr) - ((stringp expr) expr) - ((numberp expr) expr) - ((functionp expr) expr) - ((keywordp expr) expr) - ((symbolp expr) (env. expr)) + ((str? expr) expr) + ((num? expr) expr) + ((function? expr) expr) + ((keyword? expr) expr) + ((symbol? expr) (env. expr)) - ((car-is expr 'quote) (cadr expr)) + ((car? expr 'quote) (cadr expr)) - ((car-is expr 'progn) - (first (last (mapcar (lambda (e) (evl. e env.)) - (cdr expr))))) + ((car? expr 'progn) + (destructuring-bind (a &rest rest) (cdr expr) + (if rest (progn (evl. a env.) (evl. (cons 'progn rest) env.)) + (evl. a env.)))) - ((car-is expr 'dsb*) + ((car? expr 'dsb*) ; SIC (dsb (vars in &rest rest) (cdr expr) - (evl/eval-dsb vars in rest evl. env.))) + (dev/eval-dsb vars in rest evl. env.))) - ((car-is expr 'if) + ((car? expr 'if) (dsb (test then &optional else) (cdr expr) (if (evl. test env.) (evl. then env.) (evl. else env.)))) - ((car-is expr 'cond) + ((car? expr 'cond) (dsb ((cnd x) &rest rest) (cdr expr) - (evl/do-cond cnd x rest evl. env.))) + (dev/do-cond cnd x rest evl. env.))) - ((car-is expr 'lambda) + ((car? expr 'lambda) (dsb (kk &rest rest) (cdr expr) - (evl/eval-lambda kk rest evl. env.))) + (dev/eval-lambda kk rest evl. env.))) - ((car-is expr 'labels) + ((car? expr 'labels*) ; SIC (dsb (pairs &rest body) (cdr expr) - (evl/do-labels pairs body evl. env.))) + (dev/do-labels pairs body evl. env.))) - ((car-is expr 'let) + ((car? expr 'let) (dsb (vars &rest body) (cdr expr) - (evl/do-let vars body evl. env.))) + (dev/do-let vars body evl. env.))) - ((consp expr) + ((cons? expr) (apply (evl. (car expr) env.) - (mapcar (lambda (x) (evl. x env.)) + (mapcar (lmb (x) (evl. x env.)) (cdr expr))))))) (list (evl. 'xx env.) (evl. 'yy env.) @@ -65,9 +67,9 @@ (evl. '(mfx xx) env.) (evl. '(mfx yy) env.) (evl. '((lambda (x) x) :val) env.) - (evl. '(labels ((add0 (x) (add1 (sub1 x))) - (add1 (x) (1+ x)) - (sub1 (x) (1- x))) + (evl. '(labels* ((add0 (x) (add1 (sub1 x))) + (add1 (x) (1+ x)) + (sub1 (x) (1- x))) (add0 7)) env.) (evl. '(cond ((< 1 2) :yes)) env.) (evl. '(cond ((< 2 1) :yes) ((> 2 1) :no)) env.) diff --git a/test/evl-values.lisp b/test/evl-values.lisp new file mode 100644 index 0000000..875dfb6 --- /dev/null +++ b/test/evl-values.lisp @@ -0,0 +1,78 @@ +(in-package #:evl-tests) + +(plan 2) + +(subtest "evl-values-utils" + (is-values (~ (values 9 3 2) (values 5 5)) '(9 3 2 5 5)) + (is (~~ list (values 8 3 1)) '(8 3 1)) + (is (~~ list (values 8 3) (values 7 3)) '(8 3 7 3)) + (is (mvl (values 7 3)) '(7 3)) + (is (lst (values 7 3) (values 8 3)) '(7 3 8 3))) + +(subtest "evl-values" + + (is (multiple-value-list + (evl '(values 1 2 3))) '(1 2 3)) + + (is (evl '(multiple-value-list + (let ((a (list :x :y :z))) + (values (car a) (cdr a))))) + '(:x (:y :z))) + + (is (evl '(multiple-value-list + (let ((a (list :x :y :z))) + (~ (car a) (cdr a))))) + '(:x (:y :z))) + + (is (mvl (evl '(values 1 (values 2 3) 4))) '(1 2 4)) + (is (mvl (evl '(~ 1 (values 2 3) 4))) '(1 2 3 4)) + + (is (multiple-value-list + (evl '(~ 1 (~ 2 (~ 3 4)) 5))) '(1 2 3 4 5)) + (is (multiple-value-list + (evl '(~ 1 2 (~ (+ 3 4) (~ 3 4)) 5))) '(1 2 7 3 4 5)) + + (is (evl '(multiple-value-bind (a b) + (values 1 2) (list b a))) + '(2 1)) + + (is (evl '(multiple-value-bind (a b c) + (values 1 2 (values 3 4)) (list b a c))) + '(2 1 3)) + (is (multiple-value-list + (funcall (evl '(lambda () (values 1 2 3))))) + '(1 2 3) + + (is (multiple-value-list + (evl '(multiple-value-bind (a b) + (values 1 2) (values b a)))) + '(2 1)) + (is (evl '(multiple-value-list (values 1 2))) '(1 2)) + (is (evl '(mvl (mvb (a b) (values 1 2) (values b a)))) + '(2 1)) + + (is (evl '(evl:mvl (evl:mvb (a b) (~ 1 2 ) (~ b a)))) '(2 1)) + (is (multiple-value-list (evl '(progn (values 3 2 1) + (values -3 -2 -7)))) + '(-3 -2 -7)) + (is (evl '(mvl (progn (values 3 2 1) (values -3 -2 -6)))) + '(-3 -2 -6)) + (is (mvl (evl '(~~ (lambda (x y z w) (values z y x w)) + (values 1 2) (values 3 4) ))) + '(3 2 1 4)) + + (is (mvl (evl '(~~ values (values 1 2) (values 3 4)))) + '(1 2 3 4)) + + (is (evl '(mvl (~~ values (values 1 2) (values 3 4)))) '(1 2 3 4)) + (is (evl '(mvl (~~ values (~ (values 1 2) (values 3 4))))) '(1 2 3 4)) + + (is (evl '(mvl (cond ((< 1 2) (values :va :vb))))) '(:va :vb)) + (is (evl '(mvl (cond ((< 1 2) (values :va :vb))))) '(:va :vb)) + (is (evl '(mvl (cond (nil t) ((values :ka :kb))))) '(:ka)) + (is-values (evl '#1=(or (values :mvla :mvlb))) (multiple-value-list #1#)) + (is-values (evl '#2=(and (values :mvla :mvlb))) (multiple-value-list #2#)) + (is-values (evl '(and (~ :mvla :mvlb))) (multiple-value-list (and (values :mvla :mvlb)))) + )) + +(unless (finalize) (error "error in evl-values")) diff --git a/test/test-evl.lisp b/test/evl.lisp similarity index 54% rename from test/test-evl.lisp rename to test/evl.lisp index a0dae83..7acc592 100644 --- a/test/test-evl.lisp +++ b/test/evl.lisp @@ -3,13 +3,14 @@ (plan 2) (subtest "evl default env" - (is-error (evl* 's) 'error) + (is-error (evl 's) 'warning) (is (evl '1 (lambda (k) (declare (ignore k)) (warn "nop"))) 1) (is-error (evl '+ (lambda (k) (declare (ignore k)) (warn "nop"))) 'warning) (is-error (evl '(+ 1 2) (lambda (k) (declare (ignore k)) (warn "nop"))) 'warning) - (is (evl* '+) '+) - (is (evl* '(+ 1 2)) 3) - (is (evl* '(let ((a 1) (b 2)) (list b a))) '(2 1))) + (is (evl '+) '+) + (is (evl '(+ 1 2)) 3) + (is (evl '(let ((a 1) (b 2)) (list b a))) '(2 1)) + (is (with-env () (let ((a 1) (b 2)) (list b a))) '(2 1))) (subtest "evl custom env" @@ -28,15 +29,25 @@ (is (evl '+ #'env) '+) (is (evl 's #'env) 104) (is (evl '(progn s) #'env) 104) - (is (evl '(list s m) (evl/extenv #'env '(s m) '(105 106))) '(105 106)) + (is (evl '(list s m) (env/extend-pair '(s m) '(105 106) #'env)) '(105 106)) (is (evl '((lambda (x) s) -1) #'env) s) - (is (evl '((lambda (x) s) -1) (evl/extenv #'env '(s) (list 999))) 999) + (is (evl '((lambda (x) s) -1) (env/extend-pair '(s) (list 999) #'env)) 999) (is (evl '(+ s k) #'env) (+ s k)) (is (evl '(myfx 1) #'env) 1.3817732) (is (evl '(quote 1) #'env) 1) (is (evl '(quote s) #'env) 's) + (is (evl '(or )) nil) + (is (evl '(or nil)) nil) + (is (evl '(or nil :a :b)) :a) + (is (evl '(and nil :a :b)) nil) + (is (evl '(and )) t) + (is (evl '(and t t :b :c)) :c) + + (is-error (evl '(quote) #'env) 'warning) + (is-error (evl '(quote 1 1) #'env) 'warning) + (is (evl '(quote (s)) #'env) '(s)) (is (evl '(quote (+ 1 2)) #'env) '(+ 1 2)) (is (evl '(quote (+ some-symbol 2)) #'env) '(+ some-symbol 2)) @@ -47,74 +58,21 @@ (is (evl '(if (< 4 1) 2 3) #'env) 3) (is (evl '(if (< 4 1) 2) #'env) nil) - (is (evl '(cond ((< 2 1) 7) ((< 1 2) 8) (t :aa)) - #'env) - 8) - (is (evl '(cond ((< 1 2) 7) ((< 2 1) 8) (t :aa)) - #'env) - 7) - (is (evl '(cond ((< 2 1) 7) ((< 3 1) 8) (t :aa)) - #'env) - :aa) - - (is (funcall (evl '(lambda (x) x) #'env) 99) 99) - (is (funcall (evl '(lambda (x) (1- x) x) #'env) 99) 99) - (is (funcall (evl '(lambda (x) x (1- x)) #'env) 99) 98) (is (evl '((lambda () 77)) #'env) 77) (is (evl '((lambda (x) (+ s x -10000)) 888) #'env) (+ s 888 -10000)) (is (evl '((lambda (x y) (+ s x y)) 888 999) #'env) (+ s 888 999)) (is (evl '((lambda (&rest rest) rest) 999 333) #'env) '(999 333)) + (is (evl '(progn s) #'env) s) + + (is (funcall (evl '(lambda (x) x) #'env) 99) 99) + (is (funcall (evl '(lambda (x) (1- x) x) #'env) 99) 99) + (is (funcall (evl '(lambda (x) x (1- x)) #'env) 99) 98) (is (evl '((lambda (a &optional x) (list a x)) 999) #'env) '(999 nil)) (is (evl '((lambda (a &optional x) (list a x)) 999 777) #'env) '(999 777)) (is (evl '((lambda (a &optional x) 33 (list a x)) 999 777) #'env) '(999 777)) (is (evl '(funcall (lambda (a &optional x) (list a x)) 999 777) #'env) '(999 777)) - - (is (evl '(progn s) #'env) s) - - (is (evl '(let ((a 1) (b 20)) (+ a b)) #'env) (+ 1 20)) - (is (evl '(let ((a 1) (b 20)) (+ a b) (- a b)) #'env) (- 1 20)) - - (is-error (evl '(let ((a 1) (b (1+ a))) - (list a b)) #'env) - error) - - (is (evl '(let ((fx (lambda (x) (+ 1 x)))) - (fx (fx 1))) - #'env) - 3) - - (is (evl '(labels ((fact (x) (if (= x 0) - 1 - (* x (fact (1- x)))))) - (fact 7)) - #'env) - 5040) - (is (evl '(labels ((add0 (x) (add1 (sub1 x))) - (add1 (x) (1+ x)) - (sub1 (x) (1- x))) - (list 333) - (add0 7)) - #'env) - 7) - - (is (evl '(destructuring-bind ((xxx yyy) &rest zzz) - '((:a :b) :c :d) - (list :ok yyy xxx zzz)) - #'env) - '(:ok :b :a (:c :d))) - (is (evl '(destructuring-bind ((xxx yyy) &rest zzz) - (list (list :a :b) :c :d (10+ 1)) - (list xxx) - (list :ok xxx yyy zzz)) - #'env) - '(:ok :a :b (:c :d 11))) - - (is (evl '(dsb (aa &optional b&b) - (list 2) - (list :ok aa b&b 3)) - #'env) - '(:ok 2 nil 3))))) + ))) (unless (finalize) (error "error in test-evl")) diff --git a/test/run.lisp b/test/run.lisp index 20009ab..dc5e726 100644 --- a/test/run.lisp +++ b/test/run.lisp @@ -4,25 +4,40 @@ (:use #:cl #:prove) (:import-from #:evl #:+std-env+ - #:evl #:evl* #:car-is #:evl/extenv #:evl/eval-dsb #:evl/eval-lambda - #:dsb #:lmb #:lbl - #:evl/do-labels #:evl/do-let #:evl/do-cond - ) + #:evl #:evl* #:with-env + ; language + #:str? #:num? #:function? #:keyword? #:symbol? #:null? #:list? #:cons? + #:even? #:odd? #:some? #:every? #:zero? #:member? #:car? + #:~ #:~~ #:dsb #:lbl #:lmb #:mvb #:mvl #:lst + #:g/with-rules #:g/g #:later + #:g/itr/all + #:g/acc/all + #:g/acc/n + #:g/acc/until + #:g/itr/n + #:g/itr/until + ; utils + #:env/extend-pair #:env/extend-alist #:env/empty #:env/new + #:dev/do-cond #:dev/do-labels #:dev/do-let + #:dev/eval-dsb #:dev/eval-mvb #:dev/eval-lambda #:dev/eval-coerce-values) (:export #:run-tests)) (in-package #:evl-tests) (defun -run-tests (files) - (labels ((rel (f) (mapcar (lambda (p) (asdf:system-relative-pathname - "evl/tests" p)) + (labels ((rel (f) (mapcar (lambda (p) (asdf:system-relative-pathname "evl/tests" p)) f))) (loop with fails = 0 for f in (rel files) do ;(format t "~&~%starting tests in: ~a~%" (evl:str! f)) (unless (prove:run f :reporter :fiveam) (incf fails)) - ;(format t "~&done: ~a~%" (evl:str! f)) + ;(format t "~&itrne: ~a~%" (evl:str! f)) finally (return (unless (< fails 1) (uiop:quit 7)))))) (defun run-tests () - (-run-tests '(#P"test/test-evl.lisp" - #P"test/test-evl-evl.lisp"))) + (-run-tests '(#P"test/evl.lisp" + #P"test/evl-2.lisp" + #P"test/evl-values.lisp" + #P"test/evl-self.lisp" + #P"test/evl-generator.lisp" + ))) diff --git a/tmp.svg b/tmp.svg new file mode 100644 index 0000000..9eb6cc9 --- /dev/null +++ b/tmp.svg @@ -0,0 +1,3033 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +