migrate to Chicken 6

.github/workflows/build.yaml

@@ -15,11 +15,11 @@ jobs:
     - uses: actions/checkout@v3
     - name: Install chicken
       run: |
-        wget -N https://code.call-cc.org/releases/5.4.0/chicken-5.4.0.tar.gz
+        wget -N https://code.call-cc.org/releases/6.0.0/chicken-6.0.0.tar.gz
-        tar zxf chicken-5.4.0.tar.gz
+        tar zxf chicken-6.0.0.tar.gz
         sudo apt install -y make
-        make -C chicken-5.4.0 PLATFORM=linux
+        make -C chicken-6.0.0 PLATFORM=linux
-        sudo make -C chicken-5.4.0 PLATFORM=linux install
+        sudo make -C chicken-6.0.0 PLATFORM=linux install
     - name: Install dependencies
       # FIXME: [project-local deps]: use venv or something
       # run: make deps

Makefile

@@ -58,7 +58,7 @@ sextest:
 	$(MAKE) -C ./tools/sextest sextest
 	cp ./tools/sextest/sextest .
 
-SEX_TEST_PROGRAMS = hello-world lists comments
+SEX_TEST_PROGRAMS = hello-world lists comments unicode
 
 run-tests: sexc sex-tests sextest
 	./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex)

Readme.org

@@ -4,8 +4,8 @@
 #+ATTR_HTML: :width 300px
 [[sex.png][file:./sex.png]]
 
-Sex is a S-expressions language. Sex is written in Chicken, which is a
+Sex is a S-expressions language. Sex is written in Chicken, which is an
-[[https://call-cc.org][R5RS Scheme]].
+[[https://call-cc.org][R7RS Scheme]].
 Sex is statically typed, compiled general purpose language.
 
 * Compilation

dependencies.txt

@@ -1 +1 @@
-fmt getopt-long brev-separate test tree srfi-1 srfi-13 srfi-69 matchable
+fmt getopt-long brev-separate test srfi-1 srfi-13 srfi-69 matchable

fmt-c-writer.scm

@@ -2,20 +2,28 @@
 
 (import
   scheme
+  (scheme base)                         ; make-parameter
   (chicken base)
   (chicken string)
   (chicken syntax)
-  brev-separate
+  brev-separate                         ; fn, flatten
   fmt
   sex-fmt-c
   matchable
-  regex
+  (chicken irregex)                     ; unkebabify
   srfi-1                                ; lists
   srfi-13                               ; strings
-  srfi-39                               ; parameters
-  tree
   utils)
 
+;;; Map a procedure over every leaf of a tree, preserving its shape.
+;;; Was the `tree' egg, which has not been ported to CHICKEN 6. (Its
+;;; `flatten', also used here, comes from brev-separate.)
+(define (tree-map f tree)
+  (cond ((null? tree) (list))
+        ((pair? tree) (cons (tree-map f (car tree))
+                            (tree-map f (cdr tree))))
+        (else (f tree))))
+
 (define (unkebabify sym)
   (case sym
     ((-) sym)
@@ -24,8 +32,7 @@
     ((-=) sym)
     (else
      (string->symbol
-      (string-substitute "-(?!>)" "_"
+      (irregex-replace/all "-(?!>)" (symbol->string sym) "_")))))
-                         (symbol->string sym) #t)))))
 
 (define (atom-to-fmt-c atom)
   (case atom

reader.scm

@@ -12,6 +12,7 @@
 
 (import
   scheme
+  (scheme base)                         ; make-parameter
   (chicken base)
   (chicken pathname)
   utils)

sex-fmt-c.scm

@@ -33,6 +33,7 @@
 
   (import
     scheme
+    (scheme base)                       ; string->utf8, bytevector accessors
     (chicken base)
     fmt
     srfi-1
@@ -138,7 +139,31 @@
           (case n
             ((7) "\\a") ((8) "\\b") ((9) "\\t") ((10) "\\n")
             ((11) "\\v") ((12) "\\f") ((13) "\\r")
-            (else (string-append "\\x" (number->string (char->integer c) 16)))))))
+            (else (c-octal-escapes c))))))
+
+  ;; A character outside printable ASCII, as one three-digit octal escape
+  ;; per UTF-8 byte.
+  ;;
+  ;; MODIFIED FROM UPSTREAM fmt-c, which emits "\x" plus the hex of the
+  ;; character. C's \x escape consumes *every* following hex digit, so
+  ;; "\xc3\xa91" is a single out-of-range value rather than two bytes
+  ;; followed by a '1'. Under CHICKEN 6 a character is a codepoint rather
+  ;; than a byte, so the hex form additionally emits "\xe9" for a lone
+  ;; "e-acute" -- not valid UTF-8 -- and "\x65e5" for anything above the
+  ;; Latin-1 range, which does not compile at all. Octal escapes are
+  ;; capped at three digits, so they always self-terminate.
+  (define (c-octal-escapes c)
+    (let* ((bytes (string->utf8 (string c)))
+           (len (bytevector-length bytes)))
+      (let loop ((i 0) (acc '()))
+        (if (= i len)
+            (apply string-append (reverse acc))
+            (loop (+ i 1)
+                  (cons (let ((oct (number->string (bytevector-u8-ref bytes i) 8)))
+                          (string-append "\\"
+                                         (make-string (- 3 (string-length oct)) #\0)
+                                         oct))
+                        acc))))))
 
   (define (c-format-number x)
     (if (and (integer? x) (exact? x))

sexc.scm

@@ -1,4 +1,5 @@
 (import scheme
+        (scheme base)                   ; call/cc
         brev-separate
         (chicken base)
         (chicken file)
@@ -16,7 +17,6 @@
         semen
         srfi-1                          ; list routines
         srfi-13
-        tree
         utils)
 
 ;;; Main function facilities
@@ -98,19 +98,20 @@
         (out-file (if (eq? output 'default)
                       "a.out"
                       output)))
-    (call-with-values
+    ;; `process' hands back one record. Its port accessors are named
-        (lambda ()
+    ;; from the *child's* point of view, so `process-input-port' is the
-          (process compiler (append (list "-o" out-file "-x" "c")
+    ;; port we write to: the C compiler's stdin.
-                                    (if (get-arg args 'compile-object #f)
+    (let* ((proc (process compiler (append (list "-o" out-file "-x" "c")
-                                        (list "-c")
+                                           (if (get-arg args 'compile-object #f)
-                                        (list))
+                                               (list "-c")
-                                    (list "-")  ; read stdin
+                                               (list))
-                                    (get-c-compiler-args args))))
+                                           (list "-")  ; read stdin
-      (lambda (out-port in-port pid)
+                                           (get-c-compiler-args args))))
-        (with-output-to-port in-port
+           (cc-stdin (process-input-port proc)))
-          (lambda () (emit-c sex-forms)))
+      (with-output-to-port cc-stdin
-        (close-output-port in-port)
+        (lambda () (emit-c sex-forms)))
-        (process-wait pid)))))
+      (close-output-port cc-stdin)
+      (process-wait proc))))
 
 (define (semantic-process-forms raw-forms input-source)
   (if (eq? input-source 'stdin)

tests/basic.scm

@@ -13,6 +13,14 @@
   (test '_this_->_member_ (unkebabify '-this-->-member-))
   (test '__->>> (unkebabify '--->>>))
 
+  ;; Non-ASCII identifiers must survive intact. The `regex' egg's
+  ;; string-substitute drops one trailing character per multi-byte
+  ;; character, which renames things silently -- the C still compiles,
+  ;; just under a different name than was written.
+  (test 'naïve_count (unkebabify 'naïve-count))
+  (test 'aï_b (unkebabify 'aï-b))
+  (test 'ïï (unkebabify 'ïï))
+
   ;; atom-to-fmt-c
   (test '%fun (atom-to-fmt-c 'fn))
   (test '%prototype (atom-to-fmt-c 'prototype))

tests/sex-programs/unicode.sex

@@ -0,0 +1,24 @@
+(input)
+(output "café 日本語 🍺" "café1" "naïve: 3")
+(return 0)
+
+;;; Non-ASCII string literals and identifiers.
+;;;
+;;; Two things are pinned here. First, a character outside printable
+;;; ASCII must reach the C compiler as the UTF-8 bytes it was written
+;;; as. Octal escapes are used because C's \x escape swallows every
+;;; following hex digit: "café1" is the case that catches it, since a
+;;; hex escape would run "\xc3\xa9" into the "1" and produce a value out
+;;; of range for a char. Second, a kebab-case identifier containing
+;;; non-ASCII characters must survive unkebabify intact -- getting this
+;;; wrong truncates the name silently, and the program still compiles
+;;; and runs, just under a different name than the one written.
+
+(include stdio.h)
+
+(pub fn main () int
+  (puts "café 日本語 🍺")
+  (puts "café1")
+  (var naïve-count int 3)
+  (printf "naïve: %d\n" naïve-count)
+  (return 0))

tools/sextest/sextest.scm

@@ -38,27 +38,25 @@
                    (get-environment-variable "SEXC")
                    "sexc"))
         (compiled-file (create-temporary-file)))
-    (call-with-values
+    ;; `process' returns one record; `process-input-port' is named from
-        (fn
+    ;; the child's side, so it is the port we write to.
-         (process compiler
+    (let* ((proc (process compiler (append (list "-o" compiled-file) flags)))
-                  (append (list "-o" compiled-file)
+           (sexc-stdin (process-input-port proc)))
-                          flags)))
+      (with-output-to-port sexc-stdin
-      (lambda (out-port in-port pid)
+        (fn (map (fn (fmt #t x)) src)))
-        (with-output-to-port in-port
+      (close-output-port sexc-stdin)
-          (fn (map (fn (fmt #t x)) src)))
+      (call-with-values
-        (close-output-port in-port)
+          (fn (process-wait proc))
-
+        (lambda (pid exited retcode)
-        (call-with-values
+          (if (= 0 retcode)
-            (fn (process-wait pid))
+              compiled-file
-          (lambda (pid exited retcode)
+              #f))))))
-            (if (= 0 retcode)
-                compiled-file
-                #f)))))))
 
 (define (run-and-check file in out ret)
-  (call-with-values
+  (let* ((proc (process file))
-      (fn (process file))
+         (out-port (process-output-port proc))   ; the program's stdout
-    (lambda (out-port in-port pid)
+         (in-port  (process-input-port proc)))   ; the program's stdin
+    (let ()
       (when in
         (with-output-to-port in-port
           (fn (map (fn (fmt #t x))
@@ -78,7 +76,7 @@
                  ;; TODO: what if the program hangs
                  ;; we need some kind of timeout mechanism
                  (fn
-                  (process-wait pid))
+                  (process-wait proc))
                (lambda (pid exited retcode)
                  retcode))))
         (and
@@ -137,7 +135,7 @@
       (print-help)
       (exit 1))
     (unless
-        (foldl and
+        (foldl (lambda (a b) (and a b))
                #t
                (map (fn (process-test-file (assoc 'sexc args) x))
                     (cdr (assoc '@ args))))