Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Guile VM specific syntaxes and utilities |
2 | ||
ac99cb0c | 3 | ;; Copyright (C) 2001 Free Software Foundation, Inc |
17e90c5e KN |
4 | |
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
ac99cb0c KN |
8 | ;; any later version |
9 | ;; | |
17e90c5e KN |
10 | ;; This program is distributed in the hope that it will be useful, |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
ac99cb0c KN |
13 | ;; GNU General Public License for more details |
14 | ;; | |
17e90c5e KN |
15 | ;; You should have received a copy of the GNU General Public License |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
ac99cb0c | 18 | ;; Boston, MA 02111-1307, USA |
17e90c5e KN |
19 | |
20 | ;;; Code: | |
21 | ||
22 | (define-module (system base syntax) | |
1a1a10d3 AW |
23 | #:export (%compute-initargs) |
24 | #:export-syntax (define-type define-record record-case)) | |
be4efc52 | 25 | (export-syntax |) ;; emacs doesn't like the | |
17e90c5e KN |
26 | |
27 | \f | |
17e90c5e | 28 | ;;; |
ac99cb0c KN |
29 | ;;; Type |
30 | ;;; | |
31 | ||
ac99cb0c KN |
32 | (define-macro (define-type name sig) sig) |
33 | ||
34 | ;;; | |
35 | ;;; Record | |
36 | ;;; | |
37 | ||
849cefac AW |
38 | (define (symbol-trim-both sym pred) |
39 | (string->symbol (string-trim-both (symbol->string sym) pred))) | |
40 | ||
ac99cb0c | 41 | (define-macro (define-record def) |
849cefac | 42 | (let* ((name (car def)) (slots (cdr def)) |
f540e327 AW |
43 | (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot)) |
44 | slots)) | |
7f52f9e3 | 45 | (stem (symbol-trim-both name (list->char-set '(#\< #\>))))) |
ac99cb0c | 46 | `(begin |
7f52f9e3 | 47 | (define ,name (make-record-type ,(symbol->string name) ',slot-names)) |
849cefac AW |
48 | (define ,(symbol-append 'make- stem) |
49 | (let ((slots (list ,@(map (lambda (slot) | |
50 | (if (pair? slot) | |
51 | `(cons ',(car slot) ,(cadr slot)) | |
52 | `',slot)) | |
cd702346 AW |
53 | slots))) |
54 | (constructor (record-constructor ,name))) | |
849cefac | 55 | (lambda args |
cd702346 | 56 | (apply constructor (%compute-initargs args slots))))) |
7f52f9e3 | 57 | (define ,(symbol-append stem '?) (record-predicate ,name)) |
f540e327 AW |
58 | ,@(map (lambda (sname) |
59 | `(define ,(symbol-append stem '- sname) | |
7f52f9e3 AW |
60 | (make-procedure-with-setter |
61 | (record-accessor ,name ',sname) | |
62 | (record-modifier ,name ',sname)))) | |
f540e327 AW |
63 | slot-names)))) |
64 | ||
65 | (define (%compute-initargs args slots) | |
66 | (define (finish out) | |
849cefac AW |
67 | (map (lambda (slot) |
68 | (let ((name (if (pair? slot) (car slot) slot))) | |
f540e327 AW |
69 | (cond ((assq name out) => cdr) |
70 | ((pair? slot) (cdr slot)) | |
71 | (else (error "unbound slot" args slots name))))) | |
849cefac AW |
72 | slots)) |
73 | (let lp ((in args) (positional slots) (out '())) | |
74 | (cond | |
75 | ((null? in) | |
f540e327 | 76 | (finish out)) |
849cefac AW |
77 | ((keyword? (car in)) |
78 | (let ((sym (keyword->symbol (car in)))) | |
79 | (cond | |
80 | ((and (not (memq sym slots)) | |
81 | (not (assq sym (filter pair? slots)))) | |
82 | (error "unknown slot" sym)) | |
83 | ((assq sym out) (error "slot already set" sym out)) | |
84 | (else (lp (cddr in) '() (acons sym (cadr in) out)))))) | |
85 | ((null? positional) | |
86 | (error "too many initargs" args slots)) | |
87 | (else | |
88 | (lp (cdr in) (cdr positional) | |
89 | (acons (car positional) (car in) out)))))) | |
ac99cb0c | 90 | |
be4efc52 AW |
91 | (define-macro (record-case record . clauses) |
92 | (let ((r (gensym))) | |
93 | (define (process-clause clause) | |
f540e327 AW |
94 | (if (eq? (car clause) 'else) |
95 | clause | |
96 | (let ((record-type (caar clause)) | |
97 | (slots (cdar clause)) | |
98 | (body (cdr clause))) | |
99 | `(((record-predicate ,record-type) ,r) | |
100 | (let ,(map (lambda (slot) | |
101 | (if (pair? slot) | |
102 | `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r)) | |
103 | `(,slot ((record-accessor ,record-type ',slot) ,r)))) | |
104 | slots) | |
105 | ,@body))))) | |
be4efc52 | 106 | `(let ((,r ,record)) |
f540e327 AW |
107 | (cond ,@(let ((clauses (map process-clause clauses))) |
108 | (if (assq 'else clauses) | |
109 | clauses | |
110 | (append clauses `((else (error "unhandled record" ,r)))))))))) | |
b8163042 | 111 | |
01967b69 | 112 | |
ac99cb0c | 113 | \f |
17e90c5e | 114 | ;;; |
01967b69 | 115 | ;;; Variants |
17e90c5e KN |
116 | ;;; |
117 | ||
01967b69 AW |
118 | (define-macro (| . rest) |
119 | `(begin ,@(map (lambda (def) `(define-record ,def)) rest))) |