mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-18 18:40:22 +02:00
*** empty log message ***
This commit is contained in:
Keisuke Nishida
parent
ea9c5daba0
commit
46cd9a346f
20 changed files with 207 additions and 715 deletions
|
|
@ -21,6 +21,8 @@
|
|||
|
||||
(define-module (language gscheme spec)
|
||||
:use-module (system base language)
|
||||
:use-module (system il ghil)
|
||||
:use-module (language r5rs expand)
|
||||
:use-module (ice-9 match)
|
||||
:export (gscheme))
|
||||
|
||||
|
|
@ -29,37 +31,33 @@
|
|||
;;; Macro expander
|
||||
;;;
|
||||
|
||||
(define (expand x)
|
||||
(define expand-syntax expand)
|
||||
|
||||
(define (expand-macro x m)
|
||||
(if (pair? x)
|
||||
(let* ((s (car x))
|
||||
(m (current-module))
|
||||
(v (and (symbol? s) (module-defined? m s) (module-ref m s))))
|
||||
(if (defmacro? v)
|
||||
(expand (apply (defmacro-transformer v) (cdr x)))
|
||||
(cons (expand (car x)) (expand (cdr x)))))
|
||||
(expand-macro (apply (defmacro-transformer v) (cdr x)) m)
|
||||
(cons (expand-macro (car x) m) (expand-macro (cdr x) m))))
|
||||
x))
|
||||
|
||||
(define (expand x)
|
||||
(expand-syntax (expand-macro x (current-module))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Translator
|
||||
;;;
|
||||
|
||||
(define *primitive-procedure-list*
|
||||
'(void car cdr cons + - < >))
|
||||
|
||||
(define (translate x) (if (pair? x) (translate-pair x) x))
|
||||
|
||||
(define (translate-pair x)
|
||||
(let ((name (car x)) (args (cdr x)))
|
||||
(case name
|
||||
((quote) (cons '@quote args))
|
||||
((set! if and or begin)
|
||||
((define set! if and or begin)
|
||||
(cons (symbol-append '@ name) (map translate args)))
|
||||
((define)
|
||||
(if (pair? (car args))
|
||||
`(@define ,(caar args)
|
||||
(@lambda ,(cdar args) ,@(map translate (cdr args))))
|
||||
`(@define ,(car args) ,@(map translate (cdr args)))))
|
||||
((let let* letrec)
|
||||
(match x
|
||||
(('let (? symbol? f) ((s v) ...) body ...)
|
||||
|
|
@ -73,9 +71,10 @@
|
|||
((lambda)
|
||||
(cons* '@lambda (car args) (map translate (cdr args))))
|
||||
(else
|
||||
(if (memq name *primitive-procedure-list*)
|
||||
(cons (symbol-append '@ name) (map translate args))
|
||||
(cons (translate name) (map translate args)))))))
|
||||
(let ((prim (symbol-append '@ name)))
|
||||
(if (ghil-primitive? prim)
|
||||
(cons prim (map translate args))
|
||||
(cons (translate name) (map translate args))))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@
|
|||
(call-with-output-file (object-file-name file)
|
||||
(lambda (out) (uniform-vector-write bytes out)))))
|
||||
|
||||
(define (load-file-in file env lang)
|
||||
(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))))
|
||||
|
|
|
|||
|
|
@ -55,8 +55,8 @@
|
|||
;;;
|
||||
|
||||
(define *ia-void* (make-<glil-void>))
|
||||
(define *ia-drop* (make-<glil-inst> 'drop))
|
||||
(define *ia-return* (make-<glil-inst> 'return))
|
||||
(define *ia-drop* (make-<glil-call> 'drop 0))
|
||||
(define *ia-return* (make-<glil-call> 'return 0))
|
||||
|
||||
(define (make-label) (gensym ":L"))
|
||||
|
||||
|
|
@ -147,6 +147,14 @@
|
|||
(($ <ghil-lambda> vars rest body)
|
||||
(return-code! (codegen tree)))
|
||||
|
||||
(($ <ghil-inst> 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*)))
|
||||
|
||||
(($ <ghil-call> proc args)
|
||||
;; ARGS...
|
||||
;; PROC
|
||||
|
|
@ -155,15 +163,7 @@
|
|||
(comp-push proc)
|
||||
(let ((inst (if tail 'tail-call 'call)))
|
||||
(push-code! (make-<glil-call> inst (length args))))
|
||||
(if drop (push-code! *ia-drop*)))
|
||||
|
||||
(($ <ghil-inst> inst args)
|
||||
;; ARGS...
|
||||
;; (INST)
|
||||
(for-each comp-push args)
|
||||
(push-code! (make-<glil-inst> inst))
|
||||
(if drop (push-code! *ia-drop*))
|
||||
(if tail (push-code! *ia-return*)))))
|
||||
(if drop (push-code! *ia-drop*)))))
|
||||
;;
|
||||
;; main
|
||||
(match ghil
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@
|
|||
: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
|
||||
|
|
@ -56,6 +57,26 @@
|
|||
(define-structure (<ghil-call> proc args))
|
||||
(define-structure (<ghil-inst> inst args))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Procedures
|
||||
;;;
|
||||
|
||||
(define *core-primitives*
|
||||
'(@void @quote @define @set! @if @begin @let @letrec @lambda))
|
||||
|
||||
(define *macro-module* (resolve-module '(system il macros)))
|
||||
|
||||
(define (ghil-primitive-macro? x)
|
||||
(module-defined? *macro-module* x))
|
||||
|
||||
(define (ghil-macro-expander x)
|
||||
(module-ref *macro-module* x))
|
||||
|
||||
(define (ghil-primitive? x)
|
||||
(or (memq x *core-primitives*)
|
||||
(ghil-primitive-macro? x)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Variables
|
||||
|
|
@ -146,13 +167,11 @@
|
|||
(define (map-parse x e)
|
||||
(map (lambda (x) (parse x e)) x))
|
||||
|
||||
(define *macros* (resolve-module '(system il macros)))
|
||||
|
||||
(define (parse-pair x e)
|
||||
(let ((head (car x)) (tail (cdr x)))
|
||||
(if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@))
|
||||
(if (module-defined? *macros* head)
|
||||
(parse (apply (module-ref *macros* head) tail) e)
|
||||
(if (ghil-primitive-macro? head)
|
||||
(parse (apply (ghil-macro-expander head) tail) e)
|
||||
(parse-primitive head tail e))
|
||||
(make-<ghil-call> (parse head e) (map-parse tail e)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -40,7 +40,6 @@
|
|||
make-<glil-label> <glil-label>? <glil-label>-1
|
||||
make-<glil-branch> <glil-branch>? <glil-branch>-1 <glil-branch>-2
|
||||
make-<glil-call> <glil-call>? <glil-call>-1 <glil-call>-2
|
||||
make-<glil-inst> <glil-inst>? <glil-inst>-1
|
||||
))
|
||||
|
||||
;; Meta operations
|
||||
|
|
@ -60,8 +59,7 @@
|
|||
;; Controls
|
||||
(define-structure (<glil-label> label))
|
||||
(define-structure (<glil-branch> inst label))
|
||||
(define-structure (<glil-call> inst n))
|
||||
(define-structure (<glil-inst> inst))
|
||||
(define-structure (<glil-call> inst nargs))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -160,8 +158,7 @@
|
|||
;; controls
|
||||
(($ <glil-label> label) `(label ,label))
|
||||
(($ <glil-branch> inst label) `(,inst ,label))
|
||||
(($ <glil-call> inst n) `(,inst ,n))
|
||||
(($ <glil-inst> inst) `(,inst))))
|
||||
(($ <glil-call> inst nargs) `(,inst ,nargs))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -25,13 +25,6 @@
|
|||
(define (make-label) (gensym ":L"))
|
||||
(define (make-sym) (gensym "_"))
|
||||
|
||||
;;;
|
||||
;;; Module macros
|
||||
;;;
|
||||
|
||||
(define (@import identifier)
|
||||
`((@ System::Base::module::do-import) (@quote ,identifier)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Syntax
|
||||
|
|
@ -155,12 +148,12 @@
|
|||
((x y) `(@@ div ,x ,y))
|
||||
((x y . rest) `(@@ div ,x (@* ,y ,@rest)))))
|
||||
|
||||
;;; abs
|
||||
;;;
|
||||
;;; quotient
|
||||
(define (@abs x) `(@if (@< x 0) (@- x) x))
|
||||
|
||||
(define (@quotient x y) `(@@ quotient ,x ,y))
|
||||
(define (@remainder x y) `(@@ remainder ,x ,y))
|
||||
;;; modulo
|
||||
;;;
|
||||
(define (@modulo x y) `(@@ modulo ,x ,y))
|
||||
|
||||
;;; gcd
|
||||
;;; lcm
|
||||
;;;
|
||||
|
|
@ -337,34 +330,14 @@
|
|||
|
||||
;; (define (@apply proc . args) ...)
|
||||
|
||||
(define (@map f ls . more)
|
||||
(if (null? more)
|
||||
`(@let ((f ,f))
|
||||
(@let map1 ((ls ,ls))
|
||||
(@if (@null? ls)
|
||||
'()
|
||||
(@cons (f (car ls)) (map1 (cdr ls))))))
|
||||
`(@let ((f ,f))
|
||||
(@let map-more ((ls ,ls) (more ,more))
|
||||
(@if (@null? ls)
|
||||
'()
|
||||
(@cons (@apply f (car ls) (map car more))
|
||||
(map-more (cdr ls) (map cdr more))))))))
|
||||
;;; map
|
||||
;;; for-each
|
||||
|
||||
(define @for-each
|
||||
(match-lambda*
|
||||
((f l)
|
||||
(do ((ls ls (cdr ls)) (more more (map cdr more)))
|
||||
((null? ls))
|
||||
(apply f (car ls) (map car more))))
|
||||
((f . args)
|
||||
`(@apply (@~ system:il:base:for-each) args))))
|
||||
;;; (define (@force promise) `(@@ force promise))
|
||||
|
||||
(define (@force promise) `(@@ force promise))
|
||||
;;; (define (@call-with-current-continuation proc) `(@@ call/cc proc))
|
||||
|
||||
(define (@call-with-current-continuation proc) `(@@ call/cc proc))
|
||||
|
||||
(define @call/cc @call-with-current-continuation)
|
||||
;;; (define @call/cc @call-with-current-continuation)
|
||||
|
||||
;;; values
|
||||
;;; call-with-values
|
||||
|
|
|
|||
|
|
@ -1,488 +0,0 @@
|
|||
;;; REPL commands
|
||||
|
||||
;; 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 (puts x) (display x) (newline))
|
||||
|
||||
(define (user-error msg . args)
|
||||
(throw 'user-error #f msg args #f))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Meta command
|
||||
;;;
|
||||
|
||||
(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))
|
||||
(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))))
|
||||
|
||||
(define (group-name g) (car g))
|
||||
(define (group-commands g) (cdr g))
|
||||
|
||||
(define *command-module* (current-module))
|
||||
(define (command-name c) (car c))
|
||||
(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
|
||||
(define (command-procedure c) (module-ref *command-module* (command-name c)))
|
||||
(define (command-doc c) (procedure-documentation (command-procedure c)))
|
||||
|
||||
(define (command-usage c)
|
||||
(let ((doc (command-doc c)))
|
||||
(substring doc 0 (string-index doc #\newline))))
|
||||
|
||||
(define (command-summary c)
|
||||
(let* ((doc (command-doc c))
|
||||
(start (1+ (string-index doc #\newline))))
|
||||
(cond ((string-index doc #\newline start)
|
||||
=> (lambda (end) (substring doc start end)))
|
||||
(else (substring doc start)))))
|
||||
|
||||
(define (lookup-group name)
|
||||
(assq name *command-table*))
|
||||
|
||||
(define (lookup-command key)
|
||||
(let loop ((groups *command-table*) (commands '()))
|
||||
(cond ((and (null? groups) (null? commands)) #f)
|
||||
((null? commands)
|
||||
(loop (cdr groups) (cdar groups)))
|
||||
((memq key (car commands)) (car commands))
|
||||
(else (loop groups (cdr commands))))))
|
||||
|
||||
(define (display-group group . opts)
|
||||
(format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
|
||||
(for-each (lambda (c)
|
||||
(display-summary (command-usage c)
|
||||
(command-abbrev c)
|
||||
(command-summary c)))
|
||||
(group-commands group))
|
||||
(newline))
|
||||
|
||||
(define (display-command command)
|
||||
(display "Usage: ")
|
||||
(display (command-doc command))
|
||||
(newline))
|
||||
|
||||
(define (display-summary usage abbrev summary)
|
||||
(let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
|
||||
(format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
|
||||
|
||||
(define (meta-command repl line)
|
||||
(let ((input (call-with-input-string (string-append "(" line ")") read)))
|
||||
(if (not (null? input))
|
||||
(do ((key (car input))
|
||||
(args (cdr input) (cdr args))
|
||||
(opts '() (cons (make-keyword-from-dash-symbol (car args)) opts)))
|
||||
((or (null? args)
|
||||
(not (symbol? (car args)))
|
||||
(not (eq? (string-ref (symbol->string (car args)) 0) #\-)))
|
||||
(let ((c (lookup-command key)))
|
||||
(if c
|
||||
(cond ((memq :h opts) (display-command c))
|
||||
(else (apply (command-procedure c)
|
||||
repl (append! args opts))))
|
||||
(user-error "Unknown meta command: ~A" key))))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Help commands
|
||||
;;;
|
||||
|
||||
(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 :)"
|
||||
(match args
|
||||
(()
|
||||
(display-group (lookup-group 'help))
|
||||
(display "Command Groups:\n\n")
|
||||
(display-summary "help all" #f "List all commands")
|
||||
(for-each (lambda (g)
|
||||
(let* ((name (symbol->string (group-name g)))
|
||||
(usage (string-append "help " name))
|
||||
(header (string-append "List " name " commands")))
|
||||
(display-summary usage #f header)))
|
||||
(cdr *command-table*))
|
||||
(newline)
|
||||
(display "Enter `,COMMAND -h' to display 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)))))
|
||||
|
||||
(define guile-apropos apropos)
|
||||
(define (apropos repl regexp)
|
||||
"apropos [options] REGEXP
|
||||
Find bindings/modules/packages."
|
||||
(guile-apropos (object->string regexp display)))
|
||||
|
||||
(define (describe repl obj)
|
||||
"describe OBJ
|
||||
Show description/documentation."
|
||||
(display "Not implemented yet\n"))
|
||||
|
||||
(define (option repl . args)
|
||||
"option [KEY [VALUE]]
|
||||
List/show/set options."
|
||||
(display "Not implemented yet\n"))
|
||||
|
||||
(define (quit repl)
|
||||
"quit
|
||||
Quit this session."
|
||||
(throw 'quit))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Module commands
|
||||
;;;
|
||||
|
||||
(define (module repl . args)
|
||||
"module [MODULE]
|
||||
Change modules / Show current module."
|
||||
(match args
|
||||
(() (puts (binding repl.module)))))
|
||||
|
||||
(define (use repl . args)
|
||||
"use [MODULE ...]
|
||||
Use modules."
|
||||
(define (use name)
|
||||
(let ((mod (resolve-interface name)))
|
||||
(if mod
|
||||
(module-use! repl.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))))
|
||||
(for-each (lambda (name)
|
||||
(cond
|
||||
((pair? name) (use name))
|
||||
((symbol? name)
|
||||
(cond ((find-one-module (symbol->string name)) => use)))
|
||||
(else (user-error "Invalid module name: ~A" name))))
|
||||
args)))
|
||||
|
||||
(define (import repl . args)
|
||||
"import [MODULE ...]
|
||||
Import modules / List those imported."
|
||||
(define (use name)
|
||||
(let ((mod (resolve-interface name)))
|
||||
(if mod
|
||||
(module-use! repl.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))))
|
||||
(for-each (lambda (name)
|
||||
(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))))
|
||||
args)))
|
||||
|
||||
(define (load repl file . opts)
|
||||
"load [options] FILE
|
||||
Load a file in the current module."
|
||||
(apply repl-load-file repl (->string file) opts))
|
||||
|
||||
(define (binding repl . opts)
|
||||
"binding [-a]
|
||||
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))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Language commands
|
||||
;;;
|
||||
|
||||
(define (language repl name)
|
||||
"language LANGUAGE
|
||||
Change languages."
|
||||
(set! repl.language (lookup-language name))
|
||||
(repl-welcome repl))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Compile commands
|
||||
;;;
|
||||
|
||||
(define (compile repl form . opts)
|
||||
"compile [options] FORM
|
||||
Generate compiled code.
|
||||
|
||||
-e Stop after expanding syntax/macro
|
||||
-t Stop after translating into GHIL
|
||||
-c Stop after generating GLIL
|
||||
-l Stop before linking
|
||||
-o Compile into bytecode
|
||||
|
||||
-O Enable optimization
|
||||
-D Add debug information"
|
||||
(let ((x (apply repl-compile repl form opts)))
|
||||
(cond ((null? opts)
|
||||
(disassemble-program x))
|
||||
((memq :l opts)
|
||||
(disassemble-bytecode x))
|
||||
((memq :c opts)
|
||||
(pprint-glil x))
|
||||
(else
|
||||
(puts x)))))
|
||||
|
||||
(define (compile-file repl file . opts)
|
||||
"compile-file [options] FILE
|
||||
Compile a file."
|
||||
(apply repl-compile-file repl (->string file) opts))
|
||||
|
||||
(define (disassemble repl prog)
|
||||
"disassemble PROGRAM
|
||||
Disassemble a program."
|
||||
(disassemble-program (repl.vm (repl-compile repl prog))))
|
||||
|
||||
(define (disassemble-file repl file)
|
||||
"disassemble-file FILE
|
||||
Disassemble a file."
|
||||
(disassemble-bytecode (load-file-in (->string file)
|
||||
repl.module
|
||||
repl.language)))
|
||||
|
||||
(define (->string x)
|
||||
(object->string x display))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Profile commands
|
||||
;;;
|
||||
|
||||
(define (profile repl form . opts)
|
||||
"profile FORM
|
||||
Profile execution."
|
||||
(apply vm-profile repl.vm (repl-compile repl form) opts))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Debug commands
|
||||
;;;
|
||||
|
||||
(define guile-backtrace backtrace)
|
||||
(define (backtrace repl)
|
||||
"backtrace
|
||||
Show backtrace (if any)."
|
||||
(guile-backtrace))
|
||||
|
||||
(define (debugger repl)
|
||||
"debugger
|
||||
Start debugger."
|
||||
(debug))
|
||||
|
||||
(define (trace repl form . opts)
|
||||
"trace [-a] FORM
|
||||
Trace execution."
|
||||
(apply vm-trace repl.vm (repl-compile repl form) opts))
|
||||
|
||||
(define (step repl)
|
||||
"step FORM
|
||||
Step execution."
|
||||
(display "Not implemented yet\n"))
|
||||
|
||||
|
||||
;;;
|
||||
;;; 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))
|
||||
|
||||
;;;
|
||||
;;; 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"))
|
||||
|
||||
(define (statistics repl)
|
||||
"statistics
|
||||
Display statistics."
|
||||
(let ((this-tms (times))
|
||||
(this-vms (vm-stats repl.vm))
|
||||
(this-gcs (gc-stats))
|
||||
(last-tms repl.tm-stats)
|
||||
(last-vms repl.vm-stats)
|
||||
(last-gcs repl.gc-stats))
|
||||
;; GC times
|
||||
(let ((this-times (assq-ref this-gcs 'gc-times))
|
||||
(last-times (assq-ref last-gcs 'gc-times)))
|
||||
(display-diff-stat "GC times:" #t this-times last-times "times")
|
||||
(newline))
|
||||
;; Memory size
|
||||
(let ((this-cells (assq-ref this-gcs 'cells-allocated))
|
||||
(this-heap (assq-ref this-gcs 'cell-heap-size))
|
||||
(this-bytes (assq-ref this-gcs 'bytes-malloced))
|
||||
(this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
|
||||
(display-stat-title "Memory size:" "current" "limit")
|
||||
(display-stat "heap" #f this-cells this-heap "cells")
|
||||
(display-stat "malloc" #f this-bytes this-malloc "bytes")
|
||||
(newline))
|
||||
;; Cells collected
|
||||
(let ((this-marked (assq-ref this-gcs 'cells-marked))
|
||||
(last-marked (assq-ref last-gcs 'cells-marked))
|
||||
(this-swept (assq-ref this-gcs 'cells-swept))
|
||||
(last-swept (assq-ref last-gcs 'cells-swept)))
|
||||
(display-stat-title "Cells collected:" "diff" "total")
|
||||
(display-diff-stat "marked" #f this-marked last-marked "cells")
|
||||
(display-diff-stat "swept" #f this-swept last-swept "cells")
|
||||
(newline))
|
||||
;; GC time taken
|
||||
(let ((this-mark (assq-ref this-gcs 'gc-mark-time-taken))
|
||||
(last-mark (assq-ref last-gcs 'gc-mark-time-taken))
|
||||
(this-sweep (assq-ref this-gcs 'gc-sweep-time-taken))
|
||||
(last-sweep (assq-ref last-gcs 'gc-sweep-time-taken))
|
||||
(this-total (assq-ref this-gcs 'gc-time-taken))
|
||||
(last-total (assq-ref last-gcs 'gc-time-taken)))
|
||||
(display-stat-title "GC time taken:" "diff" "total")
|
||||
(display-time-stat "mark" this-mark last-mark)
|
||||
(display-time-stat "sweep" this-sweep last-sweep)
|
||||
(display-time-stat "total" this-total last-total)
|
||||
(newline))
|
||||
;; Process time spent
|
||||
(let ((this-utime (tms:utime this-tms))
|
||||
(last-utime (tms:utime last-tms))
|
||||
(this-stime (tms:stime this-tms))
|
||||
(last-stime (tms:stime last-tms))
|
||||
(this-cutime (tms:cutime this-tms))
|
||||
(last-cutime (tms:cutime last-tms))
|
||||
(this-cstime (tms:cstime this-tms))
|
||||
(last-cstime (tms:cstime last-tms)))
|
||||
(display-stat-title "Process time spent:" "diff" "total")
|
||||
(display-time-stat "user" this-utime last-utime)
|
||||
(display-time-stat "system" this-stime last-stime)
|
||||
(display-time-stat "child user" this-cutime last-cutime)
|
||||
(display-time-stat "child system" this-cstime last-cstime)
|
||||
(newline))
|
||||
;; VM statistics
|
||||
(let ((this-time (vms:time this-vms))
|
||||
(last-time (vms:time last-vms))
|
||||
(this-clock (vms:clock this-vms))
|
||||
(last-clock (vms:clock last-vms)))
|
||||
(display-stat-title "VM statistics:" "diff" "total")
|
||||
(display-time-stat "time spent" this-time last-time)
|
||||
(display-diff-stat "bogoclock" #f this-clock last-clock "clock")
|
||||
(display-mips-stat "bogomips" this-time this-clock last-time last-clock)
|
||||
(newline))
|
||||
;; Save statistics
|
||||
;; Save statistics
|
||||
(set! repl.tm-stats this-tms)
|
||||
(set! repl.vm-stats this-vms)
|
||||
(set! repl.gc-stats this-gcs)))
|
||||
|
|
@ -24,6 +24,7 @@
|
|||
:use-syntax (system base syntax)
|
||||
: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))
|
||||
|
||||
|
|
@ -63,7 +64,7 @@
|
|||
|
||||
(define (repl-compile repl form . opts)
|
||||
(let ((bytes (apply compile-in form repl.module repl.language opts)))
|
||||
(if (or (memq :c opts) (memq :l opts))
|
||||
(if (or (memq :c opts) (memq :l opts) (memq :t opts) (memq :e opts))
|
||||
bytes
|
||||
(vm-load repl.vm bytes))))
|
||||
|
||||
|
|
@ -88,4 +89,6 @@
|
|||
|
||||
(define (repl-load-file repl file . opts)
|
||||
(let ((bytes (apply load-file-in file repl.module repl.language opts)))
|
||||
(repl.vm (vm-load repl.vm bytes))))
|
||||
(if (memq #:t opts) (vm-trace-start! repl.vm #:a))
|
||||
(repl.vm (vm-load repl.vm bytes))
|
||||
(if (memq #:t opts) (vm-trace-end! repl.vm #:a))))
|
||||
|
|
|
|||
|
|
@ -135,12 +135,15 @@
|
|||
(let ((setter (lambda (addr) (- (label-ref label) (1+ addr)))))
|
||||
(push-code! (list inst setter))))
|
||||
|
||||
(($ <glil-call> inst n)
|
||||
(push-code! (list inst n)))
|
||||
|
||||
(($ <glil-inst> inst)
|
||||
(($ <glil-call> inst nargs)
|
||||
(if (instruction? inst)
|
||||
(push-code! (list inst))
|
||||
(let ((pops (instruction-pops inst)))
|
||||
(cond ((< pops 0)
|
||||
(push-code! (list inst nargs)))
|
||||
((= pops nargs)
|
||||
(push-code! (list inst)))
|
||||
(else
|
||||
(error "Wrong number of arguments:" inst nargs))))
|
||||
(error "Unknown instruction:" inst)))))
|
||||
;;
|
||||
;; main
|
||||
|
|
@ -242,9 +245,8 @@
|
|||
;; dump object table
|
||||
(cond ((null? objs) (push-code! (object->code #f)))
|
||||
(else
|
||||
(push-code! `(mark))
|
||||
(for-each dump-object! objs)
|
||||
(push-code! `(vector))))))
|
||||
(push-code! `(vector ,(length objs)))))))
|
||||
;; dump bytecode
|
||||
(push-code! `(load-program ,(bytespec-bytes spec)))))
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -83,17 +83,15 @@
|
|||
((keyword? x)
|
||||
(push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x)))))
|
||||
((list? x)
|
||||
(push-code! `(mark))
|
||||
(for-each dump! x)
|
||||
(push-code! `(list)))
|
||||
(push-code! `(list ,(length x))))
|
||||
((pair? x)
|
||||
(dump! (car x))
|
||||
(dump! (cdr x))
|
||||
(push-code! `(cons)))
|
||||
((vector? x)
|
||||
(push-code! `(mark))
|
||||
(for-each dump! (vector->list x))
|
||||
(push-code! `(vector)))
|
||||
(push-code! `(vector ,(vector-length x))))
|
||||
(else
|
||||
(error "Cannot dump:" x))))
|
||||
(reverse! stack)))
|
||||
|
|
@ -110,6 +108,9 @@
|
|||
(if (< n 32768) n (- n 65536))))
|
||||
(('make-char8 n)
|
||||
(integer->char n))
|
||||
(('load-string s) s)
|
||||
(('load-symbol s) (string->symbol s))
|
||||
(('load-keyword s) (symbol->keyword (string->symbol s)))
|
||||
(else #f)))
|
||||
|
||||
(define-public (make-byte-decoder bytes)
|
||||
|
|
|
|||
|
|
@ -64,7 +64,8 @@
|
|||
(print-info addr (format #f "load-program #~A" sym) #f)))
|
||||
(else
|
||||
(let ((info (list->string code))
|
||||
(extra (original-value code (if (null? opt) #f (car opt)))))
|
||||
(extra (original-value addr code
|
||||
(if (null? opt) #f (car opt)))))
|
||||
(print-info addr info extra))))))
|
||||
(for-each (lambda (sym+bytes)
|
||||
(format #t "Bytecode #~A:\n\n" (car sym+bytes))
|
||||
|
|
@ -86,22 +87,22 @@
|
|||
meta)
|
||||
(newline))
|
||||
|
||||
(define (original-value code table)
|
||||
(define (original-value addr code objs)
|
||||
(define (branch-code? code)
|
||||
(string-match "^(br|jump)" (symbol->string (car code))))
|
||||
(let ((code (code-unpack code)))
|
||||
(cond ((code->object code) => object->string)
|
||||
;;; ((branch-code? code)
|
||||
;;; (format #f "-> ~A" (+ addr (cadr code))))
|
||||
((branch-code? code)
|
||||
(format #f "-> ~A" (+ addr (cadr code))))
|
||||
(else
|
||||
(let ((inst (car code)) (args (cdr code)))
|
||||
(case inst
|
||||
((make-false) "#f")
|
||||
;;; ((object-ref)
|
||||
;;; (object->string (vector-ref objs (car args))))
|
||||
((local-ref local-set)
|
||||
;;'(ref x))
|
||||
#f)
|
||||
((object-ref)
|
||||
(if objs (object->string (vector-ref objs (car args))) #f))
|
||||
;;; ((local-ref local-set)
|
||||
;;; ;;'(ref x))
|
||||
;;; #f)
|
||||
;;; ((module-ref module-set)
|
||||
;;; (let ((var (vector-ref objs (car args))))
|
||||
;;; (list (if (eq? inst 'module-ref) 'ref 'set)
|
||||
|
|
@ -114,5 +115,5 @@
|
|||
|
||||
(define (print-info addr info extra)
|
||||
(if extra
|
||||
(format #t "~4@A ~24A;; ~A\n" addr info extra)
|
||||
(format #t "~4@A ~32A;; ~A\n" addr info extra)
|
||||
(format #t "~4@A ~A\n" addr info)))
|
||||
|
|
|
|||
|
|
@ -23,38 +23,39 @@
|
|||
:use-module (system vm core)
|
||||
:use-module (system vm frame)
|
||||
:use-module (ice-9 format)
|
||||
:export (vm-trace))
|
||||
:use-module (ice-9 and-let-star)
|
||||
:export (vm-trace vm-trace-start! vm-trace-end!))
|
||||
|
||||
(define (vm-trace vm prog . opts)
|
||||
(let ((flag (vm-option vm 'debug)))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set-vm-option! vm 'debug #t)
|
||||
(set-vm-option! vm 'first-apply #t)
|
||||
(lambda () (apply vm-trace-start! vm opts))
|
||||
(lambda () (vm prog))
|
||||
(lambda () (apply vm-trace-end! vm opts))))
|
||||
|
||||
(define (vm-trace-start! vm . opts)
|
||||
(set-vm-option! vm 'trace-first #t)
|
||||
(if (memq :a opts)
|
||||
(add-hook! (vm-next-hook vm) trace-next))
|
||||
(add-hook! (vm-apply-hook vm) trace-apply)
|
||||
(add-hook! (vm-return-hook vm) trace-return))
|
||||
(lambda ()
|
||||
(vm prog))
|
||||
(lambda ()
|
||||
(set-vm-option! vm 'debug flag)
|
||||
|
||||
(define (vm-trace-end! vm . opts)
|
||||
(if (memq :a opts)
|
||||
(remove-hook! (vm-next-hook vm) trace-next))
|
||||
(remove-hook! (vm-apply-hook vm) trace-apply)
|
||||
(remove-hook! (vm-return-hook vm) trace-return)))))
|
||||
(remove-hook! (vm-return-hook vm) trace-return))
|
||||
|
||||
(define (trace-next vm)
|
||||
(let ((frame (vm-current-frame vm)))
|
||||
(format #t "0x~X ~20S~S\t~S\n"
|
||||
(format #t "0x~8X ~20S~S\t~S\n"
|
||||
(vm:ip vm)
|
||||
(vm-fetch-code vm)
|
||||
(frame-variables frame)
|
||||
(vm-fetch-stack vm))))
|
||||
|
||||
(define (trace-apply vm)
|
||||
(if (vm-option vm 'first-apply)
|
||||
(set-vm-option! vm 'first-apply #f) ;; skip the initial program
|
||||
(if (vm-option vm 'trace-first)
|
||||
(set-vm-option! vm 'trace-first #f) ;; skip the initial program
|
||||
(let ((frame (vm-current-frame vm)))
|
||||
(print-prefix (frame-dynamic-link frame))
|
||||
(write (frame->call frame))
|
||||
|
|
|
|||
|
|
@ -96,7 +96,27 @@ SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
|
|||
#define FUNC_NAME s_scm_instruction_length
|
||||
{
|
||||
SCM_VALIDATE_INSTRUCTION (1, inst);
|
||||
return SCM_MAKINUM (SCM_INSTRUCTION_LEN (inst));
|
||||
return SCM_MAKINUM (SCM_INSTRUCTION_LENGTH (inst));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
|
||||
(SCM inst),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_instruction_pops
|
||||
{
|
||||
SCM_VALIDATE_INSTRUCTION (1, inst);
|
||||
return SCM_MAKINUM (SCM_INSTRUCTION_POPS (inst));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
|
||||
(SCM inst),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_instruction_pushes
|
||||
{
|
||||
SCM_VALIDATE_INSTRUCTION (1, inst);
|
||||
return SCM_MAKINUM (SCM_INSTRUCTION_PUSHES (inst));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
|
|||
|
|
@ -59,13 +59,17 @@ enum scm_opcode {
|
|||
struct scm_instruction {
|
||||
enum scm_opcode opcode; /* opcode */
|
||||
char *name; /* instruction name */
|
||||
char len; /* byte length */
|
||||
char len; /* instruction length */
|
||||
char npop; /* the number of values popped */
|
||||
char npush; /* the number of values pushed */
|
||||
};
|
||||
|
||||
#define SCM_INSTRUCTION_P(x) (scm_lookup_instruction (x))
|
||||
#define SCM_INSTRUCTION_OPCODE(i) (scm_lookup_instruction (i)->opcode)
|
||||
#define SCM_INSTRUCTION_NAME(i) (scm_lookup_instruction (i)->name)
|
||||
#define SCM_INSTRUCTION_LEN(i) (scm_lookup_instruction (i)->len)
|
||||
#define SCM_INSTRUCTION_LENGTH(i) (scm_lookup_instruction (i)->len)
|
||||
#define SCM_INSTRUCTION_POPS(i) (scm_lookup_instruction (i)->npop)
|
||||
#define SCM_INSTRUCTION_PUSHES(i) (scm_lookup_instruction (i)->npush)
|
||||
#define SCM_VALIDATE_INSTRUCTION(p,x) SCM_MAKE_VALIDATE (p, x, INSTRUCTION_P)
|
||||
|
||||
#define SCM_INSTRUCTION(i) (&scm_instruction_table[i])
|
||||
|
|
|
|||
14
src/vm.c
14
src/vm.c
|
|
@ -207,9 +207,19 @@ vm_fetch_length (scm_byte_t *ip, size_t *lenp)
|
|||
if (*lenp < 254)
|
||||
return ip;
|
||||
else if (*lenp == 254)
|
||||
*lenp = (*ip++ << 8) + *ip++;
|
||||
{
|
||||
int b1 = *ip++;
|
||||
int b2 = *ip++;
|
||||
*lenp = (b1 << 8) + b2;
|
||||
}
|
||||
else
|
||||
*lenp = (*ip++ << 24) + (*ip++ << 16) + (*ip++ << 8) + *ip++;
|
||||
{
|
||||
int b1 = *ip++;
|
||||
int b2 = *ip++;
|
||||
int b3 = *ip++;
|
||||
int b4 = *ip++;
|
||||
*lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4;
|
||||
}
|
||||
return ip;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -209,19 +209,6 @@ do { \
|
|||
*sp = l; \
|
||||
} while (0)
|
||||
|
||||
#define POP_LIST_MARK() \
|
||||
do { \
|
||||
SCM x; \
|
||||
SCM l = SCM_EOL; \
|
||||
POP (x); \
|
||||
while (!SCM_UNBNDP (x)) \
|
||||
{ \
|
||||
CONS (l, x, l); \
|
||||
POP (x); \
|
||||
} \
|
||||
PUSH (l); \
|
||||
} while (0)
|
||||
|
||||
|
||||
/*
|
||||
* Instruction operation
|
||||
|
|
|
|||
|
|
@ -60,17 +60,17 @@
|
|||
/*
|
||||
* These will go to scm_instruction_table in vm.c
|
||||
*/
|
||||
#define VM_DEFINE_INSTRUCTION(tag,name,len) \
|
||||
{VM_OPCODE (tag), name, len},
|
||||
#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, 0},
|
||||
{VM_OPCODE (tag), name, (nargs < 0) ? 1 : 0, nargs, 1},
|
||||
|
||||
#else
|
||||
#ifdef VM_INSTRUCTION_TO_LABEL
|
||||
/*
|
||||
* These will go to jump_table in vm_engine.c
|
||||
*/
|
||||
#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_ADDR (tag),
|
||||
#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_ADDR (tag),
|
||||
#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_ADDR (tag),
|
||||
|
||||
#else
|
||||
|
|
@ -78,14 +78,14 @@
|
|||
/*
|
||||
* These will go to scm_opcode in vm.h
|
||||
*/
|
||||
#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_OPCODE (tag),
|
||||
#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_OPCODE (tag),
|
||||
#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_OPCODE (tag),
|
||||
|
||||
#else /* Otherwise */
|
||||
/*
|
||||
* These are directly included in vm_engine.c
|
||||
*/
|
||||
#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_TAG (tag)
|
||||
#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_TAG (tag)
|
||||
#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_TAG (tag)
|
||||
|
||||
#endif /* VM_INSTRUCTION_TO_OPCODE */
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@
|
|||
|
||||
/* This file is included in vm_engine.c */
|
||||
|
||||
VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1)
|
||||
VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1, 0, 1)
|
||||
{
|
||||
size_t len;
|
||||
|
||||
|
|
@ -58,7 +58,7 @@ VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1)
|
|||
SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1)
|
||||
VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1, 0, 1)
|
||||
{
|
||||
size_t len;
|
||||
FETCH_LENGTH (len);
|
||||
|
|
@ -67,7 +67,7 @@ VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (load_string, "load-string", -1)
|
||||
VM_DEFINE_INSTRUCTION (load_string, "load-string", -1, 0, 1)
|
||||
{
|
||||
size_t len;
|
||||
FETCH_LENGTH (len);
|
||||
|
|
@ -76,7 +76,7 @@ VM_DEFINE_INSTRUCTION (load_string, "load-string", -1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1)
|
||||
VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1, 0, 1)
|
||||
{
|
||||
SCM sym;
|
||||
size_t len;
|
||||
|
|
@ -87,7 +87,7 @@ VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (load_module, "load-module", -1)
|
||||
VM_DEFINE_INSTRUCTION (load_module, "load-module", -1, 0, 1)
|
||||
{
|
||||
size_t len;
|
||||
FETCH_LENGTH (len);
|
||||
|
|
@ -96,7 +96,7 @@ VM_DEFINE_INSTRUCTION (load_module, "load-module", -1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (load_program, "load-program", -1)
|
||||
VM_DEFINE_INSTRUCTION (load_program, "load-program", -1, 0, 1)
|
||||
{
|
||||
size_t len;
|
||||
SCM prog, x;
|
||||
|
|
@ -127,14 +127,14 @@ VM_DEFINE_INSTRUCTION (load_program, "load-program", -1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (link, "link", 0)
|
||||
VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1)
|
||||
{
|
||||
sp[1] = scm_c_env_vcell (sp[1], sp[0], 1);
|
||||
DROP ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (link_current_module, "link/current-module", 0)
|
||||
VM_DEFINE_INSTRUCTION (link_current_module, "link/current-module", 0, 1, 1)
|
||||
{
|
||||
SCM mod = scm_current_module ();
|
||||
SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
|
||||
|
|
|
|||
|
|
@ -128,13 +128,15 @@ VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
|
|||
|
||||
VM_DEFINE_FUNCTION (list, "list", -1)
|
||||
{
|
||||
POP_LIST_MARK ();
|
||||
ARGSN (an);
|
||||
POP_LIST (an);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (vector, "vector", -1)
|
||||
{
|
||||
POP_LIST_MARK ();
|
||||
ARGSN (an);
|
||||
POP_LIST (an);
|
||||
*sp = scm_vector (*sp);
|
||||
NEXT;
|
||||
}
|
||||
|
|
|
|||
111
src/vm_system.c
111
src/vm_system.c
|
|
@ -47,12 +47,12 @@
|
|||
*/
|
||||
|
||||
/* This must be the first instruction! */
|
||||
VM_DEFINE_INSTRUCTION (nop, "nop", 0)
|
||||
VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0)
|
||||
{
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (halt, "halt", 0)
|
||||
VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
|
||||
{
|
||||
SCM ret = *sp;
|
||||
HALT_HOOK ();
|
||||
|
|
@ -61,13 +61,13 @@ VM_DEFINE_INSTRUCTION (halt, "halt", 0)
|
|||
return ret;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (drop, "drop", 0)
|
||||
VM_DEFINE_INSTRUCTION (drop, "drop", 0, 1, 0)
|
||||
{
|
||||
DROP ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (dup, "dup", 0)
|
||||
VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1)
|
||||
{
|
||||
PUSH (*sp);
|
||||
NEXT;
|
||||
|
|
@ -78,55 +78,55 @@ VM_DEFINE_INSTRUCTION (dup, "dup", 0)
|
|||
* Object creation
|
||||
*/
|
||||
|
||||
VM_DEFINE_INSTRUCTION (void, "void", 0)
|
||||
VM_DEFINE_INSTRUCTION (void, "void", 0, 0, 1)
|
||||
{
|
||||
PUSH (SCM_UNSPECIFIED);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (mark, "mark", 0)
|
||||
VM_DEFINE_INSTRUCTION (mark, "mark", 0, 0, 1)
|
||||
{
|
||||
PUSH (SCM_UNDEFINED);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (make_true, "make-true", 0)
|
||||
VM_DEFINE_INSTRUCTION (make_true, "make-true", 0, 0, 1)
|
||||
{
|
||||
PUSH (SCM_BOOL_T);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (make_false, "make-false", 0)
|
||||
VM_DEFINE_INSTRUCTION (make_false, "make-false", 0, 0, 1)
|
||||
{
|
||||
PUSH (SCM_BOOL_F);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0)
|
||||
VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0, 0, 1)
|
||||
{
|
||||
PUSH (SCM_EOL);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1)
|
||||
VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1, 0, 1)
|
||||
{
|
||||
PUSH (SCM_MAKINUM ((signed char) FETCH ()));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0)
|
||||
VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0, 0, 1)
|
||||
{
|
||||
PUSH (SCM_MAKINUM (0));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0)
|
||||
VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0, 0, 1)
|
||||
{
|
||||
PUSH (SCM_MAKINUM (1));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2)
|
||||
VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2, 0, 1)
|
||||
{
|
||||
int h = FETCH ();
|
||||
int l = FETCH ();
|
||||
|
|
@ -134,7 +134,7 @@ VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1)
|
||||
VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
|
||||
{
|
||||
PUSH (SCM_MAKE_CHAR (FETCH ()));
|
||||
NEXT;
|
||||
|
|
@ -154,7 +154,7 @@ VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1)
|
|||
#define VARIABLE_REF(v) SCM_CDR (v)
|
||||
#define VARIABLE_SET(v,o) SCM_SETCDR (v, o)
|
||||
|
||||
VM_DEFINE_INSTRUCTION (external, "external", 1)
|
||||
VM_DEFINE_INSTRUCTION (external, "external", 1, 0, 0)
|
||||
{
|
||||
int n = FETCH ();
|
||||
while (n-- > 0)
|
||||
|
|
@ -164,25 +164,25 @@ VM_DEFINE_INSTRUCTION (external, "external", 1)
|
|||
|
||||
/* ref */
|
||||
|
||||
VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1)
|
||||
VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1)
|
||||
{
|
||||
PUSH (OBJECT_REF (FETCH ()));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1)
|
||||
VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1, 0, 1)
|
||||
{
|
||||
PUSH (LOCAL_REF (FETCH ()));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (local_ref_0, "local-ref:0", 0)
|
||||
VM_DEFINE_INSTRUCTION (local_ref_0, "local-ref:0", 0, 0, 1)
|
||||
{
|
||||
PUSH (LOCAL_REF (0));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1)
|
||||
VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1, 0, 1)
|
||||
{
|
||||
unsigned int i;
|
||||
SCM e = external;
|
||||
|
|
@ -192,26 +192,13 @@ VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (module_ref, "module-ref", 1)
|
||||
{
|
||||
int i = FETCH ();
|
||||
SCM o, x = OBJECT_REF (i);
|
||||
o = VARIABLE_REF (x);
|
||||
if (SCM_UNBNDP (o))
|
||||
{
|
||||
err_args = SCM_LIST1 (SCM_CAR (x));
|
||||
goto vm_error_unbound;
|
||||
}
|
||||
PUSH (o);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0)
|
||||
VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
|
||||
{
|
||||
SCM x = *sp;
|
||||
SCM o = VARIABLE_REF (x);
|
||||
if (SCM_UNBNDP (o))
|
||||
{
|
||||
/* Try autoload here */
|
||||
err_args = SCM_LIST1 (SCM_CAR (x));
|
||||
goto vm_error_unbound;
|
||||
}
|
||||
|
|
@ -221,14 +208,14 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0)
|
|||
|
||||
/* set */
|
||||
|
||||
VM_DEFINE_INSTRUCTION (local_set, "local-set", 1)
|
||||
VM_DEFINE_INSTRUCTION (local_set, "local-set", 1, 1, 0)
|
||||
{
|
||||
LOCAL_SET (FETCH (), *sp);
|
||||
DROP ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (external_set, "external-set", 1)
|
||||
VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
|
||||
{
|
||||
unsigned int i;
|
||||
SCM e = external;
|
||||
|
|
@ -239,16 +226,7 @@ VM_DEFINE_INSTRUCTION (external_set, "external-set", 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (module_set, "module-set", 1)
|
||||
{
|
||||
int i = FETCH ();
|
||||
SCM x = OBJECT_REF (i);
|
||||
VARIABLE_SET (x, *sp);
|
||||
DROP ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0)
|
||||
VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
|
||||
{
|
||||
VARIABLE_SET (sp[0], sp[1]);
|
||||
sp += 2;
|
||||
|
|
@ -269,37 +247,37 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0)
|
|||
NEXT; \
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if, "br-if", 1)
|
||||
VM_DEFINE_INSTRUCTION (br_if, "br-if", 1, 0, 0)
|
||||
{
|
||||
BR (!SCM_FALSEP (*sp));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1)
|
||||
VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1, 0, 0)
|
||||
{
|
||||
BR (SCM_FALSEP (*sp));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 1)
|
||||
VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 1, 0, 0)
|
||||
{
|
||||
BR (SCM_EQ_P (sp[0], sp--[1]));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1)
|
||||
VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1, 0, 0)
|
||||
{
|
||||
BR (!SCM_EQ_P (sp[0], sp--[1]));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 1)
|
||||
VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 1, 0, 0)
|
||||
{
|
||||
BR (SCM_NULLP (*sp));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 1)
|
||||
VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 1, 0, 0)
|
||||
{
|
||||
BR (!SCM_NULLP (*sp));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (jump, "jump", 1)
|
||||
VM_DEFINE_INSTRUCTION (jump, "jump", 1, 0, 0)
|
||||
{
|
||||
ip += (signed char) FETCH ();
|
||||
NEXT;
|
||||
|
|
@ -310,14 +288,14 @@ VM_DEFINE_INSTRUCTION (jump, "jump", 1)
|
|||
* Subprogram call
|
||||
*/
|
||||
|
||||
VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0)
|
||||
VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1)
|
||||
{
|
||||
SYNC ();
|
||||
*sp = scm_c_make_vclosure (*sp, external);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (call, "call", 1)
|
||||
VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
|
||||
{
|
||||
POP (program);
|
||||
nargs = FETCH ();
|
||||
|
|
@ -368,7 +346,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1)
|
|||
goto vm_error_wrong_type_apply;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1)
|
||||
VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
|
||||
{
|
||||
SCM x;
|
||||
POP (x);
|
||||
|
|
@ -438,7 +416,7 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1)
|
|||
goto vm_error_wrong_type_apply;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1)
|
||||
VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1)
|
||||
{
|
||||
SYNC ();
|
||||
PUSH (capture_vm_cont (vmp));
|
||||
|
|
@ -447,7 +425,7 @@ VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1)
|
|||
goto vm_call;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (return, "return", 0)
|
||||
VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
|
||||
{
|
||||
SCM ret;
|
||||
vm_return:
|
||||
|
|
@ -463,23 +441,6 @@ VM_DEFINE_INSTRUCTION (return, "return", 0)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* Exception handling
|
||||
*/
|
||||
|
||||
VM_DEFINE_INSTRUCTION (raise, "raise", 1)
|
||||
{
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (catch, "catch", 0)
|
||||
{
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (stack_catch, "stach_catch", 0)
|
||||
{
|
||||
}
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue