Changeset 13127 in project for chicken


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

Chgd runtime::barf msgs to match library::##sys#error-hook msgs. Chgd proc define '(define x (lambda ...' style to '(define (x ...' style. Chgd err msgs to common style. Added 'exn subtyp ('arity, etc.) for untyped error-hooks. Chgd '##sys#check-' to common style.

Location:
chicken
Files:
4 edited

Legend:

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

    r13125 r13127  
    268268  (##sys#cons-flonum) )
    269269
    270 (define (##sys#check-structure x y . z)
    271   (if (pair? z)
    272       (##core#inline "C_i_check_structure_2" x y (car z))
     270(define (##sys#check-structure x y . loc)
     271  (if (pair? loc)
     272      (##core#inline "C_i_check_structure_2" x y (car loc))
    273273      (##core#inline "C_i_check_structure" x y) ) )
    274274
    275 (define (##sys#check-blob x . y)
    276   (if (pair? y)
    277       (##core#inline "C_i_check_bytevector_2" x (car y))
     275(define (##sys#check-blob x . loc)
     276  (if (pair? loc)
     277      (##core#inline "C_i_check_bytevector_2" x (car loc))
    278278      (##core#inline "C_i_check_bytevector" x) ) )
    279279
    280280(define ##sys#check-byte-vector ##sys#check-blob)
    281281
    282 (define (##sys#check-pair x . y)
    283   (if (pair? y)
    284       (##core#inline "C_i_check_pair_2" x (car y))
     282(define (##sys#check-pair x . loc)
     283  (if (pair? loc)
     284      (##core#inline "C_i_check_pair_2" x (car loc))
    285285      (##core#inline "C_i_check_pair" x) ) )
    286286
    287 (define (##sys#check-list x . y)
    288   (if (pair? y)
    289       (##core#inline "C_i_check_list_2" x (car y))
     287(define (##sys#check-list x . loc)
     288  (if (pair? loc)
     289      (##core#inline "C_i_check_list_2" x (car loc))
    290290      (##core#inline "C_i_check_list" x) ) )
    291291
    292 (define (##sys#check-string x . y)
    293   (if (pair? y)
    294       (##core#inline "C_i_check_string_2" x (car y))
     292(define (##sys#check-string x . loc)
     293  (if (pair? loc)
     294      (##core#inline "C_i_check_string_2" x (car loc))
    295295      (##core#inline "C_i_check_string" x) ) )
    296296
    297 (define (##sys#check-number x . y)
    298   (if (pair? y)
    299       (##core#inline "C_i_check_number_2" x (car y))
     297(define (##sys#check-number x . loc)
     298  (if (pair? loc)
     299      (##core#inline "C_i_check_number_2" x (car loc))
    300300      (##core#inline "C_i_check_number" x) ) )
    301301
    302 (define (##sys#check-exact x . y)
    303   (if (pair? y)
    304       (##core#inline "C_i_check_exact_2" x (car y))
     302(define (##sys#check-exact x . loc)
     303  (if (pair? loc)
     304      (##core#inline "C_i_check_exact_2" x (car loc))
    305305      (##core#inline "C_i_check_exact" x) ) )
    306306
    307 (define (##sys#check-inexact x . y)
    308   (if (pair? y)
    309       (##core#inline "C_i_check_inexact_2" x (car y))
     307(define (##sys#check-inexact x . loc)
     308  (if (pair? loc)
     309      (##core#inline "C_i_check_inexact_2" x (car loc))
    310310      (##core#inline "C_i_check_inexact" x) ) )
    311311
    312 (define (##sys#check-symbol x . y)
    313   (if (pair? y)
    314       (##core#inline "C_i_check_symbol_2" x (car y))
     312(define (##sys#check-symbol x . loc)
     313  (if (pair? loc)
     314      (##core#inline "C_i_check_symbol_2" x (car loc))
    315315      (##core#inline "C_i_check_symbol" x) ) )
    316316
    317 (define (##sys#check-vector x . y)
    318   (if (pair? y)
    319       (##core#inline "C_i_check_vector_2" x (car y))
     317(define (##sys#check-vector x . loc)
     318  (if (pair? loc)
     319      (##core#inline "C_i_check_vector_2" x (car loc))
    320320      (##core#inline "C_i_check_vector" x) ) )
    321321
    322 (define (##sys#check-char x . y)
    323   (if (pair? y)
    324       (##core#inline "C_i_check_char_2" x (car y))
     322(define (##sys#check-char x . loc)
     323  (if (pair? loc)
     324      (##core#inline "C_i_check_char_2" x (car loc))
    325325      (##core#inline "C_i_check_char" x) ) )
    326326
    327 (define (##sys#check-integer x . y)
     327(define (##sys#check-integer x . loc)
    328328  (unless (##core#inline "C_i_integerp" x)
    329329    (##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)
     330                      (and (pair? loc) (car loc)) x) ) )
     331
     332(define (##sys#check-range i from to . loc)
    333333  (##sys#check-exact i loc)
    334334  (unless (and (fx<= from i) (fx< i to))
    335335    (##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)
     336                      (and (pair? loc) (car loc)) i from to) ) )
     337
     338(define (##sys#check-special ptr . loc)
    339339  (unless (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
    340     (##sys#signal-hook #:type-error (if (pair? y) (car y) #f) "bad argument type - not a pointer-like object" ptr) ) )
    341 
    342 (define (##sys#check-closure x . y)
    343   (if (pair? y)
    344       (##core#inline "C_i_check_closure_2" x (car y))
     340    (##sys#signal-hook #:type-error (and (pair? loc) (car loc)) "bad argument type - not a pointer-like object" ptr) ) )
     341
     342(define (##sys#check-closure x . loc)
     343  (if (pair? loc)
     344      (##core#inline "C_i_check_closure_2" x (car loc))
    345345      (##core#inline "C_i_check_closure" x) ) )
    346346
     
    387387(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
    388388
    389 ;; not available on all platforms and to be used with caution...
     389;; Dynamic Unload not available on all platforms and to be used with caution!
    390390(define (##sys#dunload name)
    391391  (and-let* ((r (##core#inline "C_dunload" (##sys#make-c-string name))))
     
    460460(define (##sys#not-a-proper-list-error arg . loc)
    461461  (##sys#error-hook (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int)
    462                     (if (pair? loc) (car loc) #f) arg) )
    463 
    464 (define append
    465   (lambda lsts
    466     (if (eq? lsts '())
    467         lsts
    468         (let loop ((lsts lsts))
    469           (if (eq? (##sys#slot lsts 1) '())
    470               (##sys#slot lsts 0)
    471               (let copy ((node (##sys#slot lsts 0)))
    472                 (cond-expand
    473                  [unsafe
    474                   (if (eq? node '())
    475                       (loop (##sys#slot lsts 1))
    476                       (cons (##sys#slot node 0) (copy (##sys#slot node 1))) ) ]
    477                  [else
    478                   (cond ((eq? node '()) (loop (##sys#slot lsts 1)))
    479                         ((pair? node)
    480                          (cons (##sys#slot node 0) (copy (##sys#slot node 1))) )
    481                         (else (##sys#not-a-proper-list-error (##sys#slot lsts 0) 'append)) ) ] ) ) ) ) ) ) )
    482 
    483 (define reverse
    484   (lambda (lst0)
    485     (let loop ((lst lst0) (rest '()))
    486       (cond-expand
    487        [unsafe
    488         (if (eq? lst '())
    489             rest
    490             (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest))  ) ]
     462                    (and (pair? loc) (car loc)) arg) )
     463
     464(define (append . lsts)
     465  (if (eq? lsts '())
     466      lsts
     467      (let loop ((lsts lsts))
     468        (if (eq? (##sys#slot lsts 1) '())
     469            (##sys#slot lsts 0)
     470            (let copy ((node (##sys#slot lsts 0)))
     471              (cond-expand
     472               [unsafe
     473                (if (eq? node '())
     474                    (loop (##sys#slot lsts 1))
     475                    (cons (##sys#slot node 0) (copy (##sys#slot node 1))) ) ]
     476               [else
     477                (cond ((eq? node '()) (loop (##sys#slot lsts 1)))
     478                      ((pair? node)
     479                       (cons (##sys#slot node 0) (copy (##sys#slot node 1))) )
     480                      (else (##sys#not-a-proper-list-error (##sys#slot lsts 0) 'append)) ) ] ) ) ) ) ) )
     481
     482(define (reverse lst0)
     483  (let loop ((lst lst0) (rest '()))
     484    (cond-expand
     485     [unsafe
     486      (if (eq? lst '())
     487          rest
     488          (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest))  ) ]
    491489       [else
    492490        (cond ((eq? lst '()) rest)
    493491              ((pair? lst)
    494492               (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) )
    495               (else (##sys#not-a-proper-list-error lst0 'reverse)) ) ] ) ) ) )
     493              (else (##sys#not-a-proper-list-error lst0 'reverse)) ) ] ) ) )
    496494
    497495(define (memq x lst) (##core#inline "C_i_memq" x lst))
     
    617615                 (##sys#size s) ) ] )
    618616    (cond-expand
    619       [unsafe (##sys#substring s start end)]
    620       [else
    621         (let ([len (##sys#size s)])
    622           (if (and (fx<= start end)
    623                    (fx>= start 0)
    624                    (fx<= end len) )
    625               (##sys#substring s start end)
    626               (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
    627                                 'substring start end) ) ) ] ) ) )
    628 
    629 (define ##sys#substring
    630   (lambda (s start end)
    631     (let ([s2 (##sys#make-string (fx- end start))])
    632       (##core#inline "C_substring_copy" s s2 start end 0)
    633       s2) ) )
     617     [unsafe (##sys#substring s start end)]
     618     [else
     619      (let ([len (##sys#size s)])
     620       (if (and (fx<= start end)
     621                (fx>= start 0)
     622                (fx<= end len) )
     623          (##sys#substring s start end)
     624          (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int) 'substring start end) ) ) ] ) ) )
     625
     626(define (##sys#substring s start end)
     627  (let ([s2 (##sys#make-string (fx- end start))])
     628    (##core#inline "C_substring_copy" s s2 start end 0)
     629    s2 ) )
    634630
    635631(define (string=? x y)
     
    731727    z) )
    732728
    733 (define string-append
    734   (lambda all
    735     (let ([snew #f])
    736       (let loop ([strs all] [n 0])
    737         (if (eq? strs '())
    738             (set! snew (##sys#make-string n))
    739             (let ([s (##sys#slot strs 0)])
    740               (##sys#check-string s 'string-append)
    741               (let ([len (##sys#size s)])
    742                 (loop (##sys#slot strs 1) (fx+ n len))
    743                 (##core#inline "C_substring_copy" s snew 0 len n) ) ) ) )
    744       snew) ) )
     729(define (string-append .  all)
     730  (let ([snew #f])
     731    (let loop ([strs all] [n 0])
     732      (if (eq? strs '())
     733          (set! snew (##sys#make-string n))
     734          (let ([s (##sys#slot strs 0)])
     735            (##sys#check-string s 'string-append)
     736            (let ([len (##sys#size s)])
     737              (loop (##sys#slot strs 1) (fx+ n len))
     738              (##core#inline "C_substring_copy" s snew 0 len n) ) ) ) )
     739    snew ) )
    745740
    746741(define string
     
    809804
    810805(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) )
     806  (unless (and (flonum? x) (flonum? y))
     807    (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x y) ) )
    813808
    814809(define (fp+ x y)
     
    833828    (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) ] ) )
    834829
     830(define (fp/ x y)
     831  (cond-expand
     832   [unsafe (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y)]
     833   [else
     834    (fp-check-flonums x y 'fp/)
     835    (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) ] ) )
     836
    835837(define (fp= x y)
    836838  (cond-expand
     
    888890    (fp-check-flonums x y 'fpmin)
    889891    (##core#inline "C_i_flonum_min" x y) ] ) )
    890 
    891 (define (fp/ x y)
    892   (cond-expand
    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) ] ) )
    897892
    898893(define * (##core#primitive "C_times"))
     
    12261221          (##sys#signal-hook #:type-error 'keyword->string "bad argument type - not a keyword" kw) ) ) ) )
    12271222
    1228 (define ##sys#get-keyword
    1229   (lambda (key args0 . default)
    1230     (##sys#check-list args0 'get-keyword)
    1231     (let ([a (memq key args0)])
    1232       (if a
    1233           (let ([r (##sys#slot a 1)])
    1234             (if (pair? r)
    1235                 (##sys#slot r 0)
    1236                 (##sys#error 'get-keyword "missing keyword argument" args0 key) ) )
    1237           (and (pair? default) ((car default))) ) ) ) )
     1223(define (##sys#get-keyword key args0 . default)
     1224  (##sys#check-list args0 'get-keyword)
     1225  (let ([a (memq key args0)])
     1226    (if a
     1227        (let ([r (##sys#slot a 1)])
     1228          (if (pair? r)
     1229              (##sys#slot r 0)
     1230              (##sys#error 'get-keyword "missing keyword argument" args0 key) ) )
     1231        (and (pair? default) ((car default))) ) ) )
    12381232
    12391233(define get-keyword ##sys#get-keyword)
     
    13261320    ))
    13271321
    1328 (define vector->list
    1329   (lambda (v)
    1330     (##sys#check-vector v 'vector->list)
    1331     (let ((len (##core#inline "C_block_size" v)))
    1332       (let loop ((i 0))
    1333         (if (fx>= i len)
    1334             '()
    1335             (cons (##sys#slot v i)
    1336                   (loop (fx+ i 1)) ) ) ) ) ) )
    1337 
    1338 (define vector
    1339   (lambda xs (##sys#list->vector xs)) )
     1322(define (vector->list v)
     1323  (##sys#check-vector v 'vector->list)
     1324  (let ((len (##core#inline "C_block_size" v)))
     1325    (let loop ((i 0))
     1326      (if (fx>= i len)
     1327          '()
     1328          (cons (##sys#slot v i)
     1329                (loop (fx+ i 1)) ) ) ) ) )
     1330
     1331(define (vector . xs)
     1332  (##sys#list->vector xs) )
    13401333
    13411334(define (vector-fill! v x)
     
    13461339      (##sys#setslot v i x) ) ) )
    13471340
    1348 (define vector-copy!
    1349   (lambda (from to . n)
    1350     (##sys#check-vector from 'vector-copy!)
    1351     (##sys#check-vector to 'vector-copy!)
    1352     (let* ([len-from (##sys#size from)]
    1353            [len-to (##sys#size to)]
    1354            [n (if (pair? n) (car n) (fxmin len-to len-from))] )
    1355       (##sys#check-exact n 'vector-copy!)
    1356       (cond-expand
    1357        [(not unsafe)
    1358         (when (or (fx> n len-to) (fx> n len-from))
    1359           (##sys#signal-hook
    1360            #:bounds-error 'vector-copy!
    1361            "can not copy vector - count exceeds length" from to n) ) ]
    1362        [else] )
    1363       (do ([i 0 (fx+ i 1)])
    1364           ((fx>= i n))
    1365         (##sys#setslot to i (##sys#slot from i)) ) ) ) )
     1341(define (vector-copy! from to . n)
     1342  (##sys#check-vector from 'vector-copy!)
     1343  (##sys#check-vector to 'vector-copy!)
     1344  (let* ([len-from (##sys#size from)]
     1345         [len-to (##sys#size to)]
     1346         [n (if (pair? n) (car n) (fxmin len-to len-from))] )
     1347    (##sys#check-exact n 'vector-copy!)
     1348    (cond-expand
     1349     [(not unsafe)
     1350      (when (or (fx> n len-to) (fx> n len-from))
     1351        (##sys#signal-hook
     1352         #:bounds-error 'vector-copy!
     1353         "can not copy vector - count exceeds length" from to n) ) ]
     1354     [else] )
     1355    (do ([i 0 (fx+ i 1)])
     1356        ((fx>= i n))
     1357      (##sys#setslot to i (##sys#slot from i)) ) ) )
    13661358
    13671359(define (vector-resize v n #!optional init)
     
    13701362  (##sys#grow-vector v n init) )
    13711363
    1372 (define ##sys#grow-vector
    1373   (lambda (v n init)
    1374     (let ([v2 (##sys#make-vector n init)]
    1375           [len (##sys#size v)] )
    1376       (do ([i 0 (fx+ i 1)])
    1377           ((fx>= i len) v2)
    1378         (##sys#setslot v2 i (##sys#slot v i)) ) ) ) )
     1364(define (##sys#grow-vector v n init)
     1365  (let ([v2 (##sys#make-vector n init)]
     1366        [len (##sys#size v)] )
     1367    (do ([i 0 (fx+ i 1)])
     1368        ((fx>= i len) v2)
     1369      (##sys#setslot v2 i (##sys#slot v i)) ) ) )
    13791370       
    13801371
     
    16141605(define ##sys#dynamic-winds '())
    16151606
    1616 (define dynamic-wind
    1617   (lambda (before thunk after)
    1618     (before)
    1619     (set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds))
    1620     (##sys#call-with-values
    1621      thunk
    1622      (lambda results
    1623        (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))
    1624        (after)
    1625        (apply ##sys#values results) ) ) ) )
     1607(define (dynamic-wind before thunk after)
     1608  (before)
     1609  (set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds))
     1610  (##sys#call-with-values
     1611   thunk
     1612   (lambda results
     1613     (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))
     1614     (after)
     1615     (apply ##sys#values results) ) ) )
    16261616
    16271617(define ##sys#dynamic-wind dynamic-wind)
    16281618
    1629 (define call-with-current-continuation
    1630   (lambda (proc)
    1631     (let ((winds ##sys#dynamic-winds))
    1632       (##sys#call-with-current-continuation
    1633        (lambda (cont)
    1634          (proc
    1635           (lambda results
    1636             (unless (eq? ##sys#dynamic-winds winds)
    1637               (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )
    1638             (apply cont results) ) ) ) ) ) ) )
     1619(define (call-with-current-continuation proc)
     1620  (let ((winds ##sys#dynamic-winds))
     1621    (##sys#call-with-current-continuation
     1622     (lambda (cont)
     1623       (proc
     1624        (lambda results
     1625          (unless (eq? ##sys#dynamic-winds winds)
     1626            (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )
     1627          (apply cont results) ) ) ) ) ) )
    16391628
    16401629(define call/cc call-with-current-continuation)
     
    16801669(define (port? x) (##core#inline "C_i_portp" x))
    16811670
     1671(define-inline (%port? x)
     1672  (and (##core#inline "C_blockp" x)
     1673       (##core#inline "C_portp" x)) )
     1674
    16821675(define (input-port? x)
    1683   (and (##core#inline "C_blockp" x)
    1684        (##core#inline "C_portp" x)
     1676  (and (%port? x)
    16851677       (##sys#slot x 1) ) )
    16861678
    16871679(define (output-port? x)
    1688   (and (##core#inline "C_blockp" x)
    1689        (##core#inline "C_portp" x)
     1680  (and (%port? x)
    16901681       (not (##sys#slot x 1)) ) )
    16911682
     
    17881779(##sys#open-file-port ##sys#standard-error 2 #f)
    17891780
    1790 (define ##sys#check-port
    1791   (lambda (x . loc)
    1792     (if (or (not (##core#inline "C_blockp" x))
    1793             (not (##core#inline "C_portp" x)) )
    1794         (##sys#signal-hook #:type-error (if (pair? loc) (car loc) #f) "argument is not a port" x) ) ) )
    1795 
    1796 (define ##sys#check-port-mode
    1797   (lambda (port mode . loc)
    1798     (unless (eq? mode (##sys#slot port 1))
    1799       (##sys#signal-hook
    1800        #:type-error (if (pair? loc) (car loc) #f)
    1801        (if mode "port is not an input port" "port is not an output-port") ) ) ) )
     1781(define (##sys#check-port x . loc)
     1782  (unless (%port? x)
     1783    (##sys#signal-hook #:type-error (and (pair? loc) (car loc)) "argument is not a port" x) ) )
     1784
     1785(define (##sys#check-port-mode port mode . loc)
     1786  (unless (eq? mode (##sys#slot port 1))
     1787    (##sys#signal-hook
     1788     #:type-error (and (pair? loc) (car loc))
     1789     (if mode "port is not an input port" "port is not an output-port") port) ) )
    18021790
    18031791(define (##sys#check-port* p loc)
     
    18051793  (when (##sys#slot p 8)
    18061794    (##sys#signal-hook #:file-error loc "port already closed" p) )
    1807   p)
     1795  p )
    18081796
    18091797(define (current-input-port . arg)
     
    19841972  (##sys#flush-output port) )
    19851973
    1986 (define port-name
    1987   (lambda (#!optional (port ##sys#standard-input))
    1988     (##sys#check-port port 'port-name)
    1989     (##sys#slot port 3) ) )
     1974(define (port-name #!optional (port ##sys#standard-input))
     1975  (##sys#check-port port 'port-name)
     1976  (##sys#slot port 3) )
    19901977
    19911978(define (set-port-name! port name)
     
    19981985       (##sys#slot port 4) ) )
    19991986
    2000 (define port-position
    2001   (lambda (#!optional (port ##sys#standard-input))
    2002     (##sys#check-port port 'port-position)
    2003     (if (##sys#slot port 1)
    2004         (##sys#values (##sys#slot port 4) (##sys#slot port 5))
    2005         (##sys#error 'port-position "can not compute position of port" port) ) ) )
    2006 
    2007 (define delete-file
    2008   (lambda (filename)
    2009     (##sys#check-string filename 'delete-file)
    2010     (##sys#pathname-resolution
    2011      filename
    2012      (lambda (filename)
    2013        (unless (eq? 0 (##core#inline "C_delete_file" (##sys#make-c-string filename)))
    2014          (##sys#update-errno)
    2015          (##sys#signal-hook #:file-error 'delete-file (##sys#string-append "can not delete file - " strerror) filename) ) )
    2016      #:delete) ) )
    2017 
    2018 (define rename-file
    2019   (lambda (old new)
    2020     (##sys#check-string old 'rename-file)
    2021     (##sys#check-string new 'rename-file)
    2022     (##sys#pathname-resolution
    2023      old
    2024      (lambda (old)
    2025        (##sys#pathname-resolution
    2026         new
    2027         (lambda (new)
    2028           (unless (eq? 0 (##core#inline "C_rename_file" (##sys#make-c-string old) (##sys#make-c-string new)))
    2029             (##sys#update-errno)
    2030             (##sys#signal-hook #:file-error 'rename-file (##sys#string-append "can not rename file - " strerror) old new) ) ) ) )
    2031      #:rename new) ) )
     1987(define (port-position #!optional (port ##sys#standard-input))
     1988  (##sys#check-port port 'port-position)
     1989  (if (##sys#slot port 1)
     1990      (##sys#values (##sys#slot port 4) (##sys#slot port 5))
     1991      (##sys#error 'port-position "can not compute position of port" port) ) )
     1992
     1993(define (delete-file filename)
     1994  (##sys#check-string filename 'delete-file)
     1995  (##sys#pathname-resolution
     1996   filename
     1997   (lambda (filename)
     1998     (unless (eq? 0 (##core#inline "C_delete_file" (##sys#make-c-string filename)))
     1999       (##sys#update-errno)
     2000       (##sys#signal-hook
     2001        #:file-error 'delete-file
     2002        (##sys#string-append "can not delete file - " strerror) filename) ) )
     2003   #:delete) )
     2004
     2005(define (rename-file old new)
     2006  (##sys#check-string old 'rename-file)
     2007  (##sys#check-string new 'rename-file)
     2008  (##sys#pathname-resolution
     2009   old
     2010   (lambda (old)
     2011     (##sys#pathname-resolution
     2012      new
     2013      (lambda (new)
     2014        (unless (eq? 0 (##core#inline "C_rename_file" (##sys#make-c-string old) (##sys#make-c-string new)))
     2015          (##sys#update-errno)
     2016          (##sys#signal-hook
     2017           #:file-error 'rename-file
     2018           (##sys#string-append "can not rename file - " strerror) old new) ) ) ) )
     2019   #:rename new) )
    20322020
    20332021
     
    26432631; - Don't forget to read 'char', it's only peeked at this point.
    26442632
    2645 (define ##sys#user-read-hook
    2646   (lambda (char port)
    2647     (case char
    2648       ;; I put it here, so the SRFI-4 unit can intercept '#f...'
    2649       ((#\f #\F) (##sys#read-char-0 port) #f)
    2650       ((#\t #\T) (##sys#read-char-0 port) #t)
    2651       (else (##sys#read-error port "invalid sharp-sign read syntax" char) ) ) ) )
     2633(define (##sys#user-read-hook char port)
     2634  (case char
     2635    ;; I put it here, so the SRFI-4 unit can intercept '#f...'
     2636    ((#\f #\F) (##sys#read-char-0 port) #f)
     2637    ((#\t #\T) (##sys#read-char-0 port) #t)
     2638    (else (##sys#read-error port "invalid sharp-sign read syntax" char) ) ) )
    26522639
    26532640
     
    31663153        (loop (##sys#scan-buffer-line buf lim pos bumper)) ) ) ) )
    31673154
    3168 (define open-input-string
    3169   (lambda (string)
    3170     (##sys#check-string string 'open-input-string)
    3171     (let ([port (##sys#make-port #t ##sys#string-port-class "(string)" 'string)])
    3172       (##sys#setislot port 11 (##core#inline "C_block_size" string))
    3173       (##sys#setislot port 10 0)
    3174       (##sys#setslot port 12 string)
    3175       port) ) )
    3176 
    3177 (define open-output-string
    3178   (lambda ()
    3179     (let ([port (##sys#make-port #f ##sys#string-port-class "(string)" 'string)])
    3180       (##sys#setislot port 10 0)
    3181       (##sys#setislot port 11 output-string-initial-size)
    3182       (##sys#setslot port 12 (##sys#make-string output-string-initial-size))
    3183       port) ) )
    3184 
    3185 (define get-output-string
    3186   (lambda (port)
    3187     (##sys#check-port port 'get-output-string)
    3188     (##sys#check-port-mode port #f 'get-output-string)
    3189     (if (not (eq? 'string (##sys#slot port 7)))
    3190         (##sys#signal-hook #:type-error 'get-output-string "argument is not a string-output-port" port)
    3191         (##sys#substring (##sys#slot port 12) 0 (##sys#slot port 10)) ) ) )
     3155(define (open-input-string string)
     3156  (##sys#check-string string 'open-input-string)
     3157  (let ([port (##sys#make-port #t ##sys#string-port-class "(string)" 'string)])
     3158    (##sys#setislot port 11 (##core#inline "C_block_size" string))
     3159    (##sys#setislot port 10 0)
     3160    (##sys#setslot port 12 string)
     3161    port ) )
     3162
     3163(define (open-output-string)
     3164  (let ([port (##sys#make-port #f ##sys#string-port-class "(string)" 'string)])
     3165    (##sys#setislot port 10 0)
     3166    (##sys#setislot port 11 output-string-initial-size)
     3167    (##sys#setslot port 12 (##sys#make-string output-string-initial-size))
     3168    port ) )
     3169
     3170(define (get-output-string port)
     3171  (##sys#check-port port 'get-output-string)
     3172  (##sys#check-port-mode port #f 'get-output-string)
     3173  (if (not (eq? 'string (##sys#slot port 7)))
     3174      (##sys#signal-hook
     3175       #:type-error 'get-output-string "argument is not a string-output-port" port)
     3176      (##sys#substring (##sys#slot port 12) 0 (##sys#slot port 10)) ) )
    31923177
    31933178(define ##sys#print-to-string
     
    33983383    (##sys#print "\t<--\n" #f port) ) )
    33993384
    3400 (define print-call-chain
    3401   (lambda (#!optional (port ##sys#standard-output) (start 0) (thread ##sys#current-thread)
    3402                       (header "\n\tCall history:\n") )
    3403     (##sys#check-port port 'print-call-chain)
    3404     (##sys#check-exact start 'print-call-chain)
    3405     (##sys#check-string header 'print-call-chain)
    3406     (##sys#really-print-call-chain port (##sys#get-call-chain start thread) header) ) )
     3385(define (print-call-chain #!optional (port ##sys#standard-output) (start 0)
     3386                                    (thread ##sys#current-thread)
     3387                                     (header "\n\tCall history:\n") )
     3388  (##sys#check-port port 'print-call-chain)
     3389  (##sys#check-exact start 'print-call-chain)
     3390  (##sys#check-string header 'print-call-chain)
     3391  (##sys#really-print-call-chain port (##sys#get-call-chain start thread) header) )
    34073392
    34083393(define get-call-chain ##sys#get-call-chain)
     
    36023587;;; Condition handling:
    36033588
    3604 (define ##sys#signal-hook
    3605   (lambda (mode msg . args)
    3606     (##core#inline "C_dbg_hook" #f)
    3607     (case mode
    3608       [(#:user-interrupt)
     3589(define (##sys#signal-hook mode msg . args)
     3590  (##core#inline "C_dbg_hook" #f)
     3591  (case mode
     3592    [(#:user-interrupt)
     3593     (##sys#abort
     3594      (##sys#make-structure
     3595       'condition
     3596       '(user-interrupt) ) ) ]
     3597    [(#:warning)
     3598     (##sys#print "Warning: " #f ##sys#standard-error)
     3599     (##sys#print msg #f ##sys#standard-error)
     3600     (if (or (null? args) (fx> (length args) 1))
     3601         (##sys#write-char-0 #\newline ##sys#standard-error)
     3602         (##sys#print ": " #f ##sys#standard-error))
     3603     (for-each
     3604      (lambda (x)
     3605        (##sys#print x #t ##sys#standard-error)
     3606        (##sys#write-char-0 #\newline ##sys#standard-error) )
     3607      args)
     3608     (##sys#flush-output ##sys#standard-error) ]
     3609    [else
     3610     (when (and (symbol? msg) (null? args))
     3611       (set! msg (##sys#symbol->string msg)) )
     3612     (let* ([hasloc (and (or (not msg) (symbol? msg)) (pair? args))]
     3613            [loc (and hasloc msg)]
     3614            [msg (if hasloc (##sys#slot args 0) msg)]
     3615            [args (if hasloc (##sys#slot args 1) args)] )
    36093616       (##sys#abort
    3610         (##sys#make-structure
    3611          'condition
    3612          '(user-interrupt) ) ) ]
    3613       [(#:warning)
    3614        (##sys#print "Warning: " #f ##sys#standard-error)
    3615        (##sys#print msg #f ##sys#standard-error)
    3616        (##sys#write-char-0 #\newline ##sys#standard-error)
    3617        (for-each
    3618         (lambda (x)
    3619           (##sys#print x #t ##sys#standard-error)
    3620           (##sys#write-char-0 #\newline ##sys#standard-error) )
    3621         args)
    3622        (##sys#flush-output ##sys#standard-error) ]
    3623       [else
    3624        (when (and (symbol? msg) (null? args))
    3625          (set! msg (##sys#symbol->string msg)) )
    3626        (let* ([hasloc (and (or (not msg) (symbol? msg)) (pair? args))]
    3627               [loc (and hasloc msg)]
    3628               [msg (if hasloc (##sys#slot args 0) msg)]
    3629               [args (if hasloc (##sys#slot args 1) args)] )
    3630          (##sys#abort
    3631           (##sys#make-structure
    3632            'condition
    3633            (case mode
    3634              [(#:type-error) '(exn type)]
    3635              [(#:syntax-error) '(exn syntax)]
    3636              [(#:match-error) '(exn match)]
    3637              [(#:bounds-error) '(exn bounds)]
    3638              [(#:arithmetic-error) '(exn arithmetic)]
    3639              [(#:file-error) '(exn i/o file)]
    3640              [(#:runtime-error) '(exn runtime)]
    3641              [(#:process-error) '(exn process)]
    3642              [(#:network-error) '(exn i/o net)]
    3643              [(#:limit-error) '(exn runtime limit)]
    3644              [(#:arity-error) '(exn arity)]
    3645              [(#:access-error) '(exn access)]
    3646              [(#:domain-error) '(exn domain)]
    3647              [else '(exn)] )
    3648            (list '(exn . message) msg
    3649                  '(exn . arguments) args
    3650                  '(exn . location) loc) ) ) ) ] ) ) )
     3617        (##sys#make-structure
     3618         'condition
     3619         (case mode
     3620           [(#:type-error)              '(exn type)]
     3621           [(#:syntax-error)            '(exn syntax)]
     3622           [(#:bounds-error)            '(exn bounds)]
     3623           [(#:arithmetic-error)        '(exn arithmetic)]
     3624           [(#:file-error)              '(exn i/o file)]
     3625           [(#:runtime-error)           '(exn runtime)]
     3626           [(#:process-error)           '(exn process)]
     3627           [(#:network-error)           '(exn i/o net)]
     3628           [(#:limit-error)             '(exn runtime limit)]
     3629           [(#:arity-error)             '(exn arity)]
     3630           [(#:access-error)            '(exn access)]
     3631           [(#:domain-error)            '(exn domain)]
     3632           [else                        '(exn)] )
     3633         (list '(exn . message) msg
     3634               '(exn . arguments) args
     3635               '(exn . location) loc) ) ) ) ] ) )
    36513636
    36523637(define (##sys#abort x)
     
    37283713         (cons (cons kind (car props)) (cons (cadr props) (loop (cddr props)))) ) ) ) )
    37293714
    3730 (define make-composite-condition
    3731   (lambda (c1 . conds)
    3732     (let ([conds (cons c1 conds)])
    3733       (for-each (lambda (c) (##sys#check-structure c 'condition 'make-composite-condition)) conds)
    3734       (##sys#make-structure
    3735        'condition
    3736        (apply ##sys#append (map (lambda (c) (##sys#slot c 1)) conds))
    3737        (apply ##sys#append (map (lambda (c) (##sys#slot c 2)) conds)) ) ) ) )
     3715(define (make-composite-condition c1 . conds)
     3716  (let ([conds (cons c1 conds)])
     3717    (for-each (lambda (c) (##sys#check-structure c 'condition 'make-composite-condition)) conds)
     3718    (##sys#make-structure
     3719     'condition
     3720     (apply ##sys#append (map (lambda (c) (##sys#slot c 1)) conds))
     3721     (apply ##sys#append (map (lambda (c) (##sys#slot c 2)) conds)) ) ) )
    37383722
    37393723(define (condition? x) (##sys#structure? x 'condition))
     
    37833767                (if fn (list fn) '()))))
    37843768        ((3) (apply ##sys#signal-hook #:type-error loc "bad argument type" args))
    3785         ((4) (apply ##sys#error loc "unbound variable" args))
     3769        ((4) (apply ##sys#signal-hook #:runtime-error loc "unbound variable" args))
    37863770        ((5) (apply ##sys#signal-hook #:limit-error loc "parameter limit exceeded" args))
    37873771        ((6) (apply ##sys#signal-hook #:limit-error loc "out of memory" args))
     
    37893773        ((8) (apply ##sys#signal-hook #:bounds-error loc "out of range" args))
    37903774        ((9) (apply ##sys#signal-hook #:type-error loc "call of non-procedure" args))
    3791         ((10) (apply ##sys#error loc "continuation can not receive multiple values" args))
     3775        ((10) (apply ##sys#signal-hook #:arity-error loc "continuation can not receive multiple values" args))
    37923776        ((12) (apply ##sys#signal-hook #:limit-error loc "recursion too deep" args))
    37933777        ((13) (apply ##sys#signal-hook #:type-error loc "inexact number can not be represented as an exact number" args))
     
    38053789        ((25) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a blob" args))
    38063790        ((26) (apply ##sys#signal-hook #:type-error loc "locative refers to reclaimed object" args))
    3807         ((27) (apply ##sys#signal-hook #:type-error loc "bad argument type - non-immediate value expected" args))
    3808         ((28) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a number-vector or not of the correct type" args))
     3791        ((27) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a non-immediate value" args))
     3792        ((28) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a number vector" args))
    38093793        ((29) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an integer" args))
    38103794        ((30) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an unsigned integer" args))
    38113795        ((31) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a pointer" args))
    3812         ((32) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a tagged pointer or not of the correct type" args))
     3796        ((32) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a tagged pointer" args))
    38133797        ((33) (apply ##sys#signal-hook #:runtime-error loc
    38143798                     "code to load dynamically was linked with safe runtime libraries, but executing runtime was not"
     
    38553839  (##core#inline_allocate ("C_a_unsigned_int_to_num" 4) (##sys#slot ptr 0)) )
    38563840
    3857 (define ##sys#make-c-string
    3858   (lambda (str)
    3859     (##sys#string-append str (string (##core#inline "C_make_character" (##core#inline "C_unfix" 0)))) ) )
     3841(define (##sys#make-c-string str)
     3842  (##sys#string-append
     3843   str
     3844   (string (##core#inline "C_make_character" (##core#inline "C_unfix" 0)))) )
    38603845
    38613846(define ##sys#peek-signed-integer (##core#primitive "C_peek_signed_integer"))
     
    38703855  (##sys#cons-flonum) )
    38713856
    3872 (define ##sys#peek-c-string
    3873     (lambda (b i)
    3874       (and (not (##sys#null-pointer? b))
    3875            (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
    3876                   [str2 (##sys#make-string len)] )
    3877              (##core#inline "C_peek_c_string" b i str2 len)
    3878              str2) ) ) )
    3879 
    3880 (define ##sys#peek-nonnull-c-string
    3881     (lambda (b i)
    3882       (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
    3883              [str2 (##sys#make-string len)] )
    3884         (##core#inline "C_peek_c_string" b i str2 len)
    3885         str2) ) )
    3886 
    3887 (define ##sys#peek-and-free-c-string
    3888     (lambda (b i)
    3889       (and (not (##sys#null-pointer? b))
    3890            (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
    3891                   [str2 (##sys#make-string len)] )
    3892              (##core#inline "C_peek_c_string" b i str2 len)
    3893              (##core#inline "C_free_mptr" b i)
    3894              str2) ) ) )
    3895 
    3896 (define ##sys#peek-and-free-nonnull-c-string
    3897     (lambda (b i)
    3898       (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
    3899              [str2 (##sys#make-string len)] )
    3900         (##core#inline "C_peek_c_string" b i str2 len)
    3901         (##core#inline "C_free_mptr" b i)
    3902         str2) ) )
     3857(define (##sys#peek-c-string b i)
     3858  (and (not (##sys#null-pointer? b))
     3859       (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
     3860              [str2 (##sys#make-string len)] )
     3861         (##core#inline "C_peek_c_string" b i str2 len)
     3862         str2 ) ) )
     3863
     3864(define (##sys#peek-nonnull-c-string b i)
     3865  (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
     3866         [str2 (##sys#make-string len)] )
     3867    (##core#inline "C_peek_c_string" b i str2 len)
     3868    str2 ) )
     3869
     3870(define (##sys#peek-and-free-c-string b i)
     3871  (and (not (##sys#null-pointer? b))
     3872       (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
     3873              [str2 (##sys#make-string len)] )
     3874         (##core#inline "C_peek_c_string" b i str2 len)
     3875         (##core#inline "C_free_mptr" b i)
     3876         str2 ) ) )
     3877
     3878(define (##sys#peek-and-free-nonnull-c-string b i)
     3879  (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
     3880         [str2 (##sys#make-string len)] )
     3881    (##core#inline "C_peek_c_string" b i str2 len)
     3882    (##core#inline "C_free_mptr" b i)
     3883    str2 ) )
    39033884
    39043885(define (##sys#poke-c-string b i s)
     
    43004281;;; Promises:
    43014282
    4302 (define ##sys#make-promise
    4303     (lambda (proc)
    4304       (let ([result-ready #f]
    4305             [results #f] )
    4306         (##sys#make-structure
    4307          'promise
    4308          (lambda ()
    4309            (if result-ready
    4310                (apply ##sys#values results)
    4311                (##sys#call-with-values
    4312                 proc
    4313                 (lambda xs
    4314                   (if result-ready
    4315                       (apply ##sys#values results)
    4316                       (begin
    4317                         (set! result-ready #t)
    4318                         (set! results xs)
    4319                         (apply ##sys#values results) ) ) ) ) ) ) ) ) ) )
     4283(define (##sys#make-promise proc)
     4284  (let ([result-ready #f]
     4285        [results #f] )
     4286    (##sys#make-structure
     4287     'promise
     4288     (lambda ()
     4289       (if result-ready
     4290           (apply ##sys#values results)
     4291           (##sys#call-with-values
     4292            proc
     4293            (lambda xs
     4294              (if result-ready
     4295                  (apply ##sys#values results)
     4296                  (begin
     4297                    (set! result-ready #t)
     4298                    (set! results xs)
     4299                    (apply ##sys#values results) ) ) ) ) ) ) ) ) )
    43204300
    43214301(define (promise? x)
  • chicken/branches/chicken-3/runtime.c

    r12958 r13127  
    14791479  switch(code) {
    14801480  case C_BAD_ARGUMENT_COUNT_ERROR:
    1481     msg = C_text("wrong number of arguments in function call");
     1481    msg = C_text("bad argument count");
    14821482    c = 3;
    14831483    break;
    14841484
    14851485  case C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR:
    1486     msg = C_text("too few arguments in function call");
     1486    msg = C_text("too few arguments");
    14871487    c = 3;
    14881488    break;
     
    15391539
    15401540  case C_NOT_A_PROPER_LIST_ERROR:
    1541     msg = C_text("argument is not a proper list");
     1541    msg = C_text("bad argument type - not a proper list");
    15421542    c = 1;
    15431543    break;
     
    16041604
    16051605  case C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR:
    1606     msg = C_text("bad argument type - immediate value expected");
     1606    msg = C_text("bad argument type - not a non-immediate value");
    16071607    c = 1;
    16081608    break;
    16091609
    16101610  case C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR:
    1611     msg = C_text("bad argument type - number vector expected");
     1611    msg = C_text("bad argument type - not a number vector");
    16121612    c = 2;
    16131613    break;
    16141614
    16151615  case C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR:
    1616     msg = C_text("bad argument type - integer expected");
     1616    msg = C_text("bad argument type - not an integer");
    16171617    c = 1;
    16181618    break;
    16191619
    16201620  case C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR:
    1621     msg = C_text("bad argument type - unsigned integer expected");
     1621    msg = C_text("bad argument type - not an unsigned integer");
    16221622    c = 1;
    16231623    break;
    16241624
    16251625  case C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR:
    1626     msg = C_text("bad argument type - pointer expected");
     1626    msg = C_text("bad argument type - not a pointer");
    16271627    c = 1;
    16281628    break;
    16291629
    16301630  case C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR:
    1631     msg = C_text("bad argument type - tagged pointer expected");
     1631    msg = C_text("bad argument type - not a tagged pointer");
    16321632    c = 2;
    16331633    break;
     
    16441644
    16451645  case C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR:
    1646     msg = C_text("bad argument type - floating-point number expected");
     1646    msg = C_text("bad argument type - not a flonum");
    16471647    c = 1;
    16481648    break;
    16491649
    16501650  case C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR:
    1651     msg = C_text("bad argument type - procedure expected");
     1651    msg = C_text("bad argument type - not a procedure");
    16521652    c = 1;
    16531653    break;
  • chicken/trunk/library.scm

    r13125 r13127  
    182182
    183183
    184 
    185184;;; System routines:
    186185
     
    264263  (##sys#cons-flonum) )
    265264
    266 (define (##sys#check-structure x y . z)
    267   (if (pair? z)
    268       (##core#inline "C_i_check_structure_2" x y (car z))
     265(define (##sys#check-structure x y . loc)
     266  (if (pair? loc)
     267      (##core#inline "C_i_check_structure_2" x y (car loc))
    269268      (##core#inline "C_i_check_structure" x y) ) )
    270269
    271 (define (##sys#check-blob x . y)
    272   (if (pair? y)
    273       (##core#inline "C_i_check_bytevector_2" x (car y))
     270(define (##sys#check-blob x . loc)
     271  (if (pair? loc)
     272      (##core#inline "C_i_check_bytevector_2" x (car loc))
    274273      (##core#inline "C_i_check_bytevector" x) ) )
    275274
    276275(define ##sys#check-byte-vector ##sys#check-blob)
    277276
    278 (define (##sys#check-pair x . y)
    279   (if (pair? y)
    280       (##core#inline "C_i_check_pair_2" x (car y))
     277(define (##sys#check-pair x . loc)
     278  (if (pair? loc)
     279      (##core#inline "C_i_check_pair_2" x (car loc))
    281280      (##core#inline "C_i_check_pair" x) ) )
    282281
    283 (define (##sys#check-list x . y)
    284   (if (pair? y)
    285       (##core#inline "C_i_check_list_2" x (car y))
     282(define (##sys#check-list x . loc)
     283  (if (pair? loc)
     284      (##core#inline "C_i_check_list_2" x (car loc))
    286285      (##core#inline "C_i_check_list" x) ) )
    287286
    288 (define (##sys#check-string x . y)
    289   (if (pair? y)
    290       (##core#inline "C_i_check_string_2" x (car y))
     287(define (##sys#check-string x . loc)
     288  (if (pair? loc)
     289      (##core#inline "C_i_check_string_2" x (car loc))
    291290      (##core#inline "C_i_check_string" x) ) )
    292291
    293 (define (##sys#check-number x . y)
    294   (if (pair? y)
    295       (##core#inline "C_i_check_number_2" x (car y))
     292(define (##sys#check-number x . loc)
     293  (if (pair? loc)
     294      (##core#inline "C_i_check_number_2" x (car loc))
    296295      (##core#inline "C_i_check_number" x) ) )
    297296
    298 (define (##sys#check-exact x . y)
    299   (if (pair? y)
    300       (##core#inline "C_i_check_exact_2" x (car y))
     297(define (##sys#check-exact x . loc)
     298  (if (pair? loc)
     299      (##core#inline "C_i_check_exact_2" x (car loc))
    301300      (##core#inline "C_i_check_exact" x) ) )
    302301
    303 (define (##sys#check-inexact x . y)
    304   (if (pair? y)
    305       (##core#inline "C_i_check_inexact_2" x (car y))
     302(define (##sys#check-inexact x . loc)
     303  (if (pair? loc)
     304      (##core#inline "C_i_check_inexact_2" x (car loc))
    306305      (##core#inline "C_i_check_inexact" x) ) )
    307306
    308 (define (##sys#check-symbol x . y)
    309   (if (pair? y)
    310       (##core#inline "C_i_check_symbol_2" x (car y))
     307(define (##sys#check-symbol x . loc)
     308  (if (pair? loc)
     309      (##core#inline "C_i_check_symbol_2" x (car loc))
    311310      (##core#inline "C_i_check_symbol" x) ) )
    312311
    313 (define (##sys#check-vector x . y)
    314   (if (pair? y)
    315       (##core#inline "C_i_check_vector_2" x (car y))
     312(define (##sys#check-vector x . loc)
     313  (if (pair? loc)
     314      (##core#inline "C_i_check_vector_2" x (car loc))
    316315      (##core#inline "C_i_check_vector" x) ) )
    317316
    318 (define (##sys#check-char x . y)
    319   (if (pair? y)
    320       (##core#inline "C_i_check_char_2" x (car y))
     317(define (##sys#check-char x . loc)
     318  (if (pair? loc)
     319      (##core#inline "C_i_check_char_2" x (car loc))
    321320      (##core#inline "C_i_check_char" x) ) )
    322321
    323 (define (##sys#check-integer x . y)
     322(define (##sys#check-integer x . loc)
    324323  (unless (##core#inline "C_i_integerp" x)
    325324    (##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)
     325                      (and (pair? loc) (car loc)) x) ) )
     326
     327(define (##sys#check-range i from to . loc)
    329328  (##sys#check-exact i loc)
    330329  (unless (and (fx<= from i) (fx< i to))
    331330    (##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)
     331                      (and (pair? loc) (car loc)) i from to) ) )
     332
     333(define (##sys#check-special ptr . loc)
    335334  (unless (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
    336     (##sys#signal-hook #:type-error (if (pair? y) (car y) #f) "bad argument type - not a pointer-like object" ptr) ) )
    337 
    338 (define (##sys#check-closure x . y)
    339   (if (pair? y)
    340       (##core#inline "C_i_check_closure_2" x (car y))
     335    (##sys#signal-hook #:type-error (and (pair? loc) (car loc)) "bad argument type - not a pointer-like object" ptr) ) )
     336
     337(define (##sys#check-closure x . loc)
     338  (if (pair? loc)
     339      (##core#inline "C_i_check_closure_2" x (car loc))
    341340      (##core#inline "C_i_check_closure" x) ) )
    342341
     
    364363(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
    365364
    366 ;; not available on all platforms and to be used with caution...
     365;; Dynamic Unload not available on all platforms and to be used with caution!
    367366(define (##sys#dunload name)
    368367  (and-let* ((r (##core#inline "C_dunload" (##sys#make-c-string name))))
     
    437436(define (##sys#not-a-proper-list-error arg . loc)
    438437  (##sys#error-hook (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int)
    439                     (if (pair? loc) (car loc) #f) arg) )
    440 
    441 (define append
    442   (lambda lsts
    443     (if (eq? lsts '())
    444         lsts
    445         (let loop ((lsts lsts))
    446           (if (eq? (##sys#slot lsts 1) '())
    447               (##sys#slot lsts 0)
    448               (let copy ((node (##sys#slot lsts 0)))
    449                 (cond-expand
    450                  [unsafe
    451                   (if (eq? node '())
    452                       (loop (##sys#slot lsts 1))
    453                       (cons (##sys#slot node 0) (copy (##sys#slot node 1))) ) ]
    454                  [else
    455                   (cond ((eq? node '()) (loop (##sys#slot lsts 1)))
    456                         ((pair? node)
    457                          (cons (##sys#slot node 0) (copy (##sys#slot node 1))) )
    458                         (else (##sys#not-a-proper-list-error (##sys#slot lsts 0) 'append)) ) ] ) ) ) ) ) ) )
    459 
    460 (define reverse
    461   (lambda (lst0)
    462     (let loop ((lst lst0) (rest '()))
    463       (cond-expand
    464        [unsafe
    465         (if (eq? lst '())
    466             rest
    467             (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest))  ) ]
     438                    (and (pair? loc) (car loc)) arg) )
     439
     440(define (append . lsts)
     441  (if (eq? lsts '())
     442      lsts
     443      (let loop ((lsts lsts))
     444        (if (eq? (##sys#slot lsts 1) '())
     445            (##sys#slot lsts 0)
     446            (let copy ((node (##sys#slot lsts 0)))
     447              (cond-expand
     448               [unsafe
     449                (if (eq? node '())
     450                    (loop (##sys#slot lsts 1))
     451                    (cons (##sys#slot node 0) (copy (##sys#slot node 1))) ) ]
     452               [else
     453                (cond ((eq? node '()) (loop (##sys#slot lsts 1)))
     454                      ((pair? node)
     455                       (cons (##sys#slot node 0) (copy (##sys#slot node 1))) )
     456                      (else (##sys#not-a-proper-list-error (##sys#slot lsts 0) 'append)) ) ] ) ) ) ) ) )
     457
     458(define (reverse lst0)
     459  (let loop ((lst lst0) (rest '()))
     460    (cond-expand
     461     [unsafe
     462      (if (eq? lst '())
     463          rest
     464          (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest))  ) ]
    468465       [else
    469466        (cond ((eq? lst '()) rest)
    470467              ((pair? lst)
    471468               (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) )
    472               (else (##sys#not-a-proper-list-error lst0 'reverse)) ) ] ) ) ) )
     469              (else (##sys#not-a-proper-list-error lst0 'reverse)) ) ] ) ) )
    473470
    474471(define (memq x lst) (##core#inline "C_i_memq" x lst))
     
    594591                 (##sys#size s) ) ] )
    595592    (cond-expand
    596       [unsafe (##sys#substring s start end)]
    597       [else
    598         (let ([len (##sys#size s)])
    599           (if (and (fx<= start end)
    600                    (fx>= start 0)
    601                    (fx<= end len) )
    602               (##sys#substring s start end)
    603               (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
    604                                 'substring start end) ) ) ] ) ) )
    605 
    606 (define ##sys#substring
    607   (lambda (s start end)
    608     (let ([s2 (##sys#make-string (fx- end start))])
    609       (##core#inline "C_substring_copy" s s2 start end 0)
    610       s2) ) )
     593     [unsafe (##sys#substring s start end)]
     594     [else
     595      (let ([len (##sys#size s)])
     596       (if (and (fx<= start end)
     597                (fx>= start 0)
     598                (fx<= end len) )
     599          (##sys#substring s start end)
     600          (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int) 'substring start end) ) ) ] ) ) )
     601
     602(define (##sys#substring s start end)
     603  (let ([s2 (##sys#make-string (fx- end start))])
     604    (##core#inline "C_substring_copy" s s2 start end 0)
     605    s2 ) )
    611606
    612607(define (string=? x y)
     
    708703    z) )
    709704
    710 (define string-append
    711   (lambda all
    712     (let ([snew #f])
    713       (let loop ([strs all] [n 0])
    714         (if (eq? strs '())
    715             (set! snew (##sys#make-string n))
    716             (let ([s (##sys#slot strs 0)])
    717               (##sys#check-string s 'string-append)
    718               (let ([len (##sys#size s)])
    719                 (loop (##sys#slot strs 1) (fx+ n len))
    720                 (##core#inline "C_substring_copy" s snew 0 len n) ) ) ) )
    721       snew) ) )
     705(define (string-append .  all)
     706  (let ([snew #f])
     707    (let loop ([strs all] [n 0])
     708      (if (eq? strs '())
     709          (set! snew (##sys#make-string n))
     710          (let ([s (##sys#slot strs 0)])
     711            (##sys#check-string s 'string-append)
     712            (let ([len (##sys#size s)])
     713              (loop (##sys#slot strs 1) (fx+ n len))
     714              (##core#inline "C_substring_copy" s snew 0 len n) ) ) ) )
     715    snew ) )
    722716
    723717(define string
     
    786780
    787781(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) )
     782  (unless (and (flonum? x) (flonum? y))
     783    (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x y) ) )
    790784
    791785(define (fp+ x y)
     
    810804    (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) ] ) )
    811805
     806(define (fp/ x y)
     807  (cond-expand
     808   [unsafe (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y)]
     809   [else
     810    (fp-check-flonums x y 'fp/)
     811    (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) ] ) )
     812
    812813(define (fp= x y)
    813814  (cond-expand
     
    865866    (fp-check-flonums x y 'fpmin)
    866867    (##core#inline "C_i_flonum_min" x y) ] ) )
    867 
    868 (define (fp/ x y)
    869   (cond-expand
    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) ] ) )
    874868
    875869(define * (##core#primitive "C_times"))
     
    12081202          (##sys#signal-hook #:type-error 'keyword->string "bad argument type - not a keyword" kw) ) ) ) )
    12091203
    1210 (define ##sys#get-keyword
    1211   (lambda (key args0 . default)
    1212     (##sys#check-list args0 'get-keyword)
    1213     (let ([a (memq key args0)])
    1214       (if a
    1215           (let ([r (##sys#slot a 1)])
    1216             (if (pair? r)
    1217                 (##sys#slot r 0)
    1218                 (##sys#error 'get-keyword "missing keyword argument" args0 key) ) )
    1219           (and (pair? default) ((car default))) ) ) ) )
     1204(define (##sys#get-keyword key args0 . default)
     1205  (##sys#check-list args0 'get-keyword)
     1206  (let ([a (memq key args0)])
     1207    (if a
     1208        (let ([r (##sys#slot a 1)])
     1209          (if (pair? r)
     1210              (##sys#slot r 0)
     1211              (##sys#error 'get-keyword "missing keyword argument" args0 key) ) )
     1212        (and (pair? default) ((car default))) ) ) )
    12201213
    12211214(define get-keyword ##sys#get-keyword)
     
    13081301    ))
    13091302
    1310 (define vector->list
    1311   (lambda (v)
    1312     (##sys#check-vector v 'vector->list)
    1313     (let ((len (##core#inline "C_block_size" v)))
    1314       (let loop ((i 0))
    1315         (if (fx>= i len)
    1316             '()
    1317             (cons (##sys#slot v i)
    1318                   (loop (fx+ i 1)) ) ) ) ) ) )
    1319 
    1320 (define vector
    1321   (lambda xs (##sys#list->vector xs)) )
     1303(define (vector->list v)
     1304  (##sys#check-vector v 'vector->list)
     1305  (let ((len (##core#inline "C_block_size" v)))
     1306    (let loop ((i 0))
     1307      (if (fx>= i len)
     1308          '()
     1309          (cons (##sys#slot v i)
     1310                (loop (fx+ i 1)) ) ) ) ) )
     1311
     1312(define (vector . xs)
     1313  (##sys#list->vector xs) )
    13221314
    13231315(define (vector-fill! v x)
     
    13281320      (##sys#setslot v i x) ) ) )
    13291321
    1330 (define vector-copy!
    1331   (lambda (from to . n)
    1332     (##sys#check-vector from 'vector-copy!)
    1333     (##sys#check-vector to 'vector-copy!)
    1334     (let* ([len-from (##sys#size from)]
    1335            [len-to (##sys#size to)]
    1336            [n (if (pair? n) (car n) (fxmin len-to len-from))] )
    1337       (##sys#check-exact n 'vector-copy!)
    1338       (cond-expand
    1339        [(not unsafe)
    1340         (when (or (fx> n len-to) (fx> n len-from))
    1341           (##sys#signal-hook
    1342            #:bounds-error 'vector-copy!
    1343            "can not copy vector - count exceeds length" from to n) ) ]
    1344        [else] )
    1345       (do ([i 0 (fx+ i 1)])
    1346           ((fx>= i n))
    1347         (##sys#setslot to i (##sys#slot from i)) ) ) ) )
     1322(define (vector-copy! from to . n)
     1323  (##sys#check-vector from 'vector-copy!)
     1324  (##sys#check-vector to 'vector-copy!)
     1325  (let* ([len-from (##sys#size from)]
     1326         [len-to (##sys#size to)]
     1327         [n (if (pair? n) (car n) (fxmin len-to len-from))] )
     1328    (##sys#check-exact n 'vector-copy!)
     1329    (cond-expand
     1330     [(not unsafe)
     1331      (when (or (fx> n len-to) (fx> n len-from))
     1332        (##sys#signal-hook
     1333         #:bounds-error 'vector-copy!
     1334         "can not copy vector - count exceeds length" from to n) ) ]
     1335     [else] )
     1336    (do ([i 0 (fx+ i 1)])
     1337        ((fx>= i n))
     1338      (##sys#setslot to i (##sys#slot from i)) ) ) )
    13481339
    13491340(define (vector-resize v n #!optional init)
     
    13521343  (##sys#grow-vector v n init) )
    13531344
    1354 (define ##sys#grow-vector
    1355   (lambda (v n init)
    1356     (let ([v2 (##sys#make-vector n init)]
    1357           [len (##sys#size v)] )
    1358       (do ([i 0 (fx+ i 1)])
    1359           ((fx>= i len) v2)
    1360         (##sys#setslot v2 i (##sys#slot v i)) ) ) ) )
     1345(define (##sys#grow-vector v n init)
     1346  (let ([v2 (##sys#make-vector n init)]
     1347        [len (##sys#size v)] )
     1348    (do ([i 0 (fx+ i 1)])
     1349        ((fx>= i len) v2)
     1350      (##sys#setslot v2 i (##sys#slot v i)) ) ) )
    13611351       
    13621352
     
    15961586(define ##sys#dynamic-winds '())
    15971587
    1598 (define dynamic-wind
    1599   (lambda (before thunk after)
    1600     (before)
    1601     (set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds))
    1602     (##sys#call-with-values
    1603      thunk
    1604      (lambda results
    1605        (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))
    1606        (after)
    1607        (apply ##sys#values results) ) ) ) )
     1588(define (dynamic-wind before thunk after)
     1589  (before)
     1590  (set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds))
     1591  (##sys#call-with-values
     1592   thunk
     1593   (lambda results
     1594     (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))
     1595     (after)
     1596     (apply ##sys#values results) ) ) )
    16081597
    16091598(define ##sys#dynamic-wind dynamic-wind)
    16101599
    1611 (define call-with-current-continuation
    1612   (lambda (proc)
    1613     (let ((winds ##sys#dynamic-winds))
    1614       (##sys#call-with-current-continuation
    1615        (lambda (cont)
    1616          (proc
    1617           (lambda results
    1618             (unless (eq? ##sys#dynamic-winds winds)
    1619               (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )
    1620             (apply cont results) ) ) ) ) ) ) )
     1600(define (call-with-current-continuation proc)
     1601  (let ((winds ##sys#dynamic-winds))
     1602    (##sys#call-with-current-continuation
     1603     (lambda (cont)
     1604       (proc
     1605        (lambda results
     1606          (unless (eq? ##sys#dynamic-winds winds)
     1607            (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )
     1608          (apply cont results) ) ) ) ) ) )
    16211609
    16221610(define call/cc call-with-current-continuation)
     
    16621650(define (port? x) (##core#inline "C_i_portp" x))
    16631651
     1652(define-inline (%port? x)
     1653  (and (##core#inline "C_blockp" x)
     1654       (##core#inline "C_portp" x)) )
     1655
    16641656(define (input-port? x)
    1665   (and (##core#inline "C_blockp" x)
    1666        (##core#inline "C_portp" x)
     1657  (and (%port? x)
    16671658       (##sys#slot x 1) ) )
    16681659
    16691660(define (output-port? x)
    1670   (and (##core#inline "C_blockp" x)
    1671        (##core#inline "C_portp" x)
     1661  (and (%port? x)
    16721662       (not (##sys#slot x 1)) ) )
    16731663
     
    17701760(##sys#open-file-port ##sys#standard-error 2 #f)
    17711761
    1772 (define ##sys#check-port
    1773   (lambda (x . loc)
    1774     (if (or (not (##core#inline "C_blockp" x))
    1775             (not (##core#inline "C_portp" x)) )
    1776         (##sys#signal-hook #:type-error (if (pair? loc) (car loc) #f) "argument is not a port" x) ) ) )
    1777 
    1778 (define ##sys#check-port-mode
    1779   (lambda (port mode . loc)
    1780     (unless (eq? mode (##sys#slot port 1))
    1781       (##sys#signal-hook
    1782        #:type-error (if (pair? loc) (car loc) #f)
    1783        (if mode "port is not an input port" "port is not an output-port") ) ) ) )
     1762(define (##sys#check-port x . loc)
     1763  (unless (%port? x)
     1764    (##sys#signal-hook #:type-error (and (pair? loc) (car loc)) "argument is not a port" x) ) )
     1765
     1766(define (##sys#check-port-mode port mode . loc)
     1767  (unless (eq? mode (##sys#slot port 1))
     1768    (##sys#signal-hook
     1769     #:type-error (and (pair? loc) (car loc))
     1770     (if mode "port is not an input port" "port is not an output-port") port) ) )
    17841771
    17851772(define (##sys#check-port* p loc)
     
    17871774  (when (##sys#slot p 8)
    17881775    (##sys#signal-hook #:file-error loc "port already closed" p) )
    1789   p)
     1776  p )
    17901777
    17911778(define (current-input-port . arg)
     
    19661953  (##sys#flush-output port) )
    19671954
    1968 (define port-name
    1969   (lambda (#!optional (port ##sys#standard-input))
    1970     (##sys#check-port port 'port-name)
    1971     (##sys#slot port 3) ) )
     1955(define (port-name #!optional (port ##sys#standard-input))
     1956  (##sys#check-port port 'port-name)
     1957  (##sys#slot port 3) )
    19721958
    19731959(define (set-port-name! port name)
     
    19801966       (##sys#slot port 4) ) )
    19811967
    1982 (define port-position
    1983   (lambda (#!optional (port ##sys#standard-input))
    1984     (##sys#check-port port 'port-position)
    1985     (if (##sys#slot port 1)
    1986         (##sys#values (##sys#slot port 4) (##sys#slot port 5))
    1987         (##sys#error 'port-position "can not compute position of port" port) ) ) )
    1988 
    1989 (define delete-file
    1990   (lambda (filename)
    1991     (##sys#check-string filename 'delete-file)
    1992     (##sys#pathname-resolution
    1993      filename
    1994      (lambda (filename)
    1995        (unless (eq? 0 (##core#inline "C_delete_file" (##sys#make-c-string filename)))
    1996          (##sys#update-errno)
    1997          (##sys#signal-hook #:file-error 'delete-file (##sys#string-append "can not delete file - " strerror) filename) ) )
    1998      #:delete) ) )
    1999 
    2000 (define rename-file
    2001   (lambda (old new)
    2002     (##sys#check-string old 'rename-file)
    2003     (##sys#check-string new 'rename-file)
    2004     (##sys#pathname-resolution
    2005      old
    2006      (lambda (old)
    2007        (##sys#pathname-resolution
    2008         new
    2009         (lambda (new)
    2010           (unless (eq? 0 (##core#inline "C_rename_file" (##sys#make-c-string old) (##sys#make-c-string new)))
    2011             (##sys#update-errno)
    2012             (##sys#signal-hook #:file-error 'rename-file (##sys#string-append "can not rename file - " strerror) old new) ) ) ) )
    2013      #:rename new) ) )
     1968(define (port-position #!optional (port ##sys#standard-input))
     1969  (##sys#check-port port 'port-position)
     1970  (if (##sys#slot port 1)
     1971      (##sys#values (##sys#slot port 4) (##sys#slot port 5))
     1972      (##sys#error 'port-position "can not compute position of port" port) ) )
     1973
     1974(define (delete-file filename)
     1975  (##sys#check-string filename 'delete-file)
     1976  (##sys#pathname-resolution
     1977   filename
     1978   (lambda (filename)
     1979     (unless (eq? 0 (##core#inline "C_delete_file" (##sys#make-c-string filename)))
     1980       (##sys#update-errno)
     1981       (##sys#signal-hook
     1982        #:file-error 'delete-file
     1983        (##sys#string-append "can not delete file - " strerror) filename) ) )
     1984   #:delete) )
     1985
     1986(define (rename-file old new)
     1987  (##sys#check-string old 'rename-file)
     1988  (##sys#check-string new 'rename-file)
     1989  (##sys#pathname-resolution
     1990   old
     1991   (lambda (old)
     1992     (##sys#pathname-resolution
     1993      new
     1994      (lambda (new)
     1995        (unless (eq? 0 (##core#inline "C_rename_file" (##sys#make-c-string old) (##sys#make-c-string new)))
     1996          (##sys#update-errno)
     1997          (##sys#signal-hook
     1998           #:file-error 'rename-file
     1999           (##sys#string-append "can not rename file - " strerror) old new) ) ) ) )
     2000   #:rename new) )
    20142001
    20152002
     
    26252612; - Don't forget to read 'char', it's only peeked at this point.
    26262613
    2627 (define ##sys#user-read-hook
    2628   (lambda (char port)
    2629     (case char
    2630       ;; I put it here, so the SRFI-4 unit can intercept '#f...'
    2631       ((#\f #\F) (##sys#read-char-0 port) #f)
    2632       ((#\t #\T) (##sys#read-char-0 port) #t)
    2633       (else (##sys#read-error port "invalid sharp-sign read syntax" char) ) ) ) )
     2614(define (##sys#user-read-hook char port)
     2615  (case char
     2616    ;; I put it here, so the SRFI-4 unit can intercept '#f...'
     2617    ((#\f #\F) (##sys#read-char-0 port) #f)
     2618    ((#\t #\T) (##sys#read-char-0 port) #t)
     2619    (else (##sys#read-error port "invalid sharp-sign read syntax" char) ) ) )
    26342620
    26352621
     
    31483134        (loop (##sys#scan-buffer-line buf lim pos bumper)) ) ) ) )
    31493135
    3150 (define open-input-string
    3151   (lambda (string)
    3152     (##sys#check-string string 'open-input-string)
    3153     (let ([port (##sys#make-port #t ##sys#string-port-class "(string)" 'string)])
    3154       (##sys#setislot port 11 (##core#inline "C_block_size" string))
    3155       (##sys#setislot port 10 0)
    3156       (##sys#setslot port 12 string)
    3157       port) ) )
    3158 
    3159 (define open-output-string
    3160   (lambda ()
    3161     (let ([port (##sys#make-port #f ##sys#string-port-class "(string)" 'string)])
    3162       (##sys#setislot port 10 0)
    3163       (##sys#setislot port 11 output-string-initial-size)
    3164       (##sys#setslot port 12 (##sys#make-string output-string-initial-size))
    3165       port) ) )
    3166 
    3167 (define get-output-string
    3168   (lambda (port)
    3169     (##sys#check-port port 'get-output-string)
    3170     (##sys#check-port-mode port #f 'get-output-string)
    3171     (if (not (eq? 'string (##sys#slot port 7)))
    3172         (##sys#signal-hook #:type-error 'get-output-string "argument is not a string-output-port" port)
    3173         (##sys#substring (##sys#slot port 12) 0 (##sys#slot port 10)) ) ) )
     3136(define (open-input-string string)
     3137  (##sys#check-string string 'open-input-string)
     3138  (let ([port (##sys#make-port #t ##sys#string-port-class "(string)" 'string)])
     3139    (##sys#setislot port 11 (##core#inline "C_block_size" string))
     3140    (##sys#setislot port 10 0)
     3141    (##sys#setslot port 12 string)
     3142    port ) )
     3143
     3144(define (open-output-string)
     3145  (let ([port (##sys#make-port #f ##sys#string-port-class "(string)" 'string)])
     3146    (##sys#setislot port 10 0)
     3147    (##sys#setislot port 11 output-string-initial-size)
     3148    (##sys#setslot port 12 (##sys#make-string output-string-initial-size))
     3149    port ) )
     3150
     3151(define (get-output-string port)
     3152  (##sys#check-port port 'get-output-string)
     3153  (##sys#check-port-mode port #f 'get-output-string)
     3154  (if (not (eq? 'string (##sys#slot port 7)))
     3155      (##sys#signal-hook
     3156       #:type-error 'get-output-string "argument is not a string-output-port" port)
     3157      (##sys#substring (##sys#slot port 12) 0 (##sys#slot port 10)) ) )
    31743158
    31753159(define ##sys#print-to-string
     
    33803364    (##sys#print "\t<--\n" #f port) ) )
    33813365
    3382 (define print-call-chain
    3383   (lambda (#!optional (port ##sys#standard-output) (start 0) (thread ##sys#current-thread)
    3384                       (header "\n\tCall history:\n") )
    3385     (##sys#check-port port 'print-call-chain)
    3386     (##sys#check-exact start 'print-call-chain)
    3387     (##sys#check-string header 'print-call-chain)
    3388     (##sys#really-print-call-chain port (##sys#get-call-chain start thread) header) ) )
     3366(define (print-call-chain #!optional (port ##sys#standard-output) (start 0)
     3367                                    (thread ##sys#current-thread)
     3368                                     (header "\n\tCall history:\n") )
     3369  (##sys#check-port port 'print-call-chain)
     3370  (##sys#check-exact start 'print-call-chain)
     3371  (##sys#check-string header 'print-call-chain)
     3372  (##sys#really-print-call-chain port (##sys#get-call-chain start thread) header) )
    33893373
    33903374(define get-call-chain ##sys#get-call-chain)
     
    35843568;;; Condition handling:
    35853569
    3586 (define ##sys#signal-hook
    3587   (lambda (mode msg . args)
    3588     (##core#inline "C_dbg_hook" #f)
    3589     (case mode
    3590       [(#:user-interrupt)
     3570(define (##sys#signal-hook mode msg . args)
     3571  (##core#inline "C_dbg_hook" #f)
     3572  (case mode
     3573    [(#:user-interrupt)
     3574     (##sys#abort
     3575      (##sys#make-structure
     3576       'condition
     3577       '(user-interrupt) ) ) ]
     3578    [(#:warning)
     3579     (##sys#print "Warning: " #f ##sys#standard-error)
     3580     (##sys#print msg #f ##sys#standard-error)
     3581     (if (or (null? args) (fx> (length args) 1))
     3582         (##sys#write-char-0 #\newline ##sys#standard-error)
     3583         (##sys#print ": " #f ##sys#standard-error))
     3584     (for-each
     3585      (lambda (x)
     3586        (##sys#print x #t ##sys#standard-error)
     3587        (##sys#write-char-0 #\newline ##sys#standard-error) )
     3588      args)
     3589     (##sys#flush-output ##sys#standard-error) ]
     3590    [else
     3591     (when (and (symbol? msg) (null? args))
     3592       (set! msg (##sys#symbol->string msg)) )
     3593     (let* ([hasloc (and (or (not msg) (symbol? msg)) (pair? args))]
     3594            [loc (and hasloc msg)]
     3595            [msg (if hasloc (##sys#slot args 0) msg)]
     3596            [args (if hasloc (##sys#slot args 1) args)] )
    35913597       (##sys#abort
    35923598        (##sys#make-structure
    3593          'condition
    3594          '(user-interrupt) ) ) ]
    3595       [(#:warning)
    3596        (##sys#print "Warning: " #f ##sys#standard-error)
    3597        (##sys#print msg #f ##sys#standard-error)
    3598        (if (or (null? args) (fx> (length args) 1))
    3599            (##sys#write-char-0 #\newline ##sys#standard-error)
    3600            (##sys#print ": " #f ##sys#standard-error))
    3601        (for-each
    3602         (lambda (x)
    3603           (##sys#print x #t ##sys#standard-error)
    3604           (##sys#write-char-0 #\newline ##sys#standard-error) )
    3605         args)
    3606        (##sys#flush-output ##sys#standard-error) ]
    3607       [else
    3608        (when (and (symbol? msg) (null? args))
    3609          (set! msg (##sys#symbol->string msg)) )
    3610        (let* ([hasloc (and (or (not msg) (symbol? msg)) (pair? args))]
    3611               [loc (and hasloc msg)]
    3612               [msg (if hasloc (##sys#slot args 0) msg)]
    3613               [args (if hasloc (##sys#slot args 1) args)] )
    3614          (##sys#abort
    3615           (##sys#make-structure
    3616            'condition
    3617            (case mode
    3618              [(#:type-error) '(exn type)]
    3619              [(#:syntax-error) '(exn syntax)]
    3620              [(#:bounds-error) '(exn bounds)]
    3621              [(#:arithmetic-error) '(exn arithmetic)]
    3622              [(#:file-error) '(exn i/o file)]
    3623              [(#:runtime-error) '(exn runtime)]
    3624              [(#:process-error) '(exn process)]
    3625              [(#:network-error) '(exn i/o net)]
    3626              [(#:limit-error) '(exn runtime limit)]
    3627              [(#:arity-error) '(exn arity)]
    3628              [(#:access-error) '(exn access)]
    3629              [(#:domain-error) '(exn domain)]
    3630              [else '(exn)] )
    3631            (list '(exn . message) msg
    3632                  '(exn . arguments) args
    3633                  '(exn . location) loc) ) ) ) ] ) ) )
     3599         'condition
     3600         (case mode
     3601           [(#:type-error)              '(exn type)]
     3602           [(#:syntax-error)            '(exn syntax)]
     3603           [(#:bounds-error)            '(exn bounds)]
     3604           [(#:arithmetic-error)        '(exn arithmetic)]
     3605           [(#:file-error)              '(exn i/o file)]
     3606           [(#:runtime-error)           '(exn runtime)]
     3607           [(#:process-error)           '(exn process)]
     3608           [(#:network-error)           '(exn i/o net)]
     3609           [(#:limit-error)             '(exn runtime limit)]
     3610           [(#:arity-error)             '(exn arity)]
     3611           [(#:access-error)            '(exn access)]
     3612           [(#:domain-error)            '(exn domain)]
     3613           [else                        '(exn)] )
     3614         (list '(exn . message) msg
     3615               '(exn . arguments) args
     3616               '(exn . location) loc) ) ) ) ] ) )
    36343617
    36353618(define (##sys#abort x)
     
    37113694         (cons (cons kind (car props)) (cons (cadr props) (loop (cddr props)))) ) ) ) )
    37123695
    3713 (define make-composite-condition
    3714   (lambda (c1 . conds)
    3715     (let ([conds (cons c1 conds)])
    3716       (for-each (lambda (c) (##sys#check-structure c 'condition 'make-composite-condition)) conds)
    3717       (##sys#make-structure
    3718        'condition
    3719        (apply ##sys#append (map (lambda (c) (##sys#slot c 1)) conds))
    3720        (apply ##sys#append (map (lambda (c) (##sys#slot c 2)) conds)) ) ) ) )
     3696(define (make-composite-condition c1 . conds)
     3697  (let ([conds (cons c1 conds)])
     3698    (for-each (lambda (c) (##sys#check-structure c 'condition 'make-composite-condition)) conds)
     3699    (##sys#make-structure
     3700     'condition
     3701     (apply ##sys#append (map (lambda (c) (##sys#slot c 1)) conds))
     3702     (apply ##sys#append (map (lambda (c) (##sys#slot c 2)) conds)) ) ) )
    37213703
    37223704(define (condition? x) (##sys#structure? x 'condition))
     
    37663748                (if fn (list fn) '()))))
    37673749        ((3) (apply ##sys#signal-hook #:type-error loc "bad argument type" args))
    3768         ((4) (apply ##sys#error loc "unbound variable" args))
     3750        ((4) (apply ##sys#signal-hook #:runtime-error loc "unbound variable" args))
    37693751        ((5) (apply ##sys#signal-hook #:limit-error loc "parameter limit exceeded" args))
    37703752        ((6) (apply ##sys#signal-hook #:limit-error loc "out of memory" args))
     
    37723754        ((8) (apply ##sys#signal-hook #:bounds-error loc "out of range" args))
    37733755        ((9) (apply ##sys#signal-hook #:type-error loc "call of non-procedure" args))
    3774         ((10) (apply ##sys#error loc "continuation can not receive multiple values" args))
    3775         ((11) (apply ##sys#error loc "argument is cyclic" args))
     3756        ((10) (apply ##sys#signal-hook #:arity-error loc "continuation can not receive multiple values" args))
     3757        ((11) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a non-cyclic list" args))
    37763758        ((12) (apply ##sys#signal-hook #:limit-error loc "recursion too deep" args))
    37773759        ((13) (apply ##sys#signal-hook #:type-error loc "inexact number can not be represented as an exact number" args))
     
    37893771        ((25) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a blob" args))
    37903772        ((26) (apply ##sys#signal-hook #:type-error loc "locative refers to reclaimed object" args))
    3791         ((27) (apply ##sys#signal-hook #:type-error loc "bad argument type - non-immediate value expected" args))
    3792         ((28) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a number-vector or not of the correct type" args))
     3773        ((27) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a non-immediate value" args))
     3774        ((28) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a number vector" args))
    37933775        ((29) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an integer" args))
    37943776        ((30) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an unsigned integer" args))
    37953777        ((31) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a pointer" args))
    3796         ((32) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a tagged pointer or not of the correct type" args))
     3778        ((32) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a tagged pointer" args))
    37973779        ((33) (apply ##sys#signal-hook #:runtime-error loc
    37983780                     "code to load dynamically was linked with safe runtime libraries, but executing runtime was not"
     
    38393821  (##core#inline_allocate ("C_a_unsigned_int_to_num" 4) (##sys#slot ptr 0)) )
    38403822
    3841 (define ##sys#make-c-string
    3842   (lambda (str)
    3843     (##sys#string-append str (string (##core#inline "C_make_character" (##core#inline "C_unfix" 0)))) ) )
     3823(define (##sys#make-c-string str)
     3824  (##sys#string-append
     3825   str
     3826   (string (##core#inline "C_make_character" (##core#inline "C_unfix" 0)))) )
    38443827
    38453828(define ##sys#peek-signed-integer (##core#primitive "C_peek_signed_integer"))
     
    38543837  (##sys#cons-flonum) )
    38553838
    3856 (define ##sys#peek-c-string
    3857     (lambda (b i)
    3858       (and (not (##sys#null-pointer? b))
    3859            (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
    3860                   [str2 (##sys#make-string len)] )
    3861              (##core#inline "C_peek_c_string" b i str2 len)
    3862              str2) ) ) )
    3863 
    3864 (define ##sys#peek-nonnull-c-string
    3865     (lambda (b i)
    3866       (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
    3867              [str2 (##sys#make-string len)] )
    3868         (##core#inline "C_peek_c_string" b i str2 len)
    3869         str2) ) )
    3870 
    3871 (define ##sys#peek-and-free-c-string
    3872     (lambda (b i)
    3873       (and (not (##sys#null-pointer? b))
    3874            (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
    3875                   [str2 (##sys#make-string len)] )
    3876              (##core#inline "C_peek_c_string" b i str2 len)
    3877              (##core#inline "C_free_mptr" b i)
    3878              str2) ) ) )
    3879 
    3880 (define ##sys#peek-and-free-nonnull-c-string
    3881     (lambda (b i)
    3882       (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
    3883              [str2 (##sys#make-string len)] )
    3884         (##core#inline "C_peek_c_string" b i str2 len)
    3885         (##core#inline "C_free_mptr" b i)
    3886         str2) ) )
     3839(define (##sys#peek-c-string b i)
     3840  (and (not (##sys#null-pointer? b))
     3841       (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
     3842              [str2 (##sys#make-string len)] )
     3843         (##core#inline "C_peek_c_string" b i str2 len)
     3844         str2 ) ) )
     3845
     3846(define (##sys#peek-nonnull-c-string b i)
     3847  (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
     3848         [str2 (##sys#make-string len)] )
     3849    (##core#inline "C_peek_c_string" b i str2 len)
     3850    str2 ) )
     3851
     3852(define (##sys#peek-and-free-c-string b i)
     3853  (and (not (##sys#null-pointer? b))
     3854       (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
     3855              [str2 (##sys#make-string len)] )
     3856         (##core#inline "C_peek_c_string" b i str2 len)
     3857         (##core#inline "C_free_mptr" b i)
     3858         str2 ) ) )
     3859
     3860(define (##sys#peek-and-free-nonnull-c-string b i)
     3861  (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
     3862         [str2 (##sys#make-string len)] )
     3863    (##core#inline "C_peek_c_string" b i str2 len)
     3864    (##core#inline "C_free_mptr" b i)
     3865    str2 ) )
    38873866
    38883867(define (##sys#poke-c-string b i s)
     
    43014280;;; Promises:
    43024281
    4303 (define ##sys#make-promise
    4304     (lambda (proc)
    4305       (let ([result-ready #f]
    4306             [results #f] )
    4307         (##sys#make-structure
    4308          'promise
    4309          (lambda ()
    4310            (if result-ready
    4311                (apply ##sys#values results)
    4312                (##sys#call-with-values
    4313                 proc
    4314                 (lambda xs
    4315                   (if result-ready
    4316                       (apply ##sys#values results)
    4317                       (begin
    4318                         (set! result-ready #t)
    4319                         (set! results xs)
    4320                         (apply ##sys#values results) ) ) ) ) ) ) ) ) ) )
     4282(define (##sys#make-promise proc)
     4283  (let ([result-ready #f]
     4284        [results #f] )
     4285    (##sys#make-structure
     4286     'promise
     4287     (lambda ()
     4288       (if result-ready
     4289           (apply ##sys#values results)
     4290           (##sys#call-with-values
     4291            proc
     4292            (lambda xs
     4293              (if result-ready
     4294                  (apply ##sys#values results)
     4295                  (begin
     4296                    (set! result-ready #t)
     4297                    (set! results xs)
     4298                    (apply ##sys#values results) ) ) ) ) ) ) ) ) )
    43214299
    43224300(define (promise? x)
  • chicken/trunk/runtime.c

    r13018 r13127  
    14221422  switch(code) {
    14231423  case C_BAD_ARGUMENT_COUNT_ERROR:
    1424     msg = C_text("wrong number of arguments in function call");
     1424    msg = C_text("bad argument count");
    14251425    c = 3;
    14261426    break;
    14271427
    14281428  case C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR:
    1429     msg = C_text("too few arguments in function call");
     1429    msg = C_text("too few arguments");
    14301430    c = 3;
    14311431    break;
     
    14721472
    14731473  case C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR:
    1474     msg = C_text("argument is cyclic");
     1474    msg = C_text("bad argument type - not a non-cyclic list");
    14751475    c = 1;
    14761476    break;
     
    14871487
    14881488  case C_NOT_A_PROPER_LIST_ERROR:
    1489     msg = C_text("argument is not a proper list");
     1489    msg = C_text("bad argument type - not a proper list");
    14901490    c = 1;
    14911491    break;
     
    15521552
    15531553  case C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR:
    1554     msg = C_text("bad argument type - immediate value expected");
     1554    msg = C_text("bad argument type - not a non-immediate value");
    15551555    c = 1;
    15561556    break;
    15571557
    15581558  case C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR:
    1559     msg = C_text("bad argument type - number vector expected");
     1559    msg = C_text("bad argument type - not a number vector");
    15601560    c = 2;
    15611561    break;
    15621562
    15631563  case C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR:
    1564     msg = C_text("bad argument type - integer expected");
     1564    msg = C_text("bad argument type - not an integer");
    15651565    c = 1;
    15661566    break;
    15671567
    15681568  case C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR:
    1569     msg = C_text("bad argument type - unsigned integer expected");
     1569    msg = C_text("bad argument type - not an unsigned integer");
    15701570    c = 1;
    15711571    break;
    15721572
    15731573  case C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR:
    1574     msg = C_text("bad argument type - pointer expected");
     1574    msg = C_text("bad argument type - not a pointer");
    15751575    c = 1;
    15761576    break;
    15771577
    15781578  case C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR:
    1579     msg = C_text("bad argument type - tagged pointer expected");
     1579    msg = C_text("bad argument type - not a tagged pointer");
    15801580    c = 2;
    15811581    break;
     
    15921592
    15931593  case C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR:
    1594     msg = C_text("bad argument type - floating-point number expected");
     1594    msg = C_text("bad argument type - not a flonum");
    15951595    c = 1;
    15961596    break;
    15971597
    15981598  case C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR:
    1599     msg = C_text("bad argument type - procedure expected");
     1599    msg = C_text("bad argument type - not a procedure");
    16001600    c = 1;
    16011601    break;
Note: See TracChangeset for help on using the changeset viewer.