library.scm

Scheme跨平台编译器

;;;; library.scm - R5RS library for the CHICKEN compiler
;
; 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 library)
  (disable-interrupts)
  (disable-warning var redef)
  (usual-integrations)
  (hide ##sys#dynamic-unwind ##sys#find-symbol
	##sys#grow-vector ##sys#default-parameter-vector 
	print-length-limit current-print-length setter-tag read-marks
	##sys#print-exit
        ##sys#format-here-doc-warning)
  (foreign-declare #<<EOF
#include <string.h>
#include <ctype.h>
#include <errno.h>
#include <time.h>

#ifdef HAVE_SYSEXITS_H
# include <sysexits.h>
#endif

#if !defined(_MSC_VER) && !defined(__DJGPP__) && !defined(__MWERKS__)
# include <unistd.h>
#endif

#ifndef EX_SOFTWARE
# define EX_SOFTWARE    70
#endif

#ifndef C_BUILD_TAG
# define C_BUILD_TAG    ""
#endif

#define C_close_file(p)       (C_fclose((C_FILEPTR)(C_port_file(p))), C_SCHEME_UNDEFINED)
#define C_f64peek(b, i)       (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
#define C_fetch_c_strlen(b, i) C_fix(strlen((C_char *)C_block_item(b, C_unfix(i))))
#define C_peek_c_string(b, i, to, len) (C_memcpy(C_data_pointer(to), (C_char *)C_block_item(b, C_unfix(i)), C_unfix(len)), C_SCHEME_UNDEFINED)
#define C_free_mptr(p, i)     (C_free((void *)C_block_item(p, C_unfix(i))), C_SCHEME_UNDEFINED)
#define C_free_sptr(p, i)     (C_free((void *)(((C_char **)C_block_item(p, 0))[ C_unfix(i) ])), C_SCHEME_UNDEFINED)

#define C_direct_continuation(dummy)  t1

#define C_get_current_seconds(dummy)  (C_temporary_flonum = time(NULL), C_SCHEME_UNDEFINED)
#define C_peek_c_string_at(ptr, i)    ((C_char *)(((C_char **)ptr)[ i ]))

static C_word fast_read_line_from_file(C_word str, C_word port, C_word size) {
  int n = C_unfix(size);
  int i;
  int c;
  char *buf = C_c_string(str);
  C_FILEPTR fp = C_port_file(port);

  if ((c = getc(fp)) == EOF)
    return C_SCHEME_END_OF_FILE;

  ungetc(c, fp);

  for (i = 0; i < n; i++) {
    c = getc(fp);
    switch (c) {
    case '\r':  if ((c = getc(fp)) != '\n') ungetc(c, fp);
    case EOF:   clearerr(fp);
    case '\n':  return C_fix(i);
    }
    buf[i] = c;
  }
  return C_SCHEME_FALSE;
}

static C_word
fast_read_string_from_file (C_word dest, C_word port, C_word len, C_word pos)
{
  int n = C_unfix (len);
  char * buf = ((char *)C_data_pointer (dest) + C_unfix (pos));
  C_FILEPTR fp = C_port_file (port);

  size_t m = fread (buf, sizeof (char), n, fp);

  if (m < n) {
    if (feof (fp)) {
      clearerr (fp);
      if (0 == m)
        return C_SCHEME_END_OF_FILE;
    } else if (ferror (fp)) {
      if (0 == m) {
        return C_SCHEME_FALSE;
      } else {
        clearerr (fp);
      }
    }
  }

  return C_fix (m);
}
EOF
) )

(cond-expand 
 ((not unsafe)
  (declare (emit-exports "library.exports")))
 (else) )

(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-port* ##sys#check-string ##sys#substring ##sys#check-port-mode
     ##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair 
     ##sys#not-a-proper-list-error ##sys#error ##sys#warn ##sys#signal-hook
     ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round 
     ##sys#check-number ##sys#cons-flonum ##sys#check-integer ##sys#check-special
     ##sys#flonum-fraction ##sys#make-port ##sys#print 
     ##sys#check-structure ##sys#make-structure ##sys#procedure->string
     ##sys#gcd ##sys#lcm ##sys#ensure-heap-reserve ##sys#check-list 
     ##sys#enable-interrupts ##sys#disable-interrupts ##sys#->feature-id
     ##sys#fudge ##sys#user-read-hook ##sys#check-range ##sys#read
     ##sys#string->symbol ##sys#symbol->string ##sys#dynamic-unwind ##sys#pathname-resolution
     ##sys#platform-fixup-pathname ##sys#expand-home-path ##sys#string-append ##sys#symbol->qualified-string
     ##sys#error-handler ##sys#signal ##sys#abort ##sys#port-data
     ##sys#reset-handler ##sys#exit-handler ##sys#dynamic-wind ##sys#port-line
     ##sys#grow-vector ##sys#run-pending-finalizers ##sys#peek-char-0 ##sys#read-char-0
     ##sys#read-char/port ##sys#write-char/port
     ##sys#schedule ##sys#make-thread ##sys#print-to-string ##sys#scan-buffer-line
     ##sys#update-thread-state-buffer ##sys#restore-thread-state-buffer ##sys#user-print-hook 
     ##sys#current-exception-handler ##sys#default-exception-handler ##sys#abandon-mutexes ##sys#make-mutex
     ##sys#port-has-file-pointer? ##sys#infix-list-hook char-name ##sys#open-file-port make-parameter
     ##sys#intern-symbol ##sys#make-string ##sys#number? software-type build-platform
     open-output-string get-output-string print-call-chain ##sys#symbol-has-toplevel-binding? repl
     argv condition-property-accessor ##sys#decorate-lambda ##sys#become! ##sys#lambda-decoration
     getter-with-setter ##sys#lambda-info ##sys#lambda-info->string open-input-string ##sys#gc
     ##sys#memory-info ##sys#make-c-string ##sys#find-symbol-table array:make-locative display
     newline string-append ##sys#with-print-length-limit write print vector-fill! ##sys#context-switch
     ##sys#set-finalizer! open-output-string get-output-string read ##sys#make-pointer
     ##sys#pointer->address number->string ##sys#flush-output ##sys#break-entry ##sys#step
     ##sys#apply-values ##sys#signal-hook ##sys#get-call-chain ##sys#really-print-call-chain
     string->keyword keyword? string->keyword getenv ##sys#number->string ##sys#copy-bytes
     call-with-current-continuation ##sys#string->number ##sys#inexact->exact ##sys#exact->inexact
     ##sys#reverse-list->string reverse ##sys#inexact? list? string ##sys#char->utf8-string 
     ##sys#unicode-surrogate? ##sys#surrogates->codepoint ##sys#write-char/port
     ##sys#update-errno ##sys#file-info close-output-port close-input-port ##sys#peek-unsigned-integer
     continuation-graft char-downcase string-copy remainder floor ##sys#exact? list->string
     ##sys#append ##sys#list ##sys#cons ##sys#list->vector ##sys#list ##sys#apply ##sys#make-vector
     ##sys#write-char ##sys#force-finalizers ##sys#cleanup-before-exit ##sys#write-char-0
     ##sys#default-read-info-hook ##sys#read-error) ) ] )


(include "version.scm")
(include "banner.scm")


(define-constant namespace-max-id-len 31)
(define-constant char-name-table-size 37)
(define-constant output-string-initial-size 256)
(define-constant default-parameter-vector-size 16)
(define-constant maximal-string-length #x00ffffff)

(define-foreign-variable +build-tag+ c-string "C_BUILD_TAG")



;;; System routines:

(define (exit . code) (apply (##sys#exit-handler) code))
(define (reset) ((##sys#reset-handler)))

(define (##sys#error . args)
  (if (pair? args)
      (apply ##sys#signal-hook #:error args)
      (##sys#signal-hook #:error #f)))

(define ##sys#warnings-enabled #t)

(define (##sys#warn msg . args)
  (when ##sys#warnings-enabled
    (apply ##sys#signal-hook #:warning msg args) ) )

(define (enable-warnings . bool)
  (if (pair? bool) 
      (set! ##sys#warnings-enabled (car bool))
      ##sys#warnings-enabled) )

(define error ##sys#error)
(define warning ##sys#warn)

(define-foreign-variable main_argc int "C_main_argc")
(define-foreign-variable main_argv c-pointer "C_main_argv")
(define-foreign-variable strerror c-string "strerror(errno)")

(define (set-gc-report! flag) (##core#inline "C_set_gc_report" flag))
(define ##sys#gc (##core#primitive "C_gc"))
(define (##sys#setslot x i y) (##core#inline "C_i_setslot" x i y))
(define (##sys#setislot x i y) (##core#inline "C_i_set_i_slot" x i y))
(define ##sys#allocate-vector (##core#primitive "C_allocate_vector"))
(define argv (##core#primitive "C_get_argv"))
(define (argc+argv) (##sys#values main_argc main_argv))
(define ##sys#make-structure (##core#primitive "C_make_structure"))
(define ##sys#ensure-heap-reserve (##core#primitive "C_ensure_heap_reserve"))
(define (##sys#fudge fudge-factor) (##core#inline "C_fudge" fudge-factor))
(define ##sys#call-host (##core#primitive "C_return_to_host"))
(define return-to-host ##sys#call-host)
(define ##sys#file-info (##core#primitive "C_file_info"))
(define ##sys#symbol-table-info (##core#primitive "C_get_symbol_table_info"))
(define ##sys#memory-info (##core#primitive "C_get_memory_info"))
(define (current-milliseconds) (##sys#fudge 16))
(define (current-gc-milliseconds) (##sys#fudge 31))
(define cpu-time (##core#primitive "C_cpu_time"))
(define ##sys#decode-seconds (##core#primitive "C_decode_seconds"))
(define getenv (##core#primitive "C_get_environment_variable"))
(define (##sys#start-timer) (##core#inline "C_start_timer"))
(define ##sys#stop-timer (##core#primitive "C_stop_timer"))
(define (##sys#immediate? x) (not (##core#inline "C_blockp" x)))
(define (##sys#message str) (##core#inline "C_message" str))
(define (##sys#byte x i) (##core#inline "C_subbyte" x i))
(define (##sys#setbyte x i n) (##core#inline "C_setbyte" x i n))
(define (##sys#void) (##core#undefined))
(define void ##sys#void)
(define ##sys#undefined-value (##core#undefined))
(define (##sys#halt) (##core#inline "C_halt" #f))
(define ##sys#dload (##core#primitive "C_dload"))
(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
(define (##sys#flo2fix n) (##core#inline "C_quickflonumtruncate" n))
(define ##sys#become! (##core#primitive "C_become"))
(define (##sys#block-ref x i) (##core#inline "C_i_block_ref" x i))
(define ##sys#apply-values (##core#primitive "C_apply_values"))
(define ##sys#copy-closure (##core#primitive "C_copy_closure"))
(define ##sys#apply-argument-limit (##sys#fudge 34))

(define (##sys#block-set! x i y)
  (cond-expand
   [(not unsafe)
    (when (or (not (##core#inline "C_blockp" x)) 
	      (and (##core#inline "C_specialp" x) (fx= i 0))
	      (##core#inline "C_byteblockp" x) ) 
      (##sys#signal-hook '#:type-error '##sys#block-set! "slot not accessible" x) )
    (##sys#check-range i 0 (##sys#size x) '##sys#block-set!) ]
   [else] )
  (##sys#setslot x i y) )

(define (current-seconds) 
  (##core#inline "C_get_current_seconds" #f)
  (##sys#cons-flonum) )

(define (##sys#check-structure x y . z) 
  (if (pair? z)
      (##core#inline "C_i_check_structure_2" x y (car z))
      (##core#inline "C_i_check_structure" x y) ) )

(define (##sys#check-blob x . y) 
  (if (pair? y)
      (##core#inline "C_i_check_bytevector_2" x (car y))
      (##core#inline "C_i_check_bytevector" x) ) )

(define ##sys#check-byte-vector ##sys#check-blob)

(define (##sys#check-pair x . y) 
  (if (pair? y)
      (##core#inline "C_i_check_pair_2" x (car y))
      (##core#inline "C_i_check_pair" x) ) )

(define (##sys#check-list x . y) 
  (if (pair? y)
      (##core#inline "C_i_check_list_2" x (car y))
      (##core#inline "C_i_check_list" x) ) )

(define (##sys#check-string x . y) 
  (if (pair? y)
      (##core#inline "C_i_check_string_2" x (car y))
      (##core#inline "C_i_check_string" x) ) )

(define (##sys#check-number x . y) 
  (if (pair? y)
      (##core#inline "C_i_check_number_2" x (car y))
      (##core#inline "C_i_check_number" x) ) )

(define (##sys#check-exact x . y) 
  (if (pair? y)
      (##core#inline "C_i_check_exact_2" x (car y))
      (##core#inline "C_i_check_exact" x) ) )

(define (##sys#check-inexact x . y) 
  (if (pair? y)
      (##core#inline "C_i_check_inexact_2" x (car y))
      (##core#inline "C_i_check_inexact" x) ) )

(define (##sys#check-symbol x . y) 
  (if (pair? y)
      (##core#inline "C_i_check_symbol_2" x (car y))
      (##core#inline "C_i_check_symbol" x) ) )

(define (##sys#check-vector x . y) 
  (if (pair? y)
      (##core#inline "C_i_check_vector_2" x (car y))
      (##core#inline "C_i_check_vector" x) ) )

(define (##sys#check-char x . y) 
  (if (pair? y)
      (##core#inline "C_i_check_char_2" x (car y))
      (##core#inline "C_i_check_char" x) ) )

(define (##sys#check-integer x . y)
  (unless (##core#inline "C_i_integerp" x) 
    (##sys#signal-hook #:type-error (if (pair? y) (car y) #f) "bad argument type - not an integer" x) ) )

(define ##sys#check-range 
  (lambda (i from to loc)
    (##sys#check-exact i loc)
    (if (or (not (fx>= i from))
	    (not (fx< i to)) ) 
	(##sys#signal-hook #:bounds-error loc "out of range" i from to) ) ) )

(define (##sys#check-special ptr loc)
  (unless (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
    (##sys#signal-hook #:type-error loc "bad argument type - not a pointer-like object" ptr) ) )

(define (##sys#check-closure x . y)
  (if (pair? y)
      (##core#inline "C_i_check_closure_2" x (car y))
      (##core#inline "C_i_check_closure" x) ) )

(cond-expand
 [unsafe
  (eval-when (compile)
    (define-macro (##sys#check-closure . _) '(##core#undefined))
    (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-port* . _) '(##core#undefined))
    (define-macro (##sys#check-port-mode . _) '(##core#undefined))
    (define-macro (##sys#check-number . _) '(##core#undefined))
    (define-macro (##sys#check-special . _) '(##core#undefined))
    (define-macro (##sys#check-blob . _) '(##core#undefined))
    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
 [else] )

(define (##sys#force promise)
  (if (##sys#structure? promise 'promise)
      ((##sys#slot promise 1))
      promise) )

(define force ##sys#force)

(define (system cmd)
  (##sys#check-string cmd 'system)
  (let ((r (##core#inline "C_execute_shell_command" cmd)))
    (cond ((fx< r 0)
	   (##sys#update-errno)
	   (##sys#signal-hook #:process-error 'system "`system' invocation failed" cmd) )
	  (else r) ) ) )


;;; Operations on booleans:

(define (not x) (##core#inline "C_i_not" x))
(define (boolean? x) (##core#inline "C_booleanp" x))


;;; Equivalence predicates:

(define (eq? x y) (##core#inline "C_eqp" x y))