From df2034b2cbcfc315befe9ca6094f8e4b64625237 Mon Sep 17 00:00:00 2001 From: Benjamin Vedder Date: Wed, 3 Apr 2024 18:39:18 +0200 Subject: [PATCH] Squashed 'lispBM/lispBM/' changes from 418272ad..7bd15759 7bd15759 added clean.lisp 512cf8bc small improvements to repl make situtation. needs some work still 7231e200 added a build flag CLEAN_UP_CLOSURES that makes LBM clean the environment (and copy) of closures as they are created. This is slow, but nice on some theoretical level fdfc63ff remove undocumented experimental feature of match 11fda640 added set-union to set-extensions 04215849 stack operation consolidation 1d3ef1eb slight code deduplication pass 5fb4e996 added some missing comparisons to lbmref 02be461c started on a extension library for the set datatype and moved member into that extension lib git-subtree-dir: lispBM/lispBM git-subtree-split: 7bd1575901a23ebdfde2dea60051049b0a69d837 --- doc/lbmref.lisp | 16 +- doc/lbmref.md | 362 +++++++++++++++++++++++----- include/extensions/set_extensions.h | 36 +++ include/lbm_defines.h | 2 - lispbm.mk | 3 +- repl/Makefile | 6 + repl/clean.lisp | 27 +++ repl/clean_cl.h | 150 +++++------- repl/repl.c | 23 +- repl/repl_exts.c | 8 + src/eval_cps.c | 185 ++++++++------ src/extensions/set_extensions.c | 112 +++++++++ src/fundamental.c | 19 -- src/symrepr.c | 1 - tests/test_member_1.lisp | 6 - tests/test_member_2.lisp | 2 - tests/test_member_3.lisp | 1 - 17 files changed, 677 insertions(+), 282 deletions(-) create mode 100644 include/extensions/set_extensions.h create mode 100644 repl/clean.lisp create mode 100644 src/extensions/set_extensions.c delete mode 100644 tests/test_member_1.lisp delete mode 100644 tests/test_member_2.lisp delete mode 100644 tests/test_member_3.lisp diff --git a/doc/lbmref.lisp b/doc/lbmref.lisp index 793128fc..ebe1a577 100644 --- a/doc/lbmref.lisp +++ b/doc/lbmref.lisp @@ -861,6 +861,9 @@ comp-not-eq comp-= comp-> + comp-< + comp->= + comp-<= ) )) @@ -1819,18 +1822,6 @@ )) end))) -(define lists-member - (ref-entry "member" - (list - (para (list "`member` checks if a list contains a given element." - "The form of a `member` expression is `(member list-exp exp)`." - )) - (code '((member (list 1 2 3) 5) - (member (list 1 2 3) 2) - )) - end))) - - (define lists-rotate (ref-entry "rotate" (list @@ -1918,7 +1909,6 @@ lists-setcdr lists-take lists-drop - lists-member lists-reverse lists-rotate lists-merge diff --git a/doc/lbmref.md b/doc/lbmref.md index 7b6de123..e16b51be 100644 --- a/doc/lbmref.md +++ b/doc/lbmref.md @@ -1299,6 +1299,306 @@ nil +--- + + +### < + +Less than comparison. A less than comparison has the form `(> expr1 ... exprN)` and evaluates to `t` if expr1 is less than all of expr2 ... exprN. + + + + + + + + + + + + + + + + + + + + + +
Example Result
+ +```clj +(< 5 2) +``` + + + + +```clj +nil +``` + + +
+ +```clj +(< 5 2) +``` + + + + +```clj +nil +``` + + +
+ +```clj +(< 3.140000f32 1) +``` + + + + +```clj +nil +``` + + +
+ +```clj +(< 1 3.140000f32) +``` + + + + +```clj +t +``` + + +
+ + + + +--- + + +### >= + +Greater than or equal comparison. A greater than comparison has the form `(>= expr1 ... exprN)` and evaluates to `t` if expr1 is greater than or equal to all of expr2 ... exprN. + + + + + + + + + + + + + + + + + + + + + + + + + +
Example Result
+ +```clj +(>= 1 1) +``` + + + + +```clj +t +``` + + +
+ +```clj +(>= 5 2) +``` + + + + +```clj +t +``` + + +
+ +```clj +(>= 2 5) +``` + + + + +```clj +nil +``` + + +
+ +```clj +(>= 3.140000f32 1) +``` + + + + +```clj +t +``` + + +
+ +```clj +(>= 1 3.140000f32) +``` + + + + +```clj +nil +``` + + +
+ + + + +--- + + +### <= + +Less than or equal comparison. A less than or equal comparison has the form `(<= expr1 ... exprN)` and evaluates to `t` if expr1 is less than or equal to all of expr2 ... exprN. + + + + + + + + + + + + + + + + + + + + + + + + + +
Example Result
+ +```clj +(<= 1 1) +``` + + + + +```clj +t +``` + + +
+ +```clj +(<= 5 2) +``` + + + + +```clj +nil +``` + + +
+ +```clj +(<= 2 5) +``` + + + + +```clj +t +``` + + +
+ +```clj +(<= 3.140000f32 1) +``` + + + + +```clj +nil +``` + + +
+ +```clj +(<= 1 3.140000f32) +``` + + + + +```clj +t +``` + + +
+ + + + --- ## Boolean operators @@ -4757,7 +5057,7 @@ The `setcar` is a destructive update of the car field of a cons-cell. ```clj -(define apa '(1 . 2)) +(define apa '(42 . 2)) (setcar apa 42) apa @@ -4819,7 +5119,7 @@ The `setcdr` is a destructive update of the cdr field of a cons-cell. ```clj -(define apa '(1 . 2)) +(define apa '(1 . 42)) (setcdr apa 42) apa @@ -4941,58 +5241,6 @@ apa ---- - - -### member - -`member` checks if a list contains a given element. The form of a `member` expression is `(member list-exp exp)`. - - - - - - - - - - - - - -
Example Result
- -```clj -(member (list 1 2 3) 5) -``` - - - - -```clj -nil -``` - - -
- -```clj -(member (list 1 2 3) 2) -``` - - - - -```clj -(1 2 3) -``` - - -
- - - - --- @@ -5342,7 +5590,7 @@ The `setassoc` function destructively updates a key-value mapping in an alist. T ```clj -(define apa (list '(1 . horse) '(2 . donkey) '(3 . shark))) +(define apa (list '(1 . horse) '(2 . llama) '(3 . shark))) (setassoc apa 2 'llama) ``` @@ -5844,7 +6092,7 @@ To clear a byte array the function bufclear can be used `(bufclear arr optByte o ```clj -(define data [255 255 255 255 255 255 255 255]) +(define data [255 170 170 170 170 170 1 1]) ``` @@ -5852,7 +6100,7 @@ To clear a byte array the function bufclear can be used `(bufclear arr optByte o ```clj -[255 255 255 255 255 255 255 255] +[255 170 170 170 170 170 1 1] ``` diff --git a/include/extensions/set_extensions.h b/include/extensions/set_extensions.h new file mode 100644 index 00000000..92a1bc09 --- /dev/null +++ b/include/extensions/set_extensions.h @@ -0,0 +1,36 @@ +/* + Copyright 2022 Joel Svensson svenssonjoel@yahoo.se + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +*/ + + +/* The set extensions adds a set datatype based upon lists. */ + + +#ifndef SET_EXTENSIONS_H_ +#define SET_EXTENSIONS_H_ + +#include + +#ifdef __cplusplus +extern "C" { +#endif + +bool lbm_set_extensions_init(void); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/include/lbm_defines.h b/include/lbm_defines.h index b805919d..84c92b5e 100644 --- a/include/lbm_defines.h +++ b/include/lbm_defines.h @@ -312,7 +312,6 @@ #define SYM_REG_EVENT_HANDLER 0x20037 #define SYM_TAKE 0x20038 #define SYM_DROP 0x20039 -#define SYM_MEMBER 0x2003A // Apply funs: // Get their arguments in evaluated form on the stack. @@ -536,6 +535,5 @@ #define ENC_SYM_REG_EVENT_HANDLER ENC_SYM(SYM_REG_EVENT_HANDLER) #define ENC_SYM_TAKE ENC_SYM(SYM_TAKE) #define ENC_SYM_DROP ENC_SYM(SYM_DROP) -#define ENC_SYM_MEMBER ENC_SYM(SYM_MEMBER) #endif diff --git a/lispbm.mk b/lispbm.mk index f731a00f..7eaffcba 100644 --- a/lispbm.mk +++ b/lispbm.mk @@ -23,7 +23,8 @@ LISPBM_SRC = $(LISPBM)/src/env.c \ $(LISPBM)/src/extensions/runtime_extensions.c \ $(LISPBM)/src/extensions/matvec_extensions.c \ $(LISPBM)/src/extensions/random_extensions.c \ - $(LISPBM)/src/extensions/loop_extensions.c + $(LISPBM)/src/extensions/loop_extensions.c \ + $(LISPBM)/src/extensions/set_extensions.c LISPBM_INC = -I$(LISPBM)/include \ diff --git a/repl/Makefile b/repl/Makefile index 40dc2d8c..8b60ed1a 100644 --- a/repl/Makefile +++ b/repl/Makefile @@ -20,12 +20,18 @@ ifdef HEAP_VIS CCFLAGS += -DVISUALIZE_HEAP endif +improved_closures: CCFLAGS += -m32 -DCLEAN_UP_CLOSURES +improved_closures: repl clean_cl.h + all: CCFLAGS += -m32 all: repl all64: CCFLAGS += -DLBM64 all64: repl +clean_cl.h: clean.lisp + ./repl --store_env="clean_cl.env" --src=clean.lisp --terminate + xxd -i clean_cl.env clean_cl.h install: all mkdir -p ~/.local/bin diff --git a/repl/clean.lisp b/repl/clean.lisp new file mode 100644 index 00000000..284cfcc2 --- /dev/null +++ b/repl/clean.lisp @@ -0,0 +1,27 @@ + +(define get-vars (lambda (body) + (match (type-of body) + ( type-symbol (set-insert nil body)) + ( type-list (set-union (get-vars (car body)) (get-vars (cdr body)))) + ( _ nil) + ))) + +(define pick-out (lambda (vars env) + (match env + ( nil nil ) + ( ((? b) . (? bs)) (member vars (car b)) (cons b (pick-out vars bs))) + ( ( _ . (? bs)) (pick-out vars bs)) + ))) + +(define clean-cl-env (lambda (clo) + (setix clo 3 (pick-out (get-vars (ix clo 2)) + (ix clo 3))))) + + + + + + + + + diff --git a/repl/clean_cl.h b/repl/clean_cl.h index 85241a73..d09c5d3f 100644 --- a/repl/clean_cl.h +++ b/repl/clean_cl.h @@ -1,95 +1,61 @@ unsigned char clean_cl_env[] = { - 0x0a, 0x00, 0x00, 0x00, 0x73, 0x65, 0x74, 0x2d, 0x69, 0x6e, 0x73, 0x65, - 0x72, 0x74, 0xdc, 0x00, 0x00, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x73, - 0x75, 0x72, 0x65, 0x00, 0x01, 0x01, 0x03, 0x61, 0x00, 0x01, 0x03, 0x73, - 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6d, 0x61, 0x74, - 0x63, 0x68, 0x00, 0x01, 0x03, 0x73, 0x00, 0x01, 0x01, 0x03, 0x6e, 0x69, - 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6c, 0x69, 0x73, 0x74, 0x00, 0x01, 0x03, - 0x61, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, - 0x01, 0x01, 0x01, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x00, 0x03, - 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x73, - 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x65, 0x71, 0x00, - 0x01, 0x03, 0x65, 0x00, 0x01, 0x03, 0x61, 0x00, 0x03, 0x6e, 0x69, 0x6c, - 0x00, 0x01, 0x03, 0x73, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, - 0x01, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x00, 0x03, 0x6e, 0x69, - 0x6c, 0x00, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x73, 0x00, 0x03, - 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x63, 0x6f, 0x6e, 0x73, 0x00, - 0x01, 0x03, 0x65, 0x00, 0x01, 0x01, 0x03, 0x73, 0x65, 0x74, 0x2d, 0x69, - 0x6e, 0x73, 0x65, 0x72, 0x74, 0x00, 0x01, 0x03, 0x61, 0x00, 0x01, 0x03, - 0x65, 0x73, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, - 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, - 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x09, 0x00, - 0x00, 0x00, 0x73, 0x65, 0x74, 0x2d, 0x75, 0x6e, 0x69, 0x6f, 0x6e, 0x9f, - 0x00, 0x00, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x73, 0x75, 0x72, 0x65, - 0x00, 0x01, 0x01, 0x03, 0x73, 0x31, 0x00, 0x01, 0x03, 0x73, 0x32, 0x00, - 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6d, 0x61, 0x74, 0x63, - 0x68, 0x00, 0x01, 0x03, 0x73, 0x31, 0x00, 0x01, 0x01, 0x03, 0x6e, 0x69, - 0x6c, 0x00, 0x01, 0x03, 0x73, 0x32, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, - 0x01, 0x01, 0x01, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x00, 0x03, - 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x65, 0x73, - 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x73, 0x65, 0x74, - 0x2d, 0x75, 0x6e, 0x69, 0x6f, 0x6e, 0x00, 0x01, 0x03, 0x65, 0x73, 0x00, - 0x01, 0x01, 0x03, 0x73, 0x65, 0x74, 0x2d, 0x69, 0x6e, 0x73, 0x65, 0x72, - 0x74, 0x00, 0x01, 0x03, 0x65, 0x00, 0x01, 0x03, 0x73, 0x32, 0x00, 0x03, - 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, - 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, - 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x08, 0x00, 0x00, 0x00, 0x67, 0x65, - 0x74, 0x2d, 0x76, 0x61, 0x72, 0x73, 0xf7, 0x00, 0x00, 0x00, 0x01, 0x03, - 0x63, 0x6c, 0x6f, 0x73, 0x75, 0x72, 0x65, 0x00, 0x01, 0x01, 0x03, 0x62, - 0x6f, 0x64, 0x79, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, - 0x6d, 0x61, 0x74, 0x63, 0x68, 0x00, 0x01, 0x01, 0x03, 0x74, 0x79, 0x70, - 0x65, 0x2d, 0x6f, 0x66, 0x00, 0x01, 0x03, 0x62, 0x6f, 0x64, 0x79, 0x00, - 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x74, 0x79, 0x70, 0x65, - 0x2d, 0x73, 0x79, 0x6d, 0x62, 0x6f, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x73, - 0x65, 0x74, 0x2d, 0x69, 0x6e, 0x73, 0x65, 0x72, 0x74, 0x00, 0x01, 0x03, - 0x62, 0x6f, 0x64, 0x79, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, - 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, - 0x74, 0x79, 0x70, 0x65, 0x2d, 0x6c, 0x69, 0x73, 0x74, 0x00, 0x01, 0x01, - 0x03, 0x73, 0x65, 0x74, 0x2d, 0x75, 0x6e, 0x69, 0x6f, 0x6e, 0x00, 0x01, - 0x01, 0x03, 0x67, 0x65, 0x74, 0x2d, 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, - 0x01, 0x03, 0x63, 0x61, 0x72, 0x00, 0x01, 0x03, 0x62, 0x6f, 0x64, 0x79, - 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, - 0x01, 0x03, 0x67, 0x65, 0x74, 0x2d, 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, - 0x01, 0x03, 0x63, 0x64, 0x72, 0x00, 0x01, 0x03, 0x62, 0x6f, 0x64, 0x79, - 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, - 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, - 0x5f, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, - 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, - 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x08, 0x00, 0x00, 0x00, 0x70, 0x69, 0x63, - 0x6b, 0x2d, 0x6f, 0x75, 0x74, 0xfb, 0x00, 0x00, 0x00, 0x01, 0x03, 0x63, - 0x6c, 0x6f, 0x73, 0x75, 0x72, 0x65, 0x00, 0x01, 0x01, 0x03, 0x76, 0x61, - 0x72, 0x73, 0x00, 0x01, 0x03, 0x65, 0x6e, 0x76, 0x00, 0x03, 0x6e, 0x69, - 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6d, 0x61, 0x74, 0x63, 0x68, 0x00, 0x01, - 0x03, 0x65, 0x6e, 0x76, 0x00, 0x01, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, - 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, - 0x01, 0x01, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x62, 0x00, 0x03, 0x6e, - 0x69, 0x6c, 0x00, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x62, 0x73, 0x00, - 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6d, 0x65, 0x6d, 0x62, - 0x65, 0x72, 0x00, 0x01, 0x03, 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, 0x01, - 0x03, 0x63, 0x61, 0x72, 0x00, 0x01, 0x03, 0x62, 0x00, 0x03, 0x6e, 0x69, - 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x63, 0x6f, - 0x6e, 0x73, 0x00, 0x01, 0x03, 0x62, 0x00, 0x01, 0x01, 0x03, 0x70, 0x69, - 0x63, 0x6b, 0x2d, 0x6f, 0x75, 0x74, 0x00, 0x01, 0x03, 0x76, 0x61, 0x72, - 0x73, 0x00, 0x01, 0x03, 0x62, 0x73, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, - 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, - 0x01, 0x03, 0x5f, 0x00, 0x01, 0x03, 0x3f, 0x00, 0x01, 0x03, 0x62, 0x73, - 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x70, 0x69, 0x63, - 0x6b, 0x2d, 0x6f, 0x75, 0x74, 0x00, 0x01, 0x03, 0x76, 0x61, 0x72, 0x73, - 0x00, 0x01, 0x03, 0x62, 0x73, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, - 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x6e, - 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x0c, 0x00, 0x00, 0x00, - 0x63, 0x6c, 0x65, 0x61, 0x6e, 0x2d, 0x63, 0x6c, 0x2d, 0x65, 0x6e, 0x76, - 0x8b, 0x00, 0x00, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x73, 0x75, 0x72, - 0x65, 0x00, 0x01, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x00, 0x03, 0x6e, 0x69, - 0x6c, 0x00, 0x01, 0x01, 0x03, 0x73, 0x65, 0x74, 0x69, 0x78, 0x00, 0x01, - 0x03, 0x63, 0x6c, 0x6f, 0x00, 0x01, 0x05, 0x00, 0x00, 0x00, 0x03, 0x01, - 0x01, 0x03, 0x70, 0x69, 0x63, 0x6b, 0x2d, 0x6f, 0x75, 0x74, 0x00, 0x01, - 0x01, 0x03, 0x67, 0x65, 0x74, 0x2d, 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, - 0x01, 0x03, 0x69, 0x78, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x00, 0x01, - 0x05, 0x00, 0x00, 0x00, 0x02, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, - 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x69, 0x78, 0x00, 0x01, 0x03, 0x63, - 0x6c, 0x6f, 0x00, 0x01, 0x05, 0x00, 0x00, 0x00, 0x03, 0x03, 0x6e, 0x69, + 0x08, 0x00, 0x00, 0x00, 0x67, 0x65, 0x74, 0x2d, 0x76, 0x61, 0x72, 0x73, + 0xf7, 0x00, 0x00, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x73, 0x75, 0x72, + 0x65, 0x00, 0x01, 0x01, 0x03, 0x62, 0x6f, 0x64, 0x79, 0x00, 0x03, 0x6e, + 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6d, 0x61, 0x74, 0x63, 0x68, 0x00, + 0x01, 0x01, 0x03, 0x74, 0x79, 0x70, 0x65, 0x2d, 0x6f, 0x66, 0x00, 0x01, + 0x03, 0x62, 0x6f, 0x64, 0x79, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, + 0x01, 0x03, 0x74, 0x79, 0x70, 0x65, 0x2d, 0x73, 0x79, 0x6d, 0x62, 0x6f, + 0x6c, 0x00, 0x01, 0x01, 0x03, 0x73, 0x65, 0x74, 0x2d, 0x69, 0x6e, 0x73, + 0x65, 0x72, 0x74, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, + 0x62, 0x6f, 0x64, 0x79, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, + 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x74, 0x79, 0x70, 0x65, 0x2d, 0x6c, + 0x69, 0x73, 0x74, 0x00, 0x01, 0x01, 0x03, 0x73, 0x65, 0x74, 0x2d, 0x75, + 0x6e, 0x69, 0x6f, 0x6e, 0x00, 0x01, 0x01, 0x03, 0x67, 0x65, 0x74, 0x2d, + 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, 0x01, 0x03, 0x63, 0x61, 0x72, 0x00, + 0x01, 0x03, 0x62, 0x6f, 0x64, 0x79, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, + 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x67, 0x65, 0x74, 0x2d, + 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, 0x01, 0x03, 0x63, 0x64, 0x72, 0x00, + 0x01, 0x03, 0x62, 0x6f, 0x64, 0x79, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, + 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, + 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x5f, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, - 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00 + 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x08, + 0x00, 0x00, 0x00, 0x70, 0x69, 0x63, 0x6b, 0x2d, 0x6f, 0x75, 0x74, 0xfb, + 0x00, 0x00, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x73, 0x75, 0x72, 0x65, + 0x00, 0x01, 0x01, 0x03, 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, 0x03, 0x65, + 0x6e, 0x76, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x6d, + 0x61, 0x74, 0x63, 0x68, 0x00, 0x01, 0x03, 0x65, 0x6e, 0x76, 0x00, 0x01, + 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, + 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x01, 0x01, 0x03, 0x3f, 0x00, + 0x01, 0x03, 0x62, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x3f, + 0x00, 0x01, 0x03, 0x62, 0x73, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, + 0x01, 0x03, 0x6d, 0x65, 0x6d, 0x62, 0x65, 0x72, 0x00, 0x01, 0x03, 0x76, + 0x61, 0x72, 0x73, 0x00, 0x01, 0x01, 0x03, 0x63, 0x61, 0x72, 0x00, 0x01, + 0x03, 0x62, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, + 0x00, 0x01, 0x01, 0x03, 0x63, 0x6f, 0x6e, 0x73, 0x00, 0x01, 0x03, 0x62, + 0x00, 0x01, 0x01, 0x03, 0x70, 0x69, 0x63, 0x6b, 0x2d, 0x6f, 0x75, 0x74, + 0x00, 0x01, 0x03, 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, 0x03, 0x62, 0x73, + 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, + 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x01, 0x03, 0x5f, 0x00, 0x01, 0x03, + 0x3f, 0x00, 0x01, 0x03, 0x62, 0x73, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, + 0x01, 0x01, 0x03, 0x70, 0x69, 0x63, 0x6b, 0x2d, 0x6f, 0x75, 0x74, 0x00, + 0x01, 0x03, 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, 0x03, 0x62, 0x73, 0x00, + 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, + 0x69, 0x6c, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, + 0x6c, 0x00, 0x0c, 0x00, 0x00, 0x00, 0x63, 0x6c, 0x65, 0x61, 0x6e, 0x2d, + 0x63, 0x6c, 0x2d, 0x65, 0x6e, 0x76, 0x8b, 0x00, 0x00, 0x00, 0x01, 0x03, + 0x63, 0x6c, 0x6f, 0x73, 0x75, 0x72, 0x65, 0x00, 0x01, 0x01, 0x03, 0x63, + 0x6c, 0x6f, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, 0x73, + 0x65, 0x74, 0x69, 0x78, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x00, 0x01, + 0x05, 0x00, 0x00, 0x00, 0x03, 0x01, 0x01, 0x03, 0x70, 0x69, 0x63, 0x6b, + 0x2d, 0x6f, 0x75, 0x74, 0x00, 0x01, 0x01, 0x03, 0x67, 0x65, 0x74, 0x2d, + 0x76, 0x61, 0x72, 0x73, 0x00, 0x01, 0x01, 0x03, 0x69, 0x78, 0x00, 0x01, + 0x03, 0x63, 0x6c, 0x6f, 0x00, 0x01, 0x05, 0x00, 0x00, 0x00, 0x02, 0x03, + 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x01, 0x03, + 0x69, 0x78, 0x00, 0x01, 0x03, 0x63, 0x6c, 0x6f, 0x00, 0x01, 0x05, 0x00, + 0x00, 0x00, 0x03, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x03, 0x6e, 0x69, 0x6c, + 0x00, 0x03, 0x6e, 0x69, 0x6c, 0x00, 0x01, 0x03, 0x6e, 0x69, 0x6c, 0x00, + 0x03, 0x6e, 0x69, 0x6c, 0x00 }; -unsigned int clean_cl_env_len = 1103; +unsigned int clean_cl_env_len = 689; diff --git a/repl/repl.c b/repl/repl.c index 4672fe88..8dcc5104 100644 --- a/repl/repl.c +++ b/repl/repl.c @@ -31,10 +31,6 @@ #include "lispbm.h" #include "lbm_flat_value.h" #include "lbm_prof.h" -#include "extensions/array_extensions.h" -#include "extensions/string_extensions.h" -#include "extensions/math_extensions.h" -#include "extensions/runtime_extensions.h" #include "lbm_custom_type.h" #include "lbm_channel.h" @@ -42,7 +38,9 @@ #include "repl_exts.h" #include "repl_defines.h" +#ifdef CLEAN_UP_CLOSURES #include "clean_cl.h" +#endif #define GC_STACK_SIZE 256 @@ -64,7 +62,6 @@ bool terminate_after_startup = false; volatile lbm_cid startup_cid = -1; volatile lbm_cid store_result_cid = -1; volatile bool silent_mode = false; -bool load_lib_clean_cl = false; void shutdown_procedure(void); @@ -309,7 +306,6 @@ lbm_const_heap_t const_heap; #define STORE_RESULT 0x0403 #define TERMINATE 0x0404 #define SILENT_MODE 0x0405 -#define LOAD_LIB_CLEAN_CL 0x0406 struct option options[] = { {"help", no_argument, NULL, 'h'}, @@ -320,7 +316,6 @@ struct option options[] = { {"store_res", required_argument, NULL, STORE_RESULT}, {"terminate", no_argument, NULL, TERMINATE}, {"silent", no_argument, NULL, SILENT_MODE}, - {"lib_clean_cl", no_argument, NULL, LOAD_LIB_CLEAN_CL}, {0,0,0,0}}; typedef struct src_list_s { @@ -386,7 +381,6 @@ void parse_opts(int argc, char **argv) { printf(" --terminate Terminate the REPL after evaluating the\n"\ " source files specified with --src/-s\n"); printf(" --silent The REPL will print as little as possible\n"); - printf(" --lib_clean_cl Load the clean_cl library for closure cleaning\n"); printf("\n"); printf("Multiple sourcefiles can be added with multiple uses of the --src/-s flag.\n" \ "Multiple sources are evaluated in sequence in the order they are specified\n" \ @@ -414,9 +408,6 @@ void parse_opts(int argc, char **argv) { case SILENT_MODE: silent_mode = true; break; - case LOAD_LIB_CLEAN_CL: - load_lib_clean_cl=true; - break; default: break; } @@ -534,12 +525,12 @@ int init_repl() { init_exts(); /* Load clean_cl library into heap */ - if (load_lib_clean_cl) { - if (!load_flat_library(clean_cl_env, clean_cl_env_len)) { - printf("Error loading a flat library\n"); - return 1; - } +#ifdef CLEAN_UP_CLOSURES + if (!load_flat_library(clean_cl_env, clean_cl_env_len)) { + printf("Error loading a flat library\n"); + return 1; } +#endif if (pthread_create(&lispbm_thd, NULL, eval_thd_wrapper, NULL)) { printf("Error creating evaluation thread\n"); diff --git a/repl/repl_exts.c b/repl/repl_exts.c index 00362a70..17c5c32d 100644 --- a/repl/repl_exts.c +++ b/repl/repl_exts.c @@ -23,6 +23,11 @@ #include #include #include +#include "extensions/array_extensions.h" +#include "extensions/string_extensions.h" +#include "extensions/math_extensions.h" +#include "extensions/runtime_extensions.h" +#include "extensions/set_extensions.h" // Macro expanders @@ -556,6 +561,9 @@ int init_exts(void) { if (!lbm_runtime_extensions_init(false)) { return 0; } + if (!lbm_set_extensions_init()) { + return 0; + } lbm_add_extension("unsafe-call-system", ext_unsafe_call_system); lbm_add_extension("exec", ext_exec); diff --git a/src/eval_cps.c b/src/eval_cps.c index 337d474e..aab3c255 100644 --- a/src/eval_cps.c +++ b/src/eval_cps.c @@ -539,6 +539,38 @@ static void stack_push_4(lbm_stack_t *s, lbm_uint v1, lbm_uint v2, lbm_uint v3, error_ctx(ENC_SYM_STACK_ERROR); } +static void stack_push_5(lbm_stack_t *s, lbm_uint v1, lbm_uint v2, lbm_uint v3, lbm_uint v4, lbm_uint v5) { + if (s->sp + 4 < s->size) { + lbm_uint *t = &s->data[s->sp]; + t[0] = v1; + t[1] = v2; + t[2] = v3; + t[3] = v4; + t[4] = v5; + s->sp += 5; + if (s->sp > s->max_sp) s->max_sp = s->sp; + return; + } + error_ctx(ENC_SYM_STACK_ERROR); +} + +static void stack_push_6(lbm_stack_t *s, lbm_uint v1, lbm_uint v2, lbm_uint v3, lbm_uint v4, lbm_uint v5, lbm_uint v6) { + if (s->sp + 5 < s->size) { + lbm_uint *t = &s->data[s->sp]; + t[0] = v1; + t[1] = v2; + t[2] = v3; + t[3] = v4; + t[4] = v5; + t[5] = v6; + s->sp += 6; + if (s->sp > s->max_sp) s->max_sp = s->sp; + return; + } + error_ctx(ENC_SYM_STACK_ERROR); +} + + static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) { if (lbm_is_ptr(a)) { lbm_cons_t *cell = lbm_ref_cell(a); @@ -1058,28 +1090,20 @@ static void error_ctx_base(lbm_value err_val, bool has_at, lbm_value at, unsigne lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL); msg = lbm_cons(lbm_enc_i(ctx_running->id), msg); msg = lbm_cons(ENC_SYM_EXIT_ERROR, msg); - if (lbm_is_symbol_merror(msg)) { - // If this happens something is pretty seriously wrong. - print_error_message(err_val, - has_at, - at, - row, - column, - ctx_running->row0, - ctx_running->row1); - } else { + if (!lbm_is_symbol_merror(msg)) { lbm_find_receiver_and_send(ctx_running->parent, msg); + goto error_ctx_base_done; } } - } else { - print_error_message(err_val, - has_at, - at, - row, - column, - ctx_running->row0, - ctx_running->row1); } + print_error_message(err_val, + has_at, + at, + row, + column, + ctx_running->row0, + ctx_running->row1); + error_ctx_base_done: ctx_running->r = err_val; finish_ctx(); longjmp(error_jmp_buf, 1); @@ -1496,16 +1520,6 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) { return true; } - /* Comma-qualification experiment. */ - if (lbm_is_comma_qualified_symbol(p)) { - lbm_value sym = get_cadr(p); - lbm_value val = lbm_env_lookup(sym, *env); - if (lbm_is_symbol(SYM_NOT_FOUND)) { - return false; - } - return struct_eq(val, e); - } - if (lbm_is_symbol(p)) { if (lbm_dec_sym(p) == SYM_DONTCARE) return true; return (p == e); @@ -1771,7 +1785,19 @@ static void eval_define(eval_context_t *ctx) { static void eval_lambda(eval_context_t *ctx) { lbm_value cdr = get_cdr(ctx->curr_exp); ctx->r = allocate_closure(get_car(cdr), get_cadr(cdr), ctx->curr_env); +#ifdef CLEAN_UP_CLOSURES + // Todo, lookup once and cache. + lbm_uint sym_id = 0; + if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) { + lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL); + lbm_value app = cons_with_gc(lbm_enc_sym(sym_id), tail, tail); + ctx->curr_exp = app; + } else { + ctx->app_cont = true; + } +#else ctx->app_cont = true; +#endif } // (if cond-expr then-expr else-expr) @@ -3618,10 +3644,12 @@ static void cont_read_next_token(eval_context_t *ctx) { case TOKOPENPAR: sptr[0] = ENC_SYM_NIL; sptr[1] = ENC_SYM_NIL; - stack_push_2(&ctx->K, + stack_push_5(&ctx->K, stream, - READ_APPEND_CONTINUE); - stack_push_3(&ctx->K, stream, lbm_enc_u(0), READ_NEXT_TOKEN); + READ_APPEND_CONTINUE, + stream, + lbm_enc_u(0), + READ_NEXT_TOKEN); ctx->r = ENC_SYM_OPENPAR; return; case TOKCLOSEPAR: { @@ -3678,22 +3706,12 @@ static void cont_read_next_token(eval_context_t *ctx) { lbm_stack_drop(&ctx->K, 2); ctx->r = ENC_SYM_CLOSEPAR; return; - case TOKCONSTSTART: - ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST; - sptr[0] = stream; - sptr[1] = lbm_enc_u(0); - stack_push(&ctx->K, READ_NEXT_TOKEN); - ctx->app_cont = true; - return; + case TOKCONSTSTART: /* fall through */ case TOKCONSTEND: - ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST; - sptr[0] = stream; - sptr[1] = lbm_enc_u(0); - stack_push(&ctx->K, READ_NEXT_TOKEN); - ctx->app_cont = true; - return; case TOKCONSTSYMSTR: - ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS; + if (match == TOKCONSTSTART) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST; + if (match == TOKCONSTEND) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST; + if (match == TOKCONSTSYMSTR) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS; sptr[0] = stream; sptr[1] = lbm_enc_u(0); stack_push(&ctx->K, READ_NEXT_TOKEN); @@ -3914,8 +3932,11 @@ static void cont_read_start_array(eval_context_t *ctx) { } sptr[0] = array; - stack_push_3(&ctx->K, lbm_enc_u(initial_size), lbm_enc_u(0), stream); - stack_push(&ctx->K, READ_APPEND_ARRAY); + stack_push_4(&ctx->K, + lbm_enc_u(initial_size), + lbm_enc_u(0), + stream, + READ_APPEND_ARRAY); ctx->app_cont = true; } else { lbm_channel_reader_close(str); @@ -3990,8 +4011,11 @@ static void cont_read_append_continue(eval_context_t *ctx) { ctx->app_cont = true; return; case SYM_DOT: - stack_push(&ctx->K, READ_DOT_TERMINATE); - stack_push_3(&ctx->K, stream, lbm_enc_u(0), READ_NEXT_TOKEN); + stack_push_4(&ctx->K, + READ_DOT_TERMINATE, + stream, + lbm_enc_u(0), + READ_NEXT_TOKEN); ctx->app_cont = true; return; } @@ -4011,8 +4035,11 @@ static void cont_read_append_continue(eval_context_t *ctx) { sptr[0] = first_cell; sptr[1] = last_cell; sptr[2] = stream; // unchanged. - stack_push(&ctx->K, READ_APPEND_CONTINUE); - stack_push_3(&ctx->K, stream, lbm_enc_u(0), READ_NEXT_TOKEN); + stack_push_4(&ctx->K, + READ_APPEND_CONTINUE, + stream, + lbm_enc_u(0), + READ_NEXT_TOKEN); ctx->app_cont = true; } @@ -4035,15 +4062,23 @@ static void cont_read_eval_continue(eval_context_t *ctx) { ctx->app_cont = true; return; case SYM_DOT: - stack_push(&ctx->K, READ_DOT_TERMINATE); - stack_push_3(&ctx->K, stream, lbm_enc_u(0), READ_NEXT_TOKEN); + stack_push_4(&ctx->K, + READ_DOT_TERMINATE, + stream, + lbm_enc_u(0), + READ_NEXT_TOKEN); ctx->app_cont = true; return; } } - stack_push_3(&ctx->K, stream, env, READ_EVAL_CONTINUE); - stack_push_3(&ctx->K, stream, lbm_enc_u(1), READ_NEXT_TOKEN); + stack_push_6(&ctx->K, + stream, + env, + READ_EVAL_CONTINUE, + stream, + lbm_enc_u(1), + READ_NEXT_TOKEN); ctx->curr_env = env; ctx->curr_exp = ctx->r; @@ -4095,11 +4130,13 @@ static void cont_read_dot_terminate(eval_context_t *ctx) { if (lbm_is_cons(last_cell)) { lbm_set_cdr(last_cell, ctx->r); ctx->r = first_cell; - stack_push_3(&ctx->K, + stack_push_6(&ctx->K, stream, ctx->r, - READ_EXPECT_CLOSEPAR); - stack_push_3(&ctx->K, stream, lbm_enc_u(0), READ_NEXT_TOKEN); + READ_EXPECT_CLOSEPAR, + stream, + lbm_enc_u(0), + READ_NEXT_TOKEN); ctx->app_cont = true; } else { lbm_channel_reader_close(str); @@ -4379,8 +4416,12 @@ static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) { if (lbm_is_cons(val)) { lbm_value flash_cell = ENC_SYM_NIL; handle_flash_status(request_flash_storage_cell(val, &flash_cell)); - stack_push_4(&ctx->K, flash_cell, flash_cell, get_cdr(val), MOVE_LIST_TO_FLASH); - stack_push(&ctx->K, MOVE_VAL_TO_FLASH_DISPATCH); + stack_push_5(&ctx->K, + flash_cell, + flash_cell, + get_cdr(val), + MOVE_LIST_TO_FLASH, + MOVE_VAL_TO_FLASH_DISPATCH); ctx->r = get_car(val); ctx->app_cont = true; return; @@ -4466,8 +4507,9 @@ static void cont_move_list_to_flash(eval_context_t *ctx) { handle_flash_status(write_const_cdr(lst, rest_cell)); sptr[1] = rest_cell; sptr[2] = get_cdr(val); - stack_push(&ctx->K, MOVE_LIST_TO_FLASH); - stack_push(&ctx->K, MOVE_VAL_TO_FLASH_DISPATCH); + stack_push_2(&ctx->K, + MOVE_LIST_TO_FLASH, + MOVE_VAL_TO_FLASH_DISPATCH); ctx->r = get_car(val); } else { sptr[0] = fst; @@ -4576,9 +4618,10 @@ static void cont_qq_expand(eval_context_t *ctx) { lbm_dec_sym(car_val) == SYM_COMMAAT) { error_ctx(ENC_SYM_RERROR); } else { - stack_push_2(&ctx->K, ctx->r, QQ_APPEND); - stack_push_2(&ctx->K, cdr_val, QQ_EXPAND); - stack_push_2(&ctx->K, car_val, QQ_EXPAND_LIST); + stack_push_6(&ctx->K, + ctx->r, QQ_APPEND, + cdr_val, QQ_EXPAND, + car_val, QQ_EXPAND_LIST); ctx->app_cont = true; ctx->r = ENC_SYM_NIL; } @@ -4620,6 +4663,7 @@ static void cont_qq_expand_list(eval_context_t* ctx) { lbm_value l; lbm_pop(&ctx->K, &l); + ctx->app_cont = true; switch(lbm_type_of(l)) { case LBM_TYPE_CONS: { lbm_value car_val = get_car(l); @@ -4629,19 +4673,17 @@ static void cont_qq_expand_list(eval_context_t* ctx) { lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL, ENC_SYM_NIL); lbm_value tmp = cons_with_gc(ENC_SYM_LIST, tl, ENC_SYM_NIL); ctx->r = append(ctx->r, tmp); - ctx->app_cont = true; return; } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL && lbm_dec_sym(car_val) == SYM_COMMAAT) { ctx->r = get_car(cdr_val); - ctx->app_cont = true; return; } else { stack_push(&ctx->K, QQ_LIST); - stack_push_2(&ctx->K, ctx->r, QQ_APPEND); - stack_push_2(&ctx->K, cdr_val, QQ_EXPAND); - stack_push_2(&ctx->K, car_val, QQ_EXPAND_LIST); - ctx->app_cont = true; + stack_push_6(&ctx->K, + ctx->r, QQ_APPEND, + cdr_val, QQ_EXPAND, + car_val, QQ_EXPAND_LIST); ctx->r = ENC_SYM_NIL; } @@ -4651,7 +4693,6 @@ static void cont_qq_expand_list(eval_context_t* ctx) { lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL, ENC_SYM_NIL); lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE, tl, ENC_SYM_NIL); ctx->r = append(ctx->r, tmp); - ctx->app_cont = true; } } } diff --git a/src/extensions/set_extensions.c b/src/extensions/set_extensions.c new file mode 100644 index 00000000..d82ba265 --- /dev/null +++ b/src/extensions/set_extensions.c @@ -0,0 +1,112 @@ +/* + Copyright 2024 Joel Svensson svenssonjoel@yahoo.se + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +*/ + +#include "extensions/set_extensions.h" + +#include "extensions.h" +#include "fundamental.h" + +#define ABORT_ON_MERROR(X) if ((X) == ENC_SYM_MERROR) return ENC_SYM_MERROR; + +static lbm_value ext_member(lbm_value *args, lbm_uint argn); +static lbm_value ext_set_insert(lbm_value *args, lbm_uint argn); +static lbm_value ext_set_union(lbm_value *args, lbm_uint argn); + +bool lbm_set_extensions_init(void) { + bool res = true; + res = res && lbm_add_extension("member", ext_member); + res = res && lbm_add_extension("set-insert", ext_set_insert); + res = res && lbm_add_extension("set-union", ext_set_union); + return res; +} + +static lbm_value ext_member(lbm_value *args, lbm_uint argn) { + lbm_value res = ENC_SYM_TERROR; + if (argn == 2 && lbm_is_list(args[0])) { + res = ENC_SYM_NIL; + lbm_value curr = args[0]; + + while (lbm_is_cons(curr)) { + if (struct_eq(lbm_car(curr), args[1])) { + res = args[0]; + break; + } + curr = lbm_cdr(curr); + } + } + return res; +} + +static lbm_value set_insert(lbm_value set, lbm_value val) { + + lbm_value end = ENC_SYM_NIL; + lbm_value start = ENC_SYM_NIL; + + lbm_value curr = set; + while (lbm_is_cons(curr)) { + lbm_value h = lbm_car(curr); + if (struct_eq(lbm_car(curr), val)) { + return set; + } + lbm_value cell = lbm_cons(h, ENC_SYM_NIL); + ABORT_ON_MERROR(cell); + if (end == ENC_SYM_NIL) { + end = cell; + start = cell; + } else { + lbm_set_cdr(end, cell); + end = cell; + } + curr = lbm_cdr(curr); + } + lbm_value v = lbm_cons(val, ENC_SYM_NIL); + ABORT_ON_MERROR(v); + if (end == ENC_SYM_NIL) { + end = v; + start = v; + } else { + lbm_set_cdr(end, v); + end = v; + } + return start; +} + +/* extends a copy of the input set with the new element. */ +static lbm_value ext_set_insert(lbm_value *args, lbm_uint argn) { + lbm_value res = ENC_SYM_TERROR; + if (argn == 2 && lbm_is_list(args[0])) { + res = set_insert(args[0], args[1]); + } + return res; +} + + +static lbm_value ext_set_union(lbm_value *args, lbm_uint argn) { + lbm_value res = ENC_SYM_TERROR; + if (argn == 2 && lbm_is_list(args[0]) && lbm_is_list(args[1])) { + lbm_value curr = args[0]; + lbm_value set = args[1]; + + while (lbm_is_cons(curr)) { + set = set_insert(set, lbm_car(curr)); + ABORT_ON_MERROR(set); + curr = lbm_cdr(curr); + } + return set; + } + return res; +} diff --git a/src/fundamental.c b/src/fundamental.c index ff808d09..5bd65655 100644 --- a/src/fundamental.c +++ b/src/fundamental.c @@ -1317,24 +1317,6 @@ static lbm_value fundamental_drop(lbm_value *args, lbm_uint nargs, eval_context_ return lbm_list_drop(lbm_dec_as_u32(args[1]), args[0]); } -static lbm_value fundamental_member(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { - (void) ctx; - lbm_value res = ENC_SYM_TERROR; - if (nargs == 2 && lbm_is_list(args[0])) { - res = ENC_SYM_NIL; - lbm_value curr = args[0]; - - while (lbm_is_cons(curr)) { - if (struct_eq(lbm_car(curr), args[1])) { - res = args[0]; - break; - } - curr = lbm_cdr(curr); - } - } - return res; -} - const fundamental_fun fundamental_table[] = {fundamental_add, fundamental_sub, @@ -1394,5 +1376,4 @@ const fundamental_fun fundamental_table[] = fundamental_reg_event_handler, fundamental_take, fundamental_drop, - fundamental_member, }; diff --git a/src/symrepr.c b/src/symrepr.c index 19ce42e7..03243afd 100644 --- a/src/symrepr.c +++ b/src/symrepr.c @@ -210,7 +210,6 @@ special_sym const special_symbols[] = { {"event-register-handler", SYM_REG_EVENT_HANDLER}, {"take" , SYM_TAKE}, {"drop" , SYM_DROP}, - {"member" , SYM_MEMBER}, // fast access in list {"ix" , SYM_IX}, diff --git a/tests/test_member_1.lisp b/tests/test_member_1.lisp deleted file mode 100644 index 94a997fc..00000000 --- a/tests/test_member_1.lisp +++ /dev/null @@ -1,6 +0,0 @@ - - -;; Check is pretty serious about t and nil -(check (eq (list 1 2 3) (and (member (list 1 2 3) 2) - (member (list 1 2 3) 3) - (member (list 1 2 3) 1)))) diff --git a/tests/test_member_2.lisp b/tests/test_member_2.lisp deleted file mode 100644 index e049dee2..00000000 --- a/tests/test_member_2.lisp +++ /dev/null @@ -1,2 +0,0 @@ - -(check (eq nil (member (list 1 2 3) 4))) diff --git a/tests/test_member_3.lisp b/tests/test_member_3.lisp deleted file mode 100644 index 8f5a04c4..00000000 --- a/tests/test_member_3.lisp +++ /dev/null @@ -1 +0,0 @@ -(check (eq nil (member '() 1)))