evaluation.scm (6070B)
1 ;;; evaluation.scm -- evaluation, compilation and macro-expansion 2 3 ;; Copyright (C) 2009, 2010, 2011, 2013, 2015, 2022 Jose Antonio Ortega Ruiz 4 5 ;; This program is free software; you can redistribute it and/or 6 ;; modify it under the terms of the Modified BSD License. You should 7 ;; have received a copy of the license along with this program. If 8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. 9 10 ;; Start date: Mon Mar 02, 2009 02:46 11 12 (cond-expand 13 (guile-2.2 14 (define-module (geiser evaluation) 15 #:export (ge:compile 16 ge:eval 17 ge:macroexpand 18 ge:compile-file 19 ge:load-file 20 ge:set-warnings 21 ge:add-to-load-path) 22 #:use-module (geiser modules) 23 #:use-module (srfi srfi-1) 24 #:use-module (language tree-il) 25 #:use-module (system base compile) 26 #:use-module (system base message) 27 #:use-module (system base pmatch) 28 #:use-module (system vm program) 29 #:use-module (ice-9 pretty-print) 30 #:use-module (ice-9 textual-ports) 31 #:use-module (system vm loader))) 32 (else 33 (define-module (geiser evaluation) 34 #:export (ge:compile 35 ge:eval 36 ge:macroexpand 37 ge:compile-file 38 ge:load-file 39 ge:set-warnings 40 ge:add-to-load-path) 41 #:use-module (geiser modules) 42 #:use-module (srfi srfi-1) 43 #:use-module (language tree-il) 44 #:use-module (system base compile) 45 #:use-module (system base message) 46 #:use-module (system base pmatch) 47 #:use-module (system vm program) 48 #:use-module (ice-9 pretty-print) 49 #:use-module (ice-9 textual-ports)))) 50 51 52 (define compile-opts '()) 53 (define compile-file-opts '()) 54 55 (define default-warnings '(arity-mismatch unbound-variable format)) 56 (define verbose-warnings `(unused-variable ,@default-warnings)) 57 58 (define (ge:set-warnings wl) 59 (let* ((warns (cond ((list? wl) wl) 60 ((symbol? wl) (case wl 61 ((none nil null) '()) 62 ((medium default) default-warnings) 63 ((high verbose) verbose-warnings) 64 (else '()))) 65 (else '()))) 66 (fwarns (if (memq 'unused-variable warns) 67 (cons 'unused-toplevel warns) 68 warns))) 69 (set! compile-opts (list #:warnings warns)) 70 (set! compile-file-opts (list #:warnings fwarns)))) 71 72 (ge:set-warnings 'none) 73 74 (define context-port #f) 75 76 (define switcher-port 77 (make-soft-port (vector (lambda (c) (put-char c context-port)) 78 (lambda (s) (display s context-port)) 79 (lambda () (force-output context-port)) 80 (lambda () (close-port context-port)) 81 (lambda () 0)) 82 "w")) 83 84 (define (call-with-switcher-output long-port thunk) 85 (let ((current (current-output-port))) 86 (parameterize ((current-output-port switcher-port)) 87 (dynamic-wind 88 (lambda () (set! context-port current)) 89 thunk 90 (lambda () (set! context-port long-port)))))) 91 92 (define (call-with-result thunk) 93 (letrec* ((result #f) 94 (long-port (current-output-port)) 95 (run-thunk (lambda () (call-with-switcher-output long-port thunk))) 96 (output 97 (with-output-to-string 98 (lambda () 99 (with-fluids ((*current-warning-port* (current-output-port)) 100 (*current-warning-prefix* "")) 101 (with-error-to-port (current-output-port) 102 (lambda () 103 (set! result (map object->string (run-thunk)))))))))) 104 (write `((result ,@result) (output . ,output))) 105 (newline))) 106 107 (define (ge:compile form module) 108 (compile* form module compile-opts)) 109 110 (define (compile* form module-name opts) 111 (let* ((module (or (find-module module-name) (current-module))) 112 (ev (lambda () 113 (call-with-values 114 (lambda () 115 (let* ((to (cond-expand (guile-2.2 'bytecode) 116 (else 'objcode))) 117 (cf (cond-expand (guile-2.2 load-thunk-from-memory) 118 (else make-program))) 119 (o (compile form 120 #:to to 121 #:env module 122 #:opts opts)) 123 (thunk (cf o))) 124 (start-stack 'geiser-evaluation-stack 125 (eval `(,thunk) module)))) 126 (lambda vs vs))))) 127 (call-with-result ev))) 128 129 (define (ge:eval form module-name) 130 (let* ((module (or (find-module module-name) (current-module))) 131 (ev (lambda () 132 (call-with-values 133 (lambda () (eval form module)) 134 (lambda vs vs))))) 135 (call-with-result ev))) 136 137 (define (ge:compile-file path) 138 (call-with-result 139 (lambda () 140 (let ((cr (compile-file path 141 #:canonicalization 'absolute 142 #:opts compile-file-opts))) 143 (and cr 144 (list (object->string (save-module-excursion 145 (lambda () (load-compiled cr)))))))))) 146 147 (define ge:load-file ge:compile-file) 148 149 (define (ge:macroexpand form . all) 150 (let ((all (and (not (null? all)) (car all)))) 151 (with-output-to-string 152 (lambda () 153 (pretty-print (tree-il->scheme (macroexpand form))))))) 154 155 (define (ge:add-to-load-path dir) 156 (and (file-is-directory? dir) 157 (let ((in-lp (member dir %load-path)) 158 (in-clp (member dir %load-compiled-path))) 159 (when (not in-lp) 160 (set! %load-path (cons dir %load-path))) 161 (when (not in-clp) 162 (set! %load-compiled-path (cons dir %load-compiled-path))) 163 (or in-lp in-clp))))