brmlab/brminv
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Reuse sources from hackerbase.

Browse source
This commit is contained in:
Dominik Pantůček 2025-03-31 20:53:38 +02:00
parent 4fb44325de
commit 879107764a
6 changed files with 462 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -1,2 +1,3 @@
*~
brminv
eggs/

20
backend/Makefile
View file

@ -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)

154
backend/command-line.scm Normal file
View file

@ -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)))))
)

118
backend/duck.scm Normal file
View file

@ -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 ...))))
)

112
backend/util-proc.scm Normal file
View file

@ -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)))
)

59
install-eggs.sh Normal file
View file

@ -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