kylekrein/live-bootstrap
1
0
Fork 0
mirror of https://github.com/fosslinux/live-bootstrap.git synced 2026-03-13 14:55:24 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions 2

Add mes and mescc-tools-extra

Browse source 
mescc-tools-extra contains two important tools:
- cp
- chmod

mes first builds itself from a mes 0.21 seed as used by guix, and then
builds a mes 0.22 and then mes 0.22 using that created mes 0.22.

It does /not/ use bootstrap.sh as we don't have a proper shell at this
point, it has been manually adapted for kaem.
This commit is contained in:
fosslinux 2020-12-25 18:40:14 +11:00
parent 2706e07556
commit 649d7b68dc
1029 changed files with 120985 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

433
sysa/mes-0.22/module/mes/getopt-long.scm Normal file
View file

@ -0,0 +1,433 @@
;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc.
;;; Copyright (C) 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
;;; (regexps removed by Jan (janneke) Nieuwenhuizen)
;;; (srfi-9 backport by Jan (janneke) Nieuwenhuizen)
;;; Commentary:
;;; This module implements some complex command line option parsing, in
;;; the spirit of the GNU C library function `getopt_long'. Both long
;;; and short options are supported.
;;;
;;; The theory is that people should be able to constrain the set of
;;; options they want to process using a grammar, rather than some arbitrary
;;; structure. The grammar makes the option descriptions easy to read.
;;;
;;; `getopt-long' is a procedure for parsing command-line arguments in a
;;; manner consistent with other GNU programs. `option-ref' is a procedure
;;; that facilitates processing of the `getopt-long' return value.
;;; (getopt-long ARGS GRAMMAR)
;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
;;;
;;; ARGS should be a list of strings. Its first element should be the
;;; name of the program; subsequent elements should be the arguments
;;; that were passed to the program on the command line. The
;;; `program-arguments' procedure returns a list of this form.
;;;
;;; GRAMMAR is a list of the form:
;;; ((OPTION (PROPERTY VALUE) ...) ...)
;;;
;;; Each OPTION should be a symbol. `getopt-long' will accept a
;;; command-line option named `--OPTION'.
;;; Each option can have the following (PROPERTY VALUE) pairs:
;;;
;;; (single-char CHAR) --- Accept `-CHAR' as a single-character
;;; equivalent to `--OPTION'. This is how to specify traditional
;;; Unix-style flags.
;;; (required? BOOL) --- If BOOL is true, the option is required.
;;; getopt-long will raise an error if it is not found in ARGS.
;;; (value BOOL) --- If BOOL is #t, the option accepts a value; if
;;; it is #f, it does not; and if it is the symbol
;;; `optional', the option may appear in ARGS with or
;;; without a value.
;;; (predicate FUNC) --- If the option accepts a value (i.e. you
;;; specified `(value #t)' for this option), then getopt
;;; will apply FUNC to the value, and throw an exception
;;; if it returns #f. FUNC should be a procedure which
;;; accepts a string and returns a boolean value; you may
;;; need to use quasiquotes to get it into GRAMMAR.
;;;
;;; The (PROPERTY VALUE) pairs may occur in any order, but each
;;; property may occur only once. By default, options do not have
;;; single-character equivalents, are not required, and do not take
;;; values.
;;;
;;; In ARGS, single-character options may be combined, in the usual
;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy"). If an option
;;; accepts values, then it must be the last option in the
;;; combination; the value is the next argument. So, for example, using
;;; the following grammar:
;;; ((apples (single-char #\a))
;;; (blimps (single-char #\b) (value #t))
;;; (catalexis (single-char #\c) (value #t)))
;;; the following argument lists would be acceptable:
;;; ("-a" "-b" "bang" "-c" "couth") ("bang" and "couth" are the values
;;; for "blimps" and "catalexis")
;;; ("-ab" "bang" "-c" "couth") (same)
;;; ("-ac" "couth" "-b" "bang") (same)
;;; ("-abc" "couth" "bang") (an error, since `-b' is not the
;;; last option in its combination)
;;;
;;; If an option's value is optional, then `getopt-long' decides
;;; whether it has a value by looking at what follows it in ARGS. If
;;; the next element is does not appear to be an option itself, then
;;; that element is the option's value.
;;;
;;; The value of a long option can appear as the next element in ARGS,
;;; or it can follow the option name, separated by an `=' character.
;;; Thus, using the same grammar as above, the following argument lists
;;; are equivalent:
;;; ("--apples" "Braeburn" "--blimps" "Goodyear")
;;; ("--apples=Braeburn" "--blimps" "Goodyear")
;;; ("--blimps" "Goodyear" "--apples=Braeburn")
;;;
;;; If the option "--" appears in ARGS, argument parsing stops there;
;;; subsequent arguments are returned as ordinary arguments, even if
;;; they resemble options. So, in the argument list:
;;; ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
;;; `getopt-long' will recognize the `apples' option as having the
;;; value "Granny Smith", but it will not recognize the `blimp'
;;; option; it will return the strings "--blimp" and "Goodyear" as
;;; ordinary argument strings.
;;;
;;; The `getopt-long' function returns the parsed argument list as an
;;; assocation list, mapping option names --- the symbols from GRAMMAR
;;; --- onto their values, or #t if the option does not accept a value.
;;; Unused options do not appear in the alist.
;;;
;;; All arguments that are not the value of any option are returned
;;; as a list, associated with the empty list.
;;;
;;; `getopt-long' throws an exception if:
;;; - it finds an unrecognized property in GRAMMAR
;;; - the value of the `single-char' property is not a character
;;; - it finds an unrecognized option in ARGS
;;; - a required option is omitted
;;; - an option that requires an argument doesn't get one
;;; - an option that doesn't accept an argument does get one (this can
;;; only happen using the long option `--opt=value' syntax)
;;; - an option predicate fails
;;;
;;; So, for example:
;;;
;;; (define grammar
;;; `((lockfile-dir (required? #t)
;;; (value #t)
;;; (single-char #\k)
;;; (predicate ,file-is-directory?))
;;; (verbose (required? #f)
;;; (single-char #\v)
;;; (value #f))
;;; (x-includes (single-char #\x))
;;; (rnet-server (single-char #\y)
;;; (predicate ,string?))))
;;;
;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
;;; "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
;;; grammar)
;;; => ((() "foo1" "-fred" "foo2" "foo3")
;;; (rnet-server . "lamprod")
;;; (x-includes . "/usr/include")
;;; (lockfile-dir . "/tmp")
;;; (verbose . #t))
;;; (option-ref OPTIONS KEY DEFAULT)
;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not
;;; found. The value is either a string or `#t'.
;;;
;;; For example, using the `getopt-long' return value from above:
;;;
;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31
;;; Code:
(define-module (mes getopt-long)
#:use-module (ice-9 optargs)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:export (getopt-long option-ref))
(define-record-type option-spec
(%make-option-spec name value required? option-spec->single-char predicate value-policy)
option-spec?
(name
option-spec->name set-option-spec-name!)
(value
option-spec->value set-option-spec-value!)
(required?
option-spec->required? set-option-spec-required?!)
(option-spec->single-char
option-spec->single-char set-option-spec-single-char!)
(predicate
option-spec->predicate set-option-spec-predicate!)
(value-policy
option-spec->value-policy set-option-spec-value-policy!))
(define (make-option-spec name)
(%make-option-spec name #f #f #f #f #f))
(define (parse-option-spec desc)
(let ((spec (make-option-spec (symbol->string (car desc)))))
(for-each (lambda (desc-elem)
(let ((given (lambda () (cadr desc-elem))))
(case (car desc-elem)
((required?)
(set-option-spec-required?! spec (given)))
((value)
(set-option-spec-value-policy! spec (given)))
((single-char)
(or (char? (given))
(error "`single-char' value must be a char!"))
(set-option-spec-single-char! spec (given)))
((predicate)
(set-option-spec-predicate!
spec ((lambda (pred)
(lambda (name val)
(or (not val)
(pred val)
(error "option predicate failed:" name))))
(given))))
(else
(error "invalid getopt-long option property:"
(car desc-elem))))))
(cdr desc))
spec))
(define (split-arg-list argument-list)
;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
;; Discard the "--". If no "--" is found, AFTER-LS is empty.
(let loop ((yes '()) (no argument-list))
(cond ((null? no) (cons (reverse yes) no))
((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
(else (loop (cons (car no) yes) (cdr no))))))
(define (expand-clumped-singles opt-ls)
;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
(let loop ((opt-ls opt-ls) (ret-ls '()))
(cond ((null? opt-ls)
(reverse ret-ls)) ;;; retval
((let ((opt (car opt-ls)))
(and (eq? (string-ref opt 0) #\-)
(> (string-length opt) 1)
(char-alphabetic? (string-ref opt 1))))
(let* ((opt (car opt-ls))
(n (char->integer (string-ref opt 1)))
(sub (substring opt 1 (string-length opt)))
(end (string-index (substring opt 1 (string-length opt)) (negate char-alphabetic?)))
(end (if end (1+ end) (string-length opt)))
(singles-string (substring opt 1 end))
(singles (reverse
(map (lambda (c)
(string-append "-" (make-string 1 c)))
(string->list singles-string))))
(extra (substring opt end)))
(loop (cdr opt-ls)
(append (if (string=? "" extra)
singles
(cons extra singles))
ret-ls))))
(else (loop (cdr opt-ls)
(cons (car opt-ls) ret-ls))))))
(define (looks-like-an-option string)
(eq? (string-ref string 0) #\-))
(define (process-options specs argument-ls stop-at-first-non-option)
;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
;; FOUND is an unordered list of option specs for found options, while ETC
;; is an order-maintained list of elements in ARGUMENT-LS that are neither
;; options nor their values.
(let ((idx (map (lambda (spec)
(cons (option-spec->name spec) spec))
specs))
(sc-idx (map (lambda (spec)
(cons (make-string 1 (option-spec->single-char spec))
spec))
(filter option-spec->single-char specs))))
(let loop ((argument-ls argument-ls) (found '()) (etc '()))
(let ((eat! (lambda (spec ls)
(let ((val!loop (lambda (val n-ls n-found n-etc)
(set-option-spec-value!
spec
;; handle multiple occurrances
(cond ((option-spec->value spec)
=> (lambda (cur)
((if (list? cur) cons list)
val cur)))
(else val)))
(loop n-ls n-found n-etc)))
(ERR:no-arg (lambda ()
(error (string-append
"option must be specified"
" with argument:")
(option-spec->name spec)))))
(cond
((eq? 'optional (option-spec->value-policy spec))
(if (or (null? (cdr ls))
(looks-like-an-option (cadr ls)))
(val!loop #t
(cdr ls)
(cons spec found)
etc)
(val!loop (cadr ls)
(cddr ls)
(cons spec found)
etc)))
((eq? #t (option-spec->value-policy spec))
(if (or (null? (cdr ls))
(looks-like-an-option (cadr ls)))
(ERR:no-arg)
(val!loop (cadr ls)
(cddr ls)
(cons spec found)
etc)))
(else
(val!loop #t
(cdr ls)
(cons spec found)
etc)))))))
(if (null? argument-ls)
(cons found (reverse etc)) ;;; retval
(cond ((let ((opt (car argument-ls)))
(and (eq? (string-ref opt 0) #\-)
(> (string-length opt) 1)
(let ((n (char->integer (string-ref opt 1))))
(or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z)))
(and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))))
(let* ((c (substring (car argument-ls) 1 2))
(spec (or (assoc-ref sc-idx c)
(error "no such option:" (car argument-ls)))))
(eat! spec argument-ls)))
((let ((opt (car argument-ls)))
(and (string-prefix? "--" opt)
(let ((n (char->integer (string-ref opt 2))))
(or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z)))
(and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))
(not (string-index opt #\space))
(not (string-index opt #\=))))
(let* ((opt (substring (car argument-ls) 2))
(spec (or (assoc-ref idx opt)
(error "no such option:" (car argument-ls)))))
(eat! spec argument-ls)))
((let ((opt (car argument-ls)))
(and (string-prefix? "--" opt)
(let ((n (char->integer (string-ref opt 2))))
(or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z)))
(and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))
(or (string-index opt #\=)
(string-index opt #\space))))
(let* ((is (or (string-index (car argument-ls) #\=)
(string-index (car argument-ls) #\space)))
(opt (substring (car argument-ls) 2 is))
(spec (or (assoc-ref idx opt)
(error "no such option:" (substring opt is)))))
(if (option-spec->value-policy spec)
(eat! spec (append
(list 'ignored
(substring (car argument-ls) (1+ is)))
(cdr argument-ls)))
(error "option does not support argument:"
opt))))
(stop-at-first-non-option
(cons found (append (reverse etc) argument-ls)))
(else
(loop (cdr argument-ls)
found
(cons (car argument-ls) etc)))))))))
(define* (getopt-long program-arguments option-desc-list #:key stop-at-first-non-option)
"Process options, handling both long and short options, similar to
the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value
similar to what (program-arguments) returns. OPTION-DESC-LIST is a
list of option descriptions. Each option description must satisfy the
following grammar:
<option-spec> :: (<name> . <attribute-ls>)
<attribute-ls> :: (<attribute> . <attribute-ls>)
| ()
<attribute> :: <required-attribute>
| <arg-required-attribute>
| <single-char-attribute>
| <predicate-attribute>
| <value-attribute>
<required-attribute> :: (required? <boolean>)
<single-char-attribute> :: (single-char <char>)
<value-attribute> :: (value #t)
(value #f)
(value optional)
<predicate-attribute> :: (predicate <1-ary-function>)
The procedure returns an alist of option names and values. Each
option name is a symbol. The option value will be '#t' if no value
was specified. There is a special item in the returned alist with a
key of the empty list, (): the list of arguments that are not options
or option values.
By default, options are not required, and option values are not
required. By default, single character equivalents are not supported;
if you want to allow the user to use single character options, you need
to add a `single-char' clause to the option description."
(let* ((specifications (map parse-option-spec option-desc-list))
(pair (split-arg-list (cdr program-arguments) ))
(split-ls (expand-clumped-singles (car pair)))
(non-split-ls (cdr pair))
(found/etc (process-options specifications split-ls
stop-at-first-non-option))
(found (car found/etc))
(rest-ls (append (cdr found/etc) non-split-ls)))
(for-each (lambda (spec)
(let ((name (option-spec->name spec))
(val (option-spec->value spec)))
(and (option-spec->required? spec)
(or (memq spec found)
(error "option must be specified:" name)))
(and (memq spec found)
(eq? #t (option-spec->value-policy spec))
(or val
(error "option must be specified with argument:"
name)))
(let ((pred (option-spec->predicate spec)))
(and pred (pred name val)))))
specifications)
(cons (cons '() rest-ls)
(let ((multi-count (map (lambda (desc)
(cons (car desc) 0))
option-desc-list)))
(map (lambda (spec)
(let ((name (string->symbol (option-spec->name spec))))
(cons name
;; handle multiple occurrances
(let ((maybe-ls (option-spec->value spec)))
(if (list? maybe-ls)
(let* ((look (assq name multi-count))
(idx (cdr look))
(val (list-ref maybe-ls idx)))
(set-cdr! look (1+ idx)) ; ugh!
val)
maybe-ls)))))
found)))))
(define (option-ref options key default)
"Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
The value is either a string or `#t'."
(or (assq-ref options key) default))
;;; getopt-long.scm ends here

123
sysa/mes-0.22/module/mes/guile.scm Normal file
View file

@ -0,0 +1,123 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (mes guile)
#:export (
<cell:char>
<cell:keyword>
<cell:number>
<cell:pair>
<cell:string>
<cell:symbol>
<cell:vector>
%arch
%compiler
append2
core:apply
core:car
core:display
core:display-error
core:display-port
core:exit
core:macro-expand
core:make-cell
core:write
core:write-error
core:write-port
core:type
%compiler
equal2?
keyword->string
pmatch-car
pmatch-cdr
)
;;#:re-export (open-input-file open-input-string with-input-from-string)
)
(cond-expand
(guile-2)
(guile
(define %host-type (string-append (utsname:machine (uname)) "linux-gnu")))
(else))
(cond-expand
(guile
(define pmatch-car car)
(define pmatch-cdr cdr)
(define core:exit exit)
(define core:display display)
(define core:display-port display)
(define (core:display-error o) (display o (current-error-port)))
(define core:write write)
(define (core:write-error o) (write o (current-error-port)))
(define core:write-port write)
(define core:macro-expand identity)
(define (core:apply f a . m) (apply f a))
(define (core:car f a . m) (apply f a))
(define append2 append)
(define equal2? equal?)
(define guile:keyword? keyword?)
(define guile:number? number?)
(define guile:pair? pair?)
(define guile:string? string?)
(define guile:symbol? symbol?)
(define <cell:char> 0)
(define <cell:keyword> 4)
(define <cell:number> 6)
(define <cell:pair> 7)
(define <cell:string> 10)
(define <cell:symbol> 11)
(define <cell:vector> 15)
(define %arch (car (string-split %host-type #\-)))
(define %compiler "gnuc")
(define %compiler "gnuc")
(define keyword->string (compose symbol->string keyword->symbol))
(define (core:type x)
(cond ((guile:keyword? x) <cell:keyword>)
((guile:number? x) <cell:number>)
((guile:pair? x) <cell:pair>)
((guile:string? x) <cell:string>)
((guile:symbol? x) <cell:symbol>)))
(define (core:car x)
(cond ((guile:string? x) (string->list x))))
(define (core:make-cell type car cdr)
(cond ((eq? type <cell:string>) (list->string car)))))
(mes))
(cond-expand
(guile-2.2)
(guile-2)
(guile
(use-modules (ice-9 syncase))
(define (compose proc . rest)
(if (null? rest) proc
(lambda args
(proc (apply (apply compose rest) args)))))
(export compose))
(mes))

56
sysa/mes-0.22/module/mes/mes-0.scm Normal file
View file

@ -0,0 +1,56 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; mes-0.scm: This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; mes-0.scm is the first file being loaded into Guile. It provides
;;; non-standard definitions that Mes modules and tests depend on.
;;; Code:
(define-module (mes mes-0)
#:export (
builtin?
mes-use-module
EOF
append2
mes?
guile?
guile-1.8?
guile-2?
%arch
%compiler
))
(cond-expand
(guile-2)
(guile
(define %host-type (string-append (utsname:machine (uname)) "linux-gnu")))
(else))
(define-macro (mes-use-module . rest) #t)
(define builtin? procedure?) ; not strictly true, but ok for tests/*.test
(define mes? #f)
(define guile? #t)
(define guile-1.8? (equal? (effective-version) "1.8"))
(define guile-2? (equal? (major-version) "2"))
(define EOF (if #f #f))
(define append2 append)
(define %arch (car (string-split %host-type #\-)))
(define %compiler "gnuc")

77
sysa/mes-0.22/module/mes/misc.scm Normal file
View file

@ -0,0 +1,77 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (mes misc)
#:use-module (srfi srfi-1)
#:export (%scheme
disjoin
guile?
mes?
pk
pke
warn
stderr
string-substitute))
(cond-expand
(mes
(define %scheme "mes"))
(guile
(define %scheme "guile")))
(define guile? (equal? %scheme "guile"))
(define mes? (equal? %scheme "mes"))
(define (logf port string . rest)
(apply format (cons* port string rest))
(force-output port)
#t)
(define (stderr string . rest)
(apply logf (cons* (current-error-port) string rest)))
(define (pk . stuff)
(newline)
(display ";;; ")
(write stuff)
(newline)
(car (last-pair stuff)))
(define (pke . stuff)
(display "\n" (current-error-port))
(newline (current-error-port))
(display ";;; " (current-error-port))
(write stuff (current-error-port))
(display "\n" (current-error-port))
(car (last-pair stuff)))
(define warn pke)
(define (disjoin . predicates)
(lambda (. arguments)
(any (lambda (o) (apply o arguments)) predicates)))
(define (string-substitute string find replace)
(let ((index (string-contains string find)))
(if (not index) string
(string-append
(string-take string index)
replace
(string-substitute
(string-drop string (+ index (string-length find)))
find replace)))))

499
sysa/mes-0.22/module/mes/optargs.scm Normal file
View file

@ -0,0 +1,499 @@
;;;; optargs.scm -- support for optional arguments
;;;;
;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>
;;; Commentary:
;;; {Optional Arguments}
;;;
;;; The C interface for creating Guile procedures has a very handy
;;; "optional argument" feature. This module attempts to provide
;;; similar functionality for procedures defined in Scheme with
;;; a convenient and attractive syntax.
;;;
;;; exported macros are:
;;; let-optional
;;; let-optional*
;;; let-keywords
;;; let-keywords*
;;; lambda*
;;; define*
;;; define*-public
;;; defmacro*
;;; defmacro*-public
;;;
;;;
;;; Summary of the lambda* extended parameter list syntax (brackets
;;; are used to indicate grouping only):
;;;
;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]?
;;; [#:key [ext-var-decl]+ [#:allow-other-keys]?]?
;;; [[#:rest identifier]|[. identifier]]?
;;;
;;; ext-var-decl ::= identifier | ( identifier expression )
;;;
;;; The characters `*', `+' and `?' are not to be taken literally; they
;;; mean respectively, zero or more occurences, one or more occurences,
;;; and one or zero occurences.
;;;
;;; Code:
(define-module (mes optargs)
#:use-module (system base pmatch)
#:replace (lambda*)
#:export-syntax (let-optional
let-optional*
let-keywords
let-keywords*
define*
define*-public
defmacro*
defmacro*-public))
;; let-optional rest-arg (binding ...) . body
;; let-optional* rest-arg (binding ...) . body
;; macros used to bind optional arguments
;;
;; These two macros give you an optional argument interface that is
;; very "Schemey" and introduces no fancy syntax. They are compatible
;; with the scsh macros of the same name, but are slightly
;; extended. Each of binding may be of one of the forms <var> or
;; (<var> <default-value>). rest-arg should be the rest-argument of
;; the procedures these are used from. The items in rest-arg are
;; sequentially bound to the variable namess are given. When rest-arg
;; runs out, the remaining vars are bound either to the default values
;; or to `#f' if no default value was specified. rest-arg remains
;; bound to whatever may have been left of rest-arg.
;;
(defmacro let-optional (REST-ARG BINDINGS . BODY)
(let-optional-template REST-ARG BINDINGS BODY 'let))
(defmacro let-optional* (REST-ARG BINDINGS . BODY)
(let-optional-template REST-ARG BINDINGS BODY 'let*))
;; let-keywords rest-arg allow-other-keys? (binding ...) . body
;; let-keywords* rest-arg allow-other-keys? (binding ...) . body
;; macros used to bind keyword arguments
;;
;; These macros pick out keyword arguments from rest-arg, but do not
;; modify it. This is consistent at least with Common Lisp, which
;; duplicates keyword args in the rest arg. More explanation of what
;; keyword arguments in a lambda list look like can be found below in
;; the documentation for lambda*. Bindings can have the same form as
;; for let-optional. If allow-other-keys? is false, an error will be
;; thrown if anything that looks like a keyword argument but does not
;; match a known keyword parameter will result in an error.
;;
(defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
(let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))
(defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
(let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))
;; some utility procedures for implementing the various let-forms.
(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
(let ((bindings (map (lambda (x)
(if (list? x)
x
(list x #f)))
BINDINGS)))
`(,let-type ,(map proc bindings) ,@BODY)))
(define (let-optional-template REST-ARG BINDINGS BODY let-type)
(if (null? BINDINGS)
`(let () ,@BODY)
(let-o-k-template REST-ARG BINDINGS BODY let-type
(lambda (optional)
`(,(car optional)
(cond
((not (null? ,REST-ARG))
(let ((result (car ,REST-ARG)))
,(list 'set! REST-ARG
`(cdr ,REST-ARG))
result))
(else
,(cadr optional))))))))
(define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY let-type)
(if (null? BINDINGS)
`(let () ,@BODY)
(let* ((kb-list-gensym (gensym "kb:G"))
(bindfilter (lambda (key)
`(,(car key)
(cond
((assq ',(car key) ,kb-list-gensym)
=> cdr)
(else
,(cadr key)))))))
`(let ((,kb-list-gensym ((if (not mes?) (@@ (mes optargs) rest-arg->keyword-binding-list)
rest-arg->keyword-binding-list)
,REST-ARG ',(map (lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
BINDINGS)
,ALLOW-OTHER-KEYS?)))
,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))
(define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
(if (null? rest-arg)
'()
(let loop ((first (car rest-arg))
(rest (cdr rest-arg))
(accum '()))
(let ((next (lambda (a)
(if (null? (cdr rest))
a
(loop (cadr rest) (cddr rest) a)))))
(if (keyword? first)
(cond
((memq first keywords)
(if (null? rest)
(error "Keyword argument has no value:" first)
(next (cons (cons (keyword->symbol first)
(car rest)) accum))))
((not allow-other-keys?)
(error "Unknown keyword in arguments:" first))
(else (if (null? rest)
accum
(next accum))))
(if (null? rest)
accum
(loop (car rest) (cdr rest) accum)))))))
;; lambda* args . body
;; lambda extended for optional and keyword arguments
;;
;; lambda* creates a procedure that takes optional arguments. These
;; are specified by putting them inside brackets at the end of the
;; paramater list, but before any dotted rest argument. For example,
;; (lambda* (a b #:optional c d . e) '())
;; creates a procedure with fixed arguments a and b, optional arguments c
;; and d, and rest argument e. If the optional arguments are omitted
;; in a call, the variables for them are bound to `#f'.
;;
;; lambda* can also take keyword arguments. For example, a procedure
;; defined like this:
;; (lambda* (#:key xyzzy larch) '())
;; can be called with any of the argument lists (#:xyzzy 11)
;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments
;; are given as keywords are bound to values.
;;
;; Optional and keyword arguments can also be given default values
;; which they take on when they are not present in a call, by giving a
;; two-item list in place of an optional argument, for example in:
;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz))
;; foo is a fixed argument, bar is an optional argument with default
;; value 42, and baz is a keyword argument with default value 73.
;; Default value expressions are not evaluated unless they are needed
;; and until the procedure is called.
;;
;; lambda* now supports two more special parameter list keywords.
;;
;; lambda*-defined procedures now throw an error by default if a
;; keyword other than one of those specified is found in the actual
;; passed arguments. However, specifying #:allow-other-keys
;; immediately after the keyword argument declarations restores the
;; previous behavior of ignoring unknown keywords. lambda* also now
;; guarantees that if the same keyword is passed more than once, the
;; last one passed is the one that takes effect. For example,
;; ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails)))
;; #:heads 37 #:tails 42 #:heads 99)
;; would result in (99 47) being displayed.
;;
;; #:rest is also now provided as a synonym for the dotted syntax rest
;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in
;; all respects to lambda*. This is provided for more similarity to DSSSL,
;; MIT-Scheme and Kawa among others, as well as for refugees from other
;; Lisp dialects.
(defmacro lambda* (ARGLIST . BODY)
(parse-arglist
ARGLIST
(lambda (non-optional-args optionals keys aok? rest-arg)
;; Check for syntax errors.
(if (not (every? symbol? non-optional-args))
(error "Syntax error in fixed argument declaration."))
(if (not (every? ext-decl? optionals))
(error "Syntax error in optional argument declaration."))
(if (not (every? ext-decl? keys))
(error "Syntax error in keyword argument declaration."))
(if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
(error "Syntax error in rest argument declaration."))
;; generate the code.
(let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
(lambda-gensym (gensym "lambda*:L")))
(if (not (and (null? optionals) (null? keys)))
`(let ((,lambda-gensym
(lambda (,@non-optional-args . ,rest-gensym)
;; Make sure that if the proc had a docstring, we put it
;; here where it will be visible.
,@(if (and (not (null? BODY))
(string? (car BODY)))
(list (car BODY))
'())
(let-optional*
,rest-gensym
,optionals
(let-keywords* ,rest-gensym
,aok?
,keys
,@(if (and (not rest-arg) (null? keys))
`((if (not (null? ,rest-gensym))
(error "Too many arguments.")))
'())
(let ()
,@BODY))))))
(set-procedure-property! ,lambda-gensym 'arglist
'(,non-optional-args
,optionals
,keys
,aok?
,rest-arg))
,lambda-gensym)
`(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
,@BODY))))))
(define (every? pred lst)
(or (null? lst)
(and (pred (car lst))
(every? pred (cdr lst)))))
(define (ext-decl? obj)
(or (symbol? obj)
(and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))
;; XXX - not tail recursive
(define (improper-list-copy obj)
(if (pair? obj)
(cons (car obj) (improper-list-copy (cdr obj)))
obj))
(define (parse-arglist arglist cont)
(define (split-list-at val lst cont)
(cond
((memq val lst)
=> (lambda (pos)
(if (memq val (cdr pos))
(error (with-output-to-string
(lambda ()
(map display `(,val
" specified more than once in argument list.")))))
(cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
(else (cont lst '() #f))))
(define (parse-opt-and-fixed arglist keys aok? rest cont)
(split-list-at
#:optional arglist
(lambda (before after split?)
(if (and split? (null? after))
(error "#:optional specified but no optional arguments declared.")
(cont before after keys aok? rest)))))
(define (parse-keys arglist rest cont)
(split-list-at
#:allow-other-keys arglist
(lambda (aok-before aok-after aok-split?)
(if (and aok-split? (not (null? aok-after)))
(error "#:allow-other-keys not at end of keyword argument declarations.")
(split-list-at
#:key aok-before
(lambda (key-before key-after key-split?)
(cond
((and aok-split? (not key-split?))
(error "#:allow-other-keys specified but no keyword arguments declared."))
(key-split?
(cond
((null? key-after) (error "#:key specified but no keyword arguments declared."))
((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments."))
(else (parse-opt-and-fixed key-before key-after aok-split? rest cont))))
(else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
(define (parse-rest arglist cont)
(cond
((null? arglist) (cont '() '() '() #f #f))
((not (pair? arglist)) (cont '() '() '() #f arglist))
((not (list? arglist))
(let* ((copy (improper-list-copy arglist))
(lp (last-pair copy))
(ra (cdr lp)))
(set-cdr! lp '())
(if (memq #:rest copy)
(error "Cannot specify both #:rest and dotted rest argument.")
(parse-keys copy ra cont))))
(else (split-list-at
#:rest arglist
(lambda (before after split?)
(if split?
(case (length after)
((0) (error "#:rest not followed by argument."))
((1) (parse-keys before (car after) cont))
(else (error "#:rest argument must be declared last.")))
(parse-keys before #f cont)))))))
(parse-rest arglist cont))
;; define* args . body
;; define*-public args . body
;; define and define-public extended for optional and keyword arguments
;;
;; define* and define*-public support optional arguments with
;; a similar syntax to lambda*. They also support arbitrary-depth
;; currying, just like Guile's define. Some examples:
;; (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
;; defines a procedure x with a fixed argument y, an optional agument
;; a, another optional argument z with default value 3, a keyword argument w,
;; and a rest argument u.
;; (define-public* ((foo #:optional bar) #:optional baz) '())
;; This illustrates currying. A procedure foo is defined, which,
;; when called with an optional argument bar, returns a procedure that
;; takes an optional argument baz.
;;
;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
;; in the same way as lambda*.
(defmacro define* (ARGLIST . BODY)
(define*-guts 'define ARGLIST BODY))
(defmacro define*-public (ARGLIST . BODY)
(define*-guts 'define-public ARGLIST BODY))
;; The guts of define* and define*-public.
(define (define*-guts DT ARGLIST BODY)
(define (nest-lambda*s arglists)
(if (null? arglists)
BODY
`((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists))))))
(define (define*-guts-helper ARGLIST arglists)
(let ((first (car ARGLIST))
(al (cons (cdr ARGLIST) arglists)))
(if (symbol? first)
`(,DT ,first ,@(nest-lambda*s al))
(define*-guts-helper first al))))
(if (symbol? ARGLIST)
`(,DT ,ARGLIST ,@BODY)
(define*-guts-helper ARGLIST '())))
;; defmacro* name args . body
;; defmacro*-public args . body
;; defmacro and defmacro-public extended for optional and keyword arguments
;;
;; These are just like defmacro and defmacro-public except that they
;; take lambda*-style extended paramter lists, where #:optional,
;; #:key, #:allow-other-keys and #:rest are allowed with the usual
;; semantics. Here is an example of a macro with an optional argument:
;; (defmacro* transmorgify (a #:optional b)
(defmacro defmacro* (NAME ARGLIST . BODY)
`(define-macro ,NAME #f (lambda* ,ARGLIST ,@BODY)))
(defmacro defmacro*-public (NAME ARGLIST . BODY)
`(begin
(defmacro* ,NAME ,ARGLIST ,@BODY)
(export-syntax ,NAME)))
;;; Support for optional & keyword args with the interpreter.
(define *uninitialized* (list 'uninitialized))
(define (parse-lambda-case spec inits predicate args)
(pmatch spec
((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
(define (req args prev tail n)
(cond
((zero? n)
(if prev (set-cdr! prev '()))
(let ((slots-tail (make-list (- nargs nreq) *uninitialized*)))
(opt (if prev (append! args slots-tail) slots-tail)
slots-tail tail nopt inits)))
((null? tail)
#f) ;; fail
(else
(req args tail (cdr tail) (1- n)))))
(define (opt slots slots-tail args-tail n inits)
(cond
((zero? n)
(rest-or-key slots slots-tail args-tail inits rest-idx))
((null? args-tail)
(set-car! slots-tail (apply (car inits) slots))
(opt slots (cdr slots-tail) '() (1- n) (cdr inits)))
(else
(set-car! slots-tail (car args-tail))
(opt slots (cdr slots-tail) (cdr args-tail) (1- n) (cdr inits)))))
(define (rest-or-key slots slots-tail args-tail inits rest-idx)
(cond
(rest-idx
;; it has to be this way, vars are allocated in this order
(set-car! slots-tail args-tail)
(if (pair? kw-indices)
(key slots (cdr slots-tail) args-tail inits)
(rest-or-key slots (cdr slots-tail) '() inits #f)))
((pair? kw-indices)
;; fail early here, because once we're in keyword land we throw
;; errors instead of failing
(and (or (null? args-tail) rest-idx (keyword? (car args-tail)))
(key slots slots-tail args-tail inits)))
((pair? args-tail)
#f) ;; fail
(else
(pred slots))))
(define (key slots slots-tail args-tail inits)
(cond
((null? args-tail)
(if (null? inits)
(pred slots)
(begin
(if (eq? (car slots-tail) *uninitialized*)
(set-car! slots-tail (apply (car inits) slots)))
(key slots (cdr slots-tail) '() (cdr inits)))))
((not (keyword? (car args-tail)))
(if rest-idx
;; no error checking, everything goes to the rest..
(key slots slots-tail '() inits)
(error "bad keyword argument list" args-tail)))
((and (keyword? (car args-tail))
(pair? (cdr args-tail))
(assq-ref kw-indices (car args-tail)))
=> (lambda (i)
(list-set! slots i (cadr args-tail))
(key slots slots-tail (cddr args-tail) inits)))
((and (keyword? (car args-tail))
(pair? (cdr args-tail))
allow-other-keys?)
(key slots slots-tail (cddr args-tail) inits))
(else (error "unrecognized keyword" args-tail))))
(define (pred slots)
(cond
(predicate
(if (apply predicate slots)
slots
#f))
(else slots)))
(let ((args (list-copy args)))
(req args #f args nreq)))
(else (error "unexpected spec" spec))))

158
sysa/mes-0.22/module/mes/test.scm Normal file
View file

@ -0,0 +1,158 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; test.mes can be loaded after base.mes. It provides a minimalistic
;;; test framework: pass-if, pass-if-not, seq?, sequal? and result.
;;; Code:
(define-module (mes test)
#:use-module (ice-9 rdelim)
#:export (
pass-if
pass-if-equal
pass-if-not
pass-if-eq
pass-if-timeout
result
seq? ; deprecated
sequal? ; deprecated
))
(cond-expand
(mes
(define (inexact->exact x) x)
(define mes? #t)
(define guile? #f)
(define guile-2? #f)
(define guile-1.8? #f))
(guile-2
(define mes? #f)
(define guile? #t)
(define guile-2? #t)
(define guile-1.8? #f))
(guile
(define mes? #f)
(define guile? #f)
(define guile-2? #f)
(define guile-1.8? #t)))
(define result
((lambda (pass fail)
(lambda (. t)
(if (or (null? t) (eq? (car t) 'result)) (list pass fail)
(if (eq? (car t) 'report)
(begin
((lambda (expect)
(begin (display "expect: ") (write expect) (newline))
(newline)
(display "passed: ") (display pass) (newline)
(display "failed: ") (display fail) (newline)
(if (not (eq? expect 0)) (begin (display "expect: ") (write expect) (newline)))
(display "total: ") (display (+ pass fail)) (newline)
(exit (if (eq? expect fail) 0 fail)))
(if (null? (cdr t)) 0 (cadr t))))
(if (car t) (begin (display ": pass") (newline) (set! pass (+ pass 1)))
(begin (display ": fail") (newline) (set! fail (+ fail 1))))))))
0 0))
(define (seq? expect a) ;;REMOVE ME
(or (eq? a expect)
(begin
(display ": fail")
(newline)
(display "expected: ")
(write expect) (newline)
(display "actual: ")
(write a)
(newline)
#f)))
(define (sequal? expect a) ;;REMOVE ME
(or (equal? a expect)
(begin
(display ": fail")
(newline)
(display "expected: ")
(write expect) (newline)
(display "actual: ")
(write a)
(newline)
#f)))
(define (seq2? a expect)
(or (eq? a expect)
(begin
(display ": fail") (newline)
(display "expected: ") (write expect) (newline)
(display "actual: ") (write a) (newline)
#f)))
(define (sless? a expect)
(or (< a expect)
(begin
(display ": fail") (newline)
(display "expected: ") (write expect) (newline)
(display "actual: ") (write a) (newline)
#f)))
(define (sequal2? actual expect)
(or (equal? actual expect)
(begin
(display ": fail") (newline)
(display "expected: ") (write expect) (newline)
(display "actual: ") (write actual) (newline)
#f)))
(define-macro (pass-if name t)
(list
'begin
(list display "test: ") (list display name)
(list 'result t))) ;; FIXME
(define-macro (pass-if-eq name expect . body)
(list 'pass-if name (list seq2? (cons 'begin body) expect)))
(define-macro (pass-if-equal name expect . body)
(list 'pass-if name (list sequal2? (cons 'begin body) expect)))
(define-macro (expect-fail name expect . body)
(list 'pass-if name (list not (list sequal2? (cons 'begin body) expect))))
(define-macro (pass-if-not name f)
(list
'begin
(list display "test: ") (list display name)
(list 'result (list not f)))) ;; FIXME
(define internal-time-units-per-milli-second
(/ internal-time-units-per-second 1000))
(define (test-time thunk)
((lambda (start)
(begin
(thunk)
(inexact->exact (/ (- (get-internal-run-time) start)
internal-time-units-per-milli-second))))
(get-internal-run-time)))
(define-macro (pass-if-timeout name limit . body)
(list 'pass-if name (list sless? (list test-time (cons* 'lambda '_ body)) limit)))