summaryrefslogtreecommitdiff
path: root/module/system/base/syntax.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/base/syntax.scm')
-rw-r--r--module/system/base/syntax.scm143
1 files changed, 107 insertions, 36 deletions
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index f14b924b7..0526b3536 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -1,34 +1,34 @@
;;; Guile VM specific syntaxes and utilities
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; 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.
-;;
+;; 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.
-;;
+;; 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.
+;; Boston, MA 02111-1307, USA
;;; Code:
(define-module (system base syntax)
- :use-module (oop goops)
+ :use-module (ice-9 try)
:use-module (ice-9 match)
:use-module (ice-9 receive)
:use-module (ice-9 and-let-star)
- :export (match syntax-error and-let* receive))
+ :export (try stack-catch match syntax-error receive and-let*))
;;;
-;;; Keywords by `:KEYWORD'
+;;; Keywords by `:KEYWORD
;;;
(read-set! keywords 'prefix)
@@ -41,9 +41,9 @@
;; FOO.BAR -> (slot FOO 'BAR)
(define (expand-dot! x)
- (cond ((and (symbol? x) (not (eq? x '...))) (expand-symbol x))
+ (cond ((symbol? x) (expand-symbol x))
((pair? x)
- (cond ((memq (car x) '(quote quasiquote)) x)
+ (cond ((eq? (car x) 'quote) x)
(else (set-car! x (expand-dot! (car x)))
(set-cdr! x (expand-dot! (cdr x)))
x)))
@@ -57,39 +57,110 @@
(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)
+(define syntax expand-dot!)
;;;
-;;; Simplified define-class
+;;; Type
+;;;
+
+(export-syntax define-type)
+(define-macro (define-type name sig) sig)
+
+;;;
+;;; Record
+;;;
+
+(export-syntax define-record)
+(define-macro (define-record def)
+ (let ((name (car def)) (slots (cdr def)))
+ `(begin
+ (define (,name . args)
+ (vector ',name (%make-struct
+ args
+ (list ,@(map (lambda (slot)
+ (if (pair? slot)
+ `(cons ',(car slot) ,(cadr slot))
+ `',slot))
+ slots)))))
+ (define (,(symbol-append name '?) x)
+ (and (vector? x) (eq? (vector-ref x 0) ',name)))
+ ,@(do ((n 1 (1+ n))
+ (slots (cdr def) (cdr slots))
+ (ls '() (cons (let* ((slot (car slots))
+ (slot (if (pair? slot) (car slot) slot)))
+ `(define ,(string->symbol
+ (format #f "~A-~A" name n))
+ (lambda (x) (slot x ',slot))))
+ ls)))
+ ((null? slots) (reverse! ls))))))
+
+(define *unbound* "#<unbound>")
+
+(define-public (%make-struct args slots)
+ (map (lambda (slot)
+ (let* ((key (if (pair? slot) (car slot) slot))
+ (def (if (pair? slot) (cdr slot) *unbound*))
+ (val (get-key args (symbol->keyword key) def)))
+ (if (eq? val *unbound*)
+ (error "Slot unbound:" key)
+ (cons key val))))
+ slots))
+
+(define (get-key klist key def)
+ (do ((ls klist (cddr ls)))
+ ((or (null? ls) (eq? (car ls) key))
+ (if (null? ls) def (cadr ls)))))
+
+(define-public slot
+ (make-procedure-with-setter
+ (lambda (struct name)
+ (let ((data (assq name (vector-ref struct 1))))
+ (cond ((not data)
+ (error "Unknown slot:" name))
+ (else (cdr data)))))
+ (lambda (struct name val)
+ (let ((data (assq name (vector-ref struct 1))))
+ (cond ((not data)
+ (error "Unknown slot:" name))
+ (else (set-cdr! data val)))))))
+
+;;;
+;;; Variants
;;;
-;; (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)
+(export-syntax |)
+(define-macro (| . rest)
+ `(begin ,@(map %make-variant-type rest)))
+
+(define (%make-variant-type def)
+ (let ((name (car def)) (slots (cdr def)))
+ `(begin
+ (define ,def (vector ',name ,@slots))
+ (define (,(symbol-append name '?) x)
+ (and (vector? x) (eq? (vector-ref x 0) ',name)))
+ ,@(do ((n 1 (1+ n))
+ (slots slots (cdr slots))
+ (ls '() (cons `(define ,(string->symbol
+ (format #f "~A-~A" name n))
+ ,(string->symbol (format #f "%slot-~A" n)))
+ ls)))
+ ((null? slots) (reverse! ls))))))
+
+(define-public (%slot-1 x) (vector-ref x 1))
+(define-public (%slot-2 x) (vector-ref x 2))
+(define-public (%slot-3 x) (vector-ref x 3))
+(define-public (%slot-4 x) (vector-ref x 4))
+(define-public (%slot-5 x) (vector-ref x 5))
+(define-public (%slot-6 x) (vector-ref x 6))
+(define-public (%slot-7 x) (vector-ref x 7))
+(define-public (%slot-8 x) (vector-ref x 8))
+(define-public (%slot-9 x) (vector-ref x 9))
+
;;;
-;;; Other utilities
+;;; Utilities
;;;
(define-public (list-fold f d l)