Make hello-schemer the primary branch

.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

CONTRIBUTORS.txt

@@ -0,0 +1,2 @@
+Amirouche Amazigh BOUBEKKI
+Lassi Kortela

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.

live.egg

@@ -7,13 +7,69 @@
  (category misc)
  (license "MIT")
  (author "Scheme Live Crew")
- (dependencies srfi-151)
+ (dependencies r7rs openssl uri-generic srfi-13 srfi-14 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/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/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 "live/list/live.scm")
+     (component-dependencies live.fixnum.unstable)
+     (csc-options "-R" "r7rs" "-X" "r7rs"))
+   (extension
+     live.net.gemini.unstable
+     (source "live/net/gemini/unstable.sld")
+     (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 "live/net/gemini/client/live.scm")
+     (component-dependencies live.net.gemini.unstable)
+     (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 "live/string/live.scm")
+     (component-dependencies)
+     (csc-options "-R" "r7rs" "-X" "r7rs"))
+   (extension
+     live.time.iso.unstable
+     (source "live/time/iso/unstable.sld")
+     (source-dependencies)
+     (component-dependencies live.number.unstable)
      (csc-options "-R" "r7rs" "-X" "r7rs"))))

live/bitwise.sld → 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?

live/fixnum.sld → 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)))))

live/hash/adler32.sld → 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"))))

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"))))

live/list/live.scm

@@ -49,3 +49,10 @@
 
 (define (last-index xs)
   (if (null? xs) #f (fx- (length xs) 1)))
+
+(define (list<? elem<? list1 list2)
+  (cond ((null-list? list1) (not (null-list? list2)))
+        ((null-list? list2) #f)
+        ((elem<? (car list1) (car list2)) #t)
+        ((elem<? (car list2) (car list1)) #f)
+        (else (list<? elem<? (cdr list1) (cdr list2)))))

live/list/unstable.sld

@@ -15,7 +15,17 @@
    dotted-list?
    last-index
    length-tail
+   list<?
    map/odd
    proper-list?)
-  (import (scheme base) (srfi 1) (live fixnum))
-  (include "list/live.scm"))
+  (import (scheme base)
+
+          ;; TODO: Should we prefer the SRFI 1 copies of these
+          ;; procedures?
+          (except (srfi 1)
+                  circular-list?
+                  dotted-list?
+                  proper-list?)
+
+          (live fixnum unstable))
+  (include "live.scm"))

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))))))

live/net/gemini/client/unstable.sld

@@ -0,0 +1,8 @@
+(define-library (live net gemini client unstable)
+  (export gemini-get)
+  (import (scheme base)
+          (live net gemini unstable))
+  (cond-expand
+    (chicken
+     (import (chicken condition) (openssl) (uri-generic))))
+  (include "live.scm"))

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))))))))

live/net/gemini/unstable.sld

@@ -0,0 +1,37 @@
+(define-library (live net gemini unstable)
+  (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)
+             (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))))
+  (include "live.scm"))

live/number.sld → live/number/unstable.sld

@@ -1,4 +1,4 @@
-(define-library (live number)
+(define-library (live number unstable)
   (export natural?)
   (import (scheme base))
   (begin