diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 053b11426..88256c2f2 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -28,7 +28,10 @@ :select (the-vm vm-load objcode->u8vector)) :use-module (system vm assemble) :use-module (ice-9 regex) - :export ( make-cenv cenv? cenv-vm cenv-language cenv-module)) + :export ( make-cenv cenv? cenv-vm cenv-language cenv-module + syntax-error compile-file load-source-file load-file + compiled-file-name + scheme-eval read-file-in compile-in)) ;;; ;;; Compiler environment @@ -36,7 +39,7 @@ (define-record ( vm language module)) -(define-public (syntax-error loc msg exp) +(define (syntax-error loc msg exp) (throw 'syntax-error loc msg exp)) (define-macro (call-with-compile-error-catch thunk) @@ -57,7 +60,7 @@ (define scheme (lookup-language 'scheme)) -(define-public (compile-file file . opts) +(define (compile-file file . opts) (let ((comp (compiled-file-name file))) (catch 'nothing-at-all (lambda () @@ -89,21 +92,21 @@ ; (format #t "compile-file: returned ~a~%" result) ; result)))) -(define-public (load-source-file file . opts) +(define (load-source-file file . opts) (let ((source (read-file-in file scheme))) (apply compile-in source (current-module) scheme opts))) -(define-public (load-file file . opts) +(define (load-file file . opts) (let ((comp (compiled-file-name file))) (if (file-exists? comp) (load-objcode comp) (apply load-source-file file opts)))) -(define-public (compiled-file-name file) +(define (compiled-file-name file) (let ((m (string-match "\\.[^.]*$" file))) (string-append (if m (match:prefix m) file) ".go"))) -(define-public (scheme-eval x e) +(define (scheme-eval x e) (vm-load (the-vm) (compile-in x e scheme))) @@ -111,10 +114,10 @@ ;;; Scheme compiler interface ;;; -(define-public (read-file-in file lang) +(define (read-file-in file lang) (call-with-input-file file (language-read-file lang))) -(define-public (compile-in x e lang . opts) +(define (compile-in x e lang . opts) (catch 'result (lambda () ;; expand diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm index 02b939529..d70f4f063 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -79,7 +79,10 @@ ghil-mod-module ghil-mod-table ghil-mod-imports make-ghil-env ghil-env? - ghil-env-mod ghil-env-parent ghil-env-table ghil-env-variables)) + ghil-env-mod ghil-env-parent ghil-env-table ghil-env-variables + + ghil-primitive-macro? ghil-env-add! ghil-lookup + call-with-ghil-environment call-with-ghil-bindings)) ;;; @@ -118,7 +121,7 @@ (define *macro-module* (resolve-module '(system il macros))) -(define-public (ghil-primitive-macro? x) +(define (ghil-primitive-macro? x) (and (module-defined? *macro-module* x) (procedure? (module-ref *macro-module* x)))) @@ -151,7 +154,7 @@ (define-record ( mod parent (table '()) (variables '()))) (define %make-ghil-env make-ghil-env) -(define-public (make-ghil-env e) +(define (make-ghil-env e) (record-case e (() (%make-ghil-env :mod e :parent e)) (( mod) (%make-ghil-env :mod mod :parent e)))) @@ -169,7 +172,7 @@ (define-macro (apopq! k loc) `(set! ,loc (assq-remove! ,k ,loc))) -(define-public (ghil-env-add! env var) +(define (ghil-env-add! env var) (apush! (ghil-var-name var) var (ghil-env-table env)) (push! var (ghil-env-variables env))) @@ -182,7 +185,7 @@ ;;; ;; looking up a var has side effects? -(define-public (ghil-lookup env sym) +(define (ghil-lookup env sym) (or (ghil-env-ref env sym) (let loop ((e (ghil-env-parent env))) (record-case e @@ -197,7 +200,7 @@ (begin (set! (ghil-var-kind found) 'external) found) (loop parent)))))))) -(define-public (call-with-ghil-environment e syms func) +(define (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))) @@ -205,7 +208,7 @@ syms))) (func e vars))) -(define-public (call-with-ghil-bindings e syms func) +(define (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)) diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm index 15f0b0b04..30de3f945 100644 --- a/module/system/repl/describe.scm +++ b/module/system/repl/describe.scm @@ -49,13 +49,13 @@ (format #t "@class{~a}{~a}" name desc) (format #t "~a" desc)))) -(define-public (display-list title list) +(define (display-list title list) (if title (begin (display title) (display ":\n\n"))) (if (null? list) (display "(not defined)\n") (for-each display-summary list))) -(define-public (display-slot-list title instance list) +(define (display-slot-list title instance list) (if title (begin (display title) (display ":\n\n"))) (if (null? list) (display "(not defined)\n") @@ -70,13 +70,13 @@ (newline))) list))) -(define-public (display-file location) +(define (display-file location) (display "Defined in ") (if (eq? *describe-format* 'tag) (format #t "@location{~a}.\n" location) (format #t "`~a'.\n" location))) -(define-public (format-documentation doc) +(define (format-documentation doc) (with-current-buffer (make-buffer #:text doc) (lambda () (let ((regexp (make-regexp "@([a-z]*)(\\{([^\}]*)\\})?"))) diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm index 55c3c8465..83f09a3fa 100644 --- a/module/system/vm/core.scm +++ b/module/system/vm/core.scm @@ -19,7 +19,16 @@ ;;; Code: -(define-module (system vm core)) +(define-module (system vm core) + :export (arity:nargs arity:nrest arity:nlocs arity:nexts + make-binding binding:name binding:extp binding:index + program-bindings program-sources + frame-arguments frame-local-variables frame-external-variables + frame-environment + frame-variable-exists? frame-variable-ref frame-variable-set! + frame-object-name + vm-fetch-locals vm-fetch-externals vm-return-value + vms:time vms:clock vm-load)) ;;; ;;; Core procedures @@ -37,23 +46,23 @@ ;;; Programs ;;; -(define-public arity:nargs car) -(define-public arity:nrest cadr) -(define-public arity:nlocs caddr) -(define-public arity:nexts cadddr) +(define arity:nargs car) +(define arity:nrest cadr) +(define arity:nlocs caddr) +(define arity:nexts cadddr) -(define-public (make-binding name extp index) +(define (make-binding name extp index) (list name extp index)) -(define-public binding:name car) -(define-public binding:extp cadr) -(define-public binding:index caddr) +(define binding:name car) +(define binding:extp cadr) +(define binding:index caddr) -(define-public (program-bindings prog) +(define (program-bindings prog) (cond ((program-meta prog) => car) (else '()))) -(define-public (program-sources prog) +(define (program-sources prog) (cond ((program-meta prog) => cdr) (else '()))) @@ -62,21 +71,21 @@ ;;; Frames ;;; -(define-public (frame-arguments frame) +(define (frame-arguments frame) (let* ((prog (frame-program frame)) (arity (program-arity prog))) (do ((n (+ (arity:nargs arity) -1) (1- n)) (l '() (cons (frame-local-ref frame n) l))) ((< n 0) l)))) -(define-public (frame-local-variables frame) +(define (frame-local-variables frame) (let* ((prog (frame-program frame)) (arity (program-arity prog))) (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n)) (l '() (cons (frame-local-ref frame n) l))) ((< n 0) l)))) -(define-public (frame-external-variables frame) +(define (frame-external-variables frame) (frame-external-link frame)) (define (frame-external-ref frame index) @@ -111,25 +120,25 @@ ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs)))) (and (pair? bs) (car bs))))) -(define-public (frame-environment frame addr) +(define (frame-environment frame addr) (map (lambda (binding) (cons (binding:name binding) (frame-binding-ref frame binding))) (frame-bindings frame addr))) -(define-public (frame-variable-exists? frame addr sym) +(define (frame-variable-exists? frame addr sym) (if (frame-lookup-binding frame addr sym) #t #f)) -(define-public (frame-variable-ref frame addr sym) +(define (frame-variable-ref frame addr sym) (cond ((frame-lookup-binding frame addr sym) => (lambda (binding) (frame-binding-ref frame binding))) (else (error "Unknown variable:" sym)))) -(define-public (frame-variable-set! frame addr sym val) +(define (frame-variable-set! frame addr sym val) (cond ((frame-lookup-binding frame addr sym) => (lambda (binding) (frame-binding-set! frame binding val))) (else (error "Unknown variable:" sym)))) -(define-public (frame-object-name frame addr obj) +(define (frame-object-name frame addr obj) (cond ((frame-object-binding frame addr obj) => binding:name) (else #f))) @@ -138,13 +147,13 @@ ;;; Current status ;;; -(define-public (vm-fetch-locals vm) +(define (vm-fetch-locals vm) (frame-local-variables (vm-this-frame vm))) -(define-public (vm-fetch-externals vm) +(define (vm-fetch-externals vm) (frame-external-variables (vm-this-frame vm))) -(define-public (vm-return-value vm) +(define (vm-return-value vm) (car (vm-fetch-stack vm))) @@ -152,15 +161,15 @@ ;;; Statistics ;;; -(define-public (vms:time stat) (vector-ref stat 0)) -(define-public (vms:clock stat) (vector-ref stat 1)) +(define (vms:time stat) (vector-ref stat 0)) +(define (vms:clock stat) (vector-ref stat 1)) ;;; ;;; Loader ;;; -(define-public (vm-load vm objcode) +(define (vm-load vm objcode) (vm (objcode->program objcode))) ;; `load-compiled' is referred to by `boot-9.scm' and used by `use-modules' diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 2145b324e..7e5286e76 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -20,20 +20,23 @@ ;;; Code: (define-module (system vm frame) - :use-module ((system vm core) :renamer (symbol-prefix-proc 'vm:))) + :use-module ((system vm core) :renamer (symbol-prefix-proc 'vm:)) + :export (frame-number frame-address + vm-current-frame-chain vm-last-frame-chain + print-frame print-frame-call)) ;;; ;;; Frame chain ;;; -(define-public frame-number (make-object-property)) -(define-public frame-address (make-object-property)) +(define frame-number (make-object-property)) +(define frame-address (make-object-property)) -(define-public (vm-current-frame-chain vm) +(define (vm-current-frame-chain vm) (make-frame-chain (vm:vm-this-frame vm) (vm:vm:ip vm))) -(define-public (vm-last-frame-chain vm) +(define (vm-last-frame-chain vm) (make-frame-chain (vm:vm-last-frame vm) (vm:vm:ip vm))) (define (make-frame-chain frame addr) @@ -52,12 +55,12 @@ ;;; Pretty printing ;;; -(define-public (print-frame frame) +(define (print-frame frame) (format #t "#~A " (vm:frame-number frame)) (print-frame-call frame) (newline)) -(define-public (print-frame-call frame) +(define (print-frame-call frame) (define (abbrev x) (cond ((list? x) (if (> (length x) 3) (list (abbrev (car x)) (abbrev (cadr x)) '...) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 19b31f288..0b028277f 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -23,22 +23,23 @@ :use-syntax (system base syntax) :use-module (system vm core) :use-module (system vm frame) - :use-module (ice-9 format)) + :use-module (ice-9 format) + :export (vm-trace vm-trace-on vm-trace-off)) -(define-public (vm-trace vm objcode . opts) +(define (vm-trace vm objcode . opts) (dynamic-wind (lambda () (apply vm-trace-on vm opts)) (lambda () (vm-load vm objcode)) (lambda () (apply vm-trace-off vm opts)))) -(define-public (vm-trace-on 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-public (vm-trace-off vm . opts) +(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))