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

Cleanup and delete dead code

Browse Source
This commit is contained in:
Felix Brendel
2019-11-10 15:29:21 +01:00
parent bb1cfcd3c3
commit 8dbff42bdf
14 changed files with 152 additions and 256 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) (quasiquote (print (quote (unquote expr)) "evaluates to" (unquote expr))))
(define-syntax (pe expr) `(print ',expr "evaluates to" ,expr))
(define the-empty-stream ())
(define (stream-null? s) (if s t ()))
(define-syntax (delay expr) (quasiquote ((unquote lambda) () (unquote expr))))
(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) ()) (quasiquote (if (unquote condition) (unquote-splicing body) nil)) (quasiquote (if (unquote 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) ()) `(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) ()) (quasiquote (if (unquote condition) nil (unquote-splicing body))) (quasiquote (if (unquote 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) ()) `(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)))) (quasiquote (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)))) `(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)) (quasiquote (((unquote lambda) (unquote (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) @body) @(first (rest unzipped))))
(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 (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)) (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 (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)) (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 (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)))) (quasiquote (define ((unquote 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 @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 (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 (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 (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-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 @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 ()))