summaryrefslogtreecommitdiff
path: root/module/system/base/syntax.scm
diff options
context:
space:
mode:
authorKeisuke Nishida <kxn30@po.cwru.edu>2001-04-01 05:03:41 +0000
committerKeisuke Nishida <kxn30@po.cwru.edu>2001-04-01 05:03:41 +0000
commit17e90c5e25a7a2e453742044ee6a3fa5f27e9e5d (patch)
treedb77f6e4b51ff1a58e1016e977a3591eb856ef78 /module/system/base/syntax.scm
parentc092937bd5da5b3ca35fd7a7cc54538767fe6ab5 (diff)
downloadguile-17e90c5e25a7a2e453742044ee6a3fa5f27e9e5d.tar.gz
New VM.
Diffstat (limited to 'module/system/base/syntax.scm')
-rw-r--r--module/system/base/syntax.scm98
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))))