From 879107764ae78c0c9f8335acb40439b7c4cbf915 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?=
 <dominik.pantucek@trustica.cz>
Date: Mon, 31 Mar 2025 20:53:38 +0200
Subject: [PATCH] Reuse sources from hackerbase.

---
 .gitignore               |   1 +
 backend/Makefile         |  20 ++++-
 backend/command-line.scm | 154 +++++++++++++++++++++++++++++++++++++++
 backend/duck.scm         | 118 ++++++++++++++++++++++++++++++
 backend/util-proc.scm    | 112 ++++++++++++++++++++++++++++
 install-eggs.sh          |  59 +++++++++++++++
 6 files changed, 462 insertions(+), 2 deletions(-)
 create mode 100644 backend/command-line.scm
 create mode 100644 backend/duck.scm
 create mode 100644 backend/util-proc.scm
 create mode 100644 install-eggs.sh

diff --git a/.gitignore b/.gitignore
index 8b25d04..51e1df7 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,2 +1,3 @@
 *~
 brminv
+eggs/
diff --git a/backend/Makefile b/backend/Makefile
index e2469f5..58c54bb 100644
--- a/backend/Makefile
+++ b/backend/Makefile
@@ -5,8 +5,9 @@ default: ../brminv
 SCRP=$(shell chicken-install -repository)
 CSC=CHICKEN_REPOSITORY_PATH=../eggs:$(SCRP) csc
 
-BRMINV_SOURCES=brminv.scm frontend.import.scm
-BRMINV_OBJS=brminv.o frontend.o
+BRMINV_SOURCES=brminv.scm frontend.import.scm command-line.import.scm	\
+	util-proc.import.scm duck.import.scm
+BRMINV_OBJS=brminv.o frontend.o command-line.o util-proc.o duck.o
 
 %.o: %.scm
 	$(CSC) -c -static $<
@@ -26,3 +27,18 @@ frontend.scm:
 BRMINV_SOURCES=brminv.scm frontend.import.scm
 
 brminv.o: $(BRMINV_SOURCES)
+
+DUCK-SOURCES=duck.scm
+
+duck.o: duck.import.scm
+duck.import.scm: $(DUCK-SOURCES)
+
+UTIL-PROC-SOURCES=util-proc.scm duck.import.scm
+
+util-proc.o: util-proc.import.scm
+util-proc.import.scm: $(UTIL-PROC-SOURCES)
+
+COMMAND-LINE-SOURCES=command-line.scm util-proc.import.scm
+
+command-line.o: command-line.import.scm
+command-line.import.scm: $(COMMAND-LINE-SOURCES)
diff --git a/backend/command-line.scm b/backend/command-line.scm
new file mode 100644
index 0000000..f88e71f
--- /dev/null
+++ b/backend/command-line.scm
@@ -0,0 +1,154 @@
+;;
+;; command-line.scm
+;;
+;; Argument parsing on command-line with interpreter -- support.
+;;
+;; ISC License
+;;
+;; Copyright 2023-2025 Brmlab, z.s.
+;; 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 command-line))
+
+(module
+ command-line
+ (
+  command-line
+
+  command-line:parse-command-line
+  command-line:print-options
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken process-context)
+	 (chicken format)
+	 srfi-1
+	 util-proc)
+
+ ;; Consumes given number of arguments from the list and returns the
+ ;; remainder of the list and a list of arguments consumed.
+ (define (consume-args args num)
+   (let loop ((args args)
+	      (res '())
+	      (num num))
+     (if (= num 0)
+	 (list args (reverse res))
+	 (if (null? args)
+	     (error 'consume-args "Not enough arguments" num)
+	     (loop (cdr args)
+		   (cons (car args) res)
+		   (- num 1))))))
+
+ ;; Gets command-line arguments after the "--" of csi (not useful when
+ ;; compiled)
+ (define (get-command-line-arguments . explicit-argv)
+   (let* ((args (if (null? explicit-argv) (argv) explicit-argv))
+	  (rargs (member "--" args)))
+     (if rargs
+	 (cdr rargs)
+	 (cdr args))))
+
+ ;; Performs the actual parsing based on specification.
+ (define (command-line:parse-command-line specs+comments)
+   (let ((specs (filter (lambda (s) (not (string? s))) specs+comments)))
+     (let loop ((args (get-command-line-arguments)))
+       (when (not (null? args))
+	 (let* ((arg (car args))
+		(specp (assoc arg specs)))
+	   (when (not specp)
+	     (error 'parse-command-line "Unknown argument" arg))
+	   (let* ((proc (caddr specp))
+		  (nargs (procedure-num-args proc))
+		  (aargsl (consume-args (cdr args) nargs))
+		  (args (car aargsl))
+		  (aargs (cadr aargsl)))
+	     (apply proc aargs)
+	     (loop args)))))))
+
+ ;; String representation of procedure arguments.
+ (define (procedure->argstring proc)
+   (let* ((args (procedure-arg-names proc))
+	  (argss (sprintf "~A" args)))
+     (substring
+      (substring argss 0 (- (string-length argss) 1))
+      1)))
+
+ ;; Prints options descriptions.
+ (define (command-line:print-options specs)
+   (let* ((descrs (map (lambda (spec)
+			 (if (string? spec)
+			     spec
+			     (list (car spec)
+				   (procedure->argstring (caddr spec))
+				   (cadr spec))))
+		       specs))
+	  (owidth (apply max (map (lambda (desc)
+				    (if (string? desc)
+					0
+					(string-length (car desc))))
+				  descrs)))
+	  (awidth (apply max (map (lambda (desc)
+				    (if (string? desc)
+					0
+					(string-length (cadr desc))))
+				  descrs))))
+     (let loop ((descrs descrs))
+       (when (not (null? descrs))
+	 (let ((desc (car descrs)))
+	   (if (string? desc)
+	       (print desc)
+	       (let* ((opt (car desc))
+		      (args (cadr desc))
+		      (help (caddr desc)))
+		 (print "  "
+			opt
+			(make-string (- owidth (string-length opt)) #\space)
+			" "
+			args
+			(make-string (- awidth (string-length args)) #\space)
+			"  "
+			help)))
+	   (loop (cdr descrs)))))))
+
+ ;; Syntax for expanding various types of options.
+ (define-syntax make-option
+   (syntax-rules ()
+     ((_ (opt (args ...) help body ...))
+      (list (symbol->string 'opt)
+	    help
+	    (lambda (args ...) body ...)))
+     ((_ str)
+      str)))
+
+ (define-syntax make-options
+   (syntax-rules ()
+     ((_ exp ...)
+      (list (make-option exp) ...))))
+
+ ;; Simple syntax wrapper for command-line arguments specification and
+ ;; immediate parsing.
+ (define-syntax command-line
+   (syntax-rules ()
+     ((_ print-help exps ...)
+      (letrec ((specs (make-options exps ...))
+	       (print-help (lambda ()
+			     (command-line:print-options specs))))
+	(command-line:parse-command-line specs)))))
+
+ )
diff --git a/backend/duck.scm b/backend/duck.scm
new file mode 100644
index 0000000..87f9378
--- /dev/null
+++ b/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 ...))))
+ 
+ )
diff --git a/backend/util-proc.scm b/backend/util-proc.scm
new file mode 100644
index 0000000..1e9d85c
--- /dev/null
+++ b/backend/util-proc.scm
@@ -0,0 +1,112 @@
+;;
+;; util-proc.scm
+;;
+;; Auxiliary procedure functions.
+;;
+;; ISC License
+;;
+;; Copyright 2023 Brmlab, z.s.
+;; 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 util-proc))
+
+(import duck)
+
+(module*
+ util-proc
+ #:doc ("This module provides a few simple procedures for querying properties
+of other procedures.")
+ (
+  improper-list-info
+
+  procedure-arity=?
+  procedure-arity>=?
+  procedure-arity>?
+
+  procedure-num-args
+  procedure-arg-names
+  )
+
+ (import scheme
+	 (chicken base))
+ 
+ (define/doc (improper-list-info lst)
+   ("Returns two values: the proper part of the list length and #t if
+there is an improper list end")
+   (let loop ((lst lst)
+	      (len 0))
+     (if (symbol? lst)
+	 (values len #t)
+	 (if (null? lst)
+	     (values len #f)
+	     (loop (cdr lst)
+		   (add1 len))))))
+
+ ;; Returns two values: the number of mandatory arguments and
+ ;; information whether the procedure accepts optional arguments
+ (define (procedure-arity-info proc)
+   (let-values (((len rest?) (improper-list-info (procedure-information proc))))
+     (values (sub1 len) rest?)))
+
+ (define/doc ((procedure-arity=? n) proc)
+   ("* ```n``` - integer representing the number of arguments
+* ```proc``` - procedure to query
+
+Returns true if the procedure ```proc``` accepts exactly ```n```
+arguments.")
+   (let-values (((args rest?) (procedure-arity-info proc)))
+     (and (not rest?)
+	  (= args n))))
+
+ (define/doc ((procedure-arity>=? n) proc)
+   ("* ```n``` - integer representing the number of arguments
+* ```proc``` - procedure to query
+
+Returns true if the procedure ```proc``` accepts at least ```n```
+arguments.")
+   (let-values (((args rest?) (procedure-arity-info proc)))
+     (or rest?
+	 (>= args n))))
+
+ (define/doc ((procedure-arity>? n) proc)
+   ("* ```n``` - integer representing the number of arguments
+* ```proc``` - procedure to query
+
+Returns true if the procedure ```proc``` accepts more than ```n```
+arguments.")
+   (let-values (((args rest?) (procedure-arity-info proc)))
+     (or rest?
+	 (> args n))))
+
+ (define/doc (procedure-num-args proc)
+   ("* ```proc``` - procedure to check
+
+Returns the number of mandatory arguments.")
+   (let-values (((args rest?) (procedure-arity-info proc)))
+     args))
+
+ (define/doc (procedure-arg-names proc)
+   ("* ```proc``` - procedure to check
+
+Returns the (possibly improper) list of arguments the procedure
+```proc``` accepts. If it accepts arbitrary number of arguments, it is
+signalled by simple symbol instead of pair at the last position. If it
+accepts an exact number of arguments, it returns a proper list.")
+   (cdr (procedure-information proc)))
+
+ )
diff --git a/install-eggs.sh b/install-eggs.sh
new file mode 100644
index 0000000..0ec409b
--- /dev/null
+++ b/install-eggs.sh
@@ -0,0 +1,59 @@
+#!/bin/sh
+#
+# install-eggs.sh
+#
+# Local installer of CHICKEN eggs required for building.
+#
+# ISC License
+#
+# Copyright 2023 Brmlab, z.s.
+# 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.
+#
+
+# Source root directory
+owd=$(pwd)
+cd $(dirname "$0")
+SRCDIR=$(pwd)
+cd "$owd"
+
+# Make temporary prefix directory (eggs shared throwaway files)
+TMPDIR=$(mktemp -d)
+
+# Installs given egg locally
+chicken_install() {
+    echo "Installing $1 ..."
+    CHICKEN_INSTALL_PREFIX="$TMPDIR" \
+			  CHICKEN_REPOSITORY_PATH="$SRCDIR/eggs":`chicken-install -repository` \
+			  CHICKEN_INSTALL_REPOSITORY="$SRCDIR/eggs" \
+			  chicken-install "$1" 2>&1 | \
+	sed -u 's/^/  /'
+}
+
+# Removes throwaway files
+chicken_cleanup() {
+    echo "Cleaning up ..."
+    rm -fr ${TMPDIR}
+}
+
+# Always cleanup
+trap chicken_cleanup INT QUIT
+
+# Install required eggs
+chicken_install spiffy
+
+# Normal termination cleanup
+chicken_cleanup