sex-mode inherits scheme mode

uh oh

Makefile

@@ -1,4 +1,19 @@
 CHICKEN_C = csc
 
-sexc: sexc.scm
-	$(CHICKEN_C) $< -o $@
+MODULES = sexc templates main
+OBJ = $(MODULES:%=%.o)
+
+# chicken flags
+CFLAGS = -compile-syntax
+
+sexc: $(OBJ)
+	$(CHICKEN_C) $^ -o $@
+
+main.o: main.scm
+	$(CHICKEN_C) $< -c -o $@
+
+%.o: %.scm
+	$(CHICKEN_C) $< -e -c -o $@ $(CFLAGS)
+
+clean:
+	rm -f $(OBJ) sexc

Readme.org

@@ -1,9 +1,20 @@
 * The Sex language
 Sex is a S-expressions language, which transpiles to C.
 
+Sex is also Chicken, since all source processing and compile-time
+computations are written in Chicken.
+
+And Chicken is [[https://call-cc.org][R5RS Scheme]].
+
 * Compilation and usage
-Sex is written in Chicken Scheme, so first you'll need to get yourself
-a Chicken.
+First, get yourself a Chicken. Second, some Chicken deps.
+
+** Install Chicken Eggs
+By the way, there's a way to make Chicken install eggs non-globally. Refer to
+the documentation for more info:
+https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
+
+~chicken-install fmt getopt-long brev-separate~
 
 ** Compilation
 ~make~
@@ -15,14 +26,56 @@ cat hello-world.sex | sexc > hello_world.c
 cc hello_world.c -o hello_world
 #+end_src
 
+* Example
+Here is an example, demonstrating what Sex source looks like, and what
+it compiles too. An avid reader also shall notice how we call Chicken
+procedures in Sex source.
+
+The Sex source:
+#+begin_src
+(include stdio.h)
+
+(define (foo)
+  "Hello from Chicken code!\n")
+
+(pub fn int main ((int argc) (char **argv))
+    (puts "Hello from Sex!")
+    (var (array char 512) name)
+    (puts "What is your name?")
+    (scanf "%s" &name)
+    (printf "Hello, %s!\n" name)
+    (printf ,(foo))
+    0)
+#+end_src
+
+The resulting C source:
+#+begin_src
+#include <stdio.h>
+
+int main (int argc, char **argv) {
+    puts("Hello from Sex!");
+    char name[512];
+    puts("What is your name?");
+    scanf("%s", &name);
+    printf("Hello, %s!\n", name);
+    printf("Hello from Chicken code!\n");
+    return 0;
+}
+#+end_src
+
 * Features
 ** Full C interoperability
 Just ~(include "Your/Favourite/Library.h")~ and use it as you would
-have is C. For hardcore fans of traditional Lisp naming convention,
+have is C.
+
+For hardcore fans of traditional Lisp naming convention,
 Sex offers automatic unkebabification of all symbols, i.e. no more
-ugly ~GL_ARRAY_BUFFER~'s in your code, they may be writted in their
+ugly ~GL_ARRAY_BUFFER~ s in your code, they may be written in their
 proper form: ~GL-ARRAY-BUFFER~.
 
+** Auto typedef for structs
+Probably harmless idk.
+
 ** Use an established environment for development
 As Sex is S-expressions, you always have Emacs with paredit as your
 best option.

hello-world.sex

@@ -1,10 +1,18 @@
 (include stdio.h)
-(include unistd.h)
 
-(fn int main ((int argc) (char **argv))
+(define (foo)
+  "Hello from Chicken code!\n")
+
+(struct foo
+  ((int a)
+   (float b)))
+
+(pub fn int main ((int argc) (char **argv))
+    (var int a 10)
     (puts "Hello from Sex!")
-    (var (array char 513) name)
+    (var (array char 512) name)
     (puts "What is your name?")
     (scanf "%s" &name)
     (printf "Hello, %s!\n" name)
+    (printf ,(foo))
     0)

lib/list.hsex

@@ -0,0 +1,36 @@
+(template (list-T (T))
+  (struct list-T
+    ((T value)
+     ((* list-T) next))))
+
+(template (make-list-T (T) is-public?)
+  (,@(if is-public? '(pub) '()) fn (* list-T) make-list-T ()
+   (var (* list-T) list (cast (* list-T) (malloc (sizeof list-T))))
+    (= (-> list next) NULL)
+    list))
+
+(template (add-value-list-T (T) is-public?)
+  (,@(if is-public? '(pub) '()) fn void add-value-list-T ((list-T *list) (T value))
+       (while (!= (-> list next) NULL)
+         (= list (-> list next)))
+       (= (-> list next) (make-list-T))
+       (= (-> list value) value)))
+
+(template (length-list-T (T) is-public?)
+  (,@(if is-public? '(pub) '()) fn size-t length-list-T ((list-T *list))
+   (var size-t n 0)
+   (while (!= (-> list next) NULL)
+     (= list (-> list next))
+     (++ n))
+   n))
+
+(template (is-empty-list-T (T) is-public?)
+  (,@(if is-public? '(pub) '()) fn bool is-empty-list-T ((list-T *list))
+    (== (-> list next) NULL)))
+
+(template (list-for-each (what-do list-var elt-var))
+  (var int elt-var (-> list-var value))
+  (while (!= (-> list-var next) NULL)
+    what-do
+    (= list-var (-> list-var next))
+    (= elt-var (-> list-var value))))

lib/test-list.sex

@@ -0,0 +1,28 @@
+(include stdlib.h)
+(include stddef.h)
+(include stdbool.h)
+(include stdio.h)
+
+(load "list.hsex")
+
+(struct foo
+  ((float a)
+   (int b)))
+
+,(list-T '(int))
+,(make-list-T '(int) #f)
+,(add-value-list-T '(int) #f)
+,(length-list-T '(int) #f)
+,(is-empty-list-T '(int) #f)
+
+(fn bool bar () false)
+
+(pub fn int main ()
+     (var (* list-int) l (make-list-int))
+     (printf "Size of the list: %zu\n" (length-list-int l))
+     (add-value-list-int l 3)
+     (add-value-list-int l 4)
+     (printf "Size of the list: %zu\n" (length-list-int l))
+     ,(list-for-each '((printf "%d " v) l v))
+     (printf "\n")
+     0)

main.scm

@@ -0,0 +1,6 @@
+;;; The purpose of this file is to compile it to the only
+;;; .o that has main entry point.
+
+(declare (uses sexc))
+
+(main)

sex-mode.el

@@ -0,0 +1,91 @@
+(require 'scheme)
+
+(defgroup sex-mode nil
+  "Major mode for Sex code."
+  :prefix 'sex-
+  :group 'languages)
+
+(define-abbrev-table 'sex-mode-abbrev-table ()
+  "Abbrev table for Sex mode.
+It has `scheme-mode-abbrev-table' as its parent."
+  :parents (list scheme-mode-abbrev-table))
+
+(defvar sex-mode-syntax-table
+  (let ((table (make-syntax-table lisp-data-mode-syntax-table)))
+    table))
+
+(defvar sex-mode-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map lisp-mode-shared-map)
+    map)
+  "Keymap for Sex mode.
+All commands in `lisp-mode-shared-map' are inherited by this map.")
+
+(defvar sex-mode-line-process "")
+
+(defconst sex-font-lock-keywords
+  (eval-when-compile
+    (list
+     ;; Declarations
+     (list (concat "("
+                   (regexp-opt '("include"
+                                 "fn"
+                                 "pub"
+                                 "struct"
+                                 "template"
+                                 "var")
+                               'word)
+                   "\\>"
+                   "[[:space:]]*"
+                   "\\([[:word:]]*\\)")
+           '(1 font-lock-keyword-face)
+           '(2 font-lock-function-name-face))
+     ;; Keywords
+     (list (concat "("
+                   (regexp-opt '(
+                                 "case"
+                                 "do"
+                                 "if"
+                                 "for"
+                                 "goto"
+                                 "return"
+                                 "switch"
+                                 "var"
+                                 "while")
+                               'word)
+                   "\\>")
+           '(1 'font-lock-builtin-face)))))
+
+(defun sex-mode-set-variables ()
+  (set-syntax-table sex-mode-syntax-table)
+  (setq local-abbrev-table sex-mode-abbrev-table)
+  (setq mode-line-process '("" sex-mode-line-process))
+  (setq font-lock-defaults
+        '((sex-font-lock-keywords)
+          nil nil
+          (("+-*/.<>=!?$%_&:" . "w"))
+          nil
+          (font-lock-mark-block-function . mark-defun)))
+  (setq-local prettify-symbols-alist lisp-prettify-symbols-alist))
+
+(put 'fn 'lisp-indent-function 'defun)
+(put 'template 'lisp-indent-function 'defun)
+(put 'struct 'lisp-indent-function 'defun)
+(put 'var 'lisp-indent-function 0)
+
+;;;###autoload
+(define-derived-mode sex-mode lisp-data-mode "Sex"
+  "Major mode for editing Sex code.
+Editing commands are similar to those of `lisp-mode'.
+
+Commands:
+Delete converts tabs to spaces as it moves back.
+Blank lines separate paragraphs.  Semicolons start comments.
+\\{sex-mode-map}"
+  :group 'sex-mode
+  (sex-mode-set-variables))
+
+;;;###autoload
+(add-to-list 'auto-mode-alist '("\\.\\(sex\\|hsex\\)\\'" . sex-mode))
+
+(provide 'sex-mode)

sexc.scm

@@ -1,33 +1,183 @@
-(import brev-separate fmt fmt-c tree (chicken string))
+(declare (unit sexc)
+         (uses templates))
+
+(import brev-separate
+        (chicken pathname)
+        (chicken pretty-print)
+        (chicken process-context)
+        (chicken string)
+        fmt
+        fmt-c
+        getopt-long
+        srfi-1                          ; list routines
+        tree)
+
+(define +debug+ #f)
 
 (define (unkebabify sym)
+  (case sym
+    ((-) sym)
+    ((--) sym)
+    ((->) sym)
+    ((-=) sym)
+    (else
      (string->symbol
-   (string-translate (symbol->string sym) #\- #\_)))
+      (string-translate (symbol->string sym) #\- #\_)))))
 
-(define (loop)
-  (let ((r (read)))
-    (unless (eof-object? r)
-      (cond ((eqv? (car r) 'define) (eval r))
-            (#t
-             (fmt #t
-                  (c-expr
-                   (tree-map
-                    (fn
-	             (case x
+(define (atom-to-fmt-c atom)
+  (case atom
     ((fn) '%fun)
     ((var) '%var)
     ((begin) '%begin)
     ((pointer) '%pointer)
     ((array) '%array)
-                       (([]) 'vector-ref)
+    ((@) 'vector-ref)
     ((include) '%include)
     ((cast) '%cast)
     (else
-                        (if (symbol? x)
-                            (unkebabify x)
-                            x))))
-                    r)))
-             (fmt #t "\n")))
-      (loop))))
+     (if (symbol? atom)
+         (unkebabify atom)
+         atom))))
 
-(loop)
+(define (tree-finder symbol)
+  (lambda (node)
+    (or (and (tree? node)
+             (eq? (car node) symbol))
+        #f)))
+
+(define (walk-generic form acc)
+  (if (eq? (car form) 'unquote)
+      ;; special case - replace top-level unquote with it's expansion
+      (append
+       (fold append (list)
+             (map (fn (walk-sex-tree x (list)))
+                  (eval (cadr form))))
+       acc)
+      (let loop ((unquote-form (tree-find (tree-finder 'unquote) form #f)))
+        (if unquote-form
+            (begin
+              (let* ((inv (invert-tree form))
+                     (pos (tree-local-position inv unquote-form)))
+                (for-each (fn
+                           (set! form (tree-insert inv (tree-parent inv unquote-form) pos x))
+                           (set! inv (invert-tree form)))
+                          (reverse (eval (cadr unquote-form))))
+                (set! form (tree-prune inv unquote-form)))
+              (loop (tree-find (tree-finder 'unquote)
+                               form
+                               #f)))
+            (cons (tree-map atom-to-fmt-c form) acc)))))
+
+(define (walk-function form static acc)
+  (if static
+      (walk-generic (list 'static form) acc)
+      (walk-generic (cdr form) acc)))
+
+(define (walk-struct form acc)
+  (let ((name (unkebabify (cadr form))))
+    (walk-generic form (cons `(typedef struct ,name ,name) acc))))
+
+(define (walk-sex-tree form acc)
+  (case (car form)
+    ((fn) (walk-function form #t acc))
+    ((pub) (walk-function form #f acc))
+    ((struct) (walk-struct form acc))
+    (else (walk-generic form acc))))
+
+(define (process-form form acc)
+  (case (car form)
+    ((define) (eval form) acc)
+    ((template) (eval form) acc)
+    ((load) (eval form) acc)
+    ((instance) (walk-sex-tree (eval form) acc))
+    (else
+     (walk-sex-tree form acc))))
+
+(define (process-raw-forms raw-forms acc)
+  (if (null? raw-forms) (filter (fn (not (null? x)))
+                                (reverse acc))
+      (process-raw-forms (cdr raw-forms)
+                         (process-form (car raw-forms) acc))))
+
+(define (read-forms acc)
+  (let ((r (read)))
+    (if (eof-object? r) (reverse acc)
+        (read-forms (cons r acc)))))
+
+(define (emit-c forms)
+  (for-each (lambda (form)
+              (fmt #t (c-expr form))
+              (fmt #t "\n"))
+            forms))
+
+;;; Main function facilities
+
+(define opts-grammar
+  `((output "Write output to file"
+            (required #f)
+            (value #t)
+            (single-char #\o))
+    (help "Show this help"
+          (required #f)
+          (value #f)
+          (single-char #\h))
+    (macro-expand "Emit macro-expanded Sex code instead of C"
+                  (required #f)
+                  (value #f)
+                  (single-char #\m))))
+
+(define (print-help)
+  (fmt #t "Usage: sexc [OPTIONS] [FILE]\n")
+  (fmt #t "Options: -o, --output <file>        Write output to file. If omitted, write to stdout\n")
+  (fmt #t "         -h, --help                 Show this help\n")
+  (fmt #t "         -m, --macro-expand         Emit macro-expanded Sex code instead of C\n"))
+
+(define (help-arg? args)
+  (assoc 'help args))
+
+(define (get-arg args arg-name default)
+  (let ((arg (assoc arg-name args)))
+    (if arg (cdr arg)
+        default)))
+
+(define (get-input-file args)
+  (let ((rest-args (assoc '@ args)))
+    (if (= 1 (length rest-args))
+        'stdin
+        (cadr rest-args))))
+
+(define (read-from-file file)
+  (with-input-from-file (pathname-strip-directory file)
+    (fn (read-forms (list)))))
+
+(define (set-working-directory file)
+  (change-directory
+   (normalize-pathname
+    (make-absolute-pathname
+     (current-directory)
+     (pathname-directory file)))))
+
+(define (main)
+  (let* ((raw-args (command-line-arguments))
+         (current-dir (current-directory))
+         (args (getopt-long raw-args
+                            opts-grammar))
+         (output (get-arg args 'output 'stdout))
+         (help (help-arg? args))
+         (input (get-input-file args)))
+    (if help (print-help)
+        (let* ((raw-forms
+                (if (eq? input 'stdin)
+                    (read-forms (list))
+                    (begin
+                      (set-working-directory input)
+                      (read-from-file input))))
+               (sex-forms (process-raw-forms raw-forms (list))))
+          (change-directory current-dir)
+          (if (get-arg args 'macro-expand #f)
+              (map pp sex-forms)
+              (if (not (eq? output 'stdout))
+                  (with-output-to-file output
+                    (lambda ()
+                      (emit-c sex-forms)))
+                  (emit-c sex-forms)))))))

templates.scm

@@ -0,0 +1,56 @@
+(declare (unit templates))
+
+(import brev-separate
+        fmt
+        regex
+        srfi-1                          ; list routines
+        tree)
+
+
+(define-syntax template
+  (syntax-rules ()
+    ((_ (name subst-list args ...) body ...)
+     (define (name subst-list-arg args ...)
+       (let* ((subst-alist (map cons 'subst-list subst-list-arg))
+              (replaced-body (apply-substitution `(body ...) subst-alist)))
+         replaced-body)))))
+
+(define (apply-symbol-substitution sym subst-alist)
+  ;; All non-symbol substitutions will be filtered.
+  ;; E.g. if the subst-alist is ((T + 1 2) (U . w) (W . e)),
+  ;; only ((U . w) (W . e)) will be applied to symbols.
+  (let ((str (symbol->string sym))
+        (subst-map (map (fn
+                         (if (symbol? (car x))
+                             (cons
+                              (fmt #f "([^\\-]?)" (symbol->string (car x)) "([\\-$]?)")
+                              (fmt #f "\\1" (symbol->string (cdr x)) "\\2"))
+                             x))
+                        (filter (fn (not (list? (cdr x)))) subst-alist))))
+    (string->symbol
+     (string-substitute* str subst-map))))
+
+(define (maybe-replace-symbol sym subst-alist)
+  (call/cc
+   (lambda (return)
+     (for-each (fn (when (eq? (car x) sym)
+                     (return (cdr x))))
+               subst-alist)
+     (return sym))))
+
+(define (apply-substitution target subst-alist)
+  ;; Subsitute free symbols and -/$/^ separated parts
+  ;; of symbols with provided forms.
+  ;; E.g. with substitution (T int):
+  ;; list-T -> list-int ; by apply-symbol-substitution
+  ;; (var T data) -> (var int data) ; by maybe-replace-symbol
+  ;; see respective functions for further details.
+  (tree-map
+   (fn
+    (if (symbol? x)
+        (let ((st (maybe-replace-symbol x subst-alist)))
+          (if (eq? st x)
+              (apply-symbol-substitution x subst-alist)
+              st))
+        x))
+   target))