Changeset 4232 in project


Ignore:
Timestamp:
05/20/07 00:32:05 (13 years ago)
Author:
felix winkelmann
Message:

various fixes, alexpander update

Files:
1 added
42 edited

Legend:

Unmodified
Added
Removed
  • alexpander/alexpander-chicken-macros.scm

    r3817 r4232  
    392392                    (begin . cmd-or-defs*)
    393393                    (cond-expand . rest-clauses))))))
     394
     395(define-syntax fluid-let
     396  (syntax-rules ()
     397    ((_ ((v1 e1) ...) b1 b2 ...)
     398     (fluid-let "temps" () ((v1 e1) ...) b1 b2 ...))
     399    ((_ "temps" (t ...) ((v1 e1) x ...) b1 b2 ...)
     400     (let ((temp e1))
     401       (fluid-let "temps" ((temp e1 v1) t ...) (x ...) b1 b2 ...)))
     402    ((_ "temps" ((t e v) ...) () b1 b2 ...)
     403     (let-syntax ((swap!
     404                   (syntax-rules ()
     405                     ((swap! a b)
     406                      (let ((tmp a))
     407                        (set! a b)
     408                        (set! b tmp))))))
     409       (dynamic-wind
     410        (lambda ()
     411          (swap! t v) ...)
     412        (lambda ()
     413          b1 b2 ...)
     414        (lambda ()
     415          (swap! t v) ...))))))
  • alexpander/alexpander.setup

    r3817 r4232  
    33 'alexpander
    44 '("alexpander.so" "alexpander-chicken-macros.scm")
    5  '((version "1.58.8")
     5 '((version "1.58.9")
    66   (documentation "alexpander.html")
    77   (require-at-runtime records)
  • alexpander/doc.scm

    r3817 r4232  
    4343
    4444     (history
     45      (version "1.58.9" "added " (tt "fluid-let"))
    4546      (version "1.58.8" "added toplevel " (tt "include") " and " (tt "cond-expand"))
    4647      (version "1.58.7" "added some non-standard macros, uses records egg now")
     
    409410cond-expand
    410411include
     412fluid-let
    411413
    412414`include' should only be used at toplevel. `cond-expand' recognizes the following
  • chicken/CMakeLists.txt

    r3839 r4232  
    537537IF(NOT EXTANT_CHICKEN)
    538538  FIND_PROGRAM(EXTANT_CHICKEN
    539     NAMES chicken-static chicken
     539    NAMES chicken chicken-static
    540540    PATHS $ENV{CHICKEN_HOME} $ENV{CHICKEN_HOME}/bin
    541541  )
     
    982982
    983983IF(${CMAKE_SYSTEM_NAME} MATCHES "Darwin")
     984  SET(MACOSX TRUE)
     985ELSE(${CMAKE_SYSTEM_NAME} MATCHES "Darwin")
     986  SET(MACOSX FALSE)
     987ENDIF(${CMAKE_SYSTEM_NAME} MATCHES "Darwin")
     988
     989IF(MACOSX)
    984990  SET(SHARED_FLAGS "${SHARED_FLAGS} -fno-common -no-cpp-precomp")
    985 ENDIF(${CMAKE_SYSTEM_NAME} MATCHES "Darwin")
     991ENDIF(MACOSX)
    986992
    987993# Unix platforms can get into trouble if they don't have -lm.
     
    16791685# To work around these problems, we build all static libs and exes
    16801686# in a subdirectory.  Then there are no issues.
    1681 
    1682 ADD_SUBDIRECTORY(static)
     1687#
     1688# Apple has depreciated static linkage on Mac OS X, so we don't build or install static libraries
     1689# or executables on that platform at all.
     1690
     1691IF(NOT MACOSX)
     1692  ADD_SUBDIRECTORY(static)
     1693ENDIF(NOT MACOSX)
    16831694
    16841695
  • chicken/README

    r3839 r4232  
    33  (c)2000-2007 Felix L. Winkelmann
    44
    5   Version 2.610
     5  Version 2.615
    66
    77
  • chicken/benchmarks/fib.scm

    r1016 r4232  
    66      (+ (fib (- n 1)) (fib (- n 2))) ) )
    77
    8 (time (fib 30))
     8(time (pp (fib 40)))
  • chicken/boot/CMakeLists.txt

    r2926 r4232  
    77
    88# Files built here are only used for the bootstrap.  They are never installed.
    9 # Consequently, we don't need to build everything.  We only build static
    10 # libraries and executables, no need to fool with anything more complicated.
    11 # We build:
     9# Consequently, we don't need to build everything.
     10# Apple only officially supports dynamic linking on Mac OS X.  To simplify maintenance,
     11# we use dynamic linking for the bootstrap on all operating systems.  We build:
    1212#  libchicken-boot
    1313#  chicken-boot
     
    105105ADD_CUSTOM_TARGET(libchicken-boot-c DEPENDS ${LIBCHICKEN_BOOT_SOURCES})
    106106
    107 ADD_LIBRARY(libchicken-boot STATIC ${LIBCHICKEN_BOOT_SOURCES} ${PCRE_HEADER})
     107ADD_LIBRARY(libchicken-boot SHARED ${LIBCHICKEN_BOOT_SOURCES} ${PCRE_HEADER})
    108108SET_TARGET_PROPERTIES(libchicken-boot PROPERTIES
    109   COMPILE_FLAGS "-DC_BUILDING_LIBCHICKEN ${STATIC_FLAGS}"
     109  COMPILE_FLAGS "-DC_BUILDING_LIBCHICKEN ${SHARED_FLAGS}"
    110110  OUTPUT_NAME chicken-boot)
    111111IF(MSVC)
    112112  SET_TARGET_PROPERTIES(libchicken-boot PROPERTIES PREFIX "lib")
    113113ENDIF(MSVC)
    114 TARGET_LINK_LIBRARIES(libchicken-boot ${MORE_STATIC_LIBS})
     114TARGET_LINK_LIBRARIES(libchicken-boot libpcre-for-shared ${MORE_LIBS})
    115115ADD_DEPENDENCIES(libchicken-boot libchicken-boot-c)
    116116
     
    124124
    125125ADD_EXECUTABLE(chicken-boot ${CHICKEN_BOOT_SOURCES})
    126 SET_TARGET_PROPERTIES(chicken-boot PROPERTIES COMPILE_FLAGS "${STATIC_FLAGS}")
    127 TARGET_LINK_LIBRARIES(chicken-boot libchicken-boot libpcre-for-static)
     126SET_TARGET_PROPERTIES(chicken-boot PROPERTIES COMPILE_FLAGS "${SHARED_FLAGS}")
     127TARGET_LINK_LIBRARIES(chicken-boot libchicken-boot)
    128128ADD_DEPENDENCIES(chicken-boot chicken-boot-c)
    129129
  • chicken/build.scm

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

    r3839 r4232  
    1 2.610
     12.615
  • chicken/chicken-more-macros.scm

    r3839 r4232  
    893893
    894894
    895 ;;;; SRFI-31
     895;;; SRFI-31
    896896
    897897(define-macro (rec head . args)
     
    915915
    916916
    917 ;;;; Register features provided by this file
     917;;; Not for general use, yet
     918
     919(define-macro (define-compiler-macro head . body)
     920  (define (bad)
     921    (syntax-error 'define-compiler-macro "invalid compiler macro definition" head) )
     922  (unless ##compiler#compiler-macro-table
     923    (set! ##compiler#compiler-macro-table (make-vector 301 '())) )
     924  (if (and (pair? head) (symbol? (car head)))
     925      (cond ((memq 'compiling ##sys#features)
     926             (warning "compile macros are not available in interpreted code"
     927                      (car head) )
     928             '(void) )
     929            (else
     930             (let* ((wvar (gensym))
     931                    (llist
     932                     (let loop ((llist head))
     933                       (cond ((not (pair? llist)) llist)
     934                             ((eq? #:whole (car llist))
     935                              (unless (pair? (cdr llist)) (bad))
     936                              (set! wvar (cadr llist))
     937                              (cddr llist) )
     938                             (else (cons (car llist) (loop (cdr llist)))) ) ) ) )
     939               (##sys#hash-table-set!
     940                ##compiler#compiler-macro-table
     941                (car head)
     942                (eval `(lambda (,wvar) (apply (lambda ,llist ,@body) ,wvar))) )
     943               '(void) ) ) )
     944      (bad) ) )
     945
     946
     947;;; Register features provided by this file
    918948
    919949(eval-when (compile load eval)
  • chicken/chicken-profile.scm

    r2776 r4232  
    3636(declare
    3737  (block)
    38   (uses srfi-1))
    39 
     38  (uses srfi-1
     39        srfi-13))
    4040
    4141(define sort-by #f)
    4242(define file #f)
    4343(define no-unused #f)
     44(define seconds-digits 3)
     45(define average-digits 3)
     46(define percent-digits 3)
     47(define top 0)
    4448
    4549(define (print-usage)
    46   (display #<<EOF
     50  (display #<#EOF
    4751Usage: chicken-profile [FILENAME | OPTION] ...
    4852
     
    5155 -sort-by-avg              sort output by average procedure execution time
    5256 -sort-by-name             sort output alphabetically by procedure name
     57 -decimals DDD             set number of decimals for seconds, average and
     58                           percent columns (three digits, default: #{seconds-digits}#{average-digits}#{percent-digits})
    5359 -no-unused                remove procedures that are never called
     60 -top N                    display only the top N entries
    5461 -help                     show this text and exit
    5562 -version                  show version and exit
     
    7077        (let ([arg (car args)]
    7178              [rest (cdr args)] )
     79          (define (next-arg)
     80            (if (null? rest)
     81                (error "missing argument to option" arg)
     82                (let ((narg (car rest)))
     83                  (set! rest (cdr rest))
     84                  narg)))
     85          (define (next-number)
     86            (let ((n (string->number (next-arg))))
     87              (if (and n (> n 0)) n (error "invalid argument to option" arg))))
    7288          (match arg
    7389            [(or "-h" "-help" "--help") (print-usage)]
     
    7995             (exit) ]
    8096            ["-no-unused" (set! no-unused #t)]
     97            ["-top" (set! top (next-number))]
    8198            ["-sort-by-calls" (set! sort-by sort-by-calls)]
    8299            ["-sort-by-time" (set! sort-by sort-by-time)]
    83100            ["-sort-by-avg" (set! sort-by sort-by-avg)]
    84101            ["-sort-by-name" (set! sort-by sort-by-name)]
     102            ["-decimals" (set-decimals (next-arg))]
    85103            [_ (cond [(and (> (string-length arg) 1) (char=? #\- (string-ref arg 0)))
    86104                      (error "invalid option" arg) ]
     
    114132
    115133(set! sort-by sort-by-time)
     134
     135(define (set-decimals arg)
     136  (if (= (string-length arg) 3)
     137      (begin
     138        (define (arg-digit n)
     139          (let ((n (- (char->integer (string-ref arg n))
     140                      (char->integer #\0))))
     141            (if (<= 0 n 9)
     142                (if (= n 9) 8 n) ; 9 => overflow in format-real
     143                (error "invalid argument to -decimals option" arg))))
     144        (set! seconds-digits (arg-digit 0))
     145        (set! average-digits (arg-digit 1))
     146        (set! percent-digits (arg-digit 2)))
     147      (error "invalid argument to -decimals option" arg)))
    116148
    117149(define (read-profile)
     
    130162        (string-append str pad) ) ) )
    131163
    132 (define (format-real n cols fcols)
    133   (let ((an (abs n)))
    134     (format-string
    135      (string-append
    136       (number->string (inexact->exact (truncate n)))
    137       "."
    138       (let ((fstr (format-string (substring (number->string (exact->inexact (- an (truncate an)))) 2) fcols #f #\0)))
    139         (substring fstr 0 (fxmin (string-length fstr) fcols))) )
    140      cols #t #\space) ) )
     164(define (format-real n d)
     165  (let ((exact-value (inexact->exact (truncate n))))
     166    (string-append
     167     (number->string exact-value)
     168     (if (> d 0) "." "")
     169     (substring
     170      (number->string
     171       (inexact->exact
     172        (truncate
     173         (* (- n exact-value -1) (expt 10 d)))))
     174      1 (+ d 1)))))
    141175
    142176(define (write-profile)
     
    155189                                                    ))))
    156190                      data0)
    157                      sort-by)]
    158          [line (make-string 79 #\-)] )
    159     (print (format-string "procedure" 38)
    160            " "
    161            (format-string "calls" 9 #t)
    162            " "
    163            (format-string "seconds" 9 #t)
    164            " "
    165            (format-string "average" 9 #t)
    166            " "
    167            (format-string "percent" 8 #t) )
    168     (print line)
    169     (for-each
    170      (lambda (entry)
    171        (let ([c (second entry)]
    172              [t (third entry)]
    173              [a (cadddr entry)]
    174              [p (list-ref entry 4)] )
    175          (unless (and (zero? c) no-unused)
    176            (print (format-string (##sys#symbol->qualified-string (first entry)) 38)
    177                   " "
    178                   (format-string (number->string c) 9 #t)
    179                   " "
    180                   (format-real (/ t 1000) 9 3)
    181                   " "
    182                   (format-real (/ a 1000) 9 3)
    183                   " "
    184                   (format-real p 8 4) ) ) ) )
    185      data) ) )
    186 
     191                     sort-by)])
     192    (if (< 0 top (length data))
     193        (set! data (take data top)))
     194    (set! data (map (lambda (entry)
     195                      (let ([c (second entry)]
     196                            [t (third entry)]
     197                            [a (cadddr entry)]
     198                            [p (list-ref entry 4)] )
     199                        (list (##sys#symbol->qualified-string (first entry))
     200                              (number->string c)
     201                              (format-real (/ t 1000) seconds-digits)
     202                              (format-real (/ a 1000) average-digits)
     203                              (format-real p percent-digits))))
     204                    (filter (lambda (entry) (not (and (zero? (second entry)) no-unused)))
     205                            data)))
     206    (let* ([headers (list "procedure" "calls" "seconds" "average" "percent")]
     207           [alignments (list #f #t #t #t #t)]
     208           [spacing 2]
     209           [spacer (make-string spacing #\space)]
     210           [column-widths (fold
     211                           (lambda (row max-widths)
     212                             (map max (map string-length row) max-widths))
     213                           (list 0 0 0 0 0)
     214                           (cons headers data))])
     215      (define (print-row row)
     216        (print (string-join (map format-string row column-widths alignments) spacer)))
     217      (print-row headers)
     218      (print (make-string (+ (reduce + 0 column-widths)
     219                             (* spacing (- (length alignments) 1)))
     220                          #\-))
     221      (for-each print-row data))))
     222 
    187223(run (command-line-arguments))
  • chicken/chicken-setup.scm

    r3839 r4232  
    6060#endif
    6161
    62 #ifdef _WIN32
    63 /* It is an error to include <windows.h> prematurely.  For instance,
    64  * <winsock2.h> must be included before <windows.h> */
    65 # include <windows.h>
    66 static void create_directory(char *pathname)
    67 {
    68   CreateDirectory(pathname, NULL);
    69 }
    70 #else
    71 static void create_directory(char *pathname) {}
    72 #endif
    73 
    7462#ifndef C_TARGET_CC
    7563# define C_TARGET_CC  C_INSTALL_CC
     
    9987
    10088(define-constant long-options
    101   '("-help" "-uninstall" "-list" "-run" "-repository" "-program-path" "-version" "-script" "-check"
     89  '("-help" "-uninstall" "-list" "-run" "-repository" "-program-path" "-version" "-script"
    10290    "-fetch" "-host" "-proxy" "-keep" "-verbose" "-csc-option" "-dont-ask" "-no-install" "-docindex" "-eval"
    10391    "-debug" "-ls" "-release" "-test" "-fetch-tree" "-tree" "-svn" "-local" "-destdir" "-revision") )
    10492
    10593(define-constant short-options
    106   '(#\h #\u #\l #\r #\R #\P #\V #\s #\C #\f #\H #\p #\k #\v #\c #\d #\n #\i #\e #\D #f #f #\t #f #f #f #f #f #f) )
     94  '(#\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) )
    10795
    10896
     
    133121
    134122(define (cross-chicken) (##sys#fudge 39))
     123
     124(define create-directory/parents
     125  (let ([create-directory create-directory])
     126    (lambda (dir)
     127      (let loop ([dir dir])
     128        (when (and dir (not (directory? dir)))
     129          (loop (pathname-directory dir))
     130          (create-directory dir))) ) ) )
    135131
    136132(define create-directory
     
    141137        (lambda (dir)
    142138          (verb dir)
    143           ((foreign-lambda void "create_directory" c-string) dir) )
     139          (create-directory/parents dir) )
    144140        (lambda (dir)
    145141          (verb dir)
     
    164160(define *dont-ask* #f)
    165161(define *rebuild-doc-index* #f)
    166 (define *check-repository* #f)
    167162(define *repository-tree* #f)
    168163(define *last-decent-host* #f)
     
    177172(define *repository-hosts* '(("www.call-with-current-continuation.org" "eggs" 80)))
    178173(define *revision* #f)
    179 (define *repository-tree-downloaded* #f)
    180174
    181175
     
    410404  -n  -no-install                don't install generated binaries and support files
    411405  -i  -docindex                  display path for documentation index
    412   -C  -check                     check for available upgrades
    413406  -e  -eval EXPRESSION           evaluate expression
    414407  -t  -test EXTENSION ...        return success if all given extensions are installed
     
    534527        (to (if (pair? from) (make-pathname to (cadr from)) to)) )
    535528    (ensure-directory to)
    536     (cond ((file-exists? from)
     529    (cond ((or (glob? from) (file-exists? from))
    537530           (run (,*copy-command* ,(quotewrap from) ,(quotewrap to))) )
    538531          (err (error "file does not exist" from))
     
    569562     (#f default)
    570563     ("so" ##sys#load-dynamic-extension)
    571      ("o" (if *windows-shell* "obj" "o"))
    572564     ("a" (if *windows-shell* "lib" "a"))
    573565     (x x) ) ) )
     
    650642  (when (setup-install-flag)
    651643    (let* ((files (check-filelist (if (list? files) files (list files))))
    652            (ppath (program-path))
     644           (ppath (if *destdir* (make-pathname *destdir* "bin") (program-path)))
    653645           (pfiles (map (lambda (f)
    654646                          (let ((from (if (pair? f) (car f) f))
     
    698690                  (run (chmod a+x ,dir)))))))
    699691
    700 (define (try-compile code #!key c++ (cc (if c++ *cxx* *cc*)) (cflags "") (ldflags "") (verb (setup-verbose-flag)) (compile-only #f))
     692(define (try-compile code #!key c++ (cc (if c++ *cxx* *cc*)) (cflags "") (ldflags "")
     693                     (verb (setup-verbose-flag)) (compile-only #f))
    701694  (let* ((fname (create-temporary-file "c"))
    702695         (oname (pathname-replace-extension fname "o"))
     
    812805                                (begin
    813806                                  (set! *repository-tree* (read i))
    814                                   (set! *repository-tree-downloaded* #t)
    815807                                  (when *debug*
    816808                                    (print "catalog:")
     
    877869
    878870(define (fetch-file ext)
    879   (define (eval-req r)
    880     (when (setup-verbose-flag)
    881       (print "Testing system:")
    882       (pp r) )
    883     (let ((f (eval r)))
    884       (when (setup-verbose-flag)
    885         (print "\t-> " f) )
    886       f) )
    887871  (define (requirements reqs)
    888872    (fold
     
    893877                      ((memq r ##sys#core-library-modules) reqs)
    894878                      (else (error "Broken dependencies: extension does not exist" r) ) ) ) )
    895              ((and *repository-tree-downloaded*
    896                    (not *windows*)
    897                    (or (zero? (current-user-id))
    898                        (not *dont-ask*) ) )
    899               (print "WARNING: executing system test retrieved through potentially insecure network:\n")
    900               (pp r)
    901               (cond ((yes-or-no?
    902                       "Do you want to execute this code ?"
    903                       (if (zero? (current-user-id)) "no" "yes") )
    904                      (requirements (eval-req r) ) )
    905                     (else
    906                      (print "Test cancelled - aborting")
    907                      (abort-setup) ) ) )
    908879             (else (requirements (eval-req r) )) ) )
    909880     '()
     
    11111082         string<?) ) )
    11121083
    1113 (define (check-for-upgrades)
    1114   (download-repository-tree)
    1115   (for-each
    1116    (match-lambda
    1117      ((name props . _)
    1118       (and-let* ((a (assq 'date props))
    1119                  (info (extension-information name)) )
    1120         (let ((infoa (assq 'release info)))
    1121           (when (or (not infoa) (string>? (cadr a) (cadr infoa)))
    1122             (print
    1123              (format-string (symbol->string name) 32)
    1124              (if infoa (conc "installed: " (cadr infoa) ", ") "")
    1125              "available: " (cadr a) ) ) ) ) ) )
    1126    *repository-tree*) )
    1127 
    11281084(define (main args)
    11291085  (define (parse-host host eggdir)
     
    12401196        (("-revision" rev . more)
    12411197         (set! *revision* rev)
    1242          (loop more) )
    1243         (("-check" . more)
    1244          (set! *check-repository* #t)
    1245          (set! anydone #t)
    12461198         (loop more) )
    12471199        (("-svn" url . more)
     
    12901242                 (printf "No setup scripts to process~%")
    12911243                 (for-each (if uinst uninstall-extension install) setups) ) ) )
    1292          (when *check-repository* (check-for-upgrades))
    12931244         (when *fetch-tree-only*
    12941245           (download-repository-tree)
  • chicken/chicken.h

    r3839 r4232  
    170170#if defined(__APPLE__) && defined(__MACH__)
    171171# define C_MACOSX
    172 /*
    173  * Darwin provides gcvt/ecvt/fcvt for compatibility with legacy code.
    174  * (They don't even have a header definition!)
    175  * Use snprintf instead.
    176  */
    177172#endif
    178173
     
    226221#endif
    227222
    228 #if defined(__linux__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__)
     223#if defined(C_MACOSX) || defined(__linux__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__)
    229224# define C_GNU_ENV
    230225#endif
  • chicken/compiler.scm

    r3839 r4232  
    208208;   boxed -> <boolean>                       If true: variable has to be boxed after closure-conversion
    209209;   contractable -> <boolean>                If true: variable names contractable procedure
    210 ;   inlinable -> <boolean>                  If true: variable names potentially inlinable procedure
     210;   inlinable -> <boolean>                   If true: variable names potentially inlinable procedure
    211211;   collapsable -> <boolean>                 If true: variable refers to collapsable constant
    212212;   removable -> <boolean>                   If true: variable is not used
     
    272272  direct-call-ids foreign-type-table first-analysis callback-names namespace-table disabled-warnings
    273273  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database! scan-toplevel-assignments
    274   compiler-warning import-table use-import-table
     274  compiler-warning import-table use-import-table compiler-macro-table
    275275  perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
    276276  reorganize-recursive-bindings substitution-table simplify-named-call inline-max-size
     
    431431(define postponed-initforms '())
    432432(define unused-variables '())
     433(define compiler-macro-table #f)
    433434
    434435
     
    973974                                        (walk `(##sys#make-locative ,sym 0 #f 'location) ae me #f) ) ) ]
    974975                                 
     976                                 ((and compiler-macro-table (##sys#hash-table-ref compiler-macro-table name)) =>
     977                                  (lambda (cm)
     978                                    (let ((cx (cm x)))
     979                                      (if (equal? cx x)
     980                                          (handle-call)
     981                                          (walk cx ae me dest)))))
     982
    975983                                 [else (handle-call)] ) ) ) ) ] ) ) ) )
    976984
  • chicken/configure.in

    r3839 r4232  
    9090AC_CHECK_DECL([__MINGW32__], [mingw_system=1])
    9191
     92dnl Check for Cygwin
     93AC_MSG_CHECKING([whether we are running on Cygwin])
     94echo
     95AC_CHECK_DECL([__CYGWIN__], [cygwin_system=1])
     96
    9297dnl Check for MinGW library path, with the all important drive letter
    9398if test -n "${mingw_system}"; then
    9499  mingw_libdir=`mingw32-gcc -print-prog-name=ld | sed 's%/lib/gcc-lib/.*%/lib%'`
    95   AC_CHECK_FILE(${mingw_libdir}/libws2_32.a, [mingw_ws2=1])
    96 fi
    97 AM_CONDITIONAL(IS_MINGW, [test -n "${mingw_ws2}"])
     100  if test "$cross_compiling" != "yes"; then
     101    AC_CHECK_FILE(${mingw_libdir}/libws2_32.a, [mingw_ws2=1])
     102  else
     103    mingw_ws2=1
     104  fi
     105fi
     106AM_CONDITIONAL(IS_MINGW, [test -n "${mingw_system}"])
    98107if test -n "${mingw_ws2}"; then
    99108  WINSOCKLIB="-L${mingw_libdir} -lws2_32"
     
    115124AC_CHECK_HEADER(windows.h, [AC_DEFINE(HAVE_WINDOWS_H,1,[Define if windows.h is useable])])
    116125AC_CHECK_HEADER(grp.h, [AC_DEFINE(HAVE_GRP_H,1,[Define if grp.h is available])])
     126
     127if test x"${cygwin_system}" = x1; then
     128  USE_LIBFFI=no
     129fi
    117130
    118131if test x"$USE_LIBFFI" = xyes; then
  • chicken/csc-trans

    r3839 r4232  
    1313OUTPUT=-
    1414ALL=0
    15 while getopts ":a23ufbihprcotl:" opt; do
     15while getopts ":a23ufbihprcotlI:" opt; do
    1616   case $opt in
    1717      a ) ALL="1";;
     
    2525      b ) CSC_OPTS="$CSC_OPTS -block";;
    2626      f ) CSC_OPTS="$CSC_OPTS -fixnum-arithmetic";;
    27       i ) CSC_OPTS="$CSC_OPTS -disable-interrupts";;
     27      i ) CSC_OPTS="$CSC_OPTS -inline";;
     28      I ) CSC_OPTS="$CSC_OPTS -disable-interrupts";;
    2829      2 ) CSC_OPTS="$CSC_OPTS -O2";;
    2930      3 ) CSC_OPTS="$CSC_OPTS -O3";;
  • chicken/csc.scm

    r3839 r4232  
    129129      default) )
    130130
     131(define (quotewrap str)
     132  (if (string-any char-whitespace? str)
     133      (string-append "\"" str "\"")
     134      str) )
     135
    131136(define home
    132137  (or (getenv "CHICKEN_HOME")
     
    139144
    140145(define (homize str) (make-pathname home str))
    141 
    142 (define (quotewrap str)
    143   (if (string-any char-whitespace? str)
    144       (string-append "\"" str "\"")
    145       str) )
    146146
    147147(define translator
     
    192192(if win
    193193    (begin
     194      ; Windows cmd parsing precludes quoting anything but the command!
     195      ; This makes driving the various translators with whitespace embedded
     196      ; filenames impossible.
    194197      (define (cleanup-filename s) (string-translate s "/" "\\")) ; we need this to please the MSVC tools
    195198      (define default-compilation-optimization-options '("/nologo"))
     
    198201      (define best-compilation-optimization-options '("/O2" "/nologo")) )
    199202    (begin
    200       (define (cleanup-filename s) s)
     203      (define cleanup-filename
     204        (if (not mingw)
     205            (lambda (s) (quotewrap s)) ; allow filenames w/ whitespace
     206            (lambda (s) s)))
    201207      (define default-compilation-optimization-options (string-split (if host-mode INSTALL_CFLAGS TARGET_CFLAGS)))
    202208      (define best-compilation-optimization-options default-compilation-optimization-options)
     
    372378          (cons* (string-append
    373379                  "/I"
    374                   (if host-mode INSTALL_INCLUDE_HOME TARGET_INCLUDE_HOME)
    375                  (if (eq? (c-runtime) 'dynamic) '("/MD") '())) ) )
     380                  (if host-mode INSTALL_INCLUDE_HOME TARGET_INCLUDE_HOME))
     381                 (if (eq? (c-runtime) 'dynamic) '("/MD") '())) )
    376382      (if include-dir (list "-I" include-dir) '())) )
    377383
     
    547553    -libs                       show required libraries and exit
    548554    -cc-name                    show name of default C compiler used
     555    -cxx-name                   show name of default C++ compiler used
    549556    -ld-name                    show name of default linker used
    550557    -dry-run                    just show commands executed, don't run them
     
    635642                 (printf "Warning: output file will overwrite source file `~A' - renaming source to `~A.old'~%"
    636643                         target-filename target-filename)
    637                  (unless (zero? (system* (sprintf "mv ~A ~A.old" target-filename target-filename)))
     644                 (unless (zero? ($system (sprintf "mv ~A ~A.old" target-filename target-filename)))
    638645                   (exit last-exit-code) ) )
    639646               (run-linking)) ) ]
     
    672679                (set! show-ldflags #t) ]
    673680               [(-cc-name) (print compiler) (exit 0)]
     681               [(-cxx-name) (print c++-compiler) (exit 0)]
    674682               [(-ld-name) (print linker) (exit 0)]
    675683               [(-home) (print home) (exit 0)]
     
    856864                  (let ([x (with-input-from-file cscf read-line)])
    857865                    (or (eof-object? x) (string=? "#%eof" x)) ) )
    858          (delete-file* cscf) )
     866         ($delete-file cscf) )
    859867       (let ([fc (pathname-replace-extension
    860868                  (if (= 1 (length scheme-files))
     
    865873                        (else "c") ) ) ] )
    866874         (unless (zero?
    867                   (system*
     875                  ($system
    868876                   (string-intersperse
    869                     (cons* translator f
     877                    (cons* translator (cleanup-filename f)
    870878                           (append
    871879                            (if to-stdout
    872880                                '("-to-stdout")
    873                                 `("-output-file" ,fc) )
     881                                `("-output-file" ,(cleanup-filename fc)) )
    874882                            (if (or static static-libs static-extensions)
    875883                                (map (lambda (e) (conc "-uses " e)) required-extensions)
     
    887895                (match-lambda
    888896                  [('post-process commands ...)
    889                    (for-each system* commands) ]
     897                   (for-each $system commands) ]
    890898                  [('c-options opts ...)
    891899                   (set! compile-options (append compile-options opts)) ]
     
    894902                  [x (error "invalid entry in csc control file" x)] )
    895903                (read-file) ) ) )
    896            (delete-file* cscf) ) ) ) )
     904           ($delete-file cscf) ) ) ) )
    897905   (reverse scheme-files) )
    898   (unless keep-files (for-each delete-file* generated-scheme-files)) )
     906  (unless keep-files (for-each $delete-file generated-scheme-files)) )
    899907
    900908
     
    906914     (let ([fo (pathname-replace-extension f object-extension)])
    907915       (unless (zero?
    908                 (system*
     916                ($system
    909917                 (string-intersperse
    910918                  (list (cond (cpp-mode c++-compiler)
     
    918926       (set! object-files (cons fo object-files)) ) )
    919927   (reverse c-files) )
    920   (unless keep-files (for-each delete-file* generated-c-files)) )
     928  (unless keep-files (for-each $delete-file generated-c-files)) )
    921929
    922930(define (compiler-options)
     
    939947                                (if gui gui-shared-library-files shared-library-files) ) ) ) ] )
    940948    (unless (zero?
    941              (system*
     949             ($system
    942950              (string-intersperse
    943951               (cons* (cond (cpp-mode c++-linker)
     
    950958      (exit last-exit-code) )
    951959    (when (and win (not static) (not static-libs) (not shared))
    952       (delete-file* (pathname-replace-extension target-filename "exp"))
    953       (delete-file* (pathname-replace-extension target-filename "lib")) )
    954     (unless keep-files (for-each delete-file* generated-object-files)) ) )
     960      ($delete-file (pathname-replace-extension target-filename "exp"))
     961      ($delete-file (pathname-replace-extension target-filename "lib")) )
     962    (unless keep-files (for-each $delete-file generated-object-files)) ) )
    955963
    956964(define (static-extension-info)
     
    9921000(define-constant +hairy-chars+ '(#\\ #\#))
    9931001
    994 (define (quote-option x)
    995   (if (any (lambda (c)
    996              (or (char-whitespace? c) (memq c +hairy-chars+)) )
    997            (string->list x) )
    998       (cleanup x)
    999       x) )
    1000 
    10011002(define (cleanup s)
    10021003  (let* ((q #f)
     
    10141015        s) ) )
    10151016
     1017(define (quote-option x)
     1018  (if (any (lambda (c)
     1019             (or (char-whitespace? c) (memq c +hairy-chars+)) )
     1020           (string->list x) )
     1021      (cleanup x)
     1022      x) )
     1023
    10161024(define last-exit-code #f)
    10171025
    1018 (define (system* str)
     1026(define ($system str)
    10191027  (when verbose (print str))
    10201028  (set! last-exit-code
     
    10281036  last-exit-code)
    10291037
    1030 (define (delete-file* str)
     1038(define ($delete-file str)
    10311039  (when verbose
    10321040    (if win
  • chicken/extras.scm

    r3839 r4232  
    421421
    422422(define (##sys#read-string! n dest port start)
    423   (when (##sys#slot port 6)             ; peeked?
    424     (##core#inline "C_setsubchar" dest start (##sys#read-char-0 port))
    425     (set! start (fx+ start 1)) )
    426   (let ((rdstring (##sys#slot (##sys#slot port 2) 7)))
    427     (let loop ((start start) (n n) (m 0))
    428       (let ((n2 (if rdstring
    429                     (rdstring port n dest start) ; *** doesn't update port-position!
    430                     (let ((c (##sys#read-char-0 port)))
    431                       (if (eof-object? c)
    432                           0
    433                           (begin
    434                             (##core#inline "C_setsubchar" dest start c)
    435                             1) ) ) ) ) )
    436         (cond ((eq? n2 0) m)
    437               ((or (not n) (fx< n2 n))
    438                (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)) )
    439               (else (fx+ n2 m))) ) ) ))
     423  (cond ((eq? n 0) 0)
     424        (else
     425         (when (##sys#slot port 6)      ; peeked?
     426           (##core#inline "C_setsubchar" dest start (##sys#read-char-0 port))
     427           (set! start (fx+ start 1)) )
     428         (let ((rdstring (##sys#slot (##sys#slot port 2) 7)))
     429           (let loop ((start start) (n n) (m 0))
     430             (let ((n2 (if rdstring
     431                           (rdstring port n dest start) ; *** doesn't update port-position!
     432                           (let ((c (##sys#read-char-0 port)))
     433                             (if (eof-object? c)
     434                                 0
     435                                 (begin
     436                                   (##core#inline "C_setsubchar" dest start c)
     437                                   1) ) ) ) ) )
     438               (cond ((eq? n2 0) m)
     439                     ((or (not n) (fx< n2 n))
     440                      (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)) )
     441                     (else (fx+ n2 m))) ) ) ))))
    440442
    441443(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
  • chicken/library.scm

    r3839 r4232  
    18001800            (apply ##sys#values results) ) ) ) ) ) )
    18011801
    1802 (define (file-exists? name)
    1803   (##sys#check-string name 'file-exists?)
    1804   (##sys#pathname-resolution
    1805    name
    1806    (lambda (name) (and (##sys#file-info name) name))
    1807    #:exists?) )
     1802(define file-exists?
     1803  (let ((bp (string->symbol ((##core#primitive "C_build_platform"))))
     1804        (fixsuffix (or (eq? bp 'msvc) (eq? bp 'mingw32))))
     1805    (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?) ) ) )
    18081818
    18091819(define (##sys#flush-output port)
     
    26572667            (or (fx<= c 32)
    26582668                (fx>= c 128)
    2659                 (memq chr '(#\( #\) #\| #\, #\[ #\] #\{ #\} #\' #\" #\; #\\)) ) ) )
     2669                (memq chr '(#\( #\) #\| #\, #\[ #\] #\{ #\} #\' #\" #\; #\\ #\`)) ) ) )
    26602670
    26612671        (define (outreadablesym port str)
     
    26662676                  (outchr port #\|)
    26672677                  (let ([c (##core#inline "C_subchar" str i)])
    2668                     (when (eq? c #\|) (outchr port #\\))
     2678                    (when (or (eq? c #\|) (eq? c #\\)) (outchr port #\\))
    26692679                    (outchr port c)
    26702680                    (loop (fx+ i 1)) ) ) ) ) )
     
    42074217               (newline port) ]
    42084218              [else
    4209                (display "uncaught exception: " port)
     4219               (display ": uncaught exception: " port)
    42104220               (writeargs (list ex) port) ] ) ) ) ) )
    42114221
  • chicken/lolevel.scm

    r3839 r4232  
    5151#define C_w2b(x)                   C_fix(C_wordstobytes(C_unfix(x)))
    5252#define C_pointer_eqp(x, y)        C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
     53#define C_memmove_o(to, from, n, toff, foff) C_memmove((char *)(to) + (toff), (char *)(from) + (foff), (n))
    5354EOF
    5455) )
     
    9495
    9596(define move-memory!
    96   (let ([memmove1 (foreign-lambda void "C_memmove" c-pointer c-pointer int)]
    97         [memmove2 (foreign-lambda void "C_memmove" c-pointer scheme-pointer int)]
    98         [memmove3 (foreign-lambda void "C_memmove" scheme-pointer c-pointer int)]
    99         [memmove4 (foreign-lambda void "C_memmove" scheme-pointer scheme-pointer int)]
     97  (let ([memmove1 (foreign-lambda void "C_memmove_o" c-pointer c-pointer int int int)]
     98        [memmove2 (foreign-lambda void "C_memmove_o" c-pointer scheme-pointer int int int)]
     99        [memmove3 (foreign-lambda void "C_memmove_o" scheme-pointer c-pointer int int int)]
     100        [memmove4 (foreign-lambda void "C_memmove_o" scheme-pointer scheme-pointer int int int)]
    100101        [slot1structs '(mmap u8vector u16vector u32vector s8vector s16vector s32vector f32vector f64vector)] )
    101     (lambda (from to . n)
     102    (lambda (from to #!optional n (foffset 0) (toffset 0))
    102103      (define (err) (##sys#error 'move-memory! "need number of bytes to move" from to))
    103104      (define (xerr x) (##sys#signal-hook #:type-error 'move-memory! "invalid argument type" x))
    104       (define (checkn n nmax)
    105         (if (cond-expand [unsafe #t] [else (fx<= n nmax)])
     105      (define (checkn n nmax off)
     106        (if (cond-expand [unsafe #t] [else (fx<= n (fx- nmax off))])
    106107            n
    107108            (##sys#error 'move-memory! "number of bytes to move too large" from to n nmax) ) )
    108       (define (checkn2 n nmax nmax2)
    109         (if (cond-expand [unsafe #t] [else (and (fx<= n nmax) (fx<= n nmax2))])
     109      (define (checkn2 n nmax nmax2 off1 off2)
     110        (if (cond-expand [unsafe #t] [else (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))])
    110111            n
    111112            (##sys#error 'move-memory! "number of bytes to move too large" from to n nmax nmax2) ) )
     
    120121                   (xerr to) ) ]
    121122              [(or (##sys#pointer? from) (##sys#locative? from))
    122                (cond [(or (##sys#pointer? to) (##sys#locative? to)) (memmove1 to from (:optional n (err)))]
     123               (cond [(or (##sys#pointer? to) (##sys#locative? to))
     124                      (memmove1 to from (or n (err)) toffset foffset)]
    123125                     [(or (##sys#bytevector? to) (string? to))
    124                       (memmove3 to from (checkn (:optional n (err)) (##sys#size to))) ]
     126                      (memmove3 to from (checkn (or n (err)) (##sys#size to) toffset) toffset foffset) ]
    125127                     [else (xerr to)] ) ]
    126128              [(or (##sys#bytevector? from) (string? from))
    127129               (let ([nfrom (##sys#size from)])
    128130                 (cond [(or (##sys#pointer? to) (##sys#locative? to))
    129                         (memmove2 to from (checkn (:optional n nfrom) nfrom))]
     131                        (memmove2 to from (checkn (or n nfrom) nfrom foffset) toffset foffset)]
    130132                       [(or (##sys#bytevector? to) (string? to))
    131                         (memmove4 to from (checkn2 (:optional n nfrom) nfrom (##sys#size to))) ]
     133                        (memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
     134                                  toffset foffset) ]
    132135                       [else (xerr to)] ) ) ]
    133136              [else (xerr from)] ) ) ) ) )
     
    498501               (let* ([n (##sys#size x)]
    499502                      [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
    500                       [y (##core#inline "C_copy_block" x (make-vector words))] ) ; shamelessly mutating vector into something else
     503                      [y (##core#inline "C_copy_block" x (make-vector words))] )
    501504                 (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
    502505                   (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     
    683686      (##sys#become! lst) ) ] ) )
    684687
     688(define (mutate-procedure old proc)
     689  (unless (##core#check (procedure? old))
     690    (##sys#signal-hook #:type-error 'mutate-procedure "bad argument type - not a procedure" old))
     691  (let* ((n (##sys#size old))
     692         (words (##core#inline "C_words" n))
     693         (y (##core#inline "C_copy_block" old (make-vector words))) )
     694    (##sys#become! (list (cons old (proc y))))
     695    y) )
     696
    685697
    686698;;; locatives:
  • chicken/posixunix.scm

    r3839 r4232  
    244244}
    245245
    246 static void C_fcall C_free_exec_args() {
    247   char **a = C_exec_args;
    248   while((*a) != NULL) C_free(*(a++));
     246static void C_fcall C_free_arg_string(char **where) {
     247  while((*where) != NULL) C_free(*(where++));
    249248}
    250249
    251 static void C_fcall C_free_exec_env() {
    252   char **a = C_exec_env;
    253   while((*a) != NULL) C_free(*(a++));
    254 }
    255 
    256 #define C_set_exec_arg(i, a, len)      C_set_arg_string(C_exec_args, i, a, len)
    257 #define C_set_exec_env(i, a, len)      C_set_arg_string(C_exec_env, i, a, len)
     250#define C_set_exec_arg(i, a, len)       C_set_arg_string(C_exec_args, i, a, len)
     251#define C_free_exec_args()              C_free_arg_string(C_exec_args)
     252#define C_set_exec_env(i, a, len)       C_set_arg_string(C_exec_env, i, a, len)
     253#define C_free_exec_env()               C_free_arg_string(C_exec_env)
    258254
    259255#define C_execvp(f)         C_fix(execvp(C_data_pointer(f), C_exec_args))
     
    18641860        (##sys#check-list arglist 'process-execute)
    18651861        (let ([s (pathname-strip-directory filename)])
    1866         (setarg 0 s (##sys#size s)) )
     1862          (setarg 0 s (##sys#size s)) )
    18671863        (do ([al arglist (cdr al)]
    18681864             [i 1 (fx+ i 1)] )
     
    18701866             (setarg i #f 0)
    18711867             (when envlist
     1868               (##sys#check-list envlist 'process-execute)
    18721869               (do ([el envlist (cdr el)]
    18731870                    [i 0 (fx+ i 1)] )
     
    19241921        (let ([r (##core#inline "C_kill" id sig)])
    19251922        (when (fx= r -1) (posix-error #:process-error 'process-signal "could not send signal to process" id sig) ) ) ) ) )
    1926 
    1927   ;FIXME - shouldn't be private
    19281923
    19291924  (define (##sys#shell-command)
     
    20512046  (let ([%process
    20522047          (lambda (loc err? cmd args env)
    2053             (##sys#check-string cmd loc)
    2054             (if args
    2055               (begin
    2056                 (##sys#check-list args loc)
    2057                 (for-each (cut ##sys#check-string <> loc) args) )
    2058               (begin
    2059                 (set! args (##sys#shell-command-arguments cmd))
    2060                 (set! cmd (##sys#shell-command)) ) )
    2061             (when env
    2062               (##sys#check-list env loc)
    2063               (for-each (cut ##sys#check-string <> loc) env) )
    2064             (receive [in out pid err]
    2065                        (##sys#process loc cmd args env #t #t err?)
    2066               (if err?
    2067                 (values in out pid err)
    2068                 (values in out pid) ) ) )] )
     2048            (let ([chkstrlst
     2049                   (lambda (lst)
     2050                     (##sys#check-list lst loc)
     2051                     (for-each (cut ##sys#check-string <> loc) lst) )])
     2052              (##sys#check-string cmd loc)
     2053              (if args
     2054                (chkstrlst args)
     2055                (begin
     2056                  (set! args (##sys#shell-command-arguments cmd))
     2057                  (set! cmd (##sys#shell-command)) ) )
     2058              (when env (chkstrlst env))
     2059              (receive [in out pid err] (##sys#process loc cmd args env #t #t err?)
     2060                (if err?
     2061                  (values in out pid err)
     2062                  (values in out pid) ) ) ) )] )
    20692063    (set! process
    20702064      (lambda (cmd #!optional args env)
  • chicken/posixwin.scm

    r3839 r4232  
    6464
    6565
     66; Issues
     67;
     68; - Use of a UTF8 encoded string will not work properly. Windows uses a
     69; 16-bit UNICODE character string encoding and specialized system calls
     70; and/or structure settings for the use of such strings.
     71
     72
    6673(declare
    6774  (unit posix)
     
    6976  (disable-interrupts)
    7077  (usual-integrations)
    71   (hide ##sys#stat close-handle posix-error)
     78  (hide ##sys#stat close-handle posix-error
     79        $quote-args-list $exec-setup $exec-teardown)
    7280  (foreign-declare #<<EOF
    7381#ifndef WIN32_LEAN_AND_MEAN
     
    104112#include <time.h>
    105113
    106 #define ARG_MAX 256
    107 #define PIPE_BUF 512
     114#define ARG_MAX         256
     115#define PIPE_BUF        512
     116#ifndef ENV_MAX
     117# define ENV_MAX        1024
     118#endif
    108119
    109120static C_TLS char *C_exec_args[ ARG_MAX ];
     121static C_TLS char *C_exec_env[ ENV_MAX ];
    110122static C_TLS struct group *C_group;
    111123static C_TLS int C_pipefds[ 2 ];
     
    120132static C_TLS int C_exstatus;
    121133
    122 /* platform information */
    123 static C_TLS char C_hostname[256];
    124 static C_TLS char C_osver[16];
    125 static C_TLS char C_osrel[16];
    126 static C_TLS char C_processor[16];
     134/* platform information; initialized for cached testing */
     135static C_TLS char C_hostname[256] = "";
     136static C_TLS char C_osver[16] = "";
     137static C_TLS char C_osrel[16] = "";
     138static C_TLS char C_processor[16] = "";
     139static C_TLS char C_shlcmd[256] = "";
    127140
    128141#define C_mkdir(str)        C_fix(mkdir(C_c_string(str)))
     
    262275}
    263276
    264 static void C_fcall C_set_exec_arg(int i, char *a, int len);
    265 void C_fcall C_set_exec_arg(int i, char *a, int len) {
     277static void C_fcall C_set_arg_string(char **where, int i, char *a, int len) {
    266278  char *ptr;
    267279  if(a != NULL) {
     
    271283  }
    272284  else ptr = NULL;
    273   C_exec_args[ i ] = ptr;
    274 }
    275 
    276 static void C_fcall C_free_exec_args();
    277 void C_fcall C_free_exec_args() {
    278   char **a = C_exec_args;
    279   while((*a) != NULL) C_free(*(a++));
    280 }
     285  where[ i ] = ptr;
     286}
     287
     288static void C_fcall C_free_arg_string(char **where) {
     289  while((*where) != NULL) C_free(*(where++));
     290}
     291
     292#define C_set_exec_arg(i, a, len)       C_set_arg_string(C_exec_args, i, a, len)
     293#define C_free_exec_args()              C_free_arg_string(C_exec_args)
     294#define C_set_exec_env(i, a, len)       C_set_arg_string(C_exec_env, i, a, len)
     295#define C_free_exec_env()               C_free_arg_string(C_exec_env)
    281296
    282297#define C_execvp(f)         C_fix(execvp(C_data_pointer(f), (const char *const *)C_exec_args))
     298#define C_execve(f)         C_fix(execve(C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env))
    283299
    284300/* MS replacement for the fork-exec pair */
    285301#define C_spawnvp(m, f)     C_fix(spawnvp(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args))
     302#define C_spawnvpe(m, f)    C_fix(spawnvpe(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env))
    286303
    287304#define C_open(fn, fl, m)   C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))
     
    290307#define C_mkstemp(t)        C_fix(mktemp(C_c_string(t)))
    291308
    292 #define C_ftell(p)            C_fix(ftell(C_port_file(p)))
    293 #define C_fseek(p, n, w)      C_mk_nbool(fseek(C_port_file(p), C_unfix(n), C_unfix(w)))
    294 #define C_lseek(fd, o, w)     C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
     309#define C_ftell(p)          C_fix(ftell(C_port_file(p)))
     310#define C_fseek(p, n, w)    C_mk_nbool(fseek(C_port_file(p), C_unfix(n), C_unfix(w)))
     311#define C_lseek(fd, o, w)   C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
     312
     313#define C_flushall()        C_fix(_flushall())
    295314
    296315#define C_ctime(n)          (C_secs = (n), ctime(&C_secs))
    297316
    298317#define C_asctime(v)        (memset(&C_tm, 0, sizeof(struct tm)), C_tm.tm_sec = C_unfix(C_block_item(v, 0)), C_tm.tm_min = C_unfix(C_block_item(v, 1)), C_tm.tm_hour = C_unfix(C_block_item(v, 2)), C_tm.tm_mday = C_unfix(C_block_item(v, 3)), C_tm.tm_mon = C_unfix(C_block_item(v, 4)), C_tm.tm_year = C_unfix(C_block_item(v, 5)), C_tm.tm_wday = C_unfix(C_block_item(v, 6)), C_tm.tm_yday = C_unfix(C_block_item(v, 7)), C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE), asctime(&C_tm) )
    299 #define C_mktime(v)        (memset(&C_tm, 0, sizeof(struct tm)), C_tm.tm_sec = C_unfix(C_block_item(v, 0)), C_tm.tm_min = C_unfix(C_block_item(v, 1)), C_tm.tm_hour = C_unfix(C_block_item(v, 2)), C_tm.tm_mday = C_unfix(C_block_item(v, 3)), C_tm.tm_mon = C_unfix(C_block_item(v, 4)), C_tm.tm_year = C_unfix(C_block_item(v, 5)), C_tm.tm_wday = C_unfix(C_block_item(v, 6)), C_tm.tm_yday = C_unfix(C_block_item(v, 7)), C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE), (C_temporary_flonum = mktime(&C_tm)) != -1)
     318#define C_mktime(v)         (memset(&C_tm, 0, sizeof(struct tm)), C_tm.tm_sec = C_unfix(C_block_item(v, 0)), C_tm.tm_min = C_unfix(C_block_item(v, 1)), C_tm.tm_hour = C_unfix(C_block_item(v, 2)), C_tm.tm_mday = C_unfix(C_block_item(v, 3)), C_tm.tm_mon = C_unfix(C_block_item(v, 4)), C_tm.tm_year = C_unfix(C_block_item(v, 5)), C_tm.tm_wday = C_unfix(C_block_item(v, 6)), C_tm.tm_yday = C_unfix(C_block_item(v, 7)), C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE), (C_temporary_flonum = mktime(&C_tm)) != -1)
    300319
    301320/*
     
    372391}
    373392
     393static int set_last_errno()
     394{
     395    set_errno(GetLastError());
     396    return 0;
     397}
     398
    374399/* functions for creating process with redirected I/O */
    375400static int zero_handles()
     
    428453                &C_rd1_, 0, FALSE, DUPLICATE_SAME_ACCESS))
    429454    {
    430         set_errno(GetLastError());
     455        set_last_errno();
    431456        close_handles();
    432457        return 0;
     
    452477
    453478    if (CreateProcess(NULL, cmdline, NULL, NULL, TRUE, 0, NULL,
    454                 NULL, &si, &pi))
     479                      NULL, &si, &pi))
    455480    {
    456481        CloseHandle(pi.hThread);
     
    466491    }
    467492    else
    468     {
    469         set_errno(GetLastError());
    470         return 0;
    471     }
     493        return set_last_errno();
    472494}
    473495
     
    478500        return 1;
    479501    else
    480     {
    481         set_errno(GetLastError());
    482         return 0;
    483     }
     502        return set_last_errno();
    484503}
    485504
     
    498517            return -1;
    499518    }
    500     set_errno(GetLastError());
    501     return 0;
     519    return set_last_errno();
    502520}
    503521
     
    538556        }
    539557    }
    540     set_errno(GetLastError());
    541     return 0;
     558    return set_last_errno();
    542559}
    543560
     
    547564int get_hostname()
    548565{
    549     WSADATA wsa;
    550     if (WSAStartup(MAKEWORD(1, 1), &wsa) == 0)
    551     {
    552         int nok = gethostname(C_hostname, 256);
    553         WSACleanup();
    554         return !nok;
    555     }
    556     return 0;
     566    /* Do we already have hostname? */
     567    if (strlen(C_hostname))
     568    {
     569        return 1;
     570    }
     571    else
     572    {
     573        WSADATA wsa;
     574        if (WSAStartup(MAKEWORD(1, 1), &wsa) == 0)
     575        {
     576            int nok = gethostname(C_hostname, sizeof(C_hostname));
     577            WSACleanup();
     578            return !nok;
     579        }
     580        return 0;
     581    }
    557582}
    558583
    559584int sysinfo()
    560585{
    561     OSVERSIONINFO ovf;
    562     ZeroMemory(&ovf, sizeof(ovf));
    563     ovf.dwOSVersionInfoSize = sizeof(ovf);
    564     if (get_hostname() && GetVersionEx(&ovf))
    565     {
    566         SYSTEM_INFO si;
    567         _snprintf(C_osver, sizeof(C_osver) - 1, "%d.%d.%d",
    568                            ovf.dwMajorVersion, ovf.dwMinorVersion, ovf.dwBuildNumber);
    569         switch (ovf.dwPlatformId)
    570         {
    571         case VER_PLATFORM_WIN32s:
    572             strncpy(C_osrel, "Win32s", sizeof(C_osrel) - 1);
    573             break;
    574         case VER_PLATFORM_WIN32_WINDOWS:
    575             strncpy(C_osrel, "Win9x", sizeof(C_osrel) - 1);
    576             break;
    577         case VER_PLATFORM_WIN32_NT:
    578         default:
    579             strncpy(C_osrel, "WinNT", sizeof(C_osrel) - 1);
    580             break;
    581         }
    582         GetSystemInfo(&si);
    583         switch (si.wProcessorArchitecture)
    584         {
    585         case PROCESSOR_ARCHITECTURE_INTEL:
    586             strncpy(C_processor, "x86", sizeof(C_processor) - 1);
    587             break;
    588 #       ifdef PROCESSOR_ARCHITECTURE_IA64
    589         case PROCESSOR_ARCHITECTURE_IA64:
    590             strncpy(C_processor, "IA64", sizeof(C_processor) - 1);
    591             break;
    592 #       endif
    593 #       ifdef PROCESSOR_ARCHITECTURE_AMD64
    594         case PROCESSOR_ARCHITECTURE_AMD64:
    595             strncpy(C_processor, "x64", sizeof(C_processor) - 1);
    596             break;
    597 #       endif
    598 #       ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
    599         case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
    600             strncpy(C_processor, "WOW64", sizeof(C_processor) - 1);
    601             break;
    602 #       endif
    603         case PROCESSOR_ARCHITECTURE_UNKNOWN:
    604         default:
    605             strncpy(C_processor, "Unknown", sizeof(C_processor) - 1);
    606             break;
    607         }
    608         return 1;
    609     }
    610     set_errno(GetLastError());
    611     return 0;
     586    /* Do we need to build the sysinfo? */
     587    if (!strlen(C_osrel))
     588    {
     589        OSVERSIONINFO ovf;
     590        ZeroMemory(&ovf, sizeof(ovf));
     591        ovf.dwOSVersionInfoSize = sizeof(ovf);
     592        if (get_hostname() && GetVersionEx(&ovf))
     593        {
     594            SYSTEM_INFO si;
     595            _snprintf(C_osver, sizeof(C_osver) - 1, "%d.%d.%d",
     596                        ovf.dwMajorVersion, ovf.dwMinorVersion, ovf.dwBuildNumber);
     597            switch (ovf.dwPlatformId)
     598            {
     599            case VER_PLATFORM_WIN32s:
     600                strncpy(C_osrel, "Win32s", sizeof(C_osrel) - 1);
     601                break;
     602            case VER_PLATFORM_WIN32_WINDOWS:
     603                strncpy(C_osrel, "Win9x", sizeof(C_osrel) - 1);
     604                break;
     605            case VER_PLATFORM_WIN32_NT:
     606            default:
     607                strncpy(C_osrel, "WinNT", sizeof(C_osrel) - 1);
     608                break;
     609            }
     610            GetSystemInfo(&si);
     611            switch (si.wProcessorArchitecture)
     612            {
     613            case PROCESSOR_ARCHITECTURE_INTEL:
     614                strncpy(C_processor, "x86", sizeof(C_processor) - 1);
     615                break;
     616#           ifdef PROCESSOR_ARCHITECTURE_IA64
     617            case PROCESSOR_ARCHITECTURE_IA64:
     618                strncpy(C_processor, "IA64", sizeof(C_processor) - 1);
     619                break;
     620#           endif
     621#           ifdef PROCESSOR_ARCHITECTURE_AMD64
     622            case PROCESSOR_ARCHITECTURE_AMD64:
     623                strncpy(C_processor, "x64", sizeof(C_processor) - 1);
     624                break;
     625#           endif
     626#           ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
     627            case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
     628                strncpy(C_processor, "WOW64", sizeof(C_processor) - 1);
     629                break;
     630#           endif
     631            case PROCESSOR_ARCHITECTURE_UNKNOWN:
     632            default:
     633                strncpy(C_processor, "Unknown", sizeof(C_processor) - 1);
     634                break;
     635            }
     636        }
     637        else
     638            return set_last_errno();
     639    }
     640    return 1;
     641}
     642
     643static int get_shlcmd()
     644{
     645    /* Do we need to build the shell command pathname? */
     646    if (!strlen(C_shlcmd))
     647    {
     648        if (sysinfo())
     649        {
     650            char *cmdnam = (0 == strcmp(C_osrel, "WinNT")) ? "\\cmd.exe" : "\\command.com";
     651            UINT len = GetSystemDirectory(C_shlcmd, sizeof(C_shlcmd) - strlen(cmdnam));
     652            if (0 != len)
     653                strcpy(C_shlcmd + len, cmdnam);
     654            else
     655                return set_last_errno();
     656        }
     657        else
     658            return 0;
     659    }
     660    return 1;
    612661}
    613662
    614663#define C_get_hostname() (get_hostname() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
    615664#define C_sysinfo() (sysinfo() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
     665#define C_get_shlcmd() (get_shlcmd() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
    616666
    617667/*
    618     Spawn a process, either through shell or directly.
     668    Spawn a process directly.
    619669    Params:
    620     cmd         Command to execute.
     670    app         Command to execute.
     671    cmdlin      Command line (arguments).
    621672    env         Environment for the new process (may be NULL).
    622673    handle, stdin, stdout, stderr
     
    629680                Bit 2: Share standard output if bit is set.
    630681                Bit 3: Share standard error if bit is set.
    631                 (Bit 4: Execute command in shell if bit is set.)
    632 
    633     Returns: nonzero return value indicates failure.
     682
     683    Returns: zero return value indicates failure.
    634684*/
    635 static
    636 int C_process(const char * cmd, const char ** env,
    637               int * phandle, int * pstdin_fd, int * pstdout_fd, int * pstderr_fd,
    638               int params)
    639 {
    640     int exit_code = 0, i = 0;
    641     const int
    642         f_share_io[3] = { params & 1, params & 2, params & 4};
    643 #if 0
    644     const int
    645         f_use_shell = params & 8;
    646 #endif
    647 
    648     char * buf = NULL;
    649     const char * invoke_cmd = NULL;
    650     int io_fds[3]={-1,-1,-1};
     685static int C_process(const char * app, const char * cmdlin, const char ** env,
     686                     int * phandle,
     687                     int * pstdin_fd, int * pstdout_fd, int * pstderr_fd,
     688                     int params)
     689{
     690    int i;
     691    int success = TRUE;
     692    const int f_share_io[3] = { params & 1, params & 2, params & 4};
     693    int io_fds[3] = { -1, -1, -1 };
    651694    HANDLE
    652         child_io_handles[3]={NULL,NULL,NULL},
    653         standard_io_handles[3]={
     695        child_io_handles[3] = { NULL, NULL, NULL },
     696        standard_io_handles[3] = {
    654697            GetStdHandle(STD_INPUT_HANDLE),
    655698            GetStdHandle(STD_OUTPUT_HANDLE),
    656699            GetStdHandle(STD_ERROR_HANDLE)};
    657 
    658     const char modes[3]="rww";
     700    const char modes[3] = "rww";
    659701    HANDLE cur_process = GetCurrentProcess(), child_process = NULL;
     702    void* envblk = NULL;
    660703
    661704    /****** create io handles & fds ***/
    662705
    663     for (i=0; i<3 && exit_code == 0; ++i)
     706    for (i=0; i<3 && success; ++i)
    664707    {
    665708        if (f_share_io[i])
    666709        {
    667             exit_code = !DuplicateHandle(
     710            success = DuplicateHandle(
    668711                cur_process, standard_io_handles[i],
    669712                cur_process, &child_io_handles[i],
     
    672715        else
    673716        {
    674             HANDLE a, b, parent_end;
    675             exit_code = !CreatePipe(&a,&b,NULL,0);
    676             if(0==exit_code)
     717            HANDLE a, b;
     718            success = CreatePipe(&a,&b,NULL,0);
     719            if(success)
    677720            {
     721                HANDLE parent_end;
    678722                if (modes[i]=='r') { child_io_handles[i]=a; parent_end=b; }
    679                 else { parent_end=a; child_io_handles[i]=b; }
     723                else               { parent_end=a; child_io_handles[i]=b; }
     724                success = (io_fds[i] = _open_osfhandle((long)parent_end,0)) >= 0;
    680725            }
    681             exit_code=(io_fds[i]=_open_osfhandle((long)parent_end,0))<0;
    682726        }
    683727    }
     
    685729    /****** make handles inheritable */
    686730
    687     for (i=0; i<3 && exit_code == 0; ++i)
    688         exit_code = !SetHandleInformation(child_io_handles[i], HANDLE_FLAG_INHERIT, -1);
    689 
    690     /****** create command line ******/
    691 
    692 #if 0
    693     if (f_use_shell && exit_code == 0)
    694     {
    695         const char * shell = NULL;
    696         static const char * const fmt = "%s /c %s";
    697 
    698         shell=getenv("COMSPEC");
    699         if (NULL==shell)
     731    for (i=0; i<3 && success; ++i)
     732        success = SetHandleInformation(child_io_handles[i], HANDLE_FLAG_INHERIT, -1);
     733
     734#if 0 /* Requires a sorted list by key! */
     735    /****** create environment block if necessary ****/
     736
     737    if (env && success)
     738    {
     739        char** p;
     740        int len = 0;
     741
     742        for (p = env; *p; ++p) len += strlen(*p) + 1;
     743
     744        if (envblk = C_malloc(len + 1))
    700745        {
    701             OSVERSIONINFO ovf;
    702             ovf.dwOSVersionInfoSize = sizeof(ovf);
    703             if (GetVersionEx(&ovf) && (ovf.dwPlatformId == VER_PLATFORM_WIN32_NT))
    704                 shell="cmd.exe";
    705             else
    706                 shell="command.com";
     746            char* pb = (char*)envblk;
     747            for (p = env; *p; ++p)
     748            {
     749                strcpy(pb, *p);
     750                pb += strlen(*p) + 1;
     751            }
     752            *pb = '\0';
    707753        }
    708 
    709         buf = (char*) malloc(strlen(fmt)+strlen(shell)+strlen(cmd));
    710         exit_code=(NULL==buf);
    711         if (0==exit_code) { sprintf(buf,fmt,shell,cmd); invoke_cmd = buf; }
    712     }
    713     else
     754        else
     755            success = FALSE;
     756    }
    714757#endif
    715         invoke_cmd = cmd;
    716758
    717759    /****** finally spawn process ****/
    718760
    719     if (0==exit_code)
     761    if (success)
    720762    {
    721763        PROCESS_INFORMATION pi;
     
    730772        si.hStdError = child_io_handles[2];
    731773
    732         exit_code = !CreateProcess(
    733             NULL,(char*)invoke_cmd,NULL,NULL,TRUE,0,(char**)env,NULL,&si,&pi);
    734 
    735         if (0==exit_code)
     774        /* FIXME passing 'app' param causes failure & possible stack corruption */
     775        success = CreateProcess(
     776            NULL, (char*)cmdlin, NULL, NULL, TRUE, 0, envblk, NULL, &si, &pi);
     777
     778        if (success)
    736779        {
    737780            child_process=pi.hProcess;
    738781            CloseHandle(pi.hThread);
    739782        }
    740     }
     783        else
     784            set_last_errno();
     785    }
     786    else
     787        set_last_errno();
    741788
    742789    /****** cleanup & return *********/
    743790
    744     free(buf);
     791    /* parent must close child end */
    745792    for (i=0; i<3; ++i) CloseHandle(child_io_handles[i]);
    746     if (exit_code != 0)
    747     {
    748         for (i=0; i<3; ++i) _close(io_fds[i]);
    749         set_errno(GetLastError());
    750     }
    751     else
     793
     794    if (success)
    752795    {
    753796        *phandle = (int)child_process;
     
    756799        *pstderr_fd = io_fds[2];
    757800    }
    758 
    759     return exit_code;
     801    else
     802    {
     803        for (i=0; i<3; ++i) _close(io_fds[i]);
     804    }
     805
     806    return success;
    760807}
    761808EOF
     
    15211568(define spawn/detach _p_detach)
    15221569
    1523 (define process-execute
     1570; Windows uses a commandline style for process arguments. Thus any
     1571; arguments with embedded whitespace will parse incorrectly. Must
     1572; string-quote such arguments.
     1573(define $quote-args-list
     1574  (let ([char-whitespace? char-whitespace?]
     1575        [string-length string-length]
     1576        [string-ref string-ref]
     1577        [string-append string-append])
     1578    (lambda (lst exactf)
     1579      (if exactf
     1580        lst
     1581        (let ([needs-quoting?
     1582                ; This is essentially (string-any char-whitespace? s) but we don't
     1583                ; want a SRFI-13 dependency. (Do we?)
     1584                (lambda (s)
     1585                  (let ([len (string-length s)])
     1586                    (let loop ([i 0])
     1587                      (cond
     1588                        [(fx= i len) #f]
     1589                        [(char-whitespace? (string-ref s i)) #t]
     1590                        [else (loop (fx+ i 1))]))))])
     1591            (let loop ([ilst lst] [olst '()])
     1592              (if (null? ilst)
     1593                (reverse olst)
     1594                (let ([str (car ilst)])
     1595                  (loop
     1596                    (cdr ilst)
     1597                    (cons
     1598                      (if (needs-quoting? str) (string-append "\"" str "\"") str)
     1599                      olst)) ) ) ) ) ) ) ) )
     1600
     1601(define $exec-setup
    15241602  (let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
    1525         [freeargs (foreign-lambda void "C_free_exec_args")]
    1526         [pathname-strip-directory pathname-strip-directory] )
    1527     (lambda (filename #!optional (arglist '()) envlist)
    1528       (##sys#check-string filename 'process-execute)
    1529       (let ([arglist (if (pair? arglist) (car arglist) '())])
    1530         (##sys#check-list arglist 'process-execute)
    1531         (let ([s (pathname-strip-directory filename)])
    1532           (setarg 0 s (##sys#size s)) )
    1533         (do ([al arglist (cdr al)]
    1534              [i 1 (fx+ i 1)] )
    1535             ((null? al)
    1536              (setarg i #f 0)
    1537              (let ([r (##core#inline "C_execvp" (##sys#make-c-string (##sys#expand-home-path filename)))])
    1538                (##sys#update-errno)
    1539                (when (fx= r -1)
    1540                  (freeargs)
    1541                  (##sys#error 'process-execute "cannot execute process" filename) ) ) )
    1542           (let ([s (car al)])
    1543             (##sys#check-string s 'process-execute)
    1544             (setarg i s (##sys#size s)) ) ) ) ) ) )
    1545 
    1546 (define process-spawn
    1547   (let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
    1548         [freeargs (foreign-lambda void "C_free_exec_args")]
    1549         [pathname-strip-directory pathname-strip-directory] )
    1550     (lambda (mode filename . arglist)
    1551       (##sys#check-exact mode 'process-spawn)
    1552       (##sys#check-string filename 'process-spawn)
    1553       (let ([arglist (if (pair? arglist) (car arglist) '())])
    1554         (##sys#check-list arglist 'process-spawn)
    1555         (let ([s (pathname-strip-directory filename)])
    1556           (setarg 0 s (##sys#size s)) )
    1557         (do ([al arglist (cdr al)]
    1558              [i 1 (fx+ i 1)] )
    1559             ((null? al)
    1560              (setarg i #f 0)
    1561              (let ([r (##core#inline "C_spawnvp" mode
    1562                        (##sys#make-c-string (##sys#expand-home-path filename)))])
    1563                (##sys#update-errno)
    1564                (when (fx= r -1)
    1565                  (freeargs)
    1566                  (##sys#error 'process-spawn "cannot execute process" filename) )
    1567                r) )
    1568           (let ([s (car al)])
    1569             (##sys#check-string s 'process-spawn)
    1570             (setarg i s (##sys#size s)) ) ) ) ) ) )
     1603        [setenv (foreign-lambda void "C_set_exec_env" int scheme-pointer int)]
     1604        [pathname-strip-directory pathname-strip-directory]
     1605        [build-exec-arr
     1606          (lambda (loc lst setarr idx)
     1607            (if lst
     1608              (begin
     1609                (##sys#check-list lst loc)
     1610                (do ([l lst (cdr l)]
     1611                     [i idx (fx+ i 1)] )
     1612                    ((null? l) (setarr i #f 0))
     1613                  (let ([s (car l)])
     1614                    (##sys#check-string s loc)
     1615                    (setarr i s (##sys#size s)) ) ) )
     1616              (setarr idx #f 0) ) )])
     1617    (lambda (loc filename arglst envlst exactf)
     1618      (##sys#check-string filename loc)
     1619      (let ([s (pathname-strip-directory filename)])
     1620        (setarg 0 s (##sys#size s)) )
     1621      (build-exec-arr loc ($quote-args-list arglst exactf) setarg 1)
     1622      (build-exec-arr loc envlst setenv 0)
     1623      (##core#inline "C_flushall")
     1624      (##sys#make-c-string (##sys#expand-home-path filename)) ) ) )
     1625
     1626(define $exec-teardown
     1627  (let ([freeargs (foreign-lambda void "C_free_exec_args")]
     1628        [freeenv (foreign-lambda void "C_free_exec_env")])
     1629    (lambda (loc msg filename res)
     1630      (##sys#update-errno)
     1631      (freeargs)
     1632      (freeenv)
     1633      (when (fx= res -1) (##sys#error loc msg filename) )
     1634      res ) ) )
     1635
     1636(define (process-execute filename #!optional arglst envlst exactf)
     1637  (let ([prg ($exec-setup 'process-execute filename arglst envlst exactf)])
     1638    ($exec-teardown 'process-execute "cannot execute process" filename
     1639      (if envlst (##core#inline "C_execve" prg) (##core#inline "C_execvp" prg))) ) )
     1640
     1641(define (process-spawn mode filename #!optional arglst envlst exactf)
     1642  (let ([prg ($exec-setup 'process-spawn filename arglst envlst exactf)])
     1643    ($exec-teardown 'process-spawn "cannot spawn process" filename
     1644      (if envlst (##core#inline "C_spawnvpe" mode prg) (##core#inline "C_spawnvp" mode prg))) ) )
    15711645
    15721646(define current-process-id (foreign-lambda int "C_getpid"))
    15731647
    1574 (define ##sys#shell-command
    1575   (foreign-lambda* c-string () #<<EOF
    1576     char *ret = getenv("COMSPEC");
    1577     if (ret)
    1578         return (ret);
    1579     else
    1580     {
    1581         OSVERSIONINFO ovf;
    1582         ovf.dwOSVersionInfoSize = sizeof(ovf);
    1583         if (GetVersionEx(&ovf) && (ovf.dwPlatformId == VER_PLATFORM_WIN32_NT))
    1584             return ("cmd.exe");
    1585         else
    1586             return ("command.com");
    1587     }
    1588 EOF
    1589     ) )
     1648(define-foreign-variable _shlcmd c-string "C_shlcmd")
     1649
     1650(define (##sys#shell-command)
     1651  (or (getenv "COMSPEC")
     1652      (if (##core#inline "C_get_shlcmd")
     1653          _shlcmd
     1654          (begin
     1655            (##sys#update-errno)
     1656            (##sys#error '##sys#shell-command "cannot retrieve system directory") ) ) ) )
    15901657
    15911658(define (##sys#shell-command-arguments cmdlin)
     
    16101677
    16111678; from original by Mejedi
     1679;; ##sys#process
     1680; loc            caller procedure symbol
     1681; cmd            pathname or commandline
     1682; args           string-list or '()
     1683; env            string-list or #f (currently ignored)
     1684; stdoutf        #f then share, or #t then create
     1685; stdinf         #f then share, or #t then create
     1686; stderrf        #f then share, or #t then create
     1687;
     1688; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)
     1689; where stdin-input-port?, etc. is a port or #f, indicating no port created.
     1690
    16121691(define ##sys#process
    1613   (let (
    1614       [c-process
    1615         (foreign-lambda int "C_process" c-string c-pointer
    1616           (pointer int) (pointer int) (pointer int) (pointer int)
    1617           int)])
    1618     (lambda (loc cmd args env stdoutf stdinf stderrf)
    1619       (let ([commandline (if args (string-intersperse (cons cmd args)) cmd)])
    1620         (let-location ([handle int -1] [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])
    1621           (let (
    1622               [code
    1623                 (c-process commandline env
    1624                   (location handle) (location stdin_fd) (location stdout_fd) (location stderr_fd)
    1625                   (+ (if stdinf 0 1) (if stdoutf 0 2) (if stderrf 0 4)))])
    1626             (if (fx= 0 code)
     1692  (let ([c-process
     1693          (foreign-lambda bool "C_process" c-string c-string c-pointer
     1694            (pointer int) (pointer int) (pointer int) (pointer int) int)])
     1695    ; The environment list must be sorted & include current directory
     1696    ; information for the system drives. i.e !C:=...
     1697    ; For now any environment is ignored.
     1698    (lambda (loc cmd args env stdoutf stdinf stderrf #!optional exactf)
     1699      (let ([cmdlin (string-intersperse ($quote-args-list (cons cmd args) exactf))])
     1700        (let-location ([handle int -1]
     1701                       [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])
     1702          (let ([res
     1703                  (c-process cmd cmdlin #f
     1704                    (location handle)
     1705                    (location stdin_fd) (location stdout_fd) (location stderr_fd)
     1706                    (+ (if stdinf 0 1) (if stdoutf 0 2) (if stderrf 0 4)))])
     1707            (if res
    16271708              (values
    16281709                (and stdoutf (open-input-file* stdout_fd)) ;Parent stdin
     
    16321713              (begin
    16331714                (##sys#update-errno)
    1634                 (##sys#signal-hook #:process-error loc "cannot execute process" commandline))) ) ) ) ) ) )
     1715                (##sys#signal-hook #:process-error loc "cannot execute process" cmdlin))) ) ) ) ) ) )
    16351716
    16361717#;(define process (void))
    16371718#;(define process* (void))
    16381719(let ([%process
    1639         (lambda (loc err? cmd args env)
    1640           (##sys#check-string cmd loc)
    1641           (if args
    1642             (begin
    1643               (##sys#check-list args loc)
    1644               (for-each (cut ##sys#check-string <> loc) args) )
     1720        (lambda (loc err? cmd args env exactf)
     1721          (let ([chkstrlst
     1722                 (lambda (lst)
     1723                   (##sys#check-list lst loc)
     1724                   (for-each (cut ##sys#check-string <> loc) lst) )])
     1725            (##sys#check-string cmd loc)
     1726            (if args
     1727              (chkstrlst args)
    16451728              (begin
     1729                (set! exactf #t)
    16461730                (set! args (##sys#shell-command-arguments cmd))
    16471731                (set! cmd (##sys#shell-command)) ) )
    1648           (when env
    1649             (##sys#check-list env loc)
    1650             (for-each (cut ##sys#check-string <> loc) env) )
    1651           (receive [in out pid err] (##sys#process loc cmd args env #t #t err?)
    1652             (if err?
    1653               (values in out pid err)
    1654               (values in out pid) ) ) )] )
     1732            (when env (chkstrlst env))
     1733            (receive [in out pid err] (##sys#process loc cmd args env #t #t err? exactf)
     1734              (if err?
     1735                (values in out pid err)
     1736                (values in out pid) ) ) ) )] )
    16551737  (set! process
    1656     (lambda (cmd #!optional args env)
    1657       (%process 'process #f cmd args env) ))
     1738    (lambda (cmd #!optional args env exactf)
     1739      (%process 'process #f cmd args env exactf) ))
    16581740  (set! process*
    1659     (lambda (cmd #!optional args env)
    1660       (%process 'process* #t cmd args env) )) )
     1741    (lambda (cmd #!optional args env exactf)
     1742      (%process 'process* #t cmd args env exactf) )) )
    16611743
    16621744(define-foreign-variable _exstatus int "C_exstatus")
  • chicken/runtime.c

    r3839 r4232  
    38343834  char *buf = buffer;
    38353835
     3836  /* Windows doc says to flush all output streams before calling system.
     3837     Probably a good idea for all platforms. */
     3838  (void)fflush(NULL);
     3839
    38363840  if(n >= STRING_BUFFER_SIZE) {
    38373841    if((buf = (char *)C_malloc(n + 1)) == NULL)
  • chicken/site/index.html

    r3839 r4232  
    151151
    152152Latest development snapshot: <a
    153 href="http://www.call-with-current-continuation.org/chicken-2.608.tar.gz">chicken-2.608.tar.gz</a>
     153href="http://www.call-with-current-continuation.org/chicken-2.613.tar.gz">chicken-2.613.tar.gz</a>
    154154and <a href="http://www.call-with-current-continuation.org/ChangeLog.txt">(Change log)</a>
    155155
  • chicken/static/CMakeLists.txt

    r3241 r4232  
    115115####################################################################
    116116
    117 IF(${CMAKE_SYSTEM_NAME} MATCHES "Darwin")
    118   SET(MACOSX TRUE)
    119 ELSE(${CMAKE_SYSTEM_NAME} MATCHES "Darwin")
    120   SET(MACOSX FALSE)
    121 ENDIF(${CMAKE_SYSTEM_NAME} MATCHES "Darwin")
    122117
    123 SET(MACOSX TRUE)
    124 
    125 IF(NOT MACOSX)
    126   ADD_EXECUTABLE(csi-static ${CSI_EXE_SOURCES})
    127   SET_TARGET_PROPERTIES(csi-static PROPERTIES COMPILE_FLAGS "${STATIC_FLAGS}")
    128   TARGET_LINK_LIBRARIES(csi-static libchicken-static)
    129   ADD_DEPENDENCIES(csi-static csi-c)
    130 ENDIF(NOT MACOSX)
     118ADD_EXECUTABLE(csi-static ${CSI_EXE_SOURCES})
     119SET_TARGET_PROPERTIES(csi-static PROPERTIES COMPILE_FLAGS "${STATIC_FLAGS}")
     120TARGET_LINK_LIBRARIES(csi-static libchicken-static)
     121ADD_DEPENDENCIES(csi-static csi-c)
    131122
    132123
     
    135126####################################################################
    136127
    137 IF(NOT MACOSX)
    138   ADD_EXECUTABLE(chicken-static ${CHICKEN_EXE_SOURCES})
    139   SET_TARGET_PROPERTIES(chicken-static PROPERTIES COMPILE_FLAGS "${STATIC_FLAGS}")
    140   TARGET_LINK_LIBRARIES(chicken-static libchicken-static)
    141   ADD_DEPENDENCIES(chicken-static chicken-c)
    142 ENDIF(NOT MACOSX)
     128ADD_EXECUTABLE(chicken-static ${CHICKEN_EXE_SOURCES})
     129SET_TARGET_PROPERTIES(chicken-static PROPERTIES COMPILE_FLAGS "${STATIC_FLAGS}")
     130TARGET_LINK_LIBRARIES(chicken-static libchicken-static)
     131ADD_DEPENDENCIES(chicken-static chicken-c)
    143132
    144133
     
    160149ENDIF(WIN32 AND NOT CYGWIN)
    161150
    162 IF(NOT MACOSX)
    163   INSTALL(TARGETS
    164     chicken-static
    165     csi-static
    166     RUNTIME DESTINATION ${BIN_HOME})
    167 ENDIF(NOT MACOSX)
     151INSTALL(TARGETS
     152  chicken-static
     153  csi-static
     154  RUNTIME DESTINATION ${BIN_HOME}
     155)
    168156
    169157
  • chicken/tcp.scm

    r2776 r4232  
    108108    (define-macro (##sys#check-exact x) '(##core#undefined))
    109109    (define-macro (##sys#check-port x) '(##core#undefined))
    110     (define-macro (##sys#check-number x) '(##core#undefined))
    111     (define-macro (##sys#check-byte-vector x) '(##core#undefined)) ) )
     110    (define-macro (##sys#check-number x) '(##core#undefined))))
    112111 (else
    113112  (declare (emit-exports "tcp.exports"))) )
  • chicken/tests/runtests.sh

    r2710 r4232  
    1515echo "======================================== ffi tests ..."
    1616$compile ffi-test.scm && ./a.out
     17
     18echo "======================================== path tests ..."
     19$compile path-tests.scm && ./a.out
    1720
    1821echo "======================================== r4rstest ..."
  • chicken/utils.scm

    r3839 r4232  
    6868    (define-macro (##sys#check-exact . _) '(##core#undefined))
    6969    (define-macro (##sys#check-port . _) '(##core#undefined))
    70     (define-macro (##sys#check-number . _) '(##core#undefined))
    71     (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
     70    (define-macro (##sys#check-number . _) '(##core#undefined)))]
    7271 [else
    7372  (declare (emit-exports "utils.exports"))] )
     
    207206         [rx1 (string-append "^(.*[" set "])?([^" set "]+)(\\.([^" set ".]+))$")]
    208207         [rx2 (string-append "^(.*[" set "])?((\\.)?[^" set "]+)$")]
    209          [string-match string-match]
     208         [string-search string-search]
    210209         [strip-pds
    211210           (lambda (dir)
     
    224223                  (if m
    225224                      (values (strip-pds (cadr m)) (caddr m) #f)
    226                       (values pn #f #f) ) ) ) ) ) ) ) )
     225                      (values (strip-pds pn) #f #f) ) ) ) ) ) ) ) )
    227226
    228227(let ([decompose-pathname decompose-pathname])
  • ezxdisp/ezxdisp.html

    r1403 r4232  
    6161<li>Initialize/Finalize a window</li>
    6262<pre>
    63 (ezx-init SIZE_X SIZE_Y, WINDOW_NAME)  -->  EZX
     63(ezx-init SIZE_X SIZE_Y WINDOW_NAME)  -->  EZX
    6464(ezx-quit EZX)
    6565</pre>
  • rlimit/doc.scm

    r3128 r4232  
    3232
    3333     (history
     34      (version "1.12" ".setup file cleanup")
    3435      (version "1.11" "Windows compile [Kon Lovett]")
    3536      (version "1.1" "Bug fix for setting +inf [Kon Lovett]")
  • rlimit/rlimit.meta

    r2068 r4232  
    66 (license "BSD")
    77 (needs easyffi)
    8  (author
    9    "<a href=\"mailto:felix@call-with-current-continuation.org\">felix</a>")
     8 (eggdoc "doc.scm")
     9 (author "felix winkelmann")
    1010 (files "rlimit.setup" "rlimit.scm" "rlimit.html"))
  • rlimit/rlimit.setup

    r3128 r4232  
    55(install-extension
    66 'rlimit
    7  '("rlimit.so" "rlimit.html")
    8  `((version 1.11) (documentation "rlimit.html")
     7 '("rlimit.so")
     8 `((version 1.12)
     9   (documentation "rlimit.html")
    910   ,@(if exp '((exports "rlimit.exports")) '()) ) )
  • tar/doc.scm

    r274 r4232  
    22
    33(define license
    4 "Copyright (c) 2006, Felix Winkelmann.  All rights reserved.
     4"Copyright (c) 2006-2007, Felix Winkelmann.  All rights reserved.
    55
    66Permission is hereby granted, free of charge, to any person obtaining a
     
    3232
    3333     (history
     34      (version "1.4" "Provides stub user/group id functions with MSVC/mingw32")
    3435      (version "1.3" "space-terminated fields resulted in invalid string->number conversion; termination records")
    3536      (version "1.2" "Fixed some serious bugs")
  • tar/tar.meta

    r2189 r4232  
    66 (license "BSD")
    77 (needs easyffi)
    8  (author
    9    "<a href=\"mailto:felix@call-with-current-continuation.org\">felix</a>")
     8 (eggdoc "doc.scm")
     9 (author "feix winkelmann")
    1010 (files "tar.setup" "tar.scm" "tar.html"))
  • tar/tar.scm

    r274 r4232  
    4949  devmajor
    5050  devminor)
     51
     52#+(or msvc mingw32)
     53(begin
     54  (declare
     55    (hide current-user-id current-group-id
     56          user-information group-information) )
     57  (define (current-user-id) 0)
     58  (define (current-group-id) 0)
     59  (define (user-information _) '("unknown"))
     60  (define (group-information _) '("unknown")) )
    5161
    5262(define (tar:make-header name size
  • tar/tar.setup

    r2189 r4232  
    1 (compile -s -O2 -d0 tar.scm -X easyffi)
    2 (install-extension 'tar '("tar.html" "tar.so") '((version 1.0) (documentation "tar.html")))
     1(compile -s -O2 -d1 tar.scm -X easyffi -emit-exports "tar.exports")
     2(install-extension
     3 'tar
     4 '("tar.so")
     5 '((version 1.4)
     6   (exports "tar.exports")
     7   (documentation "tar.html")))
  • wiki/Unit regex

    r3337 r4232  
    9898Note also that {{string-match}} is implemented by calling
    9999{{string-search}} with the regular expression wrapped in {{^ ... $}}.
     100If invoked with a precompiled regular expression argument (by using
     101{{regexp}}), {{string-match}} is identical to {{string-search}}.
    100102
    101103
  • wiki/codewalk

    r3405 r4232  
    7070; special : special internal form - should normally be treated as a call to an identity function
    7171
    72 Note that external macro packages like [[http://www.call-with-current-continutation.org/eggs/syntax-case.html|syntax-case]]
     72Note that external macro packages like [[http://www.call-with-current-continuation.org/eggs/syntax-case.html|syntax-case]]
    7373expand their input completely, so the {{prehook}} will already get macroexpanded forms.
    7474
  • z3/doc.scm

    r4138 r4232  
    22
    33(define license
    4 "Copyright (c) 2005, 2006 Oskar Schirmer.  All rights reserved.
     4"Copyright (c) 2005-2007 Oskar Schirmer.  All rights reserved.
    55
    66Permission is hereby granted, free of charge, to any person obtaining a
     
    3030
    3131     (history
     32      (version "1.36" "Should compile now on Windows with mingw")
    3233      (version "1.35" "Fixed bug in " (tt "z3:encode-buffer") " [reported by Mario Domenech Goulart]")
    3334      (version "1.34" "Added whole-buffer encoding/decoding")
  • z3/z3.setup

    r4138 r4232  
    1 
    21(compile z3.scm -O2 -d1 -s
    32         -emit-exports "z3.exports"
     
    87 '("z3.so" "z3.html")
    98 '((exports "z3.exports")
    10    (version 1.35)
     9   (version 1.36)
    1110   (documentation "z3.html")))
  • z3/z3flib.c

    r1867 r4232  
    66
    77#include <errno.h>
     8#include <assert.h>
    89#include "z3lib.h"
    910#include "z3liblib.h"
     
    366367    }
    367368    return 0;
    368   default:
    369     return -EPERM; /* shutup compiler */
     369  default: assert(0);
    370370  }
    371371}
  • z3/z3lib.h

    r137 r4232  
    2525#endif
    2626
     27#ifdef _WIN32
     28# define EMSGSIZE    40
     29# define EOVERFLOW   84
     30# define EBADMSG     94
     31# define ENODATA     96
     32# define EPROTO      100
     33#endif
     34
    2735enum z3errno {
    2836  z3err_none,
Note: See TracChangeset for help on using the changeset viewer.