From 75f728f14161df80370a320594864457786bcecb Mon Sep 17 00:00:00 2001 From: Amirouche Date: Sat, 27 Nov 2021 09:34:19 +0100 Subject: [PATCH 01/27] Add LICENSE, and CONTRIBUTORS.md. --- CONTRIBUTORS.txt | 2 ++ LICENSE | 20 ++++++++++++++++++++ 2 files changed, 22 insertions(+) create mode 100644 CONTRIBUTORS.txt create mode 100644 LICENSE diff --git a/CONTRIBUTORS.txt b/CONTRIBUTORS.txt new file mode 100644 index 0000000..1144002 --- /dev/null +++ b/CONTRIBUTORS.txt @@ -0,0 +1,2 @@ +Amirouche Amazigh BOUBEKKI +Lassi Kortela diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..6aa1f8c --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (C) scheme-live contributors (2021). + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. From e9cba3eb541603074bfc4664ef1dcdcc2b723621 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 27 Nov 2021 17:44:06 +0200 Subject: [PATCH 02/27] Add (... unstable) version to a few library names Also update Chicken egg. --- live.egg | 46 ++++++++++++-- live/{bitwise.sld => bitwise/unstable.sld} | 2 +- live/{fixnum.sld => fixnum/unstable.sld} | 23 ++++--- live/list/unstable.sld | 12 +++- live/{number.sld => number/unstable.sld} | 2 +- live/{string.sld => string/unstable.sld} | 6 +- live/time/{iso.sld => iso/unstable.sld} | 13 ++-- scripts/generate-wrappers.scm | 72 +++++++++++++++++----- 8 files changed, 131 insertions(+), 45 deletions(-) rename live/{bitwise.sld => bitwise/unstable.sld} (90%) rename live/{fixnum.sld => fixnum/unstable.sld} (59%) rename live/{number.sld => number/unstable.sld} (79%) rename live/{string.sld => string/unstable.sld} (86%) rename live/time/{iso.sld => iso/unstable.sld} (89%) diff --git a/live.egg b/live.egg index 92b70bb..67788be 100644 --- a/live.egg +++ b/live.egg @@ -7,13 +7,51 @@ (category misc) (license "MIT") (author "Scheme Live Crew") - (dependencies srfi-151) + (dependencies srfi-143 srfi-151) (test-dependencies) - (distribution-files "live.egg" "live.release-info" "live/bitwise.sld") + (distribution-files + "live.egg" + "live.release-info" + "live/bitwise/unstable.sld" + "live/fixnum/unstable.sld" + "live/list/unstable.sld" + "live/number/unstable.sld" + "live/string/unstable.sld" + "live/time/iso/unstable.sld") (components (extension - live.bitwise - (source "live/bitwise.sld") + live.bitwise.unstable + (source "live/bitwise/unstable.sld") + (source-dependencies) + (component-dependencies) + (csc-options "-R" "r7rs" "-X" "r7rs")) + (extension + live.fixnum.unstable + (source "live/fixnum/unstable.sld") + (source-dependencies) + (component-dependencies) + (csc-options "-R" "r7rs" "-X" "r7rs")) + (extension + live.list.unstable + (source "live/list/unstable.sld") + (source-dependencies) + (component-dependencies) + (csc-options "-R" "r7rs" "-X" "r7rs")) + (extension + live.number.unstable + (source "live/number/unstable.sld") + (source-dependencies) + (component-dependencies) + (csc-options "-R" "r7rs" "-X" "r7rs")) + (extension + live.string.unstable + (source "live/string/unstable.sld") + (source-dependencies) + (component-dependencies) + (csc-options "-R" "r7rs" "-X" "r7rs")) + (extension + live.time.iso.unstable + (source "live/time/iso/unstable.sld") (source-dependencies) (component-dependencies) (csc-options "-R" "r7rs" "-X" "r7rs")))) diff --git a/live/bitwise.sld b/live/bitwise/unstable.sld similarity index 90% rename from live/bitwise.sld rename to live/bitwise/unstable.sld index 402435b..67f6ea1 100644 --- a/live/bitwise.sld +++ b/live/bitwise/unstable.sld @@ -1,4 +1,4 @@ -(define-library (live bitwise) +(define-library (live bitwise unstable) ;; Re-exported from SRFI 151: (export any-bit-set? diff --git a/live/fixnum.sld b/live/fixnum/unstable.sld similarity index 59% rename from live/fixnum.sld rename to live/fixnum/unstable.sld index c8511b1..b1b1eea 100644 --- a/live/fixnum.sld +++ b/live/fixnum/unstable.sld @@ -1,4 +1,4 @@ -(define-library (live fixnum) +(define-library (live fixnum unstable) ;; Re-exported from SRFI 143: (export fixnum? @@ -45,11 +45,16 @@ ;; Defined in this library: (export) (import (scheme base)) - (cond-expand (chicken - (import (rename (chicken fixnum) - (fx/ fxquotient) - ;; TODO: Is fxmod compatible with - ;; fxremainder for negative numbers? - (fxmod fxremainder)))) - ((library (srfi 143)) - (import (srfi 143))))) + (cond-expand + + #; + (chicken + (import (rename (chicken fixnum) + (fx/ fxquotient) + ;; TODO: Is fxmod compatible with + ;; fxremainder for negative numbers? + (fxmod fxremainder)))) + + ((or chicken + (library (srfi 143))) + (import (srfi 143))))) diff --git a/live/list/unstable.sld b/live/list/unstable.sld index 4b88572..04c78cf 100644 --- a/live/list/unstable.sld +++ b/live/list/unstable.sld @@ -17,5 +17,13 @@ length-tail map/odd proper-list?) - (import (scheme base) (srfi 1) (live fixnum)) - (include "list/live.scm")) + (import (scheme base) + + ;; TODO + (except (srfi 1) + circular-list? + dotted-list? + proper-list?) + + (live fixnum unstable)) + (include "live.scm")) diff --git a/live/number.sld b/live/number/unstable.sld similarity index 79% rename from live/number.sld rename to live/number/unstable.sld index b0f117a..5431797 100644 --- a/live/number.sld +++ b/live/number/unstable.sld @@ -1,4 +1,4 @@ -(define-library (live number) +(define-library (live number unstable) (export natural?) (import (scheme base)) (begin diff --git a/live/string.sld b/live/string/unstable.sld similarity index 86% rename from live/string.sld rename to live/string/unstable.sld index 632678f..edf1aef 100644 --- a/live/string.sld +++ b/live/string/unstable.sld @@ -1,4 +1,4 @@ -(define-library (live string) +(define-library (live string unstable) ;; Re-exported from SRFI 13: (export string-concatenate-reverse @@ -28,5 +28,5 @@ ((library (srfi 13)) (import (srfi 13))) (else - (include "string/srfi-13.scm"))) - (include "string/live.scm")) + (include "srfi-13.scm"))) + (include "live.scm")) diff --git a/live/time/iso.sld b/live/time/iso/unstable.sld similarity index 89% rename from live/time/iso.sld rename to live/time/iso/unstable.sld index 02e3b94..6299c53 100644 --- a/live/time/iso.sld +++ b/live/time/iso/unstable.sld @@ -3,11 +3,11 @@ ;; https://en.wikipedia.org/wiki/ISO_8601 -(define-library (live time iso) - (export parse-iso-time) +(define-library (live time iso unstable) + (export parse-iso-duration) (import (scheme base) (scheme write) - (live number)) + (live number unstable)) (begin (define null-list? null?) @@ -71,9 +71,4 @@ ((#\Y) (loop parts (acons 'year number result))) ((#\M) (loop parts (acons 'month number result))) ((#\D) (loop parts (acons 'day number result))) - (else (error "Unknown letter" letter)))))))) - - (define (parse-iso-time str) - (let ((parts (split-numbers-letters str))) - (and (equal? #\P (first parts)) - (parse-iso-duration (rest parts))))))) + (else (error "Unknown letter" letter)))))))))) diff --git a/scripts/generate-wrappers.scm b/scripts/generate-wrappers.scm index 9e52262..88f4583 100644 --- a/scripts/generate-wrappers.scm +++ b/scripts/generate-wrappers.scm @@ -16,14 +16,51 @@ (define tagline "fast-moving library collection with stable releases") (define spdx-license-expression "MIT") +;; TODO: These SRFI numbers should be found by groveling the imports +;; in the .sld files. (define srfis - '(151)) + '(143 + 151)) + +(define make-library cons) +(define library-name-parts car) +(define library-versions cdr) + +(define (library-names/r6rs lib) + (map (lambda (ver) + `(live ,@(library-name-parts lib) + ,(if (number? ver) + (string->symbol + (string-append "v" (number->string ver))) + ,ver))) + (library-versions lib))) + +(define (library-names/r7rs lib) + (map (lambda (ver) + `(live ,@(library-name-parts lib) + ,ver)) + (library-versions lib))) (define libraries - '((live bitwise) - (live number) - (live string) - (live time iso))) + (list + + (make-library '(bitwise) + '(unstable)) + + (make-library '(fixnum) + '(unstable)) + + (make-library '(list) + '(unstable)) + + (make-library '(number) + '(unstable)) + + (make-library '(string) + '(unstable)) + + (make-library '(time iso) + '(unstable)))) (define (string-join lst delimiter) (if (null? lst) "" @@ -68,18 +105,21 @@ (distribution-files "live.egg" "live.release-info" - ,@(map library-name->sld libraries)) + ,@(map library-name->sld (append-map library-names/r7rs libraries))) (components - ,@(map (lambda (lib) - `(extension - ,(library-name->chicken lib) - (source ,(library-name->sld lib)) - (source-dependencies - ,@(map library-name->sld (mine 'include lib))) - (component-dependencies - ,@(map library-name->chicken (mine 'import lib))) - (csc-options "-R" "r7rs" "-X" "r7rs"))) - libraries))))))) + ,@(append-map + (lambda (lib) + (map (lambda (libname) + `(extension + ,(library-name->chicken libname) + (source ,(library-name->sld libname)) + (source-dependencies + ,@(map library-name->sld (mine 'include lib))) + (component-dependencies + ,@(map library-name->chicken (mine 'import lib))) + (csc-options "-R" "r7rs" "-X" "r7rs"))) + (library-names/r7rs lib))) + libraries))))))) (define (main) (write-chicken-5-egg-file)) From d6c751e02be55b807db0fce1a0e7c60d0b99a356 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 27 Nov 2021 18:51:11 +0200 Subject: [PATCH 03/27] Make our Chicken egg depend on the r7rs egg --- scripts/generate-wrappers.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/scripts/generate-wrappers.scm b/scripts/generate-wrappers.scm index 88f4583..31b2a00 100644 --- a/scripts/generate-wrappers.scm +++ b/scripts/generate-wrappers.scm @@ -97,6 +97,7 @@ (license ,spdx-license-expression) (author ,author) (dependencies + r7rs ,@(map (lambda (srfi) (string->symbol (string-append "srfi-" (number->string srfi)))) From de9be923439c57aeb2fa2a3d1bcde0573f2b99c2 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 27 Nov 2021 18:52:58 +0200 Subject: [PATCH 04/27] Re-generate .egg --- live.egg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/live.egg b/live.egg index 67788be..4797525 100644 --- a/live.egg +++ b/live.egg @@ -7,7 +7,7 @@ (category misc) (license "MIT") (author "Scheme Live Crew") - (dependencies srfi-143 srfi-151) + (dependencies r7rs srfi-143 srfi-151) (test-dependencies) (distribution-files "live.egg" From 6be1c1ce2cc0baf5d6021d021311db2dd2174d29 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 27 Nov 2021 21:21:43 +0200 Subject: [PATCH 05/27] Fix bug in generate-wrappers --- scripts/generate-wrappers.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/generate-wrappers.scm b/scripts/generate-wrappers.scm index 31b2a00..a9d4005 100644 --- a/scripts/generate-wrappers.scm +++ b/scripts/generate-wrappers.scm @@ -32,7 +32,7 @@ ,(if (number? ver) (string->symbol (string-append "v" (number->string ver))) - ,ver))) + ver))) (library-versions lib))) (define (library-names/r7rs lib) From 04b6794c5bc3fc995636324b374dfb113586ec3d Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 27 Nov 2021 18:56:10 +0200 Subject: [PATCH 06/27] Depend on openssl and uri-generic eggs --- live.egg | 2 +- scripts/generate-wrappers.scm | 16 ++++++++++------ 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/live.egg b/live.egg index 4797525..905023f 100644 --- a/live.egg +++ b/live.egg @@ -7,7 +7,7 @@ (category misc) (license "MIT") (author "Scheme Live Crew") - (dependencies r7rs srfi-143 srfi-151) + (dependencies r7rs openssl uri-generic srfi-143 srfi-151) (test-dependencies) (distribution-files "live.egg" diff --git a/scripts/generate-wrappers.scm b/scripts/generate-wrappers.scm index a9d4005..09fba60 100644 --- a/scripts/generate-wrappers.scm +++ b/scripts/generate-wrappers.scm @@ -22,6 +22,15 @@ '(143 151)) +(define chicken-eggs + (append '(r7rs + openssl + uri-generic) + (map (lambda (srfi) + (string->symbol + (string-append "srfi-" (number->string srfi)))) + srfis))) + (define make-library cons) (define library-name-parts car) (define library-versions cdr) @@ -96,12 +105,7 @@ (category misc) (license ,spdx-license-expression) (author ,author) - (dependencies - r7rs - ,@(map (lambda (srfi) - (string->symbol - (string-append "srfi-" (number->string srfi)))) - srfis)) + (dependencies ,@chicken-eggs) (test-dependencies) (distribution-files "live.egg" From 9e5ebcbc22fda21de267b6aea1ed87a7376ec859 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 27 Nov 2021 18:58:39 +0200 Subject: [PATCH 07/27] Import gemini client From https://github.com/lassik/scheme-gemini Commit a896578b4a7665aabe44a89639a56da2d2c08cad --- live/net/gemini/client/unstable.sld | 38 +++++++++ live/net/gemini/unstable.sld | 119 ++++++++++++++++++++++++++++ 2 files changed, 157 insertions(+) create mode 100644 live/net/gemini/client/unstable.sld create mode 100644 live/net/gemini/unstable.sld diff --git a/live/net/gemini/client/unstable.sld b/live/net/gemini/client/unstable.sld new file mode 100644 index 0000000..6d9ef96 --- /dev/null +++ b/live/net/gemini/client/unstable.sld @@ -0,0 +1,38 @@ +(define-library (gemini client) + (export gemini-get) + (import (scheme base) (gemini)) + (cond-expand + (chicken + (import (chicken condition) (openssl) (uri-generic)))) + (begin + + (define (write-request to-server uri-string) + (write-string (string-append uri-string "\r\n") to-server)) + + (define (read-response from-server) + (let ((line (read-cr-lf-terminated-line from-server))) + (if (or (< (string-length line) 3) + (not (char<=? #\0 (string-ref line 0) #\9)) + (not (char<=? #\0 (string-ref line 1) #\9)) + (not (char=? #\space (string-ref line 2)))) + (error "Malformed first line" line) + (let ((code (string->number (string-copy line 0 2))) + (meta (string-copy line 3 (string-length line)))) + (make-gemini-response code meta from-server))))) + + (define (gemini-get uri handle-response) + (let* ((uri-object (uri-reference uri)) + (uri-string (if (string? uri) uri (uri->string uri-object)))) + (unless (eq? 'gemini (uri-scheme uri-object)) + (error "Not a gemini URI" uri)) + (let-values (((from-server to-server) + (ssl-connect* hostname: (uri-host uri-object) + port: (or (uri-port uri-object) 1965) + verify?: #f))) + (dynamic-wind (lambda () #f) + (lambda () + (write-request to-server uri-string) + (handle-response (read-response from-server))) + (lambda () + (close-input-port from-server) + (close-output-port to-server)))))))) diff --git a/live/net/gemini/unstable.sld b/live/net/gemini/unstable.sld new file mode 100644 index 0000000..70e3c2a --- /dev/null +++ b/live/net/gemini/unstable.sld @@ -0,0 +1,119 @@ +(define-library (gemini) + (export gemini-error? + gemini-error-response + make-gemini-response + gemini-symbol->code + gemini-code->symbol + gemini-response? + gemini-response-code + gemini-response-first-digit + gemini-response-second-digit + gemini-response-success? + gemini-response-redirect? + gemini-response-meta + gemini-response-port + gemini-response-read-bytevector-all + gemini-response-read-string-all + gemini-response-raise + read-cr-lf-terminated-line) + (import (scheme base)) + (cond-expand + (chicken + (import (chicken condition) (openssl) (uri-generic)))) + (cond-expand + (chicken + + (define gemini-error? + (condition-predicate 'gemini-error)) + + (define gemini-error-response + (condition-property-accessor 'gemini-error 'response #f)) + + (define (make-gemini-error response) + (make-property-condition 'gemini-error + 'message "Gemini request failed" + 'response response)))) + (begin + + ;; Snarfed from Kooda's geminid. + (define gemini-code-alist + '((input . 10) + (sensitive-input . 11) + (success . 20) + (redirect . 30) + (redirect-temporary . 30) + (redirect-permanent . 31) + (temporary-failure . 40) + (server-unavailable . 41) + (cgi-error . 42) + (proxy-error . 43) + (slow-down . 44) + (permanent-failure . 50) + (not-found . 51) + (gone . 52) + (proxy-request-refused . 53) + (bad-request . 59) + (client-certificate-required . 60) + (certificate-not-authorised . 61) + (certificate-not-valid . 62))) + + (define (rassv key alist) + (cond ((null? alist) #f) + ((eqv? key (cdar alist)) (car alist)) + (else (rassv key (cddr alist))))) + + (define (gemini-symbol->code symbol) + (let ((entry (assq symbol gemini-code-alist))) + (and entry (cdr entry)))) + + (define (gemini-code->symbol code) + (let ((entry (rassv code gemini-code-alist))) + (and entry (cdr entry)))) + + (define-record-type gemini-respose + (make-gemini-response code meta port) + gemini-response? + (code gemini-response-code) + (meta gemini-response-meta) + (port gemini-response-port)) + + (define (gemini-response-first-digit response) + (truncate-quotient (gemini-response-code response) 10)) + + (define (gemini-response-second-digit response) + (truncate-remainder (gemini-response-code response) 10)) + + (define (gemini-response-success? response) + (= 2 (gemini-response-first-digit response))) + + (define (gemini-response-redirect? response) + (= 3 (gemini-response-first-digit response))) + + (define (gemini-response-raise response) + (and (not (gemini-response-success? response)) + (raise (make-gemini-error response)))) + + (define (gemini-response-read-bytevector-all response) + (let ((port (gemini-response-port response))) + (let loop ((whole (bytevector))) + (let ((part (read-bytevector 10000 port))) + (if (eof-object? part) whole + (loop (bytevector-append whole part))))))) + + (define (gemini-response-read-string-all response) + (utf8->string (gemini-response-read-bytevector-all response))) + + (define (malformed-first-line line) + (error "Malformed first line" line)) + + (define (read-cr-lf-terminated-line port) + (let loop ((line "")) + (let ((char (read-char port))) + (if (eof-object? char) + (malformed-first-line line) + (if (char=? #\return char) + (let ((char (read-char port))) + (if (char=? #\newline char) + line + (malformed-first-line line))) + (loop (string-append line (string char)))))))))) From eb04d305a70b7c047b3d176b5a6cba55e3efc2de Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 27 Nov 2021 19:05:28 +0200 Subject: [PATCH 08/27] Make gemini client work --- live.egg | 14 +++++ live/net/gemini/client/live.scm | 30 ++++++++++ live/net/gemini/client/unstable.sld | 38 ++----------- live/net/gemini/live.scm | 82 +++++++++++++++++++++++++++ live/net/gemini/unstable.sld | 87 +---------------------------- scripts/generate-wrappers.scm | 6 ++ 6 files changed, 138 insertions(+), 119 deletions(-) create mode 100644 live/net/gemini/client/live.scm create mode 100644 live/net/gemini/live.scm diff --git a/live.egg b/live.egg index 905023f..7905814 100644 --- a/live.egg +++ b/live.egg @@ -15,6 +15,8 @@ "live/bitwise/unstable.sld" "live/fixnum/unstable.sld" "live/list/unstable.sld" + "live/net/gemini/unstable.sld" + "live/net/gemini/client/unstable.sld" "live/number/unstable.sld" "live/string/unstable.sld" "live/time/iso/unstable.sld") @@ -37,6 +39,18 @@ (source-dependencies) (component-dependencies) (csc-options "-R" "r7rs" "-X" "r7rs")) + (extension + live.net.gemini.unstable + (source "live/net/gemini/unstable.sld") + (source-dependencies) + (component-dependencies) + (csc-options "-R" "r7rs" "-X" "r7rs")) + (extension + live.net.gemini.client.unstable + (source "live/net/gemini/client/unstable.sld") + (source-dependencies) + (component-dependencies) + (csc-options "-R" "r7rs" "-X" "r7rs")) (extension live.number.unstable (source "live/number/unstable.sld") diff --git a/live/net/gemini/client/live.scm b/live/net/gemini/client/live.scm new file mode 100644 index 0000000..71c99db --- /dev/null +++ b/live/net/gemini/client/live.scm @@ -0,0 +1,30 @@ +(define (write-request to-server uri-string) + (write-string (string-append uri-string "\r\n") to-server)) + +(define (read-response from-server) + (let ((line (read-cr-lf-terminated-line from-server))) + (if (or (< (string-length line) 3) + (not (char<=? #\0 (string-ref line 0) #\9)) + (not (char<=? #\0 (string-ref line 1) #\9)) + (not (char=? #\space (string-ref line 2)))) + (error "Malformed first line" line) + (let ((code (string->number (string-copy line 0 2))) + (meta (string-copy line 3 (string-length line)))) + (make-gemini-response code meta from-server))))) + +(define (gemini-get uri handle-response) + (let* ((uri-object (uri-reference uri)) + (uri-string (if (string? uri) uri (uri->string uri-object)))) + (unless (eq? 'gemini (uri-scheme uri-object)) + (error "Not a gemini URI" uri)) + (let-values (((from-server to-server) + (ssl-connect* hostname: (uri-host uri-object) + port: (or (uri-port uri-object) 1965) + verify?: #f))) + (dynamic-wind (lambda () #f) + (lambda () + (write-request to-server uri-string) + (handle-response (read-response from-server))) + (lambda () + (close-input-port from-server) + (close-output-port to-server)))))) diff --git a/live/net/gemini/client/unstable.sld b/live/net/gemini/client/unstable.sld index 6d9ef96..e0e252d 100644 --- a/live/net/gemini/client/unstable.sld +++ b/live/net/gemini/client/unstable.sld @@ -1,38 +1,8 @@ -(define-library (gemini client) +(define-library (live net gemini client unstable) (export gemini-get) - (import (scheme base) (gemini)) + (import (scheme base) + (live net gemini unstable)) (cond-expand (chicken (import (chicken condition) (openssl) (uri-generic)))) - (begin - - (define (write-request to-server uri-string) - (write-string (string-append uri-string "\r\n") to-server)) - - (define (read-response from-server) - (let ((line (read-cr-lf-terminated-line from-server))) - (if (or (< (string-length line) 3) - (not (char<=? #\0 (string-ref line 0) #\9)) - (not (char<=? #\0 (string-ref line 1) #\9)) - (not (char=? #\space (string-ref line 2)))) - (error "Malformed first line" line) - (let ((code (string->number (string-copy line 0 2))) - (meta (string-copy line 3 (string-length line)))) - (make-gemini-response code meta from-server))))) - - (define (gemini-get uri handle-response) - (let* ((uri-object (uri-reference uri)) - (uri-string (if (string? uri) uri (uri->string uri-object)))) - (unless (eq? 'gemini (uri-scheme uri-object)) - (error "Not a gemini URI" uri)) - (let-values (((from-server to-server) - (ssl-connect* hostname: (uri-host uri-object) - port: (or (uri-port uri-object) 1965) - verify?: #f))) - (dynamic-wind (lambda () #f) - (lambda () - (write-request to-server uri-string) - (handle-response (read-response from-server))) - (lambda () - (close-input-port from-server) - (close-output-port to-server)))))))) + (include "live.scm")) diff --git a/live/net/gemini/live.scm b/live/net/gemini/live.scm new file mode 100644 index 0000000..f036259 --- /dev/null +++ b/live/net/gemini/live.scm @@ -0,0 +1,82 @@ +;; Snarfed from Kooda's geminid. +(define gemini-code-alist + '((input . 10) + (sensitive-input . 11) + (success . 20) + (redirect . 30) + (redirect-temporary . 30) + (redirect-permanent . 31) + (temporary-failure . 40) + (server-unavailable . 41) + (cgi-error . 42) + (proxy-error . 43) + (slow-down . 44) + (permanent-failure . 50) + (not-found . 51) + (gone . 52) + (proxy-request-refused . 53) + (bad-request . 59) + (client-certificate-required . 60) + (certificate-not-authorised . 61) + (certificate-not-valid . 62))) + +(define (rassv key alist) + (cond ((null? alist) #f) + ((eqv? key (cdar alist)) (car alist)) + (else (rassv key (cddr alist))))) + +(define (gemini-symbol->code symbol) + (let ((entry (assq symbol gemini-code-alist))) + (and entry (cdr entry)))) + +(define (gemini-code->symbol code) + (let ((entry (rassv code gemini-code-alist))) + (and entry (cdr entry)))) + +(define-record-type gemini-respose + (make-gemini-response code meta port) + gemini-response? + (code gemini-response-code) + (meta gemini-response-meta) + (port gemini-response-port)) + +(define (gemini-response-first-digit response) + (truncate-quotient (gemini-response-code response) 10)) + +(define (gemini-response-second-digit response) + (truncate-remainder (gemini-response-code response) 10)) + +(define (gemini-response-success? response) + (= 2 (gemini-response-first-digit response))) + +(define (gemini-response-redirect? response) + (= 3 (gemini-response-first-digit response))) + +(define (gemini-response-raise response) + (and (not (gemini-response-success? response)) + (raise (make-gemini-error response)))) + +(define (gemini-response-read-bytevector-all response) + (let ((port (gemini-response-port response))) + (let loop ((whole (bytevector))) + (let ((part (read-bytevector 10000 port))) + (if (eof-object? part) whole + (loop (bytevector-append whole part))))))) + +(define (gemini-response-read-string-all response) + (utf8->string (gemini-response-read-bytevector-all response))) + +(define (malformed-first-line line) + (error "Malformed first line" line)) + +(define (read-cr-lf-terminated-line port) + (let loop ((line "")) + (let ((char (read-char port))) + (if (eof-object? char) + (malformed-first-line line) + (if (char=? #\return char) + (let ((char (read-char port))) + (if (char=? #\newline char) + line + (malformed-first-line line))) + (loop (string-append line (string char)))))))) diff --git a/live/net/gemini/unstable.sld b/live/net/gemini/unstable.sld index 70e3c2a..be08381 100644 --- a/live/net/gemini/unstable.sld +++ b/live/net/gemini/unstable.sld @@ -1,4 +1,4 @@ -(define-library (gemini) +(define-library (live net gemini unstable) (export gemini-error? gemini-error-response make-gemini-response @@ -33,87 +33,4 @@ (make-property-condition 'gemini-error 'message "Gemini request failed" 'response response)))) - (begin - - ;; Snarfed from Kooda's geminid. - (define gemini-code-alist - '((input . 10) - (sensitive-input . 11) - (success . 20) - (redirect . 30) - (redirect-temporary . 30) - (redirect-permanent . 31) - (temporary-failure . 40) - (server-unavailable . 41) - (cgi-error . 42) - (proxy-error . 43) - (slow-down . 44) - (permanent-failure . 50) - (not-found . 51) - (gone . 52) - (proxy-request-refused . 53) - (bad-request . 59) - (client-certificate-required . 60) - (certificate-not-authorised . 61) - (certificate-not-valid . 62))) - - (define (rassv key alist) - (cond ((null? alist) #f) - ((eqv? key (cdar alist)) (car alist)) - (else (rassv key (cddr alist))))) - - (define (gemini-symbol->code symbol) - (let ((entry (assq symbol gemini-code-alist))) - (and entry (cdr entry)))) - - (define (gemini-code->symbol code) - (let ((entry (rassv code gemini-code-alist))) - (and entry (cdr entry)))) - - (define-record-type gemini-respose - (make-gemini-response code meta port) - gemini-response? - (code gemini-response-code) - (meta gemini-response-meta) - (port gemini-response-port)) - - (define (gemini-response-first-digit response) - (truncate-quotient (gemini-response-code response) 10)) - - (define (gemini-response-second-digit response) - (truncate-remainder (gemini-response-code response) 10)) - - (define (gemini-response-success? response) - (= 2 (gemini-response-first-digit response))) - - (define (gemini-response-redirect? response) - (= 3 (gemini-response-first-digit response))) - - (define (gemini-response-raise response) - (and (not (gemini-response-success? response)) - (raise (make-gemini-error response)))) - - (define (gemini-response-read-bytevector-all response) - (let ((port (gemini-response-port response))) - (let loop ((whole (bytevector))) - (let ((part (read-bytevector 10000 port))) - (if (eof-object? part) whole - (loop (bytevector-append whole part))))))) - - (define (gemini-response-read-string-all response) - (utf8->string (gemini-response-read-bytevector-all response))) - - (define (malformed-first-line line) - (error "Malformed first line" line)) - - (define (read-cr-lf-terminated-line port) - (let loop ((line "")) - (let ((char (read-char port))) - (if (eof-object? char) - (malformed-first-line line) - (if (char=? #\return char) - (let ((char (read-char port))) - (if (char=? #\newline char) - line - (malformed-first-line line))) - (loop (string-append line (string char)))))))))) + (include "live.scm")) diff --git a/scripts/generate-wrappers.scm b/scripts/generate-wrappers.scm index 09fba60..33972d5 100644 --- a/scripts/generate-wrappers.scm +++ b/scripts/generate-wrappers.scm @@ -62,6 +62,12 @@ (make-library '(list) '(unstable)) + (make-library '(net gemini) + '(unstable)) + + (make-library '(net gemini client) + '(unstable)) + (make-library '(number) '(unstable)) From 196f315a38ddc91a067c5a189a2376005bbd6a06 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 27 Nov 2021 21:40:22 +0200 Subject: [PATCH 09/27] Drop unneeded openssl import --- live/net/gemini/unstable.sld | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/live/net/gemini/unstable.sld b/live/net/gemini/unstable.sld index be08381..94510af 100644 --- a/live/net/gemini/unstable.sld +++ b/live/net/gemini/unstable.sld @@ -19,7 +19,8 @@ (import (scheme base)) (cond-expand (chicken - (import (chicken condition) (openssl) (uri-generic)))) + (import (chicken condition) + (uri-generic)))) (cond-expand (chicken From ae085ed4fcd235d78141c5fbe4605363665da10f Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Mon, 29 Nov 2021 19:04:02 +0200 Subject: [PATCH 10/27] Grovel define-library for (include "...") --- live.egg | 5 +++++ scripts/generate-wrappers.scm | 38 +++++++++++++++++++++++++++++++++-- 2 files changed, 41 insertions(+), 2 deletions(-) diff --git a/live.egg b/live.egg index 7905814..3392dd6 100644 --- a/live.egg +++ b/live.egg @@ -15,10 +15,15 @@ "live/bitwise/unstable.sld" "live/fixnum/unstable.sld" "live/list/unstable.sld" + "live/list/live.scm" "live/net/gemini/unstable.sld" + "live/net/gemini/live.scm" "live/net/gemini/client/unstable.sld" + "live/net/gemini/client/live.scm" "live/number/unstable.sld" "live/string/unstable.sld" + "live/string/live.scm" + "live/string/srfi-13.scm" "live/time/iso/unstable.sld") (components (extension diff --git a/scripts/generate-wrappers.scm b/scripts/generate-wrappers.scm index 33972d5..a8e099c 100644 --- a/scripts/generate-wrappers.scm +++ b/scripts/generate-wrappers.scm @@ -3,7 +3,8 @@ ;;! Copyright 2021 Lassi Kortela ;;! SPDX-License-Identifier: MIT -(import (scheme base) (scheme write) (srfi 1) (srfi 193)) +(import (scheme base) (scheme write) + (srfi 1) (srfi 132) (srfi 193)) (cond-expand (chicken @@ -82,15 +83,38 @@ (fold (lambda (item result) (string-append result delimiter item)) (car lst) (cdr lst)))) +(define (tree-fold merge state tree) + (let ((state (merge tree state))) + (if (not (list? tree)) state + (fold (lambda (elem state) (tree-fold merge state elem)) + state tree)))) + (define (lnp->string part) ((if (number? part) number->string symbol->string) part)) +(define (library-name->directory parts) + (fold (lambda (part whole) (string-append whole part "/")) + "" (map lnp->string (drop-right parts 1)))) + (define (library-name->sld parts) (string-append (string-join (map lnp->string parts) "/") ".sld")) (define (library-name->chicken parts) (string->symbol (string-join (map lnp->string parts) "."))) +(define (grovel-includes) + (let ((includes + (tree-fold (lambda (x includes) + (if (and (list? x) + (not (null? x)) + (eq? 'include (car x)) + (every string? (cdr x))) + (append includes (cdr x)) + includes)) + '() + (read)))) + (list-delete-neighbor-dups string=? (list-sort stringsld (append-map library-names/r7rs libraries))) + ,@(append-map + (lambda (lib-name) + (let ((lib-dir (library-name->directory lib-name)) + (sld-file (library-name->sld lib-name))) + (cons sld-file + (map (lambda (included-file) + (string-append lib-dir included-file)) + (with-input-from-file + (string-append live-root sld-file) + grovel-includes))))) + (append-map library-names/r7rs libraries))) (components ,@(append-map (lambda (lib) From 27bc859064d9ee4a3e2d154467fbd8bfcb920369 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Mon, 29 Nov 2021 19:23:24 +0200 Subject: [PATCH 11/27] Spell 'lib-name' consistently --- scripts/generate-wrappers.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/scripts/generate-wrappers.scm b/scripts/generate-wrappers.scm index a8e099c..31aaf70 100644 --- a/scripts/generate-wrappers.scm +++ b/scripts/generate-wrappers.scm @@ -154,10 +154,10 @@ (components ,@(append-map (lambda (lib) - (map (lambda (libname) + (map (lambda (lib-name) `(extension - ,(library-name->chicken libname) - (source ,(library-name->sld libname)) + ,(library-name->chicken lib-name) + (source ,(library-name->sld lib-name)) (source-dependencies ,@(map library-name->sld (mine 'include lib))) (component-dependencies From e7203d98155e313a4cec2849772c243faf1a7d70 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Mon, 29 Nov 2021 19:24:59 +0200 Subject: [PATCH 12/27] Fill in source-dependencies for each egg component --- live.egg | 8 ++++---- scripts/generate-wrappers.scm | 20 ++++++++++---------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/live.egg b/live.egg index 3392dd6..568f422 100644 --- a/live.egg +++ b/live.egg @@ -41,19 +41,19 @@ (extension live.list.unstable (source "live/list/unstable.sld") - (source-dependencies) + (source-dependencies "live/list/live.scm") (component-dependencies) (csc-options "-R" "r7rs" "-X" "r7rs")) (extension live.net.gemini.unstable (source "live/net/gemini/unstable.sld") - (source-dependencies) + (source-dependencies "live/net/gemini/live.scm") (component-dependencies) (csc-options "-R" "r7rs" "-X" "r7rs")) (extension live.net.gemini.client.unstable (source "live/net/gemini/client/unstable.sld") - (source-dependencies) + (source-dependencies "live/net/gemini/client/live.scm") (component-dependencies) (csc-options "-R" "r7rs" "-X" "r7rs")) (extension @@ -65,7 +65,7 @@ (extension live.string.unstable (source "live/string/unstable.sld") - (source-dependencies) + (source-dependencies "live/string/live.scm" "live/string/srfi-13.scm") (component-dependencies) (csc-options "-R" "r7rs" "-X" "r7rs")) (extension diff --git a/scripts/generate-wrappers.scm b/scripts/generate-wrappers.scm index 31aaf70..c7e0a1b 100644 --- a/scripts/generate-wrappers.scm +++ b/scripts/generate-wrappers.scm @@ -120,6 +120,13 @@ (define (disp . xs) (for-each display xs) (newline)) +(define (library-includes lib-name) + (let ((lib-dir (library-name->directory lib-name)) + (sld-file (library-name->sld lib-name))) + (map (lambda (file) (string-append lib-dir file)) + (with-input-from-file (string-append live-root sld-file) + grovel-includes)))) + (define (write-chicken-5-egg-file) (disp "Writing live.egg") (with-output-to-file (string-append live-root "live.egg") @@ -142,14 +149,8 @@ "live.release-info" ,@(append-map (lambda (lib-name) - (let ((lib-dir (library-name->directory lib-name)) - (sld-file (library-name->sld lib-name))) - (cons sld-file - (map (lambda (included-file) - (string-append lib-dir included-file)) - (with-input-from-file - (string-append live-root sld-file) - grovel-includes))))) + (cons (library-name->sld lib-name) + (library-includes lib-name))) (append-map library-names/r7rs libraries))) (components ,@(append-map @@ -158,8 +159,7 @@ `(extension ,(library-name->chicken lib-name) (source ,(library-name->sld lib-name)) - (source-dependencies - ,@(map library-name->sld (mine 'include lib))) + (source-dependencies ,@(library-includes lib-name)) (component-dependencies ,@(map library-name->chicken (mine 'import lib))) (csc-options "-R" "r7rs" "-X" "r7rs"))) From 3e0938ff7e3c22d1a1191c1c3193d1e9291c14b9 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Mon, 29 Nov 2021 20:50:41 +0200 Subject: [PATCH 13/27] Omit srfi polyfills for Chicken egg --- live.egg | 3 +-- scripts/generate-wrappers.scm | 16 ++++++++-------- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/live.egg b/live.egg index 568f422..62a7a60 100644 --- a/live.egg +++ b/live.egg @@ -23,7 +23,6 @@ "live/number/unstable.sld" "live/string/unstable.sld" "live/string/live.scm" - "live/string/srfi-13.scm" "live/time/iso/unstable.sld") (components (extension @@ -65,7 +64,7 @@ (extension live.string.unstable (source "live/string/unstable.sld") - (source-dependencies "live/string/live.scm" "live/string/srfi-13.scm") + (source-dependencies "live/string/live.scm") (component-dependencies) (csc-options "-R" "r7rs" "-X" "r7rs")) (extension diff --git a/scripts/generate-wrappers.scm b/scripts/generate-wrappers.scm index c7e0a1b..763189d 100644 --- a/scripts/generate-wrappers.scm +++ b/scripts/generate-wrappers.scm @@ -4,7 +4,7 @@ ;;! SPDX-License-Identifier: MIT (import (scheme base) (scheme write) - (srfi 1) (srfi 132) (srfi 193)) + (srfi 1) (srfi 13) (srfi 132) (srfi 193)) (cond-expand (chicken @@ -78,11 +78,6 @@ (make-library '(time iso) '(unstable)))) -(define (string-join lst delimiter) - (if (null? lst) "" - (fold (lambda (item result) (string-append result delimiter item)) - (car lst) (cdr lst)))) - (define (tree-fold merge state tree) (let ((state (merge tree state))) (if (not (list? tree)) state @@ -127,6 +122,10 @@ (with-input-from-file (string-append live-root sld-file) grovel-includes)))) +(define (library-includes-except-srfi lib-name) + (remove (lambda (file) (string-contains file "srfi-")) + (library-includes lib-name))) + (define (write-chicken-5-egg-file) (disp "Writing live.egg") (with-output-to-file (string-append live-root "live.egg") @@ -150,7 +149,7 @@ ,@(append-map (lambda (lib-name) (cons (library-name->sld lib-name) - (library-includes lib-name))) + (library-includes-except-srfi lib-name))) (append-map library-names/r7rs libraries))) (components ,@(append-map @@ -159,7 +158,8 @@ `(extension ,(library-name->chicken lib-name) (source ,(library-name->sld lib-name)) - (source-dependencies ,@(library-includes lib-name)) + (source-dependencies + ,@(library-includes-except-srfi lib-name)) (component-dependencies ,@(map library-name->chicken (mine 'import lib))) (csc-options "-R" "r7rs" "-X" "r7rs"))) From 4855d2777fda1c12f480f84e1faef21086f434de Mon Sep 17 00:00:00 2001 From: lassik Date: Mon, 29 Nov 2021 22:50:38 +0200 Subject: [PATCH 14/27] Grovel imports to fill in component-dependencies (#40) --- live.egg | 6 ++-- scripts/generate-wrappers.scm | 54 +++++++++++++++++++++++++++++++---- 2 files changed, 51 insertions(+), 9 deletions(-) diff --git a/live.egg b/live.egg index 62a7a60..8dfe6ca 100644 --- a/live.egg +++ b/live.egg @@ -41,7 +41,7 @@ live.list.unstable (source "live/list/unstable.sld") (source-dependencies "live/list/live.scm") - (component-dependencies) + (component-dependencies live.fixnum.unstable) (csc-options "-R" "r7rs" "-X" "r7rs")) (extension live.net.gemini.unstable @@ -53,7 +53,7 @@ live.net.gemini.client.unstable (source "live/net/gemini/client/unstable.sld") (source-dependencies "live/net/gemini/client/live.scm") - (component-dependencies) + (component-dependencies live.net.gemini.unstable) (csc-options "-R" "r7rs" "-X" "r7rs")) (extension live.number.unstable @@ -71,5 +71,5 @@ live.time.iso.unstable (source "live/time/iso/unstable.sld") (source-dependencies) - (component-dependencies) + (component-dependencies live.number.unstable) (csc-options "-R" "r7rs" "-X" "r7rs")))) diff --git a/scripts/generate-wrappers.scm b/scripts/generate-wrappers.scm index 763189d..c10e5aa 100644 --- a/scripts/generate-wrappers.scm +++ b/scripts/generate-wrappers.scm @@ -78,6 +78,13 @@ (make-library '(time iso) '(unstable)))) +(define (listchicken parts) (string->symbol (string-join (map lnp->string parts) "."))) +(define (library-name-partstring part) + (symbol->string part))) + (stringsld lib-name))) + (with-input-from-file (string-append live-root sld-file) + grovel-imports))) (define (disp . xs) (for-each display xs) (newline)) @@ -161,7 +200,10 @@ (source-dependencies ,@(library-includes-except-srfi lib-name)) (component-dependencies - ,@(map library-name->chicken (mine 'import lib))) + ,@(map library-name->chicken + (filter (lambda (name) + (list-with-head? 'live name)) + (library-imports lib-name)))) (csc-options "-R" "r7rs" "-X" "r7rs"))) (library-names/r7rs lib))) libraries))))))) From 9c750182a38af50b74faa4f26c780b8da7d6c6ed Mon Sep 17 00:00:00 2001 From: lassik Date: Mon, 29 Nov 2021 22:52:11 +0200 Subject: [PATCH 15/27] Add unwind-protect for private use (#17) --- .dir-locals.el | 1 + live/private/helpers.sld | 16 +++++++++ tests/private.scm | 70 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 87 insertions(+) create mode 100644 live/private/helpers.sld create mode 100644 tests/private.scm diff --git a/.dir-locals.el b/.dir-locals.el index e06d372..d49d2df 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -5,6 +5,7 @@ c-lambda 2 let*-pointers 1 test-group 1 + unwind-protect 0 ;; okvs: call-with-input-file 1 call-with-values 1 diff --git a/live/private/helpers.sld b/live/private/helpers.sld new file mode 100644 index 0000000..1e45244 --- /dev/null +++ b/live/private/helpers.sld @@ -0,0 +1,16 @@ +(define-library (live private helpers) + (export unwind-protect) + (import (scheme base)) + (begin + + ;; Like dynamic-wind, but ensures the `after` procedure is run + ;; only once. From Common Lisp. + (define (unwind-protect thunk after) + (dynamic-wind + (lambda () #f) + thunk + (let ((after? #t)) + (lambda () + (when after? + (set! after? #f) + (after)))))))) diff --git a/tests/private.scm b/tests/private.scm new file mode 100644 index 0000000..7ba9947 --- /dev/null +++ b/tests/private.scm @@ -0,0 +1,70 @@ +(import (scheme base) (live private helpers) (live test)) + +(test-begin "live/private/helpers") + +(test-group "unwind-protect" + + (test-equal '(1) + (let ((nums '())) + (unwind-protect + (lambda () + (set! nums (append nums '(1))) + nums) + (lambda () + (set! nums (append nums '(2))))))) + + (test-equal '(1 2) + (let ((nums '())) + (unwind-protect + (lambda () (set! nums (append nums '(1)))) + (lambda () (set! nums (append nums '(2))))) + nums)) + + + (test-equal '((1) (1 2)) + (let* ((nums '()) + (a (unwind-protect + (lambda () + (set! nums (append nums '(1))) + nums) + (lambda () + (set! nums (append nums '(2)))))) + (b nums)) + (list a b))) + + (test-equal '(0 0 1 1 2 2 3 3 4 4 5 5) + (let ((nums '()) (n 5)) + (let ((resume (call/cc + (lambda (announce) + (dynamic-wind + (lambda () #f) + (lambda () + (let loop () + (if (zero? n) + (lambda () nums) + (begin (call/cc announce) + (set! n (- n 1)) + (loop))))) + (lambda () + (call/cc announce))))))) + (set! nums (cons n nums)) + (resume)))) + + (test-equal '(0 1 2 3 4 5 5) + (let ((nums '()) (n 5)) + (let ((resume (call/cc + (lambda (announce) + (unwind-protect + (lambda () + (let loop () + (if (zero? n) + (lambda () nums) + (begin (call/cc announce) + (set! n (- n 1)) + (loop))))) + (lambda () + (call/cc announce))))))) + (set! nums (cons n nums)) + (resume))))) + +(test-end) From a15787dbb9a44c9fdeab6fa9a9816fe2a8193d66 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Mon, 29 Nov 2021 23:12:24 +0200 Subject: [PATCH 16/27] Add SRFI 13 and 14 to egg deps --- live.egg | 2 +- scripts/generate-wrappers.scm | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/live.egg b/live.egg index 8dfe6ca..41e5a3e 100644 --- a/live.egg +++ b/live.egg @@ -7,7 +7,7 @@ (category misc) (license "MIT") (author "Scheme Live Crew") - (dependencies r7rs openssl uri-generic srfi-143 srfi-151) + (dependencies r7rs openssl uri-generic srfi-13 srfi-14 srfi-143 srfi-151) (test-dependencies) (distribution-files "live.egg" diff --git a/scripts/generate-wrappers.scm b/scripts/generate-wrappers.scm index c10e5aa..778f8a7 100644 --- a/scripts/generate-wrappers.scm +++ b/scripts/generate-wrappers.scm @@ -20,7 +20,9 @@ ;; TODO: These SRFI numbers should be found by groveling the imports ;; in the .sld files. (define srfis - '(143 + '(13 + 14 + 143 151)) (define chicken-eggs From d3fb9802d792a9bfac43d6ab09d2b0b78fe9b119 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Mon, 29 Nov 2021 23:41:11 +0200 Subject: [PATCH 17/27] Add string-split procedure --- live/string/live.scm | 24 ++++++++++++++++++++++++ live/string/unstable.sld | 1 + tests/string.scm | 16 ++++++++++++++-- 3 files changed, 39 insertions(+), 2 deletions(-) diff --git a/live/string/live.scm b/live/string/live.scm index 20affab..db0f53e 100644 --- a/live/string/live.scm +++ b/live/string/live.scm @@ -13,6 +13,30 @@ (define (string-blank? str) (string-every char-whitespace? str)) +(define (string->one-char-strings string) + (let loop ((strings '()) (n (string-length string))) + (if (zero? n) strings + (loop (cons (string-copy string (- n 1) n) strings) (- n 1))))) + +;; SRFI 140 (Immutable Strings) has the following: +;; +;; (string-split string delimiter [grammar limit start end]) -> list + +(define (string-split string delimiter) + (if (string-null? delimiter) + (string->one-char-strings string) + (reverse + (let loop ((parts '()) (a 0)) + (if (> a (string-length string)) + parts + (let* ((b (string-contains string delimiter a)) + (part (string-copy + string a (or b (string-length string)))) + (parts (cons part parts))) + (if b + (loop parts (+ b (string-length delimiter))) + parts))))))) + (define (with-input-from-string str proc) (call-with-port (open-input-string str) (lambda (in) diff --git a/live/string/unstable.sld b/live/string/unstable.sld index edf1aef..243c044 100644 --- a/live/string/unstable.sld +++ b/live/string/unstable.sld @@ -18,6 +18,7 @@ string-char-prefix? string-char-suffix? string-last-index + string-split with-input-from-string with-output-to-string) (import (scheme base) diff --git a/tests/string.scm b/tests/string.scm index 3085b5e..6e172f5 100644 --- a/tests/string.scm +++ b/tests/string.scm @@ -1,6 +1,18 @@ -(import (live string) (live test)) +(import (scheme base) (live string unstable) (live test)) -(test-begin "live/string") +(test-begin "live/string/unstable") + +(test-group "string-split" + (test-equal '("f" "o" "o" "b" "a" "r") + (string-split "foobar" "")) + (test-equal '("") + (string-split "" ",")) + (test-equal '(",") + (string-split "," "")) + (test-equal '("foo" "bar") + (string-split "foo,bar" ",")) + (test-equal '("foo" "bar" "") + (string-split "foo,bar," ","))) (test-group "string-last-index" (test-eqv #f (string-last-index "")) From c3526daef08c32e57f04828c0e9ed8228f58fbf3 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Tue, 30 Nov 2021 10:14:10 +0200 Subject: [PATCH 18/27] Refactor string->one-char-strings --- live/string/live.scm | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/live/string/live.scm b/live/string/live.scm index db0f53e..7598d81 100644 --- a/live/string/live.scm +++ b/live/string/live.scm @@ -14,9 +14,14 @@ (string-every char-whitespace? str)) (define (string->one-char-strings string) - (let loop ((strings '()) (n (string-length string))) - (if (zero? n) strings - (loop (cons (string-copy string (- n 1) n) strings) (- n 1))))) + (let loop ((n (string-length string)) + (strings '())) + (if (zero? n) + strings + (let ((m (- n 1))) + (loop m + (cons (string-copy string m n) + strings)))))) ;; SRFI 140 (Immutable Strings) has the following: ;; From 701b1cbcaf65c5834a18ced07879ecbe50e3df23 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Tue, 30 Nov 2021 08:27:43 +0200 Subject: [PATCH 19/27] Update typecheck library - Add `unstable` suffix. - Add portable R7RS implementation. - Add tests. --- live/typecheck.r7rs.scm | 9 -------- live/typecheck.sld | 7 ------- .../live.chicken.scm} | 0 live/typecheck/live.r7rs.scm | 11 ++++++++++ live/typecheck/unstable.sld | 9 ++++++++ tests/typecheck.scm | 21 +++++++++++++++++++ 6 files changed, 41 insertions(+), 16 deletions(-) delete mode 100644 live/typecheck.r7rs.scm delete mode 100644 live/typecheck.sld rename live/{typecheck.chicken.scm => typecheck/live.chicken.scm} (100%) create mode 100644 live/typecheck/live.r7rs.scm create mode 100644 live/typecheck/unstable.sld create mode 100644 tests/typecheck.scm diff --git a/live/typecheck.r7rs.scm b/live/typecheck.r7rs.scm deleted file mode 100644 index feb8e70..0000000 --- a/live/typecheck.r7rs.scm +++ /dev/null @@ -1,9 +0,0 @@ -(define-syntax typecheck-bytevector - (syntax-rules () - ((_ who var) - #f))) - -(define-syntax typecheck-string - (syntax-rules () - ((_ who var) - #f))) diff --git a/live/typecheck.sld b/live/typecheck.sld deleted file mode 100644 index d559703..0000000 --- a/live/typecheck.sld +++ /dev/null @@ -1,7 +0,0 @@ -(define-library (live typecheck) - (export typecheck-bytevector - typecheck-string) - (import (scheme base)) - (cond-expand - (chicken (include "typecheck.chicken.scm")) - (else (include "typecheck.r7rs.scm")))) diff --git a/live/typecheck.chicken.scm b/live/typecheck/live.chicken.scm similarity index 100% rename from live/typecheck.chicken.scm rename to live/typecheck/live.chicken.scm diff --git a/live/typecheck/live.r7rs.scm b/live/typecheck/live.r7rs.scm new file mode 100644 index 0000000..8ff843b --- /dev/null +++ b/live/typecheck/live.r7rs.scm @@ -0,0 +1,11 @@ +(define-syntax typecheck-bytevector + (syntax-rules () + ((_ who var) + (unless (bytevector? var) + (error "Not a bytevector" var 'who))))) + +(define-syntax typecheck-string + (syntax-rules () + ((_ who var) + (unless (string? var) + (error "Not a string" var 'who))))) diff --git a/live/typecheck/unstable.sld b/live/typecheck/unstable.sld new file mode 100644 index 0000000..8c1628d --- /dev/null +++ b/live/typecheck/unstable.sld @@ -0,0 +1,9 @@ +(define-library (live typecheck unstable) + (export typecheck-bytevector + typecheck-string) + (import (scheme base)) + (cond-expand + (chicken + (include "live.chicken.scm")) + (else + (include "live.r7rs.scm")))) diff --git a/tests/typecheck.scm b/tests/typecheck.scm new file mode 100644 index 0000000..12253a4 --- /dev/null +++ b/tests/typecheck.scm @@ -0,0 +1,21 @@ +(import (scheme base) + (live typecheck unstable) + (live test)) + +(test-begin "live/typecheck") + +(test-group "typecheck-bytevector" + (let ((foo (bytevector))) + (test-assert (begin (typecheck-bytevector just-testing foo) + #t))) + (let ((foo 123)) + (test-error (typecheck-bytevector just-testing foo)))) + +(test-group "typecheck-string" + (let ((foo (string))) + (test-assert (begin (typecheck-string just-testing foo) + #t))) + (let ((foo 123)) + (test-error (typecheck-string just-testing foo)))) + +(test-end) From 3445a9849c8211c4da148edd9c5ce689abb45b8b Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Tue, 30 Nov 2021 08:51:39 +0200 Subject: [PATCH 20/27] Add `unstable` suffix to (live port) --- live/{port.sld => port/unstable.sld} | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) rename live/{port.sld => port/unstable.sld} (53%) diff --git a/live/port.sld b/live/port/unstable.sld similarity index 53% rename from live/port.sld rename to live/port/unstable.sld index 62ce646..78fdb69 100644 --- a/live/port.sld +++ b/live/port/unstable.sld @@ -1,4 +1,4 @@ -(define-library (live port) +(define-library (live port unstable) (export accumulate-bytevectors-from-port) (import (scheme base)) - (include "port/live.scm")) + (include "live.scm")) From 87e4a3932129a6fa3c1f8eebf6f344f97ff24b5b Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Tue, 30 Nov 2021 08:54:52 +0200 Subject: [PATCH 21/27] Add `unstable` suffix to hash libraries --- .../live.gauche.scm} | 0 .../{adler32.sld => adler32/unstable.sld} | 8 +++++--- live/hash/sha.sld | 16 ---------------- .../{sha.gauche.scm => sha/live.gauche.scm} | 0 live/hash/sha/unstable.sld | 19 +++++++++++++++++++ tests/{adler32.scm => hash-adler32.scm} | 4 +++- tests/{sha.scm => hash-sha.scm} | 4 +++- 7 files changed, 30 insertions(+), 21 deletions(-) rename live/hash/{adler32.gauche.scm => adler32/live.gauche.scm} (100%) rename live/hash/{adler32.sld => adler32/unstable.sld} (54%) delete mode 100644 live/hash/sha.sld rename live/hash/{sha.gauche.scm => sha/live.gauche.scm} (100%) create mode 100644 live/hash/sha/unstable.sld rename tests/{adler32.scm => hash-adler32.scm} (84%) rename tests/{sha.scm => hash-sha.scm} (92%) diff --git a/live/hash/adler32.gauche.scm b/live/hash/adler32/live.gauche.scm similarity index 100% rename from live/hash/adler32.gauche.scm rename to live/hash/adler32/live.gauche.scm diff --git a/live/hash/adler32.sld b/live/hash/adler32/unstable.sld similarity index 54% rename from live/hash/adler32.sld rename to live/hash/adler32/unstable.sld index 2231ecc..a5507a0 100644 --- a/live/hash/adler32.sld +++ b/live/hash/adler32/unstable.sld @@ -1,10 +1,12 @@ -(define-library (live hash adler32) +(define-library (live hash adler32 unstable) (export adler32-accumulator adler32-bytevector adler32-port) - (import (scheme base) (live port) (live typecheck)) + (import (scheme base) + (live port unstable) + (live typecheck unstable)) (cond-expand (gauche (import (rename (only (rfc zlib) adler32) (adler32 gauche-adler32))) - (include "adler32.gauche.scm")))) + (include "live.gauche.scm")))) diff --git a/live/hash/sha.sld b/live/hash/sha.sld deleted file mode 100644 index febc773..0000000 --- a/live/hash/sha.sld +++ /dev/null @@ -1,16 +0,0 @@ -(define-library (live hash sha) - (export - sha-1-accumulator - sha-1-bytevector - sha-1-port - sha-256-accumulator - sha-256-bytevector - sha-256-port - sha-512-accumulator - sha-512-bytevector - sha-512-port) - (import (scheme base) (live port)) - (cond-expand - (gauche - (import (only (gauche base) make) (util digest) (rfc sha)) - (include "sha.gauche.scm")))) diff --git a/live/hash/sha.gauche.scm b/live/hash/sha/live.gauche.scm similarity index 100% rename from live/hash/sha.gauche.scm rename to live/hash/sha/live.gauche.scm diff --git a/live/hash/sha/unstable.sld b/live/hash/sha/unstable.sld new file mode 100644 index 0000000..ecd6109 --- /dev/null +++ b/live/hash/sha/unstable.sld @@ -0,0 +1,19 @@ +(define-library (live hash sha unstable) + (export + sha-1-accumulator + sha-1-bytevector + sha-1-port + sha-256-accumulator + sha-256-bytevector + sha-256-port + sha-512-accumulator + sha-512-bytevector + sha-512-port) + (import (scheme base) + (live port unstable)) + (cond-expand + (gauche + (import (only (gauche base) make) + (util digest) + (rfc sha)) + (include "live.gauche.scm")))) diff --git a/tests/adler32.scm b/tests/hash-adler32.scm similarity index 84% rename from tests/adler32.scm rename to tests/hash-adler32.scm index d950452..962a352 100644 --- a/tests/adler32.scm +++ b/tests/hash-adler32.scm @@ -1,4 +1,6 @@ -(import (scheme base) (live hash adler32) (live test)) +(import (scheme base) + (live test) + (live hash adler32 unstable)) (test-begin "live/hash/adler32") diff --git a/tests/sha.scm b/tests/hash-sha.scm similarity index 92% rename from tests/sha.scm rename to tests/hash-sha.scm index 825aade..0981df7 100644 --- a/tests/sha.scm +++ b/tests/hash-sha.scm @@ -1,4 +1,6 @@ -(import (scheme base) (live hash sha) (live test)) +(import (scheme base) + (live test) + (live hash sha unstable)) (test-begin "live/hash/sha") From 335d25ba5caafb72a2f78ecd4b58ce82e316582d Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Mon, 29 Nov 2021 23:06:23 +0200 Subject: [PATCH 22/27] Add list Date: Tue, 30 Nov 2021 07:48:03 +0200 Subject: [PATCH 23/27] Fix bad test --- tests/list.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/list.scm b/tests/list.scm index f2ebf33..2486dd8 100644 --- a/tests/list.scm +++ b/tests/list.scm @@ -15,7 +15,7 @@ (test-eqv #t (list Date: Tue, 30 Nov 2021 07:48:21 +0200 Subject: [PATCH 24/27] Add another test --- tests/list.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/list.scm b/tests/list.scm index 2486dd8..e842c9e 100644 --- a/tests/list.scm +++ b/tests/list.scm @@ -17,6 +17,7 @@ (test-eqv #t (list Date: Tue, 30 Nov 2021 07:48:35 +0200 Subject: [PATCH 25/27] Check for dotted list --- live/list/live.scm | 4 ++-- tests/list.scm | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/live/list/live.scm b/live/list/live.scm index 8fee36f..99ef309 100644 --- a/live/list/live.scm +++ b/live/list/live.scm @@ -51,8 +51,8 @@ (if (null? xs) #f (fx- (length xs) 1))) (define (list Date: Tue, 30 Nov 2021 07:56:16 +0200 Subject: [PATCH 26/27] Add `unstable` suffix to (live vector) --- live/{vector.sld => vector/unstable.sld} | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) rename live/{vector.sld => vector/unstable.sld} (60%) diff --git a/live/vector.sld b/live/vector/unstable.sld similarity index 60% rename from live/vector.sld rename to live/vector/unstable.sld index 1a399ec..4ab04df 100644 --- a/live/vector.sld +++ b/live/vector/unstable.sld @@ -1,9 +1,9 @@ -(define-library (live vector) +(define-library (live vector unstable) (export vector-cons vector-cons-right vector-first vector-last vector-last-index) (import (scheme base) - (live fixnum)) - (include "vector/live.scm")) + (live fixnum unstable)) + (include "live.scm")) From 45328d0c29d97e7e796fcb8fa9f36c6b6767a907 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Tue, 30 Nov 2021 07:56:30 +0200 Subject: [PATCH 27/27] Add vector