mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
d8eeb67c89
* src/*.c: Removed calls to `scm_must_malloc', `SCM_MUST_MALLOC' and `scm_must_free'. Same for `SCM_INUMP', `SCM_INUM', `SCM_STRING_CHARS', and the likes. * module/system/base/syntax.scm: Do not import `(ice-9 match)' and do not re-export `match', do not export `syntax-error' which was not defined here. * module/system/base/compile.scm (call-with-compile-error-catch): Use the `catch' form instead of `try'. * src/instructions.c: Use `scm_from_char ()' instead of the deprecated macro `SCM_MAKINUM ()'. * src/instructions.h (scm_instruction): Made `npop' a signed char. git-archimport-id: lcourtes@laas.fr--2004-libre/guile-vm--revival--0.6--patch-2
167 lines
4.4 KiB
Scheme
167 lines
4.4 KiB
Scheme
;;; 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 (ice-9 receive)
|
||
:use-module (ice-9 and-let-star)
|
||
:export (stack-catch receive and-let*))
|
||
|
||
|
||
;;;
|
||
;;; Keywords by `:KEYWORD
|
||
;;;
|
||
|
||
(read-set! keywords 'prefix)
|
||
|
||
|
||
;;;
|
||
;;; Dot expansion
|
||
;;;
|
||
|
||
;; FOO.BAR -> (slot FOO 'BAR)
|
||
|
||
(define (expand-dot! x)
|
||
(cond ((symbol? x) (expand-symbol x))
|
||
((pair? x)
|
||
(cond ((eq? (car x) 'quote) 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)))))
|
||
|
||
(export-syntax syntax)
|
||
(define syntax expand-dot!)
|
||
|
||
|
||
;;;
|
||
;;; 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
|
||
;;;
|
||
|
||
(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))
|
||
|
||
|
||
;;;
|
||
;;; Utilities
|
||
;;;
|
||
|
||
(define-public (list-fold f d l)
|
||
(if (null? l)
|
||
d
|
||
(list-fold f (f (car l) d) (cdr l))))
|