Преглед изворни кода

environments are now hashmaps

master
FelixBrendel пре 6 година
родитељ
комит
2882f81e13
9 измењених фајлова са 124 додато и 117 уклоњено
  1. +12
    -10
      bin/alist.slime
  2. +7
    -7
      bin/pre.slime
  3. +7
    -7
      bin/pre.slime.expanded
  4. +33
    -33
      bin/tests/alists.slime
  5. +0
    -2
      bin/tests/evaluation_of_default_args.slime
  6. +14
    -7
      src/built_ins.cpp
  7. +17
    -17
      src/env.cpp
  8. +1
    -1
      src/ftb
  9. +33
    -33
      src/testing.cpp

+ 12
- 10
bin/alist.slime Прегледај датотеку

@@ -3,11 +3,11 @@
(alist::make alist::print alist::get alist::find alist::key-exists? alist::remove! alist::set! alist::set-overwrite! (alist::make alist::print alist::get alist::find alist::key-exists? alist::remove! alist::set! alist::set-overwrite!
plist::make plist::print plist::get plist::find plist::prop-exists? plist::remove! plist::set! plist::set-overwrite!) plist::make plist::print plist::get plist::find plist::prop-exists? plist::remove! plist::set! plist::set-overwrite!)


(define key-not-found-index -1)


(define-module alist (define-module alist
:imports ("cxr.slime") :imports ("cxr.slime")
:exports (make print get find key-exists? remove! set! set-overwrite!) :exports (make print get find key-exists? remove! set! set-overwrite!)
(define key-not-found-index -1)


(define (make) (define (make)
(set-type! (set-type!
@@ -33,7 +33,7 @@
(let ((associations (first alist))) (let ((associations (first alist)))
(define (alist-get-intern associations key) (define (alist-get-intern associations key)
(cond ((null? associations) (cond ((null? associations)
(error "key was not found in alist"))
(error :key-not-found "key was not found in alist"))
((= (caar associations) key) ((= (caar associations) key)
(cdar associations)) (cdar associations))
(else (alist-get-intern (rest associations) key)))) (else (alist-get-intern (rest associations) key))))
@@ -52,12 +52,12 @@




(define (key-exists? alist key) (define (key-exists? alist key)
(not (= (alist-find alist key)
(not (= (find alist key)
key-not-found-index))) key-not-found-index)))




(define (remove! alist key) (define (remove! alist key)
(let ((index (alist-find alist key)))
(let ((index (find alist key)))
(define (alist-remove!-internal asociations index) (define (alist-remove!-internal asociations index)
;; reminder: we only get called if we are not replacing the ;; reminder: we only get called if we are not replacing the
;; first element in the alist ;; first element in the alist
@@ -70,7 +70,7 @@
;; else cdr-recurse ;; else cdr-recurse
(alist-remove!-internal (rest asociations) (- index 1)))) (alist-remove!-internal (rest asociations) (- index 1))))


(cond ((= index key-not-found-index) (error "key to remove was not found"))
(cond ((= index key-not-found-index) (error :key-not-found "key to remove was not found"))
((= index 0) (mutate alist (pair (cdar alist) ()))) ((= index 0) (mutate alist (pair (cdar alist) ())))
(else (alist-remove!-internal alist index)))) (else (alist-remove!-internal alist index))))
alist) alist)
@@ -87,7 +87,7 @@
(define (alist-set-overwrite-intern associations key value) (define (alist-set-overwrite-intern associations key value)
(cond ((= (caar associations) key) (cond ((= (caar associations) key)
(mutate (car associations) (pair key value))) (mutate (car associations) (pair key value)))
((null? associations) (alist-set! alist key value))
((null? associations) (set! alist key value))
(else (alist-set-overwrite-intern (else (alist-set-overwrite-intern
(rest associations) key value)))) (rest associations) key value))))
(alist-set-overwrite-intern associations key value)) (alist-set-overwrite-intern associations key value))
@@ -108,6 +108,8 @@
;; ;;
;; '((:key1 value1 :key2 value2)) ;; '((:key1 value1 :key2 value2))


(define key-not-found-index -1)

(define (make) (define (make)
(set-type! (set-type!
'(()) '(())
@@ -131,7 +133,7 @@
(let ((props (first plist))) (let ((props (first plist)))
(define (plist-get-intern props prop) (define (plist-get-intern props prop)
(cond ((null? props) (cond ((null? props)
(error "property was not found in plist"))
(error :key-not-found "property was not found in plist"))
((= (car props) prop) ((= (car props) prop)
(cadr props)) (cadr props))
(else (plist-get-intern (cddr props) prop)))) (else (plist-get-intern (cddr props) prop))))
@@ -162,11 +164,11 @@
(plist-find-intern props prop 0))) (plist-find-intern props prop 0)))


(define (prop-exists? plist prop) (define (prop-exists? plist prop)
(not (= (plist-find plist prop)
(not (= (find plist prop)
key-not-found-index))) key-not-found-index)))


(define (remove! plist prop) (define (remove! plist prop)
(let ((index (plist-find plist prop)))
(let ((index (find plist prop)))
(define (plist-remove!-internal props index) (define (plist-remove!-internal props index)
;; reminder: we only get called if we are not replacing the ;; reminder: we only get called if we are not replacing the
;; first element in the alist ;; first element in the alist
@@ -179,7 +181,7 @@
;; else cdr-recurse ;; else cdr-recurse
(plist-remove!-internal (cddr props) (- index 1)))) (plist-remove!-internal (cddr props) (- index 1))))


(cond ((= index key-not-found-index) (error "prop to remove was not found"))
(cond ((= index key-not-found-index) (error :key-not-found "prop to remove was not found"))
((= index 0) (mutate plist (pair (cddar plist) ()))) ((= index 0) (mutate plist (pair (cddar plist) ())))
(else (plist-remove!-internal plist index)))) (else (plist-remove!-internal plist index))))
plist) plist)


+ 7
- 7
bin/pre.slime Прегледај датотеку

@@ -57,7 +57,7 @@ condition is false."
(if (= (first (first clauses)) 'else) (if (= (first (first clauses)) 'else)
(begin (begin
(if (not (= (rest clauses) ())) (if (not (= (rest clauses) ()))
(error "There are additional clauses after the else clause!")
(error :syntax-error "There are additional clauses after the else clause!")
(pair 'begin (rest (first clauses))))) (pair 'begin (rest (first clauses)))))
`(if ,(first (first clauses)) `(if ,(first (first clauses))
(begin @(rest (first clauses))) (begin @(rest (first clauses)))
@@ -72,7 +72,7 @@ condition is false."
(if (= (first (first clauses)) 'else) (if (= (first (first clauses)) 'else)
(begin (begin
(if (not (= (rest clauses) ())) (if (not (= (rest clauses) ()))
(error "There are additional clauses after the else clause!")
(error :syntax-error "There are additional clauses after the else clause!")
(pair 'begin (rest (first clauses))))) (pair 'begin (rest (first clauses)))))
`(if (member? ,var ',(first (first clauses))) `(if (member? ,var ',(first (first clauses)))
(begin @(rest (first clauses))) (begin @(rest (first clauses)))
@@ -119,7 +119,7 @@ condition is false."
`(when ,(first (rest body)) ,(rec (rest (rest body))))) `(when ,(first (rest body)) ,(rec (rest (rest body)))))
((= (first (rest body)) 'yield) ((= (first (rest body)) 'yield)
(first (rest body))) (first (rest body)))
(else (error "Not a do-able expression"))))
(else (error :syntax-error "Not a do-able expression"))))


(rec body)) (rec body))


@@ -151,7 +151,7 @@ ithe sequence as arguemens."
(symbol->string orig-export-name))))) (symbol->string orig-export-name)))))
`(define ,export-name `(define ,export-name
,(mytry (eval orig-export-name) ,(mytry (eval orig-export-name)
(error "The module does not contain" orig-export-name)))))
(error :module-error "The module does not contain a key it tries to export")))))
exports)))) exports))))




@@ -181,7 +181,7 @@ ithe sequence as arguemens."
(desired-type (first (rest objs)))) (desired-type (first (rest objs))))
(if (= actual-type desired-type) (if (= actual-type desired-type)
(inner (rest (rest objs))) (inner (rest (rest objs)))
(error "type missmatch" actual-type desired-type)))))
(error :type-missmatch "type missmatch" actual-type desired-type)))))
(inner objs)) (inner objs))


(define (number? x) (define (number? x)
@@ -288,14 +288,14 @@ with (pair elem nil)."


(define (sublist-starting-at-index seq index) (define (sublist-starting-at-index seq index)
(cond ((< index 0) (cond ((< index 0)
(error "sublist-starting-at-index: index must be positive"))
(error :index-out-of-range "sublist-starting-at-index: index must be positive"))
((null? seq) ()) ((null? seq) ())
((= 0 index) seq) ((= 0 index) seq)
(else (sublist-starting-at (rest seq) (- index 1))))) (else (sublist-starting-at (rest seq) (- index 1)))))


(define (list-without-index seq index) (define (list-without-index seq index)
(cond ((or (< index 0) (null? seq)) (cond ((or (< index 0) (null? seq))
(error "list-remove-index!: index out of range"))
(error :index-out-of-range "list-remove-index!: index out of range"))
((= 0 index) (rest seq)) ((= 0 index) (rest seq))
(else (pair (first seq) (list-without-index (rest seq) (- index 1)))))) (else (pair (first seq) (list-without-index (rest seq) (- index 1))))))




+ 7
- 7
bin/pre.slime.expanded Прегледај датотеку

@@ -8,19 +8,19 @@


(define-syntax (let bindings . body) (define (unzip lists) (when lists (define (iter lists l1 l2) (define elem (first lists)) (if elem (iter (rest lists) (pair (first elem) l1) (pair (first (rest elem)) l2)) (list l1 l2)))) (iter lists () ())) (define unzipped (unzip bindings)) `((,lambda ,(first unzipped) (unquote-splicing body)) (unquote-splicing (first (rest unzipped))))) (define-syntax (let bindings . body) (define (unzip lists) (when lists (define (iter lists l1 l2) (define elem (first lists)) (if elem (iter (rest lists) (pair (first elem) l1) (pair (first (rest elem)) l2)) (list l1 l2)))) (iter lists () ())) (define unzipped (unzip bindings)) `((,lambda ,(first unzipped) (unquote-splicing body)) (unquote-splicing (first (rest unzipped)))))


(define-syntax (cond . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if ,(first (first clauses)) (begin (unquote-splicing (rest (first clauses)))) ,(rec (rest clauses)))))) (rec clauses))
(define-syntax (cond . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if ,(first (first clauses)) (begin (unquote-splicing (rest (first clauses)))) ,(rec (rest clauses)))))) (rec clauses))


(define-syntax (case var . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if (member? ,var ',(first (first clauses))) (begin (unquote-splicing (rest (first clauses)))) ,(rec (rest clauses)))))) (rec clauses))
(define-syntax (case var . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if (member? ,var ',(first (first clauses))) (begin (unquote-splicing (rest (first clauses)))) ,(rec (rest clauses)))))) (rec clauses))


(define-syntax (define-special name-and-args . body) `(define ,(first name-and-args) (special-lambda ,(rest name-and-args) (unquote-splicing body)))) (define-syntax (define-special name-and-args . body) `(define ,(first name-and-args) (special-lambda ,(rest name-and-args) (unquote-splicing body))))


(define-syntax (construct-list . body) :doc "\n{{{example_start}}}\n(construct-list\n i <- '(1 2 3 4 5)\n yield (* i i))\n{{{example_end}}}\n\n(construct-list\n i <- '(1 2 3 4)\n j <- '(A B)\n yield (pair i j))\n\n(construct-list\n i <- '(1 2 3 4 5 6 7 8)\n if (= 0 (% i 2))\n yield i)\n" (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 (rec body) (cond ((= () body) ()) ((= () (rest body)) (first body)) ((= (first (rest body)) '<-) `(,append-map (lambda (,(first body)) (list ,(rec (rest (rest (rest body)))))) ,(first (rest (rest body))))) ((= (first body) 'if) `(when ,(first (rest body)) ,(rec (rest (rest body))))) ((= (first (rest body)) 'yield) (first (rest body))) (else (error "Not a do-able expression")))) (rec body))
(define-syntax (construct-list . body) :doc "\n{{{example_start}}}\n(construct-list\n i <- '(1 2 3 4 5)\n yield (* i i))\n{{{example_end}}}\n\n(construct-list\n i <- '(1 2 3 4)\n j <- '(A B)\n yield (pair i j))\n\n(construct-list\n i <- '(1 2 3 4 5 6 7 8)\n if (= 0 (% i 2))\n yield i)\n" (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 (rec body) (cond ((= () body) ()) ((= () (rest body)) (first body)) ((= (first (rest body)) '<-) `(,append-map (lambda (,(first body)) (list ,(rec (rest (rest (rest body)))))) ,(first (rest (rest body))))) ((= (first body) 'if) `(when ,(first (rest body)) ,(rec (rest (rest body))))) ((= (first (rest body)) 'yield) (first (rest body))) (else (error :syntax-error "Not a do-able expression")))) (rec body))


(define-syntax (apply fun seq) :doc "Applies the function to the sequence, as in calls the function with\nithe sequence as arguemens." `(eval (pair ,fun ,seq))) (define-syntax (apply fun seq) :doc "Applies the function to the sequence, as in calls the function with\nithe sequence as arguemens." `(eval (pair ,fun ,seq)))


(define-syntax (define-typed args . body) (define (get-arg-names args) (when args (pair (first args) (get-arg-names (rest (rest args)))))) (let ((name (first args)) (lambda-list (rest args)) (arg-names (get-arg-names (rest args)))) `(define (,name (unquote-splicing arg-names)) (assert-types= (unquote-splicing lambda-list)) (unquote-splicing body)))) (define-syntax (define-typed args . body) (define (get-arg-names args) (when args (pair (first args) (get-arg-names (rest (rest args)))))) (let ((name (first args)) (lambda-list (rest args)) (arg-names (get-arg-names (rest args)))) `(define (,name (unquote-splicing arg-names)) (assert-types= (unquote-splicing lambda-list)) (unquote-splicing body))))


(define-syntax (define-module module-name (:imports ()) :exports . body) (let ((module-prefix (concat-strings (symbol->string module-name) "::"))) (eval `(begin (unquote-splicing (map (lambda (x) `(,import ,x)) imports)) (unquote-splicing body))) (pair 'begin (map (lambda (orig-export-name) (let ((export-name (string->symbol (concat-strings module-prefix (symbol->string orig-export-name))))) `(define ,export-name ,(mytry (eval orig-export-name) (error "The module does not contain" orig-export-name))))) exports))))
(define-syntax (define-module module-name (:imports ()) :exports . body) (let ((module-prefix (concat-strings (symbol->string module-name) "::"))) (eval `(begin (unquote-splicing (map (lambda (x) `(,import ,x)) imports)) (unquote-splicing body))) (pair 'begin (map (lambda (orig-export-name) (let ((export-name (string->symbol (concat-strings module-prefix (symbol->string orig-export-name))))) `(define ,export-name ,(mytry (eval orig-export-name) (error :module-error "The module does not contain a key it tries to export"))))) exports))))


(define (null? x) :doc "Checks if the argument is =nil=." (= x ())) (define (null? x) :doc "Checks if the argument is =nil=." (= x ()))


@@ -28,7 +28,7 @@


(define (types=? . objs) (define (inner objs) (if objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) ())) t)) (inner objs)) (define (types=? . objs) (define (inner objs) (if objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) ())) t)) (inner objs))


(define (assert-types= . objs) (define (inner objs) (when objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) (error "type missmatch" actual-type desired-type))))) (inner objs))
(define (assert-types= . objs) (define (inner objs) (when objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) (error :type-missmatch "type missmatch" actual-type desired-type))))) (inner objs))


(define (number? x) :doc "Checks if the argument is a number." (type=? x :number)) (define (number? x) :doc "Checks if the argument is a number." (type=? x :number))


@@ -64,9 +64,9 @@


(define (member? elem seq) (when (pair? seq) (if (= elem (first seq)) t (member? elem (rest seq))))) (define (member? elem seq) (when (pair? seq) (if (= elem (first seq)) t (member? elem (rest seq)))))


(define (sublist-starting-at-index seq index) (cond ((< index 0) (error "sublist-starting-at-index: index must be positive")) ((null? seq) ()) ((= 0 index) seq) (else (sublist-starting-at (rest seq) (- index 1)))))
(define (sublist-starting-at-index seq index) (cond ((< index 0) (error :index-out-of-range "sublist-starting-at-index: index must be positive")) ((null? seq) ()) ((= 0 index) seq) (else (sublist-starting-at (rest seq) (- index 1)))))


(define (list-without-index seq index) (cond ((or (< index 0) (null? seq)) (error "list-remove-index!: index out of range")) ((= 0 index) (rest seq)) (else (pair (first seq) (list-without-index (rest seq) (- index 1))))))
(define (list-without-index seq index) (cond ((or (< index 0) (null? seq)) (error :index-out-of-range "list-remove-index!: index out of range")) ((= 0 index) (rest seq)) (else (pair (first seq) (list-without-index (rest seq) (- index 1))))))


(define (increment val) :doc "Adds one to the argument." (+ val 1)) (define (increment val) :doc "Adds one to the argument." (+ val 1))




+ 33
- 33
bin/tests/alists.slime Прегледај датотеку

@@ -1,51 +1,51 @@
(import "alist.slime") (import "alist.slime")


(define a (make-alist))
(define a (ds::alist::make))
;; a == (()) ;; a == (())


(assert (= (first a) ())) (assert (= (first a) ()))


(alist-set! a 'key1 'value1)
(ds::alist::set! a 'key1 'value1)
;; a == (key1: value1) ;; a == (key1: value1)


(assert (= (alist-get a 'key1) 'value1))
(assert (alist-key-exists? a 'key1))
(assert (not (alist-key-exists? a 'key2)))
(assert (= (ds::alist::get a 'key1) 'value1))
(assert (ds::alist::key-exists? a 'key1))
(assert (not (ds::alist::key-exists? a 'key2)))


(alist-set! a 'key2 'value2)
(ds::alist::set! a 'key2 'value2)
;; a == (key2: value2, ;; a == (key2: value2,
;; key1: value1) ;; key1: value1)


(assert (= (alist-get a 'key2) 'value2))
(assert (alist-key-exists? a 'key2))
(assert (= (alist-find a 'key2) 0))
(assert (= (alist-find a 'key1) 1))
(assert (= (ds::alist::get a 'key2) 'value2))
(assert (ds::alist::key-exists? a 'key2))
(assert (= (ds::alist::find a 'key2) 0))
(assert (= (ds::alist::find a 'key1) 1))
(assert (= (length (first a)) 2)) (assert (= (length (first a)) 2))




(alist-set! a 'key1 'value3)
(ds::alist::set! a 'key1 'value3)
;; a == (key1: value3, ;; a == (key1: value3,
;; key2: value2, ;; key2: value2,
;; key1: value1) ;; key1: value1)


(assert (= (length (first a)) 3)) (assert (= (length (first a)) 3))
(assert (= (alist-get a 'key1) 'value3))
(assert (= (ds::alist::get a 'key1) 'value3))


(alist-set-overwrite! a 'key1 'value4)
(ds::alist::set-overwrite! a 'key1 'value4)
;; a == (key1: value4, ;; a == (key1: value4,
;; key2: value2, ;; key2: value2,
;; key1: value1) ;; key1: value1)


(assert (= (length (first a)) 3)) (assert (= (length (first a)) 3))
(assert (= (alist-get a 'key1) 'value4))
(assert (= (ds::alist::get a 'key1) 'value4))


(alist-remove! a 'key1)
(ds::alist::remove! a 'key1)
;; a == (key2: value2, ;; a == (key2: value2,
;; key1: value1) ;; key1: value1)


(assert (= (length (first a)) 2)) (assert (= (length (first a)) 2))
(assert (= (alist-get a 'key1) 'value1))
(assert (= (alist-get a 'key2) 'value2))
(assert (= (ds::alist::get a 'key1) 'value1))
(assert (= (ds::alist::get a 'key2) 'value2))




;; ------------- ;; -------------
@@ -54,48 +54,48 @@
;; ;;
;; ------------- ;; -------------


(define p (make-plist))
(define p (ds::plist::make))
;; p == (()) ;; p == (())


(assert (= (first p) ())) (assert (= (first p) ()))


(plist-set! p :key1 'value1)
(ds::plist::set! p :key1 'value1)
;; p == ((:key1 value1)) ;; p == ((:key1 value1))


(assert (= (plist-get p :key1) 'value1))
(assert (plist-prop-exists? p :key1))
(assert (not (plist-prop-exists? p :key2)))
(assert (= (ds::plist::get p :key1) 'value1))
(assert (ds::plist::prop-exists? p :key1))
(assert (not (ds::plist::prop-exists? p :key2)))


(plist-set! p :key2 'value2) (plist-set! p :key2 'value2)
;; p == ((:key2 value2, ;; p == ((:key2 value2,
;; :key1 value1)) ;; :key1 value1))


(assert (= (plist-get p :key2) 'value2))
(assert (plist-prop-exists? p :key2))
(assert (= (plist-find p :key2) 0))
(assert (= (plist-find p :key1) 1))
(assert (= (ds::plist::get p :key2) 'value2))
(assert (ds::plist::prop-exists? p :key2))
(assert (= (ds::plist::find p :key2) 0))
(assert (= (ds::plist::find p :key1) 1))
(assert (= (length (first p)) 4)) (assert (= (length (first p)) 4))


(plist-set! p :key1 'value3)
(ds::plist::set! p :key1 'value3)
;; p == ((:key1 value3, ;; p == ((:key1 value3,
;; :key2 value2, ;; :key2 value2,
;; :key1 value1)) ;; :key1 value1))


(assert (= (length (first p)) 6)) (assert (= (length (first p)) 6))
(assert (= (plist-get p :key1) 'value3))
(assert (= (ds::plist::get p :key1) 'value3))


(plist-set-overwrite! p :key1 'value4)
(ds::plist::set-overwrite! p :key1 'value4)
;; p == ((:key1 value4, ;; p == ((:key1 value4,
;; :key2 value2, ;; :key2 value2,
;; :key1 value1)) ;; :key1 value1))


(assert (= (length (first p)) 6)) (assert (= (length (first p)) 6))
(assert (= (plist-get p :key1) 'value4))
(assert (= (ds::plist::get p :key1) 'value4))


(plist-remove! p :key1)
(ds::plist::remove! p :key1)
;; p == ((:key2 value2, ;; p == ((:key2 value2,
;; :key1 value1)) ;; :key1 value1))


(assert (= (length (first p)) 4)) (assert (= (length (first p)) 4))
(assert (= (plist-get p :key1) 'value1))
(assert (= (plist-get p :key2) 'value2))
(assert (= (ds::plist::get p :key1) 'value1))
(assert (= (ds::plist::get p :key2) 'value2))

+ 0
- 2
bin/tests/evaluation_of_default_args.slime Прегледај датотеку

@@ -13,5 +13,3 @@
(define (b (:k (begin (break) (a)))) (define (b (:k (begin (break) (a))))
k) k)
(b)))) (b))))

(print "k was" (test))

+ 14
- 7
src/built_ins.cpp Прегледај датотеку

@@ -1055,13 +1055,20 @@ proc load_built_ins_into_environment() -> void {
// shouldn't the string itself also get copied?? // shouldn't the string itself also get copied??
return Memory::copy_lisp_object(obj); return Memory::copy_lisp_object(obj);
}; };
// // defun("error", "TODO", __LINE__, cLambda {
// // // TODO(Felix): make the error function useful
// // try evaluated_arguments = eval_arguments(arguments, &arguments_length);
// // try assert_arguments_length(0, arguments_length);
// // create_generic_error("Userlanderror");
// // return nullptr;
// // });
define((error type message), "TODO") {
fetch(type, message);
// TODO(Felix): make the error function useful
try assert_type(type, Lisp_Object_Type::Keyword);
try assert_type(message, Lisp_Object_Type::String);

using Globals::error;
error = new(Error);
error->type = type;
error->message = message->value.string;

create_generic_error("Userlanderror");
return nullptr;
};
define((symbol->keyword sym), "TODO") { define((symbol->keyword sym), "TODO") {
fetch(sym); fetch(sym);
try assert_type(sym, Lisp_Object_Type::Symbol); try assert_type(sym, Lisp_Object_Type::Symbol);


+ 17
- 17
src/env.cpp Прегледај датотеку

@@ -90,25 +90,25 @@ proc print_indent(int indent) -> void {
} }


proc print_environment_indent(Environment* env, int indent) -> void { proc print_environment_indent(Environment* env, int indent) -> void {
if(env == get_root_environment()) {
// if(env == get_root_environment()) {
// print_indent(indent);
// printf("[built-ins]-Environment (%lld)\n", (long long)env);
// return;
// }

for_str_hash_map (env->hm) {
print_indent(indent); print_indent(indent);
printf("[built-ins]-Environment (%lld)\n", (long long)env);
return;
printf("-> %s :: ", key);
print((Lisp_Object*)value);
printf(" (%lld)", (unsigned long long)value);
puts("");
}
for (int i = 0; i < env->parents.next_index; ++i) {
print_indent(indent);
printf("parent (%lld)", (long long)env->parents.data[i]);
puts(":");
print_environment_indent(env->parents.data[i], indent+4);
} }
printf("TODO\n");
// for (int i = 0; i < env->next_index; ++i) {
// print_indent(indent);
// printf("-> %s :: ", env->keys[i]);
// print(env->values[i]);
// printf(" (%lld)", (long long)env->values[i]);
// puts("");
// }
// for (int i = 0; i < env->parents.next_index; ++i) {
// print_indent(indent);
// printf("parent (%lld)", (long long)env->parents.data[i]);
// puts(":");
// print_environment_indent(env->parents.data[i], indent+4);
// }
} }


proc print_environment(Environment* env) -> void { proc print_environment(Environment* env) -> void {


+ 1
- 1
src/ftb

@@ -1 +1 @@
Subproject commit b9de82c0d84384a7ab78e2cb7dd368612efa50f9
Subproject commit 854593273fdf8039d8ac1ac7150527fca47818ef

+ 33
- 33
src/testing.cpp Прегледај датотеку

@@ -605,43 +605,43 @@ proc run_all_tests() -> bool {
pop_environment(); pop_environment();
}; };


// printf("-- Util --\n");
// invoke_test(test_array_lists_adding_and_removing);
// invoke_test(test_array_lists_sorting);
// invoke_test(test_array_lists_searching);
// printf("\n -- Parsing --\n");
// invoke_test(test_parse_atom);
// invoke_test(test_parse_expression);
// printf("\n-- Basic evaluating --\n");
// invoke_test(test_eval_operands);
// printf("\n-- Built ins --\n");
// invoke_test(test_built_in_add);
// invoke_test(test_built_in_substract);
// invoke_test(test_built_in_multiply);
// invoke_test(test_built_in_divide);
// invoke_test(test_built_in_if);
// invoke_test(test_built_in_and);
// invoke_test(test_built_in_or);
// invoke_test(test_built_in_not);
// invoke_test(test_built_in_type);
// printf("\n-- Memory management --\n");
// invoke_test(test_singular_t_and_nil);
printf("-- Util --\n");
invoke_test(test_array_lists_adding_and_removing);
invoke_test(test_array_lists_sorting);
invoke_test(test_array_lists_searching);
printf("\n -- Parsing --\n");
invoke_test(test_parse_atom);
invoke_test(test_parse_expression);
printf("\n-- Basic evaluating --\n");
invoke_test(test_eval_operands);
printf("\n-- Built ins --\n");
invoke_test(test_built_in_add);
invoke_test(test_built_in_substract);
invoke_test(test_built_in_multiply);
invoke_test(test_built_in_divide);
invoke_test(test_built_in_if);
invoke_test(test_built_in_and);
invoke_test(test_built_in_or);
invoke_test(test_built_in_not);
invoke_test(test_built_in_type);
printf("\n-- Memory management --\n");
invoke_test(test_singular_t_and_nil);


printf("\n-- Test Files --\n"); printf("\n-- Test Files --\n");


invoke_test_script("evaluation_of_default_args"); invoke_test_script("evaluation_of_default_args");
// invoke_test_script("alists");
// invoke_test_script("case_and_cond");
// invoke_test_script("lexical_scope");
// invoke_test_script("class_macro");
// invoke_test_script("import_and_load");
// invoke_test_script("sicp");
// invoke_test_script("macro_expand");
// invoke_test_script("automata");
invoke_test_script("alists");
invoke_test_script("case_and_cond");
invoke_test_script("lexical_scope");
invoke_test_script("class_macro");
invoke_test_script("import_and_load");
invoke_test_script("sicp");
invoke_test_script("macro_expand");
invoke_test_script("automata");




return result; return result;


Loading…
Откажи
Сачувај