508 lines
16 KiB
Plaintext
508 lines
16 KiB
Plaintext
(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)
|
|
`((begin
|
|
(print :end " " ',expr "evaluates to")
|
|
((lambda (e)
|
|
(print e)
|
|
e) ,expr))
|
|
))
|
|
|
|
(define the-empty-stream ())
|
|
|
|
(define (stream-null? s) (when s t))
|
|
|
|
(define-syntax (delay expr)
|
|
`(,lambda () ,expr))
|
|
|
|
(define (force promise)
|
|
(promise))
|
|
|
|
(define-syntax (mac a) (list + 1 1))
|
|
(define-syntax (add . args) (pair '+ args))
|
|
|
|
(define-syntax (when condition . body)
|
|
"Special form for when multiple actions should be done if a
|
|
condition is true.
|
|
|
|
{{{example_start}}}
|
|
(when (not ())
|
|
(print \"Hello \")
|
|
(print \"from \")
|
|
(print \"when!\"))
|
|
|
|
(when ()
|
|
(print \"Goodbye \")
|
|
(print \"World!\"))
|
|
{{{example_end}}}
|
|
"
|
|
(if (= (rest body) ())
|
|
`(if ,condition ,@body nil)
|
|
`(if ,condition (begin ,@body) nil)))
|
|
|
|
|
|
(define-syntax (unless condition . body)
|
|
"Special form for when multiple actions should be done if a
|
|
condition is false."
|
|
(if (= (rest body) ())
|
|
`(if ,condition nil ,@body)
|
|
`(if ,condition nil (begin ,@body))))
|
|
|
|
(define-syntax (n-times times action)
|
|
"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 (= () clauses)
|
|
()
|
|
(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)
|
|
"
|
|
{{{example_start}}}
|
|
(construct-list
|
|
i <- '(1 2 3 4 5)
|
|
yield (* i i))
|
|
{{{example_end}}}
|
|
|
|
(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)
|
|
if (= 0 (% i 2))
|
|
yield i)
|
|
"
|
|
(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)
|
|
;; "Applies the function to the sequence, as in calls the function with
|
|
;; ithe 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 ,@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)
|
|
((lambda (export-name)
|
|
`(define ,export-name
|
|
,(eval orig-export-name)))
|
|
(string->symbol
|
|
(concat-strings module-prefix
|
|
(symbol->string orig-export-name)))))
|
|
exports))))
|
|
|
|
(define (tdefine-module module-name (:imports ()) (:exports ()) . body)
|
|
(let ((module-prefix (concat-strings (symbol->string module-name) "::"))
|
|
(exec `(begin ,@(map (lambda (x) `(,import ,x)) imports) ,@body)))
|
|
(eval exec)
|
|
(enable-debug-log)
|
|
(pair begin
|
|
(map (lambda (orig-export-name)
|
|
((lambda (export-name)
|
|
`(define ,export-name
|
|
,(eval orig-export-name)))
|
|
(string->symbol
|
|
(concat-strings module-prefix
|
|
(symbol->string orig-export-name)))))
|
|
exports))
|
|
(disable-debug-log)
|
|
))
|
|
|
|
(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)
|
|
;; we have the fun-name, the param names and the types, lets go:
|
|
;;
|
|
;; first 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)
|
|
(define generic-map-name (hash-map)))
|
|
(hm/set! generic-map-name types (eval `(,lambda ,names ,@body)))
|
|
;; now check if the generic procedure already exists
|
|
(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)
|
|
"Checks if the argument is =nil=."
|
|
(= x ()))
|
|
|
|
(define (type=? obj typ)
|
|
"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)
|
|
"Checks if the argument is a number."
|
|
(type=? x :number))
|
|
|
|
(define (symbol? x)
|
|
"Checks if the argument is a symbol."
|
|
(type=? x :symbol))
|
|
|
|
(define (keyword? x)
|
|
"Checks if the argument is a keyword."
|
|
(type=? x :keyword))
|
|
|
|
(define (pair? x)
|
|
"Checks if the argument is a pair."
|
|
(type=? x :pair))
|
|
|
|
(define (string? x)
|
|
"Checks if the argument is a string."
|
|
(type=? x :string))
|
|
|
|
(define (lambda? x)
|
|
"Checks if the argument is a function."
|
|
(type=? x :lambda))
|
|
|
|
(define (macro? x)
|
|
"Checks if the argument is a macro."
|
|
(type=? x :macro))
|
|
|
|
(define (special-lambda? x)
|
|
"Checks if the argument is a special-lambda."
|
|
(type=? x :dynamic-macro))
|
|
|
|
(define (built-in-function? x)
|
|
"Checks if the argument is a built-in function."
|
|
(type=? x :cfunction))
|
|
|
|
(define (continuation? x)
|
|
"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)
|
|
"Returns the last pair in the sqeuence.
|
|
|
|
{{{example_start}}}
|
|
(define a (list 1 2 3 4))
|
|
(print (end a))
|
|
{{{example_end}}}
|
|
"
|
|
(if (or (null? seq) (not (pair? (rest seq))))
|
|
seq
|
|
(end (rest seq))))
|
|
|
|
(define (last seq)
|
|
"Returns the (first) of the last (pair) of the given sequence.
|
|
|
|
{{{example_start}}}
|
|
(define a (list 1 2 3 4))
|
|
(print (last a))
|
|
{{{example_end}}}
|
|
"
|
|
(first (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)
|
|
(begin
|
|
(define e (end seq))
|
|
(mutate e (pair (first 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."
|
|
(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)
|
|
"Appends an element to a sequence, by extendeing the list
|
|
with (pair elem nil)."
|
|
(extend seq (pair elem ())))
|
|
|
|
(define (length seq)
|
|
"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)
|
|
"Adds one to the argument."
|
|
(+ val 1))
|
|
|
|
(define (decrement val)
|
|
"Subtracts one from the argument."
|
|
(- val 1))
|
|
|
|
(define (range (:from 0) :to)
|
|
"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))))
|
|
|
|
(define (range-while (:from 0) :to)
|
|
"Returns a sequence of numbers starting with the number defined
|
|
by 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)
|
|
"Takes a function and a sequence as arguments and returns a new
|
|
sequence which contains the results of using the first sequences
|
|
elemens as argument to that function."
|
|
(if (null? seq)
|
|
seq
|
|
(pair (fun (first seq))
|
|
(map fun (rest seq)))))
|
|
|
|
(define (reduce fun seq)
|
|
"Takes a function and a sequence as arguments and applies the
|
|
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))
|
|
|
|
(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 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)))))
|
|
|
|
(define (filter fun seq)
|
|
"Takes a function and a sequence as arguments and applies the
|
|
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)))))
|
|
|
|
|
|
(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))
|
|
|
|
|
|
;; (generic-extend (+ v1 :vector v2 :vector)
|
|
;; (assert (= (vector-length v1)
|
|
;; (vector-length v2)))
|
|
;; (vector (+ (vector-ref v1 0)
|
|
;; (vector-ref v2 0))))
|
|
|
|
|
|
;; (unless (bound? generic-+-map)
|
|
;; (set! generic-+-map (create-hash-map)))
|
|
;; (hm/set! generic-+-map '(:vector :vector) (lambda (v1 v2)
|
|
;; (assert (= (vector-length v1)
|
|
;; (vector-length v2)))
|
|
;; (vector (+ (vector-ref v1 0)
|
|
;; (vector-ref v2 0)))))
|
|
;; (hm/set! generic-+-map '(:string :string) (lambda (v1 v2) (concat-strings v1 v2)))
|
|
|
|
;; (let ((define-it
|
|
;; (lambda (backup)
|
|
;; (set! + (set-type!
|
|
;; (lambda args (let ((fun (hm/get-or-nil generic-+-map (map type args))))
|
|
;; (if fun (apply fun args)
|
|
;; (backup args))))
|
|
;; :generic-procedure)))))
|
|
;; (if (bound? +)
|
|
;; (let ((exisiting-fun +))
|
|
;; (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-it (lambda (args) (apply orig-proc args)))))
|
|
;; (define-it (lambda (args) (error :generic-lookup "no overloads found")))))
|