Changeset 228 in project


Ignore:
Timestamp:
02/11/06 16:01:04 (14 years ago)
Author:
felix winkelmann
Message:

z3 fix

Files:
21 added
13 edited

Legend:

Unmodified
Added
Removed
  • ajax/doc.scm

    r1 r228  
    3838      (version "1.1" "Bugfix in " (tt "remote-button") " by Daishi Kato; "
    3939               (tt "current-request") " and " (tt "current-urlencoded-arguments")
    40                " are no also available in callbacks")
     40               " are now also available in callbacks")
    4141      (version "1.0" "Initial release"))
    4242
  • http/http-utils.scm

    r222 r228  
    4242   http:make-request http:request? http:request-url http:request-protocol http:request-attributes http:request-body http:request-method
    4343   http:request-url-set! http:request-protocol-set! http:request-attributes-set! http:request-body-set! http:request-method-set!
    44    http:request-ip http:request-ip-set!) )
     44   http:request-ip http:request-ip-set! http:request-completion http:request-completion-set!) )
    4545
    4646(declare (uses srfi-1 srfi-13 srfi-18 regex))
     
    6969  url                                   ; string
    7070  protocol                              ; symbol
    71   body)                                 ; string | #f
     71  body                                  ; string | #f
     72  completion)                           ; procedure | #f
    7273
    7374(define http:make-request
     
    7576    (lambda (method url . more)
    7677      (let-optionals more ([attrs '()] [body '()] [protocol 'HTTP/1.0] [ip "<unknown>"])
    77         (make-http:request method attrs ip url protocol body) ) ) ) )
     78        (make-http:request method attrs ip url protocol body #f) ) ) ) )
    7879
    7980(define http:read-request-attributes
  • http/http.html

    r221 r228  
    2020URL-canonicalization fix by Peter Busser
    2121<li>1.37
    22 Some internal restructuring
     22Added hidden slot to request-structure
    2323<li>1.36
    2424Fixed bug in <code>http:write-error-response</code> [Thanks to Peter Bex]
  • jni/tests/hello.scm

    r211 r228  
    3636
    3737(define s (jni:string->jstring "Hello"))
    38 ;(setAppName org.eclipse.swt.widgets.Display s) ; doesn't seem to work...
     38(setAppName org.eclipse.swt.widgets.Display s) ; doesn't seem to work...
    3939(define disp (newDisplay))
    4040(define shell (newShell disp))
  • jni/tests/hello0.scm

    r81 r228  
    44(use srfi-18)
    55
    6 (apply jni:init "-Djava.class.path=swt.jar" "-Djava.library.path=." (command-line-arguments))
     6(apply jni:init "-Xss500000" "-Djava.class.path=swt.jar" "-Djava.library.path=." (command-line-arguments))
    77
    88(define-java-classes
  • sandbox/sandbox.html

    r149 r228  
    3939<h3>Version:</h3>
    4040<ul>
     41<li>1.4
     42Added proper setup script; uses trace-buffer and lambda-info
    4143<li>1.3
    4244Fixed problem with older chicken versions [Thanks to Alejandro Forero Cuervo]
     
    135137
    136138<dt class="function"><em>(environment)</em> default-safe-environment</dt><dd>
    137 <p>An evaluation environment containing basic R5RS environment without I/O procedures.</dd>
     139<p>An evaluation environment containing a basic R5RS environment without I/O procedures.</dd>
    138140
    139141<dt class="function"><em>(procedure)</em> (make-safe-environment #!key NAME PARENT MUTABLE EXTENDABLE)
  • sandbox/sandbox.meta

    r1 r228  
    11;;; sandbox.meta -*- Hen -*-
    2 ((file "sandbox.scm")
     2((egg "sandbox.egg")
     3 (files "sandbox.scm" "sandbox.setup" "sandbox.html")
    34 (category misc)
    45 (synopsis "A safe evaluation environment")
  • sandbox/sandbox.scm

    r149 r228  
    227227                x2) )
    228228          x2) ) )
     229
     230  (define (decorate p ll h)
     231    (##sys#eval-decorator p ll h #f) )
    229232
    230233  (define (compile x e h)
     
    326329                                        (cons vars e) ) ] )
    327330                            (case n
    328                               [(1) (let ([val (compile (cadar bindings) e #f)])
     331                              [(1) (let ([val (compile (cadar bindings) e (car vars))])
    329332                                     (lambda (v)
    330333                                       (##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
    331                               [(2) (let ([val1 (compile (cadar bindings) e #f)]
    332                                          [val2 (compile (cadadr bindings) e #f)] )
     334                              [(2) (let ([val1 (compile (cadar bindings) e (car vars))]
     335                                         [val2 (compile (cadadr bindings) e (cadr vars))] )
    333336                                     (lambda (v)
    334337                                       (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ]
    335                               [(3) (let* ([val1 (compile (cadar bindings) e #f)]
    336                                           [val2 (compile (cadadr bindings) e #f)]
     338                              [(3) (let* ([val1 (compile (cadar bindings) e (car vars))]
     339                                          [val2 (compile (cadadr bindings) e (cadr vars))]
    337340                                          [t (cddr bindings)]
    338                                           [val3 (compile (cadar t) e #f)] )
    339                                      (lambda (v)
    340                                        (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
    341                               [(4) (let* ([val1 (compile (cadar bindings) e #f)]
    342                                           [val2 (compile (cadadr bindings) e #f)]
    343                                           [t (cddr bindings)]
    344                                           [val3 (compile (cadar t) e #f)]
    345                                           [val4 (compile (cadadr t) e #f)] )
     341                                          [val3 (compile (cadar t) e (caddr vars))] )
    346342                                     (lambda (v)
    347343                                       (##core#app
    348344                                        body
    349                                         (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v) (##core#app val4 v)) v)) ) ) ]
     345                                        (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
     346                              [(4) (let* ([val1 (compile (cadar bindings) e (car vars))]
     347                                          [val2 (compile (cadadr bindings) e (cadr vars))]
     348                                          [t (cddr bindings)]
     349                                          [val3 (compile (cadar t) e (caddr vars))]
     350                                          [val4 (compile (cadadr t) e (cadddr vars))] )
     351                                     (lambda (v)
     352                                       (##core#app
     353                                        body
     354                                        (cons (vector (##core#app val1 v)
     355                                                      (##core#app val2 v)
     356                                                      (##core#app val3 v)
     357                                                      (##core#app val4 v))
     358                                              v)) ) ) ]
    350359                              [else
    351                                (let ([vals (map (lambda (x) (compile (cadr x) e #f)) bindings)])
     360                               (let ([vals (map (lambda (x) (compile (cadr x) e (car x))) bindings)])
    352361                                 (lambda (v)
    353362                                   (let ([v2 (make-vector n)])
     
    357366                                       (vector-set! v2 i (##core#app (car vlist) v)) )
    358367                                     (##core#app body (cons v2 v)) ) ) ) ] ) ) ]
    359                          ;; (compile
    360                          ;; `((lambda ,(##sys#map (lambda (x) (car x)) bindings)
    361                          ;; ,@(##sys#slot (##sys#slot x 1) 1) )
    362                          ;; ,@(##sys#map (lambda (x) (cadr x)) bindings) )
    363                          ;; e #f) ) ]
    364368
    365369                         [(lambda)
    366370                          (##sys#check-syntax 'lambda x '(lambda lambda-list . #(_ 1)) #f)
    367                           (##sys#decompose-lambda-list
    368                            (cadr x)
    369                            (lambda (vars argc rest)
    370                              (let ([body (compile-expression
    371                                           (canonicalize-body (cddr x))
    372                                           (cons vars e) ) ] )
    373                                (case argc
    374                                  [(0) (if rest
    375                                           (lambda (v) (lambda r (##core#app body (cons (vector r) v))))
    376                                           (lambda (v) (lambda () (##core#app body (cons #f v))))) ]
    377                                  [(1) (if rest
    378                                           (lambda (v) (lambda (a1 . r) (##core#app body (cons (vector a1 r) v))))
    379                                           (lambda (v) (lambda (a1) (##core#app body (cons (vector a1) v))))) ]
    380                                  [(2) (if rest
    381                                           (lambda (v) (lambda (a1 a2 . r) (##core#app body (cons (vector a1 a2 r) v))))
    382                                           (lambda (v) (lambda (a1 a2) (##core#app body (cons (vector a1 a2) v))))) ]
    383                                  [(3) (if rest
    384                                           (lambda (v) (lambda (a1 a2 a3 . r) (##core#app body (cons (vector a1 a2 a3 r) v))))
    385                                           (lambda (v) (lambda (a1 a2 a3) (##core#app body (cons (vector a1 a2 a3) v))))) ]
    386                                  [(4) (if rest
    387                                           (lambda (v)
    388                                             (lambda (a1 a2 a3 a4 . r) (##core#app body (cons (vector a1 a2 a3 a4 r) v))) )
    389                                           (lambda (v)
    390                                             (lambda (a1 a2 a3 a4) (##core#app body (cons (vector a1 a2 a3 a4) v))))) ]
    391                                  [else (if rest
    392                                            (lambda (v)
    393                                              (lambda as
    394                                                (##core#app body (cons (apply vector (fudge-argument-list argc as)) v)) ) )
    395                                            (lambda (v)
    396                                              (lambda as
    397                                                (let ([len (length as)])
    398                                                  (if (not (= len argc))
    399                                                      (s-error #f "bad argument count" argc len)
    400                                                      (##core#app body (cons (apply vector as) v))) ) ) ) ) ] ) ) ) ) ]
     371                          (let* ((llist (cadr x))
     372                                 (body (cddr x))
     373                                 (info (cons (or h '?) llist)) )
     374                            (##sys#decompose-lambda-list
     375                             llist
     376                             (lambda (vars argc rest)
     377                               (let ([body (compile-expression
     378                                            (canonicalize-body body)
     379                                            (cons vars e) ) ] )
     380                                 (case argc
     381                                   [(0) (if rest
     382                                            (lambda (v)
     383                                              (decorate
     384                                               (lambda r (##core#app body (cons (vector r) v)))
     385                                               info h) )
     386                                            (lambda (v)
     387                                              (decorate
     388                                               (lambda () (##core#app body (cons #f v)))
     389                                               info h) ) ) ]
     390                                   [(1) (if rest
     391                                            (lambda (v)
     392                                              (decorate
     393                                               (lambda (a1 . r) (##core#app body (cons (vector a1 r) v)))
     394                                               info h) )
     395                                            (lambda (v)
     396                                              (decorate
     397                                               (lambda (a1) (##core#app body (cons (vector a1) v)))
     398                                               info h) ) ) ]
     399                                   [(2) (if rest
     400                                            (lambda (v)
     401                                              (decorate
     402                                               (lambda (a1 a2 . r) (##core#app body (cons (vector a1 a2 r) v)))
     403                                               info h) )
     404                                            (lambda (v)
     405                                              (decorate
     406                                               (lambda (a1 a2) (##core#app body (cons (vector a1 a2) v)))
     407                                               info h) ) ) ]
     408                                   [(3) (if rest
     409                                            (lambda (v)
     410                                              (decorate
     411                                               (lambda (a1 a2 a3 . r) (##core#app body (cons (vector a1 a2 a3 r) v)))
     412                                               info h) )
     413                                            (lambda (v)
     414                                              (decorate
     415                                               (lambda (a1 a2 a3) (##core#app body (cons (vector a1 a2 a3) v)))
     416                                               info h) ) ) ]
     417                                   [(4) (if rest
     418                                            (lambda (v)
     419                                              (decorate
     420                                               (lambda (a1 a2 a3 a4 . r) (##core#app body (cons (vector a1 a2 a3 a4 r) v)))
     421                                               info h) )
     422                                            (lambda (v)
     423                                              (decorate
     424                                               (lambda (a1 a2 a3 a4) (##core#app body (cons (vector a1 a2 a3 a4) v)))
     425                                               info h) ) ) ]
     426                                   [else (if rest
     427                                             (lambda (v)
     428                                               (decorate
     429                                                (lambda as
     430                                                  (##core#app body (cons (apply vector (fudge-argument-list argc as)) v)) )
     431                                                info h) )
     432                                             (lambda (v)
     433                                               (decorate
     434                                                (lambda as
     435                                                  (let ([len (length as)])
     436                                                    (if (not (= len argc))
     437                                                        (s-error #f "bad argument count" argc len)
     438                                                        (##core#app body (cons (apply vector as) v))) ) )
     439                                                info h) ) ) ] ) ) ) ) ) ]
    401440
    402441                         [(##core#undefined) (lambda _ (##core#undefined))]
     
    428467         (length lst) ) )
    429468
     469  (define (emit-trace-info info)
     470    (##core#inline "C_emit_trace_info" info #f ##sys#current-thread) )
     471
    430472  (define (compile-call x e)
    431473    (let* ([fn (compile (car x) e #f)]
    432474           [args (cdr x)]
    433            [argc (checked-length args)] )
     475           [argc (checked-length args)]
     476           [info x] )
    434477      (case argc
    435478        [(#f) (##sys#syntax-error-hook "syntax error - malformed expression" x)]
    436479        [(0) (lambda (v)
     480               (emit-trace-info info)
    437481               (check-point fuel/lambda)
    438482               ((##core#app fn v)) ) ]
    439483        [(1) (let ([a1 (compile (car args) e #f)])
    440484               (lambda (v)
     485                 (emit-trace-info info)
    441486                 (check-point fuel/lambda)
    442487                 ((##core#app fn v) (##core#app a1 v))) ) ]
     
    444489                    [a2 (compile (list-ref args 1) e #f)] )
    445490               (lambda (v)
     491                 (emit-trace-info info)
    446492                 (check-point fuel/lambda)
    447493                 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
     
    450496                    [a3 (compile (list-ref args 2) e #f)] )
    451497               (lambda (v)
     498                 (emit-trace-info info)
    452499                 (check-point fuel/lambda)
    453500                 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
     
    457504                    [a4 (compile (list-ref args 3) e #f)] )
    458505               (lambda (v)
     506                 (emit-trace-info info)
    459507                 (check-point fuel/lambda)
    460508                 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
    461509        [else (let ([as (map (lambda (a) (compile a e #f)) args)])
    462510                (lambda (v)
     511                  (emit-trace-info info)
    463512                  (check-point fuel/lambda)
    464513                  (apply (##core#app fn v) (map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
  • spiffy/spiffy-base.scm

    r188 r228  
    5959
    6060(define spiffy-version 1)
    61 (define spiffy-release 52)
     61(define spiffy-release 53)
    6262
    6363(define spiffy-tcp-port (make-parameter 8080))
     
    161161(define spiffy-deny-access (make-parameter (regexp "^\\.|/\\.|\\.sspx$")))
    162162(define spiffy-deny-paths (make-parameter '("\\~" "\\.\\.")))
    163 (define spiffy-index-pages (make-parameter '("index.html" "index.ssp" "index.sxml")))
     163(define spiffy-index-pages (make-parameter '("index.html" "index.ssp" "index.sxml" "index.ws")))
    164164
    165165(define spiffy-file-type-map
     
    458458  (handle-exceptions ex
    459459      (let ((code (cons 500 "Internal server error")))
    460         (build-error-message ex 500 "Internal server error")
    461         (current-response-code code))
     460        (current-response-code code)
     461        (build-error-message ex 500 "Internal server error"))
    462462    (eval `(begin ,@(read-file file))) ) )
    463463
  • spiffy/spiffy.html

    r188 r228  
    4848<h3>Version:</h3>
    4949<ul>
     50<li>1.53
     51Supports default "ws" page and small bugfix [Thanks to Mario Domenech Goulart]
    5052<li>1.52
    5153Add virtual hosting support [by Peter Bex]</li>
     
    204206<tr><td>spiffy-vhost-map<td>alist of string<->string pairs<td>Maps hosts to basepaths of virtual servers<td><code>#f</code>
    205207<tr><td>spiffy-index-pages<td>list of strings<td>list of filenames that should be tried in case a request references a directory
    206   <td><code>'("index.html" "index.ssp")</code>
     208  <td><code>'("index.html" "index.ssp" "index.sxml" "index.ws")</code>
    207209<tr><td>spiffy-program-pattern<td>regular expression<td>pattern that must match path of source files to execute<td><code>#f</code>
    208210<i>(disabled)</i>
  • z3/doc.scm

    r216 r228  
    3030
    3131     (history
     32      (version "1.31" "Fixed bug in " (tt "z3:encode"))
    3233      (version "0.9" "Initial release") )
    3334
  • z3/test.scm

    r214 r228  
    3737
    3838 (test-define "prepare decompression" z (z3:decode-init))
    39  (test-define "decomp. destination" dest (open-output-string))
     39 (test-eval "decomp. destination" (set! dest (open-output-string)))
    4040 (test-eval "decompressing..." (let loop ((c compressed))
    4141                                 (let ((t (z3:decode z r c)))
  • z3/z3.scm

    r214 r228  
    149149  (let ((cbuf (z3:handle-decoded handle)))
    150150    (let-values (((r taken given) (z3d_encode (z3:handle-buffer handle) data datasize cbuf (string-length cbuf))))
    151       (cond (r (when (fx> given 0)
    152                  (receiver (substring cbuf 0 given)) )
    153                taken)
    154             (else #f) ) ) ) )
     151      (when (fx> given 0)
     152        (receiver (substring cbuf 0 given)) )
     153      (and r taken) ) ) )
    155154
    156155(define strerror (foreign-lambda c-string "strerror" int))
Note: See TracChangeset for help on using the changeset viewer.