mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
b6368dbbb9
* module/language/scheme/translate.scm (trans-pair): In the `set!' case, when a procedure-with-setter is passed, call `trans:pair' with an actual pair. This fixes a long-lasting bug which prevented compilation of `set!' statements with procedures-with-setter (this showed up when compiling `(system vm assemble)'). * module/system/base/compile.scm: Added `objcode->u8vector' to the `#:select' clause. * module/system/base/syntax.scm: Cosmetic changes. * module/system/vm/assemble.scm (preprocess): Removed debugging statements. * src/frames.c: Cosmetic changes. * src/frames.h (SCM_FRAME_SET_DYNAMIC_LINK): New. * src/objcodes.c: Use `scm_t_uint8' instead of `char' when relevant. * src/vm.c (vm_heapify_frames_1): Use `SCM_FRAME_SET_DYNAMIC_LINK ()'. * src/vm_loader.c: Added casts to mute GCC 4 warnings. * testsuite/run-vm-tests.scm (*scheme*): Renamed to `%scheme'. (run-test-from-file): Renamed to `compile/run-test-from-file'. (run-vm-tests): Run each test using both the VM and the interpreter; compare the results. * testsuite/t-proc-with-setter.scm: Try out `get/set'. * doc/Makefile.am (info_TEXINFOS): New. * doc/guile-vm.texi: Added index entries and indices. * doc/texinfo.tex: New file. git-archimport-id: lcourtes@laas.fr--2005-mobile/guile-vm--mobile--0.6--patch-5
168 lines
4.4 KiB
Scheme
168 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))))
|