From c7228382165653f593ba71e412b528d87ba9a53f Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 15 Apr 2001 14:54:59 +0000 Subject: [PATCH] *** empty log message *** --- README | 8 +- module/language/gscheme/spec.scm | 139 -------------- module/language/scheme/spec.scm | 54 ++++++ module/language/scheme/translate.scm | 277 +++++++++++++++++++++++++++ module/slib/.cvsignore | 1 + module/slib/guile.init | 8 +- 6 files changed, 339 insertions(+), 148 deletions(-) delete mode 100644 module/language/gscheme/spec.scm create mode 100644 module/language/scheme/spec.scm create mode 100644 module/language/scheme/translate.scm create mode 100644 module/slib/.cvsignore diff --git a/README b/README index 99f2897ca..f7a79bd4c 100644 --- a/README +++ b/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 diff --git a/module/language/gscheme/spec.scm b/module/language/gscheme/spec.scm deleted file mode 100644 index eb86a74af..000000000 --- a/module/language/gscheme/spec.scm +++ /dev/null @@ -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 - ) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm new file mode 100644 index 000000000..d0281512b --- /dev/null +++ b/module/language/scheme/spec.scm @@ -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 + ) diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm new file mode 100644 index 000000000..5b3585b08 --- /dev/null +++ b/module/language/scheme/translate.scm @@ -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- 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- e l (ghil-lookup e x))) + (else (make- 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- 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- e l obj)) + (else (bad-syntax)))) + + ;; (quasiquote OBJ) + ((quasiquote) + (match tail + ((obj) (make- e l (trans-quasiquote e l obj))) + (else (bad-syntax)))) + + ((define define-private) + (match tail + ;; (define NAME VAL) + (((? symbol? name) val) + (make- 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- e l (ghil-lookup e name) val))) + + (else (bad-syntax)))) + + ((set!) + (match tail + ;; (set! NAME VAL) + (((? symbol? name) val) + (make- 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- e l (trans:x test) (trans:x then) (make:void))) + ((test then else) + (make- e l (trans:x test) (trans:x then) (trans:x else))) + (else (bad-syntax)))) + + ;; (and EXPS...) + ((and) + (make- e l (map trans:x tail))) + + ;; (or EXPS...) + ((or) + (make- e l (map trans:x tail))) + + ;; (begin EXPS...) + ((begin) + (make- 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- 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- 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- 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- 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- 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- e l (trans e l obj)) + (make- 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)))))) diff --git a/module/slib/.cvsignore b/module/slib/.cvsignore new file mode 100644 index 000000000..e796b66a8 --- /dev/null +++ b/module/slib/.cvsignore @@ -0,0 +1 @@ +*.go diff --git a/module/slib/guile.init b/module/slib/guile.init index 73afc1fdc..2d53c5d59 100644 --- a/module/slib/guile.init +++ b/module/slib/guile.init @@ -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. -- 2.20.1