eval.scm

Scheme跨平台编译器

			  (when s (add-req id))
			  (values 
			   `(begin
			      ,@(if s `((##core#require-for-syntax ',id)) '())
			      ,@(if (and (not rr) s)
				   '()
				   `((##sys#require
				      ,@(map (lambda (id) `',id)
					     (cond (rr (cdr rr))
						   (else (list id)) ) ) ) ) ) )
			   #t) ) )
		       (else
			(add-req id)
			(values `(##sys#require ',id) #f)) ) ) ) ) )
      (if (and (pair? id) (symbol? (car id)))
	  (let ((a (assq (##sys#slot id 0) ##sys#extension-specifiers)))
	    (if a
		(let ((a ((##sys#slot a 1) id)))
		  (cond ((string? a) (values `(load ,a) #f))
			((vector? a) 
			 (let loop ((specs (vector->list a))
				    (exps '())
				    (f #f) )
			   (if (null? specs)
			       (values `(begin ,@(reverse exps)) f)
			       (let-values (((exp fi) (##sys#do-the-right-thing (car specs) comp?)))
				 (loop (cdr specs)
				       (cons exp exps)
				       (or fi f) ) ) ) ) )
			(else (##sys#do-the-right-thing a comp?)) ) )
		(##sys#error "undefined extension specifier" id) ) )
	  (if (symbol? id)
	      (doit id) 
	      (##sys#error "invalid extension specifier" id) ) ) ) ) )

(define ##sys#extension-specifiers '())

(define (set-extension-specifier! name proc)
  (##sys#check-symbol name 'set-extension-specifier!)
  (let ([a (assq name ##sys#extension-specifiers)])
    (if a
	(let ([old (##sys#slot a 1)])
	  (##sys#setslot a 1 (lambda (spec) (proc spec old))) )
	(set! ##sys#extension-specifiers
	  (cons (cons name (lambda (spec) (proc spec #f)))
		##sys#extension-specifiers)) ) ) )


;;; SRFI-55

(set-extension-specifier!
 'srfi 
 (let ([list->vector list->vector])
   (lambda (spec old)
     (list->vector
      (let loop ([ids (cdr spec)])
	(if (null? ids)
	    '()
	    (let ([id (car ids)])
	      (##sys#check-exact id 'require-extension)
	      (cons (##sys#string->symbol (##sys#string-append "srfi-" (number->string id)))
		    (loop (cdr ids)) ) ) ) ) ) ) ) )


;;; Version checking

(set-extension-specifier!
 'version
 (lambda (spec _)
   (define (->string x)
     (cond ((string? x) x)
	   ((symbol? x) (##sys#slot x 1))
	   ((number? x) (##sys#number->string x))
	   (else (error "invalid extension version" x)) ) )
   (match spec
     (('version id v)
      (let* ((info (extension-information id))
	     (vv (and info (assq 'version info))) )
	(unless (and vv (string>=? (->string (car vv)) (->string v)))
	  (error "installed extension does not match required version" id vv v) )
	id) )
     (_ (syntax-error 'require-extension "invalid version specification" spec)) ) ) )


;;; Convert string into valid C-identifier:

(define ##sys#string->c-identifier
  (let ([string-copy string-copy])
    (lambda (str)
      (let* ([s2 (string-copy str)]
	     [n (##sys#size s2)] )
	(do ([i 0 (fx+ i 1)])
	    ((fx>= i n) s2)
	  (let ([c (##core#inline "C_subchar" s2 i)])
	    (when (and (not (char-alphabetic? c)) (or (not (char-numeric? c)) (fx= i 0)))
	      (##core#inline "C_setsubchar" s2 i #\_) ) ) ) ) ) ) )


;;; Environments:

(define ##sys#r4rs-environment (make-vector environment-table-size '()))
(define ##sys#r5rs-environment #f)
(define ##sys#interaction-environment (##sys#make-structure 'environment #f #t))

(define ##sys#copy-env-table
  (lambda (e mff mf . args)
    (let ([syms (and (pair? args) (car args))])
      (let* ([s (##sys#size e)]
             [e2 (##sys#make-vector s '())] )
       (do ([i 0 (fx+ i 1)])
           ((fx>= i s) e2)
         (##sys#setslot 
          e2 i
          (let copy ([b (##sys#slot e i)])
            (if (null? b)
                '()
                (let ([bi (##sys#slot b 0)])
                  (let ([sym (##sys#slot bi 0)])
                    (if (or (not syms) (memq sym syms))
                      (cons (vector
                              sym
                              (##sys#slot bi 1)
                              (if mff mf (##sys#slot bi 2)))
                            (copy (##sys#slot b 1)))
                      (copy (##sys#slot b 1)) ) ) ) ) ) ) ) ) ) ) )

(define ##sys#environment-symbols
  (lambda (env . args)
    (##sys#check-structure env 'environment)
    (let ([pred (and (pair? args) (car args))])
      (let ([envtbl (##sys#slot env 1)])
        (if envtbl
            ;then "real" environment
          (let ([envtblsiz (vector-length envtbl)])
            (do ([i 0 (fx+ i 1)]
                 [syms
                   '()
                   (let loop ([bucket (vector-ref envtbl i)] [syms syms])
                     (if (null? bucket)
                       syms
                       (let ([sym (vector-ref (car bucket) 0)])
                         (if (or (not pred) (pred sym))
                           (loop (cdr bucket) (cons sym syms))
                           (loop (cdr bucket) syms) ) ) ) )])
	        ((fx>= i envtblsiz) syms) ) )
	    ;else interaction-environment
	  (let ([syms '()])
	    (##sys#walk-namespace
	      (lambda (sym)
	        (when (or (not pred) (pred sym))
	          (set! syms (cons sym syms)) ) ) )
	    syms ) ) ) ) ) )

(define (interaction-environment) ##sys#interaction-environment)

(define scheme-report-environment
  (lambda (n . mutable)
    (##sys#check-exact n 'scheme-report-environment)
    (let ([mf (and (pair? mutable) (car mutable))])
      (case n
	[(4) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r4rs-environment #t mf) mf)]
	[(5) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r5rs-environment #t mf) mf)]
	[else (##sys#error 'scheme-report-environment "no support for version" n)] ) ) ) )

(define null-environment
  (let ([make-vector make-vector])
    (lambda (n . mutable)
      (##sys#check-exact n 'null-environment)
      (when (or (fx< n 4) (fx> n 5))
	(##sys#error 'null-environment "no support for version" n) )
      (##sys#make-structure
       'environment
       (make-vector environment-table-size '())
       (and (pair? mutable) (car mutable)) ) ) ) )

(let ()
  (define (initb ht) 
    (lambda (b)
      (let ([loc (##sys#hash-table-location ht b #t)])
        (##sys#setslot loc 1 (##sys#slot b 0)) ) ) )
  (for-each 
   (initb ##sys#r4rs-environment)
   '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
     cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr cadddr cdaaar cdaadr cdadar cdaddr
     cddaar cddadr cdddar cddddr set-car! set-cdr! null? list? list length list-tail list-ref
     append reverse memq memv member assq assv assoc symbol? symbol->string string->symbol
     number? integer? exact? real? complex? inexact? rational? zero? odd? even? positive? negative?
     max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs floor ceiling truncate round
     exact->inexact inexact->exact exp log expt sqrt sin cos tan asin acos atan number->string
     string->number char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<? char-ci>?
     char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? char-upper-case?
     char-lower-case? char-upcase char-downcase char->integer integer->char string? string=?
     string>? string<? string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci>=? string-ci<=?
     make-string string-length string-ref string-set! string-append string-copy string->list 
     list->string substring string-fill! vector? make-vector vector-ref vector-set! string vector
     vector-length vector->list list->vector vector-fill! procedure? map for-each apply force 
     call-with-current-continuation input-port? output-port? current-input-port current-output-port
     call-with-input-file call-with-output-file open-input-file open-output-file close-input-port
     close-output-port load read eof-object? read-char peek-char
     write display write-char newline with-input-from-file with-output-to-file ##sys#call-with-values
     ##sys#values ##sys#dynamic-wind ##sys#void
     ##sys#list->vector ##sys#list ##sys#append ##sys#cons ##sys#make-promise) )
  (set! ##sys#r5rs-environment (##sys#copy-env-table ##sys#r4rs-environment #t #t))
  (for-each
   (initb ##sys#r5rs-environment)
   '(dynamic-wind values call-with-values eval scheme-report-environment null-environment interaction-environment) ) )


;;; Find included file:

(define ##sys#include-pathnames 
  (let ((h (chicken-home)))
    (if h (list h) '())) )

(define ##sys#resolve-include-filename
  (let ((string-append string-append) )
    (define (exists? fname)
      (let ([info (##sys#file-info fname)])
	(and info (not (eq? 1 (##sys#slot info 4)))) ) )
    (lambda (fname prefer-source #!optional repo)
      (define (test2 fname lst)
	(if (null? lst)
	    (and (exists? fname) fname)
	    (let ([fn (##sys#string-append fname (car lst))])
	      (if (exists? fn)
		  fn
		  (test2 fname (cdr lst)) ) ) ) )
      (define (test fname)
	(test2 
	 fname 
	 (if prefer-source
	     (list source-file-extension ##sys#load-dynamic-extension)
	     (list ##sys#load-dynamic-extension source-file-extension) ) ) )
      (or (test fname)
	  (let loop ((paths (if repo
				(##sys#append ##sys#include-pathnames (list (##sys#repository-path)))
				##sys#include-pathnames) ) )
	    (cond ((eq? paths '()) fname)
		  ((test (string-append (##sys#slot paths 0)
					"/"
					fname) ) )
		  (else (loop (##sys#slot paths 1))) ) ) ) ) ) )


;;; Print timing information (support for "time" macro):

(define ##sys#display-times
  (let* ((display display)
	 (spaces 
	  (lambda (n)
	    (do ((i n (fx- i 1)))
		((fx<= i 0))
	      (display #\space) ) ) )
	 (display-rj 
	  (lambda (x w)
	    (let* ((xs (if (zero? x) "0" (number->string x)))
		   (xslen (##core#inline "C_block_size" xs)) )
	      (spaces (fx- w xslen))
	      (display xs) ) ) ) )
    (lambda (info)
      (display-rj (##sys#slot info 0) 8)
      (display " seconds elapsed\n") 
      (display-rj (##sys#slot info 1) 8)
      (display " seconds in (major) GC\n")
      (display-rj (##sys#slot info 2) 8)
      (display " mutations\n")
      (display-rj (##sys#slot info 3) 8)
      (display " minor GCs\n")
      (display-rj (##sys#slot info 4) 8)
      (display " major GCs\n") ) ) )


;;; General syntax checking routine:

(define ##sys#line-number-database #f)
(define (##sys#syntax-error-hook . args) (apply ##sys#signal-hook #:syntax-error args))
(define ##sys#syntax-error-culprit #f)

(define syntax-error ##sys#syntax-error-hook)

(define (get-line-number sexp)
  (and ##sys#line-number-database
       (pair? sexp)
       (let ([head (##sys#slot sexp 0)])
	 (and (symbol? head)
	      (cond [(##sys#hash-table-ref ##sys#line-number-database head)
		     => (lambda (pl)
			  (let ([a (assq sexp pl)])
			    (and a (##sys#slot a 1)) ) ) ]
		    [else #f] ) ) ) ) )

(define ##sys#check-syntax
  (let ([string-append string-append]
	[keyword? keyword?]
	[get-line-number get-line-number]
	[symbol->string symbol->string] )
    (lambda (id exp pat . culprit)

      (define (test x pred msg)
	(unless (pred x) (err msg)) )

      (define (err msg)
	(let* ([sexp ##sys#syntax-error-culprit]
	       [ln (get-line-number sexp)] )
	  (##sys#syntax-error-hook
	   (if ln 
	       (string-append "(" (symbol->string id) ") in line " (number->string ln) " - " msg)
	       (string-append "(" (symbol->string id) ") " msg) )
	   exp) ) )

      (define (lambda-list? x)
	(or (##sys#extended-lambda-list? x)
	    (let loop ((x x))
	      (cond ((eq? x '()))
		    ((not (##core#inline "C_blockp" x)) #f)
		    ((##core#inline "C_symbolp" x) (not (keyword? x)))
		    ((##core#inline "C_pairp" x)
		     (let ((s (##sys#slot x 0)))
		       (if (or (not (##core#inline "C_blockp" s)) (not (##core#inline "C_symbolp" s)))
			   #f
			   (loop (##sys#slot x 1)) ) ) ) 
		    (else #f) ) ) ) )

      (define (proper-list? x)
	(let loop ((x x))
	  (cond ((eq? x '()))
		((and (##core#inline "C_blockp" x) (##core#inline "C_pairp" x)) (loop (##sys#slot x 1)))
		(else #f) ) ) )

      (when (pair? culprit) (set! ##sys#syntax-error-culprit (car culprit)))
      (let walk ((x exp) (p pat))
	(cond ((and (##core#inline "C_blockp" p) (##core#inline "C_vectorp" p))
	       (let* ((p2 (##sys#slot p 0))
		      (vlen (##core#inline "C_block_size" p))
		      (min (if (fx> vlen 1) 
			       (##sys#slot p 1)
			       0) )
		      (max (cond ((eq? vlen 1) 1)
				 ((fx> vlen 2) (##sys#slot p 2))
				 (else 99999) ) ) )
		 (do ((x x (##sys#slot x 1))
		      (n 0 (fx+ n 1)) )
		     ((eq? x '())
		      (if (fx< n min)
			  (err "not enough arguments") ) )
		   (cond ((fx>= n max) 
			  (err "too many arguments") )
			 ((or (not (##core#inline "C_blockp" x)) (not (##core#inline "C_pairp" x)))
			  (err "not a proper list") )
			 (else (walk (##sys#slot x 0) p2) ) ) ) ) )
	      ((not (##core#inline "C_blockp" p))
	       (if (not (eq? p x)) (err "unexpected object")) )
	      ((##core#inline "C_symbolp" p)
	       (case p
		 ((_) #t)
		 ((pair) (test x pair? "pair expected"))
		 ((variable) (test x (lambda (x) (and (symbol? x))) "identifier expected"))
		 ((symbol) (test x symbol? "symbol expected"))
		 ((list) (test x proper-list? "proper list expected"))
		 ((number) (test x number? "number expected"))
		 ((string) (test x string? "string expected"))
		 ((lambda-list) (test x lambda-list? "lambda-list expected"))
		 (else (test x (lambda (y) (eq? y p)) "missing keyword")) ) )
	      ((or (not (##core#inline "C_blockp" x)) (not (##core#inline "C_pairp" x)))
	       (err "incomplete form") )
	      (else
	       (walk (##sys#slot x 0) (##sys#slot p 0))
	       (walk (##sys#slot x 1) (