Merge branch 'dev' into leo-ard/compression-c-hostleo-ard/compression-c-host

11 files changed, 426 insertions, 123 deletions

diff --git a/src/lib/define-macro.scm b/src/lib/define-macro.scm
index 835653d..54b4ec1 100644
--- a/src/lib/define-macro.scm
+++ b/src/lib/define-macro.scm
@@ -1,5 +1,8 @@
 (define-expander
   (define-macro expr expand-expr)
+  (if (or (not (pair? expr)) (eq? (car expr) 'set!))
+    (error "*** define-macro cannot be used as a variable or be assigned."))
+
   (if (pair? (cadr expr))  ;; (define-macro (foo x) ...)
     (let ((macro-name (caadr expr))
           (macro-body `(lambda (,@(cdadr expr))
diff --git a/src/lib/expander-utils.scm b/src/lib/expander-utils.scm
new file mode 100644
index 0000000..53c9199
--- /dev/null
+++ b/src/lib/expander-utils.scm
@@ -0,0 +1,94 @@
+
+;; good ol' define-macro
+(define-expander
+  (define-macro expr expand-expr)
+  (if (or (not (pair? expr)) (eq? (car expr) 'set!))
+    (error "*** define-macro cannot be used as a variable or be assigned."))
+
+  (if (pair? (cadr expr))  ;; (define-macro (foo x) ...)
+    (let ((macro-name (caadr expr))
+          (macro-body `(lambda (,@(cdadr expr))
+                         ,@(cddr expr))))
+      (expand-expr
+        `(define-expander
+           (,macro-name ##inner-expr ##inner-expand-expr)
+           (if (symbol? ##inner-expr)
+             (error "*** a macro cannot be used as a variable:" ##inner-expr))
+           (##inner-expand-expr (apply ,macro-body (cdr ##inner-expr))))))
+
+    (let ((macro-name (cadr expr)) ;; (define-macro foo (lambda (x) ...))
+          (macro-body (caddr expr)))
+      (if (not (eq? (car macro-body) 'lambda))
+        (error "*** define-macro: expected lambda exprsession" macro-body))
+      (expand-expr
+        `(define-expander
+           (,macro-name ##inner-expr ##inner-expand-expr)
+           (if (symbol? ##inner-expr)
+             (error "*** a macro cannot be used as a variable:" ##inner-expr))
+           (##inner-expand-expr (apply ,macro-body (cdr ##inner-expr))))))))
+
+
+;; defines an identifier macro used as a compile-time constant
+(define-expander
+  (define-const expr expand-expr)
+  (cond
+    ((not (pair? expr)) (error "*** define-const cannot be used as a variable."))
+
+    ((eq? (car expr) 'set!) (error "*** define-const cannot be assigned."))
+
+    (else
+      (let ((name (cadr expr))
+            (value (expand-expr (caddr expr))))
+        (expand-expr
+          `(define-expander 
+             (,name ##inner-expr ##inner-expand-expr)
+             (cond 
+               ((not (pair? ##inner-expr)) ,value)
+
+               ((eq? (car ##inner-expr) 'set!) (error ,(string-append "*** const " (symbol->string name) " cannot be assigned.")))
+
+               (else
+                 (error ,(string-append "*** const " (symbol->string name) " was called but it is not a procedure."))))))))))
+
+
+;; sugar for defining the behavior of a procedure depending on the number of args passed to it.
+(define-expander
+  (define-expander-case expr expand-expr)
+  (cond
+    ((not (pair? expr)) (error "*** define-expander-case cannot be used as a variable."))
+
+    ((eq? (car expr) 'set!) (error "*** define-expander-case cannot be assigned."))
+
+    (else
+      (let* ((expander-name (caadr expr))
+             (args-name (cadadr expr))
+             (expander-cases (cddr expr))
+             (expander-cases (if (assq 'else expander-cases) ;; has else 
+                               expander-cases
+                               (append 
+                                 expander-cases 
+                                 `((else 
+                                     (error 
+                                       (string-append 
+                                         "*** " 
+                                         (symbol->string ',expander-name)
+                                         " called with "
+                                         (number->string (length ,args-name))
+                                         " arguments. Number of arguments must be: " 
+                                         ,(string-concatenate 
+                                            (map number->string (map caar expander-cases)) ", ")))))))))
+        (expand-expr 
+          `(define-expander
+             (,expander-name expr expand-expr)
+             (cond
+               ((not (pair? expr)) expr)
+
+               ((eq? (car expr) 'set!) `(set! ,(cadr expr) ,(expand-expr (caddr expr))))
+
+               (else 
+                 (let ((,args-name (map expand-expr (cdr expr))))
+                   (case (length ,args-name)
+                     ,@expander-cases))))))))))
+
+
+
diff --git a/src/lib/r4rs/bool.scm b/src/lib/r4rs/bool.scm
index 0d19f28..ea3e25a 100644
--- a/src/lib/r4rs/bool.scm
+++ b/src/lib/r4rs/bool.scm
@@ -1,3 +1,5 @@
+(##include-once "./types.scm")
+
 ; Booleans && Equality (R4RS sections 6.1 and 6.2).
 
 (define (not obj) (##eqv? obj (or)))
diff --git a/src/lib/r4rs/do.scm b/src/lib/r4rs/do.scm
new file mode 100644
index 0000000..b876a69
--- /dev/null
+++ b/src/lib/r4rs/do.scm
@@ -0,0 +1,27 @@
+(define-expander 
+  (do expr expand-expr)
+  (if (or (not (pair? expr)) (eq? (car expr) 'set!))
+    (error "*** do cannot be used as a variable or be assigned."))
+
+  (let ((variables (cadr expr))
+        (test (caddr expr))
+        (body (cdddr expr)))
+    (expand-expr
+      `(let ##it-do-be-doing
+         ,(map (lambda (variable)
+                 (list (car variable) (cadr variable)))
+               variables)
+         (if ,(car test)
+           (begin 
+             ,@(cdr test))
+           (begin
+             ,@body
+             (##it-do-be-doing 
+              ,@(map (lambda (variable)
+                       (if (pair? (cddr variable))
+                         (caddr variable)
+                         (car variable)))
+                     variables))))))))
+
+
+
diff --git a/src/lib/r4rs/expander-utils.scm b/src/lib/r4rs/expander-utils.scm
new file mode 100644
index 0000000..53c9199
--- /dev/null
+++ b/src/lib/r4rs/expander-utils.scm
@@ -0,0 +1,94 @@
+
+;; good ol' define-macro
+(define-expander
+  (define-macro expr expand-expr)
+  (if (or (not (pair? expr)) (eq? (car expr) 'set!))
+    (error "*** define-macro cannot be used as a variable or be assigned."))
+
+  (if (pair? (cadr expr))  ;; (define-macro (foo x) ...)
+    (let ((macro-name (caadr expr))
+          (macro-body `(lambda (,@(cdadr expr))
+                         ,@(cddr expr))))
+      (expand-expr
+        `(define-expander
+           (,macro-name ##inner-expr ##inner-expand-expr)
+           (if (symbol? ##inner-expr)
+             (error "*** a macro cannot be used as a variable:" ##inner-expr))
+           (##inner-expand-expr (apply ,macro-body (cdr ##inner-expr))))))
+
+    (let ((macro-name (cadr expr)) ;; (define-macro foo (lambda (x) ...))
+          (macro-body (caddr expr)))
+      (if (not (eq? (car macro-body) 'lambda))
+        (error "*** define-macro: expected lambda exprsession" macro-body))
+      (expand-expr
+        `(define-expander
+           (,macro-name ##inner-expr ##inner-expand-expr)
+           (if (symbol? ##inner-expr)
+             (error "*** a macro cannot be used as a variable:" ##inner-expr))
+           (##inner-expand-expr (apply ,macro-body (cdr ##inner-expr))))))))
+
+
+;; defines an identifier macro used as a compile-time constant
+(define-expander
+  (define-const expr expand-expr)
+  (cond
+    ((not (pair? expr)) (error "*** define-const cannot be used as a variable."))
+
+    ((eq? (car expr) 'set!) (error "*** define-const cannot be assigned."))
+
+    (else
+      (let ((name (cadr expr))
+            (value (expand-expr (caddr expr))))
+        (expand-expr
+          `(define-expander 
+             (,name ##inner-expr ##inner-expand-expr)
+             (cond 
+               ((not (pair? ##inner-expr)) ,value)
+
+               ((eq? (car ##inner-expr) 'set!) (error ,(string-append "*** const " (symbol->string name) " cannot be assigned.")))
+
+               (else
+                 (error ,(string-append "*** const " (symbol->string name) " was called but it is not a procedure."))))))))))
+
+
+;; sugar for defining the behavior of a procedure depending on the number of args passed to it.
+(define-expander
+  (define-expander-case expr expand-expr)
+  (cond
+    ((not (pair? expr)) (error "*** define-expander-case cannot be used as a variable."))
+
+    ((eq? (car expr) 'set!) (error "*** define-expander-case cannot be assigned."))
+
+    (else
+      (let* ((expander-name (caadr expr))
+             (args-name (cadadr expr))
+             (expander-cases (cddr expr))
+             (expander-cases (if (assq 'else expander-cases) ;; has else 
+                               expander-cases
+                               (append 
+                                 expander-cases 
+                                 `((else 
+                                     (error 
+                                       (string-append 
+                                         "*** " 
+                                         (symbol->string ',expander-name)
+                                         " called with "
+                                         (number->string (length ,args-name))
+                                         " arguments. Number of arguments must be: " 
+                                         ,(string-concatenate 
+                                            (map number->string (map caar expander-cases)) ", ")))))))))
+        (expand-expr 
+          `(define-expander
+             (,expander-name expr expand-expr)
+             (cond
+               ((not (pair? expr)) expr)
+
+               ((eq? (car expr) 'set!) `(set! ,(cadr expr) ,(expand-expr (caddr expr))))
+
+               (else 
+                 (let ((,args-name (map expand-expr (cdr expr))))
+                   (case (length ,args-name)
+                     ,@expander-cases))))))))))
+
+
+
diff --git a/src/lib/r4rs/io.scm b/src/lib/r4rs/io.scm
index 094bdf8..e12dfa9 100644
--- a/src/lib/r4rs/io.scm
+++ b/src/lib/r4rs/io.scm
@@ -1,4 +1,4 @@
-(##include-once "ribbit:define-macro.scm")
+(##include-once "ribbit:expander-utils.scm")
 (##include-once "./bool.scm")
 (##include-once "./types.scm")
 (##include-once "./vector.scm")
@@ -220,7 +220,7 @@
 
 ;; ---------------------- EOF & TYPES ---------------------- ;;
 
-(define ##eof (##rib 0 0 5))
+(define ##eof (##rib 0 0 singleton-type))
 
 (define (eof-object? obj)
   (##eqv? obj ##eof))
diff --git a/src/lib/r4rs/optimize.scm b/src/lib/r4rs/optimize.scm
new file mode 100644
index 0000000..aa40a3c
--- /dev/null
+++ b/src/lib/r4rs/optimize.scm
@@ -0,0 +1,155 @@
+(##include-once "ribbit:expander-utils.scm")
+
+
+;; ########## Booleans && Equality (R4RS sections 6.1 and 6.2) ########## ;;
+
+(define-expander-case
+  (equal? args)
+  ((2) (if (or (number? (car args)) (number? (cadr args)))
+         `(##eqv? ,@args)
+         `(equal? ,@args))))
+
+;; ########## Numbers (R4RS section 6.5) ########## ;;
+
+(define-expander-case (- args)
+  ((1) (if (number? (car args)) 
+         (- (car args)) 
+         `(##- 0 ,(car args))))
+  ((2) (if (and (number? (car args)) (number? (cadr args)))
+         (- (car args) (cadr args))
+         `(##- ,@args)))
+  (else 
+    (if (null? (filter (lambda (x) (not (number? x))) args))
+      (apply - args)
+      `(- ,@args))))
+
+
+(define-expander-case
+  (+ args)
+  ((0) 0)
+  ((1) (car args))
+  ((2) (if (and (number? (car args)) (number? (cadr args)))
+         (+ (car args) (cadr args))
+         `(##+ ,@args)))
+  (else 
+    (if (null? (filter (lambda (x) (not (number? x))) args))
+      (apply + args)
+      `(+ ,@args))))
+
+
+(define-expander-case
+  (< args)
+  ((1) #t)
+  ((2) (if (and (number? (car args)) (number? (cadr args)))
+         (< (car args) (cadr args))
+         `(##< ,@args)))
+  (else 
+    (if (null? (filter (lambda (x) (not (number? x))) args))
+      (apply < args)
+      `(< ,@args))))
+
+(define-expander-case
+  (> args)
+  ((1) #t)
+  ((2) (if (and (number? (car args)) (number? (cadr args)))
+         (< (car args) (cadr args))
+         `(##< ,@(reverse args))))
+  (else 
+    (if (null? (filter (lambda (x) (not (number? x))) args))
+      (apply > args)
+      `(< ,@(reverse args)))))
+
+(define-expander-case
+  (<= args)
+  ((1) #t)
+  ((2) (if (and (number? (car args)) (number? (cadr args)))
+         (<= (car args) (cadr args))
+         `(not (##< ,@(reverse args)))))
+  (else 
+    (if (null? (filter (lambda (x) (not (number? x))) args))
+      (apply <= args)
+      `(not (< ,@(reverse args))))))
+
+(define-expander-case
+  (>= args)
+  ((1) #t)
+  ((2) (if (and (number? (car args)) (number? (cadr args)))
+         (> (car args) (cadr args))
+         `(not (##< ,@args))))
+  (else 
+    (if (null? (filter (lambda (x) (not (number? x))) args))
+      (apply >= args)
+      `(not (< ,@args)))))
+
+(define-expander-case
+  (= args)
+  ((1) #t)
+  ((2) (if (and (number? (car args)) (number? (cadr args)))
+         (= (car args) (cadr args))
+         `(##eqv? ,@args)))
+  (else 
+    (if (null? (filter (lambda (x) (not (number? x))) args))
+      (apply = args)
+      `(= ,@args))))
+
+
+
+
+
+;; ########## Types (R4RS section 3.4 + others) ########## ;;
+
+;; ########## Case (R4RS section 4.2.1) ########## ;;
+
+
+;; ########## Quasiquotes (R4RS section 4.2.6) ########## ;;
+
+
+;; ########## Pairs and lists (R4RS section 6.3) ########## ;;
+
+
+;; ########## Numbers (R4RS section 6.5) ########## ;;
+
+
+;; ########## Characters (R4RS section 6.6) ########## ;;
+
+
+;; ########## Strings (R4RS section 6.7) ########## ;;
+
+
+;; ########## Vectors (R4RS section 6.8) ########## ;; 
+
+(define-expander-case
+  (vector-length args)
+  ((1) `(##field1 ,(car args))))
+
+
+(define-expander-case 
+  (vector-ref args) 
+  ((2) `(list-ref (##field0 ,(car args)) ,(cadr args))))
+
+(define-expander-case 
+  (vector-set! args) 
+  ((3) `(list-set! (##field0 ,(car args)) ,(cadr args) ,(caddr args))))
+
+(define-expander-case 
+  (make-vector args) 
+  ((1) 
+   (let ((k (car args))
+         (vector-type 4))
+     (cond 
+       ((number? k)
+        `(##rib ,(vector->list (make-vector k 0)) ,k ,vector-type))
+       (else
+         `(##rib (make-list ,k 0) ,k ,vector-type))))))
+
+(define-expander-case
+  (vector args)
+  ((0) '#())
+  (else 
+     `(##rib ,args ,(length args) 4)))
+
+
+;; ########## Control (R4RS section 6.9) ########## ;;
+
+
+;; ########## I/O (R4RS section 6.10) ########## ;;
diff --git a/src/lib/r4rs/r4rs.scm b/src/lib/r4rs/r4rs.scm
index 87407ad..bd547f4 100644
--- a/src/lib/r4rs/r4rs.scm
+++ b/src/lib/r4rs/r4rs.scm
@@ -11,6 +11,7 @@
 (##include-once "./control.scm")
 (##include-once "./string.scm")
 (##include-once "./compiler.scm")
+(##include-once "./do.scm")
 
 ;;;----------------------------------------------------------------------------
 
diff --git a/src/lib/r4rs/types.scm b/src/lib/r4rs/types.scm
index e46be3e..2f4a3ff 100644
--- a/src/lib/r4rs/types.scm
+++ b/src/lib/r4rs/types.scm
@@ -1,15 +1,17 @@
+(##include-once "./expander-utils.scm")
 (##include-once "./bool.scm")
 
-(define pair-type      0)
-(define procedure-type 1)
-(define symbol-type    2)
-(define string-type    3)
-(define vector-type    4)
-(define singleton-type 5)
-(define char-type      6)
 
-(define input-port-type 8)
-(define output-port-type 9)
+(define-const pair-type      0)
+(define-const procedure-type 1)
+(define-const symbol-type    2)
+(define-const string-type    3)
+(define-const vector-type    4)
+(define-const singleton-type 5)
+(define-const char-type      6)
+
+(define-const input-port-type 8)
+(define-const output-port-type 9)
 
 (define (instance? type) (lambda (o) (and (##rib? o) (##eqv? (##field2 o) type))))
 
diff --git a/src/mk-rsi b/src/mk-rsi
index 73e2d38..73e2d38 100644..100755
--- a/src/mk-rsi
+++ b/src/mk-rsi
diff --git a/src/rsc.scm b/src/rsc.scm
index 0d5deab..7a751cd 100755
--- a/src/rsc.scm
+++ b/src/rsc.scm
@@ -1278,7 +1278,7 @@
 
 (define host-config #f)
 
-(define (compile-program verbosity parsed-vm features-enabled features-disabled program)
+(define (compile-program verbosity debug-info parsed-vm features-enabled features-disabled program)
   (let* ((exprs-and-exports
            (extract-exports program))
          (exprs
@@ -1332,7 +1332,7 @@
     ;    (map (lambda (pair)
     ;           (cons (car pair) (map display-c-rib (cdr pair)))) (table->list hash-table-c-ribs))))
 
-    (if (>= verbosity 3)
+    (if (or (>= verbosity 3) (memq 'expansion debug-info))
       (begin
         (display "*** Code expansion: \n")
         (pp expansion)))
@@ -1346,16 +1346,16 @@
             (map (lambda (pair)
                    (list (car pair) (length (cdr pair)))) (table->list hash-table-c-ribs))))))
 
-    (if (>= verbosity 2)
+    (if (or (>= verbosity 2) (memq 'rvm-code debug-info))
       (begin
         (display "*** RVM code:\n")
         (pp (vector-ref return 0))))
-    (if (>= verbosity 3)
+    (if (or (>= verbosity 3) (memq 'exports debug-info))
       (begin
         (display "*** exports:\n")
         (pp (vector-ref return 1))))
 
-    (if (>= verbosity 2)
+    (if (or (>= verbosity 2) (memq 'host-config debug-info))
       (begin
         (display "*** HOST CONFIG ***\n")
         (display "*** features :\n")
@@ -1413,6 +1413,10 @@
              ((eqv? first '##RIBBIT-VERSION)
               (expand-constant ##RIBBIT-VERSION))
 
+             ((mtx-search mtx first) => 
+              (lambda (expander) 
+                (apply expander (list expr (lambda (expr) (expand-begin (list expr) mtx))))))
+
              ((eqv? first 'quote)
               (expand-constant (cadr expr)))
 
@@ -1420,11 +1424,11 @@
               (expand-quasiquote (cadr expr)))
 
              ((eqv? first 'set!)
-              (let ((var (cadr expr)))
-                (cons 'set!
-                      (cons var
-                            (cons (expand-expr (caddr expr) mtx)
-                                  '())))))
+              (let* ((var (cadr expr))
+                     (expander (mtx-search mtx var)))
+                (if expander 
+                  (apply expander (list expr (lambda (expr) (expand-begin (list expr) mtx))))
+                  (list 'set! var (expand-expr (caddr expr) mtx)))))
 
              ((eqv? first 'if)
               (cons 'if
@@ -1691,7 +1695,9 @@
           (expand-constant expr))))
 
 (define (expand-constant x)
-  (list 'quote x))
+  (if (or (number? x) (string? x) (char? x))
+    x
+    (list 'quote x)))
 
 (define (expand-quasiquote rest)
   (let parse ((x rest) (depth 1))
@@ -1737,7 +1743,7 @@
                                    (cddr expr))
                              defs)
                        mtx))))
-            ((and (pair? expr) (eqv? 'define-macro (car expr)) (pair? (cdr expr)))
+            ((and (pair? expr) (eqv? 'define-expander (car expr)) (pair? (cdr expr)))
              (let ((pattern (cadr expr)))
                (if (pair? pattern)
                  (loop (cdr exprs)
@@ -1745,20 +1751,20 @@
                        (mtx-add-cte 
                          mtx 
                          (caadr expr)
-                         `(lambda (,@(cdadr expr))
-                            ,@(cddr expr))))
+                         (eval `(lambda (,@(cdadr expr))
+                                  ,@(cddr expr)))))
                          
                  (loop (cdr exprs)
                        defs
-                       (let ((macro-name (cadr expr))
-                             (macro-value (caddr expr)))
-                         (if (not (eq? (car macro-value) 'lambda))
-                           (error "*** define-macro: expected lambda expression" macro-value))
+                       (let ((expander-name (cadr expr))
+                             (expander-body (caddr expr)))
+                         (if (not (eq? (car expander-body) 'lambda))
+                           (error "*** define-macro: expected lambda expression" expander-body))
 
                          (mtx-add-cte
                            mtx
-                           macro-name 
-                           macro-value))))))
+                           expander-name 
+                           (eval expander-body)))))))
             (else
               (expand-body-done defs exprs mtx))))
         (expand-body-done defs '(0) mtx))))
@@ -1790,42 +1796,6 @@
 
 
 
-;; dispatch rules manipulation procedure
-(define (make-dispatch-rule dr-name dr-formals dr-replacement)
-  (rib dr-name dr-formals dr-replacement))
-
-(define dispatch-rule-name field0)
-(define dispatch-rule-formals field1)
-(define dispatch-rule-replacement field2)
-(define (dr-precision dr)
-  (length (filter 
-            (lambda (dr-formal) (not (symbol? dr-formal))) 
-            (dispatch-rule-formals dr))))
-
-(define (dispatch-rule=? dr1 dr2)
-  (and (eq? (dispatch-rule-name dr1) (dispatch-rule-name dr2))
-       (eqv? (length (dispatch-rule-formals dr1)) (length (dispatch-rule-formals dr2)))
-       (all (lambda (zipped-formals)
-              (or (and 
-                    (symbol? (car zipped-formals))
-                    (symbol? (cdr zipped-formals)))
-                  (equal? (car zipped-formals) (cdr zipped-formals))))
-            (map cons (dispatch-rule-formals dr1) (dispatch-rule-formals dr2)))))
-
-;;; proc-call must be of the form: '(<proc-name> <args>)
-(define (dispatch-rule-match? dr proc-call)
-  (and (eq? (dispatch-rule-name dr) (car proc-call))
-       (eqv? (length (dispatch-rule-formals dr)) (length (cdr proc-call)))
-       (all (lambda (zipped-arg)
-              (or (symbol? (car zipped-arg))
-                  (equal? (car zipped-arg) (cdr zipped-arg))))
-            (map cons (dispatch-rule-formals dr) (cdr proc-call)))))
-
-(define (most-precise-dispatch-rule dispatch-rules)
-  (car (list-sort 
-         (lambda (dr1 dr2) 
-           (> (dr-precision dr1) (dr-precision dr2)))
-         dispatch-rules)))
 
 (define (make-mtx global-macro cte)  ;; macro-contex object
   (rib global-macro cte 0))
@@ -1842,26 +1812,12 @@
 (define (mtx-cte-set mtx cte)
   (make-mtx (mtx-global mtx) cte))
 
-(define mtx-dispatch-rules  field2)
-(define mtx-dispatch-rules-set! field2-set!)
-
 (define (included? resource)
   (member resource included-resources))
 
 (define (mtx-add-global! mtx macro-name macro-value)
   (mtx-global-set! mtx (cons (list macro-name macro-value) (mtx-global mtx))))
 
-(define (mtx-add-dispatch-rule! mtx dr-name dr-formals dr-replacement)
-  (let* ((dr (make-dispatch-rule dr-name dr-formals dr-replacement))
-         (collision (find (lambda (existing-dr) (dispatch-rule=? existing-dr dr)) (mtx-dispatch-rules mtx))))
-    (if collision
-      (error "*** define-dispatch-rule: a dispatch-rule signature must be unique. Collision between\n"
-             (cons (dispatch-rule-name collision) (dispatch-rule-formals collision))
-             'and
-             (cons (dispatch-rule-name dr) (dispatch-rule-formals dr)))
-             
-      (mtx-dispatch-rules-set! mtx (cons dr (mtx-dispatch-rules mtx))))))
-
 (define (mtx-add-cte mtx macro-name macro-value)
   (mtx-cte-set mtx (cons (list macro-name macro-value) (mtx-cte mtx))))
     
@@ -1870,14 +1826,6 @@
     (and macro-value (cadr macro-value))))
 
 
-;;; proc-call must be of the form: '(<proc-name> <args>)
-(define (mtx-dr-search mtx proc-call)
-  (let ((dispatch-rules (filter 
-                          (lambda (dr) (dispatch-rule-match? dr proc-call)) 
-                          (mtx-dispatch-rules mtx))))
-    (and (not (null? dispatch-rules))
-         (most-precise-dispatch-rule dispatch-rules))))
-
 ;; Shadow macro by a variable
 (define (mtx-shadow mtx variable-names) 
   (mtx-cte-set 
@@ -1959,38 +1907,6 @@
             (expand-cond-expand-clauses (cdr clauses) rest mtx)))
       rest))
 
-(define active-dispatch-rules '())
-(define (expand-dispatched-call dr args mtx)
-  (if (find (lambda (used-dr) (dispatch-rule=? used-dr dr)) active-dispatch-rules)
-    (error "*** dispatch-rule-expansion: dispatch rules are not allowed to be called recursively:\n"
-           dr))
-  (letrec ((dr-args (filter 
-                      (lambda (arg) (not (eq? arg '##dispatch-rule-ignore)))
-                      (map (lambda (dr-formal arg) 
-                             (if (symbol? dr-formal)
-                               arg 
-                               '##dispatch-rule-ignore)) 
-                           (dispatch-rule-formals dr) args))))
-    ;; (replace (lambda (dr-formal)
-    ;;            (cond 
-    ;;              ((symbol? dr-formal)
-    ;;               (let ((value (assq dr-formal zipped-args)))
-    ;;                 (if value 
-    ;;                   (cdr value)
-    ;;                   dr-formal)))
-    ;;              ((pair? dr-formal)
-    ;;               (map replace dr-formal))
-    ;;              (else 
-    ;;                dr-formal))))
-    (set! active-dispatch-rules (cons dr active-dispatch-rules))
-    (let ((result (expand-expr 
-                    (eval `(,(dispatch-rule-replacement dr)
-                             ,@(map expand-constant dr-args)))
-                    mtx)))
-      (set! active-dispatch-rules (cdr active-dispatch-rules))
-      result)))
-
-
 (define (expand-list exprs mtx)
   (if (pair? exprs)
       (cons (expand-expr (car exprs) mtx)
@@ -4802,7 +4718,7 @@
   (let ((file-content (call-with-input-file path (lambda (port) (read-line port #f)))))
        (if (eof-object? file-content) "" file-content)))
 
-(define (generate-code target verbosity input-path rvm-path exe-output-path output-path minify? host-file encoding-name byte-stats proc-exports-and-features) ;features-enabled features-disabled source-vm
+(define (generate-code target verbosity debug-info input-path rvm-path exe-output-path output-path minify? host-file encoding-name byte-stats proc-exports-and-features) ;features-enabled features-disabled source-vm
   (let* ((proc
            (vector-ref proc-exports-and-features 0))
          (exports
@@ -4823,7 +4739,7 @@
                              (if input-path
                                (string->list* (string-from-file input-path))
                                '()))))
-                     (if (>= verbosity 1)
+                     (if (or (>= verbosity 1) (memq 'rvm-len debug-info))
                        (begin
                          (display "*** RVM code length: ")
                          (display (length input))
@@ -4935,6 +4851,7 @@
                         lib-path
                         minify?
                         verbosity
+                        debug-info
                         _progress-status
                         primitives
                         features-enabled
@@ -4976,6 +4893,7 @@
              "Compiling program"
              (compile-program
                verbosity
+               debug-info
                host-file
                features-enabled
                features-disabled
@@ -4989,6 +4907,7 @@
         (generate-code
           _target
           verbosity
+          debug-info
           input-path
           rvm-path
           exe-output-path
@@ -5007,6 +4926,7 @@
     (pipeline-compiler)
 
     (let ((verbosity 0)
+          (debug-info '())
           (target "rvm")
           (generate-strip #f)
           (base-strip #f)
@@ -5072,6 +4992,10 @@
                    (set! byte-stats (string->number (car rest)))
                    (loop (cdr rest)))
 
+                  ((and (pair? rest) (member arg '("-di" "--debug-info")))
+                   (set! debug-info (cons (string->symbol (car rest)) debug-info))
+                   (loop (cdr rest)))
+
                   ((member arg '("-gs" "--generate-strip"))
                    (if (and (pair? rest) 
                             (>= (string-length (car rest)) 1)
@@ -5157,6 +5081,7 @@
           (if (null? lib-path) '("empty") lib-path)
           minify?
           verbosity
+          debug-info
           progress-status
           primitives
           features-enabled