mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-17 09:10:22 +02:00
*** empty log message ***
This commit is contained in:
Keisuke Nishida
parent
ac02b386c2
commit
ac99cb0cb1
47 changed files with 1319 additions and 854 deletions
|
|
@ -1,3 +1,5 @@
|
|||
SUBDIRS = system
|
||||
|
||||
DISTDIRS = $(srcdir)/system $(srcdir)/language $(srcdir)/guile $(srcdir)/slib
|
||||
EXCLUDES = --exclude=CVS --exclude=*.go --exclude=*~
|
||||
|
||||
|
|
|
|||
3
module/language/.cvsignore
Normal file
3
module/language/.cvsignore
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
Makefile
|
||||
Makefile.in
|
||||
*.go
|
||||
3
module/language/elisp/.cvsignore
Normal file
3
module/language/elisp/.cvsignore
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
Makefile
|
||||
Makefile.in
|
||||
*.go
|
||||
3
module/language/ghil/.cvsignore
Normal file
3
module/language/ghil/.cvsignore
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
Makefile
|
||||
Makefile.in
|
||||
*.go
|
||||
3
module/language/r5rs/.cvsignore
Normal file
3
module/language/r5rs/.cvsignore
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
Makefile
|
||||
Makefile.in
|
||||
*.go
|
||||
3
module/language/scheme/.cvsignore
Normal file
3
module/language/scheme/.cvsignore
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
Makefile
|
||||
Makefile.in
|
||||
*.go
|
||||
|
|
@ -29,7 +29,7 @@
|
|||
(define (translate x e)
|
||||
(call-with-ghil-environment (make-ghil-mod e) '()
|
||||
(lambda (env vars)
|
||||
(make-<ghil-lambda> env #f vars 0 (trans env #f x)))))
|
||||
(<ghil-lambda> env #f vars #f (trans env #f x)))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -43,28 +43,28 @@
|
|||
(cond ((pair? x)
|
||||
(let ((y (macroexpand x)))
|
||||
(if (eq? x y)
|
||||
(trans-pair e (or (location x) l) (car x) (cdr x))
|
||||
(trans e l y))))
|
||||
(trans-pair e (or (location x) l) (car x) (cdr x))
|
||||
(trans e l y))))
|
||||
((symbol? x)
|
||||
(let ((y (expand-symbol x)))
|
||||
(if (eq? x y)
|
||||
(make-<ghil-ref> e l (ghil-lookup e x))
|
||||
(trans e l y))))
|
||||
(else (make-<ghil-quote> e l x))))
|
||||
(let ((y (symbol-expand x)))
|
||||
(if (symbol? y)
|
||||
(<ghil-ref> e l (ghil-lookup e y))
|
||||
(trans e l y))))
|
||||
(else (<ghil-quote> e l x))))
|
||||
|
||||
(define (expand-symbol x)
|
||||
(define (symbol-expand 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)))))
|
||||
(let ((sym (string->symbol (substring s (1+ i)))))
|
||||
`(slot ,(loop (substring s 0 i)) (quote ,sym)))
|
||||
(string->symbol s)))))
|
||||
|
||||
(define (trans-pair e l head tail)
|
||||
(define (trans:x x) (trans e l x))
|
||||
(define (trans:pair x) (trans-pair e l (car x) (cdr x)))
|
||||
(define (trans:body body) (trans-body e l body))
|
||||
(define (make:void) (make-<ghil-void> e l))
|
||||
(define (make:void) (<ghil-void> e l))
|
||||
(define (bad-syntax)
|
||||
(syntax-error l (format #f "bad ~A" head) (cons head tail)))
|
||||
(case head
|
||||
|
|
@ -77,26 +77,26 @@
|
|||
;; (quote OBJ)
|
||||
((quote)
|
||||
(match tail
|
||||
((obj) (make-<ghil-quote> e l obj))
|
||||
((obj) (<ghil-quote> e l obj))
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (quasiquote OBJ)
|
||||
((quasiquote)
|
||||
(match tail
|
||||
((obj) (make-<ghil-quasiquote> e l (trans-quasiquote e l obj)))
|
||||
((obj) (<ghil-quasiquote> e l (trans-quasiquote e l obj)))
|
||||
(else (bad-syntax))))
|
||||
|
||||
((define define-private)
|
||||
(match tail
|
||||
;; (define NAME VAL)
|
||||
(((? symbol? name) val)
|
||||
(make-<ghil-define> e l (ghil-lookup e name) (trans:x val)))
|
||||
(<ghil-define> e l (ghil-lookup e name) (trans:x val)))
|
||||
|
||||
;; (define (NAME FORMALS...) BODY...)
|
||||
((((? symbol? name) . formals) . body)
|
||||
;; -> (define NAME (lambda FORMALS BODY...))
|
||||
(let ((val (trans:x `(lambda ,formals ,@body))))
|
||||
(make-<ghil-define> e l (ghil-lookup e name) val)))
|
||||
(<ghil-define> e l (ghil-lookup e name) val)))
|
||||
|
||||
(else (bad-syntax))))
|
||||
|
||||
|
|
@ -104,7 +104,7 @@
|
|||
(match tail
|
||||
;; (set! NAME VAL)
|
||||
(((? symbol? name) val)
|
||||
(make-<ghil-set> e l (ghil-lookup e name) (trans:x val)))
|
||||
(<ghil-set> e l (ghil-lookup e name) (trans:x val)))
|
||||
|
||||
;; (set! (NAME ARGS...) VAL)
|
||||
((((? symbol? name) . args) val)
|
||||
|
|
@ -117,22 +117,22 @@
|
|||
((if)
|
||||
(match tail
|
||||
((test then)
|
||||
(make-<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
|
||||
(<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
|
||||
((test then else)
|
||||
(make-<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
|
||||
(<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (and EXPS...)
|
||||
((and)
|
||||
(make-<ghil-and> e l (map trans:x tail)))
|
||||
(<ghil-and> e l (map trans:x tail)))
|
||||
|
||||
;; (or EXPS...)
|
||||
((or)
|
||||
(make-<ghil-or> e l (map trans:x tail)))
|
||||
(<ghil-or> e l (map trans:x tail)))
|
||||
|
||||
;; (begin EXPS...)
|
||||
((begin)
|
||||
(make-<ghil-begin> e l (map trans:x tail)))
|
||||
(<ghil-begin> e l (map trans:x tail)))
|
||||
|
||||
((let)
|
||||
(match tail
|
||||
|
|
@ -144,14 +144,14 @@
|
|||
;; (let () BODY...)
|
||||
((() body ...)
|
||||
;; NOTE: This differs from `begin'
|
||||
(make-<ghil-begin> e l (list (trans:body body))))
|
||||
(<ghil-begin> e l (list (trans:body body))))
|
||||
|
||||
;; (let ((SYM VAL) ...) BODY...)
|
||||
(((((? symbol? sym) val) ...) body ...)
|
||||
(let ((vals (map trans:x val)))
|
||||
(call-with-ghil-bindings e sym
|
||||
(lambda (vars)
|
||||
(make-<ghil-bind> e l vars vals (trans:body body))))))
|
||||
(<ghil-bind> e l vars vals (trans:body body))))))
|
||||
|
||||
(else (bad-syntax))))
|
||||
|
||||
|
|
@ -171,7 +171,7 @@
|
|||
(call-with-ghil-bindings e sym
|
||||
(lambda (vars)
|
||||
(let ((vals (map trans:x val)))
|
||||
(make-<ghil-bind> e l vars vals (trans:body body))))))
|
||||
(<ghil-bind> e l vars vals (trans:body body))))))
|
||||
(else (bad-syntax))))
|
||||
|
||||
;; (cond (CLAUSE BODY...) ...)
|
||||
|
|
@ -222,7 +222,7 @@
|
|||
(receive (syms rest) (parse-formals formals)
|
||||
(call-with-ghil-environment e syms
|
||||
(lambda (env vars)
|
||||
(make-<ghil-lambda> env l vars rest (trans-body env l body))))))
|
||||
(<ghil-lambda> env l vars rest (trans-body env l body))))))
|
||||
(else (bad-syntax))))
|
||||
|
||||
((eval-case)
|
||||
|
|
@ -240,8 +240,8 @@
|
|||
|
||||
(else
|
||||
(if (memq head scheme-primitives)
|
||||
(make-<ghil-inline> e l head (map trans:x tail))
|
||||
(make-<ghil-call> e l (trans:x head) (map trans:x tail))))))
|
||||
(<ghil-inline> e l head (map trans:x tail))
|
||||
(<ghil-call> e l (trans:x head) (map trans:x tail))))))
|
||||
|
||||
(define (trans-quasiquote e l x)
|
||||
(cond ((not (pair? x)) x)
|
||||
|
|
@ -250,8 +250,8 @@
|
|||
(match (cdr x)
|
||||
((obj)
|
||||
(if (eq? (car x) 'unquote)
|
||||
(make-<ghil-unquote> e l (trans e l obj))
|
||||
(make-<ghil-unquote-splicing> e l (trans e l obj))))
|
||||
(<ghil-unquote> e l (trans e l obj))
|
||||
(<ghil-unquote-splicing> e l (trans e l obj))))
|
||||
(else (syntax-error l (format #f "bad ~A" (car x)) x)))))
|
||||
(else (cons (trans-quasiquote e l (car x))
|
||||
(trans-quasiquote e l (cdr x))))))
|
||||
|
|
|
|||
3
module/system/.cvsignore
Normal file
3
module/system/.cvsignore
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
Makefile
|
||||
Makefile.in
|
||||
*.go
|
||||
1
module/system/Makefile.am
Normal file
1
module/system/Makefile.am
Normal file
|
|
@ -0,0 +1 @@
|
|||
SUBDIRS = vm
|
||||
|
|
@ -1 +1,3 @@
|
|||
Makefile
|
||||
Makefile.in
|
||||
*.go
|
||||
|
|
|
|||
12
module/system/base/Makefile.am
Normal file
12
module/system/base/Makefile.am
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
SOURCES = syntax.scm language.scm compile.scm
|
||||
OBJECTS = syntax.go language.go compile.go
|
||||
|
||||
vmdir = $(guiledir)/system/vm
|
||||
vm_DATA = $(SOURCES) $(OBJECTS)
|
||||
|
||||
DISTCLEANFILES = $(OBJECTS)
|
||||
MAINTAINERCLEANFILES = Makefile.in
|
||||
|
||||
SUFFIXES = .scm .go
|
||||
.scm.go:
|
||||
$(GUILEC) $<
|
||||
|
|
@ -20,10 +20,10 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system base compile)
|
||||
:use-module (oop goops)
|
||||
:use-syntax (system base syntax)
|
||||
:use-module (system base language)
|
||||
:use-module (system il compile)
|
||||
:use-module (system il glil)
|
||||
:use-module (system vm core)
|
||||
:use-module (system vm assemble)
|
||||
:use-module (ice-9 regex))
|
||||
|
|
@ -32,20 +32,18 @@
|
|||
;;; Compiler environment
|
||||
;;;
|
||||
|
||||
(define-vm-class <cenv> ()
|
||||
vm language module optimize)
|
||||
(define-record (<cenv> vm language module))
|
||||
|
||||
(define-public (make-cenv . rest)
|
||||
(apply make <cenv> rest))
|
||||
(apply <cenv> rest))
|
||||
|
||||
(define-public (syntax-error loc msg exp)
|
||||
(throw 'syntax-error loc msg exp))
|
||||
|
||||
(define-public (call-with-compile-error-catch thunk)
|
||||
(catch 'syntax-error
|
||||
thunk
|
||||
(lambda (key loc msg exp)
|
||||
(format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
|
||||
(try (thunk)
|
||||
((syntax-error loc msg exp)
|
||||
(format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -65,7 +63,9 @@
|
|||
(let* ((source (read-file-in file scheme))
|
||||
(objcode (apply compile-in source (current-module)
|
||||
scheme opts)))
|
||||
(uniform-array-write (objcode->string objcode) port))))
|
||||
(if (memq :c opts)
|
||||
(pprint-glil objcode port)
|
||||
(uniform-array-write (objcode->string objcode) port)))))
|
||||
(format #t "Wrote ~A\n" comp))))
|
||||
(lambda (key . args)
|
||||
(format #t "ERROR: During compiling ~A:\n" file)
|
||||
|
|
|
|||
|
|
@ -20,7 +20,6 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system base language)
|
||||
:use-module (oop goops)
|
||||
:use-syntax (system base syntax)
|
||||
:export (define-language lookup-language))
|
||||
|
||||
|
|
@ -29,21 +28,15 @@
|
|||
;;; Language class
|
||||
;;;
|
||||
|
||||
(define-vm-class <language> ()
|
||||
name title version environment
|
||||
reader printer read-file
|
||||
(expander (lambda (x e) x))
|
||||
(translator (lambda (x e) x))
|
||||
(evaluator #f)
|
||||
)
|
||||
|
||||
(define-method (write (lang <language>) port)
|
||||
(display "#<language " port)
|
||||
(display lang.name port)
|
||||
(display ">"))
|
||||
(define-record (<language> name title version reader printer read-file
|
||||
(expander (lambda (x e) x))
|
||||
(translator (lambda (x e) x))
|
||||
(evaluator #f)
|
||||
(environment #f)
|
||||
))
|
||||
|
||||
(define-macro (define-language name . spec)
|
||||
`(define ,name (,make ,<language> :name ',name ,@spec)))
|
||||
`(define ,name (,<language> :name ',name ,@spec)))
|
||||
|
||||
(define (lookup-language name)
|
||||
(let ((m (resolve-module `(language ,name spec))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;;;
|
||||
|
||||
;; (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-type)
|
||||
(define-macro (define-type name sig) sig)
|
||||
|
||||
;;;
|
||||
;;; Other utilities
|
||||
;;; 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)
|
||||
|
|
|
|||
|
|
@ -1 +1,3 @@
|
|||
Makefile
|
||||
Makefile.in
|
||||
*.go
|
||||
|
|
|
|||
12
module/system/il/Makefile.am
Normal file
12
module/system/il/Makefile.am
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
SOURCES = glil.scm ghil.scm macros.scm compile.scm
|
||||
OBJECTS = glil.go ghil.go macros.go compile.go
|
||||
|
||||
vmdir = $(guiledir)/system/il
|
||||
vm_DATA = $(SOURCES) $(OBJECTS)
|
||||
|
||||
DISTCLEANFILES = $(OBJECTS)
|
||||
MAINTAINERCLEANFILES = Makefile.in
|
||||
|
||||
SUFFIXES = .scm .go
|
||||
.scm.go:
|
||||
$(GUILEC) $<
|
||||
|
|
@ -20,7 +20,6 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system il compile)
|
||||
:use-module (oop goops)
|
||||
:use-syntax (system base syntax)
|
||||
:use-module (system il glil)
|
||||
:use-module (system il ghil)
|
||||
|
|
@ -40,22 +39,22 @@
|
|||
(define (optimize x)
|
||||
(match x
|
||||
(($ <ghil-set> env var val)
|
||||
(make-<ghil-set> env var (optimize val)))
|
||||
(<ghil-set> env var (optimize val)))
|
||||
|
||||
(($ <ghil-if> test then else)
|
||||
(make-<ghil-if> (optimize test) (optimize then) (optimize else)))
|
||||
(<ghil-if> (optimize test) (optimize then) (optimize else)))
|
||||
|
||||
(($ <ghil-begin> exps)
|
||||
(make-<ghil-begin> (map optimize exps)))
|
||||
(<ghil-begin> (map optimize exps)))
|
||||
|
||||
(($ <ghil-bind> env vars vals body)
|
||||
(make-<ghil-bind> env vars (map optimize vals) (optimize body)))
|
||||
(<ghil-bind> env vars (map optimize vals) (optimize body)))
|
||||
|
||||
(($ <ghil-lambda> env vars rest body)
|
||||
(make-<ghil-lambda> env vars rest (optimize body)))
|
||||
(<ghil-lambda> env vars rest (optimize body)))
|
||||
|
||||
(($ <ghil-inst> inst args)
|
||||
(make-<ghil-inst> inst (map optimize args)))
|
||||
(<ghil-inst> inst (map optimize args)))
|
||||
|
||||
(($ <ghil-call> env proc args)
|
||||
(match proc
|
||||
|
|
@ -67,9 +66,9 @@
|
|||
(set! v.env env)
|
||||
(ghil-env-add! env v))
|
||||
lambda-env.variables)
|
||||
(optimize (make-<ghil-bind> env vars args body)))
|
||||
(optimize (<ghil-bind> env vars args body)))
|
||||
(else
|
||||
(make-<ghil-call> env (optimize proc) (map optimize args)))))
|
||||
(<ghil-call> env (optimize proc) (map optimize args)))))
|
||||
(else x)))
|
||||
|
||||
|
||||
|
|
@ -77,25 +76,25 @@
|
|||
;;; Stage 3: Code generation
|
||||
;;;
|
||||
|
||||
(define *ia-void* (make-<glil-void>))
|
||||
(define *ia-drop* (make-<glil-call> 'drop 0))
|
||||
(define *ia-return* (make-<glil-call> 'return 0))
|
||||
(define *ia-void* (<glil-void>))
|
||||
(define *ia-drop* (<glil-call> 'drop 0))
|
||||
(define *ia-return* (<glil-call> 'return 0))
|
||||
|
||||
(define (make-label) (gensym ":L"))
|
||||
|
||||
(define (make-glil-var op env var)
|
||||
(case var.kind
|
||||
((argument)
|
||||
(make-<glil-argument> op var.index))
|
||||
(<glil-argument> op var.index))
|
||||
((local)
|
||||
(make-<glil-local> op var.index))
|
||||
(<glil-local> op var.index))
|
||||
((external)
|
||||
(do ((depth 0 (1+ depth))
|
||||
(e env e.parent))
|
||||
((eq? e var.env)
|
||||
(make-<glil-external> op depth var.index))))
|
||||
(<glil-external> op depth var.index))))
|
||||
((module)
|
||||
(make-<glil-module> op var.env var.name))
|
||||
(<glil-module> op var.env var.name))
|
||||
(else (error "Unknown kind of variable:" var))))
|
||||
|
||||
(define (codegen ghil)
|
||||
|
|
@ -104,12 +103,13 @@
|
|||
(set! stack (cons code stack)))
|
||||
(define (comp tree tail drop)
|
||||
(define (push-label! label)
|
||||
(push-code! (make-<glil-label> label)))
|
||||
(push-code! (<glil-label> label)))
|
||||
(define (push-branch! inst label)
|
||||
(push-code! (make-<glil-branch> inst label)))
|
||||
(define (push-call! inst args)
|
||||
(push-code! (<glil-branch> inst label)))
|
||||
(define (push-call! loc inst args)
|
||||
(for-each comp-push args)
|
||||
(push-code! (make-<glil-call> inst (length args))))
|
||||
(push-code! (<glil-call> inst (length args)))
|
||||
(push-code! (<glil-source> loc)))
|
||||
;; possible tail position
|
||||
(define (comp-tail tree) (comp tree tail drop))
|
||||
;; push the result
|
||||
|
|
@ -131,7 +131,7 @@
|
|||
(return-code! *ia-void*))
|
||||
;; return object if necessary
|
||||
(define (return-object! obj)
|
||||
(return-code! (make-<glil-const> obj)))
|
||||
(return-code! (<glil-const> obj)))
|
||||
;;
|
||||
;; dispatch
|
||||
(match tree
|
||||
|
|
@ -145,28 +145,32 @@
|
|||
(let loop ((x exp))
|
||||
(match x
|
||||
((? list? ls)
|
||||
(push-call! 'mark '())
|
||||
(push-call! #f 'mark '())
|
||||
(for-each loop ls)
|
||||
(push-call! 'list-mark '()))
|
||||
(push-call! #f 'list-mark '()))
|
||||
((? pair? pp)
|
||||
(loop (car pp))
|
||||
(loop (cdr pp))
|
||||
(push-code! (make-<glil-call> 'cons 2)))
|
||||
(push-code! (<glil-call> 'cons 2)))
|
||||
(($ <ghil-unquote> env loc exp)
|
||||
(comp-push exp))
|
||||
(($ <ghil-unquote-splicing> env loc exp)
|
||||
(comp-push exp)
|
||||
(push-call! 'list-break '()))
|
||||
(push-call! #f 'list-break '()))
|
||||
(else
|
||||
(push-code! (make-<glil-const> x)))))
|
||||
(push-code! (<glil-const> x)))))
|
||||
(maybe-drop)
|
||||
(maybe-return))
|
||||
|
||||
(($ <ghil-ref> env loc var)
|
||||
(return-code! (make-glil-var 'ref env var)))
|
||||
|
||||
((or ($ <ghil-set> env loc var val)
|
||||
($ <ghil-define> env loc var val))
|
||||
(($ <ghil-set> env loc var val)
|
||||
(comp-push val)
|
||||
(push-code! (make-glil-var 'set env var))
|
||||
(return-void!))
|
||||
|
||||
(($ <ghil-define> env loc var val)
|
||||
(comp-push val)
|
||||
(push-code! (make-glil-var 'set env var))
|
||||
(return-void!))
|
||||
|
|
@ -228,9 +232,9 @@
|
|||
(maybe-drop)
|
||||
(maybe-return))
|
||||
(comp-push (car exps))
|
||||
(push-call! 'dup '())
|
||||
(push-call! #f 'dup '())
|
||||
(push-branch! 'br-if L1)
|
||||
(push-call! 'drop '())))))
|
||||
(push-call! #f 'drop '())))))
|
||||
|
||||
(($ <ghil-begin> env loc exps)
|
||||
;; EXPS...
|
||||
|
|
@ -249,7 +253,10 @@
|
|||
(for-each comp-push vals)
|
||||
(for-each (lambda (var) (push-code! (make-glil-var 'set env var)))
|
||||
(reverse vars))
|
||||
(comp-tail body))
|
||||
(let ((vars (map (lambda (v) (list v.name v.kind v.index)) vars)))
|
||||
(if (not (null? vars)) (push-code! (<glil-bind> vars))))
|
||||
(comp-tail body)
|
||||
(push-code! (<glil-unbind>)))
|
||||
|
||||
(($ <ghil-lambda> env loc vars rest body)
|
||||
(return-code! (codegen tree)))
|
||||
|
|
@ -257,7 +264,7 @@
|
|||
(($ <ghil-inline> env loc inst args)
|
||||
;; ARGS...
|
||||
;; (INST NARGS)
|
||||
(push-call! inst args)
|
||||
(push-call! loc inst args)
|
||||
(maybe-drop)
|
||||
(maybe-return))
|
||||
|
||||
|
|
@ -266,7 +273,7 @@
|
|||
;; ARGS...
|
||||
;; ([tail-]call NARGS)
|
||||
(comp-push proc)
|
||||
(push-call! (if tail 'tail-call 'call) args)
|
||||
(push-call! loc (if tail 'tail-call 'call) args)
|
||||
(maybe-drop))))
|
||||
;;
|
||||
;; main
|
||||
|
|
@ -279,19 +286,25 @@
|
|||
(finalize-index! args)
|
||||
(finalize-index! locs)
|
||||
(finalize-index! exts)
|
||||
;; meta bindings
|
||||
(let ((vars (map (lambda (v) (list v.name v.kind v.index)) args)))
|
||||
(if (not (null? vars)) (push-code! (<glil-bind> vars))))
|
||||
;; export arguments
|
||||
(do ((n 0 (1+ n))
|
||||
(l args (cdr l)))
|
||||
((null? l))
|
||||
(let ((v (car l)))
|
||||
(if (eq? v.kind 'external)
|
||||
(begin (push-code! (make-<glil-argument> 'ref n))
|
||||
(push-code! (make-<glil-external> 'set 0 v.index))))))
|
||||
(cond ((eq? v.kind 'external)
|
||||
(push-code! (<glil-argument> 'ref n))
|
||||
(push-code! (<glil-external> 'set 0 v.index))))))
|
||||
;; compile body
|
||||
(comp body #t #f)
|
||||
;; create GLIL
|
||||
(make-<glil-asm> (length args) (if rest 1 0) (length locs)
|
||||
(length exts) (reverse! stack)))))))
|
||||
(let ((vars (<glil-vars> :nargs (length args)
|
||||
:nrest (if rest 1 0)
|
||||
:nlocs (length locs)
|
||||
:nexts (length exts))))
|
||||
(<glil-asm> vars (reverse! stack))))))))
|
||||
|
||||
(define (finalize-index! list)
|
||||
(do ((n 0 (1+ n))
|
||||
|
|
|
|||
|
|
@ -20,42 +20,38 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system il ghil)
|
||||
:use-module (oop goops)
|
||||
:use-syntax (system base syntax)
|
||||
:use-module (ice-9 match)
|
||||
:use-module (ice-9 regex)
|
||||
:export
|
||||
(parse-ghil
|
||||
ghil-lookup ghil-primitive?
|
||||
make-<ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2
|
||||
make-<ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
|
||||
make-<ghil-quasiquote> <ghil-quasiquote>?
|
||||
(
|
||||
<ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2
|
||||
<ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
|
||||
<ghil-quasiquote> <ghil-quasiquote>?
|
||||
<ghil-quasiquote>-1 <ghil-quasiquote>-2 <ghil-quasiquote>-3
|
||||
make-<ghil-unquote> <ghil-unquote>?
|
||||
<ghil-unquote> <ghil-unquote>?
|
||||
<ghil-unquote>-1 <ghil-unquote>-2 <ghil-unquote>-3
|
||||
make-<ghil-unquote-splicing> <ghil-unquote-splicing>?
|
||||
<ghil-unquote-splicing> <ghil-unquote-splicing>?
|
||||
<ghil-unquote-splicing>-1 <ghil-unquote-splicing>-2
|
||||
<ghil-unquote-splicing>-3
|
||||
|
||||
make-<ghil-ref> <ghil-ref>?
|
||||
<ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
|
||||
make-<ghil-set> <ghil-set>?
|
||||
<ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4
|
||||
make-<ghil-define> <ghil-define>?
|
||||
<ghil-ref> <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
|
||||
<ghil-set> <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4
|
||||
<ghil-define> <ghil-define>?
|
||||
<ghil-define>-1 <ghil-define>-2 <ghil-define>-3 <ghil-define>-4
|
||||
|
||||
make-<ghil-if> <ghil-if>?
|
||||
<ghil-if> <ghil-if>?
|
||||
<ghil-if>-1 <ghil-if>-2 <ghil-if>-3 <ghil-if>-4 <ghil-if>-5
|
||||
make-<ghil-and> <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3
|
||||
make-<ghil-or> <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3
|
||||
make-<ghil-begin> <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3
|
||||
make-<ghil-bind> <ghil-bind>?
|
||||
<ghil-and> <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3
|
||||
<ghil-or> <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3
|
||||
<ghil-begin> <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3
|
||||
<ghil-bind> <ghil-bind>?
|
||||
<ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4 <ghil-bind>-5
|
||||
make-<ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
|
||||
<ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
|
||||
<ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5
|
||||
make-<ghil-inline> <ghil-inline>?
|
||||
<ghil-inline> <ghil-inline>?
|
||||
<ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4
|
||||
make-<ghil-call> <ghil-call>?
|
||||
<ghil-call> <ghil-call>?
|
||||
<ghil-call>-1 <ghil-call>-2 <ghil-call>-3 <ghil-call>-4
|
||||
))
|
||||
|
||||
|
|
@ -64,27 +60,30 @@
|
|||
;;; Parse tree
|
||||
;;;
|
||||
|
||||
(define-structure (<ghil-void> env loc))
|
||||
(define-structure (<ghil-quote> env loc obj))
|
||||
(define-structure (<ghil-quasiquote> env loc exp))
|
||||
(define-structure (<ghil-unquote> env loc exp))
|
||||
(define-structure (<ghil-unquote-splicing> env loc exp))
|
||||
(define-type <ghil>
|
||||
(|
|
||||
;; Objects
|
||||
(<ghil-void> env loc)
|
||||
(<ghil-quote> env loc obj)
|
||||
(<ghil-quasiquote> env loc exp)
|
||||
(<ghil-unquote> env loc exp)
|
||||
(<ghil-unquote-splicing> env loc exp)
|
||||
;; Variables
|
||||
(<ghil-ref> env loc var)
|
||||
(<ghil-set> env loc var val)
|
||||
(<ghil-define> env loc var val)
|
||||
;; Controls
|
||||
(<ghil-if> env loc test then else)
|
||||
(<ghil-and> env loc exps)
|
||||
(<ghil-or> env loc exps)
|
||||
(<ghil-begin> env loc exps)
|
||||
(<ghil-bind> env loc vars vals body)
|
||||
(<ghil-lambda> env loc vars rest body)
|
||||
(<ghil-call> env loc proc args)
|
||||
(<ghil-inline> env loc inline args)))
|
||||
|
||||
(define-structure (<ghil-ref> env loc var))
|
||||
(define-structure (<ghil-set> env loc var val))
|
||||
(define-structure (<ghil-define> env loc var val))
|
||||
|
||||
(define-structure (<ghil-if> env loc test then else))
|
||||
(define-structure (<ghil-and> env loc exps))
|
||||
(define-structure (<ghil-or> env loc exps))
|
||||
(define-structure (<ghil-begin> env loc exps))
|
||||
(define-structure (<ghil-bind> env loc vars vals body))
|
||||
(define-structure (<ghil-lambda> env loc vars rest body))
|
||||
(define-structure (<ghil-call> env loc proc args))
|
||||
(define-structure (<ghil-inline> env loc inline args))
|
||||
|
||||
(define-public (ghil-env ghil) (vector-ref ghil 1))
|
||||
(define-public (ghil-loc ghil) (vector-ref ghil 2))
|
||||
(define-public ghil-env %slot-1)
|
||||
(define-public ghil-loc %slot-2)
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -96,7 +95,7 @@
|
|||
|
||||
(define *macro-module* (resolve-module '(system il macros)))
|
||||
|
||||
(define (ghil-primitive-macro? x)
|
||||
(define-public (ghil-primitive-macro? x)
|
||||
(and (module-defined? *macro-module* x)
|
||||
(procedure? (module-ref *macro-module* x))))
|
||||
|
||||
|
|
@ -112,78 +111,59 @@
|
|||
;;; Variables
|
||||
;;;
|
||||
|
||||
(define-vm-class <ghil-var> ()
|
||||
env name kind type value index)
|
||||
(define-record (<ghil-var> env name kind (type #f) (value #f) (index #f)))
|
||||
|
||||
(define-public (make-ghil-var env name kind)
|
||||
(make <ghil-var> :env env :name name :kind kind))
|
||||
|
||||
(define-method (write (var <ghil-var>) port)
|
||||
(display "#<ghil:var " port)
|
||||
(display var.name port)
|
||||
(display ">" port))
|
||||
(<ghil-var> :env env :name name :kind kind))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Modules
|
||||
;;;
|
||||
|
||||
(define-vm-class <ghil-mod> ()
|
||||
(module)
|
||||
(table '())
|
||||
(imports '()))
|
||||
(define-record (<ghil-mod> module (table '()) (imports '())))
|
||||
|
||||
(define-public (make-ghil-mod module)
|
||||
(make <ghil-mod> :module module))
|
||||
|
||||
(define-method (write (mod <ghil-mod>) port)
|
||||
(display "#<ghil:mod " port)
|
||||
(display (module-name mod.module) port)
|
||||
(display ">" port))
|
||||
|
||||
(define-method (ghil-lookup (mod <ghil-mod>) (sym <symbol>))
|
||||
(or (assq-ref mod.table sym)
|
||||
;; (let ((var (make-ghil-var (env-identifier mod.module) sym 'module)))
|
||||
(let ((var (make-ghil-var #f sym 'module)))
|
||||
(set! mod.table (acons sym var mod.table))
|
||||
var)))
|
||||
(<ghil-mod> :module module))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Environments
|
||||
;;;
|
||||
|
||||
(define-vm-class <ghil-env> ()
|
||||
(mod)
|
||||
(parent #f)
|
||||
(table '())
|
||||
(variables '()))
|
||||
(define-record (<ghil-env> mod parent (table '()) (variables '())))
|
||||
|
||||
(export make-ghil-env)
|
||||
(define-method (make-ghil-env (m <ghil-mod>))
|
||||
(make <ghil-env> :mod m :parent m))
|
||||
|
||||
(define-method (make-ghil-env (e <ghil-env>))
|
||||
(make <ghil-env> :mod e.mod :parent e))
|
||||
(define-public (make-ghil-env e)
|
||||
(match e
|
||||
(($ <ghil-mod>) (<ghil-env> :mod e :parent e))
|
||||
(($ <ghil-env> m) (<ghil-env> :mod m :parent e))))
|
||||
|
||||
(define (ghil-env-toplevel? e)
|
||||
(eq? e.mod e.parent))
|
||||
|
||||
(define-method (ghil-env-ref (env <ghil-env>) (sym <symbol>))
|
||||
(define (ghil-env-ref env sym)
|
||||
(assq-ref env.table sym))
|
||||
|
||||
(export ghil-env-add!)
|
||||
(define-method (ghil-env-add! (env <ghil-env>) (var <ghil-var>))
|
||||
(define-public (ghil-env-add! env var)
|
||||
(set! env.table (acons var.name var env.table))
|
||||
(set! env.variables (cons var env.variables)))
|
||||
|
||||
(define-method (ghil-env-remove! (env <ghil-env>) (var <ghil-var>))
|
||||
(define (ghil-env-remove! env var)
|
||||
(set! env.table (assq-remove! env.table var.name)))
|
||||
|
||||
(define-method (ghil-lookup (env <ghil-env>) (sym <symbol>))
|
||||
|
||||
;;;
|
||||
;;; Public interface
|
||||
;;;
|
||||
|
||||
(define-public (ghil-lookup env sym)
|
||||
(or (ghil-env-ref env sym)
|
||||
(let loop ((e env.parent))
|
||||
(cond ((is-a? e <ghil-mod>) (ghil-lookup e sym))
|
||||
(cond ((<ghil-mod>? e)
|
||||
(or (assq-ref e.table sym)
|
||||
(let ((var (make-ghil-var #f sym 'module)))
|
||||
(set! e.table (acons sym var e.table))
|
||||
var)))
|
||||
((ghil-env-ref e sym) =>
|
||||
(lambda (var) (set! var.kind 'external) var))
|
||||
(else (loop e.parent))))))
|
||||
|
|
@ -210,156 +190,156 @@
|
|||
;;; Parser
|
||||
;;;
|
||||
|
||||
(define (parse-ghil x e)
|
||||
(parse `(@lambda () ,x) (make-ghil-mod e)))
|
||||
|
||||
(define (parse x e)
|
||||
(cond ((pair? x) (parse-pair x e))
|
||||
((symbol? x)
|
||||
(let ((str (symbol->string x)))
|
||||
(case (string-ref str 0)
|
||||
((#\@) (error "Invalid use of IL primitive" x))
|
||||
((#\:) (let ((sym (string->symbol (substring str 1))))
|
||||
(make-<ghil-quote> (symbol->keyword sym))))
|
||||
(else (make-<ghil-ref> e (ghil-lookup e x))))))
|
||||
(else (make-<ghil-quote> x))))
|
||||
|
||||
(define (map-parse x e)
|
||||
(map (lambda (x) (parse x e)) x))
|
||||
|
||||
(define (parse-pair x e)
|
||||
(let ((head (car x)) (tail (cdr x)))
|
||||
(if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@))
|
||||
(if (ghil-primitive-macro? head)
|
||||
(parse (apply (ghil-macro-expander head) tail) e)
|
||||
(parse-primitive head tail e))
|
||||
(make-<ghil-call> e (parse head e) (map-parse tail e)))))
|
||||
|
||||
(define (parse-primitive prim args e)
|
||||
(case prim
|
||||
;; (@ IDENTIFIER)
|
||||
((@)
|
||||
(match args
|
||||
(()
|
||||
(make-<ghil-ref> e (make-ghil-var '@ '@ 'module)))
|
||||
((identifier)
|
||||
(receive (module name) (identifier-split identifier)
|
||||
(make-<ghil-ref> e (make-ghil-var module name 'module))))))
|
||||
|
||||
;; (@@ OP ARGS...)
|
||||
((@@)
|
||||
(match args
|
||||
((op . args)
|
||||
(make-<ghil-inline> op (map-parse args e)))))
|
||||
|
||||
;; (@void)
|
||||
((@void)
|
||||
(match args
|
||||
(() (make-<ghil-void>))))
|
||||
|
||||
;; (@quote OBJ)
|
||||
((@quote)
|
||||
(match args
|
||||
((obj)
|
||||
(make-<ghil-quote> obj))))
|
||||
|
||||
;; (@define NAME VAL)
|
||||
((@define)
|
||||
(match args
|
||||
((name val)
|
||||
(let ((v (ghil-lookup e name)))
|
||||
(make-<ghil-set> e v (parse val e))))))
|
||||
|
||||
;; (@set! NAME VAL)
|
||||
((@set!)
|
||||
(match args
|
||||
((name val)
|
||||
(let ((v (ghil-lookup e name)))
|
||||
(make-<ghil-set> e v (parse val e))))))
|
||||
|
||||
;; (@if TEST THEN [ELSE])
|
||||
((@if)
|
||||
(match args
|
||||
((test then)
|
||||
(make-<ghil-if> (parse test e) (parse then e) (make-<ghil-void>)))
|
||||
((test then else)
|
||||
(make-<ghil-if> (parse test e) (parse then e) (parse else e)))))
|
||||
|
||||
;; (@begin BODY...)
|
||||
((@begin)
|
||||
(parse-body args e))
|
||||
|
||||
;; (@let ((SYM INIT)...) BODY...)
|
||||
((@let)
|
||||
(match args
|
||||
((((sym init) ...) body ...)
|
||||
(let* ((vals (map-parse init e))
|
||||
(vars (map (lambda (s)
|
||||
(let ((v (make-ghil-var e s 'local)))
|
||||
(ghil-env-add! e v) v))
|
||||
sym))
|
||||
(body (parse-body body e)))
|
||||
(for-each (lambda (v) (ghil-env-remove! e v)) vars)
|
||||
(make-<ghil-bind> e vars vals body)))))
|
||||
|
||||
;; (@letrec ((SYM INIT)...) BODY...)
|
||||
((@letrec)
|
||||
(match args
|
||||
((((sym init) ...) body ...)
|
||||
(let* ((vars (map (lambda (s)
|
||||
(let ((v (make-ghil-var e s 'local)))
|
||||
(ghil-env-add! e v) v))
|
||||
sym))
|
||||
(vals (map-parse init e))
|
||||
(body (parse-body body e)))
|
||||
(for-each (lambda (v) (ghil-env-remove! e v)) vars)
|
||||
(make-<ghil-bind> e vars vals body)))))
|
||||
|
||||
;; (@lambda FORMALS BODY...)
|
||||
((@lambda)
|
||||
(match args
|
||||
((formals . body)
|
||||
(receive (syms rest) (parse-formals formals)
|
||||
(let* ((e (make-ghil-env e))
|
||||
(vars (map (lambda (s)
|
||||
(let ((v (make-ghil-var e s 'argument)))
|
||||
(ghil-env-add! e v) v))
|
||||
syms)))
|
||||
(make-<ghil-lambda> e vars rest (parse-body body e)))))))
|
||||
|
||||
;; (@eval-case CLAUSE...)
|
||||
((@eval-case)
|
||||
(let loop ((clauses args))
|
||||
(cond ((null? clauses) (make-<ghil-void>))
|
||||
((or (eq? (caar clauses) '@else)
|
||||
(and (memq 'load-toplevel (caar clauses))
|
||||
(ghil-env-toplevel? e)))
|
||||
(parse-body (cdar clauses) e))
|
||||
(else
|
||||
(loop (cdr clauses))))))
|
||||
|
||||
(else (error "Unknown primitive:" prim))))
|
||||
|
||||
(define (parse-body x e)
|
||||
(make-<ghil-begin> (map-parse x e)))
|
||||
|
||||
(define (parse-formals formals)
|
||||
(cond
|
||||
;; (@lambda x ...)
|
||||
((symbol? formals) (values (list formals) #t))
|
||||
;; (@lambda (x y z) ...)
|
||||
((list? formals) (values formals #f))
|
||||
;; (@lambda (x y . z) ...)
|
||||
((pair? formals)
|
||||
(let loop ((l formals) (v '()))
|
||||
(if (pair? l)
|
||||
(loop (cdr l) (cons (car l) v))
|
||||
(values (reverse! (cons l v)) #t))))
|
||||
(else (error "Invalid formals:" formals))))
|
||||
|
||||
(define (identifier-split identifier)
|
||||
(let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
|
||||
(if m
|
||||
(values (string->symbol (match:prefix m))
|
||||
(string->symbol (match:substring m 1)))
|
||||
(values #f identifier))))
|
||||
;;; (define-public (parse-ghil x e)
|
||||
;;; (parse `(@lambda () ,x) (make-ghil-mod e)))
|
||||
;;;
|
||||
;;; (define (parse x e)
|
||||
;;; (cond ((pair? x) (parse-pair x e))
|
||||
;;; ((symbol? x)
|
||||
;;; (let ((str (symbol->string x)))
|
||||
;;; (case (string-ref str 0)
|
||||
;;; ((#\@) (error "Invalid use of IL primitive" x))
|
||||
;;; ((#\:) (let ((sym (string->symbol (substring str 1))))
|
||||
;;; (<ghil-quote> (symbol->keyword sym))))
|
||||
;;; (else (<ghil-ref> e (ghil-lookup e x))))))
|
||||
;;; (else (<ghil-quote> x))))
|
||||
;;;
|
||||
;;; (define (map-parse x e)
|
||||
;;; (map (lambda (x) (parse x e)) x))
|
||||
;;;
|
||||
;;; (define (parse-pair x e)
|
||||
;;; (let ((head (car x)) (tail (cdr x)))
|
||||
;;; (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@))
|
||||
;;; (if (ghil-primitive-macro? head)
|
||||
;;; (parse (apply (ghil-macro-expander head) tail) e)
|
||||
;;; (parse-primitive head tail e))
|
||||
;;; (<ghil-call> e (parse head e) (map-parse tail e)))))
|
||||
;;;
|
||||
;;; (define (parse-primitive prim args e)
|
||||
;;; (case prim
|
||||
;;; ;; (@ IDENTIFIER)
|
||||
;;; ((@)
|
||||
;;; (match args
|
||||
;;; (()
|
||||
;;; (<ghil-ref> e (make-ghil-var '@ '@ 'module)))
|
||||
;;; ((identifier)
|
||||
;;; (receive (module name) (identifier-split identifier)
|
||||
;;; (<ghil-ref> e (make-ghil-var module name 'module))))))
|
||||
;;;
|
||||
;;; ;; (@@ OP ARGS...)
|
||||
;;; ((@@)
|
||||
;;; (match args
|
||||
;;; ((op . args)
|
||||
;;; (<ghil-inline> op (map-parse args e)))))
|
||||
;;;
|
||||
;;; ;; (@void)
|
||||
;;; ((@void)
|
||||
;;; (match args
|
||||
;;; (() (<ghil-void>))))
|
||||
;;;
|
||||
;;; ;; (@quote OBJ)
|
||||
;;; ((@quote)
|
||||
;;; (match args
|
||||
;;; ((obj)
|
||||
;;; (<ghil-quote> obj))))
|
||||
;;;
|
||||
;;; ;; (@define NAME VAL)
|
||||
;;; ((@define)
|
||||
;;; (match args
|
||||
;;; ((name val)
|
||||
;;; (let ((v (ghil-lookup e name)))
|
||||
;;; (<ghil-set> e v (parse val e))))))
|
||||
;;;
|
||||
;;; ;; (@set! NAME VAL)
|
||||
;;; ((@set!)
|
||||
;;; (match args
|
||||
;;; ((name val)
|
||||
;;; (let ((v (ghil-lookup e name)))
|
||||
;;; (<ghil-set> e v (parse val e))))))
|
||||
;;;
|
||||
;;; ;; (@if TEST THEN [ELSE])
|
||||
;;; ((@if)
|
||||
;;; (match args
|
||||
;;; ((test then)
|
||||
;;; (<ghil-if> (parse test e) (parse then e) (<ghil-void>)))
|
||||
;;; ((test then else)
|
||||
;;; (<ghil-if> (parse test e) (parse then e) (parse else e)))))
|
||||
;;;
|
||||
;;; ;; (@begin BODY...)
|
||||
;;; ((@begin)
|
||||
;;; (parse-body args e))
|
||||
;;;
|
||||
;;; ;; (@let ((SYM INIT)...) BODY...)
|
||||
;;; ((@let)
|
||||
;;; (match args
|
||||
;;; ((((sym init) ...) body ...)
|
||||
;;; (let* ((vals (map-parse init e))
|
||||
;;; (vars (map (lambda (s)
|
||||
;;; (let ((v (make-ghil-var e s 'local)))
|
||||
;;; (ghil-env-add! e v) v))
|
||||
;;; sym))
|
||||
;;; (body (parse-body body e)))
|
||||
;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars)
|
||||
;;; (<ghil-bind> e vars vals body)))))
|
||||
;;;
|
||||
;;; ;; (@letrec ((SYM INIT)...) BODY...)
|
||||
;;; ((@letrec)
|
||||
;;; (match args
|
||||
;;; ((((sym init) ...) body ...)
|
||||
;;; (let* ((vars (map (lambda (s)
|
||||
;;; (let ((v (make-ghil-var e s 'local)))
|
||||
;;; (ghil-env-add! e v) v))
|
||||
;;; sym))
|
||||
;;; (vals (map-parse init e))
|
||||
;;; (body (parse-body body e)))
|
||||
;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars)
|
||||
;;; (<ghil-bind> e vars vals body)))))
|
||||
;;;
|
||||
;;; ;; (@lambda FORMALS BODY...)
|
||||
;;; ((@lambda)
|
||||
;;; (match args
|
||||
;;; ((formals . body)
|
||||
;;; (receive (syms rest) (parse-formals formals)
|
||||
;;; (let* ((e (make-ghil-env e))
|
||||
;;; (vars (map (lambda (s)
|
||||
;;; (let ((v (make-ghil-var e s 'argument)))
|
||||
;;; (ghil-env-add! e v) v))
|
||||
;;; syms)))
|
||||
;;; (<ghil-lambda> e vars rest (parse-body body e)))))))
|
||||
;;;
|
||||
;;; ;; (@eval-case CLAUSE...)
|
||||
;;; ((@eval-case)
|
||||
;;; (let loop ((clauses args))
|
||||
;;; (cond ((null? clauses) (<ghil-void>))
|
||||
;;; ((or (eq? (caar clauses) '@else)
|
||||
;;; (and (memq 'load-toplevel (caar clauses))
|
||||
;;; (ghil-env-toplevel? e)))
|
||||
;;; (parse-body (cdar clauses) e))
|
||||
;;; (else
|
||||
;;; (loop (cdr clauses))))))
|
||||
;;;
|
||||
;;; (else (error "Unknown primitive:" prim))))
|
||||
;;;
|
||||
;;; (define (parse-body x e)
|
||||
;;; (<ghil-begin> (map-parse x e)))
|
||||
;;;
|
||||
;;; (define (parse-formals formals)
|
||||
;;; (cond
|
||||
;;; ;; (@lambda x ...)
|
||||
;;; ((symbol? formals) (values (list formals) #t))
|
||||
;;; ;; (@lambda (x y z) ...)
|
||||
;;; ((list? formals) (values formals #f))
|
||||
;;; ;; (@lambda (x y . z) ...)
|
||||
;;; ((pair? formals)
|
||||
;;; (let loop ((l formals) (v '()))
|
||||
;;; (if (pair? l)
|
||||
;;; (loop (cdr l) (cons (car l) v))
|
||||
;;; (values (reverse! (cons l v)) #t))))
|
||||
;;; (else (error "Invalid formals:" formals))))
|
||||
;;;
|
||||
;;; (define (identifier-split identifier)
|
||||
;;; (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
|
||||
;;; (if m
|
||||
;;; (values (string->symbol (match:prefix m))
|
||||
;;; (string->symbol (match:substring m 1)))
|
||||
;;; (values #f identifier))))
|
||||
|
|
|
|||
|
|
@ -20,54 +20,59 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system il glil)
|
||||
:use-syntax (system base syntax)
|
||||
:use-module (ice-9 match)
|
||||
:export
|
||||
(pprint-glil
|
||||
make-<glil-asm> <glil-asm>?
|
||||
<glil-vars>
|
||||
<glil-asm> <glil-asm>?
|
||||
<glil-asm>-1 <glil-asm>-2 <glil-asm>-3 <glil-asm>-4 <glil-asm>-5
|
||||
make-<glil-vars> <glil-vars>? <glil-vars>-1 <glil-vars>-2
|
||||
<glil-bind> <glil-bind>? <glil-bind>-1
|
||||
<glil-unbind> <glil-unbind>?
|
||||
<glil-source> <glil-source>? <glil-source>-1 <glil-source>-2
|
||||
|
||||
make-<glil-void> <glil-void>?
|
||||
make-<glil-const> <glil-const>? <glil-const>-1
|
||||
<glil-void> <glil-void>?
|
||||
<glil-const> <glil-const>? <glil-const>-1
|
||||
|
||||
make-<glil-argument> <glil-argument>? <glil-argument>-1 <glil-argument>-2
|
||||
make-<glil-local> <glil-local>? <glil-local>-1 <glil-local>-2
|
||||
make-<glil-external> <glil-external>?
|
||||
<glil-argument> <glil-argument>? <glil-argument>-1 <glil-argument>-2
|
||||
<glil-local> <glil-local>? <glil-local>-1 <glil-local>-2
|
||||
<glil-external> <glil-external>?
|
||||
<glil-external>-1 <glil-external>-2 <glil-external>-3
|
||||
make-<glil-module> <glil-module>?
|
||||
<glil-module> <glil-module>?
|
||||
<glil-module>-1 <glil-module>-2 <glil-module>-3
|
||||
|
||||
make-<glil-label> <glil-label>? <glil-label>-1
|
||||
make-<glil-branch> <glil-branch>? <glil-branch>-1 <glil-branch>-2
|
||||
make-<glil-call> <glil-call>? <glil-call>-1 <glil-call>-2
|
||||
<glil-label> <glil-label>? <glil-label>-1
|
||||
<glil-branch> <glil-branch>? <glil-branch>-1 <glil-branch>-2
|
||||
<glil-call> <glil-call>? <glil-call>-1 <glil-call>-2
|
||||
))
|
||||
|
||||
;; Meta operations
|
||||
(define-structure (<glil-asm> nargs nrest nlocs nexts body))
|
||||
(define-structure (<glil-vars> type syms))
|
||||
(define-record (<glil-vars> nargs nrest nlocs nexts))
|
||||
|
||||
;; Constants
|
||||
(define-structure (<glil-void>))
|
||||
(define-structure (<glil-const> obj))
|
||||
|
||||
;; Variables
|
||||
(define-structure (<glil-argument> op index))
|
||||
(define-structure (<glil-local> op index))
|
||||
(define-structure (<glil-external> op depth index))
|
||||
(define-structure (<glil-module> op module name))
|
||||
|
||||
;; Controls
|
||||
(define-structure (<glil-label> label))
|
||||
(define-structure (<glil-branch> inst label))
|
||||
(define-structure (<glil-call> inst nargs))
|
||||
(define-type <glil>
|
||||
(|
|
||||
;; Meta operations
|
||||
(<glil-asm> vars body)
|
||||
(<glil-bind> vars)
|
||||
(<glil-unbind>)
|
||||
(<glil-source> loc)
|
||||
;; Objects
|
||||
(<glil-void>)
|
||||
(<glil-const> obj)
|
||||
;; Variables
|
||||
(<glil-argument> op index)
|
||||
(<glil-local> op index)
|
||||
(<glil-external> op depth index)
|
||||
(<glil-module> op module name)
|
||||
;; Controls
|
||||
(<glil-label> label)
|
||||
(<glil-branch> inst label)
|
||||
(<glil-call> inst nargs)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Parser
|
||||
;;;
|
||||
|
||||
;; FIXME: This is not working now
|
||||
|
||||
;;; (define (parse-glil x)
|
||||
;;; (match x
|
||||
;;; (('@asm args . body)
|
||||
|
|
@ -140,9 +145,12 @@
|
|||
(define (unparse glil)
|
||||
(match glil
|
||||
;; meta
|
||||
(($ <glil-asm> nargs nrest nlocs nexts body)
|
||||
`(@asm (,nargs ,nrest ,nlocs ,nexts) ,@(map unparse body)))
|
||||
(($ <glil-vars> type syms) `(,type ,@syms))
|
||||
(($ <glil-asm> vars body)
|
||||
`(@asm (,vars.nargs ,vars.nrest ,vars.nlocs ,vars.nexts)
|
||||
,@(map unparse body)))
|
||||
(($ <glil-bind> vars) `(@bind ,@vars))
|
||||
(($ <glil-unbind>) `(@unbind))
|
||||
(($ <glil-source> loc) `(@source ,(car loc) ,(cdr loc)))
|
||||
;; constants
|
||||
(($ <glil-void>) `(void))
|
||||
(($ <glil-const> obj) `(const ,obj))
|
||||
|
|
@ -165,16 +173,17 @@
|
|||
;;; Printer
|
||||
;;;
|
||||
|
||||
(define (pprint-glil glil)
|
||||
(let print ((code (unparse glil)) (column 0))
|
||||
(display (make-string column #\space))
|
||||
(cond ((and (pair? code) (eq? (car code) '@asm))
|
||||
(format #t "(@asm ~A\n" (cadr code))
|
||||
(let ((col (+ column 2)))
|
||||
(let loop ((l (cddr code)))
|
||||
(print (car l) col)
|
||||
(if (null? (cdr l))
|
||||
(display ")")
|
||||
(begin (newline) (loop (cdr l)))))))
|
||||
(else (write code))))
|
||||
(newline))
|
||||
(define (pprint-glil glil . port)
|
||||
(let ((port (if (pair? port) (car port) (current-output-port))))
|
||||
(let print ((code (unparse glil)) (column 0))
|
||||
(display (make-string column #\space) port)
|
||||
(cond ((and (pair? code) (eq? (car code) '@asm))
|
||||
(format port "(@asm ~A\n" (cadr code))
|
||||
(let ((col (+ column 2)))
|
||||
(let loop ((l (cddr code)))
|
||||
(print (car l) col)
|
||||
(if (null? (cdr l))
|
||||
(display ")" port)
|
||||
(begin (newline port) (loop (cdr l)))))))
|
||||
(else (write code port))))
|
||||
(newline port)))
|
||||
|
|
|
|||
|
|
@ -1 +1,3 @@
|
|||
Makefile
|
||||
Makefile.in
|
||||
*.go
|
||||
|
|
|
|||
12
module/system/repl/Makefile.am
Normal file
12
module/system/repl/Makefile.am
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
SOURCES = repl.scm common.scm command.scm
|
||||
OBJECTS = repl.go common.go command.go
|
||||
|
||||
vmdir = $(guiledir)/system/repl
|
||||
vm_DATA = $(SOURCES) $(OBJECTS)
|
||||
|
||||
DISTCLEANFILES = $(OBJECTS)
|
||||
MAINTAINERCLEANFILES = Makefile.in
|
||||
|
||||
SUFFIXES = .scm .go
|
||||
.scm.go:
|
||||
$(GUILEC) $<
|
||||
|
|
@ -24,10 +24,13 @@
|
|||
:use-module (system base compile)
|
||||
:use-module (system repl common)
|
||||
:use-module (system vm core)
|
||||
:autoload (system base language) (lookup-language)
|
||||
:autoload (system il glil) (pprint-glil)
|
||||
:autoload (system vm disasm) (disassemble-program disassemble-objcode)
|
||||
:autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
|
||||
:autoload (system vm profile) (vm-profile)
|
||||
:autoload (system vm debugger) (vm-debugger)
|
||||
:autoload (system vm backtrace) (vm-backtrace)
|
||||
:use-module (ice-9 format)
|
||||
:use-module (ice-9 session)
|
||||
:use-module (ice-9 documentation))
|
||||
|
|
@ -44,7 +47,7 @@
|
|||
(compile (compile c) (compile-file cc)
|
||||
(disassemble x) (disassemble-file xx))
|
||||
(profile (time t) (profile pr))
|
||||
(debug (backtrace bt) (debugger db) (trace r) (step st))
|
||||
(debug (backtrace bt) (debugger db) (trace tr) (step st))
|
||||
(system (gc) (statistics stat))))
|
||||
|
||||
(define (group-name g) (car g))
|
||||
|
|
@ -332,16 +335,15 @@ Profile execution."
|
|||
;;; Debug commands
|
||||
;;;
|
||||
|
||||
(define guile:backtrace backtrace)
|
||||
(define (backtrace repl)
|
||||
"backtrace
|
||||
Show backtrace (if any)."
|
||||
(guile:backtrace))
|
||||
Display backtrace."
|
||||
(vm-backtrace repl.env.vm))
|
||||
|
||||
(define (debugger repl)
|
||||
"debugger
|
||||
Start debugger."
|
||||
(debug))
|
||||
(vm-debugger repl.env.vm))
|
||||
|
||||
(define (trace repl form . opts)
|
||||
"trace FORM
|
||||
|
|
|
|||
|
|
@ -20,19 +20,17 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system repl common)
|
||||
:use-module (oop goops)
|
||||
:use-syntax (system base syntax)
|
||||
:use-module (system base compile)
|
||||
:use-module (system base language)
|
||||
:use-module (system vm core)
|
||||
:use-module (system vm trace))
|
||||
:use-module (system vm core))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Repl type
|
||||
;;;
|
||||
|
||||
(define-vm-class <repl> () env options tm-stats gc-stats vm-stats)
|
||||
(define-record (<repl> env options tm-stats gc-stats vm-stats))
|
||||
|
||||
(define repl-default-options
|
||||
'((trace . #f)))
|
||||
|
|
@ -41,12 +39,11 @@
|
|||
(let ((cenv (make-cenv :vm (the-vm)
|
||||
:language (lookup-language lang)
|
||||
:module (current-module))))
|
||||
(make <repl>
|
||||
:env cenv
|
||||
:options repl-default-options
|
||||
:tm-stats (times)
|
||||
:gc-stats (gc-stats)
|
||||
:vm-stats (vm-stats cenv.vm))))
|
||||
(<repl> :env cenv
|
||||
:options repl-default-options
|
||||
:tm-stats (times)
|
||||
:gc-stats (gc-stats)
|
||||
:vm-stats (vm-stats cenv.vm))))
|
||||
|
||||
(define-public (repl-welcome repl)
|
||||
(format #t "~A interpreter ~A on Guile ~A\n"
|
||||
|
|
|
|||
|
|
@ -32,15 +32,19 @@
|
|||
(repl-welcome repl)
|
||||
(let prompt-loop ()
|
||||
(repl-prompt repl)
|
||||
(call-with-error-handlers
|
||||
(lambda ()
|
||||
(if (eq? (next-char #t) #\,)
|
||||
;; meta command
|
||||
(begin (read-char) (meta-command repl (read-line)))
|
||||
;; evaluation
|
||||
(let rep-loop ()
|
||||
(repl-print repl (repl-eval repl (repl-read repl)))
|
||||
(if (next-char #f) (rep-loop))))))
|
||||
(catch 'vm-error
|
||||
(lambda ()
|
||||
(if (eq? (next-char #t) #\,)
|
||||
;; meta command
|
||||
(begin (read-char) (meta-command repl (read-line)))
|
||||
;; evaluation
|
||||
(let rep-loop ()
|
||||
(repl-print repl (repl-eval repl (repl-read repl)))
|
||||
(if (next-char #f) (rep-loop)))))
|
||||
(lambda (key fun msg args)
|
||||
(display "ERROR: ")
|
||||
(apply format #t msg args)
|
||||
(newline)))
|
||||
(prompt-loop))))
|
||||
|
||||
(define (next-char wait)
|
||||
|
|
@ -50,21 +54,3 @@
|
|||
((char-whitespace? ch) (read-char) (next-char wait))
|
||||
(else ch)))
|
||||
#f))
|
||||
|
||||
;;;
|
||||
;;; Error handler
|
||||
;;;
|
||||
|
||||
(define (call-with-error-handlers thunk)
|
||||
(catch 'vm-error
|
||||
(lambda () (catch 'user-error thunk error-handler))
|
||||
error-handler))
|
||||
|
||||
(define (error-handler key . args)
|
||||
(case key
|
||||
((vm-error)
|
||||
(write (frame->call (cadddr args)))
|
||||
(newline)))
|
||||
(display "ERROR: ")
|
||||
(apply format #t (cadr args) (caddr args))
|
||||
(newline))
|
||||
|
|
|
|||
|
|
@ -1 +1,3 @@
|
|||
Makefile
|
||||
Makefile.in
|
||||
*.go
|
||||
|
|
|
|||
12
module/system/vm/Makefile.am
Normal file
12
module/system/vm/Makefile.am
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
SOURCES = assemble.scm conv.scm core.scm disasm.scm profile.scm trace.scm
|
||||
OBJECTS = assemble.go conv.go core.go disasm.go profile.go trace.go
|
||||
|
||||
vmdir = $(guiledir)/system/vm
|
||||
vm_DATA = $(SOURCES) $(OBJECTS)
|
||||
|
||||
DISTCLEANFILES = $(OBJECTS)
|
||||
MAINTAINERCLEANFILES = Makefile.in
|
||||
|
||||
SUFFIXES = .scm .go
|
||||
.scm.go:
|
||||
$(GUILEC) $<
|
||||
|
|
@ -20,6 +20,7 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system vm assemble)
|
||||
:use-syntax (system base syntax)
|
||||
:use-module (system il glil)
|
||||
:use-module (system vm core)
|
||||
:use-module (system vm conv)
|
||||
|
|
@ -36,11 +37,11 @@
|
|||
;;; Types
|
||||
;;;
|
||||
|
||||
(define-structure (<vm-asm> venv glil body))
|
||||
(define-structure (venv parent nexts closure?))
|
||||
(define-structure (vmod id))
|
||||
(define-structure (vlink module name))
|
||||
(define-structure (bytespec nargs nrest nlocs nexts bytes objs closure?))
|
||||
(define-record (<vm-asm> venv glil body))
|
||||
(define-record (<venv> parent nexts closure?))
|
||||
(define-record (<vmod> id))
|
||||
(define-record (<vlink> module name))
|
||||
(define-record (<bytespec> vars bytes meta objs closure?))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -49,15 +50,15 @@
|
|||
|
||||
(define (preprocess x e)
|
||||
(match x
|
||||
(($ <glil-asm> nargs nrest nlocs nexts body)
|
||||
(let* ((venv (make-venv e nexts #f))
|
||||
(($ <glil-asm> vars body)
|
||||
(let* ((venv (<venv> :parent e :nexts vars.nexts :closure? #f))
|
||||
(body (map (lambda (x) (preprocess x venv)) body)))
|
||||
(make-<vm-asm> venv x body)))
|
||||
(<vm-asm> :venv venv :glil x :body body)))
|
||||
(($ <glil-external> op depth index)
|
||||
(do ((d depth (1- d))
|
||||
(e e (venv-parent e)))
|
||||
(e e e.parent))
|
||||
((= d 0))
|
||||
(set-venv-closure?! e #t))
|
||||
(set! e.closure? #t))
|
||||
x)
|
||||
(else x)))
|
||||
|
||||
|
|
@ -68,8 +69,10 @@
|
|||
|
||||
(define (codegen glil toplevel)
|
||||
(match glil
|
||||
(($ <vm-asm> venv ($ <glil-asm> nargs nrest nlocs nexts _) body)
|
||||
(($ <vm-asm> venv ($ <glil-asm> vars _) body)
|
||||
(let ((stack '())
|
||||
(bind-alist '())
|
||||
(source-alist '())
|
||||
(label-alist '())
|
||||
(object-alist '()))
|
||||
(define (push-code! code)
|
||||
|
|
@ -84,11 +87,32 @@
|
|||
(set! object-alist (acons x i object-alist))
|
||||
i)))))
|
||||
(push-code! `(object-ref ,i))))))
|
||||
(define (current-address)
|
||||
(define (byte-length x)
|
||||
(cond ((string? x) (string-length x))
|
||||
(else 3)))
|
||||
(apply + (map byte-length stack)))
|
||||
(define (generate-code x)
|
||||
(match x
|
||||
(($ <vm-asm> venv)
|
||||
(push-object! (codegen x #f))
|
||||
(if (venv-closure? venv) (push-code! `(make-closure))))
|
||||
(if venv.closure? (push-code! `(make-closure))))
|
||||
|
||||
(($ <glil-bind> binds)
|
||||
(let ((binds (map (lambda (v)
|
||||
(case (cadr v)
|
||||
((argument) (list (car v) #f (caddr v)))
|
||||
((local) (list (car v) #f
|
||||
(+ vars.nargs (caddr v))))
|
||||
((external) (list (car v) #t (caddr v)))))
|
||||
binds)))
|
||||
(set! bind-alist (acons (current-address) binds bind-alist))))
|
||||
|
||||
(($ <glil-unbind>)
|
||||
(set! bind-alist (acons (current-address) #f bind-alist)))
|
||||
|
||||
(($ <glil-source> loc)
|
||||
(set! source-alist (acons (current-address) loc source-alist)))
|
||||
|
||||
(($ <glil-void>)
|
||||
(push-code! '(void)))
|
||||
|
|
@ -103,30 +127,26 @@
|
|||
|
||||
(($ <glil-local> op index)
|
||||
(if (eq? op 'ref)
|
||||
(push-code! `(local-ref ,(+ nargs index)))
|
||||
(push-code! `(local-set ,(+ nargs index)))))
|
||||
(push-code! `(local-ref ,(+ vars.nargs index)))
|
||||
(push-code! `(local-set ,(+ vars.nargs index)))))
|
||||
|
||||
(($ <glil-external> op depth index)
|
||||
(do ((e venv (venv-parent e))
|
||||
(do ((e venv e.parent)
|
||||
(d depth (1- d))
|
||||
(n 0 (+ n (venv-nexts e))))
|
||||
(n 0 (+ n e.nexts)))
|
||||
((= d 0)
|
||||
(if (eq? op 'ref)
|
||||
(push-code! `(external-ref ,(+ n index)))
|
||||
(push-code! `(external-set ,(+ n index)))))))
|
||||
|
||||
(($ <glil-module> op module name)
|
||||
(push-object! (make-vlink #f name)) ;; FIXME: (make-vmod module)
|
||||
(push-object! (<vlink> :module #f :name name))
|
||||
(if (eq? op 'ref)
|
||||
(push-code! '(variable-ref))
|
||||
(push-code! '(variable-set))))
|
||||
|
||||
(($ <glil-label> label)
|
||||
(define (byte-length x)
|
||||
(cond ((string? x) (string-length x))
|
||||
(else 3)))
|
||||
(let ((addr (apply + (map byte-length stack))))
|
||||
(set! label-alist (assq-set! label-alist label addr))))
|
||||
(set! label-alist (assq-set! label-alist label (current-address))))
|
||||
|
||||
(($ <glil-branch> inst label)
|
||||
(set! stack (cons (list inst label) stack)))
|
||||
|
|
@ -146,13 +166,21 @@
|
|||
(for-each generate-code body)
|
||||
(let ((bytes (stack->bytes (reverse! stack) label-alist)))
|
||||
(if toplevel
|
||||
(bytecode->objcode bytes nlocs nexts)
|
||||
(let ((objs (map car (reverse! object-alist))))
|
||||
(make-bytespec nargs nrest nlocs nexts bytes objs
|
||||
(venv-closure? venv)))))))))
|
||||
(bytecode->objcode bytes vars.nlocs vars.nexts)
|
||||
(<bytespec> :vars vars :bytes bytes
|
||||
:meta (if (and (null? bind-alist)
|
||||
(null? source-alist))
|
||||
#f
|
||||
(cons (reverse! bind-alist)
|
||||
(reverse! source-alist)))
|
||||
:objs (let ((objs (map car (reverse! object-alist))))
|
||||
(if (null? objs) #f (list->vector objs)))
|
||||
:closure? venv.closure?)))))))
|
||||
|
||||
(define (object-assoc x alist)
|
||||
(if (vlink? x) (assoc x alist) (assq x alist)))
|
||||
(match x
|
||||
(($ <vlink>) (assoc x alist))
|
||||
(else (assq x alist))))
|
||||
|
||||
(define (stack->bytes stack label-alist)
|
||||
(let loop ((result '()) (stack stack) (addr 0))
|
||||
|
|
@ -181,60 +209,63 @@
|
|||
(let dump! ((x x))
|
||||
(cond
|
||||
((object->code x) => push-code!)
|
||||
((bytespec? x)
|
||||
(match x
|
||||
(($ bytespec nargs nrest nlocs nexts bytes objs closure?)
|
||||
;; dump parameters
|
||||
(cond
|
||||
((and (< nargs 4) (< nlocs 8) (< nexts 4))
|
||||
;; 8-bit representation
|
||||
(let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
|
||||
(push-code! `(make-int8 ,x))))
|
||||
((and (< nargs 16) (< nlocs 128) (< nexts 16))
|
||||
;; 16-bit representation
|
||||
(let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
|
||||
(push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
|
||||
(else
|
||||
;; Other cases
|
||||
(push-code! (object->code nargs))
|
||||
(push-code! (object->code nrest))
|
||||
(push-code! (object->code nlocs))
|
||||
(push-code! (object->code nexts))
|
||||
(push-code! (object->code #f))))
|
||||
;; dump object table
|
||||
(cond ((not (null? objs))
|
||||
(for-each dump! objs)
|
||||
(push-code! `(vector ,(length objs)))))
|
||||
;; dump bytecode
|
||||
(push-code! `(load-program ,bytes)))))
|
||||
((vlink? x)
|
||||
;;; (dump! (vlink-module x)) ;; FIXME: no module support now
|
||||
(push-code! `(link ,(symbol->string (vlink-name x)))))
|
||||
((vmod? x)
|
||||
(push-code! `(load-module ,(vmod-id x))))
|
||||
((and (integer? x) (exact? x))
|
||||
(let ((str (do ((n x (quotient n 256))
|
||||
(l '() (cons (modulo n 256) l)))
|
||||
((= n 0)
|
||||
(list->string (map integer->char l))))))
|
||||
(push-code! `(load-integer ,str))))
|
||||
((number? x)
|
||||
(push-code! `(load-number ,(number->string x))))
|
||||
((string? x)
|
||||
(push-code! `(load-string ,x)))
|
||||
((symbol? x)
|
||||
(push-code! `(load-symbol ,(symbol->string x))))
|
||||
((keyword? x)
|
||||
(push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x)))))
|
||||
((list? x)
|
||||
(for-each dump! x)
|
||||
(push-code! `(list ,(length x))))
|
||||
((pair? x)
|
||||
(dump! (car x))
|
||||
(dump! (cdr x))
|
||||
(push-code! `(cons)))
|
||||
((vector? x)
|
||||
(for-each dump! (vector->list x))
|
||||
(push-code! `(vector ,(vector-length x))))
|
||||
(else
|
||||
(error "Cannot dump:" x)))))
|
||||
(match x
|
||||
(($ <bytespec> vars bytes meta objs closure?)
|
||||
;; dump parameters
|
||||
(let ((nargs vars.nargs) (nrest vars.nrest)
|
||||
(nlocs vars.nlocs) (nexts vars.nexts))
|
||||
(cond
|
||||
((and (< nargs 4) (< nlocs 8) (< nexts 4))
|
||||
;; 8-bit representation
|
||||
(let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
|
||||
(push-code! `(make-int8 ,x))))
|
||||
((and (< nargs 16) (< nlocs 128) (< nexts 16))
|
||||
;; 16-bit representation
|
||||
(let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
|
||||
(push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
|
||||
(else
|
||||
;; Other cases
|
||||
(push-code! (object->code nargs))
|
||||
(push-code! (object->code nrest))
|
||||
(push-code! (object->code nlocs))
|
||||
(push-code! (object->code nexts))
|
||||
(push-code! (object->code #f)))))
|
||||
;; dump object table
|
||||
(if objs (dump! objs))
|
||||
;; dump meta data
|
||||
(if meta (dump! meta))
|
||||
;; dump bytecode
|
||||
(push-code! `(load-program ,bytes)))
|
||||
(($ <vlink> module name)
|
||||
;; FIXME: dump module
|
||||
(push-code! `(link ,(symbol->string name))))
|
||||
(($ <vmod> id)
|
||||
(push-code! `(load-module ,id)))
|
||||
((and ($ integer) ($ exact))
|
||||
(let ((str (do ((n x (quotient n 256))
|
||||
(l '() (cons (modulo n 256) l)))
|
||||
((= n 0)
|
||||
(list->string (map integer->char l))))))
|
||||
(push-code! `(load-integer ,str))))
|
||||
(($ number)
|
||||
(push-code! `(load-number ,(number->string x))))
|
||||
(($ string)
|
||||
(push-code! `(load-string ,x)))
|
||||
(($ symbol)
|
||||
(push-code! `(load-symbol ,(symbol->string x))))
|
||||
(($ keyword)
|
||||
(push-code! `(load-keyword
|
||||
,(symbol->string (keyword-dash-symbol x)))))
|
||||
(($ list)
|
||||
(for-each dump! x)
|
||||
(push-code! `(list ,(length x))))
|
||||
(($ pair)
|
||||
(dump! (car x))
|
||||
(dump! (cdr x))
|
||||
(push-code! `(cons)))
|
||||
(($ vector)
|
||||
(for-each dump! (vector->list x))
|
||||
(push-code! `(vector ,(vector-length x))))
|
||||
(else
|
||||
(error "Cannot dump:" x)))))))
|
||||
|
|
|
|||
33
module/system/vm/backtrace.scm
Normal file
33
module/system/vm/backtrace.scm
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
;;; Guile VM backtrace
|
||||
|
||||
;; 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 vm backtrace)
|
||||
:use-syntax (system base syntax)
|
||||
:use-module (system vm core)
|
||||
:use-module (system vm frame)
|
||||
:use-module (ice-9 format)
|
||||
:export (vm-backtrace))
|
||||
|
||||
(define (vm-backtrace vm)
|
||||
(let ((stack (vm-last-frame-stack vm)))
|
||||
(if (null? stack)
|
||||
(display "No backtrace available\n")
|
||||
(for-each print-frame (reverse! stack)))))
|
||||
|
|
@ -35,36 +35,21 @@
|
|||
|
||||
|
||||
;;;
|
||||
;;; Loader
|
||||
;;; High-level procedures
|
||||
;;;
|
||||
|
||||
(define-public (program-bindings prog)
|
||||
(cond ((program-meta prog) => car)
|
||||
(else '())))
|
||||
|
||||
(define-public (program-sources prog)
|
||||
(cond ((program-meta prog) => cdr)
|
||||
(else '())))
|
||||
|
||||
(define-public (vms:time stat) (vector-ref stat 0))
|
||||
(define-public (vms:clock stat) (vector-ref stat 1))
|
||||
|
||||
(define-public (vm-load vm objcode)
|
||||
(vm (objcode->program objcode)))
|
||||
|
||||
(set! load-compiled (lambda (file) (vm-load (the-vm) (load-objcode file))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Frame interface
|
||||
;;;
|
||||
|
||||
(define-public (frame->call frame)
|
||||
(let* ((prog (frame-program frame))
|
||||
(nargs (car (program-arity prog))))
|
||||
(do ((i 0 (1+ i))
|
||||
(l (vector->list (frame-variables frame)) (cdr l))
|
||||
(r '() (cons (car l) r)))
|
||||
((= i nargs) (cons (program-name prog) (reverse! r))))))
|
||||
|
||||
(define (program-name x)
|
||||
(or (object-property x 'name)
|
||||
(hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x
|
||||
(module-obarray (current-module)))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Statistics interface
|
||||
;;;
|
||||
|
||||
(define-public (vms:time stat) (vector-ref stat 0))
|
||||
(define-public (vms:clock stat) (vector-ref stat 1))
|
||||
|
|
|
|||
|
|
@ -127,8 +127,7 @@
|
|||
(else #f)))))))
|
||||
|
||||
(define (list->info list)
|
||||
(let ((str (object->string list)))
|
||||
(substring str 1 (1- (string-length str)))))
|
||||
(object->string list))
|
||||
|
||||
(define (print-info addr info extra)
|
||||
(if extra
|
||||
|
|
|
|||
125
module/system/vm/frame.scm
Normal file
125
module/system/vm/frame.scm
Normal file
|
|
@ -0,0 +1,125 @@
|
|||
;;; Guile VM frame functions
|
||||
|
||||
;; 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 vm frame)
|
||||
:use-module (system vm core))
|
||||
|
||||
(define-public (vm-return-value vm)
|
||||
(car (vm-fetch-stack vm)))
|
||||
|
||||
(define-public (frame-local-ref frame index)
|
||||
(vector-ref (frame-local-variables frame) index))
|
||||
|
||||
(define-public (frame-external-ref frame index)
|
||||
(list-ref (frame-external-link frame) index))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Debug frames
|
||||
;;;
|
||||
|
||||
(define-public frame-index (make-object-property))
|
||||
(define-public frame-address (make-object-property))
|
||||
|
||||
(define-public (vm-last-frame-stack vm)
|
||||
(make-frame-stack (vm-last-frame vm) (vm:ip vm)))
|
||||
|
||||
(define-public (vm-current-frame-stack vm)
|
||||
(make-frame-stack (vm-current-frame vm) (vm:ip vm)))
|
||||
|
||||
(define (make-frame-stack frame addr)
|
||||
(cond ((frame-dynamic-link frame) =>
|
||||
(lambda (link)
|
||||
(let ((stack (make-frame-stack link (frame-return-address frame)))
|
||||
(base (program-base (frame-program frame))))
|
||||
(set! (frame-index frame) (1+ (length stack)))
|
||||
(set! (frame-address frame) (- addr base))
|
||||
(cons frame stack))))
|
||||
(else '())))
|
||||
|
||||
(define-public (frame-bindings frame addr)
|
||||
(do ((bs (program-bindings (frame-program frame)) (cdr bs))
|
||||
(ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls))))
|
||||
((or (null? bs) (> (caar bs) addr))
|
||||
(apply append ls))))
|
||||
|
||||
(define-public (frame-environment frame addr)
|
||||
(map (lambda (binding)
|
||||
(let ((name (car binding))
|
||||
(extp (cadr binding))
|
||||
(index (caddr binding)))
|
||||
(cons name (if extp
|
||||
(frame-external-ref frame index)
|
||||
(frame-local-ref frame index)))))
|
||||
(frame-bindings frame addr)))
|
||||
|
||||
(define (frame-variable-ref frame sym)
|
||||
(cond ((assq sym (frame-environment frame)) => cdr)
|
||||
(else (error "Unbound"))))
|
||||
|
||||
(define (frame-object-name frame obj)
|
||||
(display (frame-address frame))
|
||||
(let loop ((alist (frame-environment frame (frame-address frame))))
|
||||
(cond ((null? alist) #f)
|
||||
((eq? obj (cdar alist)) (caar alist))
|
||||
(else (loop (cdr alist))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Pretty printing
|
||||
;;;
|
||||
|
||||
(define-public (frame-call-list frame)
|
||||
(let* ((prog (frame-program frame))
|
||||
(locs (vector->list (frame-local-variables frame)))
|
||||
(args (list-truncate locs (car (program-arity prog))))
|
||||
(name (or (frame-object-name (frame-dynamic-link frame) prog)
|
||||
(object-name prog))))
|
||||
(cons name args)))
|
||||
|
||||
(define-public (print-frame-call frame)
|
||||
(define (abbrev x)
|
||||
(cond ((list? x) (if (> (length x) 3)
|
||||
(list (abbrev (car x)) (abbrev (cadr x)) '...)
|
||||
(map abbrev x)))
|
||||
((pair? x) (cons (abbrev (car x)) (abbrev (cdr x))))
|
||||
((vector? x) (case (vector-length x)
|
||||
((0) x)
|
||||
((1) (vector (abbrev (vector-ref x 0))))
|
||||
(else (vector (abbrev (vector-ref x 0)) '...))))
|
||||
(else x)))
|
||||
(write (abbrev (frame-call-list frame))))
|
||||
|
||||
(define-public (print-frame frame)
|
||||
(format #t "#~A " (frame-index frame))
|
||||
(print-frame-call frame)
|
||||
(newline))
|
||||
|
||||
(define (list-truncate l n)
|
||||
(do ((i 0 (1+ i))
|
||||
(l l (cdr l))
|
||||
(r '() (cons (car l) r)))
|
||||
((= i n) (reverse! r))))
|
||||
|
||||
(define (object-name x)
|
||||
(or (object-property x 'name)
|
||||
(hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d))
|
||||
x (module-obarray (current-module)))))
|
||||
|
|
@ -34,7 +34,7 @@
|
|||
(add-hook! (vm-enter-hook vm) profile-enter)
|
||||
(add-hook! (vm-exit-hook vm) profile-exit))
|
||||
(lambda ()
|
||||
(let ((val (vm (objcode->program objcode))))
|
||||
(let ((val (vm-load vm objcode)))
|
||||
(display-result vm)
|
||||
val))
|
||||
(lambda ()
|
||||
|
|
|
|||
|
|
@ -22,13 +22,14 @@
|
|||
(define-module (system vm trace)
|
||||
:use-syntax (system base syntax)
|
||||
:use-module (system vm core)
|
||||
:use-module (system vm frame)
|
||||
:use-module (ice-9 format)
|
||||
:export (vm-trace vm-trace-on vm-trace-off))
|
||||
|
||||
(define (vm-trace vm objcode . opts)
|
||||
(dynamic-wind
|
||||
(lambda () (apply vm-trace-on vm opts))
|
||||
(lambda () (vm (objcode->program objcode)))
|
||||
(lambda () (vm-load vm objcode))
|
||||
(lambda () (apply vm-trace-off vm opts))))
|
||||
|
||||
(define (vm-trace-on vm . opts)
|
||||
|
|
@ -44,30 +45,32 @@
|
|||
(remove-hook! (vm-return-hook vm) trace-return))
|
||||
|
||||
(define (trace-next vm)
|
||||
(let ((frame (vm-current-frame vm)))
|
||||
(format #t "0x~8X ~20S" (vm:ip vm) (vm-fetch-code vm))
|
||||
(do ((opts (vm-option vm 'trace-options) (cdr opts)))
|
||||
((null? opts) (newline))
|
||||
(case (car opts)
|
||||
((:s) (format #t "~20S" (vm-fetch-stack vm)))
|
||||
((:v) (format #t "~20S" (frame-variables frame)))
|
||||
((:e) (format #t "~20A" (object->string (frame-external-link frame))))))))
|
||||
(format #t "0x~8X ~20S" (vm:ip vm) (vm-fetch-code vm))
|
||||
(do ((opts (vm-option vm 'trace-options) (cdr opts)))
|
||||
((null? opts) (newline))
|
||||
(case (car opts)
|
||||
((:s) (format #t "~20S" (vm-fetch-stack vm)))
|
||||
((:v) (let ((stack (vm-current-frame-stack vm)))
|
||||
(if (pair? stack)
|
||||
(format #t "~20S" (frame-environment (car stack))))))
|
||||
((:l)
|
||||
(format #t "~20S" (frame-local-variables (vm-current-frame vm))))
|
||||
((:e)
|
||||
(format #t "~20A" (frame-external-link (vm-current-frame vm)))))))
|
||||
|
||||
(define (trace-apply vm)
|
||||
(if (vm-option vm 'trace-first)
|
||||
(set-vm-option! vm 'trace-first #f) ;; skip the initial program
|
||||
(let ((frame (vm-current-frame vm)))
|
||||
(print-prefix (frame-dynamic-link frame))
|
||||
(write (frame->call frame))
|
||||
(newline))))
|
||||
|
||||
(define (trace-return vm)
|
||||
(let ((frame (vm-current-frame vm)))
|
||||
(print-prefix (frame-dynamic-link frame))
|
||||
(write (car (vm-fetch-stack vm)))
|
||||
;; (if (vm-option vm 'trace-first)
|
||||
;; (set-vm-option! vm 'trace-first #f)
|
||||
(let ((stack (vm-current-frame-stack vm)))
|
||||
(print-indent stack)
|
||||
(print-frame-call (car stack))
|
||||
(newline)))
|
||||
|
||||
(define (print-prefix frame)
|
||||
(and-let* ((link (frame-dynamic-link frame)))
|
||||
(display "| ")
|
||||
(print-prefix link)))
|
||||
(define (trace-return vm)
|
||||
(let ((stack (vm-current-frame-stack vm)))
|
||||
(print-indent stack)
|
||||
(write (vm-return-value vm))
|
||||
(newline)))
|
||||
|
||||
(define (print-indent stack)
|
||||
(cond ((pair? stack) (display "| ") (print-indent (cdr stack)))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue