slime/bin/pre.slime

(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 (while cond . body)
  (let ((gs (gensym)))
    `(,let ((,gs ()))
       (,set! ,gs
             (,lambda ()
               (,when ,cond
                 ,@body
                 (,gs))))
       (,gs))))

(define-macro (cond . clauses)
  "Example usage:
      (define (prime? x)
       (define (rec i)
         (cond ((> i (** x 0.5))  t)
               ((= 0 (% x i))    ())
               (else             (rec (+ 1 i))))
         )
       (rec 2))"
  (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")))))