Hello,
i have an error i can not resolve in racket/r6rs. The almost same code works in Guile (pure Guile) and Kawa (approx. r7rs) .
I think it should works in Racket but i have re-written a lot of code in R6RS and i will lost all those code if i can not find a solution in r6rs.
It is a module that allow some syntax like (if test then statements else other-statements) and is also compatible with classic 'if' of scheme.
It is a bit long but here is the code:
#!r6rs
;; /Applications/Racket\ v8.13/bin/plt-r6rs --install if-then-else.scm
;; [installing /Users/mattei/Library/Racket/8.13/collects/if-then-else/main.ss]
;; [Compiling /Users/mattei/Library/Racket/8.13/collects/if-then-else/main.ss]
(library (if-then-else) ; R6RS
(export if)
(import (rnrs base (6))
(rnrs syntax-case (6))
;;(only (racket) syntax-case)
(for (rnrs base (6)) expand) ; import at expand phase (not run phase)
(for (rnrs syntax-case (6)) expand)
(only (srfi :1) third)
(declare)
(insert)
(syntax)
(for (if-parser) expand)
(for (only (rnrs io simple (6)) display newline) expand))
(define-syntax if
(lambda (stx)
(syntax-case stx (then else)
((if tst ...)
(with-syntax ((parsed-args (call-parse-if-args-syntax #'(tst ...))))
(display "if : parsed-args=") (display #'parsed-args) (newline)
#'parsed-args)))))
) ; end module
the other modules are:
#!r6rs
;; /Applications/Racket\ v8.13/bin/plt-r6rs --install if-parser.scm
(library (if-parser) ; R6RS
(export then=?
else=?
call-parse-if-args-syntax)
(import (rnrs base (6))
;;(for (rnrs base (6)) expand) ; import at expand phase (not run phase)
(rnrs syntax-case (6))
(only (srfi :1) third)
(declare)
(insert)
(syntax))
;; usefull procedures and macro for the next part of code
(define (then=? arg)
(or (datum=? arg 'then)
(datum=? arg 'THEN)))
;; (or (equal? arg 'then)
;; (equal? arg 'THEN)
;; (check-syntax=? #'then arg)
;; (check-syntax=? #'THEN arg)))
(define (else=? arg)
(or (datum=? arg 'else)
(datum=? arg 'ELSE)))
;; (or (equal? arg 'else)
;; (equal? arg 'ELSE)
;; (check-syntax=? #'else arg)
;; (check-syntax=? #'ELSE arg)))
;; > (if #f else 3)
;; 3
;; > (if #t else 3)
;; > (if #t 2 else 3)
;; 2
;; > (if #t then 2 else 3)
;; 2
;; > (if #f then 2 else 3)
;; 3
;; > (if #f then 1 2 else 3 4)
;; 4
;; > (if #t then 1 2 else 3 4)
;; 2
;; > (if #t 1 2 3)
;; 3
;; > (if #t then 1 2 else 3 4 then 5)
;; . . SRFI-105.rkt:181:17: if: then after else near : '(then 5)
;; > (if #t then 1 2 else 3 4 else 5)
;; . . SRFI-105.rkt:181:17: if: 2 else inside near: '(else 5)
;; > (if #t else 1 2 then 3 4)
;; . . SRFI-105.rkt:181:17: if: then after else near : '(then 3 4)
;; > (if #t then 1 2 then 3 4)
;; . . SRFI-105.rkt:181:17: if: 2 then inside near: '(then 3 4)
;; #|kawa:1|# (import (if-then-else))
;; #|kawa:2|# (if (< 2 3) then "2 < 3" else "error")
;; 2 < 3
(define (call-parse-if-args-syntax Largs) ; Largs = (test e1 ...)
;;(display "Largs=") (display Largs) (newline)
(define lenL (length Largs))
(declare test e1)
(cond ((< lenL 2)
(error "if: too few arguments:" Largs)))
(set! test (car Largs))
(set! e1 (cadr Largs))
; deal with the old 2 args 'if' but modified
(cond ((and (= lenL 2) (then=? e1))
(error "if: syntax error,found (if test then) only: near " Largs))
((and (= lenL 2) (else=? e1))
(error "if: syntax error,found (if test else) only: near " Largs))
((= lenL 2) #`(cond (#,test #,e1))) ; (if test e1)
((and (= lenL 3) (then=? e1)) #`(cond (#,test ; (if test then e2)
#,(third Largs))))
((and (= lenL 3) (else=? e1)) #`(cond ((not #,test) ; (if test else e2)
#,(third Largs))))
((= lenL 3) #`(cond (#,test #,e1)
(else #,(third Largs))))
(else
(let ()
(define L-then '())
(define L-else '())
(define cpt-then 0)
(define cpt-else 0)
(define (parse-if-args L)
(cond ((null? L) (set! L-then (reverse L-then))
(set! L-else (reverse L-else)))
((then=? (car L)) (cond ((= cpt-else 1)
(error "if: then after else near :" L)))
(cond ((= cpt-then 1)
(error "if: 2 then inside near:" L)))
(set! cpt-then (+ 1 cpt-then))
(parse-if-args (cdr L))) ; recurse
((else=? (car L)) (cond ((= cpt-else 1)
(error "if: 2 else inside near:" L)))
(set! cpt-else (+ 1 cpt-else))
(parse-if-args (cdr L))) ; recurse
((and (>= cpt-then 1) (= cpt-else 0)) (insert-set! (car L) L-then)
(parse-if-args (cdr L))) ; recurse
((>= cpt-else 1) (insert-set! (car L) L-else)
(parse-if-args (cdr L))) ; recurse
(else ; start with 'then' directives but without 'then' keyword !
;; i allow this syntax but this is dangerous: risk of confusion with regular scheme syntax
(insert-set! (car L) L-then)
(set! cpt-then 1)
(parse-if-args (cdr L))))) ; recurse
(define Lr (cdr Largs)) ; list of arguments of 'if' without the test
(parse-if-args Lr) ; call the parsing of arguments
(cond ((null? L-then) #`(cond ((not #,test)
(let ()
#,@L-else))))
((null? L-else) #`(cond (#,test
(let ()
#,@L-then))))
(else ;; `(if-scheme ,test
;; (let ()
;; ,@L-then)
;; (let ()
;; ,@L-else)))))))
#`(cond (#,test (let ()
#,@L-then))
(else
(let ()
#,@L-else)))))))))
) ; end library
;; /Applications/Racket\ v8.13/bin/plt-r6rs --install declare.scm
#!r6rs
(library (declare)
(export declare)
(import (rnrs base (6)))
;; (declare ls dyn) ;; declare multiple variables
(define-syntax declare
(syntax-rules ()
((_ var1 ...) (begin
(define var1 '())
...))))
) ; end library
#!r6rs
;; /Applications/Racket\ v8.13/bin/plt-r6rs --install insert.scm
(library (insert)
(export insert
insert-set!)
(import (rnrs base (6)))
;; library procedures and macro
(define insert cons)
;; insert and set
(define-syntax insert-set!
(syntax-rules ()
((_ expr var)
(set! var (insert expr var)))))
) ;; end module declaration
;; installation:
;; plt-r6rs --install syntax.scm
#!r6rs
(library (syntax)
(export datum=?
member-syntax
;;member-normal&syntax
)
(import (rnrs base (6))
(rnrs syntax-case (6))
(only (srfi :1) any member)
(only (racket) syntax?))
;; racket does not allow to syntax->datum an object not being (syntax something)
(define (datum=? obj1 obj2)
(cond ((and (syntax? obj1) (syntax? obj2))
(eq? (syntax->datum obj1)
(syntax->datum obj2)))
((and (syntax? obj1) (not (syntax? obj2)))
(eq? (syntax->datum obj1)
obj2))
((and (not (syntax? obj1)) (syntax? obj2))
(eq? obj1
(syntax->datum obj2)))
(else
(eq? obj1 obj2))))
;; Welcome to DrRacket, version 8.13 [cs].
;; Language: r6rs, with debugging; memory limit: 8192 MB.
;; > (define op-lst (list #'* #'+ #'- #'/))
;; > (member-syntax #'+ op-lst)
;; #t
;; (member-syntax '+ '(- + / *))
;; #t
;; (member-syntax + (list - + / *))
;; #t
;; (member-syntax + (list - / *))
;; #f
;; (member-syntax '+ '(- / *))
;; #f
;; > (member-syntax #'+ (list - + / *))
;;#f
(define (member-syntax x lst)
(any (lambda (y)
(datum=? x y))
lst))
;; (define (member-normal&syntax x lst)
;; (or (member x lst)
;; (member-syntax x lst)))
) ; end library
the error is on single example:
Welcome to DrRacket, version 8.13 [cs].
Language: r6rs, with debugging; memory limit: 8192 MB.
> (if #t 7)
if : parsed-args=.#<syntax:Users/mattei/Library/Racket/8.13/collects/if-parser/main.ss:111:22 (cond (#t 7))>
. ../../../../Library/Racket/8.13/collects/if-parser/main.ss:111:23: cond: unbound identifier;
also, no #%app syntax transformer is bound
context...:
other binding...:
context at layer 1...: in: cond
not so fun 
even if rewritting some code in pure Racket should solve the problem as i suppose it is tied to r6rs.
regards,
Damien
for phase levels