~tim/scheme-vm

746c7358ff1e8d8536586a84037914aa977c4a54 — Tim Morgan 2 years ago af394fe
Fix the map function so it handles multiple list args

This work exposed a serious flaw in my approach to the compiler. Up
until now I could get away with fundamentals like `car`, `cdr`, etc.
being macros, compiled directly into vm instructions. But that's not
right; these can be passed around like lambdas in Scheme, so I need to
rethink my approach.

The dirty hack I used here is to wrap the macro in a lambda, but that is
SLOW! The test suite now takes nearly twice as long to run.
4 files changed, 54 insertions(+), 9 deletions(-)

M lib/scheme/base.scm
M spec/compiler_spec.rb
M spec/lib/map-spec.scm
M vm/source_code_error_printer.rb
M lib/scheme/base.scm => lib/scheme/base.scm +36 -4
@@ 106,14 106,14 @@
    (--define-native apply base_apply)
    (--define-native call-with-current-continuation base_call_cc)
    (--define-native call/cc base_call_cc)
    (--define-native car base_car)
    (--define-native cdr base_cdr)
    (--define-native car-macro base_car)
    (--define-native cdr-macro base_cdr)
    (--define-native char? base_char?)
    (--define-native char->integer base_char_to_integer)
    (--define-native cons base_cons)
    (--define-native define base_define)
    (--define-native define-syntax base_define_syntax)
    (--define-native empty? base_null?)
    (--define-native empty-macro base_null?)
    (--define-native eq? base_eq?)
    (--define-native if base_if)
    (--define-native integer? base_integer?)


@@ 255,6 255,17 @@
         (and (eq? n1 n2)
              (= n2 n3 ...)))))

    ; FIXME: this seems like a dirty hack
    (define (car list)
      (car-macro list))

    ; FIXME: this seems like a dirty hack
    (define (cdr list)
      (cdr-macro list))

    ; FIXME: this seems like a dirty hack
    (define (empty? list)
      (empty-macro list))

    (define (>= a b)
      (or (= a b) (> a b)))


@@ 610,13 621,34 @@
    (define (odd? n)
      (= 1 (modulo n 2)))

    (define (map fn l)
    ; FIXME: not sure if this is a standard thing, but I need it below for now...
    (define (any? fn list)
      (cond
       ((empty? list) #f)
       ((fn (car list)) #t)
       (else (any? fn (cdr list)))))

    ; don't export this -- it is only used by the real map
    (define (map-over-single-list fn l)
      (letrec ((m (lambda (l l2)
                    (if (empty? l)
                      l2
                      (m (cdr l) (cons (fn (car l)) l2))))))
        (reverse (m l '()))))

    (define (map fn . lists)
      (if (= 1 (length lists))
        (map-over-single-list fn (car lists))
        (letrec ((m (lambda (l l2)
                      (if (any? empty? l)
                        l2
                        (let ((cars (map-over-single-list car l))
                              (cdrs (map-over-single-list cdr l)))
                          (m cdrs (cons (apply fn cars) l2)))))))
          (reverse (m lists '())))))

    ;(define map map-over-single-list)

    (define (string->number str)
      (letrec* ((digits (map (lambda (c)
                              (- (char->integer c) 48))

M spec/compiler_spec.rb => spec/compiler_spec.rb +8 -4
@@ 199,8 199,10 @@ describe Compiler do
          'VM::PUSH_NUM', '3',
          'VM::PUSH_NUM', 3,
          'VM::PUSH_LIST',
          'VM::CAR',
          'VM::POP',
          'VM::PUSH_NUM', 1,
          'VM::SET_ARGS',
          'VM::PUSH_VAR', 'car',
          'VM::CALL',
          'VM::HALT'
        ])
      end


@@ 221,8 223,10 @@ describe Compiler do
          'VM::PUSH_NUM', '3',
          'VM::PUSH_NUM', 3,
          'VM::PUSH_LIST',
          'VM::CDR',
          'VM::POP',
          'VM::PUSH_NUM', 1,
          'VM::SET_ARGS',
          'VM::PUSH_VAR', 'cdr',
          'VM::CALL',
          'VM::HALT'
        ])
      end

M spec/lib/map-spec.scm => spec/lib/map-spec.scm +8 -0
@@ 4,3 4,11 @@
(assert (equal?
          '(1 4 9)
          (map (lambda (n) (* n n)) '(1 2 3))))

(assert (equal?
          '((1 4) (2 5) (3 6))
          (map (lambda (x y) (list x y)) '(1 2 3) '(4 5 6))))

(assert (equal?
          '((1 4) (2 5) (3 6))
          (map (lambda (x y) (list x y)) '(1 2 3 7) '(4 5 6))))

M vm/source_code_error_printer.rb => vm/source_code_error_printer.rb +2 -1
@@ 10,7 10,8 @@ class VM
      return @title unless @error.filename && @error.filename != ''
      return @title unless @code
      lines_range = (@error.line - 2)..(@error.line - 1)
      code = @code.split("\n")[lines_range].map { |l| "  #{l}" }.join("\n")
      lines = @code.split("\n")[lines_range]
      code = lines && lines.map { |l| "  #{l}" }.join("\n")
      line = "#{@error.filename}##{@error.line}"
      pointer = " #{' ' * @error.column}^ #{@error.message}"
      "#{@title}\n\n#{line}\n\n#{code}\n#{pointer}"