define-macro bug?

27 Avr 2007


      Ok, this is going to be a bit long:
(The same code works for petite and mzscheme.)
(The same code cause error in gsi and gsc compiled code.)

# cat top.sc
(define (top)
    ( (lambda (input)
              (cond ((equal? input ''done) (display 'Goodbye) (newline))
                    (else (display (eval input))(newline) (top) ))
      ) (read) ))
(display "Welcome to toy scheme")(newline)
(top)

# compile top.sc -> ./top

cat bug.sc | ./top
....
*** ERROR IN solve-confs-248 -- (Argument 2) REAL expected
(> #!unbound 1)

cat bug.sc | /usr/4.0b22/bin/gsi top.sc
....
*** ERROR IN solve-confs-248 -- (Argument 2) REAL expected
(> #!unbound 1)

cat bug.sc
;; --------------------------------------------------------------
;; http://www.ccs.neu.edu/home/dorai/t-y-scheme/t-y-scheme-Z-H-1.html
;;
(define amb-fail '*)
(define initialize-amb-fail
  (lambda ()
    (set! amb-fail
      (lambda ()
        (error "amb tree exhausted")))))
(define-macro amb
  (lambda alts...
    `(let ((+prev-amb-fail amb-fail))
       (call/cc
        (lambda (+sk)
          ,@(map (lambda (alt)
                   `(call/cc
                     (lambda (+fk)
                       (set! amb-fail
                         (lambda ()
                           (set! amb-fail +prev-amb-fail)
                           (+fk 'fail)))
                       (+sk ,alt))))
                 alts...)
          (+prev-amb-fail))))))
(define number-between
  (lambda (lo hi)
    (let loop ((i lo))
      (if (> i hi) (amb)
          (amb i (loop (+ i 1)))))))
(define assert
  (lambda (pred)
    (if (not pred) (amb))))
(define-macro bag-of
  (lambda (e)
    `(let ((+prev-amb-fail amb-fail)
           (+results '()))
       (if (call/cc
            (lambda (+k)
              (set! amb-fail (lambda () (+k #f)))
              (let ((+v ,e))
                (set! +results (cons +v +results))
                (+k #t))))
           (amb-fail))
       (set! amb-fail +prev-amb-fail)
       (reverse! +results))))

(define (nreverse rev-it)
  (cond ((null? rev-it) rev-it)
        ((not (list? rev-it))
         (error "nreverse: Not a list in arg1" rev-it))
        (else (do ((reved '() rev-it)
                   (rev-cdr (cdr rev-it) (cdr rev-cdr))
                   (rev-it rev-it rev-cdr))
                  ((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it)))))
(define reverse! nreverse)

(define square (lambda (x) (* x x)))
(define divides? (lambda (a b) (= (remainder b a) 0)))
(define find-divisor (lambda (n test-divisor)
  (cond ((> (square test-divisor) n) n)
        ((divides? test-divisor n) test-divisor)
        (else (find-divisor n (+ test-divisor 1))))))
(define smallest-divisor (lambda (n) (find-divisor n 2)))  ;; excluding "1"
(define prime? (lambda (x) (= x (smallest-divisor x))))

(define gen-prime
  (lambda (hi)
    (let ((i (number-between 2 hi)))
      (assert (prime? i))
      i)))
(bag-of (gen-prime 20))

(display "===========================")(newline)
(define (solve-partition-n n)
    (let ((x (number-between 1 n))
          (y (number-between 1 n))
          (z (number-between 1 n))
         )
      (assert
       (= (+ x y z) n)
      )
      (list x y z)
    )
)
(bag-of (solve-partition-n 6))

(define (solve-confs-248)
    (let ((n (number-between 1 8))
          (d (number-between 1 256))
         )
         (define m (expt (+ d 1) n))
         (define v (if (> m n) m n))
         (define t (+ n m v))
         (assert (<= t 248))
         (list n d m v t )
    )
)

(define all-confs-248 (bag-of (solve-confs-248)))
all-confs-248

'done
(exit)

dillo gimp

dillo gimp

Christian Jaeger

Christian Jaeger

étiquettes

participants (2)