From e751ce2cb97e372a78fe20edccf81112fafd7bd9 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Mon, 14 Sep 2026 15:50:22 +0300 Subject: [PATCH 01/14] add sdl3 triangle example --- example/sdl3-triangle.sex | 246 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 246 insertions(+) create mode 100644 example/sdl3-triangle.sex diff --git a/example/sdl3-triangle.sex b/example/sdl3-triangle.sex new file mode 100644 index 0000000..cae2b68 --- /dev/null +++ b/example/sdl3-triangle.sex @@ -0,0 +1,246 @@ +;;; A triangle that follows the mouse pointer, spins while the left +;;; mouse button is held down, and quits on Escape (or on closing the +;;; window). +;;; +;;; SDL3 supplies the window, the GL context and the events. Everything +;;; drawn goes through an OpenGL 3.3 core-profile pipeline: a vertex and +;;; fragment shader, and one VAO/VBO holding a unit triangle. Where the +;;; triangle is and how far it has spun are passed in as uniforms, so +;;; the geometry itself is uploaded once and never touched again. +;;; +;;; Build: +;;; ./sexc example/sdl3-triangle.sex -o sdl3-triangle -- `pkg-config --cflags --libs sdl3` -framework OpenGL + +(define GL-SILENCE-DEPRECATION 1) ; OpenGL is deprecated on macOS + +(include SDL3/SDL.h) +(include OpenGL/gl3.h) + +(define WINDOW-WIDTH 800) +(define WINDOW-HEIGHT 600) + +(define TRIANGLE-RADIUS 70.0) ; in window units +(define SPIN-SPEED 3.0) ; radians per second + +;;; The vertex shader does the whole transform: spin the unit triangle +;;; by u_angle, scale it to u_radius, move it to u_center, then convert +;;; from window coordinates to clip space. That way a frame only has to +;;; push four uniforms rather than rebuild any geometry. +(var vertex-shader-src (* const char) " +#version 330 core + +layout (location = 0) in vec2 a_pos; +layout (location = 1) in vec3 a_color; + +uniform vec2 u_center; // triangle centre, in window units +uniform vec2 u_viewport; // window size, same units as u_center +uniform float u_angle; // current spin, in radians +uniform float u_radius; // triangle size, in window units + +out vec3 v_color; + +void main() +{ + float s = sin(u_angle); + float c = cos(u_angle); + vec2 spun = vec2(a_pos.x * c - a_pos.y * s, + a_pos.x * s + a_pos.y * c); + vec2 p = spun * u_radius + u_center; + + // Window coordinates have their origin top-left with y growing + // downwards; clip space is centred with y growing upwards. + gl_Position = vec4(p.x / u_viewport.x * 2.0 - 1.0, + 1.0 - p.y / u_viewport.y * 2.0, + 0.0, + 1.0); + v_color = a_color; +} +") + +(var fragment-shader-src (* const char) " +#version 330 core + +in vec3 v_color; +out vec4 frag_color; + +void main() +{ + frag_color = vec4(v_color, 1.0); +} +") + +(fn compile-shader ((kind GLenum) (src (* const char))) GLuint + (var shader GLuint (glCreateShader kind)) + (glShaderSource shader 1 (& src) NULL) + (glCompileShader shader) + + (var ok GLint 0) + (glGetShaderiv shader GL-COMPILE-STATUS (& ok)) + (if (== ok 0) + (do + (var info [char 1024]) + (glGetShaderInfoLog shader 1024 NULL info) + (SDL-Log "shader compilation failed: %s" info) + (glDeleteShader shader) + (return 0))) + (return shader)) + +(fn make-program () GLuint + (var vertex-shader GLuint (compile-shader GL-VERTEX-SHADER vertex-shader-src)) + (var fragment-shader GLuint (compile-shader GL-FRAGMENT-SHADER fragment-shader-src)) + (if (c-or (== vertex-shader 0) (== fragment-shader 0)) + (do + (glDeleteShader vertex-shader) + (glDeleteShader fragment-shader) + (return 0))) + + (var program GLuint (glCreateProgram)) + (glAttachShader program vertex-shader) + (glAttachShader program fragment-shader) + (glLinkProgram program) + + ;; The shaders are only needed until the program is linked; the + ;; program holds its own reference until then. + (glDeleteShader vertex-shader) + (glDeleteShader fragment-shader) + + (var ok GLint 0) + (glGetProgramiv program GL-LINK-STATUS (& ok)) + (if (== ok 0) + (do + (var info [char 1024]) + (glGetProgramInfoLog program 1024 NULL info) + (SDL-Log "program linking failed: %s" info) + (glDeleteProgram program) + (return 0))) + (return program)) + +(pub fn main () int + (if (! (SDL-Init SDL-INIT-VIDEO)) + (do + (SDL-Log "SDL_Init failed: %s" (SDL-GetError)) + (return 1))) + + ;; Ask for core profile 3.3 before the window exists: these attributes + ;; are read when the context is created. + (SDL-GL-SetAttribute SDL-GL-CONTEXT-MAJOR-VERSION 3) + (SDL-GL-SetAttribute SDL-GL-CONTEXT-MINOR-VERSION 3) + (SDL-GL-SetAttribute SDL-GL-CONTEXT-PROFILE-MASK SDL-GL-CONTEXT-PROFILE-CORE) + (SDL-GL-SetAttribute SDL-GL-DOUBLEBUFFER 1) + + (var window (* SDL-Window) + (SDL-CreateWindow "Sex + SDL3 + OpenGL" + WINDOW-WIDTH WINDOW-HEIGHT + SDL-WINDOW-OPENGL)) + (if (== window NULL) + (do + (SDL-Log "SDL_CreateWindow failed: %s" (SDL-GetError)) + (SDL-Quit) + (return 1))) + + (var gl-context SDL-GLContext (SDL-GL-CreateContext window)) + (if (== gl-context NULL) + (do + (SDL-Log "SDL_GL_CreateContext failed: %s" (SDL-GetError)) + (SDL-DestroyWindow window) + (SDL-Quit) + (return 1))) + + (SDL-GL-MakeCurrent window gl-context) + (SDL-GL-SetSwapInterval 1) + + (var program GLuint (make-program)) + (if (== program 0) + (do + (SDL-GL-DestroyContext gl-context) + (SDL-DestroyWindow window) + (SDL-Quit) + (return 1))) + + ;; A unit triangle, two position components then three colour + ;; components per vertex. The vertices sit on the unit circle at 90, + ;; 210 and 330 degrees; the shader spins, scales and moves it. + (var verts [GLfloat 15] + #( 0.000 1.000 1.00 0.35 0.35 + -0.866 -0.500 0.35 1.00 0.45 + 0.866 -0.500 0.40 0.50 1.00)) + + (var vao GLuint 0) + (var vbo GLuint 0) + (glGenVertexArrays 1 (& vao)) + (glBindVertexArray vao) + (glGenBuffers 1 (& vbo)) + (glBindBuffer GL-ARRAY-BUFFER vbo) + (glBufferData GL-ARRAY-BUFFER (sizeof verts) verts GL-STATIC-DRAW) + + (var stride GLsizei (cast (* 5 (sizeof GLfloat)) GLsizei)) + (glVertexAttribPointer 0 2 GL-FLOAT GL-FALSE stride (cast 0 (* void))) + (glEnableVertexAttribArray 0) + (glVertexAttribPointer 1 3 GL-FLOAT GL-FALSE stride + (cast (* 2 (sizeof GLfloat)) (* void))) + (glEnableVertexAttribArray 1) + + (var u-center GLint (glGetUniformLocation program "u_center")) + (var u-viewport GLint (glGetUniformLocation program "u_viewport")) + (var u-angle GLint (glGetUniformLocation program "u_angle")) + (var u-radius GLint (glGetUniformLocation program "u_radius")) + + (var running bool true) + (var angle float 0.0) + (var last-ticks Uint64 (SDL-GetTicks)) + (var event SDL-Event) + + (while running + (while (SDL-PollEvent (& event)) + (switch (. event type) + (case SDL-EVENT-QUIT + (= running false)) + (case SDL-EVENT-KEY-DOWN + (if (== (. event key key) SDLK-ESCAPE) + (= running false))))) + + ;; Seconds since the previous frame, so the spin rate does not + ;; depend on how fast we happen to be rendering. + (var now Uint64 (SDL-GetTicks)) + (var dt float (/ (cast (- now last-ticks) float) 1000.0)) + (= last-ticks now) + + (var mouse-x float 0.0) + (var mouse-y float 0.0) + (var buttons SDL-MouseButtonFlags (SDL-GetMouseState (& mouse-x) (& mouse-y))) + (if (!= 0 (& buttons SDL-BUTTON-LMASK)) + (= angle (+ angle (* SPIN-SPEED dt)))) + + ;; The viewport is in pixels, which is not the same as window units + ;; on a HiDPI display; the mouse position is in window units, so the + ;; shader needs that size rather than the pixel one. + (var pixel-width int 0) + (var pixel-height int 0) + (SDL-GetWindowSizeInPixels window (& pixel-width) (& pixel-height)) + (glViewport 0 0 pixel-width pixel-height) + + (var window-width int 0) + (var window-height int 0) + (SDL-GetWindowSize window (& window-width) (& window-height)) + + (glClearColor 0.06 0.06 0.09 1.0) + (glClear GL-COLOR-BUFFER-BIT) + + (glUseProgram program) + (glUniform2f u-center mouse-x mouse-y) + (glUniform2f u-viewport (cast window-width float) (cast window-height float)) + (glUniform1f u-angle angle) + (glUniform1f u-radius TRIANGLE-RADIUS) + + (glBindVertexArray vao) + (glDrawArrays GL-TRIANGLES 0 3) + + (SDL-GL-SwapWindow window)) + + (glDeleteVertexArrays 1 (& vao)) + (glDeleteBuffers 1 (& vbo)) + (glDeleteProgram program) + (SDL-GL-DestroyContext gl-context) + (SDL-DestroyWindow window) + (SDL-Quit) + (return 0)) -- 2.52.0 From 28ad33ca38cd03e86c96c48038869c083a7c0c94 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Mon, 14 Sep 2026 18:16:04 +0300 Subject: [PATCH 02/14] add sex-error reporting --- Readme.org | 6 +++++ fmt-c-writer.scm | 10 ++++---- semen.scm | 4 ++-- sex-modules.scm | 2 +- tests/codegen.scm | 43 ++++++++++++++++++++++++++++++++-- tools/sextest/utils.module.scm | 2 ++ utils.module.scm | 2 ++ utils.scm | 15 ++++++++++++ 8 files changed, 74 insertions(+), 10 deletions(-) diff --git a/Readme.org b/Readme.org index ada2d65..b3db3fb 100644 --- a/Readme.org +++ b/Readme.org @@ -145,6 +145,12 @@ return Sex code. ...) #+end_src +** Compile-time type information +Sex has a number of type reflection features, aiming to help with +macro writing. During the compilation, all type info is collected, and +is accessible during macro expansion. This allows us to write things +like providing auto serialization, adding meta information, and so on. + ** Use an established environment for development As Sex is S-expressions, you always have Emacs with paredit as your best option. diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index 6733687..02b13ec 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -175,7 +175,7 @@ forms, and what remains." (define (walk-generic-toplevel form) (cond ((atom? form) (atom-to-fmt-c form)) ((list? form) (map walk-generic-toplevel form)) - (else (error "Malformed form " form)))) + (else (sex-error form "malformed form" form)))) (define (walk-expr form) (match form @@ -281,7 +281,7 @@ forms, and what remains." (('fn arglist ret-type) `(%fun ,(walk-type ret-type) ,(walk-arglist arglist))) (('fn . _) - (assert #f "Malformed function type form")) + (sex-error form "malformed function type" form)) ;; Special case: nested structs/unions ((or ('struct . _) @@ -363,7 +363,7 @@ forms, and what remains." `(,type ,(atom-to-fmt-c name) ,(process-struct-fields fields) . ,(tree-map atom-to-fmt-c attrs))) - (else (error "Malformed aggregate definition " form)))) + (else (sex-error form "malformed aggregate definition" form)))) (define (walk-enum form) (match form @@ -379,7 +379,7 @@ forms, and what remains." (list 'extern (walk-function form))) (('var . _) (list 'extern (walk-var form))) - (else (error "Extern what?")))) + (else (sex-error form "extern must be followed by fn or var" form)))) (define (walk-public form) (match form @@ -400,7 +400,7 @@ forms, and what remains." ;; ignore here, used in generating public interface (process-toplevel-form form)) (else - (error "Pub what?" (cadr form))))) + (sex-error form "pub must be followed by a definition" form)))) (define (process-toplevel-form form) (match form diff --git a/semen.scm b/semen.scm index 6bdfcc4..64f16e9 100644 --- a/semen.scm +++ b/semen.scm @@ -85,7 +85,7 @@ ('pub 'typedef new-type target)) (process-typedef sex-form new-type target acc)) - (else (assert #f (fmt #f "Unknown top level form " sex-form))))) + (else (sex-error sex-form "unknown top level form" sex-form)))) (define (process-imports module-public-forms acc) ;; Recursively process imports: register public macros, cons all @@ -204,7 +204,7 @@ ;; we'll need them for TODO: closures support (process-fn (copy-form-source! form `(fn ,ret-type ,name ,arglist ,@body)) (list))) - (else (assert #f (fmt #f "Malformed lambda " form))))) + (else (sex-error form "malformed lambda" form)))) ;;; Structs diff --git a/sex-modules.scm b/sex-modules.scm index 5025629..c2a9d61 100644 --- a/sex-modules.scm +++ b/sex-modules.scm @@ -74,7 +74,7 @@ (cons (copy-form-source! form (take (cdr form) 4)) acc)) ((define defmacro import include struct typedef union var) (cons (copy-form-source! form (cdr form)) acc)) - (else (error "Pub what? " (cadr form))))) + (else (sex-error form "pub must be followed by a definition" form)))) (else acc))) (define (load-persistent-module-paths) diff --git a/tests/codegen.scm b/tests/codegen.scm index e278d3a..6d4a0f9 100644 --- a/tests/codegen.scm +++ b/tests/codegen.scm @@ -6,7 +6,8 @@ ;;; the existing suite, because both need an operand shape that no ;;; earlier test program happened to use. -(import (chicken port) +(import (chicken condition) + (chicken port) (chicken string) srfi-13 fmt-c-writer @@ -28,6 +29,22 @@ (define (emits? source fragment) (and (string-contains (sex->c source) fragment) #t)) +(define (error-message source) + "Compile SOURCE and return the error text as the user sees it -- +message plus arguments, the way CHICKEN prints it -- or #f if SOURCE +compiles." + (handle-exceptions e + (with-output-to-string + (lambda () + (display ((condition-property-accessor 'exn 'message) e)) + (for-each (lambda (a) (display " ") (write a)) + ((condition-property-accessor 'exn 'arguments) e)))) + (begin (sex->c source) #f))) + +(define (reports? source fragment) + (let ((m (error-message source))) + (and m (string-contains m fragment) #t))) + (define (in-fn body) (string-append "(fn f ((a int) (b int)) void " body ")")) @@ -153,4 +170,26 @@ (test-assert "c-or is still accepted" (emits? (in-fn "(var x int (c-or a b))") "a || b")) (test-assert "c-bit-or is still accepted" - (emits? (in-fn "(var x int (c-bit-or a b))") "a | b")))) + (emits? (in-fn "(var x int (c-bit-or a b))") "a | b"))) + ;; Diagnostics name also the place. Every form carries a (file + ;; . line), so an error can cite it + (test-group "errors cite the source location" + (test-assert "unknown toplevel form" + (reports? "(include stdio.h)\n(wat 1 2)" "codegen.sex:2: unknown top level form")) + (test-assert "the offending form is shown too" + (reports? "(include stdio.h)\n(wat 1 2)" "(wat 1 2)")) + (test-assert "pub with nothing to define" + (reports? "(pub 1)" "codegen.sex:1:"))) + + ;; A nested pointer chain used to silently lose a level: + ;; (var p (* (* char))) emitted `char *p' + (test-group "malformed types are rejected" + (test-assert "nested pointer chain" + (reports? (in-fn "(var p (* (* char)))") "pointer chains are written flat")) + (test-assert "and names the line" + (reports? "(pub fn f () void\n (var p (* (* char))))" "codegen.sex:2:")) + ;; A sublist that only groups has no `*' in it and must still work. + (test-assert "grouping sublist still accepted" + (emits? (in-fn "(var s (* (const struct suc)) 0)") "const struct suc * s")) + (test-assert "flat chain still accepted" + (emits? (in-fn "(var q (* * const char) 0)") "const char * * q")))) diff --git a/tools/sextest/utils.module.scm b/tools/sextest/utils.module.scm index 0eeeae1..13c0bed 100644 --- a/tools/sextest/utils.module.scm +++ b/tools/sextest/utils.module.scm @@ -12,6 +12,8 @@ form-line copy-form-source! stamp-form-source! + form-location + sex-error with-directory ) "../../utils.scm") diff --git a/utils.module.scm b/utils.module.scm index f577477..7e1e3f1 100644 --- a/utils.module.scm +++ b/utils.module.scm @@ -12,6 +12,8 @@ form-line copy-form-source! stamp-form-source! + form-location + sex-error with-directory ) "utils.scm") diff --git a/utils.scm b/utils.scm index 430bdb3..7a99fb1 100644 --- a/utils.scm +++ b/utils.scm @@ -105,6 +105,21 @@ wrap a form-building expression." (hash-table-set! +form-sources+ to src))) to) +;;; Diagnostics +;;; +;;; Every form carries a location now, so an error can say where the +;;; wrong code was written +(define (form-location form) + "\"file:line: \" for FORM, or \"\" when it has none" + (let ((src (form-source form))) + (if src + (string-append (car src) ":" (number->string (cdr src)) ": ") + ""))) + +(define (sex-error form message . args) + "Signal an error about FORM, prefixed with where it was written." + (apply error (string-append (form-location form) message) args)) + (define (stamp-form-source! form src) "Give FORM and every subform that has none the location SRC. Used for macro expansions, which inherit the location of the call site the way a -- 2.52.0 From 522c5a2c0169183dab366d9b86c3700c3a039a53 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Mon, 14 Sep 2026 18:16:14 +0300 Subject: [PATCH 03/14] reject nested pointer types with proper error message --- fmt-c-writer.scm | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index 02b13ec..a896022 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -291,11 +291,26 @@ forms, and what remains." (else (type-convert-to-c form)))) +(define (has-pointer-star? form) + (and (pair? form) + (or (memq '* form) + (any has-pointer-star? (filter pair? form))))) + +;;; A `*' inside a sublist. Pointer chains are written flat -- (* * T), +;;; never (* (* T)) +;;; Sublists that merely group, like (* (const struct suc)), contain +;;; no `*' and are fine. +(define (nested-pointer? type) + (and (pair? type) + (any has-pointer-star? (filter pair? type)))) + (define (type-convert-to-c type) ;; Our pointers to C pointers ;; int -> int ;; * const char -> const char * ;; const * const char -> const char * const + (when (nested-pointer? type) + (sex-error type "pointer chains are written flat, as (* * T), not nested" type)) (if (atom? type) (atom-to-fmt-c type) (flatten (tree-map atom-to-fmt-c -- 2.52.0 From dae19715df07670607fd7961983ad4cdd502ed15 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Mon, 14 Sep 2026 23:35:48 +0300 Subject: [PATCH 04/14] add module testing Also fix module import --- Makefile | 9 +++++++-- sex-modules.scm | 13 ++++++++----- tests/modules/Makefile | 28 ++++++++++++++++++++++++++++ tests/modules/greet-app.sex | 19 +++++++++++++++++++ tests/modules/greet.sex | 18 ++++++++++++++++++ 5 files changed, 80 insertions(+), 7 deletions(-) create mode 100644 tests/modules/Makefile create mode 100644 tests/modules/greet-app.sex create mode 100644 tests/modules/greet.sex diff --git a/Makefile b/Makefile index a8a55c5..a540e4b 100644 --- a/Makefile +++ b/Makefile @@ -60,13 +60,18 @@ sextest: SEX_TEST_PROGRAMS = hello-world lists comments unicode +# Multi-module linking is checked end to end; see tests/modules/Makefile. +check-modules: sexc + @$(MAKE) --no-print-directory -C ./tests/modules check SEXC=../../sexc + run-tests: sexc sex-tests sextest - ./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) + ./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) && $(MAKE) check-modules clean: rm -f $(OBJ) main.o rm -f *.import.scm rm -f *.link rm -f sexc sex-tests sextest + $(MAKE) -C ./tests/modules clean -.PHONY: clean run-tests sex-tests sextest +.PHONY: clean run-tests sex-tests sextest check-modules diff --git a/sex-modules.scm b/sex-modules.scm index c2a9d61..48dace6 100644 --- a/sex-modules.scm +++ b/sex-modules.scm @@ -68,11 +68,14 @@ (case (car form) ((pub) (case (cadr form) - ((fn) ; replace with prototype - ;; fn type name (arg-list) (body) - ;; 1 2 3 4 - we need first 4 - (cons (copy-form-source! form (take (cdr form) 4)) acc)) - ((define defmacro import include struct typedef union var) + ;; A function is reduced to a prototype and keeps its `pub', so + ;; the importing unit declares it with external linkage + ((fn) + (cons (copy-form-source! form (take form 5)) acc)) + ;; A variable becomes an `extern' declaration + ((var) + (cons (copy-form-source! form (cons 'extern (take (cdr form) 3))) acc)) + ((define defmacro import include struct typedef union) (cons (copy-form-source! form (cdr form)) acc)) (else (sex-error form "pub must be followed by a definition" form)))) (else acc))) diff --git a/tests/modules/Makefile b/tests/modules/Makefile new file mode 100644 index 0000000..d3d604c --- /dev/null +++ b/tests/modules/Makefile @@ -0,0 +1,28 @@ +# Multi-module linking. +# +# Modules are only testable end to end, and nothing else in the suite +# links more than one translation unit. Three things have to hold at +# once: an imported `pub fn' comes out as a prototype with external +# linkage, an imported `pub var' as an extern declaration, and the +# module's object survives being passed after `--'. Get any of them +# wrong and this fails to link -- or, in the `pub var' case, links and +# quietly counts into a private copy. + +SEXC ?= ../../sexc + +EXPECTED = hello, world\nhello, sex\n2 greetings + +check: + @$(SEXC) greet.sex -c -o greet.o + @$(SEXC) greet-app.sex -o greet-app -- greet.o + @if [ "`./greet-app`" = "`printf '$(EXPECTED)\n'`" ]; then \ + echo "modules ok"; \ + else \ + echo "modules FAILED, got:"; ./greet-app; $(MAKE) clean; exit 1; \ + fi + @$(MAKE) --no-print-directory clean + +clean: + @rm -f greet.o greet-app + +.PHONY: check clean diff --git a/tests/modules/greet-app.sex b/tests/modules/greet-app.sex new file mode 100644 index 0000000..4ecf5f0 --- /dev/null +++ b/tests/modules/greet-app.sex @@ -0,0 +1,19 @@ +;;; Uses the greet module. Build both, then link them: +;;; +;;; ./sexc example/greet.sex -c -o greet.o +;;; ./sexc example/greet-app.sex -o greet-app -- greet.o +;;; +;;; `(import greet)' pastes greet's public declarations here: `greet' +;;; as a prototype and `greet-count' as an extern. Both keep external +;;; linkage, so they refer to the one definition in greet.o rather than +;;; to private copies. + +(include stdio.h) + +(import greet) + +(pub fn main () int + (greet "world") + (greet "sex") + (printf "%d greetings\n" greet-count) + (return 0)) diff --git a/tests/modules/greet.sex b/tests/modules/greet.sex new file mode 100644 index 0000000..094333a --- /dev/null +++ b/tests/modules/greet.sex @@ -0,0 +1,18 @@ +;;; A module. Everything marked `pub' forms its public interface; +;;; everything else is private to this file. +;;; +;;; Importing a module does not link it: it pastes the declarations, so +;;; the compiled object still has to be handed to the C compiler. See +;;; greet-app.sex. + +(include stdio.h) + +(pub var greet-count int 0) + +(pub fn greet ((name (* const char))) void + (++ greet-count) + (printf "hello, %s\n" name)) + +;;; Not `pub': invisible to importers, and static in the generated C. +(fn unused-helper () void + (printf "private\n")) -- 2.52.0 From 0b2b97a0c6dd30388ff46b0e6b51c3613c43c683 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Mon, 14 Sep 2026 23:52:44 +0300 Subject: [PATCH 05/14] add type database and compile-time reflection --- Makefile | 15 ++-- example/serialize.sex | 64 +++++++++++++++ semen.scm | 20 ++++- sex-macros.module.scm | 1 + sex-macros.scm | 14 +++- tests/Makefile | 15 ++-- tests/codegen.scm | 16 ++++ tests/run.scm | 1 + tests/sex-programs/serialize.sex | 37 +++++++++ tests/types.module.scm | 3 + tests/types.scm | 106 ++++++++++++++++++++++++ types.module.scm | 14 ++++ types.scm | 133 +++++++++++++++++++++++++++++++ 13 files changed, 425 insertions(+), 14 deletions(-) create mode 100644 example/serialize.sex create mode 100644 tests/sex-programs/serialize.sex create mode 100644 tests/types.module.scm create mode 100644 tests/types.scm create mode 100644 types.module.scm create mode 100644 types.scm diff --git a/Makefile b/Makefile index a540e4b..930f804 100644 --- a/Makefile +++ b/Makefile @@ -15,7 +15,7 @@ CSC_FLAGS += -K prefix -static MODULE_FLAGS = -emit-all-import-libraries -module-registration -c # Order matters, since module check correctness on compilation -MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc +MODULES = utils types sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc OBJ = $(MODULES:%=%.o) sexc: $(OBJ) main.scm @@ -28,6 +28,9 @@ sexc: $(OBJ) main.scm utils.o: utils.module.scm utils.scm $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils +types.o: types.module.scm types.scm + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) types.module.scm -o types.o -unit types + sex-macros.o: sex-macros.module.scm sex-macros.scm $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros @@ -37,8 +40,8 @@ reader.o: reader.module.scm reader.scm utils.o sex-modules.o: sex-modules.module.scm sex-modules.scm reader.o utils.o $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils -semen.o: semen.module.scm semen.scm sex-macros.o sex-modules.o utils.o - $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,utils +semen.o: semen.module.scm semen.scm sex-macros.o sex-modules.o types.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,types,utils sex-fmt-c.o: sex-fmt-c.scm $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c @@ -46,8 +49,8 @@ sex-fmt-c.o: sex-fmt-c.scm fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o utils.o $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils -sexc.o: sexc.module.scm sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o - $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,utils +sexc.o: sexc.module.scm types.o sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,types,utils # Unit testing sex-tests: @@ -58,7 +61,7 @@ sextest: $(MAKE) -C ./tools/sextest sextest cp ./tools/sextest/sextest . -SEX_TEST_PROGRAMS = hello-world lists comments unicode +SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize # Multi-module linking is checked end to end; see tests/modules/Makefile. check-modules: sexc diff --git a/example/serialize.sex b/example/serialize.sex new file mode 100644 index 0000000..b6d2d6d --- /dev/null +++ b/example/serialize.sex @@ -0,0 +1,64 @@ +;;; Generating code from a type's own definition. +;;; +;;; `serialize-struct' is handed nothing but a struct's name. It asks +;;; the compiler's type database what fields that struct has and what +;;; type each one is, and writes a printer to match. Add a field to the +;;; struct and the printer grows with it, with no other edit. +;;; +;;; The database is filled in as toplevel forms are processed, in order, +;;; so a struct has to be declared before the macro call that asks about +;;; it -- the same rule C has. + +(include stdio.h) + +(defmacro (serialize-struct type-name) + ;; map-fields walks the declaration; type-match picks a printf + ;; conversion per field. Both come from the compiler's type database, + ;; so the macro never takes a type apart itself. + (let ((printers + (map-fields type-name + (lambda (name type) + `(fprintf out + ,(string-append + " " (symbol->string name) "=" + (type-match type + (int "%d") + (char "%c") + (long "%ld") + (unsigned "%u") + (float "%g") + (double "%g") + ((* const char) "%s") + ((* char) "%s") + (else (error "serialize-struct: unsupported field type" + type-name name type)))) + (-> v ,name)))))) + (if (not printers) + (error "serialize-struct: no such struct" type-name) + `(pub fn ,(cat 'serialize- type-name) + ((v (* const struct ,type-name)) (out (* FILE))) + void + (fprintf out ,(string-append (symbol->string type-name) " {")) + ,@printers + (fprintf out " }\n"))))) + +(struct point ((x int) (y int))) + +(struct person + ((name (* const char)) + (age int) + (height float))) + +;;; Two printers, written by the compiler from the declarations above. +(serialize-struct point) +(serialize-struct person) + +(pub fn main () int + (var origin (struct point) #(0 0)) + (var corner (struct point) #(640 -480)) + (var alex (struct person) #("Alex" 34 1.82)) + + (serialize-point (& origin) stdout) + (serialize-point (& corner) stdout) + (serialize-person (& alex) stdout) + (return 0)) diff --git a/semen.scm b/semen.scm index 64f16e9..7daaf91 100644 --- a/semen.scm +++ b/semen.scm @@ -9,6 +9,7 @@ fmt sex-macros sex-modules + types matchable ; pattern matching srfi-1 ; list routines srfi-69 ; hash tables @@ -72,7 +73,10 @@ ('pub 'var . _) ('extern 'var . _)) (process-global-var sex-form acc)) (('include _) (cons sex-form acc)) - (('define . _) (cons sex-form acc)) + ((or ('define name . _) + ('pub 'define name . _)) + (add-define name sex-form) + (cons sex-form acc)) (('comment . _) (cons sex-form acc)) (('import . modules) @@ -83,6 +87,7 @@ ((or ('typedef new-type target) ('pub 'typedef new-type target)) + (add-typedef new-type sex-form) (process-typedef sex-form new-type target acc)) (else (sex-error sex-form "unknown top level form" sex-form)))) @@ -208,9 +213,22 @@ ;;; Structs +;;; Record the named structs, unions and enums in the type database (define (process-struct sex-struct acc) + (register-aggregate! sex-struct) (cons sex-struct acc)) +(define (register-aggregate! form) + (let* ((f (if (eq? (car form) 'pub) (cdr form) form)) + (name (and (pair? (cdr f)) (symbol? (cadr f)) (cadr f)))) + ;; An anonymous aggregate has a field list where the name would be, + ;; and nothing can refer to it by name anyway + (when name + (case (car f) + ((struct) (add-struct name form)) + ((union) (add-union name form)) + ((enum) (add-enum name form)))))) + (define (process-global-var sex-var acc) (cons sex-var acc)) diff --git a/sex-macros.module.scm b/sex-macros.module.scm index f211ab7..9837c04 100644 --- a/sex-macros.module.scm +++ b/sex-macros.module.scm @@ -1,6 +1,7 @@ (module sex-macros (register-macro cat + comment get-macro macro? apply-macro diff --git a/sex-macros.scm b/sex-macros.scm index 8d1b104..1923a46 100644 --- a/sex-macros.scm +++ b/sex-macros.scm @@ -11,11 +11,23 @@ (define (cat sym-1 sym-2) (string->symbol (cat-syms sym-1 sym-2))) +;;; The reader keeps `;' comments as (comment "...") forms so they can +;;; be re-emitted into the generated C. In a macro body a comment +;;; should be a call which does nothing, hence this one +(define (comment . _) + (void)) + (define (register-macro name arglist body) (put! name 'sex-macro `(lambda ,arglist + ;; A macro body is ordinary Scheme, evaluated at compile + ;; time. It gets `cat' for building names, and read access to + ;; the type database (import scheme - (only sex-macros cat)) + (scheme base) + (only sex-macros cat comment) + (only types get-type-info get-fields get-underlying-type + type-match map-fields)) ,@body))) (define (get-macro name) diff --git a/tests/Makefile b/tests/Makefile index 0251aaa..b40a19e 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -3,10 +3,10 @@ CHICKEN_C = csc CSC_FLAGS += -K prefix -static MODULE_FLAGS = -emit-all-import-libraries -module-registration -c -MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc +MODULES = utils types sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc SEX_OBJ = $(MODULES:%=%.o) -TESTS = basic semen reader fmt-c-writer utils line-directives codegen args +TESTS = basic semen reader fmt-c-writer utils line-directives codegen args types TEST_SRCS = $(TESTS:%=%.scm) sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ) @@ -17,6 +17,9 @@ sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ) utils.o: utils.module.scm ../utils.scm $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils +types.o: types.module.scm ../types.scm + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) types.module.scm -o types.o -unit types + sex-macros.o: sex-macros.module.scm ../sex-macros.scm $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros @@ -26,8 +29,8 @@ reader.o: reader.module.scm ../reader.scm utils.o sex-modules.o: sex-modules.module.scm ../sex-modules.scm reader.o utils.o $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils -semen.o: semen.module.scm ../semen.scm sex-macros.o sex-modules.o utils.o - $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,utils +semen.o: semen.module.scm ../semen.scm sex-macros.o sex-modules.o types.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,types,utils sex-fmt-c.o: ../sex-fmt-c.scm $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) ../sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c @@ -35,8 +38,8 @@ sex-fmt-c.o: ../sex-fmt-c.scm fmt-c-writer.o: fmt-c-writer.module.scm ../fmt-c-writer.scm sex-fmt-c.o utils.o $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils -sexc.o: sexc.module.scm ../sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o - $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,utils +sexc.o: sexc.module.scm types.o ../sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,types,utils clean: rm -f $(SEX_OBJ) diff --git a/tests/codegen.scm b/tests/codegen.scm index 6d4a0f9..8dc7637 100644 --- a/tests/codegen.scm +++ b/tests/codegen.scm @@ -171,6 +171,22 @@ compiles." (emits? (in-fn "(var x int (c-or a b))") "a || b")) (test-assert "c-bit-or is still accepted" (emits? (in-fn "(var x int (c-bit-or a b))") "a | b"))) + + ;; A `;' comment is a form. In a macro body `comment' is a no-op + ;; that swallows the comment itself. Inside a quasiquoted payload + ;; the same form is data, never evaluated, and reaches the writer + ;; intact + (test-group "comments in macros" + (test-assert "a comment in the payload reaches the C" + (emits? "(defmacro (m-kept) `(fn f () void\n ;; this survives\n (g)))\n(m-kept)" + "this survives")) + (test-assert "a comment about the macro does not" + (not (emits? "(defmacro (m-dropped)\n ;; this vanishes\n `(fn f () void (g)))\n(m-dropped)" + "this vanishes"))) + (test-assert "and the macro still expands" + (emits? "(defmacro (m-both)\n ;; about the macro\n `(fn f () void (g)))\n(m-both)" + "void f (void)"))) + ;; Diagnostics name also the place. Every form carries a (file ;; . line), so an error can cite it (test-group "errors cite the source location" diff --git a/tests/run.scm b/tests/run.scm index 1256079..151ba89 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -9,6 +9,7 @@ (include "line-directives.scm") (include "codegen.scm") (include "args.scm") +(include "types.scm") ;;; Should be the last in the test suite (test-exit) diff --git a/tests/sex-programs/serialize.sex b/tests/sex-programs/serialize.sex new file mode 100644 index 0000000..344d305 --- /dev/null +++ b/tests/sex-programs/serialize.sex @@ -0,0 +1,37 @@ +(input) +(output "box { w=3 h=4 label=wide }") +(return 0) + +;;; A macro generating code from the type database: it is handed a +;;; struct name, walks its fields with map-fields, and picks a printf +;;; conversion per field with type-match. Exercises semen registering +;;; the struct and the macro reading it back at expansion time. + +(include stdio.h) + +(defmacro (print-struct type-name) + (let ((printers + (map-fields type-name + (lambda (name type) + `(printf ,(string-append " " (symbol->string name) "=" + (type-match type + (int "%d") + ((* const char) "%s") + (else (error "print-struct: unsupported field type" + name type)))) + (-> v ,name)))))) + (if (not printers) + (error "print-struct: no such struct" type-name) + `(fn ,(cat 'print- type-name) ((v (* const struct ,type-name))) void + (printf ,(string-append (symbol->string type-name) " {")) + ,@printers + (printf " }\n"))))) + +(struct box ((w int) (h int) (label (* const char)))) + +(print-struct box) + +(pub fn main () int + (var b (struct box) #(3 4 "wide")) + (print-box (& b)) + (return 0)) diff --git a/tests/types.module.scm b/tests/types.module.scm new file mode 100644 index 0000000..bee50e2 --- /dev/null +++ b/tests/types.module.scm @@ -0,0 +1,3 @@ +(module types + * + "../types.scm") diff --git a/tests/types.scm b/tests/types.scm new file mode 100644 index 0000000..4d30ee0 --- /dev/null +++ b/tests/types.scm @@ -0,0 +1,106 @@ +;;; The type database. +;;; +;;; Names here are prefixed so they cannot collide with the types the +;;; other suites register: the database is one table in the linked +;;; binary, and semen fills it in whenever a suite compiles a struct. + +(import types) + +(test-group "types" + + (add-struct 't-point '(struct t-point ((x int) (y int)))) + (test "fields come back as (name type)" + '((x int) (y int)) + (get-fields 't-point)) + (test "and the whole entry is tagged" + '(struct t-point ((x int) (y int))) + (get-type-info 't-point)) + + ;; Fields are written with the type last, so one entry can declare + ;; several names. They come back as one field each. + (add-struct 't-settings + '(pub struct t-settings ((x y w h u32) (title (* const char))))) + (test "names sharing a type are split apart" + '((x u32) (y u32) (w u32) (h u32) (title (* const char))) + (get-fields 't-settings)) + + (add-struct 't-commented '(struct t-commented ((comment " hi") (a int)))) + (test "a comment among the fields is not a field" + '((a int)) + (get-fields 't-commented)) + + (add-union 't-value '(union t-value ((i int) (f float)))) + (test "unions have fields too" + '((i int) (f float)) + (get-fields 't-value)) + + (add-enum 't-color '(enum t-color (red green blue))) + (test "enums keep their values" + '(enum t-color (red green blue)) + (get-type-info 't-color)) + (test "but have no fields" + #f + (get-fields 't-color)) + + (add-typedef 't-u8 '(typedef t-u8 uint8-t)) + (test "a typedef resolves to its target" + 'uint8-t + (get-underlying-type 't-u8)) + (add-typedef 't-byte '(typedef t-byte t-u8)) + (test "and chains are followed to the end" + 'uint8-t + (get-underlying-type 't-byte)) + (test "a struct is not a typedef" + #f + (get-underlying-type 't-point)) + + ;; A #define keeps its value forms -- there can be more than one. + (add-define 't-maxn '(define t-maxn 8)) + (test "defines are recorded" + '(define t-maxn (8)) + (get-type-info 't-maxn)) + + ;; map-fields walks an aggregate, handing each field to a function. + (test "map-fields visits every field" + '((x int) (y int)) + (map-fields 't-point (lambda (name type) (list name type)))) + (test "and splits shared names apart too" + '(x y w h title) + (map-fields 't-settings (lambda (name type) name))) + ;; An enumerator's type is the enum itself. + (test "enum values are fields whose type is the enum" + '((red (enum t-color)) (green (enum t-color)) (blue (enum t-color))) + (map-fields 't-color (lambda (name type) (list name type)))) + (test "a typedef has no fields to map" + #f + (map-fields 't-u8 (lambda (name type) name))) + (test "nor does an undeclared name" + #f + (map-fields 't-nothing (lambda (name type) name))) + + ;; type-match compares whole types, since a type is a form. + (test "a bare type matches" 'yes (type-match 'int (int 'yes) (else 'no))) + (test "so does a compound one" 'yes (type-match '(* const char) + (int 'no) + ((* const char) 'yes) + (else 'no))) + ;; The [int 10] of the docstring is Sex notation: the Sex reader turns + ;; brackets into a ¤ form, while CHICKEN reads them as plain parens. + ;; In a .scm file the array type has to be written out. + (test "and an array" 'yes (type-match '(¤ int 10) + ((¤ int 10) 'yes) + (else 'no))) + (test "else catches the rest" 'no (type-match '(* void) (int 'yes) (else 'no))) + (test "a near miss does not match" 'no (type-match '(¤ int 20) + ((¤ int 10) 'yes) + (else 'no))) + (test "no clause matching and no else is #f" + #f + (type-match 'float (int 'yes))) + + (test "an undeclared name has no entry" + #f + (get-type-info 't-never-declared)) + (test "and no fields" + #f + (get-fields 't-never-declared))) diff --git a/types.module.scm b/types.module.scm new file mode 100644 index 0000000..8f94b70 --- /dev/null +++ b/types.module.scm @@ -0,0 +1,14 @@ +(module types + (add-struct + add-union + add-enum + add-typedef + add-define + + type-match + map-fields + + get-type-info + get-fields + get-underlying-type) + "types.scm") diff --git a/types.scm b/types.scm new file mode 100644 index 0000000..2654ed2 --- /dev/null +++ b/types.scm @@ -0,0 +1,133 @@ +;;; The type database. +;;; +;;; Every named aggregate, typedef and define the semantic engine +;;; walks past is recorded here, so that macros (or other forms) can +;;; ask what a type is made of. That is what lets a macro generate +;;; code from a struct's fields given nothing but its name. +;;; +;;; Entries are filled in as toplevel forms are processed, in order, so +;;; a type has to be declared before the macro that asks about it. + +(import + scheme + (scheme base) + (chicken base) + srfi-1 + srfi-69) + +(define +type-db+ (make-hash-table)) + +(define (strip-pub form) + (if (eq? (car form) 'pub) (cdr form) form)) + +(define (comment-form? f) + (and (pair? f) (eq? (car f) 'comment))) + +;;; Fields are written with the type last and one or more names before +;;; it, so ((x y int) (p (* char))) describes three fields. Flatten that +;;; into one (name type) per field, which is what a caller wants. +(define (normalize-fields fields) + (append-map + (lambda (field) + (if (comment-form? field) + (list) + (let ((type (last field)) + (names (drop-right field 1))) + (map (lambda (name) (list name type)) names)))) + (remove comment-form? fields))) + +;;; ([pub] struct name (fields ...) . attrs) +(define (aggregate-fields form) + (let ((f (strip-pub form))) + (if (and (pair? (cddr f)) (list? (caddr f))) + (caddr f) + (list)))) + +(define (add-struct name form) + (hash-table-set! +type-db+ name + (list 'struct name (normalize-fields (aggregate-fields form))))) + +(define (add-union name form) + (hash-table-set! +type-db+ name + (list 'union name (normalize-fields (aggregate-fields form))))) + +;;; ([pub] enum name (value ...)) +(define (add-enum name form) + (let ((f (strip-pub form))) + (hash-table-set! +type-db+ name + (list 'enum name (if (and (pair? (cddr f)) (list? (caddr f))) + (caddr f) + (list)))))) + +;;; ([pub] typedef new-name target) +(define (add-typedef name form) + (hash-table-set! +type-db+ name + (list 'typedef name (last (strip-pub form))))) + +;;; (define name value ...) -- a C #define, kept so a macro can read a +;;; compile-time constant rather than re-parse the source. +(define (add-define name form) + (hash-table-set! +type-db+ name + (list 'define name (cddr (strip-pub form))))) + +(define (get-type-info name) + (hash-table-ref/default +type-db+ name #f)) + +;;; ((name type) ...) for a struct or union, #f for anything else -- +;;; including a name that was never declared. Callers give the better +;;; error, since they know what they wanted it for. +(define (get-fields name) + (let ((info (get-type-info name))) + (and info + (memq (car info) '(struct union)) + (caddr info)))) + +;;; Follow a typedef chain to the name it ultimately stands for. #f if +;;; NAME is not a typedef. +(define (get-underlying-type name) + (let ((info (get-type-info name))) + (and info + (eq? (car info) 'typedef) + (let ((target (caddr info))) + (or (and (symbol? target) (get-underlying-type target)) + target))))) + +;;; Type matcher macro +;;; (type-match type +;;; (int ...) +;;; ((* const char) ...) +;;; ([int 10] ...) +;;; (else ...)) +;;; +;;; A type is a form, not an atom, so this compares with equal? rather +;;; than dispatching like `case'. Patterns are literal types and are not +;;; evaluated; `else' is optional and the whole thing is #f when nothing +;;; matches and there is no else. +(define-syntax type-match + (syntax-rules (else) + ((_ type) #f) + ((_ type (else body ...)) (begin body ...)) + ((_ type (pattern body ...) clause ...) + (if (equal? type 'pattern) + (begin body ...) + (type-match type clause ...))))) + +;;; Map function to each field/value of a structure/union/enum +;;; For enums, field-type is the type of the enum (since C 23) +;;; (map-fields type-name +;;; (lambda (field-name field-type) ...)) +;;; +;;; Returns #f if nothing of that name was declared +(define (map-fields struct-union-enum fn) + (let ((info (get-type-info struct-union-enum))) + (and info + (case (car info) + ((struct union) + (map (lambda (field) (fn (car field) (cadr field))) + (caddr info))) + ;; An enumerator's type is the enum itself. + ((enum) + (let ((type (list 'enum struct-union-enum))) + (map (lambda (value) (fn value type)) + (caddr info)))) + (else #f))))) -- 2.52.0 From 85bf1c163c9d512170bd755eb9e9cdb3c643395c Mon Sep 17 00:00:00 2001 From: alex-eg Date: Mon, 14 Sep 2026 23:53:21 +0300 Subject: [PATCH 06/14] generate temp .c files instead of passing to compiler's stdin For a clearer architecture --- sexc.scm | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/sexc.scm b/sexc.scm index 46afcc0..d98e427 100644 --- a/sexc.scm +++ b/sexc.scm @@ -123,20 +123,21 @@ (out-file (if (eq? output 'default) "a.out" output))) - ;; `process' hands back one record. Its port accessors are named - ;; from the *child's* point of view, so `process-input-port' is the - ;; port we write to: the C compiler's stdin. - (let* ((proc (process compiler (append (list "-o" out-file "-x" "c") - (if (get-arg args 'compile-object #f) - (list "-c") - (list)) - (list "-") ; read stdin - cc-args))) - (cc-stdin (process-input-port proc))) - (with-output-to-port cc-stdin + ;; The generated C goes to a temporary .c file rather than the + ;; compiler's stdin + (let ((c-file (create-temporary-file "c"))) + (with-output-to-file c-file (lambda () (emit-c sex-forms))) - (close-output-port cc-stdin) - (process-wait proc)))) + (let ((proc (process compiler (append (list "-o" out-file) + (if (get-arg args 'compile-object #f) + (list "-c") + (list)) + (list c-file) + cc-args)))) + (call-with-values (lambda () (process-wait proc)) + (lambda status + (delete-file* c-file) + (apply values status))))))) (define (semantic-process-forms raw-forms input-source) (if (eq? input-source 'stdin) -- 2.52.0 From d0d0ea8e8418646105f84b31c6aa29e2806a6a95 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 16 Sep 2026 01:11:53 +0300 Subject: [PATCH 07/14] process imported forms as toplevel, not as text 1. register imported types 2. protect against multiple imports (diamond, circular) --- semen.scm | 14 +++----------- sex-modules.scm | 10 +++++++++- tests/modules/Makefile | 6 +++++- tests/modules/greet-app.sex | 5 +++++ tests/modules/greet.sex | 10 ++++++++++ 5 files changed, 32 insertions(+), 13 deletions(-) diff --git a/semen.scm b/semen.scm index 7daaf91..422999f 100644 --- a/semen.scm +++ b/semen.scm @@ -93,17 +93,9 @@ (else (sex-error sex-form "unknown top level form" sex-form)))) (define (process-imports module-public-forms acc) - ;; Recursively process imports: register public macros, cons all - ;; other public things to our acc - (if (null? module-public-forms) acc - (match (car module-public-forms) - (('defmacro . rest) - (defmacro rest) - (process-imports (cdr module-public-forms) acc)) - (else - (process-imports (cdr module-public-forms) - (cons (car module-public-forms) - acc)))))) + ;; consume (import ...) form and process imports so + ;; data types end up in types db + (fold match-sex-form acc module-public-forms)) (define (macro-expand form) "Walk the form recursively and expand all macros, until none is left." diff --git a/sex-modules.scm b/sex-modules.scm index 48dace6..cc63809 100644 --- a/sex-modules.scm +++ b/sex-modules.scm @@ -14,6 +14,10 @@ (define +persistent-module-paths+ (list)) +;;; for guarding against multiple imports (sort of mandatory #pragma +;;; once) +(define +imported-modules+ (list)) + (define (get-modules-public-forms module-list) ;; Module list is a list of symbols ;; How Sex handles modules: @@ -29,7 +33,11 @@ (let ((module-path (locate-module name))) (assert module-path (fmt #f "Failed to find module " name " in " (get-module-paths))) - (read-public-interface module-path))) + (if (member module-path +imported-modules+) + (list) + (begin + (set! +imported-modules+ (cons module-path +imported-modules+)) + (read-public-interface module-path))))) (define (get-module-paths) (cons (current-directory) diff --git a/tests/modules/Makefile b/tests/modules/Makefile index d3d604c..5091e44 100644 --- a/tests/modules/Makefile +++ b/tests/modules/Makefile @@ -7,10 +7,14 @@ # module's object survives being passed after `--'. Get any of them # wrong and this fails to link -- or, in the `pub var' case, links and # quietly counts into a private copy. +# +# It also checks what only a second translation unit can check: that an +# imported type reaches the type database, by expanding a macro that +# reads the imported struct's fields. SEXC ?= ../../sexc -EXPECTED = hello, world\nhello, sex\n2 greetings +EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times check: @$(SEXC) greet.sex -c -o greet.o diff --git a/tests/modules/greet-app.sex b/tests/modules/greet-app.sex index 4ecf5f0..0f1a6ec 100644 --- a/tests/modules/greet-app.sex +++ b/tests/modules/greet-app.sex @@ -7,6 +7,9 @@ ;;; as a prototype and `greet-count' as an extern. Both keep external ;;; linkage, so they refer to the one definition in greet.o rather than ;;; to private copies. +;;; +;;; Also check that import populates type-database, by means of +;;; describe-fields macro, which should work on imported type. (include stdio.h) @@ -16,4 +19,6 @@ (greet "world") (greet "sex") (printf "%d greetings\n" greet-count) + (describe-fields greeting) + (printf "\n") (return 0)) diff --git a/tests/modules/greet.sex b/tests/modules/greet.sex index 094333a..e97386a 100644 --- a/tests/modules/greet.sex +++ b/tests/modules/greet.sex @@ -9,6 +9,16 @@ (pub var greet-count int 0) +(pub struct greeting ((text (* const char)) (times int))) + +;;; Compile-time reflection across the module boundary: both the macro +;;; and the struct it asks about are exported, and the importing unit +;;; has to know the struct's fields to expand this. +(pub defmacro (describe-fields type) + `(do ,@(map-fields type + (lambda (name field-type) + `(printf "%s " ,(symbol->string name)))))) + (pub fn greet ((name (* const char))) void (++ greet-count) (printf "hello, %s\n" name)) -- 2.52.0 From 847bb1434043d362d507101feb5da67b58e04069 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 16 Sep 2026 01:16:52 +0300 Subject: [PATCH 08/14] accept pub enum, and enums used as types Implement pub support for enums, and also anonymous enums declared in-place. Also give the cdr of a `pub' form the form's own location, so a error about what follows `pub' can say where it was written --- fmt-c-writer.scm | 15 +++++++++++++-- sex-fmt-c.scm | 26 +++++++++++++++++++------- sex-modules.scm | 2 +- tests/codegen.scm | 22 ++++++++++++++++++++++ tests/modules/Makefile | 2 +- tests/modules/greet-app.sex | 2 ++ tests/modules/greet.sex | 2 ++ 7 files changed, 60 insertions(+), 11 deletions(-) diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index a896022..e5d6731 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -382,10 +382,17 @@ forms, and what remains." (define (walk-enum form) (match form + ;; Naming one without defining it: `(var m (enum mood))', the same + ;; shape walk-struct accepts for `(struct foo)'. Guarded, and + ;; before the anonymous case, since `(enum (red green))' is also a + ;; two-element form + (('enum (? symbol? name)) + `(enum ,(atom-to-fmt-c name))) (('enum (values ...)) `(enum ,(map atom-to-fmt-c values))) (('enum name (values ...)) - `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values))))) + `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values))) + (else (sex-error form "malformed enum" form)))) (define (walk-extern form) (match form @@ -410,6 +417,7 @@ forms, and what remains." ('struct . _) ('union . _) + ('enum . _) ('typedef . _)) ;; ignore here, used in generating public interface @@ -423,7 +431,10 @@ forms, and what remains." (('fn . _) (list 'static (walk-function form))) (('var . _) (list 'static (walk-var form))) (('extern . rest) (walk-extern rest)) - (('pub . rest) (walk-public rest)) + ;; The cdr of a form has no location of its own, so hand it the + ;; `pub' form's -- otherwise a complaint about what follows `pub' + ;; cannot say where it was written + (('pub . rest) (walk-public (copy-form-source! form rest))) ((or ('struct . _) ('union . _)) (walk-struct form)) (('enum . _) (walk-enum form)) diff --git a/sex-fmt-c.scm b/sex-fmt-c.scm index 127b2fc..6680ffc 100644 --- a/sex-fmt-c.scm +++ b/sex-fmt-c.scm @@ -640,16 +640,22 @@ (define (c-union . args) (apply c-struct/aux "union" args)) (define (c-class . args) (apply c-struct/aux "class" args)) + ;; MODIFIED FROM UPSTREAM fmt-c: an enum may also be named without + ;; being defined -- `enum color m;' -- exactly as c-struct/aux + ;; already allows `struct point p;'. Upstream assumed a value list + ;; was always present and mapped over whatever stood in its place. (define (c-enum x . o) (define (c-enum-one x) (if (pair? x) (cat (car x) " = " (c-expr (cadr x))) (dsp x))) (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x)) - (vals (if name (car o) x))) - (c-wrap-stmt - (cat - (c-braced-block - (if name (cat "enum " name) (dsp "enum")) - (c-in-expr (apply c-begin (map c-enum-one vals)))))))) + (vals (if name (if (null? o) #f (car o)) x))) + (if vals + (c-wrap-stmt + (cat + (c-braced-block + (if name (cat "enum " name) (dsp "enum")) + (c-in-expr (apply c-begin (map c-enum-one vals)))))) + (c-wrap-stmt (cat "enum " name))))) (define (c-attribute . args) (cat "__attribute__ ((" (fmt-join c-expr args ", ") "))")) @@ -743,7 +749,13 @@ (if (and (pair? (cadr type)) (eq? '%array (caadr type))) (c-paren name) name)))) - ((enum) (apply c-enum name (cdr type))) + ;; MODIFIED FROM UPSTREAM fmt-c: upstream passed the + ;; declarator's name to c-enum as the enum's tag, so + ;; `(var m (enum color))' emitted `enum m {...}' and lost the + ;; variable. Enums are laid out like structs: the type, then + ;; the name being declared. + ((enum) + (cat (apply c-enum (cdr type)) (if name (cat " " name) ""))) ((struct union class) (cat (apply c-struct/aux (car type) (cdr type)) (if name (cat " " name) ""))) (else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " ")))) diff --git a/sex-modules.scm b/sex-modules.scm index cc63809..c524df4 100644 --- a/sex-modules.scm +++ b/sex-modules.scm @@ -83,7 +83,7 @@ ;; A variable becomes an `extern' declaration ((var) (cons (copy-form-source! form (cons 'extern (take (cdr form) 3))) acc)) - ((define defmacro import include struct typedef union) + ((define defmacro enum import include struct typedef union) (cons (copy-form-source! form (cdr form)) acc)) (else (sex-error form "pub must be followed by a definition" form)))) (else acc))) diff --git a/tests/codegen.scm b/tests/codegen.scm index 8dc7637..1f60903 100644 --- a/tests/codegen.scm +++ b/tests/codegen.scm @@ -141,6 +141,28 @@ compiles." (test-assert "a comment in a body stays in the body" (emits? (in-fn "(while (< a b) ;; inside\n (g 1))") "while (a < b) {"))) + + (test-group "pub enum" + (test-assert "is emitted" + (emits? "(pub enum color (red green blue))" "enum color")) + (test-assert "with its values" + (emits? "(pub enum color (red green blue))" "red")) + (test-assert "and a non-pub enum still is too" + (emits? "(enum color (red green blue))" "enum color")) + ;; Naming an enum as a type, rather than defining it, had no + ;; walk-enum clause and died with `(match) no matching pattern' + (test-assert "and it can then be used as a type" + (emits? "(enum color (red green blue)) (fn f () void (var m (enum color) red))" + "enum color m = red")) + (test-assert "a malformed enum is rejected with its location" + (reports? "(enum)" "codegen.sex:1:")) + ;; c-type handed the declarator's name to c-enum as the enum tag, + ;; so this emitted `enum m { up, down }' with no variable at all + (test-assert "an anonymous enum keeps the variable" + (emits? "(fn f () void (var e (enum (up down)) up))" "} e = up")) + (test-assert "and a named definition keeps both" + (emits? "(fn f () void (var n (enum named (a b)) a))" "enum named{"))) + ;; `|', `||' and `|=' read as ordinary symbols -- our own reader has ;; no |symbol| syntax for them to collide with -- but fmt-c cannot ;; dispatch on a symbol whose name it cannot write in Scheme source, diff --git a/tests/modules/Makefile b/tests/modules/Makefile index 5091e44..1d11462 100644 --- a/tests/modules/Makefile +++ b/tests/modules/Makefile @@ -14,7 +14,7 @@ SEXC ?= ../../sexc -EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times +EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \nmood 1 check: @$(SEXC) greet.sex -c -o greet.o diff --git a/tests/modules/greet-app.sex b/tests/modules/greet-app.sex index 0f1a6ec..c7775ed 100644 --- a/tests/modules/greet-app.sex +++ b/tests/modules/greet-app.sex @@ -21,4 +21,6 @@ (printf "%d greetings\n" greet-count) (describe-fields greeting) (printf "\n") + (var m (enum mood) grumpy) + (printf "mood %d\n" m) (return 0)) diff --git a/tests/modules/greet.sex b/tests/modules/greet.sex index e97386a..382fb36 100644 --- a/tests/modules/greet.sex +++ b/tests/modules/greet.sex @@ -11,6 +11,8 @@ (pub struct greeting ((text (* const char)) (times int))) +(pub enum mood (cheerful grumpy)) + ;;; Compile-time reflection across the module boundary: both the macro ;;; and the struct it asks about are exported, and the importing unit ;;; has to know the struct's fields to expand this. -- 2.52.0 From 97ef62b7f410966252a866bcc779b797637c096d Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 16 Sep 2026 01:18:20 +0300 Subject: [PATCH 09/14] resolve typedefs in get-fields and map-fields Now these macro helpers take in account the possibility of typedefing one type to another, and correctly find the one intended --- tests/modules/Makefile | 2 +- tests/modules/greet-app.sex | 3 +++ tests/modules/greet.sex | 2 ++ tests/types.scm | 36 ++++++++++++++++++++++++++++++ types.scm | 44 ++++++++++++++++++++++++++++--------- 5 files changed, 76 insertions(+), 11 deletions(-) diff --git a/tests/modules/Makefile b/tests/modules/Makefile index 1d11462..1821967 100644 --- a/tests/modules/Makefile +++ b/tests/modules/Makefile @@ -14,7 +14,7 @@ SEXC ?= ../../sexc -EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \nmood 1 +EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \ntext times \nmood 1 check: @$(SEXC) greet.sex -c -o greet.o diff --git a/tests/modules/greet-app.sex b/tests/modules/greet-app.sex index c7775ed..6229e91 100644 --- a/tests/modules/greet-app.sex +++ b/tests/modules/greet-app.sex @@ -21,6 +21,9 @@ (printf "%d greetings\n" greet-count) (describe-fields greeting) (printf "\n") + ;; ...and through the imported typedef for it + (describe-fields greeting-t) + (printf "\n") (var m (enum mood) grumpy) (printf "mood %d\n" m) (return 0)) diff --git a/tests/modules/greet.sex b/tests/modules/greet.sex index 382fb36..887b295 100644 --- a/tests/modules/greet.sex +++ b/tests/modules/greet.sex @@ -13,6 +13,8 @@ (pub enum mood (cheerful grumpy)) +(pub typedef greeting-t (struct greeting)) + ;;; Compile-time reflection across the module boundary: both the macro ;;; and the struct it asks about are exported, and the importing unit ;;; has to know the struct's fields to expand this. diff --git a/tests/types.scm b/tests/types.scm index 4d30ee0..d9bfc8a 100644 --- a/tests/types.scm +++ b/tests/types.scm @@ -54,6 +54,42 @@ #f (get-underlying-type 't-point)) + ;; Reflection through an alias. Both spellings of the target occur: + ;; (typedef point-t point) and (typedef point-t (struct point)). + (add-typedef 't-point-t '(typedef t-point-t t-point)) + (test "a typedef to a struct has the struct's fields" + '((x int) (y int)) + (get-fields 't-point-t)) + (add-typedef 't-point-s '(typedef t-point-s (struct t-point))) + (test "written the other way round too" + '((x int) (y int)) + (get-fields 't-point-s)) + (add-typedef 't-point-2 '(typedef t-point-2 t-point-t)) + (test "and through a chain of them" + '((x int) (y int)) + (get-fields 't-point-2)) + (test "map-fields follows an alias as well" + '((x int) (y int)) + (map-fields 't-point-t (lambda (name type) (list name type)))) + (add-typedef 't-color-t '(typedef t-color-t t-color)) + (test "an aliased enum is still named as it was declared" + '((red (enum t-color)) (green (enum t-color)) (blue (enum t-color))) + (map-fields 't-color-t (lambda (name type) (list name type)))) + (test "a typedef to a primitive has no fields" + #f + (get-fields 't-u8)) + + ;; A typedef can be written to lead back to itself. Resolving it must + ;; stop rather than spin + (add-typedef 't-loop-a '(typedef t-loop-a t-loop-b)) + (add-typedef 't-loop-b '(typedef t-loop-b t-loop-a)) + (test "a typedef cycle terminates" + 't-loop-a + (get-underlying-type 't-loop-a)) + (test "and has no fields" + #f + (get-fields 't-loop-a)) + ;; A #define keeps its value forms -- there can be more than one. (add-define 't-maxn '(define t-maxn 8)) (test "defines are recorded" diff --git a/types.scm b/types.scm index 2654ed2..6e6b4b0 100644 --- a/types.scm +++ b/types.scm @@ -76,21 +76,44 @@ ;;; ((name type) ...) for a struct or union, #f for anything else -- ;;; including a name that was never declared. Callers give the better ;;; error, since they know what they wanted it for. +;;; +;;; A typedef is followed to what it stands for, so reflection over an +;;; alias works exactly as it does over the name it aliases. (define (get-fields name) - (let ((info (get-type-info name))) + (let ((info (resolve-type-info name))) (and info (memq (car info) '(struct union)) (caddr info)))) -;;; Follow a typedef chain to the name it ultimately stands for. #f if -;;; NAME is not a typedef. +;;; Follow a typedef chain to the name it stands for. #f if NAME is +;;; not a typedef. A typedef that leads back to itself stops rather +;;; than spinning: nothing prevents one from being written. (define (get-underlying-type name) + (let follow ((name name) (seen (list))) + (and (not (member name seen)) + (let ((info (get-type-info name))) + (and info + (eq? (car info) 'typedef) + (let ((target (caddr info))) + (or (and (symbol? target) (follow target (cons name seen))) + target))))))) + +;;; The declaration NAME ultimately names. For a typedef that is the +;;; entry of whatever it stands for, and for anything else it is +;;; NAME's own info. +(define (resolve-type-info name) (let ((info (get-type-info name))) (and info - (eq? (car info) 'typedef) - (let ((target (caddr info))) - (or (and (symbol? target) (get-underlying-type target)) - target))))) + (if (eq? (car info) 'typedef) + (let* ((target (get-underlying-type name)) + (tag (cond ((symbol? target) target) + ((and (pair? target) + (pair? (cdr target)) + (symbol? (cadr target))) + (cadr target)) + (else #f)))) + (and tag (get-type-info tag))) + info)))) ;;; Type matcher macro ;;; (type-match type @@ -119,15 +142,16 @@ ;;; ;;; Returns #f if nothing of that name was declared (define (map-fields struct-union-enum fn) - (let ((info (get-type-info struct-union-enum))) + (let ((info (resolve-type-info struct-union-enum))) (and info (case (car info) ((struct union) (map (lambda (field) (fn (car field) (cadr field))) (caddr info))) - ;; An enumerator's type is the enum itself. + ;; An enumerator's type is the enum itself -- named as it was + ;; declared, since `enum some-typedef' is not a C type. ((enum) - (let ((type (list 'enum struct-union-enum))) + (let ((type (list 'enum (cadr info)))) (map (lambda (value) (fn value type)) (caddr info)))) (else #f))))) -- 2.52.0 From 9763f5fa8d984ad4077217847555fc474f906567 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 16 Sep 2026 01:21:53 +0300 Subject: [PATCH 10/14] export explicitly from the test build's types module --- tests/types.module.scm | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/tests/types.module.scm b/tests/types.module.scm index bee50e2..8ae1186 100644 --- a/tests/types.module.scm +++ b/tests/types.module.scm @@ -1,3 +1,14 @@ (module types - * + (add-struct + add-union + add-enum + add-typedef + add-define + + type-match + map-fields + + get-type-info + get-fields + get-underlying-type) "../types.scm") -- 2.52.0 From 294a27590580a488032cb7a7b79928e79a3f1136 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 16 Sep 2026 01:20:03 +0300 Subject: [PATCH 11/14] fail when the C compiler fails, and clean up when we do compile-to-file returned process-wait's values and main dropped them, so cc errors were printed, but then main compiler exited 0. Also cleanup tmp C files when compilation failed. --- Makefile | 8 ++++++-- sexc.scm | 26 ++++++++++++++++++-------- tests/exit-code/Makefile | 26 ++++++++++++++++++++++++++ tests/exit-code/hello.sex | 4 ++++ tests/exit-code/nested-pointer.sex | 4 ++++ 5 files changed, 58 insertions(+), 10 deletions(-) create mode 100644 tests/exit-code/Makefile create mode 100644 tests/exit-code/hello.sex create mode 100644 tests/exit-code/nested-pointer.sex diff --git a/Makefile b/Makefile index 930f804..22b1152 100644 --- a/Makefile +++ b/Makefile @@ -67,8 +67,12 @@ SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize check-modules: sexc @$(MAKE) --no-print-directory -C ./tests/modules check SEXC=../../sexc +# The failure paths are checked end to end; see tests/exit-code/Makefile. +check-exit-code: sexc + @$(MAKE) --no-print-directory -C ./tests/exit-code check SEXC=../../sexc + run-tests: sexc sex-tests sextest - ./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) && $(MAKE) check-modules + ./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) && $(MAKE) check-modules && $(MAKE) check-exit-code clean: rm -f $(OBJ) main.o @@ -77,4 +81,4 @@ clean: rm -f sexc sex-tests sextest $(MAKE) -C ./tests/modules clean -.PHONY: clean run-tests sex-tests sextest check-modules +.PHONY: clean run-tests sex-tests sextest check-modules check-exit-code diff --git a/sexc.scm b/sexc.scm index d98e427..b807bb0 100644 --- a/sexc.scm +++ b/sexc.scm @@ -2,6 +2,7 @@ (scheme base) ; call/cc brev-separate (chicken base) + (chicken condition) ; handle-exceptions (chicken file) (chicken plist) (chicken pretty-print) @@ -117,15 +118,22 @@ (emit-c sex-forms))))) (define (compile-to-file sex-forms output args cc-args) + "Hand the generated C to the C compiler. Returns the compiler's exit +status, which is ours to pass on." (let ((compiler (or (get-arg args 'c-compiler #f) (get-env-var "SEX_CC") "cc")) (out-file (if (eq? output 'default) "a.out" - output))) - ;; The generated C goes to a temporary .c file rather than the - ;; compiler's stdin - (let ((c-file (create-temporary-file "c"))) + output)) + ;; The generated C goes to a temporary .c file rather than the + ;; compiler's stdin. It is removed however we leave -- emit-c + ;; can throw, and used to leave the file behind when it did + (c-file (create-temporary-file "c"))) + ;; An unhandled error ends the process without unwinding, so the + ;; cleanup cannot be left to dynamic-wind + (handle-exceptions exn + (begin (delete-file* c-file) (abort exn)) (with-output-to-file c-file (lambda () (emit-c sex-forms))) (let ((proc (process compiler (append (list "-o" out-file) @@ -135,9 +143,9 @@ (list c-file) cc-args)))) (call-with-values (lambda () (process-wait proc)) - (lambda status + (lambda (pid normal-exit? status) (delete-file* c-file) - (apply values status))))))) + (if normal-exit? status 1))))))) (define (semantic-process-forms raw-forms input-source) (if (eq? input-source 'stdin) @@ -198,5 +206,7 @@ (get-arg args 'emit-c #f)) ;; Emit processed and macro-expanded sex code, or emit C code (emit-c-or-sex sex-forms output args) - ;; Compile file! - (compile-to-file sex-forms output args cc-args))))))) + ;; Compile file! The C compiler's status is ours too + (let ((status (compile-to-file sex-forms output args cc-args))) + (unless (zero? status) + (exit status))))))))) diff --git a/tests/exit-code/Makefile b/tests/exit-code/Makefile new file mode 100644 index 0000000..4dc32f4 --- /dev/null +++ b/tests/exit-code/Makefile @@ -0,0 +1,26 @@ +# The failure paths. +# +# Both need a process to show themselves, so neither fits the unit +# suite: sexc has to fail when cc fails -- exiting 0 after a failed +# compile makes every driver, sextest included, read it as success -- +# and it has to clean up its temporary .c when its own emission throws. +# +# Everything is built inside a scratch TMPDIR, so nothing is left here +# to clean up. + +SEXC ?= ../../sexc + +check: + @d=`mktemp -d`; \ + TMPDIR=$$d $(SEXC) nested-pointer.sex -o $$d/out >/dev/null 2>&1; \ + if [ -n "`find $$d -name '*.c'`" ]; then \ + echo "exit code FAILED: the temporary .c survived a failed emission"; \ + rm -rf $$d; exit 1; \ + fi; \ + if $(SEXC) hello.sex -o $$d/out -- -no-such-cc-flag >/dev/null 2>&1; then \ + echo "exit code FAILED: sexc reported success after cc failed"; \ + rm -rf $$d; exit 1; \ + fi; \ + rm -rf $$d; echo "exit code ok" + +.PHONY: check diff --git a/tests/exit-code/hello.sex b/tests/exit-code/hello.sex new file mode 100644 index 0000000..39e4859 --- /dev/null +++ b/tests/exit-code/hello.sex @@ -0,0 +1,4 @@ +;;; Compiles cleanly, so the only way the build can fail is the bogus +;;; flag handed to cc -- which is the point. +(pub fn main () int + (return 0)) diff --git a/tests/exit-code/nested-pointer.sex b/tests/exit-code/nested-pointer.sex new file mode 100644 index 0000000..3f69419 --- /dev/null +++ b/tests/exit-code/nested-pointer.sex @@ -0,0 +1,4 @@ +;;; Rejected by the writer, so emit-c throws: there is a temporary .c +;;; by then, and it must not survive. +(fn f () void + (var p (* (* char)))) -- 2.52.0 From 6e4cb80424dfaa48fa085c82510d5faef260d3a0 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 16 Sep 2026 17:41:31 +0300 Subject: [PATCH 12/14] make sextest's (compilation ...) form work 1. Look for `compilation', not `compile' among the source 2. Read the file with provided --features from the (compilation ...) form, then handle resulting file to sexc --- .gitignore | 2 ++ tools/sextest/reader.module.scm | 5 ++- tools/sextest/sextest.scm | 61 ++++++++++++++++++++++++--------- 3 files changed, 50 insertions(+), 18 deletions(-) diff --git a/.gitignore b/.gitignore index dbdf980..e50abab 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,5 @@ *.link sexc sex-tests +sextest +tools/sextest/sextest diff --git a/tools/sextest/reader.module.scm b/tools/sextest/reader.module.scm index 2037c32..d3358e7 100644 --- a/tools/sextest/reader.module.scm +++ b/tools/sextest/reader.module.scm @@ -1,3 +1,6 @@ (module reader (read-from-file - read-raw-forms) + read-raw-forms + + current-features + platform-features) "../../reader.scm") diff --git a/tools/sextest/sextest.scm b/tools/sextest/sextest.scm index 1ee4c75..decb2e5 100644 --- a/tools/sextest/sextest.scm +++ b/tools/sextest/sextest.scm @@ -7,36 +7,63 @@ (chicken port) (chicken process) (chicken process-context) + (chicken string) ; string-split fmt getopt-long reader ; read-raw-forms, shared with sexc - srfi-1) + srfi-1 + srfi-13) ; string-prefix? (define (print-help) (fmt #t "Usage: sextest [options] filename" nl "Options:" nl (usage opts-grammar) nl)) -(define (process-file target-path) - (let ((contents (read-raw-forms target-path))) - (foldl (lambda (acc elt) - (case (car elt) - ((compilation input output return) - (cons - (append (car acc) (list elt)) - (cdr acc))) - (else - (cons - (car acc) - (append (cdr acc) (list elt)))))) - (cons (list) (list)) - contents))) +(define (split-settings contents) + (foldl (lambda (acc elt) + (case (car elt) + ((compilation input output return) + (cons + (append (car acc) (list elt)) + (cdr acc))) + (else + (cons + (car acc) + (append (cdr acc) (list elt)))))) + (cons (list) (list)) + contents)) -(define (compile src flags sexc) +;;; --features from the (compilation ...) form, which we have to honour +;;; ourselves: the program is read here and printed back out for sexc, +;;; so #+ and #- are resolved on this side +(define (compilation-features settings) + (let ((compilation (assoc 'compilation settings))) + (if compilation + (append-map (lambda (flag) + (if (string-prefix? "--features=" flag) + (map string->symbol + (string-split (substring flag 11) ",")) + (list))) + (string-split (cadr compilation))) + (list)))) + +(define (process-file target-path) + (let* ((first-pass (split-settings (read-raw-forms target-path))) + (features (compilation-features (car first-pass)))) + (if (null? features) + first-pass + (parameterize ((current-features (append (platform-features) features))) + (split-settings (read-raw-forms target-path)))))) + +(define (compile src compilation sexc) (let ((compiler (or (and sexc (cdr sexc)) (get-environment-variable "SEXC") "sexc")) + ;; (compilation "--features=x -- -O2") -- one string + (flags (if compilation + (string-split (cadr compilation)) + (list))) (compiled-file (create-temporary-file))) ;; `process' returns one record; `process-input-port' is named from ;; the child's side, so it is the port we write to. @@ -110,7 +137,7 @@ (let* ((settings-and-src (process-file path)) (settings (car settings-and-src)) (src (cdr settings-and-src)) - (compiled-file (compile src (assoc 'compile settings) sexc))) + (compiled-file (compile src (assoc 'compilation settings) sexc))) (if (not compiled-file) (begin (fmt #t "Failed to compile " path nl) #f) -- 2.52.0 From bf83baa508a77770059a7da6f1ae78bcd756a4b3 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 16 Sep 2026 17:44:56 +0300 Subject: [PATCH 13/14] read-time feature expressions '#+' and '#-' introduce conditional compilation: the form that follows is kept only when the feature expression is true, and otherwise is read and thrown away. An expression is a feature name, or and / or / not of them. They are read time, not compile time. Default features are the host's software-version, software-type and machine-type as CHICKEN reports them, plus what --features flag adds. --- Makefile | 2 +- Readme.org | 45 +++++++++++++++++++++++++++++++-- reader.module.scm | 5 +++- reader.scm | 45 ++++++++++++++++++++++++++++++++- sexc.scm | 29 +++++++++++++++++++++ tests/reader.scm | 45 +++++++++++++++++++++++++++++++++ tests/sex-programs/features.sex | 23 +++++++++++++++++ 7 files changed, 189 insertions(+), 5 deletions(-) create mode 100644 tests/sex-programs/features.sex diff --git a/Makefile b/Makefile index 22b1152..76857fa 100644 --- a/Makefile +++ b/Makefile @@ -61,7 +61,7 @@ sextest: $(MAKE) -C ./tools/sextest sextest cp ./tools/sextest/sextest . -SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize +SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features # Multi-module linking is checked end to end; see tests/modules/Makefile. check-modules: sexc diff --git a/Readme.org b/Readme.org index b3db3fb..9e0b73a 100644 --- a/Readme.org +++ b/Readme.org @@ -31,13 +31,21 @@ Options: --c-compiler=ARG Select C compiler. Defaults to value of SEX_CC environment variable, or if it is empty, to cc -c, --compile-object Compile object file instead of executable program - -C, --preprocess Emit C code + -f, --features=ARG Comma-separated feature names, added to the host's own + for #+ and #- feature expressions. May be given + more than once + --no-platform-features Leave out the host's own features. With --features, + this reads a file the way another platform would + -C, --emit-c Emit C code --public-interface Get module's public interface -h, --help Show this help -m, --macro-expand Emit macro-expanded semantically processed Sex code - (sort of IR). May be useful for debugging -o, --output=ARG Write output to file. Default file name is a.out. If -E or -m options are provided, defaults to stdout + --line-directives=ARG How much #line information to emit: statement (default), + toplevel, or none. `statement' is what makes a debugger + land on the right source line; `none' is for reading -C + output by eye #+end_src ** Compiling Hello World #+begin_src shell @@ -101,6 +109,39 @@ Module's public interface consists of everything declared ~pub~. Structures, function, macros, types, variables can be public. +** Read-time feature expressions +Sex is able to use ~#+~ and ~#-~ for conditional compilation: the form that +follows is kept only when the feature expression is true, and otherwise +is read and thrown away. + +#+begin_src scheme +#+macosx (include OpenGL/gl3.h) +#-macosx (include GL/gl.h) + +#+(and unix (not macosx)) (define HAVE-EPOLL 1) +#+end_src + +An expression is a feature name, or ~and~, ~or~ and ~not~ of them. + +This is read time, not compile time. What does not apply never reaches macro +expansion, the type database or the generated C. + +The features are the host's ~(software-version)~, ~(software-type)~ +and ~(machine-type)~, e.g. ~macosx unix arm64~ or ~linux unix +x86-64~. ~--features~ adds to them: + +#+begin_src shell +sexc prog.sex -f debug,with-sdl +sexc prog.sex --features=debug --features=with-sdl +#+end_src + +A feature is never taken away. The host's features can be disabled, +e.g. for checking output for other platform: + +#+begin_src shell +sexc example/sdl3-triangle.sex -C --no-platform-features --features=linux,unix,x86-64 +#+end_src + ** Syntactic macros Sex has support for syntactic macros. Macro definitions look like functions: they have a name, an argument list and a body. Macro should diff --git a/reader.module.scm b/reader.module.scm index 43a312f..0b0d208 100644 --- a/reader.module.scm +++ b/reader.module.scm @@ -1,3 +1,6 @@ (module reader (read-from-file - read-raw-forms) + read-raw-forms + + current-features + platform-features) "reader.scm") diff --git a/reader.scm b/reader.scm index e902114..45b8fd5 100644 --- a/reader.scm +++ b/reader.scm @@ -7,6 +7,8 @@ ;;; - a leading `.' rewritten to the symbol `dot-access' ;;; - `;' comments preserved as (comment "...") forms, so they can be ;;; re-emitted into the generated C (keeping the source mapping) +;;; - #+ / #- feature expressions, which decide at read time what the +;;; compiler gets to see at all ;;; It also records the source location of every form it reads (see ;;; utils' form-source), so the C writer can emit #line directives. @@ -15,6 +17,8 @@ (scheme base) ; make-parameter (chicken base) (chicken pathname) + (chicken platform) ; software-version, machine-type + (only srfi-1 every any) ; srfi-1 also has an append-reverse utils) ;;; Sentinels for structural tokens @@ -160,7 +164,8 @@ ((string->number s) => identity) (else (string->symbol s)))) -;;; #-dispatch: booleans, characters, vectors, block/datum comments +;;; #-dispatch: booleans, characters, vectors, block/datum comments, +;;; feature expressions (define (read-hash port) (let ((c (get-ch port))) (cond @@ -171,8 +176,46 @@ ((char=? c #\() (list->vector (read-list port close-paren))) ((char=? c #\|) (skip-block-comment port 1) (next-token port)) ((char=? c #\;) (read-datum port) (next-token port)) ; datum comment + ((char=? c #\+) (read-conditional port #t)) + ((char=? c #\-) (read-conditional port #f)) (else (error "Unsupported # syntax" c))))) +;;; Feature expressions +;;; +;;; #+linux (include GL/gl.h) kept on Linux +;;; #-macosx (foo) kept only on other than macOS +;;; #+(and unix (not macosx)) (bar) and / or / not combine them +;;; +(define (platform-features) + (list (software-version) (software-type) (machine-type))) + +;;; The host's features are the default, so anything reading Sex sees +;;; what the compiler would. sexc rebinds this to add --features +(define current-features (make-parameter (platform-features))) + +(define (feature-true? test) + (cond + ((symbol? test) (and (memq test (current-features)) #t)) + ((pair? test) + (case (car test) + ((and) (every feature-true? (cdr test))) + ((or) (any feature-true? (cdr test))) + ((not) + (if (and (pair? (cdr test)) (null? (cddr test))) + (not (feature-true? (cadr test))) + (error "Feature expression `not' takes exactly one operand" test))) + (else (error "Unknown operator in feature expression" (car test))))) + (else (error "Malformed feature expression" test)))) + +;;; The #-/#+ preceded datum is always read -- there is no other way +;;; to know where it ends -- and then either returned or dropped +(define (read-conditional port keep-when) + (let ((keep (eq? keep-when (feature-true? (read-datum port))))) + (if keep + (read-datum port) + (begin (read-datum port) + (next-token port))))) + ;;; #t / #true / #f / #false. `val' is the boolean; consume any ;;; trailing name characters and validate (define (read-bool port val) diff --git a/sexc.scm b/sexc.scm index b807bb0..111e8f2 100644 --- a/sexc.scm +++ b/sexc.scm @@ -9,6 +9,7 @@ (chicken process) (chicken process-context) (chicken port) + (chicken string) ; string-split fmt fmt-c-writer getopt-long @@ -31,6 +32,17 @@ (required #f) (value #f) (single-char #\c)) + (features ,(fmt #f "Comma-separated feature names, added to the host's own" nl + (pad padding) "for #+ and #- feature expressions. May be given" nl + (pad padding) "more than once") + (required #f) + (value #t) + (single-char #\f)) + (no-platform-features + ,(fmt #f "Leave out the host's own features. With --features," nl + (pad padding) "this reads a file the way another platform would") + (required #f) + (value #f)) (emit-c "Emit C code" (required #f) (value #f) @@ -98,6 +110,15 @@ ((equal? v "none") 'none) (else (error "--line-directives must be statement, toplevel or none, got" v))))) + + +;;; --features may be given more than once, and each may name several. +;;; Collect all of them +(define (cli-features args) + (append-map (lambda (entry) + (map string->symbol (string-split (cdr entry) ","))) + (filter (lambda (entry) (eq? (car entry) 'features)) args))) + (define (get-input-file args) (let ((rest-args (get-rest-args args))) (if (null? rest-args) @@ -181,6 +202,14 @@ status, which is ours to pass on." (when help (print-help) (return #f)) + ;; Read time comes before everything, so the features have to be + ;; in place before the first form is read + (current-features + (append (if (get-arg args 'no-platform-features #f) + (list) + (platform-features)) + (cli-features args))) + (when (get-arg args 'public-interface #f) (assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument") diff --git a/tests/reader.scm b/tests/reader.scm index bb709e7..b525b05 100644 --- a/tests/reader.scm +++ b/tests/reader.scm @@ -1,6 +1,14 @@ (import (chicken port) reader) +(define-syntax feature-test + (syntax-rules () + ((feature-test result features string) + (test result + (parameterize ((current-features 'features)) + (with-input-from-string string + (lambda () (read-raw-forms 'stdin)))))))) + (define-syntax reader-test (syntax-rules () ((reader-test result string) @@ -38,4 +46,41 @@ (reader-test '((a b) (comment " t")) "(a b) ; t") ;; a `;' inside a string is not a comment (reader-test '("a;b") "\"a;b\"") + + ;; #+ / #- feature expressions. What does not apply is read and + ;; dropped, so it never reaches the compiler at all + (feature-test '((a)) (linux) "#+linux (a)") + (feature-test '() (macosx) "#+linux (a)") + (feature-test '() (linux) "#-linux (a)") + (feature-test '((a)) (macosx) "#-linux (a)") + ;; the guarded datum can be anything, not only a list + (feature-test '(42) (x) "#+x 42") + (feature-test '("s") (x) "#+x \"s\"") + + ;; and / or / not + (feature-test '((a)) (unix linux) "#+(and unix linux) (a)") + (feature-test '() (unix) "#+(and unix linux) (a)") + (feature-test '((a)) (unix) "#+(or linux unix) (a)") + (feature-test '() (bsd) "#+(or linux unix) (a)") + (feature-test '((a)) (unix) "#+(and unix (not macosx)) (a)") + (feature-test '() (unix macosx) "#+(and unix (not macosx)) (a)") + ;; (and) is true and (or) is false, as they are in CL + (feature-test '((a)) () "#+(and) (a)") + (feature-test '() () "#+(or) (a)") + + ;; a guard inside a form, including as the last element -- dropping + ;; continues with the next token, so the closing paren still arrives + (feature-test '((f 1 3)) (a) "(f #+a 1 #-a 2 3)") + (feature-test '((f 2 3)) (b) "(f #+a 1 #-a 2 3)") + (feature-test '((f 1)) (a) "(f #+a 1 #+b 2)") + (feature-test '((f)) (b) "(f #+a 1)") + ;; ...and as the last form in the file + (feature-test '((a)) (x) "(a) #+y (b)") + + ;; guards nest + (feature-test '((a)) (x y) "#+x #+y (a)") + (feature-test '((b)) (x) "#+x #+y (a) (b)") + + ;; a feature the program was not given is simply absent + (feature-test '() () "#+anything (a)") ) diff --git a/tests/sex-programs/features.sex b/tests/sex-programs/features.sex new file mode 100644 index 0000000..7f5006a --- /dev/null +++ b/tests/sex-programs/features.sex @@ -0,0 +1,23 @@ +(compilation "--features=test-on") +(input) +(output "selected" "on" "and-not") +(return 0) + +;;; #+ and #- pick what the compiler gets to see. `test-on' is handed +;;; to sexc by the (compilation ...) form above, so this program reads +;;; the same way on every platform. + +(include stdio.h) + +#+test-on (define GREETING "on") +#-test-on (define GREETING "off") + +#-test-on (pub fn main () int (puts "the whole function is dropped") (return 1)) + +(pub fn main () int + ;; ...and inside a form, not only at toplevel + (puts #+test-on "selected" #-test-on "rejected") + (puts GREETING) + #+(and test-on (not test-off)) (puts "and-not") + #-test-on (puts "never printed") + (return 0)) -- 2.52.0 From a221e0f8ea7ff3052a72b997e0bb2a61704ed428 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 16 Sep 2026 17:46:06 +0300 Subject: [PATCH 14/14] build the triangle on Linux too does not exist there and -framework is not a gcc flag, so the documented build line failed with no hint why. #+macosx picks the header now, and both build lines are in the file -- pkg-config carries the flags on either platform, apart from Apple's GL framework, which has no pkg-config file to carry. --- example/sdl3-triangle.sex | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/example/sdl3-triangle.sex b/example/sdl3-triangle.sex index cae2b68..06eb20c 100644 --- a/example/sdl3-triangle.sex +++ b/example/sdl3-triangle.sex @@ -8,13 +8,29 @@ ;;; triangle is and how far it has spun are passed in as uniforms, so ;;; the geometry itself is uploaded once and never touched again. ;;; -;;; Build: +;;; Build, macOS: ;;; ./sexc example/sdl3-triangle.sex -o sdl3-triangle -- `pkg-config --cflags --libs sdl3` -framework OpenGL +;;; +;;; Build, Linux: +;;; ./sexc example/sdl3-triangle.sex -o sdl3-triangle -- `pkg-config --cflags --libs sdl3 gl` +;;; +;;; The GL header is the one platform difference, and #+ / #- picks it. +;;; Apple keeps the core-profile entry points in and +;;; links them through -framework OpenGL, which no pkg-config file +;;; describes; everywhere else the prototypes come from +;;; with GL_GLEXT_PROTOTYPES defined, and -lGL -- `pkg-config --libs +;;; gl' -- resolves them. SDL3/SDL_opengl.h is not the shortcut it +;;; looks like: on Apple it resolves to the 2.1 header, which has no +;;; glGenVertexArrays and so cannot bind the VAO this program needs. -(define GL-SILENCE-DEPRECATION 1) ; OpenGL is deprecated on macOS +#+macosx (define GL-SILENCE-DEPRECATION 1) ; OpenGL is deprecated on macOS (include SDL3/SDL.h) -(include OpenGL/gl3.h) + +#+macosx (include OpenGL/gl3.h) +#-macosx (define GL-GLEXT-PROTOTYPES 1) +#-macosx (include GL/gl.h) +#-macosx (include GL/glext.h) (define WINDOW-WIDTH 800) (define WINDOW-HEIGHT 600) -- 2.52.0