546 lines
16 KiB
Plaintext
546 lines
16 KiB
Plaintext
;; (remove_when_double_free_is_fixed)
|
|
;; (remove_when_double_free_is_fixed_2)
|
|
;; (define (kk (:key ()))
|
|
;; ())
|
|
|
|
;; (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)
|
|
(attempt (hm/get hm key) ()))
|
|
|
|
(define-macro (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-macro (delay expr)
|
|
`(,lambda () ,expr))
|
|
|
|
(define (force promise)
|
|
(promise))
|
|
|
|
(define-macro (mac a) (list + 1 1))
|
|
(define-macro (add . args) (cons '+ args))
|
|
|
|
(define-macro (and . args)
|
|
;; (and cond1 cond2 (cond3 args))
|
|
;; ->
|
|
;; (if cond1
|
|
;; (if cond2
|
|
;; (let ((g (cond3 args)))
|
|
;; (if g
|
|
;; g
|
|
;; ()))
|
|
;; ())
|
|
;; ())
|
|
(if args
|
|
`(,if ,(car args)
|
|
,(apply and (cdr args))
|
|
())
|
|
t))
|
|
|
|
(define-macro (or . args)
|
|
;; (or cond1 cond2 (cond3 args))
|
|
;; ->
|
|
;; (if cond1
|
|
;; t
|
|
;; (if cond2
|
|
;; t
|
|
;; (if (cond3 args)
|
|
;; t
|
|
;; ())))
|
|
(if args
|
|
`(,if ,(car args)
|
|
t
|
|
,(apply or (cdr args)))
|
|
()))
|
|
|
|
(define-macro (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 (= (cdr body) ())
|
|
`(if ,condition ,@body nil)
|
|
`(if ,condition (begin ,@body) nil)))
|
|
|
|
|
|
(define-macro (unless condition . body)
|
|
"Special form for when multiple actions should be done if a
|
|
condition is false."
|
|
(if (= (cdr body) ())
|
|
`(if ,condition nil ,@body)
|
|
`(if ,condition nil (begin ,@body))))
|
|
|
|
(define-macro (n-times times action)
|
|
"Executes action times times."
|
|
(define (repeat times elem)
|
|
(unless (> 1 times)
|
|
(cons elem (repeat (- times 1) elem))))
|
|
`(begin ,@(repeat times action)))
|
|
|
|
(define-macro (let bindings . body)
|
|
(define (unzip lists)
|
|
(when lists
|
|
(define (iter lists l1 l2)
|
|
(define elem (car lists))
|
|
(if elem
|
|
(iter (cdr lists)
|
|
(cons (car elem) l1)
|
|
(cons (car (cdr elem)) l2))
|
|
(list l1 l2)))
|
|
(iter lists () ())))
|
|
(define unzipped (unzip bindings))
|
|
`((,lambda ,(car unzipped) ,@body) ,@(car (cdr unzipped))))
|
|
|
|
(define-macro (cond . clauses)
|
|
(define (rec clauses)
|
|
(if (= () clauses)
|
|
()
|
|
(if (= (car (car clauses)) 'else)
|
|
(begin
|
|
(if (not (= (cdr clauses) ()))
|
|
(error :syntax-error "There are additional clauses after the else clause!")
|
|
(cons 'begin (cdr (car clauses)))))
|
|
`(if ,(car (car clauses))
|
|
(begin ,@(cdr (car clauses)))
|
|
,(rec (cdr clauses))))))
|
|
(rec clauses))
|
|
|
|
(define-macro (case var . clauses)
|
|
(define (rec clauses)
|
|
(if (= nil clauses)
|
|
nil
|
|
(if (= (car (car clauses)) 'else)
|
|
(begin
|
|
(if (not (= (cdr clauses) ()))
|
|
(error :syntax-error "There are additional clauses after the else clause!")
|
|
(cons 'begin (cdr (car clauses)))))
|
|
`(if (member? ,var ',(car (car clauses)))
|
|
(begin ,@(cdr (car clauses)))
|
|
,(rec (cdr clauses))))))
|
|
(rec clauses))
|
|
|
|
(define-macro (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 (cons 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 (car ll)))
|
|
(if (= (car val) ())
|
|
(append-map f (cdr ll))
|
|
(extend
|
|
val
|
|
(append-map f (cdr ll))))))
|
|
|
|
(define (rec body)
|
|
(cond
|
|
((= () 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-macro (define-typed args . body)
|
|
(define (get-arg-names args)
|
|
(when 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-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))
|
|
(cons '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)
|
|
(cons 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-macro (generic-extend args . body)
|
|
(let ((fun-name (car args))
|
|
(params (cdr args))
|
|
(types ())
|
|
(names ()))
|
|
(define (process-params params)
|
|
(when 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 (cdr (cdr params))))))
|
|
(process-params params)
|
|
;; we have the fun-name, the param names and the types, lets go:
|
|
;;
|
|
;; 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)
|
|
(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 (car objs)))
|
|
(desired-type (car (cdr objs))))
|
|
(if (= actual-type desired-type)
|
|
(inner (cdr (cdr objs)))
|
|
()))
|
|
t))
|
|
(inner objs))
|
|
|
|
(define (assert-types= . objs)
|
|
(define (inner objs)
|
|
(when objs
|
|
(let ((actual-type (type (car objs)))
|
|
(desired-type (car (cdr objs))))
|
|
(if (= actual-type desired-type)
|
|
(inner (cdr (cdr 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 (cons? 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 (cons? (cdr seq))))
|
|
seq
|
|
(end (cdr seq))))
|
|
|
|
(define (last seq)
|
|
"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}}}
|
|
"
|
|
(car (end seq)))
|
|
|
|
(define (extend seq elem)
|
|
"Extends a list with the given element, by putting it in
|
|
the (cdr ) of the last element of the sequence."
|
|
(if (cons? seq)
|
|
(begin
|
|
(define e (end seq))
|
|
(mutate! e (cons (car e) elem))
|
|
seq)
|
|
elem))
|
|
|
|
(define (extend2 seq elem)
|
|
"Extends a list with the given element, by putting it in
|
|
the (cdr ) of the last element of the sequence."
|
|
(print "addr of (end seq)" (addr-of (end seq)))
|
|
(if (cons? seq)
|
|
(let ((e (end seq)))
|
|
(print "addr if e inner" (addr-of e))
|
|
(mutate! e (cons (car e) elem))
|
|
seq))
|
|
elem)
|
|
|
|
(define (append seq elem)
|
|
"Appends an element to a sequence, by extendeing the list
|
|
with (cons elem nil)."
|
|
(extend seq (cons elem ())))
|
|
|
|
(define (length seq)
|
|
"Returns the length of the given sequence."
|
|
(if (null? seq)
|
|
0
|
|
(+ 1 (length (cdr seq)))))
|
|
|
|
(define (member? elem seq)
|
|
(when (cons? seq)
|
|
(if (= elem (car seq))
|
|
t
|
|
(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 (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) (cdr seq))
|
|
(else (cons (car seq) (list-without-index (cdr 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)
|
|
(cons 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 (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 car sequences
|
|
elemens as argument to that function."
|
|
(if (null? seq)
|
|
seq
|
|
(cons (fun (car seq))
|
|
(map fun (cdr 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? (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
|
|
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 (car seq))
|
|
(cons (car seq)
|
|
(filter fun (cdr seq)))
|
|
(filter fun (cdr seq)))))
|
|
|
|
|
|
(define (zip l1 l2)
|
|
(unless (and (null? l1) (null? l2))
|
|
(cons (list (car l1) (car l2))
|
|
(zip (cdr l1) (cdr l2)))))
|
|
|
|
(define (unzip lists)
|
|
(when lists
|
|
(define (iter lists l1 l2)
|
|
(define elem (car lists))
|
|
(if elem
|
|
(iter (cdr lists)
|
|
(cons (car elem) l1)
|
|
(cons (car (cdr elem)) l2))
|
|
(list l1 l2)))
|
|
|
|
(iter lists () ())))
|
|
|
|
(define (enumerate seq)
|
|
(define (enumerate-inner seq next-num)
|
|
(when seq
|
|
(cons (list (car seq) next-num)
|
|
(enumerate-inner (cdr 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")))))
|