diff --git a/src/Makefile b/src/Makefile index 110f433..7ca6aab 100644 --- a/src/Makefile +++ b/src/Makefile @@ -46,7 +46,7 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o month.o period.o ansi.o \ bank-account.o bank-fio.o members-payments.o member-parser.o \ web-static.o environment.o mailman.o util-set-list.o \ util-time.o util-tag.o util-io.o util-string.o util-io.o \ - util-list.o util-parser.o texts.o tests.o + util-list.o util-parser.o texts.o tests.o util-proc.o .PHONY: imports imports: $(HACKERBASE-DEPS) @@ -69,7 +69,7 @@ install: static $(CSC) -c -static $< %.import.scm: %.scm - rm -f $@ + @rm -f $@ $(CSC) -P -J $< ################################################################ @@ -303,3 +303,8 @@ TESTS-SOURCES=tests.scm listing.import.scm util-dict-list.import.scm \ tests.o: tests.import.scm tests.import.scm: $(TESTS-SOURCES) + +UTIL-PROC-SOURCES=util-proc.scm + +util-proc.o: util-proc.import.scm +util-proc.import.scm: $(UTIL-PROC-SOURCES) diff --git a/src/util-proc.scm b/src/util-proc.scm new file mode 100644 index 0000000..78fe9fe --- /dev/null +++ b/src/util-proc.scm @@ -0,0 +1,75 @@ +;; +;; util-proc.scm +;; +;; Auxiliary procedure functions. +;; +;; ISC License +;; +;; Copyright 2023 Brmlab, z.s. +;; Dominik Pantůček +;; +;; 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)) + +(module + util-proc + ( + procedure-arity=? + procedure-arity>=? + procedure-arity>? + ) + + (import scheme + (chicken base)) + + ;; Returns two values: the proper part of the list length and #t if + ;; there is an improper list end + (define (improper-list-info lst) + (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?))) + + ;; Returns true if given procedure arity is exactly n + (define ((procedure-arity=? n) proc) + (let-values (((args rest?) (procedure-arity-info proc))) + (and (not rest?) + (= args n)))) + + ;; Returns true if given procedure arity is greater than or equal to n + (define ((procedure-arity>=? n) proc) + (let-values (((args rest?) (procedure-arity-info proc))) + (or rest? + (>= args n)))) + + ;; Returns true if given procedure arity is greater than n + (define ((procedure-arity>? n) proc) + (let-values (((args rest?) (procedure-arity-info proc))) + (or rest? + (> args n)))) + + )