diff --git a/module/system/vm/load.scm b/module/system/vm/load.scm index d10a5dd7f..6214cc95a 100644 --- a/module/system/vm/load.scm +++ b/module/system/vm/load.scm @@ -20,8 +20,8 @@ ;;; Code: (define-module (system vm load) - :autoload (system base language) (compile-file-in lookup-language) :use-module (system vm core) + :autoload (system base language) (compile-file-in lookup-language) :use-module (ice-9 regex) :export (load/compile)) diff --git a/module/system/vm/slib.scm b/module/system/vm/slib.scm new file mode 100644 index 000000000..22aca47b5 --- /dev/null +++ b/module/system/vm/slib.scm @@ -0,0 +1,251 @@ +;;;; 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 evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (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*)))))) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index e3e524c2d..d7b074cdc 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -25,22 +25,25 @@ :use-module (system vm frame) :use-module (ice-9 format) :use-module (ice-9 and-let-star) - :export (vm-trace)) + :export (vm-trace vm-trace-on vm-trace-off)) (define (vm-trace vm bytes . opts) (dynamic-wind - (lambda () - (set-vm-option! vm 'trace-first #t) - (if (memq :b opts) (add-hook! (vm-next-hook vm) trace-next)) - (set-vm-option! vm 'trace-options opts) - (add-hook! (vm-apply-hook vm) trace-apply) - (add-hook! (vm-return-hook vm) trace-return)) - (lambda () - (vm-load vm bytes)) - (lambda () - (if (memq :b 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)))) + (lambda () (apply vm-trace-on vm opts)) + (lambda () (vm-load vm bytes)) + (lambda () (apply vm-trace-off vm opts)))) + +(define (vm-trace-on vm . opts) + (set-vm-option! vm 'trace-first #t) + (if (memq :b opts) (add-hook! (vm-next-hook vm) trace-next)) + (set-vm-option! vm 'trace-options opts) + (add-hook! (vm-apply-hook vm) trace-apply) + (add-hook! (vm-return-hook vm) trace-return)) + +(define (vm-trace-off vm . opts) + (if (memq :b 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)) (define (trace-next vm) (let ((frame (vm-current-frame vm)))