magic/magic-base.scm

(define exit (lambda () (builtin exit)))
(define gensym (lambda (x) (builtin gensym x)))
(define display (lambda (x) (builtin display x)))
(define newline (lambda () (builtin newline)))
;(define print (lambda (x) (builtin print x)))
(define eq? (lambda (x y) (builtin eq? x y)))
;(define equal? (lambda (x y) (builtin equal? x y)))
(define cons (lambda (x y) (builtin cons x y)))
(define car (lambda (x) (builtin car x)))
(define cdr (lambda (x) (builtin cdr x)))
(define set-car! (lambda (x y) (builtin set-car! x y)))
(define set-cdr! (lambda (x y) (builtin set-cdr! x y)))
(define null? (lambda (x) (builtin null? x)))
(define pair? (lambda (x) (builtin pair? x)))
(define number? (lambda (x) (builtin number? x)))
(define boolean? (lambda (x) (builtin boolean? x)))
(define string? (lambda (x) (builtin string? x)))
(define char? (lambda (x) (builtin char? x)))
(define symbol? (lambda (x) (builtin symbol? x)))
(define + (lambda (x y) (builtin + x y)))
(define - (lambda (x y) (builtin - x y)))
(define * (lambda (x y) (builtin * x y)))
(define = (lambda (x y) (builtin = x y)))
(define < (lambda (x y) (builtin < x y)))
(define > (lambda (x y) (builtin > x y)))
(define <= (lambda (x y) (builtin <= x y)))
(define >= (lambda (x y) (builtin >= x y)))
(define quotient (lambda (x y) (builtin quotient x y)))
(define modulo (lambda (x y) (builtin modulo x y)))
;(define box (lambda (x) (builtin box x)))
;(define unbox (lambda (x) (builtin unbox x)))
;(define set-box! (lambda (x y) (builtin set-box! x y)))
(define vector-ref (lambda (v i) (builtin vector-ref v i)))
(define vector-set! (lambda (v i e) (builtin vector-set! v i e)))
(define make-vector (lambda (l d) (builtin make-vector l d)))
(define vector-length (lambda (v) (builtin vector-length v)))
;(define string->list (lambda (s) (builtin string->list s)))
;(define symbol->string (lambda (s) (builtin symbol->string s)))
					;(define list->string (lambda (s) (builtin list->string s)))
(define make-string (lambda (siz ch) (builtin make-string siz ch)))
(define string-set! (lambda (s i chr) (builtin string-set! s i chr)))
(define string-ref (lambda (s i) (builtin string-ref s i)))
(define string->symbol (lambda (s) (builtin string->symbol s)))
(define string-length (lambda (s) (builtin string-length s)))
(define string=? (lambda (s t) (builtin string=? s t)))
;(define string->number (lambda (s) (builtin string->number s)))
(define eof-object? (lambda (s) (builtin eof-object? s)))
(define read-char (lambda () (builtin read-char)))
(define peek-char (lambda () (builtin peek-char)))
(define vector? (lambda (x) (builtin vector? x)))
(define symbol->string (lambda (x) (builtin symbol->string x)))
(define char->integer (lambda (x) (builtin char->integer x)))


(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))

(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))

(define (cadddr x) (car (cdddr x)))

(define (equal? x y)
  (if (pair? x)
      (if (pair? y)
	  (if (equal? (car x) (car y))
	      (equal? (cdr x) (cdr y))
	      #f)
	  #f)
      (eq? x y)))

(define (not p) (if p #f #t))

(define (length l)
  (if (null? l)
      0
      (+ 1 (length (cdr l)))))

(define (append x y)
  (if (null? x)
      y
      (cons (car x) (append (cdr x) y))))
(define (revappend l r)
  (if (null? l)
      r
      (revappend (cdr l) (cons (car l) r))))
(define (reverse l) (revappend l '()))

(define (member elt l)
  (if (null? l)
      #f
      (if (eq? elt (car l))
	  #t
	  (member elt (cdr l)))))

(define (filter p l)
  (if (null? l)
      '()
      (if (p (car l))
	  (cons (car l) (filter p (cdr l)))
	  (filter p (cdr l)))))

(define (zero? n) (= n 0))
(define (even? n) (= 0 (modulo n 2)))
(define (odd? n) (not (even? n)))

(define (list? l)
  (if (null? l)
      #t
      (if (pair? l)
	  #t
	  #f)))

(define (for-each proc l)
  (if (null? l)
      #t
      (begin (proc (car l))
	     (for-each proc (cdr l)))))

(define (map f l)
  (if (null? l)
      '()
      (cons (f (car l))
	    (map f (cdr l)))))

(define (concat-map func lst)
  (if (null? lst)
      '()
      (append (func (car lst))
	      (concat-map func (cdr lst)))))

(define (assoc key tbl)
  (if (null? tbl)
      #f
      (if (eq? key (caar tbl))
	  (car tbl)
	  (assoc key (cdr tbl)))))

(define (error x y z)
 ; (print x)
 ; (print y)
 ; (print z)
  (builtin exit)
  )

;(define (print p) (display p) (newline))
;; OR and AND

(define (list1 y) (cons y '()))
(define (list2 x y) (cons x (cons y '())))
(define (list3 x y z) (cons x (cons y (cons z '()))))
(define (list4 x y z w) (cons x (cons y (cons z (cons w '())))))

(defmacro or
  (lambda (exp)
    (if (null? (cdr exp))
	;; (or)
	#f
	(if (null? (cddr exp))
	    ;; (or v)
	    (cadr exp)
	    ;; (or ,v . ,vs)
	    (let ((v (cadr exp))
		  (vs (cddr exp))
		  (tmp (gensym 'or-tmp)))
	      (list3 'let (list1 (list2 tmp v))
		       (list4 'if tmp
				tmp
				(builtin cons 'or vs))))))))

(defmacro and
  (lambda (exp)
    (if (null? (cdr exp))
	;; (and)
	#t
	(if (null? (cddr exp))
	    ;; (and v)
	    (cadr exp)
	    ;; (and ,v . ,vs)
	    (let ((v (cadr exp))
		  (vs (cddr exp))
		  (tmp (gensym 'or-tmp)))
	      (list3 'let (list1 (list2 tmp v))
		       (list4 'if tmp
				(builtin cons 'and vs)
				#f)))))))


;; QUASIQUOTE AND UNQUOTE

(define (unquote? exp)
  (and (pair? exp)
       (eq? (car exp) 'unquote)))

(define (datum? x)
  (or (boolean? x)
      (number? x)
      (string? x)
      (char? x)))

(define (do-qq l)
  (if (or (null? l) (symbol? l))
      (list2 'quote l)
      (if (datum? l)
	  l
	  (if (unquote? l)
	      (cadr l)
	      (list3 'cons
		       (do-qq (car l))
		       (do-qq (cdr l)))))))

(defmacro quasiquote
  (lambda (exp)
    (do-qq (cadr exp))))


;;; COND SHAPE PREDICATES
;;; AND EXTRACTORS

(define (cond/0? exp)
  ;; (cond)
  (and (pair? exp) (eq? 'cond (car exp)) (null? (cdr exp))))

(define (cond/else? exp)
  ;; (cond (else . <rest>))
  (and (pair? exp) (eq? 'cond (car exp)) (pair? (cdr exp))
       (pair? (cadr exp)) (eq? 'else (car (cadr exp)))))
(define (cond-get-else exp)
  `(begin . ,(cdr (cadr exp))))

(define (cond/1? exp)
  ;; (cond (<one>) . <rest>)
  (and (pair? exp) (eq? 'cond (car exp)) (pair? (cdr exp))
       (pair? (cadr exp)) (not (eq? 'else (car (cadr exp))))
       (null? (cdr (cadr exp)))))
(define (cond-get-1 exp)
  (car (cadr exp)))

(define (cond/clause? exp)
  ;; (cond (<test> . <rest>) . <rest>)
  (and (pair? exp) (eq? 'cond (car exp)) (pair? (cdr exp))
       (pair? (cadr exp)) (not (eq? 'else (car (cadr exp))))))
(define (cond/clause-get-test exp)
  (car (cadr exp)))
(define (cond/clause-get-rest exp)
  `(begin . ,(cdr (cadr exp))))

(define (cond/=>-clause? exp)
  ;; (cond (<test> => <thunk>) . <rest>)
  (and (pair? exp) (eq? 'cond (car exp)) (pair? (cdr exp))
       (pair? (cadr exp)) (not (eq? 'else (car (cadr exp))))
       (pair? (cdr (cadr exp))) (eq? '=> (cadr (cadr exp)))))
(define (cond/=>-clause-get-thunk exp)
  (caddr (cadr exp)))

(define (cond-get-next exp)
  `(cond . ,(cddr exp)))

(defmacro cond
  (lambda (exp)
    (if (cond/0? exp)
	`(builtin exit) ;; todo void
	(if (cond/else? exp)
	    (cond-get-else exp)
	    (if (cond/1? exp)
		`(or ,(cond-get-1 exp) ,(cond-get-next exp))
		(if (cond/=>-clause? exp)
		    (let ((test (cond/clause-get-test exp))
			  (thunk (cond/=>-clause-get-thunk exp))
			  (tmp (gensym 'cond-tmp)))
		      `(let ((,tmp ,test))
			 (if ,tmp
			     (,thunk ,tmp)
			     ,(cond-get-next exp))))
		    (if (cond/clause? exp)
			(let ((test (cond/clause-get-test exp))
			      (rest (cond/clause-get-rest exp)))
				 `(if ,test
				      ,rest
				      ,(cond-get-next exp)))
			(builtin exit) ;; bad syntax
			)))))))

(defmacro when
  (lambda (exp)
    (let ((test (cadr exp))
	  (body `(begin . ,(cddr exp))))
      `(if ,test
	   ,body
	   #f))))

(defmacro unless
  (lambda (exp)
    (let ((test (cadr exp))
	  (body `(begin . ,(cddr exp))))
      `(if ,test
	   #f
	   ,body))))
;; <case> ::= (case <exp> <clause> (else <exp>))
;;
;; <clause> ::= ((<thing>) <exp>)

;; (case foo ((x) 1) ((y) 2) (else 3))
;; -->
;; let tmp foo
;; (if (eq? tmp 'x) 1)
;;   ...((y) 2) (else 3))

(define (else-clause? head)
  (and (pair? head)
       (eq? 'else (car head))))

(define (compile-case t clauses)
  (if (null? clauses)
      '(builtin exit)
      (let ((head (car clauses))
	    (rest (cdr clauses)))
	(if (else-clause? head)
	    (cadr head)
	    (let ((test (caar head))
		  (body (cdr head)))
	      `(if (eq? ,t ',test)
		   (begin . ,body)
		   ,(compile-case t rest)))))))

(defmacro case
  (lambda (exp)
    (let ((discriminant (cadr exp))
	  (tmp (gensym 'tmp)))
      `(let ((,tmp ,discriminant))
	 ,(compile-case tmp (cddr exp))))))
      

; MAGIC> (include "runtime/macro-case.scm")
; MAGIC> (case (+ 1 1) ((1) 'one) ((2) 'two) (else 'dunno))
; two

(defmacro vector
  (lambda (exp)
    (let ((l (length (cdr exp)))
	  (tmp (gensym "tmp")))
	(letrec ((loop (lambda (i elts)
			 (if (null? elts)
			     tmp
			     `(begin
				(vector-set! ,tmp ,i ,(car elts))
				,(loop (+ i 1) (cdr elts)))))))
	  `(let ((,tmp (make-vector ,l #f)))
	     ,(loop 0 (cdr exp)))))))
(defmacro mapply
  (lambda (exp)
    ;;(mapply f xs arg ...)
    (let ((f (cadr exp))
	  (xs (caddr exp))
	  (args (cdddr exp))
	  (x (gensym "x")))
      `(map (lambda (,x) (,f ,x . ,args)) ,xs))))

(defmacro list
  (lambda (exp)
    (let loop ((xs (cdr exp)))
      (if (null? xs)
	  ''()
	  `(cons ,(car xs) ,(loop (cdr xs)))))))
(define (bind-assocs tmp vars body)
  (if (null? vars)
      body
      `(let ((,(car vars) (cdr (assoc ',(car vars) ,tmp))))
	 ,(bind-assocs tmp (cdr vars) body))))

(defmacro match-assoc
  (lambda (exp)
    (let ((thing (cadr exp))
	  (vars (caddr exp))
	  (body `(begin . ,(cdddr exp)))
	  (tmp (gensym "tmp")))
      `(let ((,tmp ,thing))
	 ,(bind-assocs tmp vars body)))))

(define (assoc-replace tbl key val)
  (if (null? tbl)
      (cons (cons key val) '())
      (let ((entry (car tbl)))
        (if (eq? (car entry) key)
            (cons (cons key val) (cdr tbl))
            (cons entry (assoc-replace (cdr tbl) key val))))))

(define (assoc-update tbl key f default)
  (if (null? tbl)
      (cons (cons key default) '())
      (let ((entry (car tbl)))
        (if (eq? (car entry) key)
            (cons (cons key (f (cdr entry))) (cdr tbl))
            (cons entry (assoc-update (cdr tbl) key f default))))))

(define (assoc-split table keys k)
  (let loop ((left '()) (right '()) (table table))
    (if (null? table)
	(k left right)
	(let ((entry (car table)))
	  (if (member (car entry) keys)
	      (loop (cons entry left) right (cdr table))
	      (loop left (cons entry right) (cdr table)))))))

(defmacro transform-assoc
  (lambda (exp)
    (let ((thing (cadr exp))
	  (vars (caddr exp))
	  (body `(begin . ,(cdddr exp)))
	  (tmp (gensym "tmp"))
	  (in (gensym "in"))
	  (out (gensym "out")))
      `(let ((,tmp ,thing))
	 (assoc-split ,tmp ',vars
		      (lambda (,in ,out)
			(append (match-assoc ,in ,vars ,body) ,out)))))))
(define (display-symbol form) (display form))

(define (display-char ch) (display ch))
(define (display-chars ch) (for-each display-char ch))

(define (display-boolean form)
  (if form
      (display-chars '(#\# #\t))
      (display-chars '(#\# #\f))))

(define (display-int form) (display form))

(define (vector->list v)
  (let ((l (vector-length v)))
    (let loop ((i 0))
      (if (= i l)
	  '()
	  (cons (vector-ref v i)
		(loop (+ i 1)))))))

(define (my-display form)
  (cond ((symbol? form) (display-symbol form))
	((string? form)
	 (display-char #\")
	 (display form) ;; TODO escaping
	 (display-char #\"))
        ((char? form) (display-char form))
        ((boolean? form) (display-boolean form))
        ((number? form) (display-int form))
        ((null? form) (display-chars '(#\( #\))))
	((vector? form)
	 (display-char #\#)
	 (my-display (vector->list form)))
	((pair? form)
	 (display-char #\()
	 (let loop ((form form))
	   (my-display (car form))
	   (cond ((null? (cdr form))
		  (display-char #\)))
		 ((pair? (cdr form))
		  (display-char #\space)
		  (loop (cdr form)))
		 (else (display-chars '(#\space #\. #\space))
		       (my-display (cdr form))
		       (display-char #\))))))
	(else
	 (display "[????]"))))

(define (print p) (my-display p) (newline))
(define (length=? l n)
  ;; tests if a list has a certain length
  ;; failing early if possible
  ;; failing on non-lists
  (let loop ((l l) (n n))
    (cond ((< n 0) #f)
	  ((null? l) (= n 0))
	  ((pair? l) (loop (cdr l) (- n 1)))
	  (else #f))))

(define (length>=? l n)
  (let loop ((l l) (n n))
    (cond ((< n 0) #f)
	  ((= n 0) #t)
	  ((null? l) #f)
	  ((pair? l) (loop (cdr l) (- n 1)))
	  (else #f))))


(define (extend! b v)
  ;; b is a box containing a mutable list
  ;; v is the element you want added on to the end
  ;; returns the length after extending
  ;;
  (if (null? (unbox b))
      (begin (set-box! b (cons v '())) 1)
      (let loop ((pair (unbox b)) (i 2))
	(if (null? (cdr pair))
	    (begin (set-cdr! pair (cons v '())) i)
	    (loop (cdr pair) (+ i 1))))))

(define (index obj lst)
  (let loop ((lst lst) (i 0))
    (if (null? lst)
	#f
	(if (equal? obj (car lst))
	    i
	    (loop (cdr lst) (+ i 1))))))

(define (reverse-index obj lst)
  (let loop ((lst (reverse lst)) (i (- (length lst) 1)))
    (if (null? lst)
	#f
	(if (equal? obj (car lst))
	    i
	    (loop (cdr lst) (- i 1))))))

(define (copy-list l)
  (if (null? l)
      '()
      (cons (car l) (copy-list (cdr l)))))

(define map* map)

(define (vector-for-each proc vec)
  (let ((len (vector-length vec)))
    (let loop ((i 0))
      (unless (= i len)
	(proc (vector-ref vec i))
	(loop (+ i 1))))))

(define (vector-grow vec extra fill)
  ;; (vector-grow (vector 'a 'b 'c) 2 #f)
  ;; ;=> #(a b c #f #f)
  ;;
  (let ((res (make-vector (+ (vector-length vec) extra) fill)))
    (let ((i (box 0)))
      (vector-for-each
       (lambda (elt)
	 (vector-set! res (unbox i) elt)
	 (set-box! i (+ (unbox i) 1)))
       vec))
    res))

(define (vector-append vec-1 vec-2)
  (let ((res (vector-grow vec-1 (vector-length vec-2) #f)))
    (let ((i (box (vector-length vec-1))))
      (vector-for-each
       (lambda (elt)
	 (vector-set! res (unbox i) elt)
	 (set-box! i (+ (unbox i) 1)))
       vec-2))
    res))

(define (vector-overlay! vec-1 start vec-2)
  (let ((i (box start)))
    (vector-for-each (lambda (elt)
		       (vector-set! vec-1 (unbox i) elt)
		       (set-box! i (+ (unbox i) 1)))
		     vec-2))
  #t)

(define (list->vector l)
  (let ((len (length l)))
    (let ((vec (make-vector len #f)))
      (let loop ((i 0) (l l))
	(if (null? l)
	    vec
	    (begin (vector-set! vec i (car l))
		   (loop (+ i 1) (cdr l))))))))

; (match <expr>
;   (<pattern> <expr>)
;   (<pattern> <expr>)
;   ...)

; pattern ::= number? | symbol? | '<expr> | (<pattern> . <pattern>)

(define (moo-match e)
  (let ((exp (cadr e))
	(clauses (cddr e))
	(tmp (gensym "tmp")))
    `(let ((,tmp ,exp))
       ,(moo-match-aux tmp clauses))))

(define (quote? p)
  (and (pair? p) (eq? (car p) 'quote)))

; takes: expression to match on, pattern, body, place, failure continuation
; returns: code that returns #t if pattern matches and #f if not, and an assoc list of
; bindings
(define (subpattern-match s p)
  (begin ;(print `("in subpatterN" ,s ,p))
  (cond
   ((null? p)
    (cons `((null? ,s))
	  '()))
   ((number? p)
    (cons `((number? ,s) (= ,s ,p))
	  '()))
   ((symbol? p)
    (cons `(#t)
	  `((,p ,s))))
   ((quote? p)
    (cons `((equal? ',(cadr p) ,s))
	  '()))
   ((pair? p)
    (let ((l (subpattern-match `(car ,s) (car p)))
	  (r (subpattern-match `(cdr ,s) (cdr p))))
      (cons (cons `(pair? ,s) (append (car l) (car r)))
	    (append (cdr l) (cdr r)))))
   (else
    (begin
      (print "undefined subpattern")
      (print p))))))

(define (try t pat body fk)
  (let ((m (subpattern-match t pat)))
    `(if (and . ,(car m))
	 ,(if (not (null? (cdr m)))
	      `(let ,(cdr m)
		 ,body)
	      body)
	 (,fk))))
  
(define (moo-match-aux t clauses)
  (if (null? clauses)
      `(error 'match "match fail")
      (let ((pat (caar clauses))
	    (body `(begin . ,(cdar clauses)))
	    (fk (gensym "fk")))
	`(let ((,fk (lambda ()
		      ,(moo-match-aux t (cdr clauses)))))
	   ,(try t pat body fk)))))


(defmacro match moo-match)
(define (datum? exp) (or (boolean? exp) (number? exp) (char? exp) (string? exp)))
(define (quote? exp) (and (length=? exp 2) (eq? 'quote (car exp))))
(define variable? symbol?)
(define (if? exp) (and (length=? exp 4) (eq? 'if (car exp))))
(define (begin? exp) (and (pair? exp) (eq? 'begin (car exp))))
(define (lambda? exp) (and (length>=? exp 3) (eq? 'lambda (car exp))))
(define (named-let? exp) (and (length>=? exp 4) (eq? 'let (car exp)) (symbol? (cadr exp))))
(define (let? exp) (and (length>=? exp 3) (eq? 'let (car exp))))
(define (letrec? exp) (and (length=? exp 3) (eq? 'letrec (car exp))))
(define (builtin-app? e) (and (pair? e) (eq? 'builtin (car e))))
(define app? pair?)
;; Sequence grammar:

;; <s> ::= nil
;;       | (join <s> <s>)
;;       | (cat [list of <s>])
;;       | (elt <element>)

(define (foldr f z l)
  (if (null? l)
      z
      (f (car l) (foldr f z (cdr l)))))

(define (sequence->dlist s rest)
  (match s
    ('nil rest)
    (('join x y) (sequence->dlist x (sequence->dlist y rest)))
    (('cat seqs) (foldr sequence->dlist rest seqs))
    (('elt x) (cons x rest))
    (else (error 'sequence->dlist "invalid sequence" s))))

(define (sequence->list s)
  (sequence->dlist s '()))

(define (box val) (make-vector 1 val))
(define (unbox b) (vector-ref b 0))
(define (set-box! b v) (vector-set! b 0 v))