mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-14 15:40:19 +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

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)