Re: letrec bug

[Marijn Schouten (hkBst)]

Ludovic � wrote:
> Hello,
> 
> "Marijn Schouten (hkBst)" <address@hidden> writes:
> 
>> invoke.scm -e "(let ((x 1)) (letrec ((x 32) (y x)) y))"
> 
> Could you make a copy of `invoke.scm' available?  :-)
> 
> Thanks,
> Ludo'.

Certainly.

I hope you have as much fun with it as I have :D

Marijn

-- 
Marijn Schouten (hkBst), Gentoo Lisp project, Gentoo ML
<http://www.gentoo.org/proj/en/lisp/>, #gentoo-{lisp,ml} on FreeNode

#!/usr/bin/guile \
-s
!#

(use-modules
 (oop goops)
; (oop goops describe)
 (ice-9 syncase)
 (ice-9 getopt-long)
 (ice-9 popen)
 )

(define-class <scheme> ()
  (name #:getter s-name #:init-keyword #:name)
  (announce #:getter s-announce #:init-keyword #:announce)
  (filename #:getter s-filename #:init-keyword #:filename)
  (eval #:getter s-eval #:init-keyword #:eval)
  (load-eval #:getter s-load-eval #:init-keyword #:load-eval)
;  (version-option #:getter s-version-option #:init-keyword #:version-option)
;  (version-command #:getter s-version-command #:init-keyword #:version-command)
  )

(define (in-path executable) (search-path (parse-path (getenv "PATH")) 
executable))

(define (for-each-display s) (string-append "(for-each display (list " s "))"))

(define (for-each-display-then-exit s) (string-append "(for-each display (list 
" s "))"))

(define (available? scheme)
  (in-path (s-filename scheme)))

(define (announce-bigloo)     (system* (s-filename bigloo) "-version"))
(define (announce-chicken)    (display "CHICKEN ") (system* (s-filename 
chicken) "-release"))
(define (announce-elk)        (display "Elk 3.99.7")(newline))
(define (announce-gambit)     (display "Gambit ") (eval-gambit 
"(##system-version-string)"))
(define (announce-gauche)     (system* (s-filename gauche) "-V"))
(define (announce-guile)      (display "Guile ") (eval-guile "(version)"))
(define (announce-ikarus)     (display "Ikarus")(newline))
(define (announce-kawa)       (display "kawa")(newline))
(define (announce-larceny)    (display "larceny")(newline))
(define (announce-mit-scheme) (display "MIT/GNU Scheme ") (eval-mit-scheme 
"(get-subsystem-version-string \"Release\")"))
(define (announce-mzscheme)   (system* (s-filename mzscheme) "-v"))
(define (announce-rscheme)    (display "RScheme ") (system* (s-filename 
rscheme) "--version"))
(define (announce-scheme48)   (display "scheme48 1.8")(newline))
(define (announce-schoca)     #f);(eval-schoca ""))
(define (announce-scm)        (system* (s-filename scm) "--version"))
(define (announce-sigscheme)  (display (s-name sigscheme))(display " 
0.8.3")(newline))
(define (announce-sisc)       (into-pipe* "" (s-filename sisc)))
(define (announce-stklos)     (system* (s-filename stklos) "--version"))
(define (announce-tinyscheme) #f);(eval-tinyscheme ""))

(define (announce scheme)
  ((s-announce scheme)))

(define (evaluate-all command) (for-each (lambda (s)(evaluate s command)) 
schemes))

(define-syntax into-pipe*
  (syntax-rules ()
    ((_ command args ...)
     (let ((port (open-pipe* OPEN_WRITE args ...))) (display command port) 
(close-pipe port)))))

(define (eval-bigloo command)     (system* "bigloo" "-eval" (string-append 
(for-each-display command) "(exit)"))(newline));(into-pipe* command "bigloo" 
"-s" "-call/cc"))
(define (eval-chicken command)    (system* "csi" "-eval" (for-each-display 
command))(newline))
(define (eval-elk command)        (into-pipe* (for-each-display command) "elk" 
"-l" "-")(newline))
(define (eval-gambit command)     (system* "gambit-interpreter" "-e" 
(for-each-display command))(newline))
(define (eval-gauche command)     (into-pipe* (for-each-display command) "gosh" 
"-b")(newline))
(define (eval-guile command)      (system* "guile" "-c" (for-each-display 
command))(newline))
(define (eval-ikarus command)     (into-pipe* command "ikarus")(newline))
(define (eval-kawa command)       (into-pipe* command "kawa")(newline))
(define (eval-larceny command)    (into-pipe* command "larceny")(newline))
(define (eval-mit-scheme command) (into-pipe* (for-each-display command) 
"mit-scheme" "--batch-mode")(newline))
(define (eval-mzscheme command)   (system* "mzscheme" "--eval" 
(for-each-display command))(newline))
(define (eval-rscheme command)    (into-pipe* command "rs" "-script"))
(define (eval-scheme48 command)   (into-pipe* command "scheme48" "-a" "batch"))
(define (eval-schoca command)     (into-pipe* command "schoca")(newline))
(define (eval-scm command)        (system* "scm" "-e" (for-each-display 
command))(newline))
(define (eval-sigscheme command)  (into-pipe* command "sscm")(newline))
(define (eval-sisc command)       (into-pipe* command "sisc")(newline))
(define (eval-stklos command)     (system* "stklos" "-e" (for-each-display 
command))(newline))
(define (eval-tinyscheme command) (into-pipe* command "tinyscheme")(newline))

(define (evaluate scheme command)
  ((s-eval scheme) command))

(define (load-eval-bigloo file)     (system* "bigloo" "-load" file "-eval" 
"(exit)"))
(define (load-eval-chicken file)    (system* "csi" "-script" file))
(define (load-eval-elk file)        (system* "elk" "-l" file))
(define (load-eval-gambit file)     (system* "gambit-interpreter" file))
(define (load-eval-gauche file)     (system* "gosh" file))
(define (load-eval-guile file)      (system* "guile" "-s" file))
(define (load-eval-ikarus file)     (system* "ikarus" file))
(define (load-eval-kawa file)       (into-pipe* file "kawa"))
(define (load-eval-larceny file)    (into-pipe* file "larceny"))
(define (load-eval-mit-scheme file) (into-pipe* "" "mit-scheme" "--batch-mode" 
"--load" file))
(define (load-eval-mzscheme file)   (system* "mzscheme" "--load" file))
(define (load-eval-rscheme file)    (system* "rs" "-script" file))
(define (load-eval-scheme48 file)   (eval-scheme48 (string-append "(load \"" 
file "\")")))
(define (load-eval-schoca file)     (eval-schoca "")(system* "schoca" file))
(define (load-eval-scm file)        (system* "scm" "-l" file))
(define (load-eval-sigscheme file)  (system* "sscm" file))
(define (load-eval-sisc file)       (into-pipe* file "sisc"))
(define (load-eval-stklos file)     (system* "stklos" "-f" file))
(define (load-eval-tinyscheme file) (eval-tinyscheme "")(system* "tinyscheme" 
file))

(define (load scheme file)
  ((s-load-eval scheme) file))

(define-syntax define-scheme
  (syntax-rules ()
    ((define-scheme scheme name announce filename eval load-eval)
     (begin
       (define scheme (make <scheme>
                        #:name name #:announce announce #:filename filename 
#:eval eval #:load-eval load-eval)
         )
       (register scheme)))))

(define schemes '())
(define (register scheme)
  (set! schemes (cons scheme schemes)))

(define-scheme bigloo     "Bigloo"         announce-bigloo     "bigloo"     
eval-bigloo     load-eval-bigloo)
(define-scheme chicken    "CHICKEN"        announce-chicken    "chicken"    
eval-chicken    load-eval-chicken)   
(define-scheme elk        "Elk"            announce-elk        "elk"        
eval-elk        load-eval-elk)       
(define-scheme gambit     "Gambit"         announce-gambit     "gsi"        
eval-gambit     load-eval-gambit)    
(define-scheme gauche     "Gauche"         announce-gauche     "gosh"       
eval-gauche     load-eval-gauche)    
(define-scheme guile      "Guile"          announce-guile      "guile"      
eval-guile      load-eval-guile)     
(define-scheme ikarus     "ikarus"         announce-ikarus     "ikarus"     
eval-ikarus     load-eval-ikarus)    
(define-scheme kawa       "kawa"           announce-kawa       "kawa"       
eval-kawa       load-eval-kawa)      
(define-scheme larceny    "larceny"        announce-larceny    "larceny"    
eval-larceny    load-eval-larceny)   
(define-scheme mit-scheme "MIT/GNU Scheme" announce-mit-scheme "mit-scheme" 
eval-mit-scheme load-eval-mit-scheme)
(define-scheme mzscheme   "MzScheme"       announce-mzscheme   "mzscheme"   
eval-mzscheme   load-eval-mzscheme)  
(define-scheme rscheme    "RScheme"        announce-rscheme    "rs"         
eval-rscheme    load-eval-rscheme)   
(define-scheme scheme48   "Scheme48"       announce-scheme48   "scheme48"   
eval-scheme48   load-eval-scheme48)  
(define-scheme schoca     "Schoca"         announce-schoca     "schoca"     
eval-schoca     load-eval-schoca)    
(define-scheme scm        "SCM"            announce-scm        "scm"        
eval-scm        load-eval-scm)       
(define-scheme sigscheme  "sigscheme"      announce-sigscheme  "sscm"       
eval-sigscheme  load-eval-sigscheme) 
(define-scheme sisc       "sisc"           announce-sisc       "sisc"       
eval-sisc       load-eval-sisc)      
(define-scheme stklos     "STklos"         announce-stklos     "stklos"     
eval-stklos     load-eval-stklos)    
(define-scheme tinyscheme "tinyscheme"     announce-tinyscheme "tinyscheme" 
eval-tinyscheme load-eval-tinyscheme)


; stalin

(set! schemes (reverse schemes))

(define option-spec
  '(;(version (single-char #\v) (value #f))
    (eval (single-char #\e) (value #t))
    (load (single-char #\l) (value #t))
    (schemes (single-char #\s) (value #t))
    ))

(define (main)
  (define options (getopt-long (command-line) option-spec))
  (for-each (lambda (s)
              (cond
               ((available? s)
                (announce s)
                (let ((command (option-ref options 'eval #f)))
                  (if command (evaluate s command)))
                (let ((file (option-ref options 'load #f)))
                  (if file (load s file))))
               (else
                (begin (display (s-name s)) (display " is 
unavailable")(newline)))))
            schemes))

(main)

signature.asc
Description: OpenPGP digital signature