Reuse sources from hackerbase.

backend/duck.scm

@@ -0,0 +1,118 @@
+;;
+;; duck.scm
+;;
+;; Duck - a CHICKEN in-source documentation.
+;;
+;; ISC License
+;;
+;; Copyright 2023 Dominik Pantůček <dominik.pantucek@trustica.cz>
+;;
+;; Permission to use, copy, modify, and/or distribute this software
+;; for any purpose with or without fee is hereby granted, provided
+;; that the above copyright notice and this permission notice appear
+;; in all copies.
+;; 
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
+;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
+;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
+;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(declare (unit duck))
+
+(module
+ duck
+ (
+  module*
+  duck-extract-defines
+  duck-extract-doc
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken syntax))
+
+ (define-syntax duck-extract-defines
+   (syntax-rules
+       (define define/doc
+	 make-parameter
+	 define* define*/doc
+	 define-syntax define-syntax/doc)
+     ((_ (define-syntax id transformer))
+      (define-syntax id transformer))
+     ((_ (define-syntax/doc id doc transformer))
+      (define-syntax id transformer))
+
+     ((_ (define var val))
+      (define var val))
+     ((_ (define/doc var doc val))
+      (define var val))
+
+     ((_ (define/doc var doc arg (make-parameter val)))
+      (define var (make-parameter val)))
+
+     ((_ (define* var val))
+      (define* var val))
+     ((_ (define*/doc var doc val))
+      (define* var val))
+
+     ((_ (define (proc . args) expr ...))
+      (define (proc . args) expr ...))
+     ((_ (define/doc (proc . args) doc expr ...))
+      (define (proc . args) expr ...))
+
+     ((_ (define* (proc . args) expr ...))
+      (define* (proc . args) expr ...))
+     ((_ (define*/doc (proc . args) doc expr ...))
+      (define* (proc . args) expr ...))
+
+     ((_ expr)
+      expr)))
+
+ (define-syntax duck-extract-doc
+   (syntax-rules (define/doc make-parameter define*/doc define-syntax/doc syntax-rules)
+     ((_ (define-syntax/doc id doc
+	   (syntax-rules (literal ...)
+	     (pattern template) ...)))
+      (list 'STX 'id `doc '(pattern ...)))
+     ((_ (define-syntax/doc id doc transformer))
+      (list 'STX 'id `doc))
+     ((_ (define/doc (proc . args) doc expr ...))
+      (list 'FUN 'proc `doc 'args))
+     ((_ (define*/doc (proc . args) doc expr ...))
+      (list 'FUN 'proc `doc 'args))
+     ((_ (define/doc var doc arg (make-parameter val)))
+      (list 'PAR 'var `doc 'arg 'val))
+     ((_ (define*/doc var doc arg (make-parameter val)))
+      (list 'PAR 'var `doc 'arg 'val))
+     ((_ (define/doc var doc val))
+      (list 'VAR 'var `doc 'val))
+     ((_ (define*/doc var doc val))
+      (list 'VAR 'var `doc 'val))
+     ((_ expr)
+      #f)))
+
+ (define-syntax module*
+   (syntax-rules (#:doc)
+     ((_ modname #:doc (doc ...) exports expr ...)
+      (module
+       modname
+       exports
+       (import scheme
+	       (chicken module)
+	       (chicken base)
+	       duck
+	       )
+       (export modname)
+       (duck-extract-defines expr) ...
+       (define modname
+	 (list (list 'MOD 'modname `(doc ...))
+	       (duck-extract-doc expr) ...))))
+     ((_ modname expr ...)
+      (module* modname #:doc () expr ...))))
+ 
+ )