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-15 15:02:41 +00:00
parent c722838216
commit cb4cca12e7
23 changed files with 434 additions and 439 deletions
Download patch file Download diff file Expand all files Collapse all files

4
.cvsignore
View file

@ -1,8 +1,6 @@
misc
libtool
config.log
config.cache
config.status
config.*
configure
Makefile
Makefile.in

4
configure.in
View file

@ -1,5 +1,5 @@
AC_INIT(src/guile-vm.c)
AM_INIT_AUTOMAKE(guile-vm, 0.4)
AM_INIT_AUTOMAKE(guile-vm, 0.5)
AM_CONFIG_HEADER(src/config.h)
GUILE_FLAGS
@ -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)
AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile src/guilec)

10
module/Makefile.am
View file

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

48
module/system/base/compile.scm Normal file
View file

@ -0,0 +1,48 @@
;;; High-level compiler interface
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:
(define-module (system base compile)
:use-module (system base language)
:use-module (ice-9 regex)
:export (compile-file object-file-name))
(define scheme (lookup-language 'scheme))
(define (compile-file file)
(let ((comp (object-file-name file)))
(call-with-compile-error-catch
(lambda ()
(catch #t
(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 ((m (string-match "\\.[^.]*$" file)))
(string-append (if m (match:prefix m) file) ".go")))

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

@ -26,8 +26,8 @@
: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 load-file-in))
:export (define-language lookup-language read-in compile-in print-in
compile-file-in))
;;;
@ -37,10 +37,11 @@
(define-vm-class <language> ()
name title version environment
(reader)
(expander (lambda (x) x))
(translator (lambda (x) x))
(evaler #f)
(expander (lambda (x e) x))
(translator (lambda (x e) x))
(evaluator #f)
(printer)
(compiler)
)
(define-method (write (lang <language>) port)
@ -65,41 +66,34 @@
(define (read-in lang . port)
(lang.reader (if (null? port) (current-input-port) (car port))))
(define (compile-in form env lang . opts)
(define (compile-in x e lang . opts)
(catch 'result
(lambda ()
;; expand
(set! form (lang.expander form))
(if (memq :e opts) (throw 'result form))
(set! x (lang.expander x e))
(if (memq :e opts) (throw 'result x))
;; translate
(set! form (lang.translator form))
(if (memq :t opts) (throw 'result form))
(set! x (lang.translator x e))
(if (memq :t opts) (throw 'result x))
;; compile
(set! form (apply compile form env opts))
(if (memq :c opts) (throw 'result form))
(set! x (apply compile x e opts))
(if (memq :c opts) (throw 'result x))
;; assemble
(apply assemble form env opts))
(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 env lang . opts)
(let* ((code (call-with-input-file file
(lambda (in)
(do ((x (read-in lang in) (read-in lang in))
(l '() (cons (lang.translator (lang.expander x)) l)))
((eof-object? x) (reverse! l))))))
(asm (apply compile (cons '@begin code) env opts)))
(save-dumpcode (apply assemble asm env opts) (object-file-name file))))
(define (compile-file-in file lang . opts)
(call-with-input-file file
(lambda (port) (apply lang.compiler port (current-module) opts))))
(define (load-file-in file env lang . opts)
(let ((compiled (object-file-name file)))
(if (or (not (file-exists? compiled))
(> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
(compile-file-in file env lang :O))
(load-dumpcode compiled)))
(define-public (syntax-error loc msg exp)
(throw 'syntax-error loc msg exp))
(define (object-file-name file)
(let ((m (string-match "\\.[^.]*$" file)))
(string-append (if m (match:prefix m) file) ".go")))
(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))))

133
module/system/il/compile.scm
View file

@ -24,11 +24,11 @@
:use-syntax (system base syntax)
:use-module (system il glil)
:use-module (system il ghil)
:use-module (ice-9 match)
:use-module (ice-9 common-list)
:export (compile))
(define (compile x e . opts)
(set! x (parse-ghil x e))
(if (memq :O opts) (set! x (optimize x)))
(codegen x))
@ -103,36 +103,75 @@
(define (push-code! code)
(set! stack (cons code stack)))
(define (comp tree tail drop)
(define (push-label! label)
(push-code! (make-<glil-label> label)))
(define (push-branch! inst label)
(push-code! (make-<glil-branch> inst label)))
(define (push-call! inst args)
(for-each comp-push args)
(push-code! (make-<glil-call> inst (length args))))
;; possible tail position
(define (comp-tail tree) (comp tree tail drop))
;; push the result
(define (comp-push tree) (comp tree #f #f))
;; drop the result
(define (comp-drop tree) (comp tree #f #t))
;; drop the result if unnecessary
(define (maybe-drop)
(if drop (push-code! *ia-drop*)))
;; return here if necessary
(define (maybe-return)
(if tail (push-code! *ia-return*)))
;; return this code if necessary
(define (return-code! code)
(if (not drop) (push-code! code))
(if tail (push-code! *ia-return*)))
(maybe-return))
;; return void if necessary
(define (return-void!) (return-code! *ia-void*))
(define (return-void!)
(return-code! *ia-void*))
;; return object if necessary
(define (return-object! obj)
(return-code! (make-<glil-const> obj)))
;;
;; dispatch
(match tree
(($ <ghil-void>)
(return-void!))
(($ <ghil-quote> obj)
(return-code! (make-<glil-const> obj)))
(($ <ghil-quote> env loc obj)
(return-object! obj))
(($ <ghil-ref> env var)
(($ <ghil-quasiquote> env loc exp)
(let loop ((x exp))
(match x
((? list? ls)
(push-call! 'mark '())
(for-each loop ls)
(push-call! 'list-mark '()))
((? pair? pp)
(loop (car pp))
(loop (cdr pp))
(push-code! (make-<glil-call> 'cons 2)))
(($ <ghil-unquote> env loc exp)
(comp-push exp))
(($ <ghil-unquote-splicing> env loc exp)
(comp-push exp)
(push-call! 'list-break '()))
(else
(push-code! (make-<glil-const> x)))))
(maybe-drop)
(maybe-return))
(($ <ghil-ref> env loc var)
(return-code! (make-glil-var 'ref env var)))
(($ <ghil-set> env var val)
((or ($ <ghil-set> env loc var val)
($ <ghil-define> env loc var val))
(comp-push val)
(push-code! (make-glil-var 'set env var))
(return-void!))
(($ <ghil-if> test then else)
(($ <ghil-if> env loc test then else)
;; TEST
;; (br-if-not L1)
;; THEN
@ -141,14 +180,59 @@
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
(comp-push test)
(push-code! (make-<glil-branch> 'br-if-not L1))
(push-branch! 'br-if-not L1)
(comp-tail then)
(if (not tail) (push-code! (make-<glil-branch> 'br L2)))
(push-code! (make-<glil-label> L1))
(if (not tail) (push-branch! 'br L2))
(push-label! L1)
(comp-tail else)
(if (not tail) (push-code! (make-<glil-label> L2)))))
(if (not tail) (push-label! L2))))
(($ <ghil-begin> exps)
(($ <ghil-and> env loc exps)
;; EXP
;; (br-if-not L1)
;; ...
;; TAIL
;; (br L2)
;; L1: (const #f)
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
(if (null? exps)
(return-object! #t)
(do ((exps exps (cdr exps)))
((null? (cdr exps))
(comp-tail (car exps))
(if (not tail) (push-branch! 'br L2))
(push-label! L1)
(return-object! #f)
(if (not tail) (push-label! L2))
(maybe-drop)
(maybe-return))
(comp-push (car exps))
(push-branch! 'br-if-not L1)))))
(($ <ghil-or> env loc exps)
;; EXP
;; (dup)
;; (br-if L1)
;; (drop)
;; ...
;; TAIL
;; L1:
(let ((L1 (make-label)))
(if (null? exps)
(return-object! #f)
(do ((exps exps (cdr exps)))
((null? (cdr exps))
(comp-tail (car exps))
(push-label! L1)
(maybe-drop)
(maybe-return))
(comp-push (car exps))
(push-call! 'dup '())
(push-branch! 'br-if L1)
(push-call! 'drop '())))))
(($ <ghil-begin> env loc exps)
;; EXPS...
;; TAIL
(if (null? exps)
@ -158,7 +242,7 @@
(comp-tail (car exps)))
(comp-drop (car exps)))))
(($ <ghil-bind> env vars vals body)
(($ <ghil-bind> env loc vars vals body)
;; VALS...
;; (set VARS)...
;; BODY
@ -167,30 +251,27 @@
(reverse vars))
(comp-tail body))
(($ <ghil-lambda> env vars rest body)
(($ <ghil-lambda> env loc vars rest body)
(return-code! (codegen tree)))
(($ <ghil-inst> inst args)
(($ <ghil-inline> env loc inst args)
;; ARGS...
;; (INST NARGS)
(for-each comp-push args)
(push-code! (make-<glil-call> inst (length args)))
(if drop (push-code! *ia-drop*))
(if tail (push-code! *ia-return*)))
(push-call! inst args)
(maybe-drop)
(maybe-return))
(($ <ghil-call> env proc args)
(($ <ghil-call> env loc proc args)
;; PROC
;; ARGS...
;; ([tail-]call NARGS)
(comp-push proc)
(for-each comp-push args)
(let ((inst (if tail 'tail-call 'call)))
(push-code! (make-<glil-call> inst (length args))))
(if drop (push-code! *ia-drop*)))))
(push-call! (if tail 'tail-call 'call) args)
(maybe-drop))))
;;
;; main
(match ghil
(($ <ghil-lambda> env args rest body)
(($ <ghil-lambda> env loc args rest body)
(let* ((vars env.variables)
(locs (pick (lambda (v) (eq? v.kind 'local)) vars))
(exts (pick (lambda (v) (eq? v.kind 'external)) vars)))

130
module/system/il/ghil.scm
View file

@ -26,19 +26,37 @@
:use-module (ice-9 regex)
:export
(parse-ghil
ghil-primitive?
make-<ghil-void> <ghil-void>?
make-<ghil-quote> <ghil-quote>? <ghil-quote>-1
make-<ghil-ref> <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2
make-<ghil-set> <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3
make-<ghil-if> <ghil-if>? <ghil-if>-1 <ghil-if>-2 <ghil-if>-3
make-<ghil-begin> <ghil-begin>? <ghil-begin>-1
ghil-lookup ghil-primitive?
make-<ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2
make-<ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
make-<ghil-quasiquote> <ghil-quasiquote>?
<ghil-quasiquote>-1 <ghil-quasiquote>-2 <ghil-quasiquote>-3
make-<ghil-unquote> <ghil-unquote>?
<ghil-unquote>-1 <ghil-unquote>-2 <ghil-unquote>-3
make-<ghil-unquote-splicing> <ghil-unquote-splicing>?
<ghil-unquote-splicing>-1 <ghil-unquote-splicing>-2
<ghil-unquote-splicing>-3
make-<ghil-ref> <ghil-ref>?
<ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
make-<ghil-set> <ghil-set>?
<ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4
make-<ghil-define> <ghil-define>?
<ghil-define>-1 <ghil-define>-2 <ghil-define>-3 <ghil-define>-4
make-<ghil-if> <ghil-if>?
<ghil-if>-1 <ghil-if>-2 <ghil-if>-3 <ghil-if>-4 <ghil-if>-5
make-<ghil-and> <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3
make-<ghil-or> <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3
make-<ghil-begin> <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3
make-<ghil-bind> <ghil-bind>?
<ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4
make-<ghil-lambda> <ghil-lambda>?
<ghil-lambda>-1 <ghil-lambda>-2 <ghil-lambda>-3 <ghil-lambda>-4
make-<ghil-call> <ghil-call>? <ghil-call>-1 <ghil-call>-2 <ghil-call>-3
make-<ghil-inst> <ghil-inst>? <ghil-inst>-1 <ghil-inst>-2
<ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4 <ghil-bind>-5
make-<ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
<ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5
make-<ghil-inline> <ghil-inline>?
<ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4
make-<ghil-call> <ghil-call>?
<ghil-call>-1 <ghil-call>-2 <ghil-call>-3 <ghil-call>-4
))
@ -46,16 +64,27 @@
;;; Parse tree
;;;
(define-structure (<ghil-void>))
(define-structure (<ghil-quote> obj))
(define-structure (<ghil-ref> env var))
(define-structure (<ghil-set> env var val))
(define-structure (<ghil-if> test then else))
(define-structure (<ghil-begin> exps))
(define-structure (<ghil-bind> env vars vals body))
(define-structure (<ghil-lambda> env vars rest body))
(define-structure (<ghil-call> env proc args))
(define-structure (<ghil-inst> inst args))
(define-structure (<ghil-void> env loc))
(define-structure (<ghil-quote> env loc obj))
(define-structure (<ghil-quasiquote> env loc exp))
(define-structure (<ghil-unquote> env loc exp))
(define-structure (<ghil-unquote-splicing> env loc exp))
(define-structure (<ghil-ref> env loc var))
(define-structure (<ghil-set> env loc var val))
(define-structure (<ghil-define> env loc var val))
(define-structure (<ghil-if> env loc test then else))
(define-structure (<ghil-and> env loc exps))
(define-structure (<ghil-or> env loc exps))
(define-structure (<ghil-begin> env loc exps))
(define-structure (<ghil-bind> env loc vars vals body))
(define-structure (<ghil-lambda> env loc vars rest body))
(define-structure (<ghil-call> env loc proc args))
(define-structure (<ghil-inline> env loc inline args))
(define-public (ghil-env ghil) (vector-ref ghil 1))
(define-public (ghil-loc ghil) (vector-ref ghil 2))
;;;
@ -86,9 +115,14 @@
(define-vm-class <ghil-var> ()
env name kind type value index)
(define (make-ghil-var env name kind)
(define-public (make-ghil-var env name kind)
(make <ghil-var> :env env :name name :kind kind))
(define-method (write (var <ghil-var>) port)
(display "#<ghil:var " port)
(display var.name port)
(display ">" port))
;;;
;;; Modules
@ -99,9 +133,14 @@
(table '())
(imports '()))
(define (make-ghil-mod module)
(define-public (make-ghil-mod module)
(make <ghil-mod> :module module))
(define-method (write (mod <ghil-mod>) port)
(display "#<ghil:mod " port)
(display (module-name mod.module) port)
(display ">" port))
(define-method (ghil-lookup (mod <ghil-mod>) (sym <symbol>))
(or (assq-ref mod.table sym)
;; (let ((var (make-ghil-var (env-identifier mod.module) sym 'module)))
@ -120,6 +159,7 @@
(table '())
(variables '()))
(export make-ghil-env)
(define-method (make-ghil-env (m <ghil-mod>))
(make <ghil-env> :mod m :parent m))
@ -148,6 +188,23 @@
(lambda (var) (set! var.kind 'external) var))
(else (loop e.parent))))))
(define-public (call-with-ghil-environment e syms func)
(let* ((e (make-ghil-env e))
(vars (map (lambda (s)
(let ((v (make-ghil-var e s 'argument)))
(ghil-env-add! e v) v))
syms)))
(func e vars)))
(define-public (call-with-ghil-bindings e syms func)
(let* ((vars (map (lambda (s)
(let ((v (make-ghil-var e s 'local)))
(ghil-env-add! e v) v))
syms))
(ret (func vars)))
(for-each (lambda (v) (ghil-env-remove! e v)) vars)
ret))
;;;
;;; Parser
@ -189,11 +246,11 @@
(receive (module name) (identifier-split identifier)
(make-<ghil-ref> e (make-ghil-var module name 'module))))))
;; (@@ INST ARGS...)
;; (@@ OP ARGS...)
((@@)
(match args
((inst . args)
(make-<ghil-inst> inst (map-parse args e)))))
((op . args)
(make-<ghil-inline> op (map-parse args e)))))
;; (@void)
((@void)
@ -272,17 +329,14 @@
;; (@eval-case CLAUSE...)
((@eval-case)
(match args
((clause . rest)
(match clause
(() (make-<ghil-void>))
(((key ...) . body)
(cond ((and (ghil-env-toplevel? e) (memq 'load-toplevel key))
(parse-body body e))
(else
(error "No match clause"))))
(else
(error "No match clause"))))))
(let loop ((clauses args))
(cond ((null? clauses) (make-<ghil-void>))
((or (eq? (caar clauses) '@else)
(and (memq 'load-toplevel (caar clauses))
(ghil-env-toplevel? e)))
(parse-body (cdar clauses) e))
(else
(loop (cdr clauses))))))
(else (error "Unknown primitive:" prim))))

6
module/system/il/macros.scm
View file

@ -65,8 +65,8 @@
;;; 6.1 Equivalence predicates
(define (@eq? x y) `(@@ eq? ,x ,y))
(define (@eqv? x y) `(@@ eqv? ,x ,y))
(define (@equal? x y) `(@@ equal? ,x ,y))
;(define (@eqv? x y) `(@@ eqv? ,x ,y))
;(define (@equal? x y) `(@@ equal? ,x ,y))
;;; 6.2 Numbers
@ -79,7 +79,7 @@
(define (@exact? x) `((@ Core::exact?) ,x))
(define (@inexact? x) `((@ Core::inexact?) ,x))
(define (@= x y) `(@@ ee? ,x ,y))
;(define (@= x y) `(@@ ee? ,x ,y))
;(define (@< x y) `(@@ lt? ,x ,y))
;(define (@> x y) `(@@ gt? ,x ,y))
;(define (@<= x y) `(@@ le? ,x ,y))

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

@ -20,19 +20,16 @@
;;; Code:
(define-module (system repl command)
:use-module (oop goops)
:use-syntax (system base syntax)
:use-module (system base language)
:use-module (system repl common)
:use-module (system il glil)
:use-module (system vm core)
:use-module (system vm load)
:use-module (system vm trace)
:use-module (system vm disasm)
:use-module (system vm profile)
: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)
:use-module (ice-9 debugger)
:export (meta-command))
(define (puts x) (display x) (newline))
@ -318,8 +315,7 @@ Disassemble a program."
(define (disassemble-file repl file)
"disassemble-file FILE
Disassemble a file."
(disassemble-dumpcode
(load-file-in (->string file) repl.module repl.language)))
(disassemble-dumpcode (load-dumpcode (->string file))))
(define (->string x)
(object->string x display))
@ -388,37 +384,15 @@ Time execution."
(get id gc-start gc-end))
result))
;;;
;;; Statistics
;;;
(define guile-gc gc)
(define (gc repl)
"gc
Garbage collection."
(guile-gc))
(define (display-stat title flag field1 field2 unit)
(let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
(format #t str title field1 field2 unit)))
(define (display-stat-title title field1 field2)
(display-stat title #t field1 field2 ""))
(define (display-diff-stat title flag this last unit)
(display-stat title flag (- this last) this unit))
(define (display-time-stat title this last)
(define (conv num)
(format #f "~10,2F" (/ num internal-time-units-per-second)))
(display-stat title #f (conv (- this last)) (conv this) "s"))
(define (display-mips-stat title this-time this-clock last-time last-clock)
(define (mips time clock)
(if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000))))
(display-stat title #f
(mips (- this-time last-time) (- this-clock last-clock))
(mips this-time this-clock) "mips"))
;;;
;;; Statistics
;;;
(define (statistics repl)
"statistics
@ -494,3 +468,25 @@ Display statistics."
(set! repl.tm-stats this-tms)
(set! repl.vm-stats this-vms)
(set! repl.gc-stats this-gcs)))
(define (display-stat title flag field1 field2 unit)
(let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
(format #t str title field1 field2 unit)))
(define (display-stat-title title field1 field2)
(display-stat title #t field1 field2 ""))
(define (display-diff-stat title flag this last unit)
(display-stat title flag (- this last) this unit))
(define (display-time-stat title this last)
(define (conv num)
(format #f "~10,2F" (/ num internal-time-units-per-second)))
(display-stat title #f (conv (- this last)) (conv this) "s"))
(define (display-mips-stat title this-time this-clock last-time last-clock)
(define (mips time clock)
(if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000))))
(display-stat title #f
(mips (- this-time last-time) (- this-clock last-clock))
(mips this-time this-clock) "mips"))

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

@ -41,7 +41,7 @@
(make <repl>
:vm vm
:language (lookup-language lang)
:module #f ;; (global-ref 'user)
:module (current-module) ;; (global-ref 'user)
:value-count 0
; :value-history (make-vmodule)
:tm-stats (times)
@ -66,9 +66,9 @@
(apply compile-in form repl.module repl.language opts))
(define (repl-eval repl form)
(let ((evaler repl.language.evaler))
(if evaler
(evaler form repl.module)
(let ((eval repl.language.evaluator))
(if eval
(eval form repl.module)
(vm-load repl.vm (repl-compile repl form)))))
(define (repl-print repl val)
@ -81,11 +81,11 @@
(newline)
(set! repl.value-count num))))
(define (repl-compile-file repl form . opts)
(apply compile-file-in form repl.module repl.language opts))
(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 load-file-in file repl.module repl.language opts)))
(if (memq :t opts)
(vm-trace repl.vm bytes :a)
(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))))

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

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

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

@ -20,7 +20,6 @@
;;; Code:
(define-module (system vm assemble)
:use-syntax (system base syntax)
:use-module (system il glil)
:use-module (system vm core)
:use-module (system vm conv)
@ -210,8 +209,7 @@
(push-code! `(load-program ,bytes)))))
((vlink? x)
;;; (dump! (vlink-module x)) ;; FIXME: no module support now
(dump! (vlink-name x))
(push-code! `(link)))
(push-code! `(link ,(symbol->string (vlink-name x)))))
((vmod? x)
(push-code! `(load-module ,(vmod-id x))))
((and (integer? x) (exact? x))

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

@ -83,6 +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))
(else #f)))
(define (code->bytes code)

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

@ -20,22 +20,34 @@
;;; Code:
(define-module (system vm load)
:autoload (system base compile) (compile-file)
:use-module (system vm core)
:autoload (system base language) (compile-file-in lookup-language)
:use-module (ice-9 regex)
:export (load/compile))
:export (load-compiled-file compile-and-load load/compile))
(define (load/compile file)
(let* ((file (file-name-full-name file))
(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))))
(compile-file-in file #f (lookup-language 'gscheme) #:O))
(vm-load (the-vm) (load-dumpcode 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-name-full-name filename)
(let ((oldname (and (current-load-port)
(port-filename (current-load-port)))))
(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) #\/))
@ -43,6 +55,6 @@
(string-append (dirname oldname) "/" filename)
filename)))
(define (object-file-name file)
(define-public (object-file-name file)
(let ((m (string-match "\\.[^.]*$" file)))
(string-append (if m (match:prefix m) file) ".go")))

251
module/system/vm/slib.scm
View file

@ -1,251 +0,0 @@
;;;; slib.scm --- definitions needed to get SLIB to work with Guile
;;;;
;;;; Copyright (C) 1997, 1998, 2000 Free Software Foundation, Inc.
;;;;
;;;; This file is part of GUILE.
;;;;
;;;; GUILE 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.
;;;;
;;;; GUILE 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 GUILE; see the file COPYING. If not, write
;;;; to the Free Software Foundation, Inc., 59 Temple Place, Suite
;;;; 330, Boston, MA 02111-1307 USA
;;;;
(define-module (system vm slib)
:use-module (system vm load)
:no-backtrace)
(define (eval-load <filename> evl)
(if (not (file-exists? <filename>))
(set! <filename> (string-append <filename> (scheme-file-suffix))))
(call-with-input-file <filename>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <filename>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define slib:exit quit)
(define slib:error error)
(define slib:warn warn)
(define slib:eval (lambda (x) (eval x slib-module)))
(define defmacro:eval (lambda (x) (eval x (interaction-environment))))
(define logical:logand logand)
(define logical:logior logior)
(define logical:logxor logxor)
(define logical:lognot lognot)
(define logical:ash ash)
(define logical:logcount logcount)
(define logical:integer-length integer-length)
(define logical:bit-extract bit-extract)
(define logical:integer-expt integer-expt)
(define logical:ipow-by-squaring ipow-by-squaring)
(define slib:eval-load eval-load)
(define slib:tab #\tab)
(define slib:form-feed #\page)
(define slib-module (current-module))
(define (defined? symbol)
(module-defined? slib-module symbol))
(define slib:features
(append '(source
eval
abort
alist
defmacro
delay
dynamic-wind
full-continuation
hash
hash-table
line-i/o
logical
multiarg/and-
multiarg-apply
promise
rev2-procedures
rev4-optional-procedures
string-port
with-file)
(if (defined? 'getenv)
'(getenv)
'())
(if (defined? 'current-time)
'(current-time)
'())
(if (defined? 'system)
'(system)
'())
(if (defined? 'array?)
'(array)
'())
(if (defined? 'char-ready?)
'(char-ready?)
'())
(if (defined? 'array-for-each)
'(array-for-each)
'())
(if (and (string->number "0.0") (inexact? (string->number "0.0")))
'(inexact)
'())
(if (rational? (string->number "1/19"))
'(rational)
'())
(if (real? (string->number "0.0"))
'(real)
())
(if (complex? (string->number "1+i"))
'(complex)
'())
(let ((n (string->number "9999999999999999999999999999999")))
(if (and n (exact? n))
'(bignum)
'()))))
;;; FIXME: Because uers want require to search the path, this uses
;;; load-from-path, which probably isn't a hot idea. slib
;;; doesn't expect this function to search a path, so I expect to get
;;; bug reports at some point complaining that the wrong file gets
;;; loaded when something accidentally appears in the path before
;;; slib, etc. ad nauseum. However, the right fix seems to involve
;;; changing catalog:get in slib/require.scm, and I don't expect
;;; Aubrey will integrate such a change. So I'm just going to punt
;;; for the time being.
(define-public (slib:load name)
(save-module-excursion
(lambda ()
(define (try-load name)
(catch 'system-error
(lambda () (load/compile (%search-load-path name)) #f)
(lambda args args)))
;; (set-current-module slib-module)
(let ((errinfo (try-load name)))
(if (and errinfo (try-load (string-append name ".scm")))
(apply throw errinfo))))))
(define slib:load-source slib:load)
(define defmacro:load slib:load)
(define slib-parent-dir
(let* ((path (%search-load-path "slib/require.scm")))
(if path
(substring path 0 (- (string-length path) 17))
(error "Could not find slib/require.scm in " %load-path))))
(define-public (implementation-vicinity)
(string-append slib-parent-dir "/"))
(define-public (library-vicinity)
(string-append (implementation-vicinity) "slib/"))
(define-public home-vicinity
(let ((home-path (getenv "HOME")))
(lambda () home-path)))
(define-public (scheme-implementation-type) 'guile)
(define-public (scheme-implementation-version) "")
(define (output-port-width . arg) 80)
(define (output-port-height . arg) 24)
(define (identity x) x)
;;; {Random numbers}
;;;
(define-public (make-random-state . args)
(let ((seed (if (null? args) *random-state* (car args))))
(cond ((string? seed))
((number? seed) (set! seed (number->string seed)))
(else (let ()
(require 'object->string)
(set! seed (object->limited-string seed 50)))))
(seed->random-state seed)))
;;; {Time}
;;;
(define difftime -)
(define offset-time +)
(define %system-define define)
(define define
(procedure->memoizing-macro
(lambda (exp env)
(if (= (length env) 1)
`(define-public ,@(cdr exp))
`(%system-define ,@(cdr exp))))))
;;; Hack to make syncase macros work in the slib module
(if (nested-ref the-root-module '(app modules ice-9 syncase))
(set-object-property! (module-local-variable (current-module) 'define)
'*sc-expander*
'(define)))
(define (software-type)
"Return a symbol describing the current platform's operating system.
This may be one of AIX, VMS, UNIX, COHERENT, WINDOWS, MS-DOS, OS/2,
THINKC, AMIGA, ATARIST, MACH, or ACORN.
Note that most varieties of Unix are considered to be simply \"UNIX\".
That is because when a program depends on features that are not present
on every operating system, it is usually better to test for the presence
or absence of that specific feature. The return value of
@code{software-type} should only be used for this purpose when there is
no other easy or unambiguous way of detecting such features."
'UNIX)
(slib:load (in-vicinity (library-vicinity) "require.scm"))
(define-public require require:require)
;; {Extensions to the require system so that the user can add new
;; require modules easily.}
(define *vicinity-table*
(list
(cons 'implementation (implementation-vicinity))
(cons 'library (library-vicinity))))
(define (install-require-vicinity name vicinity)
(let ((entry (assq name *vicinity-table*)))
(if entry
(set-cdr! entry vicinity)
(set! *vicinity-table*
(acons name vicinity *vicinity-table*)))))
(define (install-require-module name vicinity-name file-name)
(if (not *catalog*) ;Fix which loads catalog in slib
(catalog:get 'random)) ;(doesn't load the feature 'random)
(let ((entry (assq name *catalog*))
(vicinity (cdr (assq vicinity-name *vicinity-table*))))
(let ((path-name (in-vicinity vicinity file-name)))
(if entry
(set-cdr! entry path-name)
(set! *catalog*
(acons name path-name *catalog*))))))

1
src/.cvsignore
View file

@ -1,5 +1,6 @@
.libs
.deps
guilec
guile-vm
stamp-h
config.h

1
src/Makefile.am
View file

@ -1,4 +1,5 @@
bin_PROGRAMS = guile-vm
bin_SCRIPTS = guilec
guile_vm_SOURCES = guile-vm.c
guile_vm_LDADD = libguilevm.la
guile_vm_LDFLAGS = $(GUILE_LDFLAGS)

5
src/guilec.in Executable file
View file

@ -0,0 +1,5 @@
#!@bindir@/guile -*- scheme -*-
!#
(use-modules (system base compile))
(for-each compile-file (cdr (command-line)))

14
src/vm_engine.h
View file

@ -219,6 +219,19 @@ do { \
PUSH (l); \
} while (0)
#define POP_LIST_MARK() \
do { \
SCM o; \
SCM l = SCM_EOL; \
POP (o); \
while (!SCM_UNBNDP (o)) \
{ \
CONS (l, o, l); \
POP (o); \
} \
PUSH (l); \
} while (0)
/*
* Instruction operation
@ -256,7 +269,6 @@ do { \
#define ARGS1(a1) SCM a1 = sp[0];
#define ARGS2(a1,a2) SCM a1 = sp[-1], a2 = sp[0]; sp--;
#define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2;
#define ARGSN(an) int an = FETCH ();
#define RETURN(x) do { *sp = x; NEXT; } while (0)

2
src/vm_expand.h
View file

@ -64,7 +64,7 @@
#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) \
{VM_OPCODE (tag), name, len, npop, npush},
#define VM_DEFINE_FUNCTION(tag,name,nargs) \
{VM_OPCODE (tag), name, (nargs < 0) ? 1 : 0, nargs, 1},
{VM_OPCODE (tag), name, 0, nargs, 1},
#define VM_DEFINE_LOADER(tag,name) \
{VM_OPCODE (tag), name, -1, 0, 1},

34
src/vm_loader.c
View file

@ -159,22 +159,30 @@ VM_DEFINE_LOADER (load_program, "load-program")
NEXT;
}
VM_DEFINE_INSTRUCTION (link, "link", 0, 1, 1)
VM_DEFINE_LOADER (link, "link")
{
SCM sym;
size_t len;
FETCH_LENGTH (len);
sym = scm_mem2symbol (ip, len);
ip += len;
#if 0
sp[-1] = scm_c_env_vcell (sp[-1], sp[0], 1);
sp--;
*sp = scm_c_env_vcell (*sp, sym, 1);
#endif
/* Temporary hack that supports the current module system */
SCM mod = scm_current_module ();
SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
*sp, SCM_BOOL_F);
if (SCM_FALSEP (var))
/* Create a new variable if not defined yet */
var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
*sp, SCM_BOOL_T);
*sp = SCM_VARVCELL (var);
NEXT;
{
/* Temporary hack that supports the current module system */
SCM mod = scm_current_module ();
SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
sym, SCM_BOOL_F);
if (SCM_FALSEP (var))
/* Create a new variable if not defined yet */
var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
sym, SCM_BOOL_T);
PUSH (SCM_VARVCELL (var));
NEXT;
}
}
/*

14
src/vm_scheme.c
View file

@ -158,20 +158,6 @@ VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
RETURN (SCM_UNSPECIFIED);
}
VM_DEFINE_FUNCTION (list, "list", -1)
{
ARGSN (n);
POP_LIST (n);
NEXT;
}
VM_DEFINE_FUNCTION (vector, "vector", -1)
{
ARGSN (n);
POP_LIST (n);
RETURN (scm_vector (*sp));
}
/*
* Numeric relational tests

44
src/vm_system.c
View file

@ -68,6 +68,12 @@ VM_DEFINE_INSTRUCTION (drop, "drop", 0, 0, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (mark, "mark", 0, 0, 1)
{
PUSH (SCM_UNDEFINED);
NEXT;
}
VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1)
{
SCM x = *sp;
@ -136,6 +142,43 @@ VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (list, "list", 1, -1, 1)
{
int n = FETCH ();
POP_LIST (n);
NEXT;
}
VM_DEFINE_INSTRUCTION (vector, "vector", 1, -1, 1)
{
int n = FETCH ();
POP_LIST (n);
*sp = scm_vector (*sp);
NEXT;
}
VM_DEFINE_INSTRUCTION (list_mark, "list-mark", 0, 0, 0)
{
POP_LIST_MARK ();
NEXT;
}
VM_DEFINE_INSTRUCTION (vector_mark, "vector-mark", 0, 0, 0)
{
POP_LIST_MARK ();
*sp = scm_vector (*sp);
NEXT;
}
VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
{
SCM l;
POP (l);
for (; !SCM_NULLP (l); l = SCM_CDR (l))
PUSH (SCM_CAR (l));
NEXT;
}
/*
* Variable access
@ -180,7 +223,6 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
SCM o = VARIABLE_REF (x);
if (SCM_UNBNDP (o))
{
/* Try autoload here */
err_args = SCM_LIST1 (SCM_CAR (x));
goto vm_error_unbound;
}