mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
*** empty log message ***
This commit is contained in:
Keisuke Nishida
parent
bd5b51c205
commit
c722838216
6 changed files with 339 additions and 148 deletions
8
README
8
README
|
|
@ -3,19 +3,17 @@ Installation
|
|||
|
||||
1. Install the latest Guile from CVS.
|
||||
|
||||
2. Install slib.
|
||||
|
||||
3. Install Guile VM:
|
||||
2. Install Guile VM:
|
||||
|
||||
% configure
|
||||
% make install
|
||||
% ln -s module/{system,language} /usr/local/share/guile/site/
|
||||
|
||||
4. Add the following lines to your ~/.guile:
|
||||
3. Add the following lines to your ~/.guile:
|
||||
|
||||
(cond ((string=? (car (command-line)) "guile-vm")
|
||||
(use-modules (system repl repl))
|
||||
(start-repl 'gscheme)
|
||||
(start-repl 'scheme)
|
||||
(quit)))
|
||||
|
||||
Example Session
|
||||
|
|
|
|||
|
|
@ -1,139 +0,0 @@
|
|||
;;; Guile Scheme specification
|
||||
|
||||
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (language gscheme spec)
|
||||
:use-module (system base language)
|
||||
:use-module (system il ghil)
|
||||
:use-module (ice-9 match)
|
||||
:use-module (ice-9 and-let-star)
|
||||
:export (gscheme))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Translator
|
||||
;;;
|
||||
|
||||
(define (translate x) (if (pair? x) (translate-pair x) x))
|
||||
|
||||
(define (translate-pair x)
|
||||
(let ((head (car x)) (rest (cdr x)))
|
||||
(case head
|
||||
((quote) `(@quote ,@rest))
|
||||
((set! if and or begin)
|
||||
(cons (symbol-append '@ head) (map translate rest)))
|
||||
((define)
|
||||
(match rest
|
||||
((((? symbol? name) . args) . body)
|
||||
`(@define ,name (@lambda ,args ,@(map translate body))))
|
||||
(((? symbol? name) val)
|
||||
`(@define ,name ,(translate val)))
|
||||
(else (error "Syntax error:" x))))
|
||||
((lambda)
|
||||
`(@lambda ,(car rest) ,@(map translate (cdr rest))))
|
||||
((let let* letrec)
|
||||
(match x
|
||||
(('let (? symbol? f) ((s v) ...) body ...)
|
||||
`(@letrec ((,f (@lambda ,s ,@(map translate body))))
|
||||
(,f ,@(map translate v))))
|
||||
(else
|
||||
(cons* (symbol-append '@ head)
|
||||
(map (lambda (b) (cons (car b) (map translate (cdr b))))
|
||||
(car rest))
|
||||
(map translate (cdr rest))))))
|
||||
((cond)
|
||||
(let loop ((x rest))
|
||||
(match x
|
||||
(() '(@void))
|
||||
((('else . body)) `(@begin ,@(map translate body)))
|
||||
(((test) . rest) `(@or ,(translate test) ,(loop rest)))
|
||||
(((test '=> proc) . rest)
|
||||
`(@let ((_t ,(translate test)))
|
||||
(@if _t (,(translate proc) _t) ,(loop rest))))
|
||||
(((test . body) . rest)
|
||||
`(@if ,(translate test)
|
||||
(@begin ,@(map translate body))
|
||||
,(loop rest)))
|
||||
(else (error "bad cond" x)))))
|
||||
((case)
|
||||
`(@let ((_t ,(translate (car rest))))
|
||||
,(let loop ((x (cdr rest)))
|
||||
(match x
|
||||
(() '(@void))
|
||||
((('else . body)) `(@begin ,@(map translate body)))
|
||||
((((keys ...) . body) . rest)
|
||||
`(@if (@memv _t (@quote ,keys))
|
||||
(@begin ,@(map translate body))
|
||||
,(loop rest)))
|
||||
(else (error "bad cond" x))))))
|
||||
((do)
|
||||
(match rest
|
||||
((((sym init . update) ...) (test . result) body ...)
|
||||
(define (translate-update s x)
|
||||
(if (pair? x) (translate (car x)) s))
|
||||
`(@letrec ((_loop (@lambda
|
||||
,sym
|
||||
(@if ,(translate test)
|
||||
(@begin ,@(map translate result))
|
||||
(@begin ,@(map translate body)
|
||||
(_loop ,@(map translate-update
|
||||
sym update)))))))
|
||||
(_loop ,@(map translate init))))))
|
||||
|
||||
((eval-case)
|
||||
`(@eval-case
|
||||
,@(let loop ((x rest))
|
||||
(match x
|
||||
(() '(()))
|
||||
((('else . body)) `((@else ,@(map translate body))))
|
||||
(((keys . body) . rest)
|
||||
`((,keys ,@(map translate body)) ,@(loop rest)))
|
||||
(else (error "bad eval-case" x))))))
|
||||
|
||||
(else
|
||||
(let ((e (expand x)))
|
||||
(if (eq? e x)
|
||||
(let ((prim (and (symbol? head) (symbol-append '@ head))))
|
||||
(if (and prim (ghil-primitive? prim))
|
||||
(cons prim (map translate rest))
|
||||
(cons (translate head) (map translate rest))))
|
||||
(translate e)))))))
|
||||
|
||||
(define (expand x)
|
||||
(if (and (symbol? (car x))
|
||||
(module-defined? (current-module) (car x)))
|
||||
(let ((v (module-ref (current-module) (car x))))
|
||||
(if (defmacro? v)
|
||||
(apply (defmacro-transformer v) (cdr x))
|
||||
x))
|
||||
x))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Language definition
|
||||
;;;
|
||||
|
||||
(define-language gscheme
|
||||
:title "Guile Scheme"
|
||||
:version "0.4"
|
||||
:reader read
|
||||
:translator translate
|
||||
:printer write
|
||||
)
|
||||
54
module/language/scheme/spec.scm
Normal file
54
module/language/scheme/spec.scm
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
;;; Guile Scheme specification
|
||||
|
||||
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (language scheme spec)
|
||||
:use-module (language scheme translate)
|
||||
:use-module (system base language)
|
||||
:export (scheme))
|
||||
|
||||
;;;
|
||||
;;; Reader
|
||||
;;;
|
||||
|
||||
(read-enable 'positions)
|
||||
|
||||
;;;
|
||||
;;; Compiler
|
||||
;;;
|
||||
|
||||
(define (compile port env . opts)
|
||||
(do ((x (read port) (read port))
|
||||
(l '() (cons x l)))
|
||||
((eof-object? x)
|
||||
(apply compile-in (cons 'begin (reverse! l)) env scheme opts))))
|
||||
|
||||
;;;
|
||||
;;; Language definition
|
||||
;;;
|
||||
|
||||
(define-language scheme
|
||||
:title "Guile Scheme"
|
||||
:version "0.5"
|
||||
:reader read
|
||||
:translator translate
|
||||
:printer write
|
||||
:compiler compile
|
||||
)
|
||||
277
module/language/scheme/translate.scm
Normal file
277
module/language/scheme/translate.scm
Normal file
|
|
@ -0,0 +1,277 @@
|
|||
;;; Guile Scheme specification
|
||||
|
||||
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (language scheme translate)
|
||||
:use-module (system base language)
|
||||
:use-module (system il ghil)
|
||||
:use-module (ice-9 match)
|
||||
:use-module (ice-9 receive)
|
||||
:export (translate))
|
||||
|
||||
(define (translate x e)
|
||||
(call-with-ghil-environment (make-ghil-mod e) '()
|
||||
(lambda (env vars)
|
||||
(make-<ghil-lambda> env #f vars 0 (trans env #f x)))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Translator
|
||||
;;;
|
||||
|
||||
(define (trans e l x)
|
||||
(cond ((pair? x)
|
||||
(let ((y (macroexpand x)))
|
||||
(if (eq? x y)
|
||||
(trans-pair e (or (location x) l) (car x) (cdr x))
|
||||
(trans e l y))))
|
||||
((symbol? x) (make-<ghil-ref> e l (ghil-lookup e x)))
|
||||
(else (make-<ghil-quote> e l x))))
|
||||
|
||||
(define (trans-pair e l head tail)
|
||||
(define (trans:x x) (trans e l x))
|
||||
(define (trans:pair x) (trans-pair e l (car x) (cdr x)))
|
||||
(define (trans:body body) (trans-body e l body))
|
||||
(define (make:void) (make-<ghil-void> e l))
|
||||
(define (bad-syntax)
|
||||
(syntax-error l (format #f "bad ~A" head) (cons head tail)))
|
||||
(case head
|
||||
;; (void)
|
||||
((void)
|
||||
(match tail
|
||||
(() (make:void))
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (quote OBJ)
|
||||
((quote)
|
||||
(match tail
|
||||
((obj) (make-<ghil-quote> e l obj))
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (quasiquote OBJ)
|
||||
((quasiquote)
|
||||
(match tail
|
||||
((obj) (make-<ghil-quasiquote> e l (trans-quasiquote e l obj)))
|
||||
(else (bad-syntax))))
|
||||
|
||||
((define define-private)
|
||||
(match tail
|
||||
;; (define NAME VAL)
|
||||
(((? symbol? name) val)
|
||||
(make-<ghil-define> e l (ghil-lookup e name) (trans:x val)))
|
||||
|
||||
;; (define (NAME FORMALS...) BODY...)
|
||||
((((? symbol? name) . formals) . body)
|
||||
;; -> (define NAME (lambda FORMALS BODY...))
|
||||
(let ((val (trans:x `(lambda ,formals ,@body))))
|
||||
(make-<ghil-define> e l (ghil-lookup e name) val)))
|
||||
|
||||
(else (bad-syntax))))
|
||||
|
||||
((set!)
|
||||
(match tail
|
||||
;; (set! NAME VAL)
|
||||
(((? symbol? name) val)
|
||||
(make-<ghil-set> e l (ghil-lookup e name) (trans:x val)))
|
||||
|
||||
;; (set! (NAME ARGS...) VAL)
|
||||
((((? symbol? name) . args) val)
|
||||
;; -> ((setter NAME) ARGS... VAL)
|
||||
(trans:pair `((setter ,name) (,@args ,val))))
|
||||
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (if TEST THEN [ELSE])
|
||||
((if)
|
||||
(match tail
|
||||
((test then)
|
||||
(make-<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
|
||||
((test then else)
|
||||
(make-<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (and EXPS...)
|
||||
((and)
|
||||
(make-<ghil-and> e l (map trans:x tail)))
|
||||
|
||||
;; (or EXPS...)
|
||||
((or)
|
||||
(make-<ghil-or> e l (map trans:x tail)))
|
||||
|
||||
;; (begin EXPS...)
|
||||
((begin)
|
||||
(make-<ghil-begin> e l (map trans:x tail)))
|
||||
|
||||
((let)
|
||||
(match tail
|
||||
;; (let NAME ((SYM VAL) ...) BODY...)
|
||||
(((? symbol? name) (((? symbol? sym) val) ...) body ...)
|
||||
;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
|
||||
(trans:pair `(letrec ((,name (lambda ,sym ,@body))) (,name ,@val))))
|
||||
|
||||
;; (let () BODY...)
|
||||
((() body ...)
|
||||
;; NOTE: This differs from `begin'
|
||||
(make-<ghil-begin> e l (list (trans:body body))))
|
||||
|
||||
;; (let ((SYM VAL) ...) BODY...)
|
||||
(((((? symbol? sym) val) ...) body ...)
|
||||
(let ((vals (map trans:x val)))
|
||||
(call-with-ghil-bindings e sym
|
||||
(lambda (vars)
|
||||
(make-<ghil-bind> e l vars vals (trans:body body))))))
|
||||
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (let* ((SYM VAL) ...) BODY...)
|
||||
((let*)
|
||||
(match tail
|
||||
(((def ...) body ...)
|
||||
(if (null? def)
|
||||
(trans:pair `(let () ,@body))
|
||||
(trans:pair `(let (,(car def)) (let* ,(cdr def) ,@body)))))
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (letrec ((SYM VAL) ...) BODY...)
|
||||
((letrec)
|
||||
(match tail
|
||||
(((((? symbol? sym) val) ...) body ...)
|
||||
(call-with-ghil-bindings e sym
|
||||
(lambda (vars)
|
||||
(let ((vals (map trans:x val)))
|
||||
(make-<ghil-bind> e l vars vals (trans:body body))))))
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (cond (CLAUSE BODY...) ...)
|
||||
((cond)
|
||||
(match tail
|
||||
(() (make:void))
|
||||
((('else . body)) (trans:body body))
|
||||
(((test) . rest) (trans:pair `(or ,test (cond ,@rest))))
|
||||
(((test '=> proc) . rest)
|
||||
(trans:pair `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
|
||||
(((test . body) . rest)
|
||||
(trans:pair `(if ,test (begin ,@body) (cond ,@rest))))
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (case EXP ((KEY...) BODY...) ...)
|
||||
((case)
|
||||
(match tail
|
||||
((exp . clauses)
|
||||
(trans:pair
|
||||
`(let ((_t ,exp))
|
||||
,(let loop ((ls clauses))
|
||||
(cond ((null? ls) '(void))
|
||||
((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
|
||||
(else `(if (memv _t ',(caar ls))
|
||||
(begin ,@(cdar ls))
|
||||
,(loop (cdr ls)))))))))
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
|
||||
((do)
|
||||
(let ()
|
||||
(define (next s x) (if (pair? x) (car x) s))
|
||||
(match tail
|
||||
((((sym init . update) ...) (test . result) body ...)
|
||||
(trans:pair
|
||||
`(letrec ((_l (lambda ,sym
|
||||
(if ,test
|
||||
(let () (void) ,@result)
|
||||
(let () (void) ,@body
|
||||
(_l ,@(map next sym update)))))))
|
||||
(_l ,@init))))
|
||||
(else (bad-syntax)))))
|
||||
|
||||
;; (lambda FORMALS BODY...)
|
||||
((lambda)
|
||||
(match tail
|
||||
((formals body ...)
|
||||
(receive (syms rest) (parse-formals formals)
|
||||
(call-with-ghil-environment e syms
|
||||
(lambda (env vars)
|
||||
(make-<ghil-lambda> env l vars rest (trans-body env l body))))))
|
||||
(else (bad-syntax))))
|
||||
|
||||
((eval-case)
|
||||
(let loop ((x tail))
|
||||
(match x
|
||||
(() (make:void))
|
||||
((('else . body)) (trans:pair `(begin ,@body)))
|
||||
(((((? symbol? key) ...) body ...) rest ...)
|
||||
(if (memq 'compile key)
|
||||
(primitive-eval `(begin ,@(copy-tree body))))
|
||||
(if (memq 'load-toplevel key)
|
||||
(trans:pair `(begin ,@body))
|
||||
(loop rest)))
|
||||
(else (bad-syntax)))))
|
||||
|
||||
(else
|
||||
(make-<ghil-call> e l (trans:x head) (map trans:x tail)))))
|
||||
|
||||
(define (trans-quasiquote e l x)
|
||||
(cond ((not (pair? x)) x)
|
||||
((memq (car x) '(unquote unquote-splicing))
|
||||
(let ((l (location x)))
|
||||
(match (cdr x)
|
||||
((obj)
|
||||
(if (eq? (car x) 'unquote)
|
||||
(make-<ghil-unquote> e l (trans e l obj))
|
||||
(make-<ghil-unquote-splicing> e l (trans e l obj))))
|
||||
(else (syntax-error l (format #f "bad ~A" (car x)) x)))))
|
||||
(else (cons (trans-quasiquote e l (car x))
|
||||
(trans-quasiquote e l (cdr x))))))
|
||||
|
||||
(define (trans-body e l body)
|
||||
(define (define->binding df)
|
||||
(match (cdr df)
|
||||
(((? symbol? name) val) (list name val))
|
||||
((((? symbol? name) . formals) . body)
|
||||
(list name `(lambda ,formals ,@body)))
|
||||
(else (syntax-error (location df) "bad define" df))))
|
||||
;; main
|
||||
(let loop ((ls body) (ds '()))
|
||||
(cond ((null? ls) (syntax-error l "bad body" body))
|
||||
((and (pair? (car ls)) (eq? (caar ls) 'define))
|
||||
(loop (cdr ls) (cons (car ls) ds)))
|
||||
(else
|
||||
(if (null? ds)
|
||||
(trans-pair e l 'begin ls)
|
||||
(trans-pair e l 'letrec (cons (map define->binding ds) ls)))))))
|
||||
|
||||
(define (parse-formals formals)
|
||||
(cond
|
||||
;; (lambda x ...)
|
||||
((symbol? formals) (values (list formals) #t))
|
||||
;; (lambda (x y z) ...)
|
||||
((list? formals) (values formals #f))
|
||||
;; (lambda (x y . z) ...)
|
||||
((pair? formals)
|
||||
(let loop ((l formals) (v '()))
|
||||
(if (pair? l)
|
||||
(loop (cdr l) (cons (car l) v))
|
||||
(values (reverse! (cons l v)) #t))))
|
||||
(else (syntax-error (location formals) "bad formals" formals))))
|
||||
|
||||
(define (location x)
|
||||
(and (pair? x)
|
||||
(let ((props (source-properties x)))
|
||||
(and (not (null? props))
|
||||
(cons (assq-ref props 'line) (assq-ref props 'column))))))
|
||||
1
module/slib/.cvsignore
Normal file
1
module/slib/.cvsignore
Normal file
|
|
@ -0,0 +1 @@
|
|||
*.go
|
||||
|
|
@ -88,8 +88,8 @@
|
|||
;CALL-WITH-OUTPUT-STRING
|
||||
; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
|
||||
char-ready?
|
||||
macro ;has R4RS high level macros
|
||||
macro-by-example
|
||||
; macro ;has R4RS high level macros
|
||||
; macro-by-example
|
||||
defmacro ;has Common Lisp DEFMACRO
|
||||
eval ;R5RS two-argument eval
|
||||
record ;has user defined data structures
|
||||
|
|
@ -126,7 +126,7 @@
|
|||
logical
|
||||
promise
|
||||
string-case
|
||||
syntax-case
|
||||
; syntax-case
|
||||
))
|
||||
|
||||
;; time
|
||||
|
|
@ -223,7 +223,7 @@
|
|||
;;; by compiling "foo.scm" if this implementation can compile files.
|
||||
;;; See feature 'COMPILED.
|
||||
|
||||
(define slib:load-compiled load)
|
||||
(define slib:load-compiled load-compiled)
|
||||
|
||||
;;; At this point SLIB:LOAD must be able to load SLIB files.
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue