eval.scm

Scheme跨平台编译器

;;;; eval.scm - Interpreter for CHICKEN
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(declare
  (unit eval)
  (disable-warning var)
  (hide ##sys#unregister-macro ##sys#split-at-separator
	##sys#r4rs-environment ##sys#r5rs-environment 
	##sys#interaction-environment pds pdss pxss) )

#>
#ifndef C_INSTALL_EGG_HOME
# define C_INSTALL_EGG_HOME    "."
#endif

#ifndef C_INSTALL_SHARE_HOME
# define C_INSTALL_SHARE_HOME NULL
#endif
<#

(cond-expand
 [paranoia]
 [else
  (declare
    (no-bound-checks)
    (no-procedure-checks-for-usual-bindings)
    (bound-to-procedure 
     ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string ##sys#load-library
     ##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair ##sys#not-a-proper-list-error
     ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round 
     ##sys#check-number ##sys#cons-flonum ##sys#copy-env-table
     ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg ##sys#print ##sys#check-structure 
     ##sys#make-structure ##sys#feature? ##sys#interpreter-toplevel-macroexpand-hook
     ##sys#error-handler ##sys#hash-symbol ##sys#register-macro ##sys#check-syntax
     ##sys#hash-table-ref ##sys#hash-table-set! ##sys#canonicalize-body ##sys#decompose-lambda-list
     ##sys#make-c-string ##sys#resolve-include-filename ##sys#register-macro-2 
     ##sys#load ##sys#error ##sys#warn ##sys#hash-table-location ##sys#expand-home-path
     ##sys#make-flonum ##sys#make-pointer ##sys#null-pointer ##sys#address->pointer 
     ##sys#pointer->address ##sys#compile-to-closure ##sys#make-string ##sys#make-lambda-info
     ##sys#number? ##sys#symbol->qualified-string ##sys#decorate-lambda ##sys#string-append
     ##sys#ensure-heap-reserve ##sys#syntax-error-hook ##sys#read-prompt-hook
     ##sys#repl-eval-hook ##sys#append ##sys#eval-decorator ##sys#alias-global-hook
     open-output-string get-output-string make-parameter software-type software-version machine-type
     build-platform getenv set-extensions-specifier! ##sys#string->symbol list->vector
     extension-information syntax-error ->string chicken-home ##sys#expand-curried-define
     ##sys#match-expression vector->list store-string open-input-string eval ##sys#gc
     with-exception-handler print-error-message read-char read ##sys#read-error
     ##sys#reset-handler call-with-current-continuation ##sys#peek-char-0 ##sys#read-char-0
     ##sys#clear-trace-buffer ##sys#write-char-0 print-call-chain ##sys#with-print-length-limit
     repl-prompt ##sys#flush-output ##sys#extended-lambda-list? keyword? get-line-number
     symbol->string string-append display ##sys#repository-path ##sys#file-info make-vector
     ##sys#make-vector string-copy vector->list ##sys#do-the-right-thing ##sys#->feature-id
     ##sys#extension-information ##sys#symbol->string ##sys#canonicalize-extension-path
     file-exists? ##sys#load-extension ##sys#find-extension ##sys#substring reverse
     dynamic-load-libraries ##sys#string->c-identifier load-verbose ##sys#load ##sys#get-keyword
     port? ##sys#file-info ##sys#signal-hook ##sys#dload open-input-file close-input-port
     read write newline ##sys#eval-handler ##sys#set-dlopen-flags! cadadr ##sys#lookup-runtime-requirements
     map string->keyword ##sys#abort
     ##sys#macroexpand-0 ##sys#macroexpand-1-local ##sys#hash-table-update!) ) ] )

(cond-expand
 [unsafe
  (eval-when (compile)
    (define-macro (##sys#check-structure . _) '(##core#undefined))
    (define-macro (##sys#check-range . _) '(##core#undefined))
    (define-macro (##sys#check-pair . _) '(##core#undefined))
    (define-macro (##sys#check-list . _) '(##core#undefined))
    (define-macro (##sys#check-symbol . _) '(##core#undefined))
    (define-macro (##sys#check-string . _) '(##core#undefined))
    (define-macro (##sys#check-char . _) '(##core#undefined))
    (define-macro (##sys#check-exact . _) '(##core#undefined))
    (define-macro (##sys#check-port . _) '(##core#undefined))
    (define-macro (##sys#check-number . _) '(##core#undefined))
    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
 [else
  (declare (emit-exports "eval.exports"))])


(define-foreign-variable install-egg-home c-string "C_INSTALL_EGG_HOME")
(define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")

(define ##sys#core-library-modules
  '(extras lolevel utils tcp regex regex-extras posix match
    data-structures ports files srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69))

(define ##sys#explicit-library-modules '())

(define-constant macro-table-size 301)
(define-constant default-dynamic-load-libraries '("libchicken"))
(define-constant cygwin-default-dynamic-load-libraries '("cygchicken-0"))
(define-constant macosx-load-library-extension ".dylib")
(define-constant windows-load-library-extension ".dll")
(define-constant hppa-load-library-extension ".sl")
(define-constant default-load-library-extension ".so")
(define-constant environment-table-size 301)
(define-constant source-file-extension ".scm")
(define-constant setup-file-extension "setup-info")
(define-constant repository-environment-variable "CHICKEN_REPOSITORY")
(define-constant prefix-environment-variable "CHICKEN_PREFIX")
(define-constant special-syntax-files '(chicken-ffi-macros chicken-more-macros))
(define-constant default-binary-version 3)

; these are actually in unit extras, but that is used by default
; srfi-12 in unit library
(define-constant builtin-features
  '(chicken srfi-2 srfi-6 srfi-10 srfi-12 srfi-23 srfi-28 srfi-30 srfi-31 srfi-39) )

(define-constant builtin-features/compiled
  '(srfi-6 srfi-8 srfi-9 srfi-11 srfi-15 srfi-16 srfi-17 srfi-26 srfi-55) )

(define ##sys#chicken-prefix
  (let ((prefix (and-let* ((p (getenv prefix-environment-variable)))
		  (##sys#string-append 
		   p
		   (if (memq (string-ref p (fx- (##sys#size p) 1)) '(#\\ #\/))
		       "" "/") ) ) ) )
    (lambda (#!optional dir)
      (and prefix
	   (if dir (##sys#string-append prefix dir) prefix) ) ) ) )
	  

;;; System settings

(define chicken-home
  (let ([getenv getenv])
    (lambda ()
      (or (##sys#chicken-prefix "share/chicken")
	  installation-home) ) ) )


;;; Macro handling:

(define ##sys#macro-environment (make-vector macro-table-size '()))

(define (##sys#register-macro-2 name handler)
  (##sys#hash-table-set! 
   ##sys#macro-environment name
   (lambda (form) (handler (##sys#slot form 1))) ) )

(define ##sys#register-macro
  (lambda (name handler)
    (##sys#hash-table-set! 
     ##sys#macro-environment name
     (lambda (form) (apply handler (##sys#slot form 1))) ) ) )

(define (##sys#copy-macro old new)
  (##sys#hash-table-set! ##sys#macro-environment new (##sys#hash-table-ref ##sys#macro-environment old)) )

(define (macro? sym)
  (##sys#check-symbol sym 'macro?)
  (and (##sys#hash-table-ref ##sys#macro-environment sym) #t) )

(define (##sys#unregister-macro name)
  (##sys#hash-table-set! ##sys#macro-environment name #f) )

(define (undefine-macro! name)
  (##sys#check-symbol name 'undefine-macro!)
  (##sys#unregister-macro name) )


;; The basic macro-expander

(define ##sys#macroexpand-0
  (let ([string-append string-append])
    (lambda (exp me)

      (define (call-handler name handler exp)
	(handle-exceptions ex
	    (##sys#abort
	     (if (and (##sys#structure? ex 'condition)
		      (memv 'exn (##sys#slot ex 1)) )
		 (##sys#make-structure
		  'condition
		  (##sys#slot ex 1)
		  (let copy ([ps (##sys#slot ex 2)])
		    (if (null? ps)
			'()
			(let ([p (car ps)]
			      [r (cdr ps)])
			  (if (and (equal? '(exn . message) p)
				   (pair? r)
				   (string? (car r)) )
			      (cons 
			       '(exn . message)
			       (cons (string-append
				      "during expansion of (" (##sys#slot name 1) " ...) - "
				      (car r) )
				     (cdr r) ) )
			      (copy r) ) ) ) ) )
		 ex) )
	  (handler exp) ) )
				   
      (define (expand exp head)
	(cond [(assq head me) => (lambda (mdef) (values ((##sys#slot mdef 1) exp) #t))]
	      [(##sys#hash-table-ref ##sys#macro-environment head) 
	       => (lambda (handler)
		    (cond-expand
		     [unsafe (values (call-handler head handler exp) #t)]
		     [else
		      (let scan ([x exp])
			(cond [(null? x) (values (call-handler head handler exp) #t)]
			      [(pair? x) (scan (##sys#slot x 1))]
			      [else (##sys#syntax-error-hook "invalid syntax in macro form" exp)] ) ) ] ) ) ]
	      [else (values exp #f)] ) )

      (if (pair? exp)
	  (let ([head (##sys#slot exp 0)]
		[body (##sys#slot exp 1)] )
	    (if (symbol? head)
		(cond [(eq? head 'let)
		       (##sys#check-syntax 'let body '#(_ 2))
		       (let ([bindings (car body)])
			 (cond [(symbol? bindings)
				(##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)))
				(let ([bs (cadr body)])
				  (values
				   `(##core#app
				     (letrec ([,bindings (##core#loop-lambda ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
				       ,bindings)
				     ,@(##sys#map cadr bs) )
				   #t) ) ]
			       [else (values exp #f)] ) ) ]
		      [(and (memq head '(set! ##core#set!))
			    (pair? body)
			    (pair? (##sys#slot body 0)) )
		       (let ([dest (##sys#slot body 0)])
			 (##sys#check-syntax 'set! body '(#(_ 1) _))
			 (values
			  (append (list (list '##sys#setter (##sys#slot dest 0)))
				  (##sys#slot dest 1)
				  (##sys#slot body 1) ) 
			  #t) ) ]
		      [else (expand exp head)] )
		(values exp #f) ) )
	  (values exp #f) ) ) ) )


;;; These are needed to hook other module/macro systems into the evaluator and compiler

(define (##sys#compiler-toplevel-macroexpand-hook exp) exp)
(define (##sys#interpreter-toplevel-macroexpand-hook exp) exp)
(define (##sys#macroexpand-1-local exp me) (##sys#macroexpand-0 exp me))


;;; For the compiler

(define ##sys#enable-runtime-macros #f)


;;; User-level macroexpansion

(define (macroexpand exp . me)
  (let ((me (if (pair? me) (car me) '())))
    (let loop ([exp exp])
      (let-values ([(exp2 m) (##sys#macroexpand-0 exp me)])
	(if m
	    (loop exp2)
	    exp2) ) ) ) )

(define (macroexpand-1 exp . me)
  (##sys#macroexpand-0 exp (if (pair? me) (car me) '())) )


;;; Extended (DSSSL-style) lambda lists
;
; Assumptions:
;
; 1) #!rest must come before #!key
; 2) default values may refer to earlier variables
; 3) optional/key args may be either variable or (variable default)
; 4) an argument marker may not be specified more than once
; 5) no special handling of extra keywords (no error)
; 6) default value of optional/key args is #f
; 7) mixing with dotted list syntax is allowed

(define (##sys#extended-lambda-list? llist)
  (let loop ([llist llist])
    (and (pair? llist)
	 (case (##sys#slot llist 0)
	   [(#!rest #!optional #!key) #t]
	   [else (loop (##sys#slot llist 1))] ) ) ) )

(define ##sys#expand-extended-lambda-list
  (let ([reverse reverse]
	[gensym gensym] )
    (lambda (llist0 body errh)
      (define (err msg) (errh msg llist0))
      (define (->keyword s) (string->keyword (##sys#slot s 1)))
      (let ([rvar #f]
	    [hasrest #f] )
	(let loop ([mode 0]		; req, opt, rest, key, end
		   [req '()]
		   [opt '()]
		   [key '()] 
		   [llist llist0] )
	  (cond [(null? llist)
		 (values 
		  (if rvar (##sys#append (reverse req) rvar) (reverse req))
		  (let ([body 
			 (if (null? key)
			     body
			     `((let* ,(map (lambda (k)
					     (let ([s (car k)])
					       `[,s (##sys#get-keyword 
						     ',(->keyword s) ,rvar
						     ,@(if (pair? (cdr k)) 
							   `((lambda () ,@(cdr k)))
							   '() ) ) ] ) )
					   (reverse key) )
				 ,@body) ) ) ] )
		    (cond [(null? opt) body]
			  [(and (not hasrest) (null? key) (null? (cdr opt)))
			   `((let ([,(caar opt) (:optional ,rvar ,(cadar opt))])
			       ,@body) ) ]
			  [(and (not hasrest) (null? key)) `((let-optionals ,rvar ,(reverse opt) ,@body))]
			  [else 
			   `((let-optionals* ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar))) 
			      ,@body))] ) ) ) ]
		[(symbol? llist) 
		 (if (fx> mode 2)
		     (err "rest argument list specified more than once")
		     (begin
		       (if (not rvar) (set! rvar llist))
		       (set! hasrest llist)
		       (loop 4 req opt '() '()) ) ) ]
		[(not (pair? llist))
		 (err "invalid lambda list syntax") ]
		[else
		 (let ([x (##sys#slot llist 0)]
		       [r (##sys#slot llist 1)])
		   (case x
		     [(#!optional)
		      (if (not rvar) (set! rvar (gensym)))
		      (if (eq? mode 0)
			  (loop 1 req '() '() r)
			  (err "`#!optional' argument marker in wrong context") ) ]
		     [(#!rest)
		      (if (fx<= mode 1)
			  (if (and (pair? r) (symbol? (##sys#slot r 0)))
			      (begin
				(if (not rvar) (set! rvar (##sys#slot r 0)))
				(set! hasrest (##sys#slot r 0))
				(loop 2 req opt '() (##sys#slot r 1)) )
			      (err "invalid syntax of `#!rest' argument") )