eval.scm

Scheme跨平台编译器

;;; Loading source/object files:

(define load-verbose (make-parameter (##sys#fudge 13)))

(define (##sys#abort-load) #f)
(define ##sys#current-source-filename #f)
(define ##sys#current-load-path "")

(define-foreign-variable _dlerror c-string "C_dlerror")

(define (set-dynamic-load-mode! mode)
  (let ([mode (if (pair? mode) mode (list mode))]
	[now #f]
	[global #t] )
    (let loop ([mode mode])
      (when (pair? mode)
	(case (##sys#slot mode 0)
	  [(global) (set! global #t)]
	  [(local) (set! global #f)]
	  [(lazy) (set! now #f)]
	  [(now) (set! now #t)]
	  [else (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (##sys#slot mode 0))] )
	(loop (##sys#slot mode 1)) ) )
    (##sys#set-dlopen-flags! now global) ) )

(let ([read read]
      [write write]
      [display display]
      [newline newline]
      [eval eval]
      [open-input-file open-input-file]
      [close-input-port close-input-port]
      [string-append string-append] 
      [load-verbose load-verbose]
      [topentry (##sys#make-c-string "C_toplevel")] )
  (define (has-sep? str)
    (let loop ([i (fx- (##sys#size str) 1)])
      (and (not (zero? i))
	   (if (memq (##core#inline "C_subchar" str i) '(#\\ #\/))
	       i
	       (loop (fx- i 1)) ) ) ) )
  (define (badfile x)
    (##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" x) )
  (set! ##sys#load 
    (lambda (input evaluator pf #!optional timer printer)
      (when (string? input) 
	(set! input (##sys#expand-home-path input)) )
      (let* ([isdir #f]
	     [fname 
	     (cond [(port? input) #f]
		   [(not (string? input)) (badfile input)]
		   [(and-let* ([info (##sys#file-info input)]
			       [id (##sys#slot info 4)] )
		      (set! isdir (eq? 1 id)) 
		      (not id) )
		    input]
		   [else
		    (let ([fname2 (##sys#string-append input ##sys#load-dynamic-extension)])
		      (if (##sys#file-info fname2)
			  fname2
			  (let ([fname3 (##sys#string-append input source-file-extension)])
			    (if (##sys#file-info fname3)
				fname3
				(and (not isdir) input) ) ) ) ) ] ) ]
	    [evproc (or evaluator eval)] )
	(cond [(and (string? input) (not fname))
	       (##sys#signal-hook #:file-error 'load "can not open file" input) ]
	      [(and (load-verbose) fname)
	       (display "; loading ")
	       (display fname)
	       (display " ...\n") ] )
	(or (and fname
		 (or (##sys#dload (##sys#make-c-string fname) topentry #t) 
		     (and (not (has-sep? fname))
			  (##sys#dload (##sys#make-c-string (##sys#string-append "./" fname)) topentry #t) ) ) )
	    (call-with-current-continuation
	     (lambda (abrt)
	       (fluid-let ([##sys#read-error-with-line-number #t]
			   [##sys#current-source-filename fname]
			   [##sys#current-load-path
			    (and fname
				 (let ((i (has-sep? fname)))
				   (if i (##sys#substring fname 0 (fx+ i 1)) "") ) ) ]
			   [##sys#abort-load (lambda () (abrt #f))] )
		 (let ([in (if fname (open-input-file fname) input)])
		   (##sys#dynamic-wind
		    (lambda () #f)
		    (lambda ()
		      (let ([c1 (peek-char in)])
			(when (char=? c1 (integer->char 127))
			  (##sys#error 'load "unable to load compiled module" fname _dlerror) ) )
		      (let ((x1 (read in)))
			(do ((x x1 (read in)))
			    ((eof-object? x))
			  (when printer (printer x))
			  (##sys#call-with-values
			   (lambda () 
			     (if timer
				 (time (evproc x)) 
				 (evproc x) ) )
			   (lambda results
			     (when pf
			       (for-each
				(lambda (r) 
				  (write r)
				  (newline) )
				results) ) ) ) ) ) )
		    (lambda () (close-input-port in)) ) ) ) ) ) )
	(##core#undefined) ) ) )
  (set! load
    (lambda (filename . evaluator)
      (##sys#load filename (:optional evaluator #f) #f) ) )
  (set! load-relative
    (lambda (filename . evaluator)
      (##sys#load
       (if (memq (string-ref filename 0) '(#\\ #\/))
	   filename
	   (##sys#string-append ##sys#current-load-path filename) )
       (:optional evaluator #f) #f) ) )
  (set! load-noisily
    (lambda (filename #!key (evaluator #f) (time #f) (printer #f))
      (##sys#load filename evaluator #t time printer) ) ) )

(define ##sys#load-library-extension 	; this is crude...
  (cond [(eq? (software-type) 'windows) windows-load-library-extension]
	[(eq? (software-version) 'macosx) macosx-load-library-extension]
	[(and (eq? (software-version) 'hpux) 
	      (eq? (machine-type) 'hppa)) hppa-load-library-extension]
	[else default-load-library-extension] ) )

(define ##sys#load-dynamic-extension default-load-library-extension)

(define ##sys#default-dynamic-load-libraries 
  (case (build-platform)
    ((cygwin) cygwin-default-dynamic-load-libraries)
    (else default-dynamic-load-libraries) ) )

(define dynamic-load-libraries 
  (make-parameter
   (map (cut ##sys#string-append <> ##sys#load-library-extension) ##sys#default-dynamic-load-libraries)
   (lambda (x)
     (##sys#check-list x)
     x) ) )

(define ##sys#load-library
  (let ([load-verbose load-verbose]
	[string-append string-append]
	[dynamic-load-libraries dynamic-load-libraries]
	[display display] )
    (lambda (uname lib)
      (let ([id (##sys#->feature-id uname)])
	(or (memq id ##sys#features)
	    (let ([libs
		   (if lib
		       (##sys#list lib)
		       (cons (##sys#string-append (##sys#slot uname 1) ##sys#load-library-extension)
			     (dynamic-load-libraries) ) ) ]
		  [top 
		   (##sys#make-c-string
		    (string-append 
		     "C_"
		     (##sys#string->c-identifier (##sys#slot uname 1)) 
		     "_toplevel") ) ] )
	      (when (load-verbose)
		(display "; loading library ")
		(display uname)
		(display " ...\n") )
	      (let loop ([libs libs])
		(cond [(null? libs) #f]
		      [(##sys#dload (##sys#make-c-string (##sys#slot libs 0)) top #f)
		       (unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features)))
		       #t]
		      [else (loop (##sys#slot libs 1))] ) ) ) ) ) ) ) )

(define load-library
  (lambda (uname . lib)
    (##sys#check-symbol uname 'load-library)
    (or (##sys#load-library uname (and (pair? lib) (car lib)))
	(##sys#error 'load-library "unable to load library" uname _dlerror) ) ) )

(define ##sys#split-at-separator
  (let ([reverse reverse] )
    (lambda (str sep)
      (let ([len (##sys#size str)])
	(let loop ([items '()] [i 0] [j 0])
	  (cond [(fx>= i len)
		 (reverse (cons (##sys#substring str j len) items)) ]
		[(char=? (##core#inline "C_subchar" str i) sep)
		 (let ([i2 (fx+ i 1)])
		   (loop (cons (##sys#substring str j i) items) i2 i2) ) ]
		[else (loop items (fx+ i 1) j)] ) ) ) ) ) )


;;; Extensions:

(define ##sys#canonicalize-extension-path
  (let ([string-append string-append])
    (lambda (id loc)
      (define (err) (##sys#error loc "invalid extension path" id))
      (define (sep? c) (or (char=? #\\ c) (char=? #\/ c)))
      (let ([p (cond [(string? id) id]
		     [(symbol? id) (##sys#symbol->string id)]
		     [(list? id) 
		      (let loop ([id id])
			(if (null? id)
			    ""
			    (string-append 
			     (let ([id0 (##sys#slot id 0)])
			       (cond [(symbol? id0) (##sys#symbol->string id0)]
				     [(string? id0) id0]
				     [else (err)] ) )
			     (if (null? (##sys#slot id 1))
				 ""
				 "/")
			     (loop (##sys#slot id 1)) ) ) ) ] ) ] )
	(let check ([p p])
	  (let ([n (##sys#size p)])
	    (cond [(fx= 0 n) (err)]
		  [(sep? (string-ref p 0))
		   (check (##sys#substring p 1 n)) ]
		  [(sep? (string-ref p (fx- n 1)))
		   (check (##sys#substring p 0 (fx- n 1))) ]
		  [else p] ) ) ) ) ) ) )

(define ##sys#repository-path
  (make-parameter 
   (or (getenv repository-environment-variable)
       (##sys#chicken-prefix 
	(##sys#string-append 
	 "lib/chicken/"
	 (##sys#number->string (or (##sys#fudge 42) default-binary-version)) ) )
       install-egg-home) ) )

(define repository-path ##sys#repository-path)

(define ##sys#find-extension
  (let ([file-exists? file-exists?]
	[string-append string-append] )
    (lambda (p inc?)
	(define (check path)
	  (let ([p0 (string-append path "/" p)])
	    (and (or (file-exists? (##sys#string-append p0 ##sys#load-dynamic-extension))
		     (file-exists? (##sys#string-append p0 source-file-extension)) )
		 p0) ) )
	(let loop ([paths (##sys#append (list (##sys#repository-path))
					(if inc? (##sys#append ##sys#include-pathnames '(".")) '()) ) ] )
	  (and (pair? paths)
	       (let ([pa (##sys#slot paths 0)])
		 (or (check pa)
		     (loop (##sys#slot paths 1)) ) ) ) ) ) ) )

(define ##sys#loaded-extensions '())

(define ##sys#load-extension
  (let ((string->symbol string->symbol))
    (lambda (id loc . err?)
      (cond ((string? id) (set! id (string->symbol id)))
	    (else (##sys#check-symbol id loc)) )
      (let ([p (##sys#canonicalize-extension-path id loc)])
	(cond ((member p ##sys#loaded-extensions))
	      ((memq id ##sys#core-library-modules)
	       (##sys#load-library id #f) )
	      (else
	       (let ([id2 (##sys#find-extension p #t)])
		 (cond (id2
			(##sys#load id2 #f #f)
			(set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) 
			#t)
		       ((:optional err? #t) (##sys#error loc "can not load extension" id))
		       (else #f) ) ) ) ) ) ) ) )

(define (##sys#provide . ids)
  (for-each
   (lambda (id)
     (##sys#check-symbol id 'provide)
     (let ([p (##sys#canonicalize-extension-path id 'provide)])
       (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) ) ) 
   ids) )

(define provide ##sys#provide)

(define (##sys#provided? id)
  (and (member (##sys#canonicalize-extension-path id 'provided?) ##sys#loaded-extensions) 
       #t) )

(define provided? ##sys#provided?)

(define ##sys#require
  (lambda ids
    (for-each
     (cut ##sys#load-extension <> 'require) 
     ids) ) )

(define require ##sys#require)

(define ##sys#extension-information
  (let ([with-input-from-file with-input-from-file]
	[file-exists? file-exists?]
	[string-append string-append]
	[read read] )
    (lambda (id loc)
      (let* ((p (##sys#canonicalize-extension-path id loc))
	     (rpath (string-append (##sys#repository-path) "/" p ".")) )
	(cond ((file-exists? (string-append rpath setup-file-extension))
	       => (cut with-input-from-file <> read) )
	      (else #f) ) ) ) ) )

(define (extension-information ext)
  (##sys#extension-information ext 'extension-information) )

(define ##sys#lookup-runtime-requirements 
  (let ([with-input-from-file with-input-from-file]
	[read read] )
    (lambda (ids)
      (let loop1 ([ids ids])
	(if (null? ids)
	    '()
	    (append
	     (or (and-let* ([info (##sys#extension-information (car ids) #f)]
			    [a (assq 'require-at-runtime info)] )
		   (cdr a) )
		 '() )
	     (loop1 (cdr ids)) ) ) ) ) ) )

(define ##sys#do-the-right-thing
  (let ((vector->list vector->list))
    (lambda (id comp?)
      (define (add-req id)
	(when comp?
	  (##sys#hash-table-update!
	   ##compiler#file-requirements
	   'syntax-requirements
	   (cut lset-adjoin eq? <> id) 
	   (lambda () (list id)))))
      (define (doit id)
	(cond ((or (memq id builtin-features)
		   (if comp?
		       (memq id builtin-features/compiled)
		       (##sys#feature? id) ) )
	       (values '(##sys#void) #t) )
	      ((memq id special-syntax-files)
	       (let ((fid (##sys#->feature-id id)))
		 (unless (memq fid ##sys#features)
		   (##sys#load (##sys#resolve-include-filename (##sys#symbol->string id) #t) #f #f) 
		   (set! ##sys#features (cons fid ##sys#features)) )
		 (values '(##sys#void) #t) ) )
	      ((memq id ##sys#core-library-modules)
	       (values
		(if comp?
		    `(##core#declare '(uses ,id))
		    `(load-library ',id) )
		#t) )
	      ((memq id ##sys#explicit-library-modules)
	       (let* ((info (##sys#extension-information id 'require-extension))
		      (s (assq 'syntax info)))
		 (values
		  `(begin
		     ,@(if s `((##core#require-for-syntax ',id)) '())
		     ,(if comp?
			  `(##core#declare '(uses ,id)) 
			  `(load-library ',id) ) )
		  #t) ) )
	      (else
	       (let ((info (##sys#extension-information id 'require-extension)))
		 (cond (info
			(let ((s (assq 'syntax info))
			      (rr (assq 'require-at-runtime info)) )