Changeset 13125 in project for chicken


Ignore:
Timestamp:
01/27/09 20:30:54 (11 years ago)
Author:
Kon Lovett
Message:

Chgd to use existing errmsg (##sys#error-hook). Use of define-inline for common fx & fp code. Common cond-expand style for fx & fp.

Location:
chicken
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/chicken-3/library.scm

    r13124 r13125  
    3535        print-length-limit current-print-length setter-tag read-marks
    3636        ##sys#print-exit
    37         ##sys#format-here-doc-warning)
     37        ##sys#format-here-doc-warning)
    3838  (foreign-declare #<<EOF
    3939#include <string.h>
     
    5151
    5252#ifndef EX_SOFTWARE
    53 # define EX_SOFTWARE    70
     53# define EX_SOFTWARE    70
    5454#endif
    5555
    5656#ifndef C_BUILD_TAG
    57 # define C_BUILD_TAG    ""
     57# define C_BUILD_TAG    ""
    5858#endif
    5959
    60 #define C_close_file(p)       (C_fclose((C_FILEPTR)(C_port_file(p))), C_SCHEME_UNDEFINED)
    61 #define C_f64peek(b, i)       (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
     60#define C_close_file(p)       (C_fclose((C_FILEPTR)(C_port_file(p))), C_SCHEME_UNDEFINED)
     61#define C_f64peek(b, i)       (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
    6262#define C_fetch_c_strlen(b, i) C_fix(strlen((C_char *)C_block_item(b, C_unfix(i))))
    6363#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)
     
    8585    c = getc(fp);
    8686    switch (c) {
    87     case '\r':  if ((c = getc(fp)) != '\n') ungetc(c, fp);
    88     case EOF:   clearerr(fp);
    89     case '\n':  return C_fix(i);
     87    case '\r':  if ((c = getc(fp)) != '\n') ungetc(c, fp);
     88    case EOF:   clearerr(fp);
     89    case '\n':  return C_fix(i);
    9090    }
    9191    buf[i] = c;
     
    107107      clearerr (fp);
    108108      if (0 == m)
    109         return C_SCHEME_END_OF_FILE;
     109        return C_SCHEME_END_OF_FILE;
    110110    } else if (ferror (fp)) {
    111111      if (0 == m) {
    112         return C_SCHEME_FALSE;
     112        return C_SCHEME_FALSE;
    113113      } else {
    114         clearerr (fp);
     114        clearerr (fp);
    115115      }
    116116    }
     
    246246(define ##sys#undefined-value (##core#undefined))
    247247(define (##sys#halt) (##core#inline "C_halt" #f))
    248 (define ##sys#dload (##core#primitive "C_dload"))
    249 (define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
    250248(define (##sys#flo2fix n) (##core#inline "C_quickflonumtruncate" n))
    251249(define ##sys#become! (##core#primitive "C_become"))
     
    329327(define (##sys#check-integer x . y)
    330328  (unless (##core#inline "C_i_integerp" x)
    331     (##sys#signal-hook #:type-error (if (pair? y) (car y) #f) "bad argument type - not an integer" x) ) )
    332 
    333 (define ##sys#check-range
    334   (lambda (i from to loc)
    335     (##sys#check-exact i loc)
    336     (if (or (not (fx>= i from))
    337             (not (fx< i to)) )
    338         (##sys#signal-hook #:bounds-error loc "out of range" i from to) ) ) )
    339 
    340 (define (##sys#check-special ptr loc)
     329    (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int)
     330                      (if (pair? y) (car y) #f) x) ) )
     331
     332(define (##sys#check-range i from to . y)
     333  (##sys#check-exact i loc)
     334  (unless (and (fx<= from i) (fx< i to))
     335    (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
     336                      (if (pair? y) (car y) #f) i from to) ) )
     337
     338(define (##sys#check-special ptr . y)
    341339  (unless (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
    342     (##sys#signal-hook #:type-error loc "bad argument type - not a pointer-like object" ptr) ) )
     340    (##sys#signal-hook #:type-error (if (pair? y) (car y) #f) "bad argument type - not a pointer-like object" ptr) ) )
    343341
    344342(define (##sys#check-closure x . y)
     
    382380           (##sys#signal-hook #:process-error 'system "`system' invocation failed" cmd) )
    383381          (else r) ) ) )
     382
     383
     384;;; Dynamic Load
     385
     386(define ##sys#dload (##core#primitive "C_dload"))
     387(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
     388
     389;; not available on all platforms and to be used with caution...
     390(define (##sys#dunload name)
     391  (and-let* ((r (##core#inline "C_dunload" (##sys#make-c-string name))))
     392    (##sys#gc #t)
     393    #t ) )
    384394
    385395
     
    448458          (else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
    449459
    450 (define ##sys#not-a-proper-list-error
    451   (lambda (arg . loc)
    452     (##sys#signal-hook #:type-error (if (pair? loc) (car loc) #f) "argument is not a proper list" arg) ) )
     460(define (##sys#not-a-proper-list-error arg . loc)
     461  (##sys#error-hook (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int)
     462                    (if (pair? loc) (car loc) #f) arg) )
    453463
    454464(define append
     
    514524    (##sys#signal-hook #:bounds-error 'make-string "size is negative" size))
    515525  (%make-string size
    516                 (if (null? fill)
    517                     #\space
    518                     (let ((c (car fill)))
    519                       (##sys#check-char c 'make-string)
    520                       c ) ) ) )
     526                (if (null? fill)
     527                    #\space
     528                    (let ((c (car fill)))
     529                      (##sys#check-char c 'make-string)
     530                      c ) ) ) )
    521531
    522532(define ##sys#string->list
     
    536546    [unsafe
    537547    (let* ([len (length lst0)]
    538            [s (##sys#make-string len)] )
     548           [s (##sys#make-string len)] )
    539549      (do ([i 0 (fx+ i 1)]
    540            [lst lst0 (##sys#slot lst 1)] )
    541         ((fx>= i len) s)
    542         (##core#inline "C_setsubchar" s i (##sys#slot lst 0)) ) )]
     550           [lst lst0 (##sys#slot lst 1)] )
     551        ((fx>= i len) s)
     552        (##core#inline "C_setsubchar" s i (##sys#slot lst 0)) ) )]
    543553    [else
    544554    (if (not (list? lst0))
    545555      (##sys#not-a-proper-list-error lst0 'list->string)
    546556      (let* ([len (length lst0)]
    547              [s (##sys#make-string len)] )
    548         (do ([i 0 (fx+ i 1)]
    549              [lst lst0 (##sys#slot lst 1)] )
    550           ((fx>= i len) s)
    551           (let ([c (##sys#slot lst 0)])
    552             (##sys#check-char c 'list->string)
    553             (##core#inline "C_setsubchar" s i c) ) ) ) )]
     557             [s (##sys#make-string len)] )
     558        (do ([i 0 (fx+ i 1)]
     559             [lst lst0 (##sys#slot lst 1)] )
     560          ((fx>= i len) s)
     561          (let ([c (##sys#slot lst 0)])
     562            (##sys#check-char c 'list->string)
     563            (##core#inline "C_setsubchar" s i c) ) ) ) )]
    554564    ))
    555565
     
    562572    [unsafe
    563573    (let* ((n (length l))
    564            (s (##sys#make-string n)))
     574           (s (##sys#make-string n)))
    565575      (let iter ((l2 l) (n2 (fx- n 1)))
    566         (cond ((fx>= n2 0)
    567                (##core#inline "C_setsubchar" s n2 (##sys#slot l2 0))
    568                (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
     576        (cond ((fx>= n2 0)
     577               (##core#inline "C_setsubchar" s n2 (##sys#slot l2 0))
     578               (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
    569579      s ) ]
    570580    [else
    571581    (if (list? l)
    572582      (let* ((n (length l))
    573              (s (##sys#make-string n)))
    574         (let iter ((l2 l) (n2 (fx- n 1)))
    575           (cond ((fx>= n2 0)
    576                 (let ((c (##sys#slot l2 0)))
    577                    (##sys#check-char c 'reverse-list->string)
    578                    (##core#inline "C_setsubchar" s n2 c) )
    579                 (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
    580         s )
     583             (s (##sys#make-string n)))
     584        (let iter ((l2 l) (n2 (fx- n 1)))
     585          (cond ((fx>= n2 0)
     586                (let ((c (##sys#slot l2 0)))
     587                   (##sys#check-char c 'reverse-list->string)
     588                   (##core#inline "C_setsubchar" s n2 c) )
     589                (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
     590        s )
    581591      (##sys#not-a-proper-list-error l 'reverse-list->string) ) ]
    582592    ) )
     
    598608      s2) ) )
    599609
    600 (define substring
    601   (lambda (s start . end)
    602     (##sys#check-string s 'substring)
    603     (##sys#check-exact start 'substring)
    604     (let ([end (if (pair? end)
    605                    (let ([end (car end)])
    606                      (##sys#check-exact end 'substring)
    607                      end)
    608                    (##sys#size s) ) ] )
    609       (cond-expand
    610        [unsafe (##sys#substring s start end)]
    611        [else
     610(define (substring s start . end)
     611  (##sys#check-string s 'substring)
     612  (##sys#check-exact start 'substring)
     613  (let ([end (if (pair? end)
     614                 (let ([end (car end)])
     615                   (##sys#check-exact end 'substring)
     616                   end)
     617                 (##sys#size s) ) ] )
     618    (cond-expand
     619      [unsafe (##sys#substring s start end)]
     620      [else
    612621        (let ([len (##sys#size s)])
    613622          (if (and (fx<= start end)
     
    615624                   (fx<= end len) )
    616625              (##sys#substring s start end)
    617               (##sys#signal-hook #:bounds-error 'substring "index out of bounds" start end) ) ) ] ) ) ) )
     626              (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
     627                                'substring start end) ) ) ] ) ) )
    618628
    619629(define ##sys#substring
     
    770780(define (fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
    771781
    772 (define fx/
    773   (lambda (x y)
    774     (cond-expand
    775      [unsafe (##core#inline "C_fixnum_divide" x y)]
    776      [else
    777       (if (eq? y 0)
    778           (##sys#signal-hook #:arithmetic-error 'fx/ "division by zero" x y)
    779           (##core#inline "C_fixnum_divide" x y) ) ] ) ) )
    780 
    781 (define fxmod
    782   (lambda (x y)
    783     (cond-expand
    784      [unsafe (##core#inline "C_fixnum_modulo" x y)]
    785      [else
    786       (if (eq? y 0)
    787           (##sys#signal-hook #:arithmetic-error 'fxmod "division by zero" x y)
    788           (##core#inline "C_fixnum_modulo" x y) ) ] ) ) )
     782(define-inline (fx-check-divison-by-zero x y loc)
     783  (when (eq? 0 y)
     784    (##sys#error-hook (foreign-value "C_DIVISION_BY_ZERO_ERROR" int) loc x y) ) )
     785
     786(define (fx/ x y)
     787  (cond-expand
     788   [unsafe (##core#inline "C_fixnum_divide" x y)]
     789   [else
     790    (fx-check-divison-by-zero x y 'fx/)
     791    (##core#inline "C_fixnum_divide" x y) ] ) )
     792
     793(define (fxmod x y)
     794  (cond-expand
     795   [unsafe (##core#inline "C_fixnum_modulo" x y)]
     796   [else
     797    (fx-check-divison-by-zero x y 'fxmod)
     798    (##core#inline "C_fixnum_modulo" x y) ] ) )
    789799
    790800(define (flonum? x) (##core#inline "C_i_flonump" x))
     
    794804  (##core#inline "C_i_finitep" x) )
    795805
     806(define-inline (fp-check-flonum x loc)
     807  (unless (flonum? x)
     808    (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x) ) )
     809
     810(define-inline (fp-check-flonums x y loc)
     811  (unless (and (flonum? x) (flonum? y)
     812    (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x y) )
     813
    796814(define (fp+ x y)
    797815  (cond-expand
    798    (unsafe (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
    799    (else
    800     (if (and (flonum? x)
    801              (flonum? y))
    802         (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y)
    803         (##sys#signal-hook #:type-error 'fp+ "not flonums" x y)))))
     816   [unsafe (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y)]
     817   [else
     818    (fp-check-flonums x y 'fp+)
     819    (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) ] ) )
    804820
    805821(define (fp- x y)
    806822  (cond-expand
    807    (unsafe (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
    808    (else
    809     (if (and (flonum? x)
    810              (flonum? y))
    811         (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y)
    812         (##sys#signal-hook #:type-error 'fp- "not flonums" x y)))))
     823   [unsafe (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y)]
     824   [else
     825    (fp-check-flonums x y 'fp-)
     826    (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) ] ) )
    813827
    814828(define (fp* x y)
    815829  (cond-expand
    816    (unsafe (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
    817    (else
    818     (if (and (flonum? x)
    819              (flonum? y))
    820         (##core#inline_allocate ("C_a_i_flonum_times" 4) x y)
    821         (##sys#signal-hook #:type-error 'fp* "not flonums" x y)))))
     830   [unsafe (##core#inline_allocate ("C_a_i_flonum_times" 4) x y)]
     831   [else
     832    (fp-check-flonums x y 'fp*)
     833    (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) ] ) )
    822834
    823835(define (fp= x y)
    824836  (cond-expand
    825    (unsafe (##core#inline "C_flonum_equalp" x y))
    826    (else (if (and (flonum? x)
    827                   (flonum? y))
    828              (##core#inline "C_flonum_equalp" x y)
    829              (##sys#signal-hook #:type-error 'fp= "not flonums" x y)))))
     837   [unsafe (##core#inline "C_flonum_equalp" x y)]
     838   [else
     839    (fp-check-flonums x y 'fp=)
     840    (##core#inline "C_flonum_equalp" x y) ] ) )
    830841
    831842(define (fp> x y)
    832843  (cond-expand
    833    (unsafe (##core#inline "C_flonum_greaterp" x y))
    834    (else (if (and (flonum? x)
    835                   (flonum? y))
    836              (##core#inline "C_flonum_greaterp" x y)
    837              (##sys#signal-hook #:type-error 'fp> "not flonums" x y)))))
     844   [unsafe (##core#inline "C_flonum_greaterp" x y)]
     845   [else
     846    (fp-check-flonums x y 'fp>)
     847    (##core#inline "C_flonum_greaterp" x y) ] ) )
    838848
    839849(define (fp< x y)
    840850  (cond-expand
    841    (unsafe (##core#inline "C_flonum_lessp" x y))
    842    (else (if (and (flonum? x)
    843                   (flonum? y))
    844              (##core#inline "C_flonum_lessp" x y)
    845              (##sys#signal-hook #:type-error 'fp< "not flonums" x y)))))
     851   [unsafe (##core#inline "C_flonum_lessp" x y)]
     852   [else
     853    (fp-check-flonums x y 'fp<)
     854    (##core#inline "C_flonum_lessp" x y) ] ) )
    846855
    847856(define (fp>= x y)
    848857  (cond-expand
    849    (unsafe (##core#inline "C_flonum_greater_or_equal_p" x y))
    850    (else (if (and (flonum? x)
    851                   (flonum? y))
    852              (##core#inline "C_flonum_greater_or_equal_p" x y)
    853              (##sys#signal-hook #:type-error 'fp>= "not flonums" x y)))))
     858   [unsafe (##core#inline "C_flonum_greater_or_equal_p" x y)]
     859   [else
     860    (fp-check-flonums x y 'fp>=)
     861    (##core#inline "C_flonum_greater_or_equal_p" x y) ] ) )
    854862
    855863(define (fp<= x y)
    856864  (cond-expand
    857    (unsafe (##core#inline "C_flonum_less_or_equal_p" x y))
    858    (else (if (and (flonum? x)
    859                   (flonum? y))
    860              (##core#inline "C_flonum_less_or_equal_p" x y)
    861              (##sys#signal-hook #:type-error 'fp<= "not flonums" x y)))))
     865   [unsafe (##core#inline "C_flonum_less_or_equal_p" x y)]
     866   [else
     867    (fp-check-flonums x y 'fp<=)
     868    (##core#inline "C_flonum_less_or_equal_p" x y) ] ) )
    862869
    863870(define (fpneg x)
    864871  (cond-expand
    865    (unsafe (##core#inline_allocate ("C_a_i_flonum_negate" 4) x))
    866    (else (if (flonum? x)
    867              (##core#inline_allocate ("C_a_i_flonum_negate" 4) x)
    868              (##sys#signal-hook #:type-error 'fpneg "not flonums" x)))))
     872   [unsafe (##core#inline_allocate ("C_a_i_flonum_negate" 4) x)]
     873   [else
     874    (fp-check-flonum x 'fpneg)
     875    (##core#inline_allocate ("C_a_i_flonum_negate" 4) x) ] ) )
    869876
    870877(define (fpmax x y)
    871878  (cond-expand
    872    (unsafe (##core#inline "C_i_flonum_max" x y))
    873    (else (if (and (flonum? x)
    874                   (flonum? y))
    875              (##core#inline "C_i_flonum_max" x y)
    876              (##sys#signal-hook #:type-error 'fpmax "not flonums" x y)))))
     879   [unsafe (##core#inline "C_i_flonum_max" x y)]
     880   [else
     881    (fp-check-flonums x y 'fpmax)
     882    (##core#inline "C_i_flonum_max" x y) ] ) )
    877883
    878884(define (fpmin x y)
    879885  (cond-expand
    880    (unsafe (##core#inline "C_i_flonum_min" x y))
    881    (else (if (and (flonum? x)
    882                   (flonum? y))
    883              (##core#inline "C_i_flonum_min" x y)
    884              (##sys#signal-hook #:type-error 'fpmin "not flonums" x y)))))
     886   [unsafe (##core#inline "C_i_flonum_min" x y)]
     887   [else
     888    (fp-check-flonums x y 'fpmin)
     889    (##core#inline "C_i_flonum_min" x y) ] ) )
    885890
    886891(define (fp/ x y)
    887892  (cond-expand
    888    (unsafe (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
    889    (else (if (and (flonum? x)
    890                   (flonum? y))
    891              (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y)
    892              (##sys#signal-hook #:type-error 'fp/ "not flonums" x y)))))
     893   [unsafe (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y)]
     894   [else
     895    (fp-check-flonums x y 'fp/)
     896    (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) ] ) )
    893897
    894898(define * (##core#primitive "C_times"))
     
    12581262  (##sys#check-string s 'string->blob)
    12591263  (let* ([n (##sys#size s)]
    1260         [bv (##sys#make-blob n)] )
     1264        [bv (##sys#make-blob n)] )
    12611265    (##core#inline "C_copy_memory" bv s n)
    12621266    bv) )
     
    12651269  (##sys#check-blob bv 'blob->string)
    12661270  (let* ([n (##sys#size bv)]
    1267         [s (##sys#make-string n)] )
     1271        [s (##sys#make-string n)] )
    12681272    (##core#inline "C_copy_memory" s bv n)
    12691273    s) )
     
    13001304    [unsafe
    13011305    (let* ([len (length lst0)]
    1302            [v (##sys#make-vector len)] )
     1306           [v (##sys#make-vector len)] )
    13031307      (let loop ([lst lst0]
    1304                 [i 0])
    1305         (if (null? lst)
    1306           v
    1307           (begin
    1308             (##sys#setslot v i (##sys#slot lst 0))
    1309             (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) )]
     1308                [i 0])
     1309        (if (null? lst)
     1310          v
     1311          (begin
     1312            (##sys#setslot v i (##sys#slot lst 0))
     1313            (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) )]
    13101314    [else
    13111315    (if (not (list? lst0))
    13121316      (##sys#not-a-proper-list-error lst0 'list->vector)
    13131317      (let* ([len (length lst0)]
    1314              [v (##sys#make-vector len)] )
    1315         (let loop ([lst lst0]
    1316                    [i 0])
    1317           (if (null? lst)
    1318             v
    1319             (begin
    1320               (##sys#setslot v i (##sys#slot lst 0))
    1321               (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) )]
     1318             [v (##sys#make-vector len)] )
     1319        (let loop ([lst lst0]
     1320                   [i 0])
     1321          (if (null? lst)
     1322            v
     1323            (begin
     1324              (##sys#setslot v i (##sys#slot lst 0))
     1325              (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) )]
    13221326    ))
    13231327
     
    17311735          (lambda (p s)                 ; write-string
    17321736            (##core#inline "C_display_string" p s) )
    1733           (lambda (p)                   ; close
     1737          (lambda (p)                   ; close
    17341738            (##core#inline "C_close_file" p)
    17351739            (##sys#update-errno) )
     
    17401744          #f                            ; read-string!
    17411745          #; ;UNUSED
    1742           (lambda (p n dest start)      ; read-string!
    1743             (let loop ([rem (or n (fx- (##sys#size dest) start))] [act 0] [start start])
    1744               (let ([len (##core#inline "fast_read_string_from_file" dest p rem start)])
    1745                 (cond [(eof-object? len)
    1746                         (if (eq? 0 act) #!eof act)]
    1747                       [(not len)
    1748                         act]
    1749                       [(fx< len rem)
    1750                         (loop (fx- rem len) (fx+ act len) (fx+ start len))]
    1751                       [else
    1752                         act ] ) ) ) )
     1746          (lambda (p n dest start)      ; read-string!
     1747            (let loop ([rem (or n (fx- (##sys#size dest) start))] [act 0] [start start])
     1748              (let ([len (##core#inline "fast_read_string_from_file" dest p rem start)])
     1749                (cond [(eof-object? len)
     1750                        (if (eq? 0 act) #!eof act)]
     1751                      [(not len)
     1752                        act]
     1753                      [(fx< len rem)
     1754                        (loop (fx- rem len) (fx+ act len) (fx+ start len))]
     1755                      [else
     1756                        act ] ) ) ) )
    17531757          (lambda (p limit)             ; read-line
    17541758            (let* ((buffer-len (if limit limit 256))
     
    18351839    (lambda (name)
    18361840      (if fixsuffix
    1837         (let ([end (fx- (##sys#size name) 1)])
    1838           (if (fx>= end 0)
    1839             (let ([c (##core#inline "C_subchar" name end)])
    1840               (if (or (eq? c #\\) (eq? c #\/))
    1841                 (##sys#substring name 0 end)
    1842                 name) )
    1843             name) )
    1844         name) ) ) )
     1841        (let ([end (fx- (##sys#size name) 1)])
     1842          (if (fx>= end 0)
     1843            (let ([c (##core#inline "C_subchar" name end)])
     1844              (if (or (eq? c #\\) (eq? c #\/))
     1845                (##sys#substring name 0 end)
     1846                name) )
     1847            name) )
     1848        name) ) ) )
    18451849
    18461850(define (##sys#pathname-resolution name thunk . _)
     
    21752179                (skip (##sys#read-char-0 port)) ) ) )
    21762180
    2177         (define (readrec)
    2178 
    2179           (define (r-spaces)
    2180             (let loop ([c (##sys#peek-char-0 port)])
     2181        (define (readrec)
     2182
     2183          (define (r-spaces)
     2184            (let loop ([c (##sys#peek-char-0 port)])
    21812185              (cond ((##core#inline "C_eofp" c))
    21822186                    ((eq? #\; c)
     
    21872191                     (loop (##sys#peek-char-0 port)) ) ) ) )
    21882192
    2189           (define (r-usequence u n)
     2193          (define (r-usequence u n)
    21902194            (let loop ([seq '()] [n n])
    21912195              (if (eq? n 0)
    2192                 (let* ([str (##sys#reverse-list->string seq)]
    2193                        [n (string->number str 16)])
    2194                   (or n
    2195                       (##sys#read-error port (string-append "invalid escape-sequence '\\" u str "\'")) ) )
    2196                 (let ([x (##sys#read-char-0 port)])
    2197                   (if (or (eof-object? x) (char=? #\" x))
    2198                     (##sys#read-error port "unterminated string constant")
    2199                     (loop (cons x seq) (fx- n 1)) ) ) ) ) )
    2200 
    2201           (define (r-cons-codepoint cp lst)
    2202             (let* ((s (##sys#char->utf8-string (integer->char cp)))
    2203                    (len (##sys#size s)))
    2204               (let lp ((i 0) (lst lst))
    2205                 (if (fx>= i len)
    2206                   lst
    2207                   (lp (fx+ i 1) (cons (##core#inline "C_subchar" s i) lst))))))
    2208 
    2209           (define (r-string term)
    2210             (if (eq? (##sys#read-char-0 port) term)
     2196                (let* ([str (##sys#reverse-list->string seq)]
     2197                       [n (string->number str 16)])
     2198                  (or n
     2199                      (##sys#read-error port (string-append "invalid escape-sequence '\\" u str "\'")) ) )
     2200                (let ([x (##sys#read-char-0 port)])
     2201                  (if (or (eof-object? x) (char=? #\" x))
     2202                    (##sys#read-error port "unterminated string constant")
     2203                    (loop (cons x seq) (fx- n 1)) ) ) ) ) )
     2204
     2205          (define (r-cons-codepoint cp lst)
     2206            (let* ((s (##sys#char->utf8-string (integer->char cp)))
     2207                   (len (##sys#size s)))
     2208              (let lp ((i 0) (lst lst))
     2209                (if (fx>= i len)
     2210                  lst
     2211                  (lp (fx+ i 1) (cons (##core#inline "C_subchar" s i) lst))))))
     2212
     2213          (define (r-string term)
     2214            (if (eq? (##sys#read-char-0 port) term)
    22112215                (let loop ((c (##sys#read-char-0 port)) (lst '()))
    22122216                  (cond ((##core#inline "C_eofp" c)
     
    22282232                            (let ([n (r-usequence "u" 4)])
    22292233                              (if (##sys#unicode-surrogate? n)
    2230                                   (if (and (eqv? #\\ (##sys#read-char-0 port))
    2231                                            (eqv? #\u (##sys#read-char-0 port)))
    2232                                       (let* ((m (r-usequence "u" 4))
    2233                                              (cp (##sys#surrogates->codepoint n m)))
    2234                                         (if cp
    2235                                             (loop (##sys#read-char-0 port)
    2236                                                   (r-cons-codepoint cp lst))
    2237                                             (##sys#read-error port "bad surrogate pair" n m)))
    2238                                       (##sys#read-error port "unpaired escaped surrogate" n))
    2239                                   (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) ) ))
     2234                                  (if (and (eqv? #\\ (##sys#read-char-0 port))
     2235                                           (eqv? #\u (##sys#read-char-0 port)))
     2236                                      (let* ((m (r-usequence "u" 4))
     2237                                             (cp (##sys#surrogates->codepoint n m)))
     2238                                        (if cp
     2239                                            (loop (##sys#read-char-0 port)
     2240                                                  (r-cons-codepoint cp lst))
     2241                                            (##sys#read-error port "bad surrogate pair" n m)))
     2242                                      (##sys#read-error port "unpaired escaped surrogate" n))
     2243                                  (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) ) ))
    22402244                           ((#\U)
    22412245                            (let ([n (r-usequence "U" 8)])
    22422246                              (if (##sys#unicode-surrogate? n)
    2243                                   (##sys#read-error port (string-append "invalid escape (surrogate)" n))
    2244                                   (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) )))
     2247                                  (##sys#read-error port (string-append "invalid escape (surrogate)" n))
     2248                                  (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) )))
    22452249                           ((#\\ #\' #\")
    22462250                            (loop (##sys#read-char-0 port) (cons c lst)))
     
    22542258                        (else (loop (##sys#read-char-0 port) (cons c lst))) ) )
    22552259                (##sys#read-error port (string-append "missing `" (string term) "'")) ) )
    2256                    
     2260                   
    22572261          (define (r-list start end)
    22582262            (if (eq? (##sys#read-char-0 port) start)
     
    23112315                      '() ) )
    23122316                (##sys#read-error port "missing token" start) ) )
    2313          
     2317         
    23142318          (define (r-vector)
    23152319            (let ([lst (r-list #\( #\))])
     
    23172321                  (##sys#list->vector lst)
    23182322                  (##sys#read-error port "invalid vector syntax" lst) ) ) )
    2319          
     2323         
    23202324          (define (r-number radix)
    23212325            (set! rat-flag #f)
     
    23402344                           [else (##sys#read-error port "illegal number syntax - invalid exactness prefix" c2)] ) ) ]
    23412345                  [else (r-number radix)] ) )
    2342          
     2346         
    23432347          (define (r-number-with-radix)
    23442348            (cond [(char=? #\# (##sys#peek-char-0 port))
     
    23522356                           [else (##sys#read-error port "illegal number syntax - invalid radix" c2)] ) ) ]
    23532357                  [else (r-number 10)] ) )
    2354        
     2358       
    23552359          (define (r-token)
    23562360            (let loop ([c (##sys#peek-char-0 port)] [lst '()])
     
    23792383            (r-spaces)
    23802384            (r-token) )
    2381          
     2385         
    23822386          (define (r-symbol)
    23832387            (let ((s (resolve-symbol
     
    23982402                        (else (loop (##sys#read-char-0 port) (cons c lst))) ) )
    23992403                (##sys#read-error port "missing \'|\'") ) )
    2400          
     2404         
    24012405          (define (r-char)
    24022406            ;; Code contributed by Alex Shinn
     
    24572461              (let loop ([i 0])
    24582462                (cond [(fx>= i toklen)
    2459                        (##sys#read-error port "invalid qualified symbol syntax" tok) ]
     2463                       (##sys#read-error port "invalid qualified symbol syntax" tok) ]
    24602464                      [(fx= (##sys#byte tok i) (char->integer #\#))
    24612465                       (when (fx> i namespace-max-id-len)
     
    25752579                                                   [(member tok '("optional" "rest" "key"))
    25762580                                                    (build-symbol (##sys#string-append "#!" tok)) ]
    2577                                                    [(string=? "current-line" tok)
    2578                                                        (##sys#slot port 4)]
    2579                                                    [(string=? "current-file" tok)
    2580                                                        (port-name port)]
     2581                                                   [(string=? "current-line" tok)
     2582                                                       (##sys#slot port 4)]
     2583                                                   [(string=? "current-file" tok)
     2584                                                       (port-name port)]
    25812585                                                   [else
    25822586                                                    (let ((a (assq (string->symbol tok) read-marks)))
     
    26102614      ((fx<= i #x7FF)
    26112615       (string (integer->char (fxior #b11000000 (fxshr i 6)))
    2612                (integer->char (fxior #b10000000 (fxand i #b111111)))))
     2616               (integer->char (fxior #b10000000 (fxand i #b111111)))))
    26132617      ((fx<= i #xFFFF)
    26142618       (string (integer->char (fxior #b11100000 (fxshr i 12)))
    2615                (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
    2616                (integer->char (fxior #b10000000 (fxand i #b111111)))))
     2619               (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
     2620               (integer->char (fxior #b10000000 (fxand i #b111111)))))
    26172621      ((fx<= i #x1FFFFF)
    26182622       (string (integer->char (fxior #b11110000 (fxshr i 18)))
    2619                (integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111)))
    2620                (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
    2621                (integer->char (fxior #b10000000 (fxand i #b111111)))))
     2623               (integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111)))
     2624               (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
     2625               (integer->char (fxior #b10000000 (fxand i #b111111)))))
    26222626      (else (error "unicode codepoint out of range:" i)))))
    26232627
     
    26302634       (fx<= #xDC00 lo) (fx<= lo #xDFFF)
    26312635       (fxior (fxshl (fx+ 1 (fxand (fxshr hi 6) #b11111)) 16)
    2632               (fxior (fxshl (fxand hi #b111111) 10)
    2633                      (fxand lo #b1111111111)))))
     2636              (fxior (fxshl (fxand hi #b111111) 10)
     2637                     (fxand lo #b1111111111)))))
    26342638
    26352639;;; Hooks for user-defined read-syntax:
     
    29312935                 (outstr port (number->string (##core#inline "C_block_size" x)))
    29322936                 (outchr port #\>) )
    2933                 ((##core#inline "C_structurep" x) (##sys#user-print-hook x readable port))
     2937                ((##core#inline "C_structurep" x) (##sys#user-print-hook x readable port))
    29342938                ((##core#inline "C_closurep" x) (outstr port (##sys#procedure->string x)))
    2935                 ((##core#inline "C_locativep" x) (outstr port "#<locative>"))
     2939                ((##core#inline "C_locativep" x) (outstr port "#<locative>"))
    29362940                ((##core#inline "C_lambdainfop" x)
    29372941                 (outstr port "#<lambda info ")
     
    31003104             (##core#inline "C_setsubchar" output position (##core#inline "C_subchar" str i))
    31013105             (set! position (fx+ position 1)) ) ) ) )
    3102      (lambda (p)                        ; close
     3106     (lambda (p)                        ; close
    31033107       (##sys#setislot p 10 (##sys#slot p 11)) )
    31043108     (lambda (p) #f)                    ; flush-output
     
    31513155  (let loop ([pos pos])
    31523156    (let ([bumper
    3153            (lambda (cur ptr)
    3154              (cond [(eq? cur ptr)       ; at EOB
    3155                      (##sys#setislot port 5 (fx+ (##sys#slot port 5) (fx- cur pos)))
    3156                      #f ]
    3157                    [else                ; at EOL
    3158                      (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
    3159                      (##sys#setislot port 5 0)
    3160                      ptr ] ) ) ] )
     3157           (lambda (cur ptr)
     3158             (cond [(eq? cur ptr)       ; at EOB
     3159                     (##sys#setislot port 5 (fx+ (##sys#slot port 5) (fx- cur pos)))
     3160                     #f ]
     3161                   [else                ; at EOL
     3162                     (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
     3163                     (##sys#setislot port 5 0)
     3164                     ptr ] ) ) ] )
    31613165      (when pos
    3162         (loop (##sys#scan-buffer-line buf lim pos bumper)) ) ) ) )
     3166        (loop (##sys#scan-buffer-line buf lim pos bumper)) ) ) ) )
    31633167
    31643168(define open-input-string
     
    32583262      (let ((rev (##sys#fudge 38))
    32593263            (spec (string-append
    3260                    (if (##sys#fudge 3)  " 64bit" "")
     3264                   (if (##sys#fudge 3)  " 64bit" "")
    32613265                   (if (##sys#fudge 15) " symbolgc" "")
    32623266                   (if (##sys#fudge 40) " manyargs" "")
     
    32993303            [(keyword? x) x]
    33003304            [(symbol? x)  (string->keyword (##sys#symbol->string x))]
    3301             [else         (err x)] ) ) ) )
     3305            [else         (err x)] ) ) ) )
    33023306
    33033307(define ##sys#features '(#:chicken #:srfi-23 #:srfi-30 #:srfi-39 #:srfi-62 #:srfi-17 #:srfi-12))
     
    34623466  (unless (##sys#fudge 35)
    34633467    (##sys#signal-hook #:runtime-error 'singlestep "apply-hook not available") )
    3464   (unless (procedure? thunk)
    3465     (##sys#signal-hook #:type-error "bad argument type - not a procedure" thunk) )
     3468  (##sys#check-closure thunk 'singlestep)
    34663469  (set! ##sys#stepped-thread ##sys#current-thread)
    34673470  (##sys#step thunk) )
     
    34853488    (flush-output o)
    34863489    (let loop ()
    3487       (##sys#print "\n        step (RETURN), (s)kip, (c)ontinue or (b)reak ? " #f o)
     3490      (##sys#print "\n        step (RETURN), (s)kip, (c)ontinue or (b)reak ? " #f o)
    34883491      (let ((c (##sys#read-char-0 i)))
    34893492        (if (eof-object? c)
     
    38143817                     "code to load dynamically was linked with unsafe runtime libraries, but executing runtime was not"
    38153818                     args) )
    3816         ((35) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a floating-point number" args))
     3819        ((35) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a flonum" args))
    38173820        ((36) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a procedure" args))
    38183821        (else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )
     
    38963899             [str2 (##sys#make-string len)] )
    38973900        (##core#inline "C_peek_c_string" b i str2 len)
    3898         (##core#inline "C_free_mptr" b i)
     3901        (##core#inline "C_free_mptr" b i)
    38993902        str2) ) )
    39003903
     
    40084011   (##core#undefined)                   ; #10 specific
    40094012   #f                                   ; #11 block object (type depends on blocking type)
    4010    '()                                  ; #12 recipients (currently unused)
     4013   '()                                  ; #12 recipients (currently unused)
    40114014   #f) )                                ; #13 unblocked by timeout?
    40124015
     
    41094112                      [end (readln port)]
    41104113                      [f #f] )
    4111                   (let ((endlen (string-length end)))
    4112                     (cond
    4113                      ((fx= endlen 0)
    4114                       (##sys#read-warning
    4115                        port "Missing tag after #<< here-doc token"))
    4116                      ((or (char=? (string-ref end (fx- endlen 1)) #\space)
    4117                           (char=? (string-ref end (fx- endlen 1)) #\tab))
    4118                       (##sys#read-warning
    4119                        port "Whitespace after #<< here-doc tag"))
    4120                      ))                    
     4114                  (let ((endlen (string-length end)))
     4115                    (cond
     4116                     ((fx= endlen 0)
     4117                      (##sys#read-warning
     4118                       port "Missing tag after #<< here-doc token"))
     4119                     ((or (char=? (string-ref end (fx- endlen 1)) #\space)
     4120                          (char=? (string-ref end (fx- endlen 1)) #\tab))
     4121                      (##sys#read-warning
     4122                       port "Whitespace after #<< here-doc tag"))
     4123                     ))                    
    41214124                  (do ([ln (readln port) (readln port)])
    41224125                      ((or (eof-object? ln) (string=? end ln))
    41234126                       (when (eof-object? ln)
    41244127                         (##sys#read-warning port
    4125                           (##sys#format-here-doc-warning end)))
     4128                          (##sys#format-here-doc-warning end)))
    41264129                       (get-output-string str) )
    41274130                    (if f
     
    41384141                      s))
    41394142
    4140                   (let ((endlen (string-length end)))
    4141                     (cond
    4142                      ((fx= endlen 0)
    4143                       (##sys#read-warning
    4144                        port "Missing tag after #<# here-doc token"))
    4145                      ((or (char=? (string-ref end (fx- endlen 1)) #\space)
    4146                           (char=? (string-ref end (fx- endlen 1)) #\tab))
    4147                       (##sys#read-warning
    4148                        port "Whitespace after #<# here-doc tag"))
    4149                      ))
     4143                  (let ((endlen (string-length end)))
     4144                    (cond
     4145                     ((fx= endlen 0)
     4146                      (##sys#read-warning
     4147                       port "Missing tag after #<# here-doc token"))
     4148                     ((or (char=? (string-ref end (fx- endlen 1)) #\space)
     4149                          (char=? (string-ref end (fx- endlen 1)) #\tab))
     4150                      (##sys#read-warning
     4151                       port "Whitespace after #<# here-doc tag"))
     4152                     ))
    41504153
    41514154                  (let loop [(lst '())]
     
    41574160                                  (when (eof-object? c)
    41584161                                    (##sys#read-warning
    4159                                      port (##sys#format-here-doc-warning end))
    4160                                      )
     4162                                     port (##sys#format-here-doc-warning end))
     4163                                     )
    41614164                                  `(##sys#print-to-string
    41624165                                    ;;Can't just use `(list ,@lst) because of 126 argument apply limit
     
    44984501(define ##sys#import
    44994502  (let ([enum-syms! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object)])
    4500     (lambda (ns  . more)
     4503    (lambda (ns  . more)
    45014504      (let-optionals more ([syms '()] [prefix #f])
    45024505        (let ([prefix
     
    45514554  (let ([ns (if (pair? args) (car args) ".")])
    45524555    (let ([nsp (##sys#find-symbol-table ns)]
    4553           [enum-syms! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object)]
    4554           [pos (cons -1 '())])
     4556          [enum-syms! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object)]
     4557          [pos (cons -1 '())])
    45554558      (unless nsp (##sys#error "undefined namespace" ns))
    45564559      (let loop ()
    4557         (let ([sym (enum-syms! nsp pos)])
    4558           (when sym
    4559             (proc sym)
    4560             (loop) ) ) ) ) ) )
     4560        (let ([sym (enum-syms! nsp pos)])
     4561          (when sym
     4562            (proc sym)
     4563            (loop) ) ) ) ) ) )
    45614564
    45624565;;; More memory info
     
    46134616  (let ((open-input-string open-input-string))
    46144617    (lambda (x)
    4615       (unless (procedure? x)
    4616         (##sys#signal-hook #:type-error 'procedure-information "bad argument type - not a procedure" x) )
     4618      (##sys#check-closure x 'procedure-information)
    46174619      (and-let* ((info (##sys#lambda-info x)))
    46184620        (##sys#read (open-input-string (##sys#lambda-info->string info)) #f) ) ) ) )
     
    46784680(define vector-ref (getter-with-setter vector-ref vector-set!))
    46794681
    4680 (define (##sys#dunload name)            ; not available on all platforms and to be used with caution...
    4681   (and-let* ((r (##core#inline "C_dunload" (##sys#make-c-string name))))
    4682     (##sys#gc #t)
    4683     #t) )
    4684 
    46854682
    46864683;;; Property lists
  • chicken/trunk/library.scm

    r13124 r13125  
    3535        print-length-limit current-print-length setter-tag read-marks
    3636        ##sys#print-exit
    37         ##sys#format-here-doc-warning)
     37        ##sys#format-here-doc-warning)
    3838  (foreign-declare #<<EOF
    3939#include <string.h>
     
    5151
    5252#ifndef EX_SOFTWARE
    53 # define EX_SOFTWARE    70
     53# define EX_SOFTWARE    70
    5454#endif
    5555
    5656#ifndef C_BUILD_TAG
    57 # define C_BUILD_TAG    ""
     57# define C_BUILD_TAG    ""
    5858#endif
    5959
    60 #define C_close_file(p)       (C_fclose((C_FILEPTR)(C_port_file(p))), C_SCHEME_UNDEFINED)
    61 #define C_f64peek(b, i)       (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
     60#define C_close_file(p)       (C_fclose((C_FILEPTR)(C_port_file(p))), C_SCHEME_UNDEFINED)
     61#define C_f64peek(b, i)       (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
    6262#define C_fetch_c_strlen(b, i) C_fix(strlen((C_char *)C_block_item(b, C_unfix(i))))
    6363#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)
     
    8585    c = getc(fp);
    8686    switch (c) {
    87     case '\r':  if ((c = getc(fp)) != '\n') ungetc(c, fp);
    88     case EOF:   clearerr(fp);
    89     case '\n':  return C_fix(i);
     87    case '\r':  if ((c = getc(fp)) != '\n') ungetc(c, fp);
     88    case EOF:   clearerr(fp);
     89    case '\n':  return C_fix(i);
    9090    }
    9191    buf[i] = c;
     
    107107      clearerr (fp);
    108108      if (0 == m)
    109         return C_SCHEME_END_OF_FILE;
     109        return C_SCHEME_END_OF_FILE;
    110110    } else if (ferror (fp)) {
    111111      if (0 == m) {
    112         return C_SCHEME_FALSE;
     112        return C_SCHEME_FALSE;
    113113      } else {
    114         clearerr (fp);
     114        clearerr (fp);
    115115      }
    116116    }
     
    242242(define ##sys#undefined-value (##core#undefined))
    243243(define (##sys#halt) (##core#inline "C_halt" #f))
    244 (define ##sys#dload (##core#primitive "C_dload"))
    245 (define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
    246244(define (##sys#flo2fix n) (##core#inline "C_quickflonumtruncate" n))
    247245(define ##sys#become! (##core#primitive "C_become"))
     
    325323(define (##sys#check-integer x . y)
    326324  (unless (##core#inline "C_i_integerp" x)
    327     (##sys#signal-hook #:type-error (if (pair? y) (car y) #f) "bad argument type - not an integer" x) ) )
    328 
    329 (define ##sys#check-range
    330   (lambda (i from to loc)
    331     (##sys#check-exact i loc)
    332     (if (or (not (fx>= i from))
    333             (not (fx< i to)) )
    334         (##sys#signal-hook #:bounds-error loc "out of range" i from to) ) ) )
    335 
    336 (define (##sys#check-special ptr loc)
     325    (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int)
     326                      (if (pair? y) (car y) #f) x) ) )
     327
     328(define (##sys#check-range i from to . y)
     329  (##sys#check-exact i loc)
     330  (unless (and (fx<= from i) (fx< i to))
     331    (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
     332                      (if (pair? y) (car y) #f) i from to) ) )
     333
     334(define (##sys#check-special ptr . y)
    337335  (unless (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
    338     (##sys#signal-hook #:type-error loc "bad argument type - not a pointer-like object" ptr) ) )
     336    (##sys#signal-hook #:type-error (if (pair? y) (car y) #f) "bad argument type - not a pointer-like object" ptr) ) )
    339337
    340338(define (##sys#check-closure x . y)
     
    359357           (##sys#signal-hook #:process-error 'system "`system' invocation failed" cmd) )
    360358          (else r) ) ) )
     359
     360
     361;;; Dynamic Load
     362
     363(define ##sys#dload (##core#primitive "C_dload"))
     364(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
     365
     366;; not available on all platforms and to be used with caution...
     367(define (##sys#dunload name)
     368  (and-let* ((r (##core#inline "C_dunload" (##sys#make-c-string name))))
     369    (##sys#gc #t)
     370    #t ) )
    361371
    362372
     
    425435          (else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
    426436
    427 (define ##sys#not-a-proper-list-error
    428   (lambda (arg . loc)
    429     (##sys#signal-hook #:type-error (if (pair? loc) (car loc) #f) "argument is not a proper list" arg) ) )
     437(define (##sys#not-a-proper-list-error arg . loc)
     438  (##sys#error-hook (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int)
     439                    (if (pair? loc) (car loc) #f) arg) )
    430440
    431441(define append
     
    491501    (##sys#signal-hook #:bounds-error 'make-string "size is negative" size))
    492502  (%make-string size
    493                 (if (null? fill)
    494                     #\space
    495                     (let ((c (car fill)))
    496                       (##sys#check-char c 'make-string)
    497                       c ) ) ) )
     503                (if (null? fill)
     504                    #\space
     505                    (let ((c (car fill)))
     506                      (##sys#check-char c 'make-string)
     507                      c ) ) ) )
    498508
    499509(define ##sys#string->list
     
    513523    [unsafe
    514524    (let* ([len (length lst0)]
    515            [s (##sys#make-string len)] )
     525           [s (##sys#make-string len)] )
    516526      (do ([i 0 (fx+ i 1)]
    517            [lst lst0 (##sys#slot lst 1)] )
    518         ((fx>= i len) s)
    519         (##core#inline "C_setsubchar" s i (##sys#slot lst 0)) ) )]
     527           [lst lst0 (##sys#slot lst 1)] )
     528        ((fx>= i len) s)
     529        (##core#inline "C_setsubchar" s i (##sys#slot lst 0)) ) )]
    520530    [else
    521531    (if (not (list? lst0))
    522532      (##sys#not-a-proper-list-error lst0 'list->string)
    523533      (let* ([len (length lst0)]
    524              [s (##sys#make-string len)] )
    525         (do ([i 0 (fx+ i 1)]
    526              [lst lst0 (##sys#slot lst 1)] )
    527           ((fx>= i len) s)
    528           (let ([c (##sys#slot lst 0)])
    529             (##sys#check-char c 'list->string)
    530             (##core#inline "C_setsubchar" s i c) ) ) ) )]
     534             [s (##sys#make-string len)] )
     535        (do ([i 0 (fx+ i 1)]
     536             [lst lst0 (##sys#slot lst 1)] )
     537          ((fx>= i len) s)
     538          (let ([c (##sys#slot lst 0)])
     539            (##sys#check-char c 'list->string)
     540            (##core#inline "C_setsubchar" s i c) ) ) ) )]
    531541    ))
    532542
     
    539549    [unsafe
    540550    (let* ((n (length l))
    541            (s (##sys#make-string n)))
     551           (s (##sys#make-string n)))
    542552      (let iter ((l2 l) (n2 (fx- n 1)))
    543         (cond ((fx>= n2 0)
    544                (##core#inline "C_setsubchar" s n2 (##sys#slot l2 0))
    545                (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
     553        (cond ((fx>= n2 0)
     554               (##core#inline "C_setsubchar" s n2 (##sys#slot l2 0))
     555               (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
    546556      s ) ]
    547557    [else
    548558    (if (list? l)
    549559      (let* ((n (length l))
    550              (s (##sys#make-string n)))
    551         (let iter ((l2 l) (n2 (fx- n 1)))
    552           (cond ((fx>= n2 0)
    553                 (let ((c (##sys#slot l2 0)))
    554                    (##sys#check-char c 'reverse-list->string)
    555                    (##core#inline "C_setsubchar" s n2 c) )
    556                 (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
    557         s )
     560             (s (##sys#make-string n)))
     561        (let iter ((l2 l) (n2 (fx- n 1)))
     562          (cond ((fx>= n2 0)
     563                (let ((c (##sys#slot l2 0)))
     564                   (##sys#check-char c 'reverse-list->string)
     565                   (##core#inline "C_setsubchar" s n2 c) )
     566                (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
     567        s )
    558568      (##sys#not-a-proper-list-error l 'reverse-list->string) ) ]
    559569    ) )
     
    575585      s2) ) )
    576586
    577 (define substring
    578   (lambda (s start . end)
    579     (##sys#check-string s 'substring)
    580     (##sys#check-exact start 'substring)
    581     (let ([end (if (pair? end)
    582                    (let ([end (car end)])
    583                      (##sys#check-exact end 'substring)
    584                      end)
    585                    (##sys#size s) ) ] )
    586       (cond-expand
    587        [unsafe (##sys#substring s start end)]
    588        [else
     587(define (substring s start . end)
     588  (##sys#check-string s 'substring)
     589  (##sys#check-exact start 'substring)
     590  (let ([end (if (pair? end)
     591                 (let ([end (car end)])
     592                   (##sys#check-exact end 'substring)
     593                   end)
     594                 (##sys#size s) ) ] )
     595    (cond-expand
     596      [unsafe (##sys#substring s start end)]
     597      [else
    589598        (let ([len (##sys#size s)])
    590599          (if (and (fx<= start end)
     
    592601                   (fx<= end len) )
    593602              (##sys#substring s start end)
    594               (##sys#signal-hook #:bounds-error 'substring "index out of bounds" start end) ) ) ] ) ) ) )
     603              (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
     604                                'substring start end) ) ) ] ) ) )
    595605
    596606(define ##sys#substring
     
    747757(define (fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
    748758
    749 (define fx/
    750   (lambda (x y)
    751     (cond-expand
    752      [unsafe (##core#inline "C_fixnum_divide" x y)]
    753      [else
    754       (if (eq? y 0)
    755           (##sys#signal-hook #:arithmetic-error 'fx/ "division by zero" x y)
    756           (##core#inline "C_fixnum_divide" x y) ) ] ) ) )
    757 
    758 (define fxmod
    759   (lambda (x y)
    760     (cond-expand
    761      [unsafe (##core#inline "C_fixnum_modulo" x y)]
    762      [else
    763       (if (eq? y 0)
    764           (##sys#signal-hook #:arithmetic-error 'fxmod "division by zero" x y)
    765           (##core#inline "C_fixnum_modulo" x y) ) ] ) ) )
     759(define-inline (fx-check-divison-by-zero x y loc)
     760  (when (eq? 0 y)
     761    (##sys#error-hook (foreign-value "C_DIVISION_BY_ZERO_ERROR" int) loc x y) ) )
     762
     763(define (fx/ x y)
     764  (cond-expand
     765   [unsafe (##core#inline "C_fixnum_divide" x y)]
     766   [else
     767    (fx-check-divison-by-zero x y 'fx/)
     768    (##core#inline "C_fixnum_divide" x y) ] ) )
     769
     770(define (fxmod x y)
     771  (cond-expand
     772   [unsafe (##core#inline "C_fixnum_modulo" x y)]
     773   [else
     774    (fx-check-divison-by-zero x y 'fxmod)
     775    (##core#inline "C_fixnum_modulo" x y) ] ) )
    766776
    767777(define (flonum? x) (##core#inline "C_i_flonump" x))
     
    771781  (##core#inline "C_i_finitep" x) )
    772782
     783(define-inline (fp-check-flonum x loc)
     784  (unless (flonum? x)
     785    (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x) ) )
     786
     787(define-inline (fp-check-flonums x y loc)
     788  (unless (and (flonum? x) (flonum? y)
     789    (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x y) )
     790
    773791(define (fp+ x y)
    774792  (cond-expand
    775    (unsafe (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
    776    (else
    777     (if (and (flonum? x)
    778              (flonum? y))
    779         (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y)
    780         (##sys#signal-hook #:type-error 'fp+ "not flonums" x y)))))
     793   [unsafe (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y)]
     794   [else
     795    (fp-check-flonums x y 'fp+)
     796    (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) ] ) )
    781797
    782798(define (fp- x y)
    783799  (cond-expand
    784    (unsafe (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
    785    (else
    786     (if (and (flonum? x)
    787              (flonum? y))
    788         (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y)
    789         (##sys#signal-hook #:type-error 'fp- "not flonums" x y)))))
     800   [unsafe (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y)]
     801   [else
     802    (fp-check-flonums x y 'fp-)
     803    (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) ] ) )
    790804
    791805(define (fp* x y)
    792806  (cond-expand
    793    (unsafe (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
    794    (else
    795     (if (and (flonum? x)
    796              (flonum? y))
    797         (##core#inline_allocate ("C_a_i_flonum_times" 4) x y)
    798         (##sys#signal-hook #:type-error 'fp* "not flonums" x y)))))
     807   [unsafe (##core#inline_allocate ("C_a_i_flonum_times" 4) x y)]
     808   [else
     809    (fp-check-flonums x y 'fp*)
     810    (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) ] ) )
    799811
    800812(define (fp= x y)
    801813  (cond-expand
    802    (unsafe (##core#inline "C_flonum_equalp" x y))
    803    (else (if (and (flonum? x)
    804                   (flonum? y))
    805              (##core#inline "C_flonum_equalp" x y)
    806              (##sys#signal-hook #:type-error 'fp= "not flonums" x y)))))
     814   [unsafe (##core#inline "C_flonum_equalp" x y)]
     815   [else
     816    (fp-check-flonums x y 'fp=)
     817    (##core#inline "C_flonum_equalp" x y) ] ) )
    807818
    808819(define (fp> x y)
    809820  (cond-expand
    810    (unsafe (##core#inline "C_flonum_greaterp" x y))
    811    (else (if (and (flonum? x)
    812                   (flonum? y))
    813              (##core#inline "C_flonum_greaterp" x y)
    814              (##sys#signal-hook #:type-error 'fp> "not flonums" x y)))))
     821   [unsafe (##core#inline "C_flonum_greaterp" x y)]
     822   [else
     823    (fp-check-flonums x y 'fp>)
     824    (##core#inline "C_flonum_greaterp" x y) ] ) )
    815825
    816826(define (fp< x y)
    817827  (cond-expand
    818    (unsafe (##core#inline "C_flonum_lessp" x y))
    819    (else (if (and (flonum? x)
    820                   (flonum? y))
    821              (##core#inline "C_flonum_lessp" x y)
    822              (##sys#signal-hook #:type-error 'fp< "not flonums" x y)))))
     828   [unsafe (##core#inline "C_flonum_lessp" x y)]
     829   [else
     830    (fp-check-flonums x y 'fp<)
     831    (##core#inline "C_flonum_lessp" x y) ] ) )
    823832
    824833(define (fp>= x y)
    825834  (cond-expand
    826    (unsafe (##core#inline "C_flonum_greater_or_equal_p" x y))
    827    (else (if (and (flonum? x)
    828                   (flonum? y))
    829              (##core#inline "C_flonum_greater_or_equal_p" x y)
    830              (##sys#signal-hook #:type-error 'fp>= "not flonums" x y)))))
     835   [unsafe (##core#inline "C_flonum_greater_or_equal_p" x y)]
     836   [else
     837    (fp-check-flonums x y 'fp>=)
     838    (##core#inline "C_flonum_greater_or_equal_p" x y) ] ) )
    831839
    832840(define (fp<= x y)
    833841  (cond-expand
    834    (unsafe (##core#inline "C_flonum_less_or_equal_p" x y))
    835    (else (if (and (flonum? x)
    836                   (flonum? y))
    837              (##core#inline "C_flonum_less_or_equal_p" x y)
    838              (##sys#signal-hook #:type-error 'fp<= "not flonums" x y)))))
     842   [unsafe (##core#inline "C_flonum_less_or_equal_p" x y)]
     843   [else
     844    (fp-check-flonums x y 'fp<=)
     845    (##core#inline "C_flonum_less_or_equal_p" x y) ] ) )
    839846
    840847(define (fpneg x)
    841848  (cond-expand
    842    (unsafe (##core#inline_allocate ("C_a_i_flonum_negate" 4) x))
    843    (else (if (flonum? x)
    844              (##core#inline_allocate ("C_a_i_flonum_negate" 4) x)
    845              (##sys#signal-hook #:type-error 'fpneg "not flonums" x)))))
     849   [unsafe (##core#inline_allocate ("C_a_i_flonum_negate" 4) x)]
     850   [else
     851    (fp-check-flonum x 'fpneg)
     852    (##core#inline_allocate ("C_a_i_flonum_negate" 4) x) ] ) )
    846853
    847854(define (fpmax x y)
    848855  (cond-expand
    849    (unsafe (##core#inline "C_i_flonum_max" x y))
    850    (else (if (and (flonum? x)
    851                   (flonum? y))
    852              (##core#inline "C_i_flonum_max" x y)
    853              (##sys#signal-hook #:type-error 'fpmax "not flonums" x y)))))
     856   [unsafe (##core#inline "C_i_flonum_max" x y)]
     857   [else
     858    (fp-check-flonums x y 'fpmax)
     859    (##core#inline "C_i_flonum_max" x y) ] ) )
    854860
    855861(define (fpmin x y)
    856862  (cond-expand
    857    (unsafe (##core#inline "C_i_flonum_min" x y))
    858    (else (if (and (flonum? x)
    859                   (flonum? y))
    860              (##core#inline "C_i_flonum_min" x y)
    861              (##sys#signal-hook #:type-error 'fpmin "not flonums" x y)))))
     863   [unsafe (##core#inline "C_i_flonum_min" x y)]
     864   [else
     865    (fp-check-flonums x y 'fpmin)
     866    (##core#inline "C_i_flonum_min" x y) ] ) )
    862867
    863868(define (fp/ x y)
    864869  (cond-expand
    865    (unsafe (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
    866    (else (if (and (flonum? x)
    867                   (flonum? y))
    868              (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y)
    869              (##sys#signal-hook #:type-error 'fp/ "not flonums" x y)))))
     870   [unsafe (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y)]
     871   [else
     872    (fp-check-flonums x y 'fp/)
     873    (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) ] ) )
    870874
    871875(define * (##core#primitive "C_times"))
     
    12401244  (##sys#check-string s 'string->blob)
    12411245  (let* ([n (##sys#size s)]
    1242         [bv (##sys#make-blob n)] )
     1246        [bv (##sys#make-blob n)] )
    12431247    (##core#inline "C_copy_memory" bv s n)
    12441248    bv) )
     
    12471251  (##sys#check-blob bv 'blob->string)
    12481252  (let* ([n (##sys#size bv)]
    1249         [s (##sys#make-string n)] )
     1253        [s (##sys#make-string n)] )
    12501254    (##core#inline "C_copy_memory" s bv n)
    12511255    s) )
     
    12821286    [unsafe
    12831287    (let* ([len (length lst0)]
    1284            [v (##sys#make-vector len)] )
     1288           [v (##sys#make-vector len)] )
    12851289      (let loop ([lst lst0]
    1286                 [i 0])
    1287         (if (null? lst)
    1288           v
    1289           (begin
    1290             (##sys#setslot v i (##sys#slot lst 0))
    1291             (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) )]
     1290                [i 0])
     1291        (if (null? lst)
     1292          v
     1293          (begin
     1294            (##sys#setslot v i (##sys#slot lst 0))
     1295            (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) )]
    12921296    [else
    12931297    (if (not (list? lst0))
    12941298      (##sys#not-a-proper-list-error lst0 'list->vector)
    12951299      (let* ([len (length lst0)]
    1296              [v (##sys#make-vector len)] )
    1297         (let loop ([lst lst0]
    1298                    [i 0])
    1299           (if (null? lst)
    1300             v
    1301             (begin
    1302               (##sys#setslot v i (##sys#slot lst 0))
    1303               (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) )]
     1300             [v (##sys#make-vector len)] )
     1301        (let loop ([lst lst0]
     1302                   [i 0])
     1303          (if (null? lst)
     1304            v
     1305            (begin
     1306              (##sys#setslot v i (##sys#slot lst 0))
     1307              (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) )]
    13041308    ))
    13051309
     
    17131717          (lambda (p s)                 ; write-string
    17141718            (##core#inline "C_display_string" p s) )
    1715           (lambda (p)                   ; close
     1719          (lambda (p)                   ; close
    17161720            (##core#inline "C_close_file" p)
    17171721            (##sys#update-errno) )
     
    17221726          #f                            ; read-string!
    17231727          #; ;UNUSED
    1724           (lambda (p n dest start)      ; read-string!
    1725             (let loop ([rem (or n (fx- (##sys#size dest) start))] [act 0] [start start])
    1726               (let ([len (##core#inline "fast_read_string_from_file" dest p rem start)])
    1727                 (cond [(eof-object? len)
    1728                         (if (eq? 0 act) #!eof act)]
    1729                       [(not len)
    1730                         act]
    1731                       [(fx< len rem)
    1732                         (loop (fx- rem len) (fx+ act len) (fx+ start len))]
    1733                       [else
    1734                         act ] ) ) ) )
     1728          (lambda (p n dest start)      ; read-string!
     1729            (let loop ([rem (or n (fx- (##sys#size dest) start))] [act 0] [start start])
     1730              (let ([len (##core#inline "fast_read_string_from_file" dest p rem start)])
     1731                (cond [(eof-object? len)
     1732                        (if (eq? 0 act) #!eof act)]
     1733                      [(not len)
     1734                        act]
     1735                      [(fx< len rem)
     1736                        (loop (fx- rem len) (fx+ act len) (fx+ start len))]
     1737                      [else
     1738                        act ] ) ) ) )
    17351739          (lambda (p limit)             ; read-line
    17361740            (let* ((buffer-len (if limit limit 256))
     
    18171821    (lambda (name)
    18181822      (if fixsuffix
    1819         (let ([end (fx- (##sys#size name) 1)])
    1820           (if (fx>= end 0)
    1821             (let ([c (##core#inline "C_subchar" name end)])
    1822               (if (or (eq? c #\\) (eq? c #\/))
    1823                 (##sys#substring name 0 end)
    1824                 name) )
    1825             name) )
    1826         name) ) ) )
     1823        (let ([end (fx- (##sys#size name) 1)])
     1824          (if (fx>= end 0)
     1825            (let ([c (##core#inline "C_subchar" name end)])
     1826              (if (or (eq? c #\\) (eq? c #\/))
     1827                (##sys#substring name 0 end)
     1828                name) )
     1829            name) )
     1830        name) ) ) )
    18271831
    18281832(define (##sys#pathname-resolution name thunk . _)
     
    21572161                (skip (##sys#read-char-0 port)) ) ) )
    21582162
    2159         (define (readrec)
    2160 
    2161           (define (r-spaces)
    2162             (let loop ([c (##sys#peek-char-0 port)])
     2163        (define (readrec)
     2164
     2165          (define (r-spaces)
     2166            (let loop ([c (##sys#peek-char-0 port)])
    21632167              (cond ((##core#inline "C_eofp" c))
    21642168                    ((eq? #\; c)
     
    21692173                     (loop (##sys#peek-char-0 port)) ) ) ) )
    21702174
    2171           (define (r-usequence u n)
     2175          (define (r-usequence u n)
    21722176            (let loop ([seq '()] [n n])
    21732177              (if (eq? n 0)
    2174                 (let* ([str (##sys#reverse-list->string seq)]
    2175                        [n (string->number str 16)])
    2176                   (or n
    2177                       (##sys#read-error port (string-append "invalid escape-sequence '\\" u str "\'")) ) )
    2178                 (let ([x (##sys#read-char-0 port)])
    2179                   (if (or (eof-object? x) (char=? #\" x))
    2180                     (##sys#read-error port "unterminated string constant")
    2181                     (loop (cons x seq) (fx- n 1)) ) ) ) ) )
    2182 
    2183           (define (r-cons-codepoint cp lst)
    2184             (let* ((s (##sys#char->utf8-string (integer->char cp)))
    2185                    (len (##sys#size s)))
    2186               (let lp ((i 0) (lst lst))
    2187                 (if (fx>= i len)
    2188                   lst
    2189                   (lp (fx+ i 1) (cons (##core#inline "C_subchar" s i) lst))))))
    2190 
    2191           (define (r-string term)
    2192             (if (eq? (##sys#read-char-0 port) term)
     2178                (let* ([str (##sys#reverse-list->string seq)]
     2179                       [n (string->number str 16)])
     2180                  (or n
     2181                      (##sys#read-error port (string-append "invalid escape-sequence '\\" u str "\'")) ) )
     2182                (let ([x (##sys#read-char-0 port)])
     2183                  (if (or (eof-object? x) (char=? #\" x))
     2184                    (##sys#read-error port "unterminated string constant")
     2185                    (loop (cons x seq) (fx- n 1)) ) ) ) ) )
     2186
     2187          (define (r-cons-codepoint cp lst)
     2188            (let* ((s (##sys#char->utf8-string (integer->char cp)))
     2189                   (len (##sys#size s)))
     2190              (let lp ((i 0) (lst lst))
     2191                (if (fx>= i len)
     2192                  lst
     2193                  (lp (fx+ i 1) (cons (##core#inline "C_subchar" s i) lst))))))
     2194
     2195          (define (r-string term)
     2196            (if (eq? (##sys#read-char-0 port) term)
    21932197                (let loop ((c (##sys#read-char-0 port)) (lst '()))
    21942198                  (cond ((##core#inline "C_eofp" c)
     
    22102214                            (let ([n (r-usequence "u" 4)])
    22112215                              (if (##sys#unicode-surrogate? n)
    2212                                   (if (and (eqv? #\\ (##sys#read-char-0 port))
    2213                                            (eqv? #\u (##sys#read-char-0 port)))
    2214                                       (let* ((m (r-usequence "u" 4))
    2215                                              (cp (##sys#surrogates->codepoint n m)))
    2216                                         (if cp
    2217                                             (loop (##sys#read-char-0 port)
    2218                                                   (r-cons-codepoint cp lst))
    2219                                             (##sys#read-error port "bad surrogate pair" n m)))
    2220                                       (##sys#read-error port "unpaired escaped surrogate" n))
    2221                                   (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) ) ))
     2216                                  (if (and (eqv? #\\ (##sys#read-char-0 port))
     2217                                           (eqv? #\u (##sys#read-char-0 port)))
     2218                                      (let* ((m (r-usequence "u" 4))
     2219                                             (cp (##sys#surrogates->codepoint n m)))
     2220                                        (if cp
     2221                                            (loop (##sys#read-char-0 port)
     2222                                                  (r-cons-codepoint cp lst))
     2223                                            (##sys#read-error port "bad surrogate pair" n m)))
     2224                                      (##sys#read-error port "unpaired escaped surrogate" n))
     2225                                  (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) ) ))
    22222226                           ((#\U)
    22232227                            (let ([n (r-usequence "U" 8)])
    22242228                              (if (##sys#unicode-surrogate? n)
    2225                                   (##sys#read-error port (string-append "invalid escape (surrogate)" n))
    2226                                   (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) )))
     2229                                  (##sys#read-error port (string-append "invalid escape (surrogate)" n))
     2230                                  (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) )))
    22272231                           ((#\\ #\' #\")
    22282232                            (loop (##sys#read-char-0 port) (cons c lst)))
     
    22362240                        (else (loop (##sys#read-char-0 port) (cons c lst))) ) )
    22372241                (##sys#read-error port (string-append "missing `" (string term) "'")) ) )
    2238                    
     2242                   
    22392243          (define (r-list start end)
    22402244            (if (eq? (##sys#read-char-0 port) start)
     
    22932297                      '() ) )
    22942298                (##sys#read-error port "missing token" start) ) )
    2295          
     2299         
    22962300          (define (r-vector)
    22972301            (let ([lst (r-list #\( #\))])
     
    22992303                  (##sys#list->vector lst)
    23002304                  (##sys#read-error port "invalid vector syntax" lst) ) ) )
    2301          
     2305         
    23022306          (define (r-number radix)
    23032307            (set! rat-flag #f)
     
    23222326                           [else (##sys#read-error port "illegal number syntax - invalid exactness prefix" c2)] ) ) ]
    23232327                  [else (r-number radix)] ) )
    2324          
     2328         
    23252329          (define (r-number-with-radix)
    23262330            (cond [(char=? #\# (##sys#peek-char-0 port))
     
    23342338                           [else (##sys#read-error port "illegal number syntax - invalid radix" c2)] ) ) ]
    23352339                  [else (r-number 10)] ) )
    2336        
     2340       
    23372341          (define (r-token)
    23382342            (let loop ([c (##sys#peek-char-0 port)] [lst '()])
     
    23612365            (r-spaces)
    23622366            (r-token) )
    2363          
     2367         
    23642368          (define (r-symbol)
    23652369            (let ((s (resolve-symbol
     
    23802384                        (else (loop (##sys#read-char-0 port) (cons c lst))) ) )
    23812385                (##sys#read-error port "missing \'|\'") ) )
    2382          
     2386         
    23832387          (define (r-char)
    23842388            ;; Code contributed by Alex Shinn
     
    24392443              (let loop ([i 0])
    24402444                (cond [(fx>= i toklen)
    2441                        (##sys#read-error port "invalid qualified symbol syntax" tok) ]
     2445                       (##sys#read-error port "invalid qualified symbol syntax" tok) ]
    24422446                      [(fx= (##sys#byte tok i) (char->integer #\#))
    24432447                       (when (fx> i namespace-max-id-len)
     
    25572561                                                   [(member tok '("optional" "rest" "key"))
    25582562                                                    (build-symbol (##sys#string-append "#!" tok)) ]
    2559                                                    [(string=? "current-line" tok)
    2560                                                        (##sys#slot port 4)]
    2561                                                    [(string=? "current-file" tok)
    2562                                                        (port-name port)]
     2563                                                   [(string=? "current-line" tok)
     2564                                                       (##sys#slot port 4)]
     2565                                                   [(string=? "current-file" tok)
     2566                                                       (port-name port)]
    25632567                                                   [else
    25642568                                                    (let ((a (assq (string->symbol tok) read-marks)))
     
    25922596      ((fx<= i #x7FF)
    25932597       (string (integer->char (fxior #b11000000 (fxshr i 6)))
    2594                (integer->char (fxior #b10000000 (fxand i #b111111)))))
     2598               (integer->char (fxior #b10000000 (fxand i #b111111)))))
    25952599      ((fx<= i #xFFFF)
    25962600       (string (integer->char (fxior #b11100000 (fxshr i 12)))
    2597                (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
    2598                (integer->char (fxior #b10000000 (fxand i #b111111)))))
     2601               (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
     2602               (integer->char (fxior #b10000000 (fxand i #b111111)))))
    25992603      ((fx<= i #x1FFFFF)
    26002604       (string (integer->char (fxior #b11110000 (fxshr i 18)))
    2601                (integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111)))
    2602                (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
    2603                (integer->char (fxior #b10000000 (fxand i #b111111)))))
     2605               (integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111)))
     2606               (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
     2607               (integer->char (fxior #b10000000 (fxand i #b111111)))))
    26042608      (else (error "unicode codepoint out of range:" i)))))
    26052609
     
    26122616       (fx<= #xDC00 lo) (fx<= lo #xDFFF)
    26132617       (fxior (fxshl (fx+ 1 (fxand (fxshr hi 6) #b11111)) 16)
    2614               (fxior (fxshl (fxand hi #b111111) 10)
    2615                      (fxand lo #b1111111111)))))
     2618              (fxior (fxshl (fxand hi #b111111) 10)
     2619                     (fxand lo #b1111111111)))))
    26162620
    26172621;;; Hooks for user-defined read-syntax:
     
    29132917                 (outstr port (number->string (##core#inline "C_block_size" x)))
    29142918                 (outchr port #\>) )
    2915                 ((##core#inline "C_structurep" x) (##sys#user-print-hook x readable port))
     2919                ((##core#inline "C_structurep" x) (##sys#user-print-hook x readable port))
    29162920                ((##core#inline "C_closurep" x) (outstr port (##sys#procedure->string x)))
    2917                 ((##core#inline "C_locativep" x) (outstr port "#<locative>"))
     2921                ((##core#inline "C_locativep" x) (outstr port "#<locative>"))
    29182922                ((##core#inline "C_lambdainfop" x)
    29192923                 (outstr port "#<lambda info ")
     
    30823086             (##core#inline "C_setsubchar" output position (##core#inline "C_subchar" str i))
    30833087             (set! position (fx+ position 1)) ) ) ) )
    3084      (lambda (p)                        ; close
     3088     (lambda (p)                        ; close
    30853089       (##sys#setislot p 10 (##sys#slot p 11)) )
    30863090     (lambda (p) #f)                    ; flush-output
     
    31333137  (let loop ([pos pos])
    31343138    (let ([bumper
    3135            (lambda (cur ptr)
    3136              (cond [(eq? cur ptr)       ; at EOB
    3137                      (##sys#setislot port 5 (fx+ (##sys#slot port 5) (fx- cur pos)))
    3138                      #f ]
    3139                    [else                ; at EOL
    3140                      (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
    3141                      (##sys#setislot port 5 0)
    3142                      ptr ] ) ) ] )
     3139           (lambda (cur ptr)
     3140             (cond [(eq? cur ptr)       ; at EOB
     3141                     (##sys#setislot port 5 (fx+ (##sys#slot port 5) (fx- cur pos)))
     3142                     #f ]
     3143                   [else                ; at EOL
     3144                     (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
     3145                     (##sys#setislot port 5 0)
     3146                     ptr ] ) ) ] )
    31433147      (when pos
    3144         (loop (##sys#scan-buffer-line buf lim pos bumper)) ) ) ) )
     3148        (loop (##sys#scan-buffer-line buf lim pos bumper)) ) ) ) )
    31453149
    31463150(define open-input-string
     
    32403244      (let ((rev (##sys#fudge 38))
    32413245            (spec (string-append
    3242                    (if (##sys#fudge 3)  " 64bit" "")
     3246                   (if (##sys#fudge 3)  " 64bit" "")
    32433247                   (if (##sys#fudge 15) " symbolgc" "")
    32443248                   (if (##sys#fudge 40) " manyargs" "")
     
    32803284            [(keyword? x) x]
    32813285            [(symbol? x)  (string->keyword (##sys#symbol->string x))]
    3282             [else         (err x)] ) ) ) )
     3286            [else         (err x)] ) ) ) )
    32833287
    32843288(define ##sys#features
     
    34443448  (unless (##sys#fudge 35)
    34453449    (##sys#signal-hook #:runtime-error 'singlestep "apply-hook not available") )
    3446   (unless (procedure? thunk)
    3447     (##sys#signal-hook #:type-error "bad argument type - not a procedure" thunk) )
     3450  (##sys#check-closure thunk 'singlestep)
    34483451  (set! ##sys#stepped-thread ##sys#current-thread)
    34493452  (##sys#step thunk) )
     
    34673470    (flush-output o)
    34683471    (let loop ()
    3469       (##sys#print "\n        step (RETURN), (s)kip, (c)ontinue or (b)reak ? " #f o)
     3472      (##sys#print "\n        step (RETURN), (s)kip, (c)ontinue or (b)reak ? " #f o)
    34703473      (let ((c (##sys#read-char-0 i)))
    34713474        (if (eof-object? c)
     
    37983801                     "code to load dynamically was linked with unsafe runtime libraries, but executing runtime was not"
    37993802                     args) )
    3800         ((35) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a floating-point number" args))
     3803        ((35) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a flonum" args))
    38013804        ((36) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a procedure" args))
    38023805        (else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )
     
    38803883             [str2 (##sys#make-string len)] )
    38813884        (##core#inline "C_peek_c_string" b i str2 len)
    3882         (##core#inline "C_free_mptr" b i)
     3885        (##core#inline "C_free_mptr" b i)
    38833886        str2) ) )
    38843887
     
    39923995   (##core#undefined)                   ; #10 specific
    39933996   #f                                   ; #11 block object (type depends on blocking type)
    3994    '()                                  ; #12 recipients (currently unused)
     3997   '()                                  ; #12 recipients (currently unused)
    39953998   #f) )                                ; #13 unblocked by timeout?
    39963999
     
    40934096                      [end (readln port)]
    40944097                      [f #f] )
    4095                   (let ((endlen (string-length end)))
    4096                     (cond
    4097                      ((fx= endlen 0)
    4098                       (##sys#read-warning
    4099                        port "Missing tag after #<< here-doc token"))
    4100                      ((or (char=? (string-ref end (fx- endlen 1)) #\space)
    4101                           (char=? (string-ref end (fx- endlen 1)) #\tab))
    4102                       (##sys#read-warning
    4103                        port "Whitespace after #<< here-doc tag"))
    4104                      ))                    
     4098                  (let ((endlen (string-length end)))
     4099                    (cond
     4100                     ((fx= endlen 0)
     4101                      (##sys#read-warning
     4102                       port "Missing tag after #<< here-doc token"))
     4103                     ((or (char=? (string-ref end (fx- endlen 1)) #\space)
     4104                          (char=? (string-ref end (fx- endlen 1)) #\tab))
     4105                      (##sys#read-warning
     4106                       port "Whitespace after #<< here-doc tag"))
     4107                     ))                    
    41054108                  (do ([ln (readln port) (readln port)])
    41064109                      ((or (eof-object? ln) (string=? end ln))
    41074110                       (when (eof-object? ln)
    41084111                         (##sys#read-warning port
    4109                           (##sys#format-here-doc-warning end)))
     4112                          (##sys#format-here-doc-warning end)))
    41104113                       (get-output-string str) )
    41114114                    (if f
     
    41224125                      s))
    41234126
    4124                   (let ((endlen (string-length end)))
    4125                     (cond
    4126                      ((fx= endlen 0)
    4127                       (##sys#read-warning
    4128                        port "Missing tag after #<# here-doc token"))
    4129                      ((or (char=? (string-ref end (fx- endlen 1)) #\space)
    4130                           (char=? (string-ref end (fx- endlen 1)) #\tab))
    4131                       (##sys#read-warning
    4132                        port "Whitespace after #<# here-doc tag"))
    4133                      ))
     4127                  (let ((endlen (string-length end)))
     4128                    (cond
     4129                     ((fx= endlen 0)
     4130                      (##sys#read-warning
     4131                       port "Missing tag after #<# here-doc token"))
     4132                     ((or (char=? (string-ref end (fx- endlen 1)) #\space)
     4133                          (char=? (string-ref end (fx- endlen 1)) #\tab))
     4134                      (##sys#read-warning
     4135                       port "Whitespace after #<# here-doc tag"))
     4136                     ))
    41344137
    41354138                  (let loop [(lst '())]
     
    41414144                                  (when (eof-object? c)
    41424145                                    (##sys#read-warning
    4143                                      port (##sys#format-here-doc-warning end))
    4144                                      )
     4146                                     port (##sys#format-here-doc-warning end))
     4147                                     )
    41454148                                  `(##sys#print-to-string
    41464149                                    ;;Can't just use `(list ,@lst) because of 126 argument apply limit
     
    44584461(define ##sys#import
    44594462  (let ([enum-syms! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object)])
    4460     (lambda (ns  . more)
     4463    (lambda (ns  . more)
    44614464      (let-optionals more ([syms '()] [prefix #f])
    44624465        (let ([prefix
     
    45114514  (let ([ns (if (pair? args) (car args) ".")])
    45124515    (let ([nsp (##sys#find-symbol-table ns)]
    4513           [enum-syms! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object)]
    4514           [pos (cons -1 '())])
     4516          [enum-syms! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object)]
     4517          [pos (cons -1 '())])
    45154518      (unless nsp (##sys#error "undefined namespace" ns))
    45164519      (let loop ()
    4517         (let ([sym (enum-syms! nsp pos)])
    4518           (when sym
    4519             (proc sym)
    4520             (loop) ) ) ) ) ) )
     4520        (let ([sym (enum-syms! nsp pos)])
     4521          (when sym
     4522            (proc sym)
     4523            (loop) ) ) ) ) ) )
    45214524
    45224525;;; More memory info
     
    45734576  (let ((open-input-string open-input-string))
    45744577    (lambda (x)
    4575       (unless (procedure? x)
    4576         (##sys#signal-hook #:type-error 'procedure-information "bad argument type - not a procedure" x) )
     4578      (##sys#check-closure x 'procedure-information)
    45774579      (and-let* ((info (##sys#lambda-info x)))
    45784580        (##sys#read (open-input-string (##sys#lambda-info->string info)) #f) ) ) ) )
     
    46384640(define vector-ref (getter-with-setter vector-ref vector-set!))
    46394641
    4640 (define (##sys#dunload name)            ; not available on all platforms and to be used with caution...
    4641   (and-let* ((r (##core#inline "C_dunload" (##sys#make-c-string name))))
    4642     (##sys#gc #t)
    4643     #t) )
    4644 
    46454642
    46464643;;; Property lists
Note: See TracChangeset for help on using the changeset viewer.