#cs(module sedna-low mzscheme
(require "myenv.ss")
(require "srfi-12.ss")
(cond-expand
(plt
(define (sedna:open-tcp-connection host port-number)
(let-values*
(((input-port output-port)
(tcp-connect host port-number)))
(cons input-port output-port)))
(define sedna:flush-output-port flush-output)
(define (sedna:close-tcp-connection port)
(or(and(output-port? port)(close-output-port port))(close-input-port port)))
(define sedna:port-position file-position))
(chicken
(define (sedna:open-tcp-connection host port-number)
(let-values*
(((input-port output-port)
(tcp-connect host port-number)))
(cons input-port output-port)))
(define sedna:flush-output-port flush-output)
(define sedna:close-tcp-connection close-output-port)
(define (sedna:port-position input-port)
(receive (row col) (port-position input-port)
(+ (* 80 row) col))))
(gambit
(define (sedna:open-tcp-connection host port-number)
(let ((p (open-tcp-client
(list server-address: host
port-number: port-number))))
(cons p p)))
(define sedna:flush-output-port force-output)
(define sedna:close-tcp-connection close-port)
(define (sedna:port-position input-port)
(+ (* 80 (input-port-line input-port))
(input-port-column input-port)))
)
(else
#f)
)
(cond-expand
(chicken
(define (sedna:list-head lst k)
(if (or (null? lst) (zero? k))
'()
(cons (car lst) (sedna:list-head (cdr lst) (- k 1)))))
(define (sedna:apply-string-append str-lst)
(cond
((null? str-lst) "")
((null? (cdr str-lst)) (car str-lst))
(else (let ((middle (inexact->exact (round (/ (length str-lst) 2)))))
(string-append
(sedna:apply-string-append (sedna:list-head str-lst middle))
(sedna:apply-string-append (list-tail str-lst middle)))))))
)
(else
(define (sedna:apply-string-append str-lst)
(apply string-append str-lst))
))
(cond-expand
(plt
(define (sedna:make-pipe)
(call-with-values make-pipe cons))
(define sedna:close-output-pipe close-output-port)
)
(chicken
(define (sedna:make-pipe)
(call-with-values create-pipe cons))
(define sedna:close-output-pipe close-output-port)
)
(else
(define (sedna:make-pipe)
(cons #f #f))
(define (sedna:close-output-pipe port) #f)
))
(define (sedna:raise-exn . msg)
(exc:signal
(make-property-condition 'exn
'message (sedna:apply-string-append msg))))
(define (sedna:first-n n lst)
(cond
((= n 0) '())
((null? lst)
(sedna:raise-exn "sedna:first-n: Unexpected end of the list")
#f)
(else
(cons (car lst)
(sedna:first-n (- n 1) (cdr lst))))))
(cond-expand
((and plt plt-bytes)
(define sedna:char000 0)
(define sedna:char001 1)
(define sedna:read-byte read-byte)
(define sedna:peek-byte peek-byte)
(define (sedna:integer->chars num)
(let* ((frst (quotient num 16777216))
(num (- num (* frst 16777216)))
(scnd (quotient num 65536))
(num (- num (* scnd 65536)))
(thrd (quotient num 256))
(frth (- num (* thrd 256))))
(list frst scnd thrd frth)))
(define (sedna:chars->integer byte-lst)
(+ (* (car byte-lst) 16777216)
(* (cadr byte-lst) 65536)
(* (caddr byte-lst) 256)
(cadddr byte-lst)))
(define (sedna:string->network str)
(let ((lst (bytes->list (string->bytes/utf-8 str))))
(cons
sedna:char000
(append
(sedna:integer->chars (length lst))
lst))))
(define (sedna:extract-string chars)
(if
(< (length chars) 5) (begin
(sedna:raise-exn "sedna:extract-string: No string found")
#f)
(let ((lng
(sedna:chars->integer
(sedna:first-n 4 (cdr chars))))
(rest (list-tail chars 5)))
(values (bytes->string/utf-8 (list->bytes (sedna:first-n lng rest)))
(list-tail rest lng)))))
(define (sedna:write-package-as-bytes header-code body output-port)
(display
(list->bytes (sedna:integer->chars header-code))
output-port)
(display
(list->bytes (sedna:integer->chars (length body)))
output-port)
(display (list->bytes body) output-port)
(sedna:flush-output-port output-port))
)
(else
(define sedna:char000 (integer->char 0))
(define sedna:char001 (integer->char 1))
(define sedna:read-byte read-char)
(define sedna:peek-byte peek-char)
(define (sedna:integer->chars num)
(let* ((frst (quotient num 16777216))
(num (- num (* frst 16777216)))
(scnd (quotient num 65536))
(num (- num (* scnd 65536)))
(thrd (quotient num 256))
(frth (- num (* thrd 256))))
(list (integer->char frst)
(integer->char scnd)
(integer->char thrd)
(integer->char frth))))
(define (sedna:chars->integer char-lst)
(+ (* (char->integer (car char-lst)) 16777216)
(* (char->integer (cadr char-lst)) 65536)
(* (char->integer (caddr char-lst)) 256)
(char->integer (cadddr char-lst))))
(define (sedna:string->network str)
(cons
sedna:char000
(append
(sedna:integer->chars (string-length str))
(string->list str))))
(define (sedna:extract-string chars)
(if
(< (length chars) 5) (begin
(sedna:raise-exn "sedna:extract-string: No string found")
#f)
(let ((lng
(sedna:chars->integer
(sedna:first-n 4 (cdr chars))))
(rest (list-tail chars 5)))
(values (list->string (sedna:first-n lng rest))
(list-tail rest lng)))))
(define (sedna:write-package-as-bytes header-code body output-port)
(display
(list->string (sedna:integer->chars header-code))
output-port)
(display
(list->string (sedna:integer->chars (length body)))
output-port)
(display
(list->string body)
output-port)
(sedna:flush-output-port output-port))
))
(provide (all-defined)))