diff --git a/bin/a.slime b/bin/a.slime new file mode 100644 index 0000000..db41acb --- /dev/null +++ b/bin/a.slime @@ -0,0 +1 @@ +(define-syntax (e x) x) diff --git a/bin/b.slime b/bin/b.slime new file mode 100644 index 0000000..558ed4e --- /dev/null +++ b/bin/b.slime @@ -0,0 +1,3 @@ +(import "a.slime") + +(printf (e 2)) diff --git a/bin/math.slime b/bin/math.slime new file mode 100644 index 0000000..d639fcf --- /dev/null +++ b/bin/math.slime @@ -0,0 +1,57 @@ +(import "oo.slime") + +(define-package math + + (define pi 3.14159265) + + (define (abs x) + (if (> x 0) x (- x))) + + (define (sqrt x) + (** x 0.5)) + + (define-class vector3 (x y z) + (define (get-x) x) + (define (get-y) y) + (define (get-z) z) + + (define (set-x new-x) (mutate x new-x)) + (define (set-y new-y) (mutate y new-y)) + (define (set-z new-z) (mutate z new-z)) + + (define (length) + (** (+ (* x x) (* y y) (* z z)) 0.5)) + + (define (scale fac) + (mutate x (* fac x)) + (mutate y (* fac y)) + (mutate z (* fac z)) + fac) + + (define (add other) + (make-vector3 + (+ x (other get-x)) + (+ y (other get-y)) + (+ z (other get-z)))) + + (define (subtract other) + (make-vector3 + (- x (other get-x)) + (- y (other get-y)) + (- z (other get-z)))) + + (define (scalar-product other) + (+ (* x (other get-x)) + (* y (other get-y)) + (* z (other get-z)))) + + (define (cross-product other) + (make-vector3 + (- (* y (other get-z)) (* z (other get-y))) + (- (* z (other get-x)) (* x (other get-z))) + (- (* x (other get-y)) (* y (other get-x))))) + + (define (print) + (printf :sep "" "[vector3] (" x y z ")")) + ) +) diff --git a/bin/oo.slime b/bin/oo.slime new file mode 100644 index 0000000..61f521c --- /dev/null +++ b/bin/oo.slime @@ -0,0 +1,29 @@ +(define-syntax (define-class name members :rest body) + "Macro for creating classes." + (define (underscore sym) + (string->symbol (concat-strings "_" (symbol->string sym)))) + + (define underscored-members (map underscore members)) + + ;; the wrapping let environment + (define let-body `(let ,(zip members underscored-members))) + + ;; the body + (extend let-body body) + ;; (map (lambda (fun) (append let-body fun)) body) + + ;; the dispatch function + (append let-body `(set-type + (special-lambda + (message :rest args) + "This is the docs for the handle" + (eval (extend (list message) args))) ,(symbol->keyword name))) + + ;; stuff it all in the constructor function + `(define + ;; The function definition + ,(pair (string->symbol (concat-strings "make-" (symbol->string name))) underscored-members) + ;; The docstring + ,(concat-strings "This is the handle to an object of the class " (symbol->string name)) + ;; the body + ,let-body)) diff --git a/bin/pre.slime b/bin/pre.slime index 24387a9..488dd7d 100644 --- a/bin/pre.slime +++ b/bin/pre.slime @@ -53,7 +53,23 @@ (define-syntax (define-special name-and-args :rest body) `(define ,(first name-and-args) (special-lambda ,(rest name-and-args) @body))) -(define-syntax (do-list :rest body) +(define-syntax (construct-list :rest body) + " +(construct-list + i <- '(1 2 3 4 5) + yield (* i i)) + +(construct-list + i <- '(1 2 3 4) + j <- '(A B) + yield (pair i j)) + +(construct-list + i <- '(1 2 3 4 5 6 7 8) + when (evenp i) + yield i) + +" (define (append-map f ll) (unless (= ll ()) (define val (f (first ll))) @@ -73,32 +89,29 @@ `(if ,(first (rest body)) ,(rec (rest (rest body))))) ((= (first body) 'yield) (first (rest body))) - (t (error "Not a do-able expression: ~S" `(quote ,body)))) - ) + (else (error "Not a do-able expression")))) + (rec body)) +(define-syntax (apply fun seq) + "Applies the funciton to the sequence, as in calls the function with +ithe sequence as arguemens." + `(eval (pair ,fun ,seq))) + + +(define-syntax (define-package name :rest body) + `(define ,(string->symbol (concat-strings (symbol->string name) "->")) + ((lambda () + @body + (set-type + (special-lambda (:rest args) + (let ((op (first args)) + (args (rest args))) + (cond ((= op 'pi) 3.14159265) + (else (try (apply op args) + (error "The package does not contain this operation")))))) + :package))))) -;; (define (append-map f ll) - ;; (unless (= ll ()) - ;; (define val (f (first ll))) - ;; (if (= (first val) ()) - ;; (append-map f (rest ll)) - ;; (extend - ;; val - ;; (append-map f (rest ll)))))) - - ;; (define-special (do-list :rest body) - ;; (cond - ;; ((= () body) ()) - ;; ((= () (rest body)) (first body)) - ;; ((= (first (rest body)) '<-) - ;; `(,append-map (lambda (,(first body)) (list ,(eval `(do-list @(rest (rest (rest body))))))) ,(first (rest (rest body))))) - ;; ((= (first body) 'when) - ;; `(if ,(first (rest body)) ,(eval `(do-list @(rest (rest body)))))) - ;; ((= (first body) 'yield) - ;; (first (rest body))) - ;; (t (error "Not a do-able expression: ~S" `(quote ,body)))) - ;; ) (define (nil? x) "Checks if the argument is nil." @@ -136,11 +149,6 @@ "Checks if the argument is a built-in function." (= (type x) :built-in-function)) -(define (apply fun seq) - "Applies the funciton to the sequence, as in calls the function with -ithe sequence as arguemens." - (eval (pair fun seq))) - (define (end seq) "Returns the last pair in the sqeuence." (if (or (nil? seq) (not (pair? (rest seq)))) diff --git a/bin/pre.slime.expanded b/bin/pre.slime.expanded index 7bd8fa9..012201f 100644 --- a/bin/pre.slime.expanded +++ b/bin/pre.slime.expanded @@ -16,9 +16,6 @@ (define (built-n-function? x) "Checks if the argument is a built-in function." (= (type x) :built-in-function)) -(define (apply fun seq) "Applies the funciton to the sequence, as in calls the function with -ithe sequence as arguemens." (eval (pair fun seq))) - (define (end seq) "Returns the last pair in the sqeuence." (if (or (nil? seq) (not (pair? (rest seq)))) seq (end (rest seq)))) (define (last seq) "Returns the (first) of the last (pair) of the given sequence." (first (end seq))) @@ -52,7 +49,7 @@ elemens as argument to that function." (if (nil? seq) seq (pair (fun (first seq) function to the argument sequence. This only works correctly if the given function accepts a variable amount of parameters. If your funciton is limited to two arguments, use `reduce-binary' -instead." (apply fun seq)) +instead." (eval (pair fun seq))) (define (reduce-binary fun seq) "Takes a function and a sequence as arguments and applies the function to the argument sequence. reduce-binary applies the diff --git a/bin/tests/class_macro.slime b/bin/tests/class_macro.slime index 38988d3..1d51fe8 100644 --- a/bin/tests/class_macro.slime +++ b/bin/tests/class_macro.slime @@ -1,35 +1,6 @@ -(define (type-wrap obj type) - (set-type obj type) - obj) +(import "oo.slime") -(define-syntax (defclass name members :rest body) - "Macro for creating classes." - (define (underscore sym) - (string->symbol (concat-strings "_" (symbol->string sym)))) - - (define underscored-members (map underscore members)) - - ;; the wrapping let environment - (define let-body `(let ,(zip members underscored-members))) - - ;; the body - (map (lambda (fun) (append let-body fun)) body) - - ;; the dispatch function - (append let-body `(type-wrap - (special-lambda - (message :rest args) - "This is the docs for the handle" - (eval (extend (list message) args))) ,(symbol->keyword name))) - - ;; stuff it all in the constructor function - `(define - ,(pair (string->symbol (concat-strings "make-" (symbol->string name))) underscored-members) - ,(concat-strings "This is the handle to an object of the class " (symbol->string name)) - ,let-body)) - - -(defclass vector3 (x y z) +(define-class vector3 (x y z) (define (get-x) x) (define (get-y) y) (define (get-z) z) diff --git a/bin/tests/class_macro.slime.expanded b/bin/tests/class_macro.slime.expanded index 465ab21..17987ee 100644 --- a/bin/tests/class_macro.slime.expanded +++ b/bin/tests/class_macro.slime.expanded @@ -1,6 +1,6 @@ -(define (type-wrap obj type) (set-type obj type) obj) +(import "oo.slime") -(define (make-vector3 _x _y _z) "This is the handle to an object of the class vector3" (let ((x _x) (y _y) (z _z)) (define (get-x) x) (define (get-y) y) (define (get-z) z) (define (set-x new-x) (mutate x new-x)) (define (set-y new-y) (mutate y new-y)) (define (set-z new-z) (mutate z new-z)) (define (length) (** (+ (* x x) (* y y) (* z z)) 0.500000)) (define (scale fac) (mutate x (* fac x)) (mutate y (* fac y)) (mutate z (* fac z)) fac) (define (add other) (make-vector3 (+ x (other get-x)) (+ y (other get-y)) (+ z (other get-z)))) (define (subtract other) (make-vector3 (- x (other get-x)) (- y (other get-y)) (- z (other get-z)))) (define (scalar-product other) (+ (* x (other get-x)) (* y (other get-y)) (* z (other get-z)))) (define (cross-product other) (make-vector3 (- (* y (other get-z)) (* z (other get-y))) (- (* z (other get-x)) (* x (other get-z))) (- (* x (other get-y)) (* y (other get-x))))) (define (print) (printf :sep "" "[vector3] (" x y z ")")) (type-wrap (special-lambda (message :rest args) "This is the docs for the handle" (eval (extend (list message) args))) :vector3))) +(define-class vector3 (x y z) (define (get-x) x) (define (get-y) y) (define (get-z) z) (define (set-x new-x) (mutate x new-x)) (define (set-y new-y) (mutate y new-y)) (define (set-z new-z) (mutate z new-z)) (define (length) (** (+ (* x x) (* y y) (* z z)) 0.500000)) (define (scale fac) (mutate x (* fac x)) (mutate y (* fac y)) (mutate z (* fac z)) fac) (define (add other) (make-vector3 (+ x (other get-x)) (+ y (other get-y)) (+ z (other get-z)))) (define (subtract other) (make-vector3 (- x (other get-x)) (- y (other get-y)) (- z (other get-z)))) (define (scalar-product other) (+ (* x (other get-x)) (* y (other get-y)) (* z (other get-z)))) (define (cross-product other) (make-vector3 (- (* y (other get-z)) (* z (other get-y))) (- (* z (other get-x)) (* x (other get-z))) (- (* x (other get-y)) (* y (other get-x))))) (define (print) (printf :sep "" "[vector3] (" x y z ")"))) (define v1 (make-vector3 1 2 3)) diff --git a/bin/tests/lexical_scope.slime b/bin/tests/lexical_scope.slime index 4f29b84..cccedcc 100644 --- a/bin/tests/lexical_scope.slime +++ b/bin/tests/lexical_scope.slime @@ -1,3 +1,5 @@ +;; regular arguments + (define (make-counter) (let ((var 0)) (lambda () @@ -5,12 +7,47 @@ var))) (define counter1 (make-counter)) + (assert (= (counter1) 1)) (define counter2 (make-counter)) + (assert (= (counter2) 1)) (assert (= (counter2) 2)) (assert (= (counter1) 2)) (assert (= (counter1) 3)) (assert (= (counter2) 3)) +(assert (= (counter2) 4)) +(assert (= (counter2) 5)) +(assert (= (counter1) 4)) +(assert (= (counter1) 5)) + +;; key arguments + +(define (make-key-counter) + ((lambda (:keys var) + (lambda () + (mutate var (+ 1 var)) + var)) + :var 0)) + + +(define key-counter1 (make-key-counter)) + +(assert (= (key-counter1) 1)) + +(define key-counter2 (make-key-counter)) + +(assert (= (key-counter2) 1)) + +(assert (= (key-counter2) 2)) +(assert (= (key-counter1) 2)) +(assert (= (key-counter1) 3)) +(assert (= (key-counter2) 3)) +(assert (= (key-counter2) 4)) +(assert (= (key-counter2) 5)) +(assert (= (key-counter1) 4)) +(assert (= (key-counter1) 5)) + +;; rest arguments will no be copied so we don't need to test them here diff --git a/bin/tests/lexical_scope.slime.expanded b/bin/tests/lexical_scope.slime.expanded index 1d37c4e..d2064a6 100644 --- a/bin/tests/lexical_scope.slime.expanded +++ b/bin/tests/lexical_scope.slime.expanded @@ -16,3 +16,37 @@ (assert (= (counter2) 3)) +(assert (= (counter2) 4)) + +(assert (= (counter2) 5)) + +(assert (= (counter1) 4)) + +(assert (= (counter1) 5)) + +(define (make-key-counter) ((lambda (:keys var) (lambda () (mutate var (+ 1 var)) var)) :var 0)) + +(define key-counter1 (make-key-counter)) + +(assert (= (key-counter1) 1)) + +(define key-counter2 (make-key-counter)) + +(assert (= (key-counter2) 1)) + +(assert (= (key-counter2) 2)) + +(assert (= (key-counter1) 2)) + +(assert (= (key-counter1) 3)) + +(assert (= (key-counter2) 3)) + +(assert (= (key-counter2) 4)) + +(assert (= (key-counter2) 5)) + +(assert (= (key-counter1) 4)) + +(assert (= (key-counter1) 5)) + diff --git a/bin/tests/macro_expand.slime b/bin/tests/macro_expand.slime new file mode 100644 index 0000000..d704402 --- /dev/null +++ b/bin/tests/macro_expand.slime @@ -0,0 +1,13 @@ +(define-syntax (error) + (assert t)) + + +(define-syntax (test) + `(begin + (+ 1 1) + (error) + (+ 1 1))) + +(test) + +(assert t) diff --git a/bin/visualization.svg b/bin/visualization.svg deleted file mode 100644 index 66b1de7..0000000 --- a/bin/visualization.svg +++ /dev/null @@ -1,3069 +0,0 @@ - - - - - Date: - - - 12.05.2019 - - - | - - - Time: - - - 16:44:55 - - - | - - - String Memory: - - - [allocated chars] - - - 65536 - - - [free] - - - 4924 - - - [used] - - - 60612 - - - [%free] - - - 00007.513428 - - - [%used] - - - 00092.486572 - - - | - - - Object Memory: - - - [#allocated] - - - 8192000 - - - [#free] - - - 8190327 - - - [#used] - - - 1673 - - - [%free] - - - 00099.979576 - - - [%used] - - - 00000.020422 - - - | - - - Memory Contents: - - - Symbols: - - - 778 - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - sym - - - + - - - fun - - - + - - - define - - - fun - - - lambda - - - x - - - + - - - * - - - x - - - x - - - eval - - - + - - - eval - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - + - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - - - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - * - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - / - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - if - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - if - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - and - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - and - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - or - - - nil - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - or - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - not - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - not - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - = - - - > - - - >= - - - < - - - <= - - - + - - - - - - - * - - - / - - - ** - - - % - - - assert - - - define - - - mutate - - - if - - - quote - - - quasiquote - - - and - - - or - - - not - - - while - - - let - - - lambda - - - special-lambda - - - eval - - - prog - - - list - - - pair - - - first - - - rest - - - set-type - - - delete-type - - - type - - - info - - - show - - - print - - - read - - - exit - - - break - - - memstat - - - try - - - load - - - import - - - copy - - - error - - - symbol->keyword - - - string->symbol - - - symbol->string - - - concat-strings - - - prog - - - define - - - a - - - type - - - a - - - prog - - - set-type - - - a - - - type - - - a - - - prog - - - set-type - - - a - - - type - - - a - - - Keywords: - - - 6 - - - : - - - key1 - - - : - - - key:2 - - - : - - - haha - - - : - - - number - - - : - - - my-type - - - : - - - type-missmatch - - - Numbers: - - - 29 - - - 00123.000000 - - - -0000.012300 - - - 00012.000000 - - - 00005.000000 - - - 00001.000000 - - - 00001.000000 - - - 00002.000000 - - - 00003.000000 - - - 00010.000000 - - - 00004.000000 - - - 00014.000000 - - - 00010.000000 - - - 00004.000000 - - - 00006.000000 - - - 00010.000000 - - - 00004.000000 - - - 00040.000000 - - - 00020.000000 - - - 00004.000000 - - - 00005.000000 - - - 00001.000000 - - - 00004.000000 - - - 00005.000000 - - - 00004.000000 - - - 00005.000000 - - - 00001.000000 - - - 00004.000000 - - - 00004.000000 - - - 00010.000000 - - - Strings: - - - 7 - - - "asd" - - - "okay" - - - "asd" - - - "asd" - - - "asd" - - - "asd xD" - - - "wrong tpye" - - - Lists, Pairs: - - - 34 - - - 116 - - - fun - - - + - - - 00012.000000 - - - - - - + - - - 00012.000000 - - - - - define - - - fun - - - lambda - - - x - - - - + - - - 00005.000000 - - - * - - - x - - - x - - - - - - - - - - - - - - - eval - - - 00001.000000 - - - - - + - - - 00001.000000 - - - 00002.000000 - - - - - - "okay" - - - eval - - - : - - - haha - - - - - - - - - 00001.000000 - - - 00003.000000 - - - "okay" - - - : - - - haha - - - - - - - 00001.000000 - - - - 00001.000000 - - - 00002.000000 - - - - - : - - - haha - - - - + - - - 00010.000000 - - - 00004.000000 - - - - - - 00010.000000 - - - 00004.000000 - - - - - - - - - 00010.000000 - - - 00004.000000 - - - - - - 00010.000000 - - - 00004.000000 - - - - - * - - - 00010.000000 - - - 00004.000000 - - - - - - 00010.000000 - - - 00004.000000 - - - - - / - - - 00020.000000 - - - 00004.000000 - - - - - - 00020.000000 - - - 00004.000000 - - - - - if - - - 00001.000000 - - - 00004.000000 - - - 00005.000000 - - - - - - - if - - - () - - - 00004.000000 - - - 00005.000000 - - - - - - - and - - - 00001.000000 - - - "asd" - - - 00004.000000 - - - - - - - and - - - () - - - "asd" - - - 00004.000000 - - - - - - - or - - - "asd" - - - nil - - - - - - or - - - () - - - () - - - - - - not - - - () - - - - - not - - - "asd xD" - - - - - prog - - - define - - - a - - - 00010.000000 - - - - - - type - - - a - - - - - - - - 00010.000000 - - - : - - - number - - - - - 00010.000000 - - - - prog - - - set-type - - - a - - - : - - - my-type - - - - - - type - - - a - - - - - - - - : - - - my-type - - - : - - - my-type - - - - - 00010.000000 - - - : - - - my-type - - - - - 00010.000000 - - - - prog - - - set-type - - - a - - - "wrong tpye" - - - - - - type - - - a - - - - - - - - () - - - - 00010.000000 - - - "wrong tpye" - - - - - - \ No newline at end of file diff --git a/src/built_ins.cpp b/src/built_ins.cpp index cd1e950..dcde3c6 100644 --- a/src/built_ins.cpp +++ b/src/built_ins.cpp @@ -30,7 +30,8 @@ proc lisp_object_equal(Lisp_Object* n1, Lisp_Object* n2) -> bool { } proc built_in_load(String* file_name, Environment* env) -> Lisp_Object* { - char* file_content = read_entire_file(Memory::get_c_str(file_name)); + char* full_file_name = find_slime_file(file_name); + char* file_content = read_entire_file(full_file_name ); if (file_content) { Lisp_Object* result = Memory::nil; Lisp_Object_Array_List* program; @@ -50,6 +51,7 @@ proc built_in_import(String* file_name, Environment* env) -> Lisp_Object* { // create new empty environment Environment* new_env; try new_env = Memory::create_child_environment(Globals::root_environment); + append_to_array_list(env->parents, new_env); Environment* old_macro_env = Parser::environment_for_macros; Parser::environment_for_macros = new_env; @@ -58,8 +60,6 @@ proc built_in_import(String* file_name, Environment* env) -> Lisp_Object* { Parser::environment_for_macros = old_macro_env; - append_to_array_list(env->parents, new_env); - return res; } @@ -391,10 +391,9 @@ proc load_built_ins_into_environment(Environment* env) -> void { defun("mutate", cLambda { try evaluated_arguments = eval_arguments(arguments, env, &arguments_length); try assert_arguments_length(2, arguments_length); - Lisp_Object* target = evaluated_arguments->value.pair.first; Lisp_Object* source = evaluated_arguments->value.pair.rest->value.pair.first; - +# if (target == Memory::nil || target == Memory::t || Memory::get_type(target) == Lisp_Object_Type::Keyword || @@ -724,8 +723,8 @@ proc load_built_ins_into_environment(Environment* env) -> void { try assert_type(type, Lisp_Object_Type::Keyword); - evaluated_arguments->value.pair.first->userType = type; - return type; + object->userType = type; + return object; }); defun("delete-type", cLambda { try evaluated_arguments = eval_arguments(arguments, env, &arguments_length); @@ -850,6 +849,7 @@ proc load_built_ins_into_environment(Environment* env) -> void { puts("body:\n"); print(evaluated_arguments->value.pair.first->value.function.body); puts("\n"); + printf("parent_env: %lld\n", (long long)evaluated_arguments->value.pair.first->value.function.parent_environment); return Memory::nil; }); @@ -947,21 +947,7 @@ proc load_built_ins_into_environment(Environment* env) -> void { try evaluated_arguments = eval_arguments(arguments, env, &arguments_length); try assert_arguments_length(1, arguments_length); - - if (evaluated_arguments->value.pair.first == Memory::nil || - evaluated_arguments->value.pair.first == Memory::t || - Memory::get_type(evaluated_arguments->value.pair.first) == Lisp_Object_Type::Symbol || - Memory::get_type(evaluated_arguments->value.pair.first) == Lisp_Object_Type::Keyword) - { - // we don't copy singleton objects - return evaluated_arguments->value.pair.first; - } - - Lisp_Object* target = Memory::create_lisp_object(); - Lisp_Object* source = evaluated_arguments->value.pair.first; - - *target = *source; - return target; + return Memory::copy_lisp_object(evaluated_arguments->value.pair.first); }); defun("error", cLambda { // TODO(Felix): make the error function useful diff --git a/src/env.cpp b/src/env.cpp index 68bcbbc..b9f64ef 100644 --- a/src/env.cpp +++ b/src/env.cpp @@ -71,6 +71,7 @@ proc print_environment_indent(Environment* env, int indent) -> void { print_indent(indent); print(env->values[i]); printf(" %s", env->keys[i]); + printf(" (%lld)", (long long)env->values[i]); puts(""); } for (int i = 0; i < env->parents->next_index; ++i) { @@ -82,6 +83,6 @@ proc print_environment_indent(Environment* env, int indent) -> void { } proc print_environment(Environment* env) -> void { - printf("\n=== Environment ===\n"); + printf("\n=== Environment === (%lld)\n", (long long)env); print_environment_indent(env, 0); } diff --git a/src/eval.cpp b/src/eval.cpp index a7cbb83..e6685d1 100644 --- a/src/eval.cpp +++ b/src/eval.cpp @@ -14,8 +14,13 @@ proc apply_arguments_to_function(Lisp_Object* arguments, Function* function) -> // their identifiers but before we converted them to // strings from symbols... Wo maybe just use the symbols? + // NOTE(Felix): We have to copy all the arguments, otherwise + // we change the program code. try sym = Memory::get_or_create_lisp_object_symbol(function->positional_arguments->identifiers[i]); - define_symbol(sym, arguments->value.pair.first, new_env); + define_symbol( + sym, + Memory::copy_lisp_object_except_pairs(arguments->value.pair.first), + new_env); arguments = arguments->value.pair.rest; } @@ -82,7 +87,10 @@ proc apply_arguments_to_function(Lisp_Object* arguments, Function* function) -> // if not set it and then add it to the array list try sym = Memory::get_or_create_lisp_object_symbol(arguments->value.pair.first->value.symbol.identifier); // NOTE(Felix): It seems we do not need to evaluate the argument here... - try define_symbol(sym, arguments->value.pair.rest->value.pair.first, new_env); + try define_symbol( + sym, + Memory::copy_lisp_object_except_pairs(arguments->value.pair.rest->value.pair.first), + new_env); append_to_array_list(read_in_keywords, arguments->value.pair.first->value.symbol.identifier); @@ -122,7 +130,7 @@ proc apply_arguments_to_function(Lisp_Object* arguments, Function* function) -> // to use it or if the user supplied his own if (!was_set) { try sym = Memory::get_or_create_lisp_object_symbol(defined_keyword); - try val = Memory::copy_lisp_object(function->keyword_arguments->values->data[i]); + try val = Memory::copy_lisp_object_except_pairs(function->keyword_arguments->values->data[i]); define_symbol(sym, val, new_env); } } @@ -137,7 +145,12 @@ proc apply_arguments_to_function(Lisp_Object* arguments, Function* function) -> } else { if (function->rest_argument) { try sym = Memory::get_or_create_lisp_object_symbol(function->rest_argument); - define_symbol(sym, arguments, new_env); + define_symbol( + sym, + // NOTE(Felix): arguments will be a list, and I THINK + // we do not need to copy it... + arguments, + new_env); } else { // rest was not declared but additional arguments were found create_generic_error( @@ -152,20 +165,9 @@ proc apply_arguments_to_function(Lisp_Object* arguments, Function* function) -> return result; } -/* - (begin - (define type--before type) - (define type - (lambda (e) - (if (and (= (type--before e) :pair) (= (first e) :my-type)) - :my-type - (type--before e)))) - ) -*/ - /** This parses the argument specification of funcitons into their - Function struct. It dois this by allocating new + Function struct. It does this by allocating new positional_arguments, keyword_arguments and rest_argument and filling it in */ @@ -382,7 +384,6 @@ proc eval_expr(Lisp_Object* node, Environment* env) -> Lisp_Object* { case Lisp_Object_Type::Symbol: { Lisp_Object* symbol; try symbol = lookup_symbol(node, env); - return symbol; } case Lisp_Object_Type::Pair: { @@ -409,7 +410,8 @@ proc eval_expr(Lisp_Object* node, Environment* env) -> Lisp_Object* { // check for lisp function if (Memory::get_type(lispOperator) == Lisp_Object_Type::Function) { // only for lambdas we evaluate the arguments before - // apllying + // apllying, for the other types, special-lambda and macro + // we do not need. if (lispOperator->value.function.type == Function_Type::Lambda) { try arguments = eval_arguments(arguments, env, &arguments_length); } @@ -440,25 +442,7 @@ proc interprete_file (char* file_name) -> Lisp_Object* { try user_env = Memory::create_child_environment(root_env); Parser::environment_for_macros = user_env; - // save the current working directory - char cwd[1024]; - getcwd(cwd, 1024); - - // get the direction of the exe - char* exe_path = exe_dir(); - - // switch to the exe directory for loading pre.slime - chdir(exe_path); - free(exe_path); - - built_in_import(Memory::create_string("pre.slime"), user_env); - - - // switch back to the users directory - chdir(cwd); - - Lisp_Object* result; - result = built_in_load(Memory::create_string(file_name), user_env); + Lisp_Object* result = built_in_load(Memory::create_string(file_name), user_env); if (Globals::error) { log_error(); @@ -480,23 +464,6 @@ proc interprete_stdin(bool is_emacs_repl = false) -> void { return; } - // save the current working directory - char cwd[1024]; - getcwd(cwd, 1024); - - // get the direction of the exe - char* exe_path = exe_dir(); - - // switch to the exe directory for loading pre.slime - chdir(exe_path); - free(exe_path); - - built_in_import(Memory::create_string("pre.slime"), user_env); - - - // switch back to the users directory - chdir(cwd); - Parser::environment_for_macros = user_env; printf("Welcome to the lispy interpreter.\n"); diff --git a/src/forward_decls.cpp b/src/forward_decls.cpp index 114290c..b5dd99d 100644 --- a/src/forward_decls.cpp +++ b/src/forward_decls.cpp @@ -12,6 +12,8 @@ proc load_built_ins_into_environment(Environment*) -> void; proc parse_argument_list(Lisp_Object*, Function*) -> void; proc print_environment(Environment*) -> void; +proc exe_dir() -> char*; + proc Lisp_Object_Type_to_string(Lisp_Object_Type type) -> const char*; proc visualize_lisp_machine() -> void; @@ -24,6 +26,8 @@ namespace Memory { namespace Parser { + extern Environment* environment_for_macros; + extern String* standard_in; extern String* parser_file; extern int parser_line; diff --git a/src/io.cpp b/src/io.cpp index a376be5..18e78d2 100644 --- a/src/io.cpp +++ b/src/io.cpp @@ -90,6 +90,10 @@ proc unescape_string(char* in) -> bool { return true; } +proc find_slime_file(String* filename) -> char* { + return Memory::get_c_str(filename); +} + proc read_entire_file(char* filename) -> char* { char *fileContent = nullptr; FILE *fp = fopen(filename, "r"); @@ -351,7 +355,7 @@ proc log_error() -> void { puts(console_normal); } -char* exe_dir() { +proc exe_dir() -> char* { size_t size = 512, i, n; char *path, *temp; diff --git a/src/memory.cpp b/src/memory.cpp index e3a80d4..ca0ba12 100644 --- a/src/memory.cpp +++ b/src/memory.cpp @@ -182,7 +182,7 @@ namespace Memory { set_type(t, Lisp_Object_Type::T); try_void Globals::root_environment = create_built_ins_environment(); - try_void Parser::standard_in = create_string("stdin"); + try_void Parser::standard_in = create_string("stdin"); } proc reset() -> void { @@ -283,7 +283,14 @@ namespace Memory { } proc copy_lisp_object(Lisp_Object* n) -> Lisp_Object* { - if (n == nil || n == t) + // TODO(Felix): If argument is a list (pair), do a FULL copy, + + // we don't copy singleton objects + if ( + n == Memory::nil || n == Memory::t || + Memory::get_type(n) == Lisp_Object_Type::Symbol || + Memory::get_type(n) == Lisp_Object_Type::Keyword + ) return n; Lisp_Object* target; @@ -292,6 +299,12 @@ namespace Memory { return target; } + proc copy_lisp_object_except_pairs(Lisp_Object* n) -> Lisp_Object* { + if (get_type(n) == Lisp_Object_Type::Pair) + return n; + return copy_lisp_object(n); + } + proc create_child_environment(Environment* parent) -> Environment* { int index; @@ -337,8 +350,24 @@ namespace Memory { proc create_built_ins_environment() -> Environment* { Environment* ret; - try ret = create_child_environment(nullptr); + try ret = create_empty_environment(); load_built_ins_into_environment(ret); + + Parser::environment_for_macros = ret; + + // save the current working directory + char cwd[1024]; + getcwd(cwd, 1024); + + // get the direction of the exe + char* exe_path = exe_dir(); + chdir(exe_path); + free(exe_path); + + built_in_load(Memory::create_string("pre.slime"), ret); + + chdir(cwd); + return ret; } diff --git a/src/parse.cpp b/src/parse.cpp index da552cc..4d5f15f 100644 --- a/src/parse.cpp +++ b/src/parse.cpp @@ -455,6 +455,9 @@ namespace Parser { Memory::get_type(macro) == Lisp_Object_Type::Function && macro->value.function.type == Function_Type::Macro) { + // printf("Found macro: ") ; + // print(parsed_symbol); + // printf("\n"); try expression = eval_expr(expression, environment_for_macros); } else break; } diff --git a/src/testing.cpp b/src/testing.cpp index a2e4085..3ee55d3 100644 --- a/src/testing.cpp +++ b/src/testing.cpp @@ -572,21 +572,15 @@ proc test_singular_t_and_nil() -> testresult { } proc test_file(const char* file) -> testresult { - Environment* root_env; - Environment* user_env; - Memory::reset(); assert_no_error(); - root_env = Memory::create_built_ins_environment(); - assert_no_error(); - user_env = Memory::create_child_environment(root_env); + Environment* root_env = Globals::root_environment; + Environment* user_env = Memory::create_child_environment(root_env); assert_no_error(); Parser::environment_for_macros = user_env; - built_in_import(Memory::create_string("pre.slime"), user_env); - assert_no_error(); Lisp_Object* result = built_in_load(Memory::create_string(file), user_env); assert_no_error(); @@ -595,8 +589,7 @@ proc test_file(const char* file) -> testresult { } proc run_all_tests() -> bool { - Memory::init(4096 * 2000, 1024, 4096 * 16); - Parser::environment_for_macros = Globals::root_environment; + Memory::init(4096 * 2000, 1024 * 32, 4096 * 16); // get the direction of the exe char* exe_path = exe_dir(); @@ -638,8 +631,9 @@ proc run_all_tests() -> bool { invoke_test_script("evaluation_of_default_args"); invoke_test_script("lexical_scope"); invoke_test_script("class_macro"); - invoke_test_script("sicp"); invoke_test_script("import_and_load"); + invoke_test_script("sicp"); + invoke_test_script("macro_expand"); return result; }