mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

*** empty log message ***

Browse source
This commit is contained in:
Keisuke Nishida 2001-04-16 03:43:48 +00:00
parent 78591ef5c3
commit 8f5cfc810f
41 changed files with 681 additions and 529 deletions
Download patch file Download diff file Expand all files Collapse all files

92
README
View file

@ -7,10 +7,12 @@ Installation
% configure
% make install
% ln -s module/{system,language} /usr/local/share/guile/site/
% ln -s module/{guile,system,language} /usr/local/share/guile/
3. Add the following lines to your ~/.guile:
(use-modules (system vm core)
(cond ((string=? (car (command-line)) "guile-vm")
(use-modules (system repl repl))
(start-repl 'scheme)
@ -20,79 +22,63 @@ Example Session
---------------
% guile-vm
Guile Scheme interpreter 0.4 on Guile 1.4.1
Guile Scheme interpreter 0.5 on Guile 1.4.1
Copyright (C) 2001 Free Software Foundation, Inc.
Enter `,help' for help.
gscheme@guile> (+ 1 2)
$1 = 3
gscheme@guile> ,c -c (+ 1 2) ;; Compile into GLIL
(@asm (0 0 0 0)
scheme@guile-user> (+ 1 2)
3
scheme@guile-user> ,c -c (+ 1 2) ;; Compile into GLIL
(@asm (0 1 0 0)
(module-ref #f +)
(const 1)
(const 2)
(add 2)
(return 0))
gscheme@guile> ,c (+ 1 2) ;; Compile into bootcode
Disassembly of bootcode:
Compiled for Guile VM 0.4
(tail-call 2))
scheme@guile-user> ,c (+ 1 2) ;; Compile into object code
Disassembly of #<objcode 403c5fb0>:
nlocs = 0 nexts = 0
0 make-int8:1 ;; 1
1 make-int8 2 ;; 2
3 add
4 return
0 link "+" ;; (+ . ???)
3 variable-ref
4 make-int8:1 ;; 1
5 make-int8 2 ;; 2
7 tail-call 2
gscheme@guile> (define (add x y) (+ x y))
gscheme@guile> (add 1 2)
$2 = 3
gscheme@guile> ,x add ;; Disassemble
scheme@guile-user> (define (add x y) (+ x y))
scheme@guile-user> (add 1 2)
3
scheme@guile-user> ,x add ;; Disassemble
Disassembly of #<program add>:
nargs = 2 nrest = 0 nlocs = 0 nexts = 0
Bytecode:
0 local-ref 0
2 local-ref 1
4 add
5 return
0 object-ref 0 ;; (+ . #<primitive-procedure +>)
2 variable-ref
3 local-ref 0
5 local-ref 1
7 tail-call 2
gscheme@guile>
Objects:
Write Modules
-------------
0 (+ . #<primitive-procedure +>)
---- fib.scm ---------------------------
(define-module (fib)
:use-module (system vm load)
:export (fib))
scheme@guile-user>
(load/compile "fib.gs")
----------------------------------------
Compile Modules
---------------
---- fib.gs ----------------------------
(define (fib n)
(if (< n 2)
1
(+ (fib (- n 1)) (fib (- n 2)))))
----------------------------------------
Use `guilec' to compile your modules:
Now, expressions in fib.gsm are automatically compiled and
executed by the Guile VM:
% cat fib.scm
(define-module (fib) :export (fib))
(define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))
% guilec fib.scm
Wrote fib.go
% guile
guile> (use-modules (fib))
guile> (time (fib 30))
clock utime stime cutime cstime gctime
2.80 2.79 0.00 0.00 0.00 0.00
$1 = 1346269
guile> (define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))
guile> (time (fib 30))
clock utime stime cutime cstime gctime
26.05 25.01 0.17 0.00 0.00 14.33
$2 = 1346269
If you don't want to compile your code (e.g., for debugging purpose),
just change `load/compile' to `load'.
guile> (fib 8)
34

2
configure.in
View file

@ -12,4 +12,4 @@ AC_PROG_LN_S
AM_PROG_LIBTOOL
AC_C_LABELS_AS_VALUES
AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile src/guilec)
AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile)

6
module/Makefile.am
View file

@ -1,5 +1,5 @@
DISTDIRS = $(srcdir)/language $(srcdir)/system $(srcdir)/slib
EXCLUDES = --exclude=CVS --exclude='*~'
DISTDIRS = $(srcdir)/system $(srcdir)/language $(srcdir)/guile $(srcdir)/slib
EXCLUDES = --exclude=CVS --exclude=*.go --exclude=*~
all: slibcat
@ -7,7 +7,7 @@ clean:
rm -f slibcat slib/*.go
slibcat:
guile -s slib-comp.scm
guile -s $(top_srcdir)/src/guilec slib/*.scm
dist-hook:
$(TAR) cf - $(EXCLUDES) $(DISTDIRS) | (cd $(distdir); $(TAR) xf -)

10
module/language/scheme/spec.scm
View file

@ -30,15 +30,11 @@
(read-enable 'positions)
;;;
;;; Compiler
;;;
(define (compile port env . opts)
(define (read-file port)
(do ((x (read port) (read port))
(l '() (cons x l)))
((eof-object? x)
(apply compile-in (cons 'begin (reverse! l)) env scheme opts))))
(cons 'begin (reverse! l)))))
;;;
;;; Language definition
@ -48,7 +44,7 @@
:title "Guile Scheme"
:version "0.5"
:reader read
:read-file read-file
:translator translate
:printer write
:compiler compile
)

13
module/language/scheme/translate.scm
View file

@ -36,6 +36,9 @@
;;; Translator
;;;
(define scheme-primitives
'(not null? eq? eqv? equal? pair? list? cons car cdr set-car! set-cdr!))
(define (trans e l x)
(cond ((pair? x)
(let ((y (macroexpand x)))
@ -216,15 +219,17 @@
(() (make:void))
((('else . body)) (trans:pair `(begin ,@body)))
(((((? symbol? key) ...) body ...) rest ...)
(if (memq 'compile key)
(primitive-eval `(begin ,@(copy-tree body))))
(if (memq 'load-toplevel key)
(trans:pair `(begin ,@body))
(begin
(primitive-eval `(begin ,@(copy-tree body)))
(trans:pair `(begin ,@body)))
(loop rest)))
(else (bad-syntax)))))
(else
(make-<ghil-call> e l (trans:x head) (map trans:x tail)))))
(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))))))
(define (trans-quasiquote e l x)
(cond ((not (pair? x)) x)

4
module/slib/guile.init
View file

@ -223,10 +223,10 @@
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled load-compiled)
(define (slib:load-compiled f) (load-compiled-file (string-append f ".go")))
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-compiled)
(define slib:load slib:load)
(slib:load (in-vicinity (library-vicinity) "require"))

1
module/system/base/.cvsignore Normal file
View file

@ -0,0 +1 @@
*.go

128
module/system/base/compile.scm
View file

@ -20,29 +20,125 @@
;;; Code:
(define-module (system base compile)
:use-module (oop goops)
:use-syntax (system base syntax)
:use-module (system base language)
:use-module (ice-9 regex)
:export (compile-file object-file-name))
:use-module (system il compile)
:use-module (system vm core)
:use-module (system vm assemble)
:use-module (ice-9 regex))
;;;
;;; Compiler environment
;;;
(define-vm-class <cenv> ()
vm language module optimize)
(define-public (make-cenv . rest)
(apply make <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))))
;;;
;;; Compiler
;;;
(define scheme (lookup-language 'scheme))
(define (compile-file file)
(let ((comp (object-file-name file)))
(call-with-compile-error-catch
(lambda ()
(catch #t
(define-public (compile-file file . opts)
(let ((comp (compiled-file-name file)))
(catch #t
(lambda ()
(call-with-compile-error-catch
(lambda ()
(call-with-output-file comp
(lambda (port)
(uniform-array-write (compile-file-in file scheme) port))))
(lambda (key . args)
(format #t "ERROR: In ~A:\n" file)
(display "ERROR: ")
(format #t (cadr args) (caddr args))
(newline)
(delete-file comp)))))
(format #t "Wrote ~A\n" comp)))
(let* ((source (read-file-in file scheme))
(objcode (apply compile-in source (current-module)
scheme opts)))
(uniform-array-write (objcode->string objcode) port))))
(format #t "Wrote ~A\n" comp))))
(lambda (key . args)
(format #t "ERROR: In ~A:\n" file)
(display "ERROR: ")
(format #t (cadr args) (caddr args))
(newline)
(delete-file comp)))))
(define (object-file-name file)
(define-public (load-source-file file . opts)
(let ((source (read-file-in file scheme)))
(vm-load (the-vm) (apply compile-in source (current-module) scheme opts))))
(define-public (load-file file . opts)
(let ((comp (compiled-file-name file)))
(if (file-exists? comp)
(vm-load (the-vm) (load-objcode comp))
(apply load-source-file file opts))))
(define-public (compiled-file-name file)
(let ((m (string-match "\\.[^.]*$" file)))
(string-append (if m (match:prefix m) file) ".go")))
;;;
;;; Scheme compiler interface
;;;
(define-public (read-file-in file lang)
(call-with-input-file file lang.read-file))
(define-public (compile-in x e lang . opts)
(catch 'result
(lambda ()
;; expand
(set! x (lang.expander x e))
(if (memq :e opts) (throw 'result x))
;; translate
(set! x (lang.translator x e))
(if (memq :t opts) (throw 'result x))
;; compile
(set! x (apply compile x e opts))
(if (memq :c opts) (throw 'result x))
;; assemble
(apply assemble x e opts))
(lambda (key val) val)))
;;;
;;;
;;;
(define (compile-and-load file . opts)
(let ((comp (object-file-name file)))
(if (or (not (file-exists? comp))
(> (stat:mtime (stat file)) (stat:mtime (stat comp))))
(compile-file file))
(load-compiled-file comp)))
(define (load/compile file . opts)
(let* ((file (file-full-name file))
(compiled (object-file-name file)))
(if (or (not (file-exists? compiled))
(> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
(apply compile-file file #f opts))
(if (memq #:b opts)
(apply vm-trace (the-vm) (load-objcode compiled) opts)
((the-vm) (load-objcode compiled)))))
(define (file-full-name filename)
(let* ((port (current-load-port))
(oldname (and port (port-filename port))))
(if (and oldname
(> (string-length filename) 0)
(not (char=? (string-ref filename 0) #\/))
(not (string=? (dirname oldname) ".")))
(string-append (dirname oldname) "/" filename)
filename)))

51
module/system/base/language.scm
View file

@ -22,12 +22,7 @@
(define-module (system base language)
:use-module (oop goops)
:use-syntax (system base syntax)
:use-module (system il compile)
:use-module (system vm core)
:use-module (system vm assemble)
:use-module (ice-9 regex)
:export (define-language lookup-language read-in compile-in print-in
compile-file-in))
:export (define-language lookup-language))
;;;
@ -36,12 +31,10 @@
(define-vm-class <language> ()
name title version environment
(reader)
reader printer read-file
(expander (lambda (x e) x))
(translator (lambda (x e) x))
(evaluator #f)
(printer)
(compiler)
)
(define-method (write (lang <language>) port)
@ -57,43 +50,3 @@
(if (module-bound? m name)
(module-ref m name)
(error "No such language:" name))))
;;;
;;; Evaluation interface
;;;
(define (read-in lang . port)
(lang.reader (if (null? port) (current-input-port) (car port))))
(define (compile-in x e lang . opts)
(catch 'result
(lambda ()
;; expand
(set! x (lang.expander x e))
(if (memq :e opts) (throw 'result x))
;; translate
(set! x (lang.translator x e))
(if (memq :t opts) (throw 'result x))
;; compile
(set! x (apply compile x e opts))
(if (memq :c opts) (throw 'result x))
;; assemble
(apply assemble x e opts))
(lambda (key val) val)))
(define (print-in val lang . port)
(lang.printer val (if (null? port) (current-output-port) (car port))))
(define (compile-file-in file lang . opts)
(call-with-input-file file
(lambda (port) (apply lang.compiler port (current-module) opts))))
(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))))

1
module/system/il/.cvsignore Normal file
View file

@ -0,0 +1 @@
*.go

1
module/system/repl/.cvsignore Normal file
View file

@ -0,0 +1 @@
*.go

205
module/system/repl/command.scm
View file

@ -21,37 +21,31 @@
(define-module (system repl command)
:use-syntax (system base syntax)
:use-module (system base language)
:use-module (system base compile)
:use-module (system repl common)
:use-module (system il glil)
:use-module (system vm core)
:autoload (system il glil) (pprint-glil)
:autoload (system vm disasm) (disassemble-program disassemble-objcode)
:autoload (system vm trace) (vm-trace)
:autoload (system vm disasm) (disassemble-program disassemble-dumpcode)
:autoload (system vm profile) (vm-profile)
:use-module (ice-9 format)
:use-module (ice-9 session)
:export (meta-command))
(define (puts x) (display x) (newline))
(define (user-error msg . args)
(throw 'user-error #f msg args #f))
:use-module (ice-9 documentation))
;;;
;;; Meta command
;;; Meta command interface
;;;
(define *command-table*
'((help (help h) (apropos a) (describe d) (option o) (quit q))
(module (module m) (use u) (import i) (load l) (binding b) (lsmod lm))
(package (package p) (lspkg lp) (autopackage) (globals g))
(module (module m) (use u) (import i) (load l) (binding b))
(language (language L))
(compile (compile c) (compile-file cc)
(disassemble x) (disassemble-file xx))
(profile (time t) (profile pr))
(debug (backtrace bt) (debugger db) (trace tr) (step st))
(system (statistics stat) (gc))))
(debug (backtrace bt) (debugger db) (trace r) (step st))
(system (gc) (statistics st))))
(define (group-name g) (car g))
(define (group-commands g) (cdr g))
@ -102,7 +96,7 @@
(let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
(format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
(define (meta-command repl line)
(define-public (meta-command repl line)
(let ((input (call-with-input-string (string-append "(" line ")") read)))
(if (not (null? input))
(do ((key (car input))
@ -125,10 +119,10 @@
(define (help repl . args)
"help [GROUP]
Show help messages.
The optional argument can be either one of command groups or
command names. Without argument, a list of help commands and
all command groups are displayed, as you have already seen :)"
List available meta commands.
A command group name can be given as an optional argument.
Without any argument, a list of help commands and command groups
are displayed, as you have already seen ;)"
(match args
(()
(display-group (lookup-group 'help))
@ -141,27 +135,29 @@ all command groups are displayed, as you have already seen :)"
(display-summary usage #f header)))
(cdr *command-table*))
(newline)
(display "Enter `,COMMAND -h' to display documentation of each command.")
(display "Type `,COMMAND -h' to show documentation of each command.")
(newline))
(('all)
(for-each display-group *command-table*))
((? lookup-group group)
(display-group (lookup-group group)))
(else (user-error "Unknown command group: ~A" (car args)))))
(else
(user-error "Unknown command group: ~A" (car args)))))
(define guile-apropos apropos)
(define guile:apropos apropos)
(define (apropos repl regexp)
"apropos [options] REGEXP
"apropos REGEXP
Find bindings/modules/packages."
(guile-apropos (object->string regexp display)))
(guile:apropos (->string regexp)))
(define (describe repl obj)
"describe OBJ
Show description/documentation."
(display "Not implemented yet\n"))
(display (object-documentation (repl-eval repl obj)))
(newline))
(define (option repl . args)
"option [KEY [VALUE]]
"option [KEY VALUE]
List/show/set options."
(display "Not implemented yet\n"))
@ -179,7 +175,7 @@ Quit this session."
"module [MODULE]
Change modules / Show current module."
(match args
(() (puts (binding repl.module)))))
(() (puts (binding repl.env.module)))))
(define (use repl . args)
"use [MODULE ...]
@ -187,11 +183,12 @@ Use modules."
(define (use name)
(let ((mod (resolve-interface name)))
(if mod
(module-use! repl.module mod)
(module-use! repl.env.module mod)
(user-error "No such module: ~A" name))))
(if (null? args)
(for-each puts (map module-name
(cons repl.module (module-uses repl.module))))
(cons repl.env.module
(module-uses repl.env.module))))
(for-each (lambda (name)
(cond
((pair? name) (use name))
@ -206,11 +203,11 @@ Import modules / List those imported."
(define (use name)
(let ((mod (resolve-interface name)))
(if mod
(module-use! repl.module mod)
(module-use! repl.env.module mod)
(user-error "No such module: ~A" name))))
(if (null? args)
(for-each puts (map module-name
(cons repl.module (module-uses repl.module))))
(cons repl.env.module (module-uses repl.env.module))))
(for-each (lambda (name)
(cond
((pair? name) (use name))
@ -221,55 +218,23 @@ Import modules / List those imported."
args)))
(define (load repl file . opts)
"load [options] FILE
Load a file in the current module."
(apply repl-load-file repl (->string file) opts))
"load FILE
Load a file in the current module.
-f Load source file (see `compile')
-r Trace loading (see `trace')"
(let* ((file (->string file))
(objcode (if (memq :f opts)
(apply load-source-file file opts)
(apply load-file file opts))))
(if (memq :r opts)
(apply vm-trace repl.env.vm objcode opts)
(vm-load repl.env.vm objcode))))
(define (binding repl . opts)
"binding [-a]
"binding
List current bindings."
(fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.module))
(define (lsmod repl . args)
"lsmod
."
(define (use name)
(set! repl.module (resolve-module name))
(module-use! repl.module repl.value-history))
(if (null? args)
(use '(guile-user))
(let ((name (car args)))
(cond
((pair? name) (use name))
((symbol? name)
(and-let* ((m (find-one-module (symbol->string name))))
(puts m) (use m)))
(else (user-error "Invalid module name: ~A" name))))))
;;;
;;; Package commands
;;;
(define (package repl)
"package [PACKAGE]
List available packages/modules."
(for-each puts (find-module "")))
(define (lspkg repl)
"lspkg
List available packages/modules."
(for-each puts (find-module "")))
(define (autopackage repl)
"autopackage
List available packages/modules."
(for-each puts (find-module "")))
(define (globals repl)
"globals
List all global variables."
(global-fold (lambda (s v d) (format #t "~A\t~S\n" s v)) #f))
(fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.env.module))
;;;
@ -279,7 +244,7 @@ List all global variables."
(define (language repl name)
"language LANGUAGE
Change languages."
(set! repl.language (lookup-language name))
(set! repl.env.language (lookup-language name))
(repl-welcome repl))
@ -288,7 +253,7 @@ Change languages."
;;;
(define (compile repl form . opts)
"compile [options] FORM
"compile FORM
Generate compiled code.
-e Stop after expanding syntax/macro
@ -300,10 +265,10 @@ Generate compiled code.
(let ((x (apply repl-compile repl form opts)))
(cond ((or (memq :e opts) (memq :t opts)) (puts x))
((memq :c opts) (pprint-glil x))
(else (disassemble-dumpcode x)))))
(else (disassemble-objcode x)))))
(define (compile-file repl file . opts)
"compile-file [options] FILE
"compile-file FILE
Compile a file."
(apply repl-compile-file repl (->string file) opts))
@ -315,31 +280,51 @@ Disassemble a program."
(define (disassemble-file repl file)
"disassemble-file FILE
Disassemble a file."
(disassemble-dumpcode (load-dumpcode (->string file))))
(define (->string x)
(object->string x display))
(disassemble-objcode (load-objcode (->string file))))
;;;
;;; Profile commands
;;;
(define (time repl form)
"time FORM
Time execution."
(let* ((vms-start (vm-stats repl.env.vm))
(gc-start (gc-run-time))
(tms-start (times))
(result (repl-eval repl form))
(tms-end (times))
(gc-end (gc-run-time))
(vms-end (vm-stats repl.env.vm)))
(define (get proc start end)
(/ (- (proc end) (proc start)) internal-time-units-per-second))
(repl-print repl result)
(display "clock utime stime cutime cstime gctime\n")
(format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
(get tms:clock tms-start tms-end)
(get tms:utime tms-start tms-end)
(get tms:stime tms-start tms-end)
(get tms:cutime tms-start tms-end)
(get tms:cstime tms-start tms-end)
(get identity gc-start gc-end))
result))
(define (profile repl form . opts)
"profile FORM
Profile execution."
(apply vm-profile repl.vm (repl-compile repl form) opts))
(apply vm-profile repl.env.vm (repl-compile repl form) opts))
;;;
;;; Debug commands
;;;
(define guile-backtrace backtrace)
(define guile:backtrace backtrace)
(define (backtrace repl)
"backtrace
Show backtrace (if any)."
(guile-backtrace))
(guile:backtrace))
(define (debugger repl)
"debugger
@ -347,9 +332,14 @@ Start debugger."
(debug))
(define (trace repl form . opts)
"trace [-b] FORM
Trace execution."
(apply vm-trace repl.vm (repl-compile repl form) opts))
"trace FORM
Trace execution.
-s Display stack
-l Display local variables
-e Display external variables
-b Bytecode level trace"
(apply vm-trace repl.env.vm (repl-compile repl form) opts))
(define (step repl)
"step FORM
@ -361,44 +351,17 @@ Step execution."
;;; System commands
;;;
(define (time repl form)
"time FORM
Time execution."
(let* ((vms-start (vm-stats repl.vm))
(gc-start (gc-run-time))
(tms-start (times))
(result (repl-eval repl form))
(tms-end (times))
(gc-end (gc-run-time))
(vms-end (vm-stats repl.vm)))
(define (get proc start end)
(/ (- (proc end) (proc start)) internal-time-units-per-second))
(repl-print repl result)
(display "clock utime stime cutime cstime gctime\n")
(format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
(get tms:clock tms-start tms-end)
(get tms:utime tms-start tms-end)
(get tms:stime tms-start tms-end)
(get tms:cutime tms-start tms-end)
(get tms:cstime tms-start tms-end)
(get id gc-start gc-end))
result))
(define guile-gc gc)
(define guile:gc gc)
(define (gc repl)
"gc
Garbage collection."
(guile-gc))
;;;
;;; Statistics
;;;
(guile:gc))
(define (statistics repl)
"statistics
Display statistics."
(let ((this-tms (times))
(this-vms (vm-stats repl.vm))
(this-vms (vm-stats repl.env.vm))
(this-gcs (gc-stats))
(last-tms repl.tm-stats)
(last-vms repl.vm-stats)

82
module/system/repl/common.scm
View file

@ -22,70 +22,66 @@
(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)
:export (make-repl repl-welcome repl-prompt repl-read repl-compile
repl-eval repl-print repl-compile-file repl-load-file))
:use-module (system vm trace))
;;;
;;; Repl
;;; Repl type
;;;
(define-vm-class <repl> ()
vm language module value-count value-history tm-stats vm-stats gc-stats)
(define-vm-class <repl> () env tm-stats vm-stats gc-stats)
(define (make-repl lang)
(let ((vm (the-vm)))
(define-public (make-repl lang)
(let ((cenv (make-cenv :vm (the-vm)
:language (lookup-language lang)
:module (current-module))))
(make <repl>
:vm vm
:language (lookup-language lang)
:module (current-module) ;; (global-ref 'user)
:value-count 0
; :value-history (make-vmodule)
:env cenv
:tm-stats (times)
:vm-stats (vm-stats vm)
:vm-stats (vm-stats cenv.vm)
:gc-stats (gc-stats))))
(define (repl-welcome repl)
(define-public (repl-welcome repl)
(format #t "~A interpreter ~A on Guile ~A\n"
repl.language.title repl.language.version (version))
repl.env.language.title repl.env.language.version (version))
(display "Copyright (C) 2001 Free Software Foundation, Inc.\n\n")
(display "Enter `,help' for help.\n"))
(define (repl-prompt repl)
(format #t "~A@~A> " repl.language.name 'guile)
;; (env-identifier repl.module))
(force-output))
(define-public (repl-prompt repl)
(let ((module-name (car (last-pair (module-name repl.env.module)))))
(format #t "~A@~A> " repl.env.language.name module-name)
(force-output)))
(define (repl-read repl . args)
(apply read-in repl.language args))
(define-public (repl-read repl)
(repl.env.language.reader))
(define (repl-compile repl form . opts)
(apply compile-in form repl.module repl.language opts))
(define-public (repl-compile repl form . opts)
(apply compile-in form repl.env.module repl.env.language opts))
(define (repl-eval repl form)
(let ((eval repl.language.evaluator))
(define-public (repl-eval repl form)
(let ((eval repl.env.language.evaluator))
(if eval
(eval form repl.module)
(vm-load repl.vm (repl-compile repl form)))))
(eval form repl.env.module)
(vm-load repl.env.vm (repl-compile repl form)))))
(define (repl-print repl val)
(define-public (repl-print repl val)
(if (not (eq? val *unspecified*))
(let* ((num (1+ repl.value-count))
(sym (string->symbol (format #f "$~A" num))))
; (vmodule-define repl.value-history sym val)
(format #t "~A = " sym)
(print-in val repl.language)
(newline)
(set! repl.value-count num))))
(begin
(repl.env.language.printer val)
(newline))))
(define (repl-compile-file repl file . opts)
(apply compile-file-in file repl.language opts))
;;;
;;; Utilities
;;;
(define (repl-load-file repl file . opts)
(let ((bytes (apply repl-compile-file repl file opts)))
(if (or (memq :b opts) (memq :r opts))
(apply vm-trace repl.vm bytes opts)
(vm-load repl.vm bytes))))
(define-public (puts x) (display x) (newline))
(define-public (->string x)
(object->string x display))
(define-public (user-error msg . args)
(throw 'user-error #f msg args #f))

19
module/system/repl/describe.scm
View file

@ -22,16 +22,15 @@
(define-module (system repl describe)
:use-module (oop goops)
:use-module (ice-9 regex)
:use-module (ice-9 format))
:use-module (ice-9 format)
:use-module (ice-9 and-let-star)
:export (describe))
(define *describe-format* #t)
(define-public (describe symbol)
(assert symbol? symbol)
(define-method (describe (symbol <symbol>))
(format #t "`~s' is " symbol)
(if (not (defined? symbol))
(display "not defined in the current module.\n")
(describe-object (eval symbol))))
(describe-object (module-ref (current-module) symbol))))
;;;
@ -302,13 +301,13 @@
;;; Instances
;;;
(define-method display-type ((obj <object>))
(define-method (display-type (obj <object>))
(display-class <object> "an instance")
(display " of class ")
(display-class (class-of obj))
(display ".\n"))
(define-method display-value ((obj <object>))
(define-method (display-value (obj <object>))
(display-slot-list #f obj (class-slots (class-of obj))))
@ -316,13 +315,13 @@
;;; Generic functions
;;;
(define-method display-type ((obj <generic>))
(define-method (display-type (obj <generic>))
(display-class <generic> "a generic function")
(display " of class ")
(display-class (class-of obj))
(display ".\n"))
(define-method display-value ((obj <generic>))
(define-method (display-value (obj <generic>))
(display-list #f (generic-function-methods obj)))

6
module/system/repl/repl.scm
View file

@ -23,14 +23,11 @@
:use-syntax (system base syntax)
:use-module (system repl common)
:use-module (system repl command)
:use-module (system vm frame)
:use-module (ice-9 rdelim)
:export (start-repl))
(define (start-repl lang)
(let ((repl (make-repl lang)))
;; (set-current-vmodule! repl.module)
;; (set-current-evaluator! repl.vm)
(repl-welcome repl)
(let prompt-loop ()
(repl-prompt repl)
@ -38,8 +35,7 @@
(lambda ()
(if (eq? (next-char #t) #\,)
;; meta command
(begin (read-char)
(meta-command repl (read-line)))
(begin (read-char) (meta-command repl (read-line)))
;; evaluation
(let rep-loop ()
(repl-print repl (repl-eval repl (repl-read repl)))

2
module/system/vm/assemble.scm
View file

@ -146,7 +146,7 @@
(for-each generate-code body)
(let ((bytes (stack->bytes (reverse! stack) label-alist)))
(if toplevel
(make-dumpcode nlocs nexts bytes)
(bytecode->objcode bytes nlocs nexts)
(let ((objs (map car (reverse! object-alist))))
(make-bytespec nargs nrest nlocs nexts bytes objs
(venv-closure? venv)))))))))

2
module/system/vm/conv.scm
View file

@ -83,7 +83,7 @@
(('load-string s) s)
(('load-symbol s) (string->symbol s))
(('load-keyword s) (make-keyword-from-dash-symbol (string->symbol s)))
(('link s) (string->symbol s))
(('link s) (cons (string->symbol s) '???))
(else #f)))
(define (code->bytes code)

68
module/system/vm/core.scm
View file

@ -21,6 +21,7 @@
(define-module (system vm core))
;;;
;;; Core procedures
;;;
@ -32,60 +33,37 @@
(hash-fold (lambda (k v d) (cons k d)) '()
(module-obarray (current-module)))))
;;;
;;; Dumpcode interface
;;; Loader
;;;
(export make-dumpcode dumpcode? dumpcode-version
dumpcode-nlocs dumpcode-nexts dumpcode-bytecode
load-dumpcode save-dumpcode)
(define-public (vm-load vm objcode)
(vm (objcode->program objcode)))
(define *dumpcode-cookie* (string-append "\0GBC-" (vm-version)))
(set! load-compiled (lambda (file) (vm-load (the-vm) (load-objcode file))))
(define (make-dumpcode nlocs nexts bytes)
(string-append *dumpcode-cookie*
(integer->bytes nlocs)
(integer->bytes nexts)
bytes))
;;;
;;; Frame interface
;;;
(define (dumpcode? x)
(and (string? x)
(> (string-length x) 10)
(string=? (substring x 1 4) "GBC")))
(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 (dumpcode-version x)
(substring x 5 8))
(define (dumpcode-nlocs x)
(bytes->integer x 8))
(define (dumpcode-nexts x)
(bytes->integer x 9))
(define (dumpcode-bytecode x)
(substring x 10))
(define (load-dumpcode file)
(let ((bytes (make-uniform-vector (stat:size (stat file)) #\a)))
(call-with-input-file file
(lambda (p) (uniform-vector-read! bytes p)))
bytes))
(define (save-dumpcode dump file)
(call-with-output-file file
(lambda (out) (uniform-vector-write dump out))))
(define (integer->bytes n)
(string (integer->char n)))
(define (bytes->integer bytes start)
(char->integer (string-ref bytes start)))
(define (program-name x)
(hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x
(module-obarray (current-module))))
;;;
;;; Statistics interface
;;;
(export vms:time vms:clock)
(define (vms:time stat) (vector-ref stat 0))
(define (vms:clock stat) (vector-ref stat 1))
(define-public (vms:time stat) (vector-ref stat 0))
(define-public (vms:clock stat) (vector-ref stat 1))

18
module/system/vm/disasm.scm
View file

@ -27,15 +27,17 @@
:use-module (ice-9 format)
:use-module (ice-9 receive)
:use-module (ice-9 and-let-star)
:export (disassemble-dumpcode disassemble-program))
:export (disassemble-objcode disassemble-program))
(define (disassemble-dumpcode dumpcode . opts)
(if (not (dumpcode? dumpcode)) (error "Invalid dumpcode"))
(format #t "Disassembly of dumpcode:\n\n")
(format #t "Compiled for Guile VM ~A\n\n" (dumpcode-version dumpcode))
(format #t "nlocs = ~A nexts = ~A\n\n"
(dumpcode-nlocs dumpcode) (dumpcode-nexts dumpcode))
(disassemble-bytecode (dumpcode-bytecode dumpcode) #f))
(define (disassemble-objcode objcode . opts)
(let* ((prog (objcode->program objcode))
(arity (program-arity prog))
(nlocs (caddr arity))
(nexts (cadddr arity))
(bytes (program-bytecode prog)))
(format #t "Disassembly of ~A:\n\n" objcode)
(format #t "nlocs = ~A nexts = ~A\n\n" nlocs nexts)
(disassemble-bytecode bytes #f)))
(define (disassemble-program prog . opts)
(let* ((arity (program-arity prog))

36
module/system/vm/frame.scm
View file

@ -1,36 +0,0 @@
;;; Guile VM frame 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 vm frame)
:use-module (system vm core)
:export (frame->call))
(define (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)
(hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x
(module-obarray (current-module))))

60
module/system/vm/load.scm
View file

@ -1,60 +0,0 @@
;;; Guile VM compiling loader
;; 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 load)
:autoload (system base compile) (compile-file)
:use-module (system vm core)
:use-module (ice-9 regex)
:export (load-compiled-file compile-and-load load/compile))
(define (load-compiled-file file . opts)
(vm-load (the-vm) (load-dumpcode file)))
(define (compile-and-load file . opts)
(let ((comp (object-file-name file)))
(if (or (not (file-exists? comp))
(> (stat:mtime (stat file)) (stat:mtime (stat comp))))
(compile-file file))
(load-compiled-file comp)))
(define (load/compile file . opts)
(let* ((file (file-full-name file))
(compiled (object-file-name file)))
(if (or (not (file-exists? compiled))
(> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
(apply compile-file file #f opts))
(if (memq #:b opts)
(apply vm-trace (the-vm) (load-dumpcode compiled) opts)
(vm-load (the-vm) (load-dumpcode compiled)))))
(define (file-full-name filename)
(let* ((port (current-load-port))
(oldname (and port (port-filename port))))
(if (and oldname
(> (string-length filename) 0)
(not (char=? (string-ref filename 0) #\/))
(not (string=? (dirname oldname) ".")))
(string-append (dirname oldname) "/" filename)
filename)))
(define-public (object-file-name file)
(let ((m (string-match "\\.[^.]*$" file)))
(string-append (if m (match:prefix m) file) ".go")))

4
module/system/vm/profile.scm
View file

@ -24,7 +24,7 @@
:use-module (ice-9 format)
:export (vm-profile))
(define (vm-profile vm bytes . opts)
(define (vm-profile vm objcode . opts)
(let ((flag (vm-option vm 'debug)))
(dynamic-wind
(lambda ()
@ -34,7 +34,7 @@
(add-hook! (vm-enter-hook vm) profile-enter)
(add-hook! (vm-exit-hook vm) profile-exit))
(lambda ()
(let ((val (vm-load vm bytes)))
(let ((val (vm (objcode->program objcode))))
(display-result vm)
val))
(lambda ()

6
module/system/vm/trace.scm
View file

@ -22,15 +22,13 @@
(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)
:use-module (ice-9 and-let-star)
:export (vm-trace vm-trace-on vm-trace-off))
(define (vm-trace vm bytes . opts)
(define (vm-trace vm objcode . opts)
(dynamic-wind
(lambda () (apply vm-trace-on vm opts))
(lambda () (vm-load vm bytes))
(lambda () (vm (objcode->program objcode)))
(lambda () (apply vm-trace-off vm opts))))
(define (vm-trace-on vm . opts)

13
src/Makefile.am
View file

@ -5,12 +5,14 @@ guile_vm_LDADD = libguilevm.la
guile_vm_LDFLAGS = $(GUILE_LDFLAGS)
lib_LTLIBRARIES = libguilevm.la
libguilevm_la_SOURCES = envs.c instructions.c programs.c vm.c \
envs.h instructions.h programs.h vm.h vm_engine.h vm_expand.h
libguilevm_la_SOURCES = \
envs.c instructions.c objcodes.c programs.c vm.c \
envs.h instructions.h objcodes.h programs.h vm.h \
vm_engine.h vm_expand.h
libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic
EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c
BUILT_SOURCES = vm_system.i vm_scheme.i vm_loader.i \
envs.x instructions.x programs.x vm.x
envs.x instructions.x objcodes.x programs.x vm.x
INCLUDES = $(GUILE_CFLAGS)
DISTCLEANFILES = $(BUILT_SOURCES)
@ -27,4 +29,9 @@ SUFFIXES = .i .x
$(SNARF) $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
|| { rm $@; false; }
GUILE = "$(bindir)/guile"
guilec: guilec.in
sed "s!@guile@!$(GUILE)!" guilec.in > guilec
@chmod 755 guilec
$(BUILT_SOURCES): config.h vm_expand.h

6
src/envs.h
View file

@ -39,8 +39,8 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
#ifndef _ENVS_H_
#define _ENVS_H_
#ifndef _SCM_ENVS_H_
#define _SCM_ENVS_H_
#include <libguile.h>
#include "config.h"
@ -64,7 +64,7 @@ extern SCM scm_c_env_vcell (SCM env, SCM name, int intern);
extern void scm_init_envs (void);
#endif /* _ENVS_H_ */
#endif /* _SCM_ENVS_H_ */
/*
Local Variables:

2
src/guile-vm.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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

2
src/guilec.in
View file

@ -1,4 +1,4 @@
#!@bindir@/guile -*- scheme -*-
#!@guile@ -s
!#
(use-modules (system base compile))

2
src/instructions.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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

8
src/instructions.h
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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
@ -39,8 +39,8 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
#ifndef _INSTRUCTIONS_H_
#define _INSTRUCTIONS_H_
#ifndef _SCM_INSTRUCTIONS_H_
#define _SCM_INSTRUCTIONS_H_
#include <libguile.h>
#include "config.h"
@ -78,7 +78,7 @@ extern struct scm_instruction *scm_lookup_instruction (SCM name);
extern void scm_init_instructions (void);
#endif /* _INSTRUCTIONS_H_ */
#endif /* _SCM_INSTRUCTIONS_H_ */
/*
Local Variables:

225
src/objcodes.c Normal file
View file

@ -0,0 +1,225 @@
/* 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 software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
#include <string.h>
#include <fcntl.h>
#include <unistd.h>
#include <sys/mman.h>
#include <sys/stat.h>
#include <sys/types.h>
#include "programs.h"
#include "objcodes.h"
#define OBJCODE_COOKIE "GOOF-0.5"
/*
* Objcode type
*/
scm_bits_t scm_tc16_objcode;
static SCM
make_objcode (size_t size)
#define FUNC_NAME "make_objcode"
{
struct scm_objcode *p = SCM_MUST_MALLOC (sizeof (struct scm_objcode));
p->size = size;
p->base = SCM_MUST_MALLOC (size);
p->fd = -1;
SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
}
#undef FUNC_NAME
static SCM
make_objcode_by_mmap (int fd)
#define FUNC_NAME "make_objcode_by_mmap"
{
int ret;
char *addr;
struct stat st;
struct scm_objcode *p;
ret = fstat (fd, &st);
if (ret < 0) SCM_SYSERROR;
addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
if (addr == MAP_FAILED) SCM_SYSERROR;
p = SCM_MUST_MALLOC (sizeof (struct scm_objcode));
p->size = st.st_size;
p->base = addr;
p->fd = fd;
SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
}
#undef FUNC_NAME
static scm_sizet
objcode_free (SCM obj)
#define FUNC_NAME "objcode_free"
{
size_t size = (sizeof (struct scm_objcode));
struct scm_objcode *p = SCM_OBJCODE_DATA (obj);
if (p->fd >= 0)
{
int rv;
rv = munmap (p->base, p->size);
if (rv < 0) SCM_SYSERROR;
rv = close (p->fd);
if (rv < 0) SCM_SYSERROR;
}
else
{
size += p->size;
scm_must_free (p->base);
}
scm_must_free (p);
return size;
}
#undef FUNC_NAME
/*
* Scheme interface
*/
SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_objcode_p
{
return SCM_BOOL (SCM_OBJCODE_P (obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
(SCM bytecode, SCM nlocs, SCM nexts),
"")
#define FUNC_NAME s_scm_bytecode_to_objcode
{
size_t size;
char *base;
SCM objcode;
SCM_VALIDATE_STRING (1, bytecode);
SCM_VALIDATE_INUM (2, nlocs);
SCM_VALIDATE_INUM (3, nexts);
size = SCM_STRING_LENGTH (bytecode) + 10;
objcode = make_objcode (size);
base = SCM_OBJCODE_BASE (objcode);
memcpy (base, OBJCODE_COOKIE, 8);
base[8] = SCM_INUM (nlocs);
base[9] = SCM_INUM (nexts);
memcpy (base + 10, SCM_STRING_CHARS (bytecode), size - 10);
return objcode;
}
#undef FUNC_NAME
SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
(SCM file),
"")
#define FUNC_NAME s_scm_load_objcode
{
int fd;
SCM_VALIDATE_STRING (1, file);
fd = open (SCM_STRING_CHARS (file), O_RDONLY);
if (fd < 0) SCM_SYSERROR;
return make_objcode_by_mmap (fd);
}
#undef FUNC_NAME
SCM_DEFINE (scm_objcode_to_string, "objcode->string", 1, 0, 0,
(SCM objcode),
"")
#define FUNC_NAME s_scm_objcode_to_string
{
SCM_VALIDATE_OBJCODE (1, objcode);
return scm_makfromstr (SCM_OBJCODE_BASE (objcode),
SCM_OBJCODE_SIZE (objcode),
0);
}
#undef FUNC_NAME
SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0,
(SCM objcode),
"")
#define FUNC_NAME s_scm_objcode_to_program
{
SCM prog;
size_t size;
char *base;
SCM_VALIDATE_OBJCODE (1, objcode);
base = SCM_OBJCODE_BASE (objcode);
size = SCM_OBJCODE_SIZE (objcode);
prog = scm_c_make_program (base + 10, size - 10, objcode);
SCM_PROGRAM_NLOCS (prog) = base[8];
SCM_PROGRAM_NEXTS (prog) = base[9];
return prog;
}
#undef FUNC_NAME
void
scm_init_objcodes (void)
{
scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
scm_set_smob_free (scm_tc16_objcode, objcode_free);
#ifndef SCM_MAGIC_SNARFER
#include "objcodes.x"
#endif
}
/*
Local Variables:
c-file-style: "gnu"
End:
*/

72
src/objcodes.h Normal file
View file

@ -0,0 +1,72 @@
/* 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 software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
#ifndef _SCM_OBJCODES_H_
#define _SCM_OBJCODES_H_
#include <libguile.h>
#include "config.h"
struct scm_objcode {
size_t size; /* objcode size */
char *base; /* objcode base address */
int fd; /* file descriptor when mmap'ed */
};
extern scm_bits_t scm_tc16_objcode;
#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x))
#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
#define SCM_OBJCODE_SIZE(x) (SCM_OBJCODE_DATA (x)->size)
#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
#define SCM_OBJCODE_FD(x) (SCM_OBJCODE_DATA (x)->fd)
extern void scm_init_objcodes (void);
#endif /* _SCM_OBJCODES_H_ */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

2
src/programs.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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

8
src/programs.h
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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
@ -39,8 +39,8 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
#ifndef _PROGRAM_H_
#define _PROGRAM_H_
#ifndef _SCM_PROGRAMS_H_
#define _SCM_PROGRAMS_H_
#include <libguile.h>
#include "config.h"
@ -87,7 +87,7 @@ extern SCM scm_c_make_closure (SCM program, SCM external);
extern void scm_init_programs (void);
#endif /* _PROGRAM_H_ */
#endif /* _SCM_PROGRAMS_H_ */
/*
Local Variables:

33
src/vm.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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
@ -42,6 +42,7 @@
#include <string.h>
#include "instructions.h"
#include "programs.h"
#include "objcodes.h"
#include "envs.h"
#include "vm.h"
@ -598,35 +599,6 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_load, "vm-load", 2, 0, 0,
(SCM vm, SCM bootcode),
"")
#define FUNC_NAME s_scm_vm_load
{
SCM prog;
int len;
char *base;
SCM_VALIDATE_VM (1, vm);
SCM_VALIDATE_STRING (2, bootcode);
base = SCM_STRING_CHARS (bootcode);
len = SCM_STRING_LENGTH (bootcode);
/* Check bootcode */
if (strncmp (base, "\0GBC", 4) != 0)
SCM_MISC_ERROR ("Invalid bootcode: ~S", SCM_LIST1 (bootcode));
/* Create program */
prog = scm_c_make_program (base + 10, len - 10, bootcode);
SCM_PROGRAM_NLOCS (prog) = base[8];
SCM_PROGRAM_NEXTS (prog) = base[9];
/* Load it */
return scm_vm_apply (vm, prog, SCM_EOL);
}
#undef FUNC_NAME
/*
* Initialize
@ -637,6 +609,7 @@ scm_init_vm (void)
{
scm_init_instructions ();
scm_init_programs ();
scm_init_objcodes ();
scm_tc16_vm_heap_frame = scm_make_smob_type ("vm_frame", 0);
scm_set_smob_mark (scm_tc16_vm_heap_frame, vm_heap_frame_mark);

8
src/vm.h
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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
@ -39,8 +39,8 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
#ifndef _VM_H_
#define _VM_H_
#ifndef _SCM_VM_H_
#define _SCM_VM_H_
#include <libguile.h>
#include "config.h"
@ -151,7 +151,7 @@ extern SCM scm_vm_current_frame (SCM vm);
extern void scm_init_vm (void);
#endif /* _VM_H_ */
#endif /* _SCM_VM_H_ */
/*
Local Variables:

2
src/vm_engine.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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

2
src/vm_engine.h
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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

2
src/vm_expand.h
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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

2
src/vm_loader.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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

2
src/vm_scheme.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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

2
src/vm_system.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2000 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