felix/slime
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

using stdint types

Browse Source
This commit is contained in:
FelixBrendel
2020-03-31 11:38:53 +02:00
parent 33145be4c6
commit 76dd4d6482
52 changed files with 483 additions and 1503 deletions
Download Patch File Download Diff File Expand all files Collapse all files
bin/alist.slime
+22 -22
View File
@@ -15,13 +15,13 @@
:alist))
(define (print alist)
(let ((associations (first alist)))
(let ((associations (car alist)))
(define (pprint-intern associations)
(when associations
(print " "
(caar associations) "->"
(cdar associations))
(pprint-intern (rest associations))))
(pprint-intern (cdr associations))))
(print "(")
(when associations
(print "\n")
@@ -30,22 +30,22 @@
(define (get alist key)
(let ((associations (first alist)))
(let ((associations (car alist)))
(define (alist-get-intern associations key)
(cond ((null? associations)
(error :key-not-found "key was not found in alist"))
((= (caar associations) key)
(cdar associations))
(else (alist-get-intern (rest associations) key))))
(else (alist-get-intern (cdr associations) key))))
(alist-get-intern associations key)))
(define (find alist key)
(let ((associations (first alist)))
(let ((associations (car alist)))
(define (alist-find-intern associations key current-index)
(cond ((null? associations) key-not-found-index)
((= (caar associations) key) current-index)
(else (alist-find-intern (rest associations)
(else (alist-find-intern (cdr associations)
key
(+ 1 current-index)))))
(alist-find-intern associations key 0)))
@@ -65,31 +65,31 @@
(if (= index 1)
;; we want to remove the next one, so we set our
;; cdr to the next next one
(mutate associations (pair (first associations)
(rest (rest associations))))
(mutate! associations (cons (car associations)
(cdr (cdr associations))))
;; else cdr-recurse
(alist-remove!-internal (rest asociations) (- index 1))))
(alist-remove!-internal (cdr asociations) (- index 1))))
(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 (cons (cdar alist) ())))
(else (alist-remove!-internal alist index))))
alist)
(define (set! alist key value)
(mutate alist (set-type! (pair (pair (pair key value)
(mutate! alist (set-type! (cons (cons (cons key value)
(car alist))
())
:alist)))
(define (set-overwrite! alist key value)
(let ((associations (first alist)))
(let ((associations (car alist)))
(define (alist-set-overwrite-intern associations key value)
(cond ((= (caar associations) key)
(mutate (car associations) (pair key value)))
(mutate! (car associations) (cons key value)))
((null? associations) (set! alist key value))
(else (alist-set-overwrite-intern
(rest associations) key value))))
(cdr associations) key value))))
(alist-set-overwrite-intern associations key value))
alist)
)
@@ -116,7 +116,7 @@
:plist))
(define (print plist)
(let ((props (first plist)))
(let ((props (car plist)))
(define (pprint-intern props)
(when props
(print " "
@@ -130,7 +130,7 @@
(print ")\n")))
(define (get plist prop)
(let ((props (first plist)))
(let ((props (car plist)))
(define (plist-get-intern props prop)
(cond ((null? props)
(error :key-not-found "property was not found in plist"))
@@ -140,14 +140,14 @@
(plist-get-intern props prop)))
(define (set! plist prop value)
(mutate plist (set-type! (pair (pair prop (pair value (first plist))) ())
(mutate! plist (set-type! (cons (cons prop (cons value (car plist))) ())
:plist)))
(define (set-overwrite! plist prop value)
(let ((props (first plist)))
(let ((props (car plist)))
(define (plist-set-overwrite-intern props prop value)
(cond ((= (car props) prop)
(mutate (cdr props) (pair value (cddr props))))
(mutate! (cdr props) (cons value (cddr props))))
((null? props) (plist-set! plist prop value))
(else (plist-set-overwrite-intern
(cddr props) prop value))))
@@ -155,7 +155,7 @@
plist)
(define (find plist prop)
(let ((props (first plist)))
(let ((props (car plist)))
(define (plist-find-intern props prop current-index)
(cond ((null? props) key-not-found-index)
((= (car props) prop) current-index)
@@ -176,13 +176,13 @@
(if (= index 1)
;; we want to remove the next one, so we set our
;; cdr to the next next one
(mutate (cdar props) (pair (cadar props) ;; xD nice meme dude!!!
(mutate! (cdar props) (cons (cadar props) ;; xD nice meme dude!!!
(cdr (cdr (cdr (cdar props))))))
;; else cdr-recurse
(plist-remove!-internal (cddr props) (- index 1))))
(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 (cons (cddar plist) ())))
(else (plist-remove!-internal plist index))))
plist)
bin/cxr.slime
-4
View File
@@ -1,7 +1,3 @@
(define cons pair)
(define car first)
(define cdr rest)
(define (caar seq)
(car (car seq)))
bin/emoji.slime
+1 -1
View File
@@ -3826,6 +3826,6 @@
(hm/set! emoji-map :flag:-Wales '🏴󠁧󠁢󠁷󠁬󠁳󠁿)
(define (get emoji-name)
(mytry
(attempt
(hm/get emoji-map emoji-name)
(error :not-found "emoji was not found"))))
bin/generate-docs.slime → bin/generate-docs-file.slime
+8 -8
View File
@@ -1,8 +1,8 @@
(import "alist.slime")
(import "automata.slime")
(import "interpolation.slime")
(import "oo.slime")
(import "math.slime")
(import "sets.slime")
(generate-docs "../manual/built-in-docs.org")
(import "alist.slime")
(import "automata.slime")
(import "interpolation.slime")
(import "oo.slime")
(import "math.slime")
(import "sets.slime")
(generate-docs-file "../manual/built-in-docs.org")
bin/interpolation.slime
+1 -1
View File
@@ -17,7 +17,7 @@
(dt (/ 1 #steps)))
(lambda ()
(let ((res (lerp a b t)))
(mutate t (+ t dt))
(mutate! t (+ t dt))
res))))
(define make-point pair)
bin/math.slime
+6 -6
View File
@@ -15,17 +15,17 @@
(** x 0.5))
(define-class (vector3 x y 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 (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))
(mutate! x (* fac x))
(mutate! y (* fac y))
(mutate! z (* fac z))
fac)
(define (add other)
bin/oo.slime
+6 -6
View File
@@ -1,7 +1,7 @@
(define-syntax (define-class name-and-members . body)
(define-macro (define-class name-and-members . body)
"Macro for creating simple classes."
(let ((name (first name-and-members))
(members (rest name-and-members)))
(let ((name (car name-and-members))
(members (cdr name-and-members)))
`(set-type!
(define
;; The function definition
@@ -14,12 +14,12 @@
(set-type!
(lambda args
"This is the docs for the handle"
(let ((op (eval (first args))))
(let ((op (eval (car args))))
(if (procedure? op)
(eval args)
(eval (first args)))))
(eval (car args)))))
,(symbol->keyword name))))
:constructor)))
(define-syntax (-> obj meth . args)
(define-macro (-> obj meth . args)
`(,obj ',meth ,@args))
bin/pre.slime
+118 -114
View File
@@ -5,13 +5,17 @@
;; (kk)
(define pair cons)
(define first car)
(define rest cdr)
(define hm/set! hash-map-set!)
(define hm/get hash-map-get)
(define (hm/get-or-nil hm key)
(mytry (hm/get hm key) ()))
(attempt (hm/get hm key) ()))
(define-syntax (pe expr)
(define-macro (pe expr)
`(begin
(print :end " " ',expr "evaluates to")
((lambda (e)
@@ -23,16 +27,16 @@
(define (stream-null? s) (when s t))
(define-syntax (delay expr)
(define-macro (delay expr)
`(,lambda () ,expr))
(define (force promise)
(promise))
(define-syntax (mac a) (list + 1 1))
(define-syntax (add . args) (pair '+ args))
(define-macro (mac a) (list + 1 1))
(define-macro (add . args) (cons '+ args))
(define-syntax (and . args)
(define-macro (and . args)
;; (and cond1 cond2 (cond3 args))
;; ->
;; (if cond1
@@ -44,12 +48,12 @@
;; ())
;; ())
(if args
`(,if ,(first args)
,(apply and (rest args))
`(,if ,(car args)
,(apply and (cdr args))
())
t))
(define-syntax (or . args)
(define-macro (or . args)
;; (or cond1 cond2 (cond3 args))
;; ->
;; (if cond1
@@ -60,12 +64,12 @@
;; t
;; ())))
(if args
`(,if ,(first args)
`(,if ,(car args)
t
,(apply or (rest args)))
,(apply or (cdr args)))
()))
(define-syntax (when condition . body)
(define-macro (when condition . body)
"Special form for when multiple actions should be done if a
condition is true.
@@ -80,68 +84,68 @@ condition is true.
(print \"World!\"))
{{{example_end}}}
"
(if (= (rest body) ())
(if (= (cdr body) ())
`(if ,condition ,@body nil)
`(if ,condition (begin ,@body) nil)))
(define-syntax (unless condition . body)
(define-macro (unless condition . body)
"Special form for when multiple actions should be done if a
condition is false."
(if (= (rest body) ())
(if (= (cdr body) ())
`(if ,condition nil ,@body)
`(if ,condition nil (begin ,@body))))
(define-syntax (n-times times action)
(define-macro (n-times times action)
"Executes action times times."
(define (repeat times elem)
(unless (> 1 times)
(pair elem (repeat (- times 1) elem))))
(cons elem (repeat (- times 1) elem))))
`(begin ,@(repeat times action)))
(define-syntax (let bindings . body)
(define-macro (let bindings . body)
(define (unzip lists)
(when lists
(define (iter lists l1 l2)
(define elem (first lists))
(define elem (car lists))
(if elem
(iter (rest lists)
(pair (first elem) l1)
(pair (first (rest elem)) l2))
(iter (cdr lists)
(cons (car elem) l1)
(cons (car (cdr elem)) l2))
(list l1 l2)))
(iter lists () ())))
(define unzipped (unzip bindings))
`((,lambda ,(first unzipped) ,@body) ,@(first (rest unzipped))))
`((,lambda ,(car unzipped) ,@body) ,@(car (cdr unzipped))))
(define-syntax (cond . clauses)
(define-macro (cond . clauses)
(define (rec clauses)
(if (= () clauses)
()
(if (= (first (first clauses)) 'else)
(if (= (car (car clauses)) 'else)
(begin
(if (not (= (rest clauses) ()))
(if (not (= (cdr clauses) ()))
(error :syntax-error "There are additional clauses after the else clause!")
(pair 'begin (rest (first clauses)))))
`(if ,(first (first clauses))
(begin ,@(rest (first clauses)))
,(rec (rest clauses))))))
(cons 'begin (cdr (car clauses)))))
`(if ,(car (car clauses))
(begin ,@(cdr (car clauses)))
,(rec (cdr clauses))))))
(rec clauses))
(define-syntax (case var . clauses)
(define-macro (case var . clauses)
(define (rec clauses)
(if (= nil clauses)
nil
(if (= (first (first clauses)) 'else)
(if (= (car (car clauses)) 'else)
(begin
(if (not (= (rest clauses) ()))
(if (not (= (cdr clauses) ()))
(error :syntax-error "There are additional clauses after the else clause!")
(pair 'begin (rest (first clauses)))))
`(if (member? ,var ',(first (first clauses)))
(begin ,@(rest (first clauses)))
,(rec (rest clauses))))))
(cons 'begin (cdr (car clauses)))))
`(if (member? ,var ',(car (car clauses)))
(begin ,@(cdr (car clauses)))
,(rec (cdr clauses))))))
(rec clauses))
(define-syntax (construct-list . body)
(define-macro (construct-list . body)
"
{{{example_start}}}
(construct-list
@@ -152,7 +156,7 @@ condition is false."
(construct-list
i <- '(1 2 3 4)
j <- '(A B)
yield (pair i j))
yield (cons i j))
(construct-list
i <- '(1 2 3 4 5 6 7 8)
@@ -161,44 +165,44 @@ condition is false."
"
(define (append-map f ll)
(unless (= ll ())
(define val (f (first ll)))
(if (= (first val) ())
(append-map f (rest ll))
(define val (f (car ll)))
(if (= (car val) ())
(append-map f (cdr ll))
(extend
val
(append-map f (rest ll))))))
(append-map f (cdr 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)))
((= () (cdr body)) (car body))
((= (car (cdr body)) '<-)
`(,append-map (lambda (,(car body)) (list ,(rec (cdr (cdr (cdr body)))))) ,(car (cdr (cdr body)))))
((= (car body) 'if)
`(when ,(car (cdr body)) ,(rec (cdr (cdr body)))))
((= (car (cdr body)) 'yield)
(car (cdr body)))
(else (error :syntax-error "Not a do-able expression"))))
(rec body))
(define-syntax (define-typed args . body)
(define-macro (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))))
(cons (car args)
(get-arg-names (cdr (cdr args))))))
(let ((name (car args))
(lambda-list (cdr args))
(arg-names (get-arg-names (cdr args))))
`(define (,name ,@arg-names)
(assert-types= ,@lambda-list)
,@body)))
(define-syntax (define-module module-name (:imports ()) (:exports ()) . body)
(define-macro (define-module module-name (:imports ()) (:exports ()) . body)
(let ((module-prefix (concat-strings (symbol->string module-name) "::")))
(eval `(,begin ,@(map (lambda (x) `(,import ,x)) imports) ,@body))
(pair 'begin
(cons 'begin
(map (lambda (orig-export-name)
((lambda (export-name)
`(define ,export-name
@@ -213,7 +217,7 @@ condition is false."
(exec `(begin ,@(map (lambda (x) `(,import ,x)) imports) ,@body)))
(eval exec)
(enable-debug-log)
(pair begin
(cons begin
(map (lambda (orig-export-name)
((lambda (export-name)
`(define ,export-name
@@ -224,24 +228,24 @@ condition is false."
exports))
(disable-debug-log)))
(define-syntax (generic-extend args . body)
(let ((fun-name (first args))
(params (rest args))
(define-macro (generic-extend args . body)
(let ((fun-name (car args))
(params (cdr args))
(types ())
(names ()))
(define (process-params params)
(when params
(let ((_name (first params))
(_type (first (rest params))))
(let ((_name (car params))
(_type (car (cdr params))))
(assert (symbol? _name))
(assert (keyword? _type))
(set! types (append types _type))
(set! names (append names _name))
(process-params (rest (rest params))))))
(process-params (cdr (cdr params))))))
(process-params params)
;; we have the fun-name, the param names and the types, lets go:
;;
;; first check if there is already a generic-<name>-map
;; car check if there is already a generic-<name>-map
(let ((generic-map-name (string->symbol
(concat-strings "generic-" (symbol->string fun-name) "-map"))))
(unless (bound? generic-map-name)
@@ -279,10 +283,10 @@ condition is false."
(define (types=? . objs)
(define (inner objs)
(if objs
(let ((actual-type (type (first objs)))
(desired-type (first (rest objs))))
(let ((actual-type (type (car objs)))
(desired-type (car (cdr objs))))
(if (= actual-type desired-type)
(inner (rest (rest objs)))
(inner (cdr (cdr objs)))
()))
t))
(inner objs))
@@ -290,10 +294,10 @@ condition is false."
(define (assert-types= . objs)
(define (inner objs)
(when objs
(let ((actual-type (type (first objs)))
(desired-type (first (rest objs))))
(let ((actual-type (type (car objs)))
(desired-type (car (cdr objs))))
(if (= actual-type desired-type)
(inner (rest (rest objs)))
(inner (cdr (cdr objs)))
(error :type-missmatch "type missmatch" actual-type desired-type)))))
(inner objs))
@@ -309,7 +313,7 @@ condition is false."
"Checks if the argument is a keyword."
(type=? x :keyword))
(define (pair? x)
(define (cons? x)
"Checks if the argument is a pair."
(type=? x :pair))
@@ -352,70 +356,70 @@ condition is false."
(print (end a))
{{{example_end}}}
"
(if (or (null? seq) (not (pair? (rest seq))))
(if (or (null? seq) (not (cons? (cdr seq))))
seq
(end (rest seq))))
(end (cdr seq))))
(define (last seq)
"Returns the (first) of the last (pair) of the given sequence.
"Returns the (car) of the last (cons) of the given sequence.
{{{example_start}}}
(define a (list 1 2 3 4))
(print (last a))
{{{example_end}}}
"
(first (end seq)))
(car (end seq)))
(define (extend seq elem)
"Extends a list with the given element, by putting it in
the (rest) of the last element of the sequence."
(if (pair? seq)
the (cdr ) of the last element of the sequence."
(if (cons? seq)
(begin
(define e (end seq))
(mutate e (pair (first e) elem))
(mutate! e (cons (car e) elem))
seq)
elem))
(define (extend2 seq elem)
"Extends a list with the given element, by putting it in
the (rest) of the last element of the sequence."
the (cdr ) of the last element of the sequence."
(print "addr of (end seq)" (addr-of (end seq)))
(if (pair? seq)
(if (cons? seq)
(let ((e (end seq)))
(print "addr if e inner" (addr-of e))
(mutate e (pair (first e) elem))
(mutate! e (cons (car e) elem))
seq))
elem)
(define (append seq elem)
"Appends an element to a sequence, by extendeing the list
with (pair elem nil)."
(extend seq (pair elem ())))
with (cons elem nil)."
(extend seq (cons elem ())))
(define (length seq)
"Returns the length of the given sequence."
(if (null? seq)
0
(+ 1 (length (rest seq)))))
(+ 1 (length (cdr seq)))))
(define (member? elem seq)
(when (pair? seq)
(if (= elem (first seq))
(when (cons? seq)
(if (= elem (car seq))
t
(member? elem (rest seq)))))
(member? elem (cdr seq)))))
(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)))))
(else (sublist-starting-at (cdr 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))))))
((= 0 index) (cdr seq))
(else (cons (car seq) (list-without-index (cdr seq) (- index 1))))))
(define (increment val)
"Adds one to the argument."
@@ -429,7 +433,7 @@ with (pair elem nil)."
"Returns a sequence of numbers starting with the number defined
by the key =from= and ends with the number defined in =to=."
(when (< from to)
(pair from (range :from (+ 1 from) :to to))))
(cons from (range :from (+ 1 from) :to to))))
(define (range-while (:from 0) :to)
"Returns a sequence of numbers starting with the number defined
@@ -439,19 +443,19 @@ by the key 'from' and ends with the number defined in 'to'."
(set! from (increment from))
(while (< from to)
(begin
(mutate head (pair (first head) (pair (copy from) nil)))
(define head (rest head))
(mutate! head (cons (car head) (cons (copy from) nil)))
(define head (cdr head))
(set! from (increment from))))
result)
(define (map fun seq)
"Takes a function and a sequence as arguments and returns a new
sequence which contains the results of using the first sequences
sequence which contains the results of using the car sequences
elemens as argument to that function."
(if (null? seq)
seq
(pair (fun (first seq))
(map fun (rest seq)))))
(cons (fun (car seq))
(map fun (cdr seq)))))
(define (reduce fun seq)
"Takes a function and a sequence as arguments and applies the
@@ -466,10 +470,10 @@ instead."
function to the argument sequence. reduce-binary applies the arguments
*pair-wise* which means it works with binary functions as compared to
[[=reduce=]]."
(if (null? (rest seq))
(first seq)
(fun (first seq)
(reduce-binary fun (rest seq)))))
(if (null? (cdr seq))
(car seq)
(fun (car seq)
(reduce-binary fun (cdr seq)))))
(define (filter fun seq)
"Takes a function and a sequence as arguments and applies the
@@ -477,25 +481,25 @@ function to every value in the sequence. If the result of that
funciton application returns a truthy value, the original value is
added to a list, which in the end is returned."
(when seq
(if (fun (first seq))
(pair (first seq)
(filter fun (rest seq)))
(filter fun (rest seq)))))
(if (fun (car seq))
(cons (car seq)
(filter fun (cdr seq)))
(filter fun (cdr seq)))))
(define (zip l1 l2)
(unless (and (null? l1) (null? l2))
(pair (list (first l1) (first l2))
(zip (rest l1) (rest l2)))))
(cons (list (car l1) (car l2))
(zip (cdr l1) (cdr l2)))))
(define (unzip lists)
(when lists
(define (iter lists l1 l2)
(define elem (first lists))
(define elem (car lists))
(if elem
(iter (rest lists)
(pair (first elem) l1)
(pair (first (rest elem)) l2))
(iter (cdr lists)
(cons (car elem) l1)
(cons (car (cdr elem)) l2))
(list l1 l2)))
(iter lists () ())))
@@ -503,8 +507,8 @@ added to a list, which in the end is returned."
(define (enumerate seq)
(define (enumerate-inner seq next-num)
(when seq
(pair (list (first seq) next-num)
(enumerate-inner (rest seq) (+ 1 next-num)))))
(cons (list (car seq) next-num)
(enumerate-inner (cdr seq) (+ 1 next-num)))))
(enumerate-inner seq 0))
bin/pre.slime.expanded
-106
View File
@@ -1,106 +0,0 @@
(define hm/set! hash-map-set!)
(define hm/get hash-map-get)
(define (hm/get-or-nil hm key) (mytry (hm/get hm key) ()))
(define-syntax (pe expr) `(print ',expr "evaluates to" ,expr))
(define the-empty-stream ())
(define (stream-null? s) (if s t ()))
(define-syntax (delay expr) `(,lambda () ,expr))
(define (force promise) (promise))
(define-syntax (when condition . body) :doc "Special form for when multiple actions should be done if a\ncondition is true.\n\n{{{example_start}}}\n(when (not ())\n (print "Hello ")\n (print "from ")\n (print "when!"))\n\n(when ()\n (print "Goodbye ")\n (print "World!"))\n{{{example_end}}}\n" (if (= (rest body) ()) `(if ,condition ,@body nil) `(if ,condition (begin ,@body) nil)))
(define-syntax (unless condition . body) :doc "Special form for when multiple actions should be done if a\ncondition is false." (if (= (rest body) ()) `(if ,condition nil ,@body) `(if ,condition nil (begin ,@body))))
(define-syntax (n-times times action) :doc "Executes action times times." (define (repeat times elem) (unless (> 1 times) (pair elem (repeat (- times 1) elem)))) `(begin ,@(repeat times action)))
(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) ,@body) ,@(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 :syntax-error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if ,(first (first clauses)) (begin ,@(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 ,@(rest (first clauses))) ,(rec (rest clauses)))))) (rec clauses))
(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 (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 ,@arg-names) (assert-types= ,@lambda-list) ,@body)))
(define-syntax (define-module module-name (:imports ()) :exports . body) (let ((module-prefix (concat-strings (symbol->string module-name) "::"))) (eval `(begin ,@(map (lambda (x) `(,import ,x)) imports) ,@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-syntax (generic-extend args . body) (let ((fun-name (first args)) (params (rest args)) (types ()) (names ())) (define (process-params params) (when params (let ((_name (first params)) (_type (first (rest params)))) (assert (symbol? _name)) (assert (keyword? _type)) (set! types (append types _type)) (set! names (append names _name)) (process-params (rest (rest params)))))) (process-params params) (let ((generic-map-name (string->symbol (concat-strings "generic-" (symbol->string fun-name) "-map")))) (unless (bound? generic-map-name) (define generic-map-name (hash-map))) (hm/set! generic-map-name types (eval `(,lambda ,names ,@body))) (if (bound? fun-name) (let ((exisiting-fun (eval fun-name))) (unless (type=? exisiting-fun :generic-procedure) (unless (procedure? exisiting-fun) (error :macro-expand-error "can only generic-extend procedures.")) (define orig-proc exisiting-fun) (define fun-name (eval `(,lambda args (let ((fun (hm/get (map type args)))) (if (procedure? fun) (fun . args) (,orig-proc . args))))))))))))
(define (null? x) :doc "Checks if the argument is =nil=." (= x ()))
(define (type=? obj typ) :doc "Checks if the argument =obj= is of type =typ=" (= (type obj) typ))
(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 "type missmatch" actual-type desired-type))))) (inner objs))
(define (number? x) :doc "Checks if the argument is a number." (type=? x :number))
(define (symbol? x) :doc "Checks if the argument is a symbol." (type=? x :symbol))
(define (keyword? x) :doc "Checks if the argument is a keyword." (type=? x :keyword))
(define (pair? x) :doc "Checks if the argument is a pair." (type=? x :pair))
(define (string? x) :doc "Checks if the argument is a string." (type=? x :string))
(define (lambda? x) :doc "Checks if the argument is a function." (type=? x :lambda))
(define (macro? x) :doc "Checks if the argument is a macro." (type=? x :macro))
(define (special-lambda? x) :doc "Checks if the argument is a special-lambda." (type=? x :dynamic-macro))
(define (built-in-function? x) :doc "Checks if the argument is a built-in function." (type=? x :cfunction))
(define (continuation? x) :doc "Checks if the argument is a continuation." (type=? x :continuation))
(define (procedure? x) (or (lambda? x) (special-lambda? x) (macro? x) (built-in-function? x) (continuation? x)))
(define (end seq) :doc "Returns the last pair in the sqeuence.\n\n{{{example_start}}}\n(define a (list 1 2 3 4))\n(print (end a))\n{{{example_end}}}\n" (if (or (null? seq) (not (pair? (rest seq)))) seq (end (rest seq))))
(define (last seq) :doc "Returns the (first) of the last (pair) of the given sequence.\n\n{{{example_start}}}\n(define a (list 1 2 3 4))\n(print (last a))\n{{{example_end}}}\n" (first (end seq)))
(define (extend seq elem) :doc "Extends a list with the given element, by putting it in\nthe (rest) of the last element of the sequence." (if (pair? seq) (begin (define e (end seq)) (mutate e (pair (first e) elem)) seq) elem))
(define (extend2 seq elem) :doc "Extends a list with the given element, by putting it in\nthe (rest) of the last element of the sequence." (print "addr of (end seq)" (addr-of (end seq))) (if (pair? seq) (let ((e (end seq))) (print "addr if e inner" (addr-of e)) (mutate e (pair (first e) elem)) seq)) elem)
(define (append seq elem) :doc "Appends an element to a sequence, by extendeing the list\nwith (pair elem nil)." (extend seq (pair elem ())))
(define (length seq) :doc "Returns the length of the given sequence." (if (null? seq) 0 (+ 1 (length (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 :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 :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 (decrement val) :doc "Subtracts one from the argument." (- val 1))
(define (range (:from 0) :to) :doc "Returns a sequence of numbers starting with the number defined\nby the key =from= and ends with the number defined in =to=." (when (< from to) (pair from (range :from (+ 1 from) :to to))))
(define (range-while (:from 0) :to) :doc "Returns a sequence of numbers starting with the number defined\nby the key 'from' and ends with the number defined in 'to'." (define result (list (copy from))) (define head result) (set! from (increment from)) (while (< from to) (begin (mutate head (pair (first head) (pair (copy from) nil))) (define head (rest head)) (set! from (increment from)))) result)
(define (map fun seq) :doc "Takes a function and a sequence as arguments and returns a new\nsequence which contains the results of using the first sequences\nelemens as argument to that function." (if (null? seq) seq (pair (fun (first seq)) (map fun (rest seq)))))
(define (reduce fun seq) :doc "Takes a function and a sequence as arguments and applies the\nfunction to the argument sequence. This only works correctly if the\ngiven function accepts a variable amount of parameters. If your\nfunciton is limited to two arguments, use [[=reduce-binary=]]\ninstead." (apply fun seq))
(define (reduce-binary fun seq) :doc "Takes a function and a sequence as arguments and applies the\nfunction to the argument sequence. reduce-binary applies the arguments\n*pair-wise* which means it works with binary functions as compared to\n[[=reduce=]]." (if (null? (rest seq)) (first seq) (fun (first seq) (reduce-binary fun (rest seq)))))
(define (filter fun seq) :doc "Takes a function and a sequence as arguments and applies the\nfunction to every value in the sequence. If the result of that\nfunciton application returns a truthy value, the original value is\nadded to a list, which in the end is returned." (when seq (if (fun (first seq)) (pair (first seq) (filter fun (rest seq))) (filter fun (rest seq)))))
(define (zip l1 l2) (unless (and (null? l1) (null? l2)) (pair (list (first l1) (first l2)) (zip (rest l1) (rest l2)))))
(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 (enumerate seq) (define (enumerate-inner seq next-num) (when seq (pair (list (first seq) next-num) (enumerate-inner (rest seq) (+ 1 next-num))))) (enumerate-inner seq 0))
bin/sets.slime
+1 -1
View File
@@ -25,7 +25,7 @@
(define (insert! set value)
(unless (contains? set value)
(set! set (pair (pair value (first set)) ()))
(set! set (cons (cons value (car set)) ()))
(set-type! set :set))
set)
)
bin/tests/alists.slime
+10 -10
View File
@@ -3,7 +3,7 @@
(define a (ds::alist::make))
;; a == (())
(assert (= (first a) ()))
(assert (= (car a) ()))
(ds::alist::set! a 'key1 'value1)
;; a == (key1: value1)
@@ -20,7 +20,7 @@
(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 (car a)) 2))
(ds::alist::set! a 'key1 'value3)
@@ -28,7 +28,7 @@
;; key2: value2,
;; key1: value1)
(assert (= (length (first a)) 3))
(assert (= (length (car a)) 3))
(assert (= (ds::alist::get a 'key1) 'value3))
(ds::alist::set-overwrite! a 'key1 'value4)
@@ -36,14 +36,14 @@
;; key2: value2,
;; key1: value1)
(assert (= (length (first a)) 3))
(assert (= (length (car a)) 3))
(assert (= (ds::alist::get a 'key1) 'value4))
(ds::alist::remove! a 'key1)
;; a == (key2: value2,
;; key1: value1)
(assert (= (length (first a)) 2))
(assert (= (length (car a)) 2))
(assert (= (ds::alist::get a 'key1) 'value1))
(assert (= (ds::alist::get a 'key2) 'value2))
@@ -57,7 +57,7 @@
(define p (ds::plist::make))
;; p == (())
(assert (= (first p) ()))
(assert (= (car p) ()))
(ds::plist::set! p :key1 'value1)
;; p == ((:key1 value1))
@@ -74,14 +74,14 @@
(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 (car p)) 4))
(ds::plist::set! p :key1 'value3)
;; p == ((:key1 value3,
;; :key2 value2,
;; :key1 value1))
(assert (= (length (first p)) 6))
(assert (= (length (car p)) 6))
(assert (= (ds::plist::get p :key1) 'value3))
(ds::plist::set-overwrite! p :key1 'value4)
@@ -89,13 +89,13 @@
;; :key2 value2,
;; :key1 value1))
;; (assert (= (length (first p)) 6))
;; (assert (= (length (car p)) 6))
;; (assert (= (ds::plist::get p :key1) 'value4))
;; (ds::plist::remove! p :key1)
;; ;; p == ((:key2 value2,
;; ;; :key1 value1))
;; (assert (= (length (first p)) 4))
;; (assert (= (length (car p)) 4))
;; (assert (= (ds::plist::get p :key1) 'value1))
;; (assert (= (ds::plist::get p :key2) 'value2))
bin/tests/automata.slime
+12 -12
View File
@@ -22,25 +22,25 @@
(set::make "q0")))
(let ((state (aut ())))
(assert (= (first state) :accept))
(assert (= (first (rest state)) "q0")))
(assert (= (car state) :accept))
(assert (= (car (cdr state)) "q0")))
(let ((state (aut "M")))
(assert (= (first state) :fail))
(assert (= (first (rest state)) "q1")))
(assert (= (car state) :fail))
(assert (= (car (cdr state)) "q1")))
(let ((state (aut "A")))
(assert (= (first state) :accept))
(assert (= (first (rest state)) "q0")))
(assert (= (car state) :accept))
(assert (= (car (cdr state)) "q0")))
(let ((state (aut "M")))
(assert (= (first state) :fail))
(assert (= (first (rest state)) "q1")))
(assert (= (car state) :fail))
(assert (= (car (cdr state)) "q1")))
(let ((state (aut "G")))
(assert (= (first state) :fail))
(assert (= (first (rest state)) "q2")))
(assert (= (car state) :fail))
(assert (= (car (cdr state)) "q2")))
(let ((state (aut "E")))
(assert (= (first state) :accept))
(assert (= (first (rest state)) "q0")))
(assert (= (car state) :accept))
(assert (= (car (cdr state)) "q0")))
bin/tests/class_macro.slime
+6 -6
View File
@@ -1,17 +1,17 @@
(import "oo.slime")
(define-class (vector3 x y 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 (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))
(mutate! x (* fac x))
(mutate! y (* fac y))
(mutate! z (* fac z))
fac)
(define (add other)
bin/tests/evaluation_of_default_args.slime
+1 -1
View File
@@ -10,6 +10,6 @@
((lambda ()
(define (a)
:ok)
(define (b (:k (begin (break) (a))))
(define (b (:k (begin (show-environment) (a))))
k)
(b))))
bin/tests/lexical_scope.slime
+2 -2
View File
@@ -26,7 +26,7 @@
(define x 0)
(lambda ()
(define temp x)
(mutate x (+ x 1))
(mutate! x (+ x 1))
temp))
;; key arguments
@@ -34,7 +34,7 @@
(define (make-key-counter)
((lambda (:var)
(lambda ()
(mutate var (+ 1 var))
(mutate! var (+ 1 var))
var))
:var 0))
bin/tests/macro_expand.slime
+2 -2
View File
@@ -1,8 +1,8 @@
(define-syntax (error)
(define-macro (error)
(assert t))
(define-syntax (test)
(define-macro (test)
`(begin
(+ 1 1)
(error)