Changeset 12227 in project

Timestamp:

10/21/08 20:42:22 (12 years ago)

Author:

felix winkelmann

Message:

• added helpful script for testing in build dir
• chicken-install checks for TCP timeouts and handles multiple default sources to download from
• alias-global-hook is saved and restored when loading compiler extensions
• making bootstrap automaticaly makes confclean

Location:

chicken/trunk

Files:

• TODO (modified) (2 diffs)
• batch-driver.scm (modified) (1 diff)
• chicken-install.scm (modified) (6 diffs)
• compiler.scm (modified) (2 diffs)
• manual/Unit tcp (modified) (2 diffs)
• rules.make (modified) (2 diffs)
• scripts/xhere (added)
• setup-download.scm (modified) (2 diffs)

chicken/trunk/TODO

@@ -44 +44 @@
 
 * optimizations
+** allocation-estimation in conditionals should take max of both branches, not sum
 ** self-recursion optimization
    what MacScheme called "benchmark-mode" (assume self-calls are recursion)
@@ -49 +50 @@
 ** when inlining, consing arg-list with "list" may make get-keyword possible foldable
 ** local flow analysis
-** lambda-fusion
+** lambda-fusion / "fuse-and-dispatch" (suggested by Alex)
+   convert groups of local lambdas referenced to only in operator-position into
+   looping lambda + dispatch (static variable can be used), otherwise similar to
+   a conditional
+*** new forms (after optimization, prepared language)
+    [##core#dispatch LAMBDABODY1 ... BODY]
+    [##core#call/dispatch {INDEX} ARGUMENT1 ...}
 ** handle optional ags primitively 
    for example, set to distinguished val (checking argc) on C level, core

chicken/trunk/batch-driver.scm

@@ -299 +299 @@
         (printf "Loading compiler extensions...~%~!")
         (load-verbose #t) )
-      (for-each (lambda (f) (load (##sys#resolve-include-filename f #f #t))) extends) )
+      ;; rebind a-g-h to allow extensions in source files to use private-namespace.scm
+      (fluid-let ((##sys#alias-global-hook ##sys#alias-global-hook))
+        (for-each
+         (lambda (f) (load (##sys#resolve-include-filename f #f #t))) 
+         extends) ) )
     (set! ##sys#features (delete #:compiler-extension ##sys#features eq?))
 

chicken/trunk/chicken-install.scm

@@ -54 +54 @@
          (else (foreign-value "C_INSTALL_BIN_HOME" c-string) ) )) )
 
-  (define *default-transport* #f)
-  (define *default-location* #f)
   (define *keep* #f)
   (define *force* #f)
@@ -66 +64 @@
   (define *username* #f)
   (define *password* #f)
+  (define *default-sources* '())
+  (define *default-location* #f)
+  (define *default-transport* 'http)
 
   (define (load-defaults)
-    (let* ((deff (make-pathname (repository-path) "setup.defaults"))
-           (def (cond ((file-exists? deff)
-                       (with-input-from-file deff read))
-                      (else '())))
-           (loc (assq 'location def))
-           (tr (assq 'transport def)))
-      (when loc (set! *default-location* (cadr loc)))
-      (when tr (set! *default-transport* (cadr tr)))
-      (pair? def)))
+    (let ((deff (make-pathname (repository-path) "setup.defaults")))
+      (cond ((not (file-exists? deff)) '())
+            (else
+             (set! *default-sources* (read-file deff))
+             (pair? *default-sources*)))))
 
   (define (deps key meta)
@@ -137 +134 @@
     (define *checked* '())
 
+    (define (try name version)
+      (let loop ((defs (if (and *default-location* *default-transport*)
+                           `(((location ,*default-location*)
+                              (transport ,*default-transport*)))
+                           *default-sources*)))
+        (and (pair? defs)
+             (let* ((def (car defs))
+                    (loc (cadr (or (assq 'location def)
+                                   (error "missing location entry" def))))
+                    (trans (cadr (or (assq 'transport def)
+                                     (error "missing transport entry" def)))))
+               (or (condition-case
+                       (retrieve-extension 
+                        name trans loc
+                        version: version
+                        destination: (and *retrieve-only* (current-directory))
+                        tests: *run-tests*
+                        username: *username* 
+                        password: *password*)
+                     ((exn net) 
+                      (print "TCP connect timeout")
+                      #f)
+                     (e () (abort e)))
+                   (loop (cdr defs)))))))
+
     (define (retrieve eggs)
       (print "retrieving ...")
@@ -148 +170 @@
                 (let* ((name (if (pair? egg) (car egg) egg))
                        (version (and (pair? egg) (cdr egg)))
-                       (dir (retrieve-extension 
-                             name *default-transport* *default-location*
-                             version: version
-                             destination: (and *retrieve-only* (current-directory))
-                             tests: *run-tests*
-                             username: *username* 
-                             password: *password*)))
+                       (dir (try name version)))
                   (unless dir
                     (error "extension or version not found"))
@@ -241 +257 @@
 
   (define (usage code)
-    (print #<#EOF
+    (print #<<EOF
 usage: chicken-install [OPTION | EXTENSION[:VERSION]] ...
 
@@ -248 +264 @@
        -force                   don't ask, install even if versions don't match
   -k   -keep                    keep temporary files
-  -l   -location LOCATION       install from given location instead of default (#{*default-location*})
-  -t   -transport TRANSPORT     use given transport instead of default (#{*default-transport*})
+  -l   -location LOCATION       install from given location instead of default
+  -t   -transport TRANSPORT     use given transport instead of default
   -s   -sudo                    use sudo(1) for installing or removing files
   -r   -retrieve                only retrieve egg into current directory, don't install

chicken/trunk/compiler.scm

@@ -177 +177 @@
 ; [##core#call {<safe-flag> [<debug-info> [<call-id> <customizable-flag>]]} <exp-f> <exp>...]
 ; [##core#callunit {<unitname>} <exp>...]
+; [##core#cond <exp> <exp> <exp>]
 ; [##core#local {<index>}]
 ; [##core#setlocal {<index>} <exp>]
@@ -2510 +2511 @@
                    (else (make-node '##core#literal (list (literal c)) '())) ) ) )
 
+          ;;*** conditionals (if + ##core#cond) are missing here: allocation
+          ;; calculation should use max of both branches, not sum.
+
           (else (make-node class params (mapwalk subs e here boxes)) ) ) ) )
     

chicken/trunk/manual/Unit tcp

@@ -52 +52 @@
 and {{tcp-write-timeout}}, respectively, to determine the maximal
 number of milliseconds to wait for input/output before a timeout
-error is signalled.
+error is signalled by raising an exception of the kinds {{(exn i/o net)}}.
 
 Note: this operation and any I/O on the ports returned will not block
@@ -94 +94 @@
 {{tcp-write-timeout}}, respectively, to determine the maximal number
 of milliseconds to wait for input/output before a timeout error is
-signalled.
+signalled by raising an exception of the kinds {{(exn i/o net)}}.
 
 If the {{TCPPORT}} is omitted, the port is parsed from the {{HOSTNAME}} string.  The format expected is {{HOSTNAME:PORT}}.  The {{PORT}} can either be a string representation of an integer or a service name which is translated to an integer using the POSIX function [[http://www.opengroup.org/onlinepubs/009695399/functions/getservbyname.html|{{getservbyname}}]].

chicken/trunk/rules.make

@@ -1324 +1324 @@
           $(MSVC_CHICKEN_EXPORT_FILES) chicken.info $(CLEAN_PCRE) $(CLEAN_MINGW_LIBS) \
           $(CLEAN_MANIFESTS)
+
 confclean:
         -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) chicken-config.h chicken-defaults.h buildsvnrevision
@@ -1381 +1382 @@
         cp chicken$(EXE) chicken-boot$(EXE)
         touch *.scm
+        $(MAKE) PLATFORM=$(PLATFORM) confclean
 
 $(SRCDIR)bootstrap.tar.gz: distfiles

chicken/trunk/setup-download.scm

@@ -38 +38 @@
   (import extras regex posix utils setup-utils srfi-1 data-structures tcp 
           srfi-13 files)
+
+  (tcp-connect-timeout 10000)           ; 10 seconds
+  (tcp-read-timeout 10000)
+  (tcp-write-timeout 10000)
 
   (define *quiet* #f)
@@ -133 +137 @@
                      "")))
            (eggdir (make-pathname tmpdir egg)))
-      (create-directory eggdir)
+      (unless (file-exists? eggdir)
+        (create-directory eggdir))
       (http-fetch host port loc eggdir)
       eggdir))