-Installation
-------------
-
-1. Install the latest Guile from CVS.
-
-2. Install Guile VM:
-
- % configure
- % make install
- % ln -s module/{system,language} /usr/local/share/guile/site/
-
-3. Add the following lines to your ~/.guile:
-
- (cond ((string=? (car (command-line)) "guile-vm")
- (use-modules (system repl repl))
- (start-repl 'scheme)
- (quit)))
-
-Example Session
----------------
-
- % guile-vm
- Guile Scheme interpreter 0.4 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)
- (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
-
- nlocs = 0 nexts = 0
-
- 0 make-int8:1 ;; 1
- 1 make-int8 2 ;; 2
- 3 add
- 4 return
-
- gscheme@guile> (define (add x y) (+ x y))
- gscheme@guile> (add 1 2)
- $2 = 3
- gscheme@guile> ,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
-
- gscheme@guile>
-
-Write Modules
--------------
-
- ---- fib.scm ---------------------------
- (define-module (fib)
- :use-module (system vm load)
- :export (fib))
-
- (load/compile "fib.gs")
- ----------------------------------------
-
- ---- fib.gs ----------------------------
- (define (fib n)
- (if (< n 2)
- 1
- (+ (fib (- n 1)) (fib (- n 2)))))
- ----------------------------------------
-
-Now, expressions in fib.gsm are automatically compiled and
-executed by the Guile VM:
-
- % 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'.
+Installation
+------------
+
+1. Install the latest Guile from CVS.
+
+2. Install Guile VM:
+
+ % configure
+ % make install
+ % 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)
+ (quit)))
+
+Example Session
+---------------
+
+ % guile-vm
+ Guile Scheme interpreter 0.5 on Guile 1.4.1
+ Copyright (C) 2001 Free Software Foundation, Inc.
+
+ Enter `,help' for help.
+ 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)
+ (tail-call 2))
+ scheme@guile-user> ,c (+ 1 2) ;; Compile into object code
+ Disassembly of #<objcode 403c5fb0>:
+
+ nlocs = 0 nexts = 0
+
+ 0 link "+" ;; (+ . ???)
+ 3 variable-ref
+ 4 make-int8:1 ;; 1
+ 5 make-int8 2 ;; 2
+ 7 tail-call 2
+
+ 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 object-ref 0 ;; (+ . #<primitive-procedure +>)
+ 2 variable-ref
+ 3 local-ref 0
+ 5 local-ref 1
+ 7 tail-call 2
+
+ Objects:
+
+ 0 (+ . #<primitive-procedure +>)
+
+ scheme@guile-user>
+
+Compile Modules
+---------------
+
+Use `guilec' to compile your modules:
+
+ % 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> (fib 8)
+ 34
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)
-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
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 -)
(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
:title "Guile Scheme"
:version "0.5"
:reader read
+ :read-file read-file
:translator translate
:printer write
- :compiler compile
)
;;; 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)))
(() (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)
;;; 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"))
;;; 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))))
+
+\f
+;;;
+;;; 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)))
-
-(define (object-file-name file)
+ (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-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")))
+
+\f
+;;;
+;;; 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)))
(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))
\f
;;;
(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)
(if (module-bound? m name)
(module-ref m name)
(error "No such language:" name))))
-
-\f
-;;;
-;;; 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))))
(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))
\f
;;;
-;;; 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))
(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))
(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))
(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"))
"module [MODULE]
Change modules / Show current module."
(match args
- (() (puts (binding repl.module)))))
+ (() (puts (binding repl.env.module)))))
(define (use repl . args)
"use [MODULE ...]
(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))
(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))
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))))))
-
-\f
-;;;
-;;; 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))
\f
;;;
(define (language repl name)
"language LANGUAGE
Change languages."
- (set! repl.language (lookup-language name))
+ (set! repl.env.language (lookup-language name))
(repl-welcome repl))
\f
;;;
(define (compile repl form . opts)
- "compile [options] FORM
+ "compile FORM
Generate compiled code.
-e Stop after expanding syntax/macro
(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))
(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))))
\f
;;;
;;; 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))
\f
;;;
;;; 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
(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
;;; 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)
(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))
\f
;;;
-;;; 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))))
-
-(define (repl-compile-file repl file . opts)
- (apply compile-file-in file repl.language opts))
-
-(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))))
+ (begin
+ (repl.env.language.printer val)
+ (newline))))
+
+\f
+;;;
+;;; Utilities
+;;;
+
+(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))
(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))))
\f
;;;
;;; 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))))
\f
;;; 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)))
\f
: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)
(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)))
(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)))))))))
(('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)
-;;; Guile VM frame utilities
+;;; Guile VM core
;; Copyright (C) 2001 Free Software Foundation, Inc.
;;; Code:
-(define-module (system vm frame)
- :use-module (system vm core)
- :export (frame->call))
+(define-module (system vm core))
-(define (frame->call frame)
+\f
+;;;
+;;; Core procedures
+;;;
+
+(dynamic-call "scm_init_vm" (dynamic-link "libguilevm.so"))
+
+(module-export! (current-module)
+ (delq! '%module-public-interface
+ (hash-fold (lambda (k v d) (cons k d)) '()
+ (module-obarray (current-module)))))
+
+\f
+;;;
+;;; Loader
+;;;
+
+(define-public (vm-load vm objcode)
+ (vm (objcode->program objcode)))
+
+(set! load-compiled (lambda (file) (vm-load (the-vm) (load-objcode file))))
+
+\f
+;;;
+;;; Frame interface
+;;;
+
+(define-public (frame->call frame)
(let* ((prog (frame-program frame))
(nargs (car (program-arity prog))))
(do ((i 0 (1+ i))
(define (program-name x)
(hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x
(module-obarray (current-module))))
+
+\f
+;;;
+;;; Statistics interface
+;;;
+
+(define-public (vms:time stat) (vector-ref stat 0))
+(define-public (vms:clock stat) (vector-ref stat 1))
: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))
+++ /dev/null
-;;; 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")))
: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 ()
(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 ()
(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)
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)
$(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
* 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"
extern void scm_init_envs (void);
-#endif /* _ENVS_H_ */
+#endif /* _SCM_ENVS_H_ */
/*
Local Variables:
-/* 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
-#!@bindir@/guile -*- scheme -*-
+#!@guile@ -s
!#
(use-modules (system base compile))
-/* 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
-/* 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
* 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"
extern void scm_init_instructions (void);
-#endif /* _INSTRUCTIONS_H_ */
+#endif /* _SCM_INSTRUCTIONS_H_ */
/*
Local Variables:
--- /dev/null
+/* 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"
+
+\f
+/*
+ * 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
+
+\f
+/*
+ * 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
+
+\f
+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:
+*/
--- /dev/null
+/* 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:
+*/
-/* 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
-/* 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
* 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"
extern void scm_init_programs (void);
-#endif /* _PROGRAM_H_ */
+#endif /* _SCM_PROGRAMS_H_ */
/*
Local Variables:
-/* 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
#include <string.h>
#include "instructions.h"
#include "programs.h"
+#include "objcodes.h"
#include "envs.h"
#include "vm.h"
}
#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
-
\f
/*
* Initialize
{
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);
-/* 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
* 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"
extern void scm_init_vm (void);
-#endif /* _VM_H_ */
+#endif /* _SCM_VM_H_ */
/*
Local Variables:
-/* 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
-/* 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
-/* 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
-/* 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
-/* 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
-/* 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
HCoop / bpt / guile.git / commitdiff