~amirouche/chez-scheme-thunderchez

9d6344a868b002e20a6d2d205710a3cd2030b398 — Aldo Nicolas Bruno 3 years ago 27d3a94
synced with fossil
M README.md => README.md +1 -8
@@ 33,14 33,7 @@ Based on [surfage](https://github.com/dharmatech/surfage/) with minor changes
Based on [matchable egg](http://wiki.call-cc.org/eggref/4/matchable)

	(import (matchable))


## irregex
Based on [ashinn irregex](http://synthcode.com/scheme/irregex)

    (import (irregex))


  
## Sqlite3
Based partially on chicken [sqlite3 egg](http://wiki.call-cc.org/eggref/4/sqlite3) but slightly different. Needs some testing.


M cairo/cairo-pdf-functions.ss => cairo/cairo-pdf-functions.ss +1 -1
@@ 1,5 1,5 @@
(define-cairo-func (* cairo-surface-t) cairo-pdf-surface-create ((filename string) (width_in_points double) (height_in_points double)) "cairo_pdf_surface_create")
(define-cairo-func (* cairo-surface-t) cairo-pdf-surface-create-for-stream ((write_func (* cairo-write-func-t)) (closure void*) (width_in_points double) (height_in_points double)) "cairo_pdf_surface_create_for_stream")
(define-cairo-func (* cairo-surface-t) cairo-pdf-surface-create-for-stream ((write_func (* cairo-write-func-t)) (closure ptr) (width_in_points double) (height_in_points double)) "cairo_pdf_surface_create_for_stream")
(define-cairo-func void cairo-pdf-surface-restrict-to-version ((surface (* cairo-surface-t)) (version cairo-pdf-version-t)) "cairo_pdf_surface_restrict_to_version")
(define-cairo-func void cairo-pdf-get-versions ((versions (* cairo-pdf-version-t*)) (num_versions (* int))) "cairo_pdf_get_versions")
(define-cairo-func string cairo-pdf-version-to-string ((version cairo-pdf-version-t)) "cairo_pdf_version_to_string")

M cairo/types.ss => cairo/types.ss +2 -2
@@ 67,10 67,10 @@
 (define cairo-format-invalid -1)

 (define-ftype cairo-write-func-t
   (function (void* void* unsigned-int) cairo-status-t))
   (function (ptr (* unsigned-8) unsigned-int) cairo-status-t))

 (define-ftype cairo-read-func-t
   (function (void* void* unsigned-int) cairo-status-t))
   (function (ptr (* unsigned-8) unsigned-int) cairo-status-t))

 (define-ftype cairo-rectangle-int-t
   (struct [x int] [y int] [width int] [height int]))

M ffi-utils.sls => ffi-utils.sls +1 -1
@@ 127,7 127,7 @@
; you can use also (flags-alist <flags-name>-flags) to get the alist of flags
; and (flags-name <flags-name>-flags) to get the name

;EXAMPLE: (define-flag colors (red 1) (blue 2) (green 4))
;EXAMPLE: (define-flags colors (red 1) (blue 2) (green 4))
;> color-flags -> #[#{flags ew79exa0q5qi23j9k1faa8-51} color ((red . 1) (blue . 2) (green . 4))]
;> (color 'blue) -> 2
;> (color 'red 'blue) -> 3

M json.sls => json.sls +3 -1
@@ 196,7 196,7 @@
 (define (json->string json)
   (define special '((#\backspace . #\b) (#\newline . #\n) (#\alarm . #\a) 
		     (#\return . #\r) (#\tab #\t) (#\\ . #\\) (#\" . #\")))
   (cond [(and (pair? json) (eq? (car json) 'dict))
   (cond [(and (pair? json)  (eq? (car json) '@))
	  (string-append 
	   "{\n"
	   (string-intersperse


@@ 224,6 224,8 @@
					'()
					(string->list json)))
			 "\"" )]
	 [(bytevector? json)
	  (utf8->string json)]		
   
	 [(symbol? json)
	  (json->string (symbol->string json))]

M nanomsg.sls => nanomsg.sls +34 -17
@@ 347,23 347,40 @@
 ;; 	     (string-set! str i c)
 ;; 	     str)))))

 (define (nn-recv s buf len flags)
   (define b #f)
   (define r #f)
   (dynamic-wind 
       (lambda ()
	 (set! b (make-ftype-pointer void* (foreign-alloc (ftype-sizeof void*))))
	 (set! r (nn-recv% s (ftype-pointer-address b) len flags)))
       (lambda ()
	 (if (and r (> r 0))
	     (let ([c (make-ftype-pointer char (ftype-ref void* () b))])
	       (set-box! buf (char*->bytevector c r)))
	     (set-box! buf #f)))
       (lambda ()
	 (if (and r (> r 0))
	     (nn-freemsg (ftype-ref void* () b)))
	 (if b (foreign-free (ftype-pointer-address b)))))
   r)
 (define nn-recv
   (case-lambda
     [(s flags)
      (define b #f)
      (define r #f)
      (dynamic-wind 
	(lambda ()
	  (set! b (make-ftype-pointer void* (foreign-alloc (ftype-sizeof void*))))
	  (set! r (nn-recv% s (ftype-pointer-address b) NN_MSG flags)))
	(lambda ()
	  (if (and r (> r 0))
	      (let ([c (make-ftype-pointer char (ftype-ref void* () b))])
		(char*->bytevector c r))))
	(lambda ()
	  (if (and r (> r 0))
	      (nn-freemsg (ftype-ref void* () b)))
	  (if b (foreign-free (ftype-pointer-address b)))))]
     [(s buf len flags)
      (define b #f)
      (define r #f)
      (dynamic-wind 
	(lambda ()
	  (set! b (make-ftype-pointer void* (foreign-alloc (ftype-sizeof void*))))
	  (set! r (nn-recv% s (ftype-pointer-address b) len flags)))
	(lambda ()
	  (if (and r (> r 0))
	      (let ([c (make-ftype-pointer char (ftype-ref void* () b))])
		(set-box! buf (char*->bytevector c r)))
	      (set-box! buf #f)))
	(lambda ()
	  (if (and r (> r 0))
	      (nn-freemsg (ftype-ref void* () b)))
	  (if b (foreign-free (ftype-pointer-address b)))))
      r]))

 (define-nn-func int nn-sendmsg ((s int) (msghdr (* nn-msghdr)) (flags int))
   "nn_sendmsg")

M scgi.sls => scgi.sls +10 -3
@@ 15,7 15,8 @@

(library (scgi)
  (export scgi-request-handler handle-scgi-connection run-scgi
	  scgi-headers->bytevector)
	  scgi-headers->bytevector
	  scgi-before-fork-hook)
  (import (chezscheme)
	  (socket)
	  (netstring)


@@ 47,6 48,8 @@
			(bytevector->u8-list (string->utf8 value)) '(0)
			acc)))
	    '() l )))
  
  (define scgi-before-fork-hook (make-parameter values))

  (define scgi-request-handler
    (make-parameter


@@ 62,9 65,11 @@
    (let* ([len (string->number (cdr (assq 'CONTENT_LENGTH h)))]
	   [content (get-bytevector-n sock len)])
      (assert (= (bytevector-length content) len))
      (let ([port (transcoded-port sock (make-transcoder (utf-8-codec) 'none))])
      ;;(let ([port (transcoded-port sock (make-transcoder (utf-8-codec) 'none))])
      (let ([port sock])
	((scgi-request-handler) port h content)
	(flush-output-port port))))
	#;(flush-output-port port)
	#;(close-port port))))

  (define (run-scgi addr port)
    (define nchildren 0)


@@ 77,6 82,7 @@
       (listen sock 1000)
       (do ()
	   (#f)
	 (printf "scgi: active children: ~d~n" nchildren)
	 (printf "scgi: waiting for connection...~n")
	 (call-with-port
	  (accept sock)


@@ 84,6 90,7 @@
	    (printf "scgi: accepted connection~n")
	    (if (> nchildren max-children)
		(sleep (make-time 'time-duration 0 1)))
	    ((scgi-before-fork-hook))
	    (printf "scgi: forking..~n")
	    (let ([pid (fork)])
	      (cond

M sqlite3.sls => sqlite3.sls +28 -16
@@ 12,6 12,7 @@
                                        ;define-function
  set-busy-handler!
                                        ;make-busy-timeout
  sqlite3-busy-timeout
  interrupt!
  auto-committing?
  change-count


@@ 47,7 48,8 @@
  enable-shared-cache!
  enable-load-extension!

  sqlite3-trace)
  sqlite3-trace
  sqlite3-config-log)

 (import
  (chezscheme)


@@ 126,6 128,8 @@
 (define (sqlite3:type-ref index)
   (list-ref (enum-set->list sqlite3:type-enum) index))

 

 ;; Auxiliary types

 (define-ftype sqlite3:context void*)


@@ 153,16 157,8 @@
 (define-record-type statement
   (fields
    (mutable ptr)
    (mutable database)))

                                        ;(record-writer
                                        ; (type-descriptor statement)
                                        ; (lambda (r p wr)
                                        ;   (wr
                                        ;    (if (statement-ptr r)
                                        ;        (format "#<sqlite3:statement sql=~s>" (source-sql r))
                                        ;        "#<sqlite3:statement zombie>")
                                        ;    p)))
    (mutable database)
    (mutable sql)))

                                        ;(define-check+error-type statement)



@@ 237,6 233,10 @@
   (check-database 'set-busy-handler! db)
   (database-busy-handler-set! db handler))

 (define (sqlite3-busy-timeout db ms)
   (let ([f (foreign-procedure "sqlite3_busy_timeout" (sqlite3:database* int) int)])
     (f (database-addr db) ms)))
 
 (define (database-addr db)
   (ftype-pointer-address (database-ptr db)))



@@ 286,7 286,7 @@
   (let* ([f (foreign-procedure "sqlite3_next_stmt" (sqlite3:database*) sqlite3:statement*)]
          [stmt* (f (database-addr db))])
     (make-statement (make-ftype-pointer sqlite3:statement* stmt*)
                     db)))
                     db "")))

 (define finalize!
   (case-lambda


@@ 370,10 370,10 @@
            [nByte (bytevector-length zSql)]
            [e (sqlite3_prepare_v2 (database-addr db) zSql nByte (ftype-pointer-address ptr) #f)])
       (cond [(equal? e 0)
              (make-statement (ftype-&ref sqlite3:statement** (*) ptr) db)]
              (make-statement (ftype-&ref sqlite3:statement** (*) ptr) db sql)]
             [else
              (case (number->sqlite3:status e)
                [(busy)
                #;[(busy)
                 (let ([h (database-busy-handler db)])
                   (cond
                    [(and h (h db retries))


@@ 810,8 810,11 @@
   (check-database 'sqlite3-trace db)
   (let ([f (foreign-procedure "sqlite3_trace" (sqlite3:database* void* void*) void)])
     (f (database-addr db) func data)))
 
 (foreign-procedure "sqlite3_trace" ( void* void*) void)

 (define (sqlite3-config-log func data)
   ;(check-database 'sqlite3-config-log db)
   (let ([f (foreign-procedure "sqlite3_config" (int void* void*) void)])
     (f 16 func data)))

 (record-writer
  (type-descriptor database)


@@ 821,6 824,15 @@
         "#<sqlite3:database>"
         "#<sqlite3:database zombie>")
     p)))
 (record-writer
  (type-descriptor statement)
  (lambda (r p wr)
    (wr
     (if (statement-ptr r)
         (format "#<sqlite3:statement sql=~s>" (statement-sql r))
         "#<sqlite3:statement zombie>")
     p)))


 ) ; library sqlite3


M srfi/s37/args-fold.sls => srfi/s37/args-fold.sls +1 -1
@@ 41,6 41,6 @@

  (define args-fold
    (let ([option make-option])
      (include/resolve ("srfi" "%3a37") "srfi-37-reference.scm")
      (include/resolve ("srfi" "s37") "srfi-37-reference.scm")
      args-fold))
)

M srfi/tests/multi-dimensional-arrays--arlib.sps => srfi/tests/multi-dimensional-arrays--arlib.sps +1 -1
@@ 18,6 18,6 @@
                ((_ expr (error msg))
                 (check expr => #T))
                ((_ . r) (or . r)))))
  (include/resolve ("srfi" "%3a25") "list.scm"))
  (include/resolve ("srfi" "s25") "list.scm"))

(check-report)

M sxml/SXML-to-HTML-ext.scm => sxml/SXML-to-HTML-ext.scm +3 -1
@@ 164,7 164,9 @@
      . ,(lambda (trigger . value) (cons '@ value)))
    (*default* . ,(lambda (tag . elems) (entag* tag elems)))
    (*text* . ,(lambda (trigger str) 
		 (if (string? str) (string->goodHTML str) str)))
		 (cond [(string? str) (string->goodHTML str)]
			[(bytevector? str) (utf8->string str)]
			[else str])))
    (n_		; a non-breaking space
     . ,(lambda (tag . elems)
	  (cons "&nbsp;" elems)))))

M sxml/SXML-to-HTML.scm => sxml/SXML-to-HTML.scm +4 -2
@@ 65,8 65,10 @@
        . ,(lambda (attr-key . value) (enattr attr-key value))))
      . ,(lambda (trigger . value) (cons '@ value)))
     (*default* . ,(lambda (tag . elems) (entag tag elems)))
     (*text* . ,(lambda (trigger str) 
		  (if (string? str) (string->goodHTML str) str)))
     (*text* . ,(lambda (trigger str)
		  (cond [(string? str) (string->goodHTML str)]
			[(bytevector? str) (utf8->string str)]
			[else str])))
 
                ; Handle a nontraditional but convenient top-level element:
                ; (html:begin title <html-body>) element

M thunder-utils.sls => thunder-utils.sls +113 -3
@@ 17,9 17,13 @@
  (export string-split string-replace bytevector-copy* read-string
	  print-stack-trace
	  sub-bytevector  sub-bytevector=?
	  load-bytevector save-bytevector)
	  load-bytevector save-bytevector
	  define/optional lambda/optional /optional
	  define/keys lambda/keys /keys decode-keys)
  
  (import (scheme) (srfi s14 char-sets))
  (import (scheme) (srfi s14 char-sets)
	  (only (srfi s1 lists) take drop)
	  (srfi private auxiliary-keyword))

  ;; s is a string , c is a character-set or a list of chars
  ;; null strings are discarded from result by default unless #f is specified as third argument


@@ 120,7 124,7 @@
    (call-with-port (open-file-output-port path)
		    (lambda (p) (put-bytevector p data))))

  
  ;; from https://fare.livejournal.com/189741.html
  (define-syntax (nest stx)
    (syntax-case stx ()
      ((nest outer ... inner)


@@ 130,6 134,112 @@
		       #'(outer ... inner)))
		   #'inner (syntax->list #'(outer ...))))))

  (define-auxiliary-keywords /optional /keys)

  (define-syntax define/optional
    (lambda (stx)
      (syntax-case stx (/optional)
	[(_ (name params ... (/optional opts ...)) body ...)
	 (let ([opts-list
		(map (lambda (opt)
		       (let ([x (syntax->datum opt)])
			 (if (list? x)
			     (list (datum->syntax (car (syntax->list opt)) (car x))
				   (datum->syntax (car (syntax->list opt)) (cadr x) ))
			     (list opt #f))))
		     (syntax->list #'(opts ...)))])
	   #`(define name
	       (case-lambda
		 #,@(map (lambda (i)
			   #`[(params ... #,@(take (map car opts-list) i))
			      (name params ...
				    #,@(take (map car opts-list) i)
				    #,@(drop (map cadr opts-list) i))])
			 (iota  (length opts-list)))
		 [(params ... #,@(map car opts-list))
		  body ...])))])))

  
  (define-syntax lambda/optional
    (lambda (stx)
      (syntax-case stx (/optional)
	[(_ (params ... (/optional opts ...)) body ...)
	 (let ([opts-list
		(map (lambda (opt)
		       (let ([x (syntax->datum opt)])
			 (if (list? x)
			     (list (datum->syntax (car (syntax->list opt)) (car x))
				   (datum->syntax (car (syntax->list opt)) (cadr x) ))
			     (list opt #f))))
		     (syntax->list #'(opts ...)))])
	   #`(letrec ([func 
		       (case-lambda
			 #,@(map (lambda (i)
				   #`[(params ... #,@(take (map car opts-list) i))
				      (func params ...
					    #,@(take (map car opts-list) i)
					    #,@(drop (map cadr opts-list) i))])
				 (iota  (length opts-list)))
			 [(params ... #,@(map car opts-list))
			  body ...])])
	       func))])))

  (define (decode-keys func-name names keys)
    (for-each (lambda (k)
		(unless (assq (car k) names)
		  (errorf func-name "unknown keyword argument ~d" k)))
	      keys)
    (apply values (map (lambda (name)
			 (let ([p (assq (if (pair? name) (car name) name) keys)])
			   (if p
			       (if (pair? (cdr p))
				   (cadr p)
				   (cdr p))
			       (if (pair? name)
				   (if (pair? (cdr name))
				       (cadr name)
				       (cdr name))
				   #f))))
		       names)))
  
  (define-syntax define/keys 
    (lambda (stx)
      (syntax-case stx (/keys)
	[(_ (name params ... (/keys keys ...)) body ...)
	 (let ([keys-list
		(map (lambda (key)
		       (let ([x (syntax->datum key)])
			 (if (list? x)
			     (list (datum->syntax (car (syntax->list key)) (car x))
				   (datum->syntax (car (syntax->list key)) (cadr x) ))
			     (list key #f))))
		     (syntax->list #'(keys ...)))])
 	   #`(define name
	       (lambda (params ... . keys*)
		 (import (only (data-structures) chop))
		 (import (only (thunder-utils) decode-keys))
		 (let-values ([(#,@(map car keys-list))
			       (decode-keys 'name '#,keys-list (chop keys* 2))])
		   body ...))))])))

  
  (define-syntax lambda/keys 
    (lambda (stx)
      (syntax-case stx (/keys)
	[(_ (params ... (/keys keys ...)) body ...)
	 (let ([keys-list
		(map (lambda (key)
		       (let ([x (syntax->datum key)])
			 (if (list? x)
			     (list (datum->syntax (car (syntax->list key)) (car x))
				   (datum->syntax (car (syntax->list key)) (cadr x) ))
			     (list key #f))))
		     (syntax->list #'(keys ...)))])
 	   #`(lambda (params ... . keys*)
	       (import (only (data-structures) chop))
	       (import (only (thunder-utils) decode-keys))
	       (let-values ([(#,@(map car keys-list))
			     (decode-keys 'func '#,keys-list (chop keys* 2))])
		 body ...)))])))
  );library