Changeset 4232 in project
- Timestamp:
- 05/20/07 00:32:05 (14 years ago)
- Files:
-
- 1 added
- 42 edited
Legend:
- Unmodified
- Added
- Removed
-
alexpander/alexpander-chicken-macros.scm
r3817 r4232 392 392 (begin . cmd-or-defs*) 393 393 (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 3 3 'alexpander 4 4 '("alexpander.so" "alexpander-chicken-macros.scm") 5 '((version "1.58. 8")5 '((version "1.58.9") 6 6 (documentation "alexpander.html") 7 7 (require-at-runtime records) -
alexpander/doc.scm
r3817 r4232 43 43 44 44 (history 45 (version "1.58.9" "added " (tt "fluid-let")) 45 46 (version "1.58.8" "added toplevel " (tt "include") " and " (tt "cond-expand")) 46 47 (version "1.58.7" "added some non-standard macros, uses records egg now") … … 409 410 cond-expand 410 411 include 412 fluid-let 411 413 412 414 `include' should only be used at toplevel. `cond-expand' recognizes the following -
chicken/CMakeLists.txt
r3839 r4232 537 537 IF(NOT EXTANT_CHICKEN) 538 538 FIND_PROGRAM(EXTANT_CHICKEN 539 NAMES chicken -static chicken539 NAMES chicken chicken-static 540 540 PATHS $ENV{CHICKEN_HOME} $ENV{CHICKEN_HOME}/bin 541 541 ) … … 982 982 983 983 IF(${CMAKE_SYSTEM_NAME} MATCHES "Darwin") 984 SET(MACOSX TRUE) 985 ELSE(${CMAKE_SYSTEM_NAME} MATCHES "Darwin") 986 SET(MACOSX FALSE) 987 ENDIF(${CMAKE_SYSTEM_NAME} MATCHES "Darwin") 988 989 IF(MACOSX) 984 990 SET(SHARED_FLAGS "${SHARED_FLAGS} -fno-common -no-cpp-precomp") 985 ENDIF( ${CMAKE_SYSTEM_NAME} MATCHES "Darwin")991 ENDIF(MACOSX) 986 992 987 993 # Unix platforms can get into trouble if they don't have -lm. … … 1679 1685 # To work around these problems, we build all static libs and exes 1680 1686 # 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 1691 IF(NOT MACOSX) 1692 ADD_SUBDIRECTORY(static) 1693 ENDIF(NOT MACOSX) 1683 1694 1684 1695 -
chicken/README
r3839 r4232 3 3 (c)2000-2007 Felix L. Winkelmann 4 4 5 Version 2.61 05 Version 2.615 6 6 7 7 -
chicken/benchmarks/fib.scm
r1016 r4232 6 6 (+ (fib (- n 1)) (fib (- n 2))) ) ) 7 7 8 (time ( fib 30))8 (time (pp (fib 40))) -
chicken/boot/CMakeLists.txt
r2926 r4232 7 7 8 8 # 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 static10 # 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: 12 12 # libchicken-boot 13 13 # chicken-boot … … 105 105 ADD_CUSTOM_TARGET(libchicken-boot-c DEPENDS ${LIBCHICKEN_BOOT_SOURCES}) 106 106 107 ADD_LIBRARY(libchicken-boot S TATIC${LIBCHICKEN_BOOT_SOURCES} ${PCRE_HEADER})107 ADD_LIBRARY(libchicken-boot SHARED ${LIBCHICKEN_BOOT_SOURCES} ${PCRE_HEADER}) 108 108 SET_TARGET_PROPERTIES(libchicken-boot PROPERTIES 109 COMPILE_FLAGS "-DC_BUILDING_LIBCHICKEN ${S TATIC_FLAGS}"109 COMPILE_FLAGS "-DC_BUILDING_LIBCHICKEN ${SHARED_FLAGS}" 110 110 OUTPUT_NAME chicken-boot) 111 111 IF(MSVC) 112 112 SET_TARGET_PROPERTIES(libchicken-boot PROPERTIES PREFIX "lib") 113 113 ENDIF(MSVC) 114 TARGET_LINK_LIBRARIES(libchicken-boot ${MORE_STATIC_LIBS})114 TARGET_LINK_LIBRARIES(libchicken-boot libpcre-for-shared ${MORE_LIBS}) 115 115 ADD_DEPENDENCIES(libchicken-boot libchicken-boot-c) 116 116 … … 124 124 125 125 ADD_EXECUTABLE(chicken-boot ${CHICKEN_BOOT_SOURCES}) 126 SET_TARGET_PROPERTIES(chicken-boot PROPERTIES COMPILE_FLAGS "${S TATIC_FLAGS}")127 TARGET_LINK_LIBRARIES(chicken-boot libchicken-boot libpcre-for-static)126 SET_TARGET_PROPERTIES(chicken-boot PROPERTIES COMPILE_FLAGS "${SHARED_FLAGS}") 127 TARGET_LINK_LIBRARIES(chicken-boot libchicken-boot) 128 128 ADD_DEPENDENCIES(chicken-boot chicken-boot-c) 129 129 -
chicken/build.scm
r3839 r4232 1 (define-constant +build-version+ "2.61 0")1 (define-constant +build-version+ "2.615") -
chicken/buildversion
r3839 r4232 1 2.61 01 2.615 -
chicken/chicken-more-macros.scm
r3839 r4232 893 893 894 894 895 ;;; ;SRFI-31895 ;;; SRFI-31 896 896 897 897 (define-macro (rec head . args) … … 915 915 916 916 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 918 948 919 949 (eval-when (compile load eval) -
chicken/chicken-profile.scm
r2776 r4232 36 36 (declare 37 37 (block) 38 (uses srfi-1 ))39 38 (uses srfi-1 39 srfi-13)) 40 40 41 41 (define sort-by #f) 42 42 (define file #f) 43 43 (define no-unused #f) 44 (define seconds-digits 3) 45 (define average-digits 3) 46 (define percent-digits 3) 47 (define top 0) 44 48 45 49 (define (print-usage) 46 (display #< <EOF50 (display #<#EOF 47 51 Usage: chicken-profile [FILENAME | OPTION] ... 48 52 … … 51 55 -sort-by-avg sort output by average procedure execution time 52 56 -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}) 53 59 -no-unused remove procedures that are never called 60 -top N display only the top N entries 54 61 -help show this text and exit 55 62 -version show version and exit … … 70 77 (let ([arg (car args)] 71 78 [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)))) 72 88 (match arg 73 89 [(or "-h" "-help" "--help") (print-usage)] … … 79 95 (exit) ] 80 96 ["-no-unused" (set! no-unused #t)] 97 ["-top" (set! top (next-number))] 81 98 ["-sort-by-calls" (set! sort-by sort-by-calls)] 82 99 ["-sort-by-time" (set! sort-by sort-by-time)] 83 100 ["-sort-by-avg" (set! sort-by sort-by-avg)] 84 101 ["-sort-by-name" (set! sort-by sort-by-name)] 102 ["-decimals" (set-decimals (next-arg))] 85 103 [_ (cond [(and (> (string-length arg) 1) (char=? #\- (string-ref arg 0))) 86 104 (error "invalid option" arg) ] … … 114 132 115 133 (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))) 116 148 117 149 (define (read-profile) … … 130 162 (string-append str pad) ) ) ) 131 163 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))))) 141 175 142 176 (define (write-profile) … … 155 189 )))) 156 190 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 187 223 (run (command-line-arguments)) -
chicken/chicken-setup.scm
r3839 r4232 60 60 #endif 61 61 62 #ifdef _WIN3263 /* 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 #else71 static void create_directory(char *pathname) {}72 #endif73 74 62 #ifndef C_TARGET_CC 75 63 # define C_TARGET_CC C_INSTALL_CC … … 99 87 100 88 (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" 102 90 "-fetch" "-host" "-proxy" "-keep" "-verbose" "-csc-option" "-dont-ask" "-no-install" "-docindex" "-eval" 103 91 "-debug" "-ls" "-release" "-test" "-fetch-tree" "-tree" "-svn" "-local" "-destdir" "-revision") ) 104 92 105 93 (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) ) 107 95 108 96 … … 133 121 134 122 (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))) ) ) ) 135 131 136 132 (define create-directory … … 141 137 (lambda (dir) 142 138 (verb dir) 143 ( (foreign-lambda void "create_directory" c-string)dir) )139 (create-directory/parents dir) ) 144 140 (lambda (dir) 145 141 (verb dir) … … 164 160 (define *dont-ask* #f) 165 161 (define *rebuild-doc-index* #f) 166 (define *check-repository* #f)167 162 (define *repository-tree* #f) 168 163 (define *last-decent-host* #f) … … 177 172 (define *repository-hosts* '(("www.call-with-current-continuation.org" "eggs" 80))) 178 173 (define *revision* #f) 179 (define *repository-tree-downloaded* #f)180 174 181 175 … … 410 404 -n -no-install don't install generated binaries and support files 411 405 -i -docindex display path for documentation index 412 -C -check check for available upgrades413 406 -e -eval EXPRESSION evaluate expression 414 407 -t -test EXTENSION ... return success if all given extensions are installed … … 534 527 (to (if (pair? from) (make-pathname to (cadr from)) to)) ) 535 528 (ensure-directory to) 536 (cond (( file-exists? from)529 (cond ((or (glob? from) (file-exists? from)) 537 530 (run (,*copy-command* ,(quotewrap from) ,(quotewrap to))) ) 538 531 (err (error "file does not exist" from)) … … 569 562 (#f default) 570 563 ("so" ##sys#load-dynamic-extension) 571 ("o" (if *windows-shell* "obj" "o"))572 564 ("a" (if *windows-shell* "lib" "a")) 573 565 (x x) ) ) ) … … 650 642 (when (setup-install-flag) 651 643 (let* ((files (check-filelist (if (list? files) files (list files)))) 652 (ppath ( program-path))644 (ppath (if *destdir* (make-pathname *destdir* "bin") (program-path))) 653 645 (pfiles (map (lambda (f) 654 646 (let ((from (if (pair? f) (car f) f)) … … 698 690 (run (chmod a+x ,dir))))))) 699 691 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)) 701 694 (let* ((fname (create-temporary-file "c")) 702 695 (oname (pathname-replace-extension fname "o")) … … 812 805 (begin 813 806 (set! *repository-tree* (read i)) 814 (set! *repository-tree-downloaded* #t)815 807 (when *debug* 816 808 (print "catalog:") … … 877 869 878 870 (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) )887 871 (define (requirements reqs) 888 872 (fold … … 893 877 ((memq r ##sys#core-library-modules) reqs) 894 878 (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 (else906 (print "Test cancelled - aborting")907 (abort-setup) ) ) )908 879 (else (requirements (eval-req r) )) ) ) 909 880 '() … … 1111 1082 string<?) ) ) 1112 1083 1113 (define (check-for-upgrades)1114 (download-repository-tree)1115 (for-each1116 (match-lambda1117 ((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 (print1123 (format-string (symbol->string name) 32)1124 (if infoa (conc "installed: " (cadr infoa) ", ") "")1125 "available: " (cadr a) ) ) ) ) ) )1126 *repository-tree*) )1127 1128 1084 (define (main args) 1129 1085 (define (parse-host host eggdir) … … 1240 1196 (("-revision" rev . more) 1241 1197 (set! *revision* rev) 1242 (loop more) )1243 (("-check" . more)1244 (set! *check-repository* #t)1245 (set! anydone #t)1246 1198 (loop more) ) 1247 1199 (("-svn" url . more) … … 1290 1242 (printf "No setup scripts to process~%") 1291 1243 (for-each (if uinst uninstall-extension install) setups) ) ) ) 1292 (when *check-repository* (check-for-upgrades))1293 1244 (when *fetch-tree-only* 1294 1245 (download-repository-tree) -
chicken/chicken.h
r3839 r4232 170 170 #if defined(__APPLE__) && defined(__MACH__) 171 171 # 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 */177 172 #endif 178 173 … … 226 221 #endif 227 222 228 #if defined( __linux__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__)223 #if defined(C_MACOSX) || defined(__linux__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) 229 224 # define C_GNU_ENV 230 225 #endif -
chicken/compiler.scm
r3839 r4232 208 208 ; boxed -> <boolean> If true: variable has to be boxed after closure-conversion 209 209 ; contractable -> <boolean> If true: variable names contractable procedure 210 ; inlinable -> <boolean> If true: variable names potentially inlinable procedure210 ; inlinable -> <boolean> If true: variable names potentially inlinable procedure 211 211 ; collapsable -> <boolean> If true: variable refers to collapsable constant 212 212 ; removable -> <boolean> If true: variable is not used … … 272 272 direct-call-ids foreign-type-table first-analysis callback-names namespace-table disabled-warnings 273 273 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 275 275 perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization! 276 276 reorganize-recursive-bindings substitution-table simplify-named-call inline-max-size … … 431 431 (define postponed-initforms '()) 432 432 (define unused-variables '()) 433 (define compiler-macro-table #f) 433 434 434 435 … … 973 974 (walk `(##sys#make-locative ,sym 0 #f 'location) ae me #f) ) ) ] 974 975 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 975 983 [else (handle-call)] ) ) ) ) ] ) ) ) ) 976 984 -
chicken/configure.in
r3839 r4232 90 90 AC_CHECK_DECL([__MINGW32__], [mingw_system=1]) 91 91 92 dnl Check for Cygwin 93 AC_MSG_CHECKING([whether we are running on Cygwin]) 94 echo 95 AC_CHECK_DECL([__CYGWIN__], [cygwin_system=1]) 96 92 97 dnl Check for MinGW library path, with the all important drive letter 93 98 if test -n "${mingw_system}"; then 94 99 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 105 fi 106 AM_CONDITIONAL(IS_MINGW, [test -n "${mingw_system}"]) 98 107 if test -n "${mingw_ws2}"; then 99 108 WINSOCKLIB="-L${mingw_libdir} -lws2_32" … … 115 124 AC_CHECK_HEADER(windows.h, [AC_DEFINE(HAVE_WINDOWS_H,1,[Define if windows.h is useable])]) 116 125 AC_CHECK_HEADER(grp.h, [AC_DEFINE(HAVE_GRP_H,1,[Define if grp.h is available])]) 126 127 if test x"${cygwin_system}" = x1; then 128 USE_LIBFFI=no 129 fi 117 130 118 131 if test x"$USE_LIBFFI" = xyes; then -
chicken/csc-trans
r3839 r4232 13 13 OUTPUT=- 14 14 ALL=0 15 while getopts ":a23ufbihprcotl :" opt; do15 while getopts ":a23ufbihprcotlI:" opt; do 16 16 case $opt in 17 17 a ) ALL="1";; … … 25 25 b ) CSC_OPTS="$CSC_OPTS -block";; 26 26 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";; 28 29 2 ) CSC_OPTS="$CSC_OPTS -O2";; 29 30 3 ) CSC_OPTS="$CSC_OPTS -O3";; -
chicken/csc.scm
r3839 r4232 129 129 default) ) 130 130 131 (define (quotewrap str) 132 (if (string-any char-whitespace? str) 133 (string-append "\"" str "\"") 134 str) ) 135 131 136 (define home 132 137 (or (getenv "CHICKEN_HOME") … … 139 144 140 145 (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) )146 146 147 147 (define translator … … 192 192 (if win 193 193 (begin 194 ; Windows cmd parsing precludes quoting anything but the command! 195 ; This makes driving the various translators with whitespace embedded 196 ; filenames impossible. 194 197 (define (cleanup-filename s) (string-translate s "/" "\\")) ; we need this to please the MSVC tools 195 198 (define default-compilation-optimization-options '("/nologo")) … … 198 201 (define best-compilation-optimization-options '("/O2" "/nologo")) ) 199 202 (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))) 201 207 (define default-compilation-optimization-options (string-split (if host-mode INSTALL_CFLAGS TARGET_CFLAGS))) 202 208 (define best-compilation-optimization-options default-compilation-optimization-options) … … 372 378 (cons* (string-append 373 379 "/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") '())) ) 376 382 (if include-dir (list "-I" include-dir) '())) ) 377 383 … … 547 553 -libs show required libraries and exit 548 554 -cc-name show name of default C compiler used 555 -cxx-name show name of default C++ compiler used 549 556 -ld-name show name of default linker used 550 557 -dry-run just show commands executed, don't run them … … 635 642 (printf "Warning: output file will overwrite source file `~A' - renaming source to `~A.old'~%" 636 643 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))) 638 645 (exit last-exit-code) ) ) 639 646 (run-linking)) ) ] … … 672 679 (set! show-ldflags #t) ] 673 680 [(-cc-name) (print compiler) (exit 0)] 681 [(-cxx-name) (print c++-compiler) (exit 0)] 674 682 [(-ld-name) (print linker) (exit 0)] 675 683 [(-home) (print home) (exit 0)] … … 856 864 (let ([x (with-input-from-file cscf read-line)]) 857 865 (or (eof-object? x) (string=? "#%eof" x)) ) ) 858 ( delete-file*cscf) )866 ($delete-file cscf) ) 859 867 (let ([fc (pathname-replace-extension 860 868 (if (= 1 (length scheme-files)) … … 865 873 (else "c") ) ) ] ) 866 874 (unless (zero? 867 ( system*875 ($system 868 876 (string-intersperse 869 (cons* translator f877 (cons* translator (cleanup-filename f) 870 878 (append 871 879 (if to-stdout 872 880 '("-to-stdout") 873 `("-output-file" , fc) )881 `("-output-file" ,(cleanup-filename fc)) ) 874 882 (if (or static static-libs static-extensions) 875 883 (map (lambda (e) (conc "-uses " e)) required-extensions) … … 887 895 (match-lambda 888 896 [('post-process commands ...) 889 (for-each system*commands) ]897 (for-each $system commands) ] 890 898 [('c-options opts ...) 891 899 (set! compile-options (append compile-options opts)) ] … … 894 902 [x (error "invalid entry in csc control file" x)] ) 895 903 (read-file) ) ) ) 896 ( delete-file*cscf) ) ) ) )904 ($delete-file cscf) ) ) ) ) 897 905 (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)) ) 899 907 900 908 … … 906 914 (let ([fo (pathname-replace-extension f object-extension)]) 907 915 (unless (zero? 908 ( system*916 ($system 909 917 (string-intersperse 910 918 (list (cond (cpp-mode c++-compiler) … … 918 926 (set! object-files (cons fo object-files)) ) ) 919 927 (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)) ) 921 929 922 930 (define (compiler-options) … … 939 947 (if gui gui-shared-library-files shared-library-files) ) ) ) ] ) 940 948 (unless (zero? 941 ( system*949 ($system 942 950 (string-intersperse 943 951 (cons* (cond (cpp-mode c++-linker) … … 950 958 (exit last-exit-code) ) 951 959 (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)) ) ) 955 963 956 964 (define (static-extension-info) … … 992 1000 (define-constant +hairy-chars+ '(#\\ #\#)) 993 1001 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 1001 1002 (define (cleanup s) 1002 1003 (let* ((q #f) … … 1014 1015 s) ) ) 1015 1016 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 1016 1024 (define last-exit-code #f) 1017 1025 1018 (define ( system*str)1026 (define ($system str) 1019 1027 (when verbose (print str)) 1020 1028 (set! last-exit-code … … 1028 1036 last-exit-code) 1029 1037 1030 (define ( delete-file*str)1038 (define ($delete-file str) 1031 1039 (when verbose 1032 1040 (if win -
chicken/extras.scm
r3839 r4232 421 421 422 422 (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))) ) ) )))) 440 442 441 443 (define (read-string! n dest #!optional (port ##sys#standard-input) (start 0)) -
chicken/library.scm
r3839 r4232 1800 1800 (apply ##sys#values results) ) ) ) ) ) ) 1801 1801 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?) ) ) ) 1808 1818 1809 1819 (define (##sys#flush-output port) … … 2657 2667 (or (fx<= c 32) 2658 2668 (fx>= c 128) 2659 (memq chr '(#\( #\) #\| #\, #\[ #\] #\{ #\} #\' #\" #\; #\\ )) ) ) )2669 (memq chr '(#\( #\) #\| #\, #\[ #\] #\{ #\} #\' #\" #\; #\\ #\`)) ) ) ) 2660 2670 2661 2671 (define (outreadablesym port str) … … 2666 2676 (outchr port #\|) 2667 2677 (let ([c (##core#inline "C_subchar" str i)]) 2668 (when ( eq? c #\|) (outchr port #\\))2678 (when (or (eq? c #\|) (eq? c #\\)) (outchr port #\\)) 2669 2679 (outchr port c) 2670 2680 (loop (fx+ i 1)) ) ) ) ) ) … … 4207 4217 (newline port) ] 4208 4218 [else 4209 (display " uncaught exception: " port)4219 (display ": uncaught exception: " port) 4210 4220 (writeargs (list ex) port) ] ) ) ) ) ) 4211 4221 -
chicken/lolevel.scm
r3839 r4232 51 51 #define C_w2b(x) C_fix(C_wordstobytes(C_unfix(x))) 52 52 #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)) 53 54 EOF 54 55 ) ) … … 94 95 95 96 (define move-memory! 96 (let ([memmove1 (foreign-lambda void "C_memmove " c-pointer c-pointerint)]97 [memmove2 (foreign-lambda void "C_memmove " c-pointer scheme-pointerint)]98 [memmove3 (foreign-lambda void "C_memmove " scheme-pointer c-pointerint)]99 [memmove4 (foreign-lambda void "C_memmove " scheme-pointer scheme-pointerint)]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)] 100 101 [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)) 102 103 (define (err) (##sys#error 'move-memory! "need number of bytes to move" from to)) 103 104 (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))]) 106 107 n 107 108 (##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)))]) 110 111 n 111 112 (##sys#error 'move-memory! "number of bytes to move too large" from to n nmax nmax2) ) ) … … 120 121 (xerr to) ) ] 121 122 [(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)] 123 125 [(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) ] 125 127 [else (xerr to)] ) ] 126 128 [(or (##sys#bytevector? from) (string? from)) 127 129 (let ([nfrom (##sys#size from)]) 128 130 (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)] 130 132 [(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) ] 132 135 [else (xerr to)] ) ) ] 133 136 [else (xerr from)] ) ) ) ) ) … … 498 501 (let* ([n (##sys#size x)] 499 502 [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 else503 [y (##core#inline "C_copy_block" x (make-vector words))] ) 501 504 (unless (or (##core#inline "C_byteblockp" x) (symbol? x)) 502 505 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)]) … … 683 686 (##sys#become! lst) ) ] ) ) 684 687 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 685 697 686 698 ;;; locatives: -
chicken/posixunix.scm
r3839 r4232 244 244 } 245 245 246 static void C_fcall C_free_exec_args() { 247 char **a = C_exec_args; 248 while((*a) != NULL) C_free(*(a++)); 246 static void C_fcall C_free_arg_string(char **where) { 247 while((*where) != NULL) C_free(*(where++)); 249 248 } 250 249 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) 258 254 259 255 #define C_execvp(f) C_fix(execvp(C_data_pointer(f), C_exec_args)) … … 1864 1860 (##sys#check-list arglist 'process-execute) 1865 1861 (let ([s (pathname-strip-directory filename)]) 1866 (setarg 0 s (##sys#size s)) )1862 (setarg 0 s (##sys#size s)) ) 1867 1863 (do ([al arglist (cdr al)] 1868 1864 [i 1 (fx+ i 1)] ) … … 1870 1866 (setarg i #f 0) 1871 1867 (when envlist 1868 (##sys#check-list envlist 'process-execute) 1872 1869 (do ([el envlist (cdr el)] 1873 1870 [i 0 (fx+ i 1)] ) … … 1924 1921 (let ([r (##core#inline "C_kill" id sig)]) 1925 1922 (when (fx= r -1) (posix-error #:process-error 'process-signal "could not send signal to process" id sig) ) ) ) ) ) 1926 1927 ;FIXME - shouldn't be private1928 1923 1929 1924 (define (##sys#shell-command) … … 2051 2046 (let ([%process 2052 2047 (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) ) ) ) )] ) 2069 2063 (set! process 2070 2064 (lambda (cmd #!optional args env) -
chicken/posixwin.scm
r3839 r4232 64 64 65 65 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 66 73 (declare 67 74 (unit posix) … … 69 76 (disable-interrupts) 70 77 (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) 72 80 (foreign-declare #<<EOF 73 81 #ifndef WIN32_LEAN_AND_MEAN … … 104 112 #include <time.h> 105 113 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 108 119 109 120 static C_TLS char *C_exec_args[ ARG_MAX ]; 121 static C_TLS char *C_exec_env[ ENV_MAX ]; 110 122 static C_TLS struct group *C_group; 111 123 static C_TLS int C_pipefds[ 2 ]; … … 120 132 static C_TLS int C_exstatus; 121 133 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 */ 135 static C_TLS char C_hostname[256] = ""; 136 static C_TLS char C_osver[16] = ""; 137 static C_TLS char C_osrel[16] = ""; 138 static C_TLS char C_processor[16] = ""; 139 static C_TLS char C_shlcmd[256] = ""; 127 140 128 141 #define C_mkdir(str) C_fix(mkdir(C_c_string(str))) … … 262 275 } 263 276 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) { 277 static void C_fcall C_set_arg_string(char **where, int i, char *a, int len) { 266 278 char *ptr; 267 279 if(a != NULL) { … … 271 283 } 272 284 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 288 static 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) 281 296 282 297 #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)) 283 299 284 300 /* MS replacement for the fork-exec pair */ 285 301 #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)) 286 303 287 304 #define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m))) … … 290 307 #define C_mkstemp(t) C_fix(mktemp(C_c_string(t))) 291 308 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()) 295 314 296 315 #define C_ctime(n) (C_secs = (n), ctime(&C_secs)) 297 316 298 317 #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) 300 319 301 320 /* … … 372 391 } 373 392 393 static int set_last_errno() 394 { 395 set_errno(GetLastError()); 396 return 0; 397 } 398 374 399 /* functions for creating process with redirected I/O */ 375 400 static int zero_handles() … … 428 453 &C_rd1_, 0, FALSE, DUPLICATE_SAME_ACCESS)) 429 454 { 430 set_ errno(GetLastError());455 set_last_errno(); 431 456 close_handles(); 432 457 return 0; … … 452 477 453 478 if (CreateProcess(NULL, cmdline, NULL, NULL, TRUE, 0, NULL, 454 NULL, &si, &pi))479 NULL, &si, &pi)) 455 480 { 456 481 CloseHandle(pi.hThread); … … 466 491 } 467 492 else 468 { 469 set_errno(GetLastError()); 470 return 0; 471 } 493 return set_last_errno(); 472 494 } 473 495 … … 478 500 return 1; 479 501 else 480 { 481 set_errno(GetLastError()); 482 return 0; 483 } 502 return set_last_errno(); 484 503 } 485 504 … … 498 517 return -1; 499 518 } 500 set_errno(GetLastError()); 501 return 0; 519 return set_last_errno(); 502 520 } 503 521 … … 538 556 } 539 557 } 540 set_errno(GetLastError()); 541 return 0; 558 return set_last_errno(); 542 559 } 543 560 … … 547 564 int get_hostname() 548 565 { 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 } 557 582 } 558 583 559 584 int sysinfo() 560 585 { 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 643 static 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; 612 661 } 613 662 614 663 #define C_get_hostname() (get_hostname() ? C_SCHEME_TRUE : C_SCHEME_FALSE) 615 664 #define C_sysinfo() (sysinfo() ? C_SCHEME_TRUE : C_SCHEME_FALSE) 665 #define C_get_shlcmd() (get_shlcmd() ? C_SCHEME_TRUE : C_SCHEME_FALSE) 616 666 617 667 /* 618 Spawn a process , either through shell ordirectly.668 Spawn a process directly. 619 669 Params: 620 cmd Command to execute. 670 app Command to execute. 671 cmdlin Command line (arguments). 621 672 env Environment for the new process (may be NULL). 622 673 handle, stdin, stdout, stderr … … 629 680 Bit 2: Share standard output if bit is set. 630 681 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. 634 684 */ 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}; 685 static 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 }; 651 694 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] = { 654 697 GetStdHandle(STD_INPUT_HANDLE), 655 698 GetStdHandle(STD_OUTPUT_HANDLE), 656 699 GetStdHandle(STD_ERROR_HANDLE)}; 657 658 const char modes[3]="rww"; 700 const char modes[3] = "rww"; 659 701 HANDLE cur_process = GetCurrentProcess(), child_process = NULL; 702 void* envblk = NULL; 660 703 661 704 /****** create io handles & fds ***/ 662 705 663 for (i=0; i<3 && exit_code == 0; ++i)706 for (i=0; i<3 && success; ++i) 664 707 { 665 708 if (f_share_io[i]) 666 709 { 667 exit_code = !DuplicateHandle(710 success = DuplicateHandle( 668 711 cur_process, standard_io_handles[i], 669 712 cur_process, &child_io_handles[i], … … 672 715 else 673 716 { 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) 677 720 { 721 HANDLE parent_end; 678 722 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; 680 725 } 681 exit_code=(io_fds[i]=_open_osfhandle((long)parent_end,0))<0;682 726 } 683 727 } … … 685 729 /****** make handles inheritable */ 686 730 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)) 700 745 { 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'; 707 753 } 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 } 714 757 #endif 715 invoke_cmd = cmd;716 758 717 759 /****** finally spawn process ****/ 718 760 719 if ( 0==exit_code)761 if (success) 720 762 { 721 763 PROCESS_INFORMATION pi; … … 730 772 si.hStdError = child_io_handles[2]; 731 773 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) 736 779 { 737 780 child_process=pi.hProcess; 738 781 CloseHandle(pi.hThread); 739 782 } 740 } 783 else 784 set_last_errno(); 785 } 786 else 787 set_last_errno(); 741 788 742 789 /****** cleanup & return *********/ 743 790 744 free(buf);791 /* parent must close child end */ 745 792 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) 752 795 { 753 796 *phandle = (int)child_process; … … 756 799 *pstderr_fd = io_fds[2]; 757 800 } 758 759 return exit_code; 801 else 802 { 803 for (i=0; i<3; ++i) _close(io_fds[i]); 804 } 805 806 return success; 760 807 } 761 808 EOF … … 1521 1568 (define spawn/detach _p_detach) 1522 1569 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 1524 1602 (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))) ) ) 1571 1645 1572 1646 (define current-process-id (foreign-lambda int "C_getpid")) 1573 1647 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") ) ) ) ) 1590 1657 1591 1658 (define (##sys#shell-command-arguments cmdlin) … … 1610 1677 1611 1678 ; 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 1612 1691 (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 1627 1708 (values 1628 1709 (and stdoutf (open-input-file* stdout_fd)) ;Parent stdin … … 1632 1713 (begin 1633 1714 (##sys#update-errno) 1634 (##sys#signal-hook #:process-error loc "cannot execute process" c ommandline))) ) ) ) ) ) )1715 (##sys#signal-hook #:process-error loc "cannot execute process" cmdlin))) ) ) ) ) ) ) 1635 1716 1636 1717 #;(define process (void)) 1637 1718 #;(define process* (void)) 1638 1719 (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) 1645 1728 (begin 1729 (set! exactf #t) 1646 1730 (set! args (##sys#shell-command-arguments cmd)) 1647 1731 (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) ) ) ) )] ) 1655 1737 (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) )) 1658 1740 (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) )) ) 1661 1743 1662 1744 (define-foreign-variable _exstatus int "C_exstatus") -
chicken/runtime.c
r3839 r4232 3834 3834 char *buf = buffer; 3835 3835 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 3836 3840 if(n >= STRING_BUFFER_SIZE) { 3837 3841 if((buf = (char *)C_malloc(n + 1)) == NULL) -
chicken/site/index.html
r3839 r4232 151 151 152 152 Latest development snapshot: <a 153 href="http://www.call-with-current-continuation.org/chicken-2.6 08.tar.gz">chicken-2.608.tar.gz</a>153 href="http://www.call-with-current-continuation.org/chicken-2.613.tar.gz">chicken-2.613.tar.gz</a> 154 154 and <a href="http://www.call-with-current-continuation.org/ChangeLog.txt">(Change log)</a> 155 155 -
chicken/static/CMakeLists.txt
r3241 r4232 115 115 #################################################################### 116 116 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")122 117 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) 118 ADD_EXECUTABLE(csi-static ${CSI_EXE_SOURCES}) 119 SET_TARGET_PROPERTIES(csi-static PROPERTIES COMPILE_FLAGS "${STATIC_FLAGS}") 120 TARGET_LINK_LIBRARIES(csi-static libchicken-static) 121 ADD_DEPENDENCIES(csi-static csi-c) 131 122 132 123 … … 135 126 #################################################################### 136 127 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) 128 ADD_EXECUTABLE(chicken-static ${CHICKEN_EXE_SOURCES}) 129 SET_TARGET_PROPERTIES(chicken-static PROPERTIES COMPILE_FLAGS "${STATIC_FLAGS}") 130 TARGET_LINK_LIBRARIES(chicken-static libchicken-static) 131 ADD_DEPENDENCIES(chicken-static chicken-c) 143 132 144 133 … … 160 149 ENDIF(WIN32 AND NOT CYGWIN) 161 150 162 IF(NOT MACOSX) 163 INSTALL(TARGETS 164 chicken-static 165 csi-static 166 RUNTIME DESTINATION ${BIN_HOME}) 167 ENDIF(NOT MACOSX) 151 INSTALL(TARGETS 152 chicken-static 153 csi-static 154 RUNTIME DESTINATION ${BIN_HOME} 155 ) 168 156 169 157 -
chicken/tcp.scm
r2776 r4232 108 108 (define-macro (##sys#check-exact x) '(##core#undefined)) 109 109 (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)))) 112 111 (else 113 112 (declare (emit-exports "tcp.exports"))) ) -
chicken/tests/runtests.sh
r2710 r4232 15 15 echo "======================================== ffi tests ..." 16 16 $compile ffi-test.scm && ./a.out 17 18 echo "======================================== path tests ..." 19 $compile path-tests.scm && ./a.out 17 20 18 21 echo "======================================== r4rstest ..." -
chicken/utils.scm
r3839 r4232 68 68 (define-macro (##sys#check-exact . _) '(##core#undefined)) 69 69 (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)))] 72 71 [else 73 72 (declare (emit-exports "utils.exports"))] ) … … 207 206 [rx1 (string-append "^(.*[" set "])?([^" set "]+)(\\.([^" set ".]+))$")] 208 207 [rx2 (string-append "^(.*[" set "])?((\\.)?[^" set "]+)$")] 209 [string- match string-match]208 [string-search string-search] 210 209 [strip-pds 211 210 (lambda (dir) … … 224 223 (if m 225 224 (values (strip-pds (cadr m)) (caddr m) #f) 226 (values pn#f #f) ) ) ) ) ) ) ) )225 (values (strip-pds pn) #f #f) ) ) ) ) ) ) ) ) 227 226 228 227 (let ([decompose-pathname decompose-pathname]) -
ezxdisp/ezxdisp.html
r1403 r4232 61 61 <li>Initialize/Finalize a window</li> 62 62 <pre> 63 (ezx-init SIZE_X SIZE_Y ,WINDOW_NAME) --> EZX63 (ezx-init SIZE_X SIZE_Y WINDOW_NAME) --> EZX 64 64 (ezx-quit EZX) 65 65 </pre> -
rlimit/doc.scm
r3128 r4232 32 32 33 33 (history 34 (version "1.12" ".setup file cleanup") 34 35 (version "1.11" "Windows compile [Kon Lovett]") 35 36 (version "1.1" "Bug fix for setting +inf [Kon Lovett]") -
rlimit/rlimit.meta
r2068 r4232 6 6 (license "BSD") 7 7 (needs easyffi) 8 ( author9 "<a href=\"mailto:felix@call-with-current-continuation.org\">felix</a>")8 (eggdoc "doc.scm") 9 (author "felix winkelmann") 10 10 (files "rlimit.setup" "rlimit.scm" "rlimit.html")) -
rlimit/rlimit.setup
r3128 r4232 5 5 (install-extension 6 6 'rlimit 7 '("rlimit.so" "rlimit.html") 8 `((version 1.11) (documentation "rlimit.html") 7 '("rlimit.so") 8 `((version 1.12) 9 (documentation "rlimit.html") 9 10 ,@(if exp '((exports "rlimit.exports")) '()) ) ) -
tar/doc.scm
r274 r4232 2 2 3 3 (define license 4 "Copyright (c) 2006 , Felix Winkelmann. All rights reserved.4 "Copyright (c) 2006-2007, Felix Winkelmann. All rights reserved. 5 5 6 6 Permission is hereby granted, free of charge, to any person obtaining a … … 32 32 33 33 (history 34 (version "1.4" "Provides stub user/group id functions with MSVC/mingw32") 34 35 (version "1.3" "space-terminated fields resulted in invalid string->number conversion; termination records") 35 36 (version "1.2" "Fixed some serious bugs") -
tar/tar.meta
r2189 r4232 6 6 (license "BSD") 7 7 (needs easyffi) 8 ( author9 "<a href=\"mailto:felix@call-with-current-continuation.org\">felix</a>")8 (eggdoc "doc.scm") 9 (author "feix winkelmann") 10 10 (files "tar.setup" "tar.scm" "tar.html")) -
tar/tar.scm
r274 r4232 49 49 devmajor 50 50 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")) ) 51 61 52 62 (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 98 98 Note also that {{string-match}} is implemented by calling 99 99 {{string-search}} with the regular expression wrapped in {{^ ... $}}. 100 If invoked with a precompiled regular expression argument (by using 101 {{regexp}}), {{string-match}} is identical to {{string-search}}. 100 102 101 103 -
wiki/codewalk
r3405 r4232 70 70 ; special : special internal form - should normally be treated as a call to an identity function 71 71 72 Note that external macro packages like [[http://www.call-with-current-continu tation.org/eggs/syntax-case.html|syntax-case]]72 Note that external macro packages like [[http://www.call-with-current-continuation.org/eggs/syntax-case.html|syntax-case]] 73 73 expand their input completely, so the {{prehook}} will already get macroexpanded forms. 74 74 -
z3/doc.scm
r4138 r4232 2 2 3 3 (define license 4 "Copyright (c) 2005 , 2006Oskar Schirmer. All rights reserved.4 "Copyright (c) 2005-2007 Oskar Schirmer. All rights reserved. 5 5 6 6 Permission is hereby granted, free of charge, to any person obtaining a … … 30 30 31 31 (history 32 (version "1.36" "Should compile now on Windows with mingw") 32 33 (version "1.35" "Fixed bug in " (tt "z3:encode-buffer") " [reported by Mario Domenech Goulart]") 33 34 (version "1.34" "Added whole-buffer encoding/decoding") -
z3/z3.setup
r4138 r4232 1 2 1 (compile z3.scm -O2 -d1 -s 3 2 -emit-exports "z3.exports" … … 8 7 '("z3.so" "z3.html") 9 8 '((exports "z3.exports") 10 (version 1.3 5)9 (version 1.36) 11 10 (documentation "z3.html"))) -
z3/z3flib.c
r1867 r4232 6 6 7 7 #include <errno.h> 8 #include <assert.h> 8 9 #include "z3lib.h" 9 10 #include "z3liblib.h" … … 366 367 } 367 368 return 0; 368 default: 369 return -EPERM; /* shutup compiler */ 369 default: assert(0); 370 370 } 371 371 } -
z3/z3lib.h
r137 r4232 25 25 #endif 26 26 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 27 35 enum z3errno { 28 36 z3err_none,
Note: See TracChangeset
for help on using the changeset viewer.