Changeset 4232 in project


Ignore:
Timestamp:
05/20/07 00:32:05 (14 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.