diff options
author | Keisuke Nishida <kxn30@po.cwru.edu> | 2001-04-01 05:03:41 +0000 |
---|---|---|
committer | Keisuke Nishida <kxn30@po.cwru.edu> | 2001-04-01 05:03:41 +0000 |
commit | 17e90c5e25a7a2e453742044ee6a3fa5f27e9e5d (patch) | |
tree | db77f6e4b51ff1a58e1016e977a3591eb856ef78 /module/system/base/syntax.scm | |
parent | c092937bd5da5b3ca35fd7a7cc54538767fe6ab5 (diff) | |
download | guile-17e90c5e25a7a2e453742044ee6a3fa5f27e9e5d.tar.gz |
New VM.
Diffstat (limited to 'module/system/base/syntax.scm')
-rw-r--r-- | module/system/base/syntax.scm | 98 |
1 files changed, 98 insertions, 0 deletions
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm new file mode 100644 index 000000000..fab3f0bd0 --- /dev/null +++ b/module/system/base/syntax.scm @@ -0,0 +1,98 @@ +;;; Guile VM specific syntaxes and utilities + +;; 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 (system base syntax) + :use-module (oop goops) + :use-module (ice-9 match) + :use-module (ice-9 receive) + :use-module (ice-9 and-let-star) + :export (match and-let* receive)) + + +;;; +;;; Keywords by `:KEYWORD' +;;; + +(read-set! keywords 'prefix) + + +;;; +;;; Dot expansion +;;; + +;; FOO.BAR -> (slot FOO 'BAR) + +(define (expand-dot! x) + (cond ((and (symbol? x) (not (eq? x '...))) (expand-symbol x)) + ((pair? x) + (cond ((memq (car x) '(quote quasiquote)) x) + (else (set-car! x (expand-dot! (car x))) + (set-cdr! x (expand-dot! (cdr x))) + x))) + (else x))) + +(define (expand-symbol x) + (let loop ((s (symbol->string x))) + (let ((i (string-rindex s #\.))) + (if i + `(slot ,(loop (substring s 0 i)) + (quote ,(string->symbol (substring s (1+ i))))) + (string->symbol s))))) + +(define syntax expand-dot!) +(export-syntax syntax) + +;; slot accessor +(define slot (make-procedure-with-setter slot-ref slot-set!)) +(export slot) + + +;;; +;;; Simplified define-class +;;; + +;; (define-vm-class <foo> () (x 1) (y 2)) => +;; +;; (define-class <foo> () +;; (a :init-keyword :a :init-form 1) +;; (b :init-keyword :b :init-form 2)) + +(define-macro (define-vm-class name supers . rest) + `(define-class ,name ,supers + ,@(map (lambda (def) + (if (not (pair? def)) (set! def (list def))) + (let ((name (car def)) (rest (cdr def))) + (cons* name :init-keyword (symbol->keyword name) + (if (or (null? rest) (keyword? (car rest))) + rest + (cons :init-form rest))))) + rest))) + +(export-syntax define-vm-class) + +;;; +;;; Other utilities +;;; + +(define-public (list-fold f d l) + (if (null? l) + d + (list-fold f (f (car l) d) (cdr l)))) |