diff options
Diffstat (limited to 'module/system/base/syntax.scm')
-rw-r--r-- | module/system/base/syntax.scm | 143 |
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) |