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

Fixed Memory Leaks. :)

Browse Source
This commit is contained in:
Felix Brendel
2019-11-10 00:50:09 +01:00
parent a790a38655
commit bb1cfcd3c3
19 changed files with 199 additions and 173 deletions
Download Patch File Download Diff File Expand all files Collapse all files
bin/pre.slime.expanded
+12 -12
View File
@@ -4,35 +4,35 @@
(define (hm/get-or-nil hm key) (mytry (hm/get hm key) ()))
(define-syntax (pe expr) `(print ',expr "evaluates to" ,expr))
(define-syntax (pe expr) (quasiquote (print (quote (unquote expr)) "evaluates to" (unquote expr))))
(define the-empty-stream ())
(define (stream-null? s) (if s t ()))
(define-syntax (delay expr) `(,lambda () ,expr))
(define-syntax (delay expr) (quasiquote ((unquote lambda) () (unquote 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 (unquote-splicing body) nil) `(if ,condition (begin (unquote-splicing body)) nil)))
(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) ()) (quasiquote (if (unquote condition) (unquote-splicing body) nil)) (quasiquote (if (unquote condition) (begin (unquote-splicing 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 (unquote-splicing body)) `(if ,condition nil (begin (unquote-splicing body)))))
(define-syntax (unless condition . body) :doc "Special form for when multiple actions should be done if a\ncondition is false." (if (= (rest body) ()) (quasiquote (if (unquote condition) nil (unquote-splicing body))) (quasiquote (if (unquote condition) nil (begin (unquote-splicing 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 (unquote-splicing (repeat times action))))
(define-syntax (n-times times action) :doc "Executes action times times." (define (repeat times elem) (unless (> 1 times) (pair elem (repeat (- times 1) elem)))) (quasiquote (begin (unquote-splicing (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) (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)) (quasiquote (((unquote lambda) (unquote (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 :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 (cond . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) (quote else)) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair (quote begin) (rest (first clauses))))) (quasiquote (if (unquote (first (first clauses))) (begin (unquote-splicing (rest (first clauses)))) (unquote (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 (case var . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) (quote else)) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair (quote begin) (rest (first clauses))))) (quasiquote (if (member? (unquote var) (quote (unquote (first (first clauses))))) (begin (unquote-splicing (rest (first clauses)))) (unquote (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 (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)) (quote <-)) (quasiquote ((unquote append-map) (lambda ((unquote (first body))) (list (unquote (rec (rest (rest (rest body))))))) (unquote (first (rest (rest body))))))) ((= (first body) (quote if)) (quasiquote (when (unquote (first (rest body))) (unquote (rec (rest (rest body))))))) ((= (first (rest body)) (quote 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 (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)))) (quasiquote (define ((unquote 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 :module-error "The module does not contain a key it tries to export"))))) exports))))
(define-syntax (define-module module-name (:imports ()) :exports . body) (let ((module-prefix (concat-strings (symbol->string module-name) "::"))) (eval (quasiquote (begin (unquote-splicing (map (lambda (x) (quasiquote ((unquote import) (unquote x)))) imports)) (unquote-splicing body)))) (pair (quote begin) (map (lambda (orig-export-name) (let ((export-name (string->symbol (concat-strings module-prefix (symbol->string orig-export-name))))) (quasiquote (define (unquote export-name) (unquote (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 (create-hash-map))) (hm/set! generic-map-name types (eval `(,lambda ,names (unquote-splicing 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-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 (create-hash-map))) (hm/set! generic-map-name types (eval (quasiquote ((unquote lambda) (unquote names) (unquote-splicing 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 (quasiquote ((unquote lambda) args (let ((fun (hm/get (map type args)))) (if (procedure? fun) (fun . args) ((unquote orig-proc) . args)))))))))))))
(define (null? x) :doc "Checks if the argument is =nil=." (= x ()))