Changeset 4340 in project


Ignore:
Timestamp:
05/28/07 16:01:34 (13 years ago)
Author:
felix winkelmann
Message:

fp updates

Files:
2 added
24 edited

Legend:

Unmodified
Added
Removed
  • chicken/README

    r4232 r4340  
    33  (c)2000-2007 Felix L. Winkelmann
    44
    5   Version 2.615
     5  Version 2.619
    66
    77
  • chicken/build.scm

    r4232 r4340  
    1 (define-constant +build-version+ "2.615")
     1(define-constant +build-version+ "2.619")
  • chicken/buildversion

    r4232 r4340  
    1 2.615
     12.619
  • chicken/c-backend.scm

    r3839 r4340  
    3636(declare (unit backend))
    3737
    38 
    39 ;; The unspeakable namespace hack
    4038
    4139#{compiler
     
    568566                   [else
    569567                    (gen #\))
    570                                         ;(when customizable (gen " C_c_regparm"))
     568                    ;;(when customizable (gen " C_c_regparm"))
    571569                    (unless direct (gen " C_noret"))
    572570                    (gen #\;) ] ) ) )
     
    998996
    999997
    1000 ;;; Emit prrocedure table:
     998;;; Emit procedure table:
    1001999
    10021000(define (emit-procedure-table-info lambdas sf)
     
    10941092       (when rname
    10951093         (gen #t "/* from " (cleanup rname) " */") )
    1096        (when body (gen #t "#define return(x) C_cblock C_r = (" rconv "(x))); goto C_return; C_cblockend"))
     1094       (when body
     1095         (gen #t "#define return(x) C_cblock C_r = (" rconv
     1096              "(x))); goto C_ret; C_cblockend"))
    10971097       (if cps
    10981098           (gen #t "C_noret_decl(" id ")"
     
    11151115               (foreign-argument-conversion type) "C_a" index ");") )
    11161116        types (iota n) names)
    1117        (when callback (gen #t "int C_dummy=C_save_callback_continuation(&C_a,C_k);"))
     1117       (when callback (gen #t "int C_level=C_save_callback_continuation(&C_a,C_k);"))
    11181118       (cond [body
    11191119              (gen #t body
    1120                    #t "C_return:")
     1120                   #t "C_ret:")
    11211121              (gen #t "#undef return" #t)
    11221122              (cond [callback
    1123                      (gen #t "C_k=C_restore_callback_continuation();"
     1123                     (gen #t "C_k=C_restore_callback_continuation2(C_level);"
    11241124                          #t "C_kontinue(C_k,C_r);") ]
    11251125                    [cps (gen #t "C_kontinue(C_k,C_r);")]
     
    11341134              (gen ");")
    11351135              (cond [callback
    1136                      (gen #t "C_k=C_restore_callback_continuation();"
     1136                     (gen #t "C_k=C_restore_callback_continuation2(level);"
    11371137                          #t "C_kontinue(C_k,C_r);") ]
    11381138                    [cps (gen "C_kontinue(C_k,C_r);")]
     
    12371237       (str "void *")]
    12381238      [(c-string-list c-string-list*) "C_char **"]
    1239       [(byte-vector nonnull-byte-vector u8vector nonnull-u8vector) (str "unsigned char *")]
     1239      [(byte-vector) (str "unsigned char *")] ; DEPRECATED
     1240      [(blob nonnull-byte-vector u8vector nonnull-u8vector) (str "unsigned char *")]
    12401241      [(u16vector nonnull-u16vector) (str "unsigned short *")]
    12411242      [(s8vector nonnull-s8vector) (str "char *")]
     
    13141315      ((c-pointer) "C_c_pointer_or_null(")
    13151316      ((nonnull-c-pointer) "C_c_pointer_nn(")
    1316       ((byte-vector) "C_c_bytevector_or_null(")
    1317       ((nonnull-byte-vector) "C_c_bytevector(")
     1317      ((blob) "C_c_bytevector_or_null(")
     1318      ((byte-vector) "C_c_bytevector_or_null(") ; DEPRECATED
     1319      ((nonnull-blob) "C_c_bytevector(")
     1320      ((nonnull-byte-vector) "C_c_bytevector(") ; DEPRECATED
    13181321      ((u8vector) "C_c_u8vector_or_null(")
    13191322      ((nonnull-u8vector) "C_c_u8vector(")
  • chicken/c-platform.scm

    r3839 r4340  
    166166    arithmetic-shift void flush-output thread-specific thread-specific-set!
    167167    not-pair? atom? null-list? print print* error cpu-time proper-list? call/cc
    168     u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector
    169     u32vector->byte-vector
    170     s32vector->byte-vector byte-vector-length block-ref block-set! number-of-slots
    171     f32vector->byte-vector f64vector->byte-vector byte-vector-ref byte-vector-set!
     168    u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector ; DEPRECATED
     169    u32vector->byte-vector s32vector->byte-vector byte-vector-length ; DEPRECATED
     170    f32vector->byte-vector f64vector->byte-vector byte-vector-ref byte-vector-set! ; DEPRECATED
     171    blob-size u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared
     172    s16vector->blob/shared u32vector->blob/shared s32vector->blob/shared
     173    f32vector->blob/shared f64vector->blob/shared
     174    blob->u8vector/shared blob->s8vector/shared blob->u16vector/shared
     175    blob->s16vector/shared blob->u32vector/shared blob->s32vector/shared
     176    blob->f32vector/shared blob->f64vector/shared
     177    block-ref block-set! number-of-slots
    172178    hash-table-ref any?
    173179    first second third fourth make-record-instance
     
    214220(define non-foldable-extended-bindings
    215221  '(##sys#slot ##sys#setslot ##sys#call-with-current-continuation ##sys#fudge flush-output print void
    216     u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector u32vector->byte-vector
    217     s32vector->byte-vector ##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot ##sys#block-ref
    218     f32vector->byte-vector f64vector->byte-vector ##sys#byte ##sys#setbyte byte-vector-ref byte-vector-set!
     222    u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector u32vector->byte-vector ; DEPRECATED
     223    f32vector->byte-vector f64vector->byte-vector s32vector->byte-vector ;DEPRECATED
     224    u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared s16vector->blob/shared u32vector->blob/shared
     225    f32vector->blob/shared f64vector->blob/shared
     226    s32vector->blob/shared
     227    ##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot ##sys#block-ref
     228    ##sys#byte ##sys#setbyte
     229    byte-vector-ref byte-vector-set!    ; DEPRECATED
    219230    u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
    220231    f32vector-length f64vector-length ##sys#apply-values ##sys#setter setter
     
    899910(rewrite '##sys#direct-return 17 2 "C_direct_return")
    900911
    901 (rewrite 'byte-vector-ref 2 2 "C_subbyte" #f #f)
    902 (rewrite 'byte-vector-set! 2 3 "C_setbyte" #f #f)
    903 (rewrite 'byte-vector-length 2 1 "C_block_size" #f #f)
     912(rewrite 'byte-vector-ref 2 2 "C_subbyte" #f #f) ; DEPRECATED
     913(rewrite 'byte-vector-set! 2 3 "C_setbyte" #f #f) ; DEPRECATED
     914(rewrite 'byte-vector-length 2 1 "C_block_size" #f #f) ; DEPRECATED
     915(rewrite 'blob-size 2 1 "C_block_size" #f #f) ; DEPRECATED
    904916
    905917(rewrite 'u8vector-ref 2 2 "C_u_i_u8vector_ref" #f #f)
     
    931943(rewrite 'null-list? 17 1 "C_i_null_list_p" "C_i_nullp")
    932944
    933 (rewrite 'u8vector->byte-vector 7 1 "C_slot" 1 #f)
    934 (rewrite 's8vector->byte-vector 7 1 "C_slot" 1 #f)
    935 (rewrite 'u16vector->byte-vector 7 1 "C_slot" 1 #f)
    936 (rewrite 's16vector->byte-vector 7 1 "C_slot" 1 #f)
    937 (rewrite 'u32vector->byte-vector 7 1 "C_slot" 1 #f)
    938 (rewrite 's32vector->byte-vector 7 1 "C_slot" 1 #f)
    939 (rewrite 'f32vector->byte-vector 7 1 "C_slot" 1 #f)
    940 (rewrite 'f64vector->byte-vector 7 1 "C_slot" 1 #f)
     945(rewrite 'u8vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
     946(rewrite 's8vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
     947(rewrite 'u16vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
     948(rewrite 's16vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
     949(rewrite 'u32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
     950(rewrite 's32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
     951(rewrite 'f32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
     952(rewrite 'f64vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
     953
     954(rewrite 'u8vector->blob/shared 7 1 "C_slot" 1 #f)
     955(rewrite 's8vector->blob/shared 7 1 "C_slot" 1 #f)
     956(rewrite 'u16vector->blob/shared 7 1 "C_slot" 1 #f)
     957(rewrite 's16vector->blob/shared 7 1 "C_slot" 1 #f)
     958(rewrite 'u32vector->blob/shared 7 1 "C_slot" 1 #f)
     959(rewrite 's32vector->blob/shared 7 1 "C_slot" 1 #f)
     960(rewrite 'f32vector->blob/shared 7 1 "C_slot" 1 #f)
     961(rewrite 'f64vector->blob/shared 7 1 "C_slot" 1 #f)
    941962
    942963(let ()
     
    10011022    (hash-table-ref . hash-table-set!)
    10021023    (block-ref . block-set!)
    1003     (byte-vector-ref . byte-vector-set!)
     1024    (byte-vector-ref . byte-vector-set!) ; DEPRECATED
    10041025    (locative-ref . locative-set!)
    10051026    (u8vector-ref . u8vector-set!)
  • chicken/chicken-setup.1

    r2616 r4340  
    175175
    176176.TP
     177.B \-test
     178If the extension sources contain a directory named
     179.B tests
     180and this directory includes a file named
     181.B run\.scm
     182then this file is executed (with
     183.B tests
     184being the current working directory).
     185
     186.TP
    177187.BI \-tree\ filename
    178188Uses the repository catalog stored in
  • chicken/chicken-setup.scm

    r4232 r4340  
    9494  '(#\h #\u #\l #\r #\R #\P #\V #\s #\f #\H #\p #\k #\v #\c #\d #\n #\i #\e #\D #f #f #\t #f #f #f #f #f #f) )
    9595
    96 
    9796(define *install-bin-path*
    9897  (or (and-let* ((p (getenv "CHICKEN_PREFIX")))
     
    172171(define *repository-hosts* '(("www.call-with-current-continuation.org" "eggs" 80)))
    173172(define *revision* #f)
     173(define *run-tests* #f)
    174174
    175175
     
    405405  -i  -docindex                  display path for documentation index
    406406  -e  -eval EXPRESSION           evaluate expression
    407   -t  -test EXTENSION ...        return success if all given extensions are installed
     407  -t  -test                      run test suite, if it exists
    408408      -ls EXTENSION              list installed files for extension
    409409      -fetch-tree                download and show repository catalog
     
    442442(define (run-setup-script filename)
    443443  (when (setup-verbose-flag) (printf "executing ~A ...~%" filename))
    444   (load filename) )
     444  (load filename)
     445  (when (and *run-tests*
     446             (file-exists? "tests")
     447             (directory? "tests")
     448             (file-exists? (make-pathname "tests" "run.scm")) )
     449    (let ((old (current-directory)))
     450      (change-directory "tests")
     451      (when (setup-verbose-flag)
     452        (printf "running test cases ...~%") )
     453      (run (csi -s run.scm ,(pathname-file filename)))
     454      (change-directory old))))
    445455
    446456(define (write-info id files info)
     
    519529                 (v (setup-verbose-flag)) )
    520530             (if (testgz fn2)
    521                  (run (gunzip -c ,fn2 |\|| tar ,(if v 'xvf 'xf) -))
     531                 (run (gzip -d -c ,fn2 |\|| tar ,(if v 'xvf 'xf) -))
    522532                 (run (tar ,(if v 'xvf 'xf) ,fn2)) ) ) ) )
    523533    (set! *temporary-directory* tmpdir) ) )
     
    12011211         (set! *dont-ask* #t)
    12021212         (loop more) )
     1213        (("-test" . more)
     1214         (set! *run-tests* #t)
     1215         (loop more) )
    12031216        (("-local" path . more)
    12041217         (set! *local-repository* path)
     
    12091222         (set! anydone #t)
    12101223         (loop more) )
    1211         (("-test" . exts)
    1212          (let ((missing (remove extension-info exts)))
    1213            (cond ((pair? missing)
    1214                   (print "the following extensions are currently not installed: " missing)
    1215                   1)
    1216                  (else (exit 0)) ) ) )
    12171224        (((or "-run" "-script" "-proxy" "-host" "-csc-option" "-ls" "-destdir" "-tree" "-local" "-svn" "-eval"))
    12181225         (error "missing option argument" (car args)) )
  • chicken/chicken.h

    r4232 r4340  
    11131113C_fctexport int C_fcall C_save_callback_continuation(C_word **ptr, C_word k);
    11141114C_fctexport C_word C_fcall C_restore_callback_continuation(void);
     1115C_fctexport C_word C_fcall C_restore_callback_continuation2(int level);
    11151116C_fctexport C_word C_fcall C_callback(C_word closure, int argc);
    11161117C_fctexport C_word C_fcall C_callback_wrapper(void *proc, int argc);
     
    14291430C_fctexport C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2) C_regparm;
    14301431C_fctexport C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n) C_regparm;
     1432C_fctexport C_word C_fcall C_i_o_fixnum_plus(C_word x, C_word y) C_regparm;
     1433C_fctexport C_word C_fcall C_i_o_fixnum_difference(C_word x, C_word y) C_regparm;
    14311434
    14321435C_fctexport C_word C_fcall C_i_foreign_char_argumentp(C_word x) C_regparm;
  • chicken/csi.scm

    r3156 r4340  
    659659              [(##sys#bytevector? x)
    660660               (let ([len (##sys#size x)])
    661                  (fprintf out "byte vector of size ~S:~%" len)
     661                 (fprintf out "blob of size ~S:~%" len)
    662662                 (hexdump x len ##sys#byte out) ) ]
    663663              [(##core#inline "C_lambdainfop" x)
  • chicken/extras.scm

    r4232 r4340  
    281281  ;; this should really shadow SORT! and RANDOM...
    282282  (lambda (l)
    283     (map cdr
    284          (sort! (map (lambda (x) (cons (random 10000) x)) l)
    285                 (lambda (x y) (< (car x) (car y)))) ) ) )
     283    (let ((len (length l)))
     284      (map cdr
     285           (sort! (map (lambda (x) (cons (random len) x)) l)
     286                  (lambda (x y) (< (car x) (car y)))) ) ) ) )
    286287
    287288
     
    493494      (##sys#check-string s 'write-string)
    494495      (let-optionals more ([n #f] [port ##sys#standard-output])
    495         (##sys#check-port port 'read-string)
     496        (##sys#check-port port 'write-string)
    496497        (when n (##sys#check-exact n 'write-string))
    497498        (display
     
    725726              ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))
    726727              ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))
     728              ((eq? obj (##sys#slot '##sys#arbitrary-unbound-symbol 0))
     729               (out "#<unbound value>" col) )
    727730              ((##sys#generic-structure? obj)
    728731               (let ([o (open-output-string)])
     
    730733                 (out (get-output-string o) col) ) )
    731734              ((port? obj) (out (string-append "#<port " (##sys#slot obj 3) ">") col))
     735              ((##core#inline "C_bytevectorp" obj)
     736               (if (##core#inline "C_permanentp" obj)
     737                   (out "#<static blob of size" col)
     738                   (out "#<blob of size " col) )
     739               (out (number->string (##core#inline "C_block_size" obj)) col)
     740               (out ">" col) )
    732741              ((##core#inline "C_lambdainfop" obj)
    733742               (out "#<lambda info " col)
    734743               (out (##sys#lambda-info->string obj) col)
    735744               (out "#>" col) )
    736               ((eq? obj (##sys#slot '##sys#arbitrary-unbound-symbol 0))
    737                (out "#<unbound value>" col) )
    738745              (else               (out "#<unprintable object>" col)) ) )
    739746
  • chicken/hen.el

    r3839 r4340  
    6262;; * still pretty bad...
    6363
     64;; Changes by Adhi Hargo:
     65;;
     66;; * automatically raise *csi* buffer on any relevant operations, and
     67;;   made it a read-only buffer.
     68;; * changes definition-at-point evaluation command.
     69;; * s-exp evaluation no longer shown in minibuffer.
     70;; * added : + Hen-mode customization group.
     71;;           + Buffer evaluation command.
     72;;           + csi process-terminating command, partly so I can erase
     73;;             previous definitions and start anew.
     74;;           + close-parens-at-point command, from SLIME.
     75;;           + modification-check before compilation.
    6476
    6577;;; Code:
     
    6981
    7082Report bugs to: Felix Winkelmann <bunny351@gmail.com>")
    71 (defvar hen-load-hook nil
    72  "*Hooks run after loading hen.")
    7383
    7484(require 'scheme)
    7585(require 'compile)
     86
     87;;; GROUP DECLARATION ================================================
     88
     89(defgroup hen nil
     90  "Major mode for editing Scheme programs using Chicken."
     91  :version "21.3"
     92  :group 'scheme
     93  :prefix "hen-")
     94(defgroup hen-font-face nil
     95  "Various font face configurations."
     96  :group 'hen)
     97
     98(defun hen-version ()
     99  "Outputs Hen's current version to the minibuffer."
     100  (interactive)
     101  (message "Hen %s" hen-version))
     102
     103;;; USER-CONFIGURABLE COMMANDS =======================================
     104
     105(defcustom hen-csc-program "csc"
     106  "*Chicken compiler executable's filename."
     107  :group 'hen
     108  :type 'string)
     109(defcustom hen-csi-program "csi"
     110  "*Chicken interpreter executable's filename."
     111  :group 'hen
     112  :type 'string)
     113(defcustom hen-build-exec-arg ""
     114  "*Compiler-argument when building an executable file."
     115  :group 'hen
     116  :type 'string)
     117(defcustom hen-build-obj-arg ""
     118  "*Compiler-argument when building an object file."
     119  :group 'hen
     120  :type 'string)
     121(defcustom hen-eval-init-arg ""
     122  "*Additional interpreter argument."
     123  :group 'hen
     124  :type 'string)
     125
     126(defcustom hen-autosave-buffer-before-compile nil
     127  "*Save modified file automatically before compilation.
     128The default behavior is to ask the user whether to save or not."
     129  :group 'hen
     130  :type 'boolean)
     131
     132(defcustom hen-load-hook nil
     133  "Hook run after entering Hen mode."
     134  :group 'hen
     135  :type 'hook)
     136
    76137
    77138;; with-temp-message pasted from a mailing list. It's not available in my xemacs 21.4
     
    233294
    234295(defun hen-build (cmd args)
     296  (when (and (buffer-modified-p)
     297             (or hen-autosave-buffer-before-compile
     298                 (progn (beep)
     299                        (y-or-n-p "File modified. Save it? "))))
     300    (save-buffer))
    235301 (compile-internal (mapconcat 'identity (cons cmd args) " ")
    236302                   "No more errors" "csc" nil
     
    239305
    240306(defun hen-build-extension ()
    241  (interactive)
    242  (let* ((file-name (file-name-nondirectory
    243                     (buffer-file-name))))
    244    (hen-build "csc" (list "-s" file-name))))
     307  (interactive)
     308  (let* ((file-name (file-name-nondirectory
     309                     (buffer-file-name))))
     310    (hen-build hen-csc-program (list "-s" file-name hen-build-obj-arg))))
    245311
    246312(defun hen-build-program ()
     
    248314 (let* ((file-name (file-name-nondirectory
    249315                     (buffer-file-name))))
    250    (hen-build "csc" (list file-name) )))
     316    (hen-build hen-csc-program (list file-name hen-build-exec-arg))))
    251317
    252318(define-derived-mode hen-mode scheme-mode "Hen"
     
    255321\\[hen-csi-eval-last-sexp] evaluates the sexp at/preceding point in csi.
    256322\\[hen-csi-eval-region] evaluates the region in csi.
     323\\[hen-csi-eval-buffer] evaluates current buffer in csi.
     324\\[hen-csi-eval-definition] evaluates the toplevel definition at point in csi.
    257325\\[hen-csi-apropos] lists the csi's symbols matching a regex.
    258 \\[hen-csi-send] reads a s-exp from the user and evaluates it csi.
     326\\[hen-csi-send] reads a sexp from the user and evaluates it csi.
     327\\[hen-csi-proc-delete] terminates csi subprocess.
     328\\[hen-close-parens-at-point] closes parentheses for top-level sexp at point.
    259329\\[hen-build-extension] compiles the current file as a shared object
    260330\\[hen-build-program] compiles the current file as a program
     
    264334 (setq local-abbrev-table scheme-mode-abbrev-table)
    265335
    266  (define-key hen-mode-map (kbd "M-TAB")   'hen-complete-symbol)
    267  (define-key hen-mode-map (kbd "C-c C-e") 'hen-csi-eval-last-sexp)
    268  (define-key hen-mode-map (kbd "C-c C-r") 'hen-csi-eval-region)
    269  (define-key hen-mode-map (kbd "C-c C-a") 'hen-csi-apropos)
    270  (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-unit)
    271  (define-key hen-mode-map (kbd "C-c C-x") 'hen-csi-send)
    272  (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-extension)
    273  (define-key hen-mode-map (kbd "C-c C-c") 'hen-build-program)
    274 
    275  (define-key hen-mode-map [menu-bar scheme run-scheme] nil)
    276  (define-key hen-mode-map [menu-bar shared build-prog] '("Compile File" hen-build-program))
    277  (define-key hen-mode-map [menu-bar shared send-to-csi] '("Evaluate" . hen-csi-send))
    278  (define-key hen-mode-map [menu-bar scheme build-as-extension]
    279    '("Compile File as Extension" . hen-build-extension))
    280  (define-key hen-mode-map [menu-bar scheme apropos] '("Symbol Apropos" . hen-csi-apropos))
    281  (define-key hen-mode-map [menu-bar scheme eval-region] '("Eval Region" . hen-csi-eval-region))
    282  (define-key hen-mode-map [menu-bar scheme eval-last-sexp]
    283    '("Eval Last S-Expression" . hen-csi-eval-last-sexp))
    284 
    285  (setq font-lock-defaults
    286        '((hen-font-lock-keywords
    287           hen-font-lock-keywords-1 hen-font-lock-keywords-2)
    288          nil t
    289          ((?+ . "w") (?- . "w") (?* . "w") (?/ . "w")
    290           (?. . "w") (?< . "w") (?> . "w") (?= . "w")
    291           (?? . "w") (?$ . "w") (?% . "w") (?_ . "w")
    292           (?& . "w") (?~ . "w") (?^ . "w") (?: . "w"))
    293          beginning-of-defun
    294          (font-lock-mark-block-function . mark-defun))))
     336  (define-key hen-mode-map (kbd "M-TAB")   'hen-complete-symbol)
     337  (define-key hen-mode-map (kbd "C-c C-e") 'hen-csi-eval-last-sexp)
     338  (define-key hen-mode-map (kbd "C-c C-r") 'hen-csi-eval-region)
     339  (define-key hen-mode-map (kbd "C-c C-b") 'hen-csi-eval-buffer)
     340  (define-key hen-mode-map (kbd "C-c C-d") 'hen-csi-eval-definition)
     341  (define-key hen-mode-map (kbd "C-c C-a") 'hen-csi-apropos)
     342  (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-unit)
     343  (define-key hen-mode-map (kbd "C-c C-x") 'hen-csi-send)
     344  (define-key hen-mode-map (kbd "C-c C-q") 'hen-csi-proc-delete)
     345  (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-extension)
     346  (define-key hen-mode-map (kbd "C-c C-c") 'hen-build-program)
     347  (define-key hen-mode-map (kbd "C-c C-]") 'hen-close-parens-at-point)
     348
     349  (define-key hen-mode-map [menu-bar scheme run-scheme] nil)
     350  (define-key hen-mode-map [menu-bar shared build-prog] '("Compile File" hen-build-program))
     351  (define-key hen-mode-map [menu-bar shared send-to-csi] '("Evaluate" . hen-csi-send))
     352  (define-key hen-mode-map [menu-bar scheme build-as-extension]
     353    '("Compile File as Extension" . hen-build-extension))
     354  (define-key hen-mode-map [menu-bar scheme apropos] '("Symbol Apropos" . hen-csi-apropos))
     355  (define-key hen-mode-map [menu-bar scheme eval-buffer] '("Eval Buffer" . hen-csi-eval-buffer))
     356  (define-key hen-mode-map [menu-bar scheme eval-region] '("Eval Region" . hen-csi-eval-region))
     357  (define-key hen-mode-map [menu-bar scheme eval-last-sexp]
     358    '("Eval Last S-Expression" . hen-csi-eval-last-sexp))
     359
     360  (setq font-lock-defaults
     361        '((hen-font-lock-keywords
     362           hen-font-lock-keywords-1 hen-font-lock-keywords-2)
     363          nil t
     364          ((?+ . "w") (?- . "w") (?* . "w") (?/ . "w")
     365           (?. . "w") (?< . "w") (?> . "w") (?= . "w")
     366           (?? . "w") (?$ . "w") (?% . "w") (?_ . "w")
     367           (?& . "w") (?~ . "w") (?^ . "w") (?: . "w"))
     368          beginning-of-defun
     369          (font-lock-mark-block-function . mark-defun)))
     370  (make-local-variable 'paragraph-start)
     371  (setq paragraph-start (concat page-delimiter "\\|$" ))
     372
     373  (make-local-variable 'paragraph-separate)
     374  (setq paragraph-separate paragraph-start)
     375
     376  (make-local-variable 'paragraph-ignore-fill-prefix)
     377  (setq paragraph-ignore-fill-prefix t)
     378
     379  (make-local-variable 'adaptive-fill-mode)
     380  (setq adaptive-fill-mode nil)
     381
     382  (make-local-variable 'parse-sexp-ignore-comments)
     383  (setq parse-sexp-ignore-comments t)
     384
     385  (make-local-variable 'outline-regexp)
     386  (setq outline-regexp ";;;;* \\|(")
     387
     388  (make-local-variable 'comment-start)
     389  (setq comment-start ";")
     390
     391  (make-local-variable 'comment-column)
     392  (setq comment-column 40)
     393
     394  (make-local-variable 'comment-add)
     395  (setf comment-add 1)
     396  )
    295397
    296398;;stolen from cxref
     
    307409
    308410(defun hen-proc-wait-prompt (proc prompt-re &optional timeout msg)
    309  "Wait for the prompt of interactive process PROC. PROMPT-RE must be
     411  "Wait for the prompt of interactive process PROC. PROMPT-RE must be
    310412a regexp matching the prompt. TIMEOUT is the amount of time to wait in
    311413secs before giving up. MSG is the message to display while waiting."
    312  (setq timeout (if (numberp timeout) (* timeout 2) 60))
    313  (unless (stringp msg)
    314    (setq msg (concat "wait for "
    315                      (process-name proc)
    316                      "'s prompt")))
    317  (goto-char (process-mark proc))
    318  (if (hen-looking-backward-at prompt-re)
    319      t
    320    (while (and (> timeout 0) (not (hen-looking-backward-at prompt-re)))
    321      (with-temp-message (setq msg (concat msg "."))
    322        (accept-process-output proc 0 timeout))
    323      (setq timeout (1- timeout))
    324      (goto-char (process-mark proc)))
    325    (with-temp-message (concat msg (if (> timeout 0)
    326                                       " got it!" " timeout!"))
    327      (sit-for 0 100))
    328    (> timeout 0)))
     414  (setq timeout (if (numberp timeout) (* timeout 2) 60))
     415  (unless (stringp msg)
     416    (setq msg (concat "wait for " hen-csi-proc-name "'s prompt")))
     417  (goto-char (process-mark proc))
     418  (if (hen-looking-backward-at prompt-re)
     419      t
     420    (while (and (> timeout 0) (not (hen-looking-backward-at prompt-re)))
     421      (with-temp-message (setq msg (concat msg "."))
     422        (accept-process-output proc 0 timeout))
     423      (setq timeout (1- timeout))
     424      (goto-char (process-mark proc)))
     425    (with-temp-message (concat msg (if (> timeout 0)
     426                                       " got it!" " timeout!"))
     427      (sit-for 0 100))
     428    (> timeout 0))
     429  )
    329430
    330431(defun hen-proc-send (question proc prompt-re &optional timeout msg)
     
    333434wait in secs before giving up. MSG is the message to display while
    334435waiting."
    335  (setq timeout (if (numberp timeout) (* timeout 2) 60))
    336  (save-excursion
    337    (set-buffer (process-buffer proc))
    338    (widen)
    339    (save-match-data
    340      (goto-char (process-mark proc))
    341      (if (hen-looking-backward-at prompt-re)
    342          (let ((start (match-end 0)))
    343            (narrow-to-region start (point-max))
    344            (process-send-string proc (concat question "\n"))
    345            (hen-proc-wait-prompt proc prompt-re timeout msg)
    346            (narrow-to-region start (match-beginning 0))
    347            (current-buffer))))))
    348 
    349 (defun hen-csi-buffer () (get-buffer-create " *csi*"))
    350 
    351 (defconst hen-prompt-pattern "#;[0-9]*> ")
     436  (setq timeout (if (numberp timeout) (* timeout 2) 60))
     437  (save-excursion
     438    (set-buffer (process-buffer proc))
     439    (widen)
     440    (save-match-data
     441      (goto-char (process-mark proc))
     442      (if (hen-looking-backward-at prompt-re)
     443          (let ((start (match-end 0)))
     444            (narrow-to-region start (point-max))
     445            (process-send-string proc (concat question "\n"))
     446            (hen-proc-wait-prompt proc prompt-re timeout msg)
     447            (narrow-to-region start (match-beginning 0))
     448            (current-buffer))))))
     449
     450(defconst hen-csi-prompt-pattern "#;[0-9]*> ")
     451(defconst hen-csi-proc-name "csi")
     452(defconst hen-csi-buffer-name "*csi*")
     453
     454(defun hen-csi-buffer-create ()
     455  "Creates a new buffer for csi, make it read-only."
     456  (let ((buffer (get-buffer-create hen-csi-buffer-name)))
     457    (with-current-buffer buffer
     458      (make-local-variable 'buffer-read-only)
     459      (setf buffer-read-only t))
     460    buffer))
     461
     462(defun hen-csi-buffer-erase ()
     463  "Erases csi buffer's content, used mainly when its process was being
     464reset."
     465  (let ((buffer (get-buffer hen-csi-buffer-name)))
     466    (unless (null buffer) (with-current-buffer buffer
     467                            (setf buffer-read-only '())
     468                            (erase-buffer)
     469                            (setf buffer-read-only t)))))
     470
     471(defun hen-csi-buffer ()
     472  (let ((buffer (or (get-buffer hen-csi-buffer-name) ;check if exists
     473                    (hen-csi-buffer-create)))) ;... or create one
     474    (display-buffer buffer)
     475    buffer))
    352476
    353477(defun hen-csi-proc ()
    354  (let ((proc (get-buffer-process (hen-csi-buffer))))
    355    (if (and (processp proc)
    356             (eq (process-status proc) 'run))
    357        proc
    358      (setq proc (start-process "csi" (hen-csi-buffer) "csi" "-no-init" "-quiet" "-:c"))
    359      (with-current-buffer (hen-csi-buffer)
    360        (hen-proc-wait-prompt proc hen-prompt-pattern)
    361        proc))))
     478  (let ((proc (get-process hen-csi-proc-name)))
     479    (if (and (processp proc)
     480             (eq (process-status proc) 'run))
     481        proc
     482      (setq proc
     483            (eval `(start-process hen-csi-proc-name (hen-csi-buffer)
     484                                  hen-csi-program
     485                                  "-no-init" "-quiet" "-:c"
     486                                  ,@(split-string hen-eval-init-arg))))
     487      (with-current-buffer (hen-csi-buffer)
     488        (hen-proc-wait-prompt proc hen-csi-prompt-pattern)
     489        proc))))
     490
     491(defun hen-csi-proc-delete ()
     492  (interactive)
     493  (let ((proc (get-process hen-csi-proc-name)))
     494    (when (and (processp proc)
     495               (eq (process-status proc) 'run))
     496      (delete-process proc))
     497    (hen-csi-buffer-erase)
     498    ()))
    362499
    363500(defun hen-csi-send (sexp)
    364  "Evaluate SEXP in CSI"
    365  (interactive
    366   (let ((sexp (read-string "Evaluate S-expression: "))
    367         (send-sexp-p nil))
    368     (unwind-protect
    369         (progn
    370           (let ((obarray (make-vector 11 0)))
    371             (read sexp)
    372             (setq send-sexp-p t)))
    373       (unless send-sexp-p
    374         (setq send-sexp-p
    375               (y-or-n-p (format "`%s' is not a valid sexp! evaluate anyway? " sexp)))))
    376     (list (if send-sexp-p sexp nil))))
    377  (when (stringp sexp)
    378    (let* ((proc (hen-csi-proc))
    379           (buf (hen-proc-send (concat sexp "\n") proc hen-prompt-pattern))
    380           result len)
    381      (unless (buffer-live-p buf)
    382        (error "Internal hen-mode failure"))
    383 
    384      (save-excursion
    385        (with-current-buffer buf
    386          (setq result (buffer-string))
    387          (setq len (length result))
    388          (if (and (> len 0)
    389                   (eq (aref result (1- len)) ?\n))
    390              (setq result (substring result 0 -1)))
    391          result)))))
     501  "Evaluate SEXP in CSI"
     502  (interactive
     503   (let ((sexp (read-string "Evaluate S-expression: "))
     504         (send-sexp-p nil))
     505     (unwind-protect
     506         (progn
     507           (let ((obarray (make-vector 11 0)))
     508             (read sexp)
     509             (setq send-sexp-p t)))
     510       (unless send-sexp-p
     511         (setq send-sexp-p
     512               (y-or-n-p (format "`%s' is not a valid sexp! evaluate anyway? " sexp)))))
     513     (list (if send-sexp-p sexp nil))))
     514  (when (stringp sexp)
     515    (let* ((proc (hen-csi-proc))
     516           (buf (hen-proc-send (concat sexp "\n") proc hen-csi-prompt-pattern))
     517           result len)
     518      (unless (buffer-live-p buf)
     519        (error "Internal hen-mode failure"))
     520
     521      (save-excursion
     522        (with-current-buffer buf
     523          (setq result (buffer-string))
     524          (setq len (length result))
     525          (if (and (> len 0)
     526                   (eq (aref result (1- len)) ?\n))
     527              (setq result (substring result 0 -1)))
     528          result)))))
     529
     530(defun hen-csi-eval-buffer ()
     531  "Evaluate the current buffer in CSI"
     532  (interactive)
     533  (hen-csi-send (buffer-string)))
    392534
    393535(defun hen-csi-eval-region (beg end)
    394  "Evaluate the current region in CSI."
    395  (interactive "r")
    396  (message
    397   (hen-csi-send (buffer-substring beg end))))
     536  "Evaluate the current region in CSI."
     537  (interactive "r")
     538  (hen-csi-send (buffer-substring beg end)))
    398539
    399540(defun hen-csi-eval-last-sexp ()
    400  "Evaluate the s-expression at point in CSI"
    401  (interactive)
    402  (message
     541  "Evaluate the s-expression at point in CSI"
     542  (interactive)
    403543  (hen-csi-eval-region (save-excursion (backward-sexp) (point))
    404                        (point))))
     544                       (point)))
    405545
    406546(defun hen-csi-eval-definition ()
    407  "Evaluate the enclosing top-level form in CSI."
    408  (interactive)
    409  (save-excursion
    410    (message
    411     (hen-csi-eval-region (progn (beginning-of-defun) (point))
    412                          (progn (forward-sexp 1) (point))))))
     547  "Evaluate the enclosing top-level form in CSI."
     548  (interactive)
     549  (hen-csi-eval-region (save-excursion
     550                         (end-of-defun) (beginning-of-defun)
     551                         (point))
     552                       (save-excursion
     553                         (end-of-defun) (point))))
     554
     555;; from SLIME
     556(defun hen-close-parens-at-point ()
     557  "Close parenthesis at point to complete the top-level-form.  Simply
     558inserts ')' characters at point until `beginning-of-defun' and
     559`end-of-defun' execute without errors, or internal variable
     560`close-parens-limit' is exceeded."
     561  (interactive)
     562  (let ((close-parens-limit 16))
     563    (loop for i from 1 to close-parens-limit
     564          until (save-excursion
     565                  (beginning-of-defun)
     566                  (ignore-errors (end-of-defun) t))
     567          do (insert ")"))))
    413568
    414569(defun hen-csi-completions-alist (prefix)
  • chicken/library.scm

    r4232 r4340  
    125125     ##sys#fudge ##sys#user-read-hook ##sys#check-range ##sys#read
    126126     ##sys#string->symbol ##sys#symbol->string ##sys#dynamic-unwind ##sys#pathname-resolution
    127      ##sys#expand-home-path ##sys#string-append ##sys#symbol->qualified-string
     127     ##sys#platform-fixup-pathname ##sys#expand-home-path ##sys#string-append ##sys#symbol->qualified-string
    128128     ##sys#error-handler ##sys#signal ##sys#abort ##sys#port-data
    129129     ##sys#reset-handler ##sys#exit-handler ##sys#dynamic-wind ##sys#port-line
     
    16891689(define (##sys#port-data port) (##sys#slot port 9))
    16901690
     1691(define ##sys#platform-fixup-pathname
     1692  (let* ([bp (string->symbol ((##core#primitive "C_build_platform")))]
     1693         [fixsuffix (or (eq? bp 'msvc) (eq? bp 'mingw32))])
     1694    (lambda (name)
     1695      (if fixsuffix
     1696        (let ([end (fx- (##sys#size name) 1)])
     1697          (if (fx>= end 0)
     1698            (let ([c (##core#inline "C_subchar" name end)])
     1699              (if (or (eq? c #\\) (eq? c #\/))
     1700                (##sys#substring name 0 end)
     1701                name) )
     1702            name) )
     1703        name) ) ) )
     1704
    16911705(define (##sys#pathname-resolution name thunk . _)
    16921706  (thunk (##sys#expand-home-path name)) )
     
    18001814            (apply ##sys#values results) ) ) ) ) ) )
    18011815
    1802 (define file-exists?
    1803   (let ((bp (string->symbol ((##core#primitive "C_build_platform"))))
    1804         (fixsuffix (or (eq? bp 'msvc) (eq? bp 'mingw32))))
     1816(define (file-exists? name)
     1817  (##sys#check-string name 'file-exists?)
     1818  (##sys#pathname-resolution
     1819    name
    18051820    (lambda (name)
    1806       (##sys#check-string name 'file-exists?)
    1807       (##sys#pathname-resolution
    1808        name
    1809        (lambda (name)
    1810          (let* ((len (##sys#size name))
    1811                 (name2 (if (and fixsuffix
    1812                                (let ((c (##core#inline "C_subchar" name (fx- len 1))))
    1813                                  (or (eq? c #\\) (eq? c #\/)) ) )
    1814                           (##sys#substring name 0 (fx- len 1))
    1815                           name) ) )
    1816            (and (##sys#file-info name2) name)) )
    1817        #:exists?) ) ) )
     1821      (and (##sys#file-info (##sys#platform-fixup-pathname name)) name) )
     1822    #:exists?) )
    18181823
    18191824(define (##sys#flush-output port)
     
    27902795                ((##core#inline "C_bytevectorp" x)
    27912796                 (if (##core#inline "C_permanentp" x)
    2792                      (outstr port "#<static byte-vector>")
    2793                      (outstr port "#<byte-vector>") ) )
    2794                 ((##core#inline "C_structurep" x) (##sys#user-print-hook x readable port))
     2797                     (outstr port "#<static blob of size")
     2798                     (outstr port "#<blob of size ") )
     2799                 (outstr port (number->string (##core#inline "C_block_size" x)))
     2800                 (outchr port #\>) )
     2801                ((##core#inline "C_structurep" x) (##sys#user-print-hook x readable port))
    27952802                ((##core#inline "C_closurep" x) (outstr port (##sys#procedure->string x)))
    27962803                ((##core#inline "C_locativep" x) (outstr port "#<locative>"))
     
    38483855   q                                    ; #9 quantum
    38493856   (##core#undefined)                   ; #10 specific
    3850    #f                                   ; #11 block-thread (currently unused)
     3857   #f                                   ; #11 block object (type depends on blocking type)
    38513858   '() ) )                              ; #12 recipients (currently unused)
    38523859
  • chicken/lolevel.scm

    r4232 r4340  
    6565     hash-table-ref/default ##sys#make-string make-vector hash-table-set! hash-table-set!
    6666     make-property-condition make-composite-condition signal ##sys#set-pointer-address! ##sys#make-vector
    67      ##sys#make-pointer byte-vector-fill! make-string make-byte-vector ##sys#not-a-proper-list-error ##sys#check-pointer
     67     ##sys#make-pointer make-string make-byte-vector ##sys#not-a-proper-list-error ##sys#check-pointer
    6868     ##sys#locative? ##sys#bytevector?
    6969     extend-procedure ##sys#lambda-decoration ##sys#decorate-lambda ##sys#make-tagged-pointer ##sys#check-special
     
    305305;;; Bytevector stuff:
    306306
    307 (define (byte-vector? x)
     307(define (blob? x)
    308308  (and (##core#inline "C_blockp" x)
    309309       (##core#inline "C_bytevectorp" x) ) )
    310310
    311 (define (byte-vector-fill! bv n)
     311(define byte-vector? blob?)             ; DEPRECATED
     312
     313(define (byte-vector-fill! bv n)        ; DEPRECATED
    312314  (##sys#check-byte-vector bv 'byte-vector-fill!)
    313315  (##sys#check-exact n 'byte-vector-fill!)
     
    317319      (##sys#setbyte bv i n) ) ) )
    318320
    319 (define make-byte-vector
    320   (let ([byte-vector-fill! byte-vector-fill!])
     321(define make-byte-vector                ; DEPRECATED
    321322    (lambda (size . init)
    322323      (##sys#check-exact size 'make-byte-vector)
     
    324325        (##core#inline "C_string_to_bytevector" bv)
    325326        (when (pair? init) (byte-vector-fill! bv (car init)))
    326         bv) ) ) )
    327 
    328 (define byte-vector
    329   (let ([make-byte-vector make-byte-vector])
     327        bv) ) )
     328
     329(define byte-vector                     ; DEPRECATED
    330330    (lambda bytes
    331331      (let* ([n (length bytes)]
     
    334334             [bytes bytes (##sys#slot bytes 1)] )
    335335            ((fx>= i n) bv)
    336           (##sys#setbyte bv i (##sys#slot bytes 0)) ) ) ) ) )
    337 
    338 (define byte-vector-set!
     336          (##sys#setbyte bv i (##sys#slot bytes 0)) ) ) ) )
     337
     338(define byte-vector-set!                ; DEPRECATED
    339339  (lambda (bv i x)
    340340    (##sys#check-byte-vector bv 'byte-vector-set!)
     
    346346          (##sys#setbyte bv i x) ) ) ) )
    347347
    348 (define byte-vector-ref
     348(define byte-vector-ref                 ; DEPRECATED
    349349  (getter-with-setter
    350350   (lambda (bv i)
     
    357357   byte-vector-set!) )
    358358
    359 (define (byte-vector->list bv)
     359(define (byte-vector->list bv)          ; DEPRECATED
    360360  (##sys#check-byte-vector bv 'byte-vector->list)
    361361  (let ([len (##sys#size bv)])
     
    366366                (loop (fx+ i 1)) ) ) ) ) )
    367367
    368 (define list->byte-vector
    369   (let ([make-byte-vector make-byte-vector])
     368(define list->byte-vector               ; DEPRECATED
    370369    (lambda (lst)
    371370      (##sys#check-list lst 'list->byte-vector)
     
    379378                (##sys#check-exact b 'list->byte-vector)
    380379                (##sys#setbyte v i b) )
    381               (##sys#not-a-proper-list-error lst) ) ) ) ) ) )
    382 
    383 (define string->byte-vector
    384   (let ([make-byte-vector make-byte-vector])
     380              (##sys#not-a-proper-list-error lst) ) ) ) ) )
     381
     382(define string->blob
    385383    (lambda (s)
    386384      (##sys#check-string s 'string->byte-vector)
     
    388386             [bv (make-byte-vector n)] )
    389387        (##core#inline "C_copy_memory" bv s n)
    390         bv) ) ) )
    391 
    392 (define byte-vector->string
    393   (let ([make-string make-string])
     388        bv) ) )
     389
     390(define string->byte-vector string->blob) ; DEPRECATED
     391
     392(define blob->string
    394393    (lambda (bv)
    395       (##sys#check-byte-vector bv 'byte-vector->string)
     394      (##sys#check-byte-vector bv 'blob->string)
    396395      (let* ([n (##sys#size bv)]
    397396             [s (make-string n)] )
    398397        (##core#inline "C_copy_memory" s bv n)
    399         s) ) ) )
    400 
    401 (define (byte-vector-length bv)
    402   (##sys#check-byte-vector bv 'byte-vector-length)
     398        s) ) )
     399
     400(define byte-vector->string blob->string) ; DEPRECATED
     401
     402(define (blob-size bv)
     403  (##sys#check-byte-vector bv 'blob-size)
    403404  (##sys#size bv) )
    404405
     406(define byte-vector-length blob-size) ; DEPRECATED
     407
    405408(define-foreign-variable _c_header_size_mask int "C_HEADER_SIZE_MASK")
    406409
    407 (let ([byte-vector-fill! byte-vector-fill!]
    408       [malloc
     410(let ([malloc
    409411       (foreign-lambda* scheme-object ((int size))
    410412         "char *bv;
     
    422424                 bv]
    423425                [else (##sys#signal-hook #:runtime-error "can not allocate statically allocated bytevector" size)] ) ) ) )
    424   (set! make-static-byte-vector (lambda (size . init) (make size init malloc 'make-static-byte-vector))))
    425 
    426 (define static-byte-vector->pointer
     426  (set! make-static-byte-vector         ; DEPRECATED
     427    (lambda (size . init) (make size init malloc 'make-static-byte-vector))))
     428
     429(define static-byte-vector->pointer             ; DEPRECATED
    427430  (lambda (bv)
    428431    (##sys#check-byte-vector bv 'static-byte-vector->pointer)
     
    431434          (##core#inline "C_pointer_to_block" p bv)
    432435          p)
    433         (##sys#error 'static-byte-vector->pointer "can not coerce non-static bytevector" bv) ) ) )
    434 
    435 (define (byte-vector-move! src src-start src-end dst dst-start)
     436        (##sys#error 'static-blob->pointer "can not coerce non-static blob" bv) ) ) )
     437
     438(define (byte-vector-move! src src-start src-end dst dst-start) ; DEPRECATED
    436439  (let ((from (make-locative src src-start))
    437440        (to   (make-locative dst dst-start)) )
    438441    (move-memory! from to (- src-end src-start)) ) )
    439442
    440 (define (byte-vector-append . vectors)
     443(define (byte-vector-append . vectors)          ; DEPRECATED
    441444  (define (append-rest-at i vectors)
    442445    (if (pair? vectors)
     
    514517
    515518(define object-evict
    516   (let ([make-hash-table make-hash-table]
    517         [hash-table-ref/default hash-table-ref/default]
    518         [hash-table-set! hash-table-set!] )
    519519    (lambda (x . allocator)
    520520      (let ([allocator
     
    537537                       ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
    538538                       (##sys#setislot y i (evict (##sys#slot x i))) ) )
    539                    y) ] ) ) ) ) ) )
     539                   y) ] ) ) ) ) )
    540540
    541541(define object-release
    542542  (lambda (x . releaser)
    543     (let ([free (if (pair? releaser)
     543    (let ((free (if (pair? releaser)
    544544                    (car releaser)
    545                     (foreign-lambda void "C_free" c-pointer) ) ] )
     545                    (foreign-lambda void "C_free" c-pointer) ) )
     546          (released '()))
    546547      (let release ([x x])
    547548        (cond [(not (##core#inline "C_blockp" x)) x]
    548549              [(not (##core#inline "C_permanentp" x)) x]
     550              ((memq x released) x)
    549551              [else
    550552               (let ([n (##sys#size x)])
     553                 (set! released (cons x released))
    551554                 (unless (##core#inline "C_byteblockp" x)
    552555                   (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     
    556559
    557560(define object-evict-to-location
    558   (let ([make-hash-table make-hash-table]
    559         [hash-table-ref/default hash-table-ref/default]
    560         [align-to-word align-to-word]
    561         [hash-table-set! hash-table-set!] )
    562561    (lambda (x ptr . limit)
    563562      (cond-expand
     
    605604                               (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
    606605                           y) ) ] ) ) ] )
    607         (values x2 ptr2) ) ) ) )
     606        (values x2 ptr2) ) ) )
    608607
    609608(define object-size
    610   (let ([make-hash-table make-hash-table]
    611         [hash-table-ref/default hash-table-ref/default]
    612         [align-to-word align-to-word]
    613         [hash-table-set! hash-table-set!] )
    614609    (lambda (x)
    615610      (let ([tab (make-hash-table eq?)])
     
    630625                         ((fx>= i n))
    631626                       (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
    632                    bytes) ] ) ) ) ) ) )
     627                   bytes) ] ) ) ) ) )
    633628
    634629(define object-unevict
    635   (let ([make-vector make-vector]
    636         [make-hash-table make-hash-table]
    637         [hash-table-set! hash-table-set!]
    638         [hash-table-ref/default hash-table-ref/default] )
    639630    (lambda (x #!optional (full #f))
    640631      (define (err x)
     
    662653                       ((fx>= i words))
    663654                     (##sys#setslot y i (copy (##sys#slot y i))) )
    664                    y) ] ) ) ) ) ) )
     655                   y) ] ) ) ) ) )
    665656
    666657
  • chicken/posixunix.scm

    r4232 r4340  
    548548      (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
    549549        (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
    550           (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or byte-vector" buf) )
     550          (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
    551551        (let ([n (##core#inline "C_read" fd buf size)])
    552552          (when (eq? -1 n)
     
    558558    (##sys#check-exact fd 'file-write)
    559559    (unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))
    560       (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or byte-vector" buffer) )
     560      (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )
    561561    (let ([size (if (pair? size) (car size) (##sys#size buffer))])
    562562      (##sys#check-exact size 'file-write)
     
    14041404      fd) ) )
    14051405
    1406 ;FIXME - UTF8?
    1407 
    14081406(define ##sys#custom-input-port
    14091407  (let ([make-input-port make-input-port]
    14101408        [set-port-name! set-port-name!] )
    14111409    (lambda (loc nam fd
    1412              #!optional (bufi 0) (on-close (lambda () (void))) (more? #f))
    1413       (let ([bufsiz (if (fixnum? bufi) (fxmax bufi 1) (##sys#size bufi))]
    1414             [buf (if (fixnum? bufi) (##sys#make-string (fxmax bufi 1)) bufi)]
    1415             [len 0]
    1416             [pos 0] )
     1410               #!optional
     1411               (nonblocking? #f) (bufi 1) (on-close noop) (more? #f))
     1412      (when nonblocking? (##sys#file-nonblocking! fd) )
     1413      (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))]
     1414            [buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
     1415            [buflen 0]
     1416            [bufpos 0] )
    14171417        (let (
    14181418            [ready?
     
    14221422            [peek
    14231423              (lambda ()
    1424                 (if (fx>= pos len)
     1424                (if (fx>= bufpos buflen)
    14251425                  #!eof
    1426                   (##core#inline "C_subchar" buf pos)) )]
     1426                  (##core#inline "C_subchar" buf bufpos)) )]
    14271427            [fetch
    14281428              (lambda ()
    1429                 (when (fx>= pos len)
     1429                (when (fx>= bufpos buflen)
    14301430                  (let loop ()
    1431                     (let ([n (##core#inline "C_read" fd buf bufsiz)])
     1431                    (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
    14321432                      (cond
    1433                         [(fx= n -1)
     1433                        [(fx= cnt -1)
    14341434                          (if (fx= _errno _ewouldblock)
    14351435                            (begin
     
    14381438                              (loop) )
    14391439                            (posix-error #:file-error loc "cannot read" fd nam) )]
    1440                         [(and more? (fx= n 0))
     1440                        [(and more? (fx= cnt 0))
    14411441                          ; When "more" keep trying, otherwise read once more
    14421442                          ; to guard against race conditions
     
    14451445                              (##sys#thread-yield!)
    14461446                              (loop) )
    1447                             (let ([n (##core#inline "C_read" fd buf bufsiz)])
    1448                               (when (fx= n -1)
     1447                            (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
     1448                              (when (fx= cnt -1)
    14491449                                (if (fx= _errno _ewouldblock)
    1450                                   (set! n 0)
     1450                                  (set! cnt 0)
    14511451                                  (posix-error #:file-error loc "cannot read" fd nam) ) )
    1452                               (set! len n)
    1453                               (set! pos 0) ) )]
     1452                              (set! buflen cnt)
     1453                              (set! bufpos 0) ) )]
    14541454                        [else
    1455                           (set! len n)
    1456                           (set! pos 0)]) ) ) ) )] )
     1455                          (set! buflen cnt)
     1456                          (set! bufpos 0)]) ) ) ) )] )
    14571457          (letrec (
    1458               [port
     1458              [this-port
    14591459                (make-input-port
    1460                   (lambda () ; Read
     1460                  (lambda ()                    ; Read-Char
    14611461                    (fetch)
    14621462                    (let ([ch (peek)])
    1463                       #;(unless (eof-object? ch) (set! pos (fx+ pos 1)))
    1464                       (set! pos (fx+ pos 1))
     1463                      #; ; Allow increment since overflow is far, far away
     1464                      (unless (eof-object? ch) (set! bufpos (fx+ bufpos 1)))
     1465                      (set! bufpos (fx+ bufpos 1))
    14651466                      ch ) )
    14661467                  (lambda () ; Ready?
    1467                     (or (fx< pos len) (ready?)) )
    1468                   (lambda () ; Close
    1469                     (unless (##sys#slot port 8) ;closed?
     1468                    (or (fx< bufpos buflen)
     1469                        (ready?)) )
     1470                  (lambda ()                    ; Close
     1471                    ; Do nothing when closed already
     1472                    (unless (##sys#slot this-port 8)
    14701473                      (when (fx< (##core#inline "C_close" fd) 0)
    14711474                        (posix-error #:file-error loc "cannot close" fd nam) )
    14721475                      (on-close) ) )
    1473                   (lambda () ; Peek
     1476                  (lambda ()                    ; Peek
    14741477                    (fetch)
    14751478                    (peek) )
    1476                   #;(lambda (port n dest start) ; Read-String
    1477                     )
    1478                   #;(lambda (port limit) ; Read-Line
    1479                     ) )] )
    1480             (set-port-name! port nam)
    1481             port ) ) ) ) ) )
     1479                  (lambda (port n dest start)   ; Read-String!
     1480                    (let loop ([n n] [m 0] [start start])
     1481                      (cond
     1482                        [(eq? n 0) m]
     1483                        [(fx< bufpos buflen)
     1484                          (let* ([rest (fx- buflen bufpos)]
     1485                                 [n2 (if (fx< n rest) n rest)])
     1486                            (##core#inline "C_substring_copy"
     1487                              buf dest bufpos (fx+ bufpos n2) start)
     1488                            (set! bufpos (fx+ bufpos n2))
     1489                            (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]
     1490                        [else
     1491                          (fetch)
     1492                          (if (eq? buflen 0)
     1493                            m
     1494                            (loop n m start) ) ] ) ) )
     1495                  (lambda (port limit)          ; Read-Line
     1496                    (let loop ([str #f])
     1497                      (cond
     1498                        [(fx< bufpos buflen)
     1499                          (##sys#scan-buffer-line
     1500                            buf buflen bufpos
     1501                            (lambda (cur ptr)
     1502                              (let ([dest (##sys#make-string (fx- cur bufpos))])
     1503                                (##core#inline "C_substring_copy" buf dest bufpos cur 0)
     1504                                (set! bufpos ptr)
     1505                                (cond
     1506                                  [(eq? cur ptr) ; no line-terminator encountered
     1507                                    (fetch)
     1508                                    (if (fx>= bufpos buflen)
     1509                                      (or str "")
     1510                                      (loop (if str (##sys#string-append str dest) dest)) ) ]
     1511                                  [else
     1512                                    (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
     1513                                    (if str (##sys#string-append str dest) dest) ] ) ) ) ) ]
     1514                        [else
     1515                          (fetch)
     1516                          (if (fx< bufpos buflen)
     1517                            (loop str)
     1518                            #!eof) ] ) ) ) )] )
     1519            (set-port-name! this-port nam)
     1520            this-port ) ) ) ) ) )
    14821521
    14831522(define ##sys#custom-output-port
     
    14851524        [set-port-name! set-port-name!] )
    14861525    (lambda (loc nam fd
    1487              #!optional (bufi 0) (on-close (lambda () (void))))
     1526               #!optional
     1527               (nonblocking? #f) (bufi 0) (on-close noop))
     1528      (when nonblocking? (##sys#file-nonblocking! fd) )
    14881529      (letrec (
    14891530          [poke
    1490             (lambda (s len)
    1491               (let ([n (##core#inline "C_write" fd s len)])
     1531            (lambda (str len)
     1532              (let ([cnt (##core#inline "C_write" fd str len)])
    14921533                (cond
    1493                   [(fx= -1 n)
     1534                  [(fx= -1 cnt)
    14941535                    (if (fx= _errno _ewouldblock)
    14951536                      (begin
    14961537                        (##sys#thread-yield!)
    1497                         (poke s len) )
     1538                        (poke str len) )
    14981539                      (posix-error loc #:file-error "cannot write" fd nam) ) ]
    1499                   [(fx< n len)
    1500                     (poke (##sys#substring s n len) (fx- len n)) ] ) ) )]
     1540                  [(fx< cnt len)
     1541                    (poke (##sys#substring str cnt len) (fx- len cnt)) ] ) ) )]
    15011542          [store
    15021543            (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])
    15031544              (if (fx= 0 bufsiz)
    1504                 (lambda (s)
    1505                   (when s
    1506                     (poke s (##sys#size s)) ) )
     1545                (lambda (str)
     1546                  (when str
     1547                    (poke str (##sys#size str)) ) )
    15071548                (let ([buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
    1508                       [pos 0])
    1509                   (lambda (s)
    1510                     (if s
    1511                       (let loop ([rem (fx- bufsiz pos)] [start 0] [len (##sys#size s)])
     1549                      [bufpos 0])
     1550                  (lambda (str)
     1551                    (if str
     1552                      (let loop ([rem (fx- bufsiz bufpos)] [start 0] [len (##sys#size str)])
    15121553                        (cond
    15131554                          [(fx= 0 rem)
    15141555                            (poke buf bufsiz)
    1515                             (set! pos 0)
     1556                            (set! bufpos 0)
    15161557                            (loop bufsiz 0 len)]
    15171558                          [(fx< rem len)
    1518                             (##core#inline "C_substring_copy" s buf start rem pos)
     1559                            (##core#inline "C_substring_copy" str buf start rem bufpos)
    15191560                            (loop 0 rem (fx- len rem))]
    15201561                          [else
    1521                             (##core#inline "C_substring_copy" s buf start len pos)
    1522                             (set! pos (fx+ pos len))] ) )
    1523                       (when (fx< 0 pos)
    1524                         (poke buf pos) ) ) ) ) ) )])
     1562                            (##core#inline "C_substring_copy" str buf start len bufpos)
     1563                            (set! bufpos (fx+ bufpos len))] ) )
     1564                      (when (fx< 0 bufpos)
     1565                        (poke buf bufpos) ) ) ) ) ) )])
    15251566        (letrec (
    1526             [port
     1567            [this-port
    15271568              (make-output-port
    1528                 (lambda (s) ; Write
    1529                   (store s) )
    1530                 (lambda () ; Close
    1531                   (unless (##sys#slot port 8) ;closed?
     1569                (lambda (str)           ; Write-String
     1570                  (store str) )
     1571                (lambda ()              ; Close
     1572                  ; Do nothing when closed already
     1573                  (unless (##sys#slot this-port 8)
    15321574                    (when (fx< (##core#inline "C_close" fd) 0)
    15331575                      (posix-error #:file-error loc "cannot close" fd nam) )
    15341576                    (on-close) ) )
    1535                 (lambda () ; Flush
     1577                (lambda ()              ; Flush
    15361578                  (store #f) ) )] )
    1537           (set-port-name! port nam)
    1538           port ) ) ) ) )
     1579          (set-port-name! this-port nam)
     1580          this-port ) ) ) ) )
    15391581
    15401582
     
    19912033                   (let ([usefd (car pipe)] [clsfd (cdr pipe)])
    19922034                     (file-close clsfd)
    1993                      (##sys#file-nonblocking! usefd)
    19942035                     usefd) ) )]
    19952036          [connect-child
     
    20002041                  (replace-fd loc usefd stdfd)) ) )] )
    20012042        (let (
    2002             [child
    2003               (lambda (loc cmd args env stdoutf stdinf stderrf)
    2004                 (let ([ipipe (needed-pipe loc stdinf)]
    2005                       [opipe (needed-pipe loc stdoutf)]
    2006                       [epipe (needed-pipe loc stderrf)]
    2007                       [swap-ends
    2008                         (lambda (pipe)
    2009                           (and pipe (cons (cdr pipe) (car pipe)) ) )])
    2010                   (values
    2011                     ipipe (swap-ends opipe) epipe
    2012                     (process-fork
    2013                       (lambda ()
    2014                         (connect-child loc opipe stdinf fileno/stdin)
    2015                         (connect-child loc (swap-ends ipipe) stdoutf fileno/stdout)
    2016                         (connect-child loc (swap-ends epipe) stderrf fileno/stderr)
    2017                         (process-execute cmd args env)))) ) )]
     2043            [spawn
     2044              (let ([swapped-ends
     2045                      (lambda (pipe)
     2046                        (and pipe
     2047                             (cons (cdr pipe) (car pipe)) ) )])
     2048                (lambda (loc cmd args env stdoutf stdinf stderrf)
     2049                  (let ([ipipe (needed-pipe loc stdinf)]
     2050                        [opipe (needed-pipe loc stdoutf)]
     2051                        [epipe (needed-pipe loc stderrf)])
     2052                    (values
     2053                      ipipe (swapped-ends opipe) epipe
     2054                      (process-fork
     2055                        (lambda ()
     2056                          (connect-child loc opipe stdinf fileno/stdin)
     2057                          (connect-child loc (swapped-ends ipipe) stdoutf fileno/stdout)
     2058                          (connect-child loc (swapped-ends epipe) stderrf fileno/stderr)
     2059                          (process-execute cmd args env)))) ) ) )]
    20182060            [input-port
    20192061              (lambda (loc pid cmd pipe stdf stdfd on-close)
    20202062                (and-let* ([fd (connect-parent loc pipe stdf stdfd)])
    2021                   (##sys#custom-input-port loc cmd fd DEFAULT-INPUT-BUFFER-SIZE on-close) ) )]
     2063                  (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close) ) )]
    20222064            [output-port
    20232065              (lambda (loc pid cmd pipe stdf stdfd on-close)
    20242066                (and-let* ([fd (connect-parent loc pipe stdf stdfd)])
    2025                   (##sys#custom-output-port loc cmd fd DEFAULT-OUTPUT-BUFFER-SIZE on-close) ) )] )
     2067                  (##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close) ) )] )
    20262068          (lambda (loc cmd args env stdoutf stdinf stderrf)
    20272069            (receive [inpipe outpipe errpipe pid]
    2028                        (child loc cmd args env stdoutf stdinf stderrf)
     2070                       (spawn loc cmd args env stdoutf stdinf stderrf)
    20292071              ;When shared assume already "closed", since only created ports
    20302072              ;should be explicitly closed, and when one is closed we want
  • chicken/posixwin.scm

    r4232 r4340  
    251251#define C_setvbuf(p, m, s)  C_fix(setvbuf(C_port_file(p), NULL, C_unfix(m), C_unfix(s)))
    252252#define C_access(fn, m)     C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
    253 #define C_pipe(d)           C_fix(_pipe(C_pipefds, PIPE_BUF, O_BINARY))
     253#define C_pipe(d, m)        C_fix(_pipe(C_pipefds, PIPE_BUF, C_unfix(m)))
    254254#define C_close(fd)         C_fix(close(C_unfix(fd)))
    255255
     
    864864(define-foreign-variable _o_binary int "O_BINARY")
    865865(define-foreign-variable _o_text int "O_TEXT")
     866(define-foreign-variable _o_noinherit int "O_NOINHERIT")
    866867
    867868(define open/rdonly _o_rdonly)
     
    876877(define open/binary _o_binary)
    877878(define open/text _o_text)
     879(define open/noinherit _o_noinherit)
    878880
    879881(define-foreign-variable _s_irusr int "S_IREAD")
     
    930932      (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
    931933        (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
    932           (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or byte-vector" buf) )
     934          (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
    933935        (let ([n (##core#inline "C_read" fd buf size)])
    934936          (when (eq? -1 n)
     
    941943    (##sys#check-exact fd 'file-write)
    942944    (unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))
    943       (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or byte-vector" buffer) )
     945      (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )
    944946    (let ([size (if (pair? size) (car size) (##sys#size buffer))])
    945947      (##sys#check-exact size 'file-write)
     
    10981100(define (directory? fname)
    10991101  (##sys#check-string fname 'directory?)
    1100   (let ((info (##sys#file-info (##sys#expand-home-path fname))))
     1102  (let ((info (##sys#file-info
     1103                (##sys#platform-fixup-pathname (##sys#expand-home-path fname)))))
    11011104    (and info (fx= 1 (##sys#slot info 4))) ) )
    11021105
     
    12021205
    12031206(define create-pipe
    1204     (lambda ()
    1205       (when (fx< (##core#inline "C_pipe" #f) 0)
     1207    (lambda (#!optional (mode (fxior open/binary open/noinherit)))
     1208      (when (fx< (##core#inline "C_pipe" #f mode) 0)
    12061209        (##sys#update-errno)
    12071210        (##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") )
  • chicken/runtime.c

    r4232 r4340  
    432432  heap_size_changed,
    433433  chicken_is_running,
    434   chicken_ran_once;
     434  chicken_ran_once,
     435  callback_continuation_level;
    435436static C_TLS unsigned int
    436437  mutation_count,
     
    719720  current_module_handle = NULL;
    720721  reload_lf = NULL;
     722  callback_continuation_level = 0;
    721723  C_randomize(time(NULL));
    722724  return 1;
     
    12551257{
    12561258  if(C_temporary_stack_bottom != C_temporary_stack)
    1257     panic(C_text("invalid level of temporary stack"));
     1259    panic(C_text("invalid temporary stack level"));
    12581260
    12591261  if(!chicken_is_initialized)
     
    14791481
    14801482  case C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR:
    1481     msg = C_text("bad argument type - not a bytevector");
     1483    msg = C_text("bad argument type - not a blob");
    14821484    c = 1;
    14831485    break;
     
    16281630 
    16291631  C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), p);
    1630   return 0;
     1632  return ++callback_continuation_level;
    16311633}
    16321634
     
    16341636C_word C_fcall C_restore_callback_continuation(void)
    16351637{
     1638  /* obsolete, but retained for keeping old code working */
    16361639  C_word p = C_block_item(callback_continuation_stack_symbol, 0),
    16371640         k;
     
    16411644
    16421645  C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));
     1646  --callback_continuation_level;
     1647  return k;
     1648}
     1649
     1650
     1651C_word C_fcall C_restore_callback_continuation2(int level)
     1652{
     1653  C_word p = C_block_item(callback_continuation_stack_symbol, 0),
     1654         k;
     1655
     1656#ifndef C_UNSAFE_RUNTIME
     1657  if(level != callback_continuation_level || C_immediatep(p) || C_block_header(p) != C_PAIR_TAG)
     1658    panic(C_text("unbalanced callback continuation stack"));
     1659#endif
     1660
     1661  k = C_u_i_car(p);
     1662
     1663  C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));
     1664  --callback_continuation_level;
    16431665  return k;
    16441666}
     
    16511673    *a = C_alloc(2),
    16521674    k = C_closure(&a, 1, (C_word)callback_return_continuation);
     1675  int old = chicken_is_running;
     1676
     1677#ifndef C_UNSAFE_RUNTIME
     1678  if(old && C_block_item(callback_continuation_stack_symbol, 0) == C_SCHEME_END_OF_LIST)
     1679    panic(C_text("callback invoked in non-safe context"));
     1680#endif
    16531681
    16541682  C_memcpy(&prev, &C_restart, sizeof(jmp_buf));
     
    16571685
    16581686  if(!C_setjmp(C_restart)) C_do_apply(argc, closure, k);
    1659 
    1660   chicken_is_running = 0;
    16611687
    16621688  if(!callback_returned_flag) (C_restart_trampoline)(C_restart_address);
     
    16661692  }
    16671693 
     1694  chicken_is_running = old;
    16681695  return C_restore;
    16691696}
     
    21762203  C_SCHEME_BLOCK *pbv = C_malloc(len + sizeof(C_header));
    21772204
    2178   if(pbv == NULL) panic(C_text("out of memory - can not allocate permanent bytevector"));
     2205  if(pbv == NULL) panic(C_text("out of memory - can not allocate permanent blob"));
    21792206
    21802207  pbv->header = C_BYTEVECTOR_TYPE | len;
     
    88048831  C_apply(4, C_SCHEME_UNDEFINED, k, proc, C_SCHEME_END_OF_LIST);
    88058832}
     8833
     8834
     8835/* fixnum arithmetic with overflow detection (from "Hacker's Delight" by Hank Warren) */
     8836
     8837C_regparm C_word C_i_o_fixnum_plus(C_word n1, C_word n2)
     8838{
     8839  C_word x1 = C_unfix(n1);
     8840  C_word x2 = C_unfix(n2);
     8841  C_word s = x1 + x2;
     8842 
     8843  if((((s ^ x1) & (s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;
     8844  else return C_fix(s);
     8845}
     8846
     8847C_regparm C_word C_i_o_fixnum_difference(C_word n1, C_word n2)
     8848{
     8849  C_word x1 = C_unfix(n1);
     8850  C_word x2 = C_unfix(n2);
     8851  C_word s = x1 - x2;
     8852 
     8853  if((((s ^ x1) & ~(s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;
     8854  else return C_fix(s);
     8855}
  • chicken/scheduler.scm

    r2776 r4340  
    333333              (##sys#setslot a 1 (cons t (cdr a)))
    334334              (loop (cdr lst)) ) ) ) )
    335   (if i/o
    336       (##sys#fdset-input-set fd)
    337       (##sys#fdset-output-set fd) )
     335  (case i/o
     336    ((#t #:input) (##sys#fdset-input-set fd))
     337    ((#f #:output) (##sys#fdset-output-set fd))
     338    ((#:all)
     339     (##sys#fdset-input-set fd)
     340     (##sys#fdset-output-set fd) ) )
    338341  (##sys#setslot t 3 'blocked)
    339342  (##sys#setslot t 11 (cons fd i/o)) )
  • chicken/srfi-4.scm

    r3033 r4340  
    505505    (lambda (v)
    506506      (##sys#check-structure v tag loc)
    507       (##core#inline "C_slot" v 1) ) )
     507      (##sys#slot v 1) ) )
     508
     509  (define (pack-copy tag loc)
     510    (lambda (v)
     511      (##sys#check-structure v tag loc)
     512      (let* ((old (##sys#slot v 1))
     513             (new (make-string (##sys#size old))))
     514        (##core#inline "C_copy_block" old new) ) ) )
    508515
    509516  (define (unpack tag sz loc)
    510517    (lambda (str)
    511518      (##sys#check-byte-vector str loc)
    512       (let ([len (##core#inline "C_block_size" str)])
     519      (let ([len (##sys#size str)])
    513520        (if (or (eq? #t sz)
    514                 (##core#inline "C_eqp" 0 (##core#inline "C_fixnum_modulo" len sz)))
     521                (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
    515522            (##sys#make-structure tag str)
    516             (##sys#error loc "bytevector does not have correct size for packing" tag len sz) ) ) ) )
    517 
    518   (set! u8vector->byte-vector (pack 'u8vector 'u8vector->byte-vector))
    519   (set! s8vector->byte-vector (pack 's8vector 's8vector->byte-vector))
    520   (set! u16vector->byte-vector (pack 'u16vector 'u16vector->byte-vector))
    521   (set! s16vector->byte-vector (pack 's16vector 's16vector->byte-vector))
    522   (set! u32vector->byte-vector (pack 'u32vector 'u32vector->byte-vector))
    523   (set! s32vector->byte-vector (pack 's32vector 's32vector->byte-vector))
    524   (set! f32vector->byte-vector (pack 'f32vector 'f32vector->byte-vector))
    525   (set! f64vector->byte-vector (pack 'f64vector 'f64vector->byte-vector))
    526 
    527   (set! byte-vector->u8vector (unpack 'u8vector #t 'byte-vector->u8vector))
    528   (set! byte-vector->s8vector (unpack 's8vector #t 'byte-vector->s8vector))
    529   (set! byte-vector->u16vector (unpack 'u16vector 2 'byte-vector->u16vector))
    530   (set! byte-vector->s16vector (unpack 's16vector 2 'byte-vector->s16vector))
    531   (set! byte-vector->u32vector (unpack 'u32vector 4 'byte-vector->u32vector))
    532   (set! byte-vector->s32vector (unpack 's32vector 4 'byte-vector->s32vector))
    533   (set! byte-vector->f32vector (unpack 'f32vector 4 'byte-vector->f32vector))
    534   (set! byte-vector->f64vector (unpack 'f64vector 8 'byte-vector->f64vector)) )
     523            (##sys#error loc "blob does not have correct size for packing" tag len sz) ) ) ) )
     524
     525  (define (unpack-copy tag sz loc)
     526    (lambda (str)
     527      (##sys#check-byte-vector str loc)
     528      (let* ((len (##sys#size str))
     529            (new (make-string len)))
     530        (if (or (eq? #t sz)
     531                (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
     532            (##sys#make-structure
     533             tag
     534             (##core#inline "C_copy_block" str new) )
     535            (##sys#error loc "blob does not have correct size for packing" tag len sz) ) ) ) )   
     536
     537  (set! u8vector->byte-vector (pack 'u8vector 'u8vector->byte-vector)) ; DEPRECATED
     538  (set! s8vector->byte-vector (pack 's8vector 's8vector->byte-vector)) ; DEPRECATED
     539  (set! u16vector->byte-vector (pack 'u16vector 'u16vector->byte-vector)) ; DEPRECATED
     540  (set! s16vector->byte-vector (pack 's16vector 's16vector->byte-vector)) ; DEPRECATED
     541  (set! u32vector->byte-vector (pack 'u32vector 'u32vector->byte-vector)) ; DEPRECATED
     542  (set! s32vector->byte-vector (pack 's32vector 's32vector->byte-vector)) ; DEPRECATED
     543  (set! f32vector->byte-vector (pack 'f32vector 'f32vector->byte-vector)) ; DEPRECATED
     544  (set! f64vector->byte-vector (pack 'f64vector 'f64vector->byte-vector)) ; DEPRECATED
     545
     546  (set! u8vector->blob/shared (pack 'u8vector 'u8vector->blob/shared))
     547  (set! s8vector->blob/shared (pack 's8vector 's8vector->blob/shared))
     548  (set! u16vector->blob/shared (pack 'u16vector 'u16vector->blob/shared))
     549  (set! s16vector->blob/shared (pack 's16vector 's16vector->blob/shared))
     550  (set! u32vector->blob/shared (pack 'u32vector 'u32vector->blob/shared))
     551  (set! s32vector->blob/shared (pack 's32vector 's32vector->blob/shared))
     552  (set! f32vector->blob/shared (pack 'f32vector 'f32vector->blob/shared))
     553  (set! f64vector->blob/shared (pack 'f64vector 'f64vector->blob/shared))
     554
     555  (set! u8vector->blob (pack-copy 'u8vector 'u8vector->blob))
     556  (set! s8vector->blob (pack-copy 's8vector 's8vector->blob))
     557  (set! u16vector->blob (pack-copy 'u16vector 'u16vector->blob))
     558  (set! s16vector->blob (pack-copy 's16vector 's16vector->blob))
     559  (set! u32vector->blob (pack-copy 'u32vector 'u32vector->blob))
     560  (set! s32vector->blob (pack-copy 's32vector 's32vector->blob))
     561  (set! f32vector->blob (pack-copy 'f32vector 'f32vector->blob))
     562  (set! f64vector->blob (pack-copy 'f64vector 'f64vector->blob))
     563
     564  (set! byte-vector->u8vector (unpack 'u8vector #t 'byte-vector->u8vector)) ; DEPRECATED
     565  (set! byte-vector->s8vector (unpack 's8vector #t 'byte-vector->s8vector)) ; DEPRECATED
     566  (set! byte-vector->u16vector (unpack 'u16vector 2 'byte-vector->u16vector)) ; DEPRECATED
     567  (set! byte-vector->s16vector (unpack 's16vector 2 'byte-vector->s16vector)) ; DEPRECATED
     568  (set! byte-vector->u32vector (unpack 'u32vector 4 'byte-vector->u32vector)) ; DEPRECATED
     569  (set! byte-vector->s32vector (unpack 's32vector 4 'byte-vector->s32vector)) ; DEPRECATED
     570  (set! byte-vector->f32vector (unpack 'f32vector 4 'byte-vector->f32vector)) ; DEPRECATED
     571  (set! byte-vector->f64vector (unpack 'f64vector 8 'byte-vector->f64vector)) ; DEPRECATED
     572
     573  (set! blob->u8vector/shared (unpack 'u8vector #t 'blob->u8vector/shared))
     574  (set! blob->s8vector/shared (unpack 's8vector #t 'blob->s8vector/shared))
     575  (set! blob->u16vector/shared (unpack 'u16vector 2 'blob->u16vector/shared))
     576  (set! blob->s16vector/shared (unpack 's16vector 2 'blob->s16vector/shared))
     577  (set! blob->u32vector/shared (unpack 'u32vector 4 'blob->u32vector/shared))
     578  (set! blob->s32vector/shared (unpack 's32vector 4 'blob->s32vector/shared))
     579  (set! blob->f32vector/shared (unpack 'f32vector 4 'blob->f32vector/shared))
     580  (set! blob->f64vector/shared (unpack 'f64vector 8 'blob->f64vector/shared))
     581
     582  (set! blob->u8vector (unpack-copy 'u8vector #t 'blob->u8vector))
     583  (set! blob->s8vector (unpack-copy 's8vector #t 'blob->s8vector))
     584  (set! blob->u16vector (unpack-copy 'u16vector 2 'blob->u16vector))
     585  (set! blob->s16vector (unpack-copy 's16vector 2 'blob->s16vector))
     586  (set! blob->u32vector (unpack-copy 'u32vector 4 'blob->u32vector))
     587  (set! blob->s32vector (unpack-copy 's32vector 4 'blob->s32vector))
     588  (set! blob->f32vector (unpack-copy 'f32vector 4 'blob->f32vector))
     589  (set! blob->f64vector (unpack-copy 'f64vector 8 'blob->f64vector)) )
    535590
    536591
  • chicken/support.scm

    r3839 r4340  
    910910              (if unsafe param `(##sys#foreign-fixnum-argument ,param))]
    911911             [(float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param))]
    912              [(pointer byte-vector scheme-pointer) ; pointer is DEPRECATED
     912             [(pointer byte-vector blob scheme-pointer) ; pointer and byte-vector are DEPRECATED
    913913              (let ([tmp (gensym)])
    914914                `(let ([,tmp ,param])
     
    918918                            `(##sys#foreign-block-argument ,tmp) )
    919919                       '#f) ) ) ]
    920              [(nonnull-pointer nonnull-scheme-pointer nonnull-byte-vector) ; nonnull-pointer is DEPRECATED
     920             [(nonnull-pointer nonnull-scheme-pointer nonnull-blob nonnull-byte-vector) ; nonnull-pointer and nonnull-blob are DEPRECATED
    921921              (if unsafe
    922922                  param
  • chicken/tcp.scm

    r4232 r4340  
    546546                (when (eq? f -1) (fail))
    547547                (unless (eq? f 1)
    548                   ;(##sys#thread-block-for-i/o! ##sys#current-thread s #t)
     548                  (##sys#thread-block-for-i/o! ##sys#current-thread s #:all)
    549549                  (yield)
    550550                  (loop) ) ) )
  • chicken/tests/runtests.sh

    r4232 r4340  
    11#!/bin/sh
    2 # runtests.sh 
     2# runtests.sh
    33
    44set -e
     
    1010../csi -w -s library-tests.scm
    1111
     12echo "======================================== fixnum tests ..."
     13$compile fixnum-tests.scm && ./a.out
     14
    1215echo "======================================== srfi-18 tests ..."
    1316../csi -w -s srfi-18-tests.scm
    14 
    15 echo "======================================== ffi tests ..."
    16 $compile ffi-test.scm && ./a.out
    1717
    1818echo "======================================== path tests ..."
  • fp/trunk/fp.setup

    r3947 r4340  
    1616
    1717(install-extension
    18  'fp2scheme
    19  '("fp2scheme.so" "stdlib.fp.so")
     18 'fp
     19 `("fp2scheme.so" "stdlib.fp.so"
     20   ("fp" ,(make-pathname (installation-prefix) "bin/fp")))
    2021 '((documentation "fp.html")
    2122   (version 2.1)
    2223   (exports "fp2scheme.exports")
    23    (examples "stdlib.fp") ) )
    24 
    25 (install-program 'fp-program "fp")
     24   (examples "stdlib.fp" "fpc.fp" "lex.fp" "parse.fp" "palindrome.fp") ) )
  • fp/trunk/grammar.scm

    r4138 r4340  
    22
    33
    4 (use lalr)
     4(load "lalr.scm")
    55
    66(lalr-parser
  • wiki/faq

    r4105 r4340  
    435435{{fp=}} {{fp>}} {{fp>=}} {{fpneg}} {{fpmax}} {{fpmin}}
    436436{{arithmetic-shift}} {{signum}} {{flush-output}} {{thread-specific}} {{thread-specific-set!}}
    437 {{not-pair?}} {{null-list?}} {{print}} {{print*}} {{u8vector->bytevector}}
    438 {{s8vector->bytevector}} {{u16vector->bytevector}} {{s16vector->bytevector}}
    439 {{u32vector->bytevector}}
    440 {{s32vector->bytevector}} {{f32vector->bytevector}} {{f64vector->bytevector}} {{block-ref}}
    441 {{byte-vector-length}}
     437{{not-pair?}} {{null-list?}} {{print}} {{print*}} {{u8vector->blob/shared}}
     438{{s8vector->blob/shared}} {{u16vector->blob/shared}} {{s16vector->blob/shared}}
     439{{u32vector->blob/shared}}
     440{{s32vector->blob/shared}} {{f32vector->blob/shared}} {{f64vector->blob/shared}} {{block-ref}}
     441{{blob-size}}
    442442{{u8vector-length}}
    443443{{s8vector-length}}
Note: See TracChangeset for help on using the changeset viewer.