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

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

35
sysa/mes-0.22/mes/module/srfi/srfi-0.mes Normal file
View file

@ -0,0 +1,35 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016 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:
;;; srfi-0.mes - cond-expand
;;; Code:
(define mes '(0 1))
(define (cond-expand-expander clauses)
(if (defined? (caar clauses))
(cdar clauses)
(cond-expand-expander (cdr clauses))))
(define-macro (cond-expand . clauses)
(cons 'begin (cond-expand-expander clauses)))

148
sysa/mes-0.22/mes/module/srfi/srfi-1.mes Normal file
View file

@ -0,0 +1,148 @@
;;; -*-scheme-*-
;;; 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/>.
;;; Commentary:
;;; srfi-1.mes is the minimal srfi-1 needed to run mescc.
;;; Code:
(define (find pred lst)
(let loop ((lst lst))
(if (null? lst) #f
(if (pred (car lst)) (car lst)
(loop (cdr lst))))))
(define (filter pred lst)
(let loop ((lst lst))
(if (null? lst) '()
(if (pred (car lst))
(cons (car lst) (loop (cdr lst)))
(loop (cdr lst))))))
(define (append-map f lst . rest)
(apply append (apply map f (cons lst rest))))
(define (filter-map f h . t)
(if (null? h) '()
(if (null? t)
(let ((r (f (car h))))
(if r (cons r (filter-map f (cdr h)))
(filter-map f (cdr h))))
(if (null? (cdr t))
(let ((r (f (car h) (caar t))))
(if r (cons r (filter-map f (cdr h) (cdar t)))
(filter-map f (cdr h) (cdar t))))
(error 'unsupported (cons* "filter-map 3:" f h t))))))
(define (fold proc init lst1 . rest)
(if (null? rest)
(let loop ((lst1 lst1) (result init))
(if (null? lst1) result
(loop (cdr lst1) (proc (car lst1) result))))
(if (null? (cdr rest))
(let loop ((lst1 lst1) (lst2 (car rest)) (result init))
(if (or (null? lst1)
(null? lst2)) result
(loop (cdr lst1) (cdr lst2) (proc (car lst1) (car lst2) result))))
(let loop ((lst1 lst1) (lst2 (car rest)) (lst3 (cadr rest)) (result init))
(if (or (null? lst1)
(null? lst2)
(null? lst3)) result
(loop (cdr lst1) (cdr lst2) (cdr lst3) (proc (car lst1) (car lst2) (car lst3) result))))
(error "FOLD-4-NOT-SUPPORTED"))))
(define (fold-right proc init lst1 . rest)
(if (null? rest)
(let loop ((lst lst1))
(if (null? lst) init
(proc (car lst) (loop (cdr lst)))))
(if (null? (cdr rest))
(let loop ((lst1 lst1) (lst2 (car rest)))
(if (or (null? lst1)
(null? lst2)) init
(proc (car lst1) (car lst2) (loop (cdr lst1) (cdr lst2)))))
(let loop ((lst1 lst1) (lst2 (car rest)) (lst3 (cadr rest)))
(if (or (null? lst1)
(null? lst2)
(null? lst3)) init
(proc (car lst1) (car lst2) (car lst3) (loop (cdr lst1) (cdr lst2) (cdr lst3)))))
(error "FOLD-RIGHT-4-NOT-SUPPORTED"))))
(define (unfold p f g seed . rest)
(let ((tail-gen (if (null? rest) (const '())
(car rest))))
(define (reverse+tail lst seed)
(let loop ((lst lst)
(result (tail-gen seed)))
(if (null? lst) result
(loop (cdr lst)
(cons (car lst) result)))))
(let loop ((seed seed) (result '()))
(if (p seed) (reverse+tail result seed)
(loop (g seed)
(cons (f seed) result))))))
(define (remove pred lst) (filter (lambda (x) (not (pred x))) lst))
(define (reverse! lst . term)
(if (null? term) (core:reverse! lst term)
(core:reverse! lst (car term))))
(define (srfi-1:member x lst eq)
(if (null? lst) #f
(if (eq x (car lst)) lst
(srfi-1:member x (cdr lst) eq))))
(define mes:member member)
(define (member x lst . rest)
(if (null? rest) (mes:member x lst)
(srfi-1:member x lst (car rest))))
(define mes:iota iota)
(define (srfi-1:iota n start step)
(if (<= n 0) '()
(cons start (srfi-1:iota (- n 1) (+ start step) step))))
(define (iota n . rest)
(if (null? rest) (mes:iota n)
(let ((start (car rest))
(step (if (null? (cdr rest)) 1
(cadr rest))))
(srfi-1:iota n start step))))
(define last (compose car last-pair))
(define (delete-duplicates lst . equal)
(let ((equal (and (pair? equal) (car equal))))
(let loop ((lst lst))
(if (null? lst) '()
(if (if equal (member (car lst) (cdr lst) equal)
(member (car lst) (cdr lst)))
(loop (cdr lst))
(cons (car lst) (loop (cdr lst))))))))
(include-from-path "srfi/srfi-1.scm")
(define (take-while pred lst)
(if (or (null? lst) (not (pred (car lst)))) '()
(cons (car lst) (take-while pred (cdr lst)))))

115
sysa/mes-0.22/mes/module/srfi/srfi-1.scm Normal file
View file

@ -0,0 +1,115 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
;;;
;;; 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/>.
;;; From Guile-1.8
;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;; Date: 2001-06-06
;;; Searching
;; Internal helper procedure. Map `f' over the single list `ls'.
;;
(define map1 map)
(define (any pred ls . lists)
(if (null? lists)
(any1 pred ls)
(let lp ((lists (cons ls lists)))
(cond ((any1 null? lists)
#f)
((any1 null? (map1 cdr lists))
(apply pred (map1 car lists)))
(else
(or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
(define (any1 pred ls)
(let lp ((ls ls))
(cond ((null? ls)
#f)
((null? (cdr ls))
(pred (car ls)))
(else
(or (pred (car ls)) (lp (cdr ls)))))))
(define (every pred ls . lists)
(if (null? lists)
(every1 pred ls)
(let lp ((lists (cons ls lists)))
(cond ((any1 null? lists)
#t)
((any1 null? (map1 cdr lists))
(apply pred (map1 car lists)))
(else
(and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
(define (every1 pred ls)
(let lp ((ls ls))
(cond ((null? ls)
#t)
((null? (cdr ls))
(pred (car ls)))
(else
(and (pred (car ls)) (lp (cdr ls)))))))
(define (list-index pred clist1 . rest)
(if (null? rest)
(let lp ((l clist1) (i 0))
(if (null? l)
#f
(if (pred (car l))
i
(lp (cdr l) (+ i 1)))))
(let lp ((lists (cons clist1 rest)) (i 0))
(cond ((any1 null? lists)
#f)
((apply pred (map car lists)) i)
(else
(lp (map cdr lists) (+ i 1)))))))
;;; Set operations on lists
(define (lset-union = . rest)
(let ((acc '()))
(for-each (lambda (lst)
(if (null? acc)
(set! acc lst)
(for-each (lambda (elem)
(if (not (member elem acc =))
(set! acc (cons elem acc))))
lst)))
rest)
acc))
(define (lset-intersection = list1 . rest)
(let lp ((l list1) (acc '()))
(if (null? l)
(reverse! acc)
(if (every (lambda (ll) (member (car l) ll =)) rest)
(lp (cdr l) (cons (car l) acc))
(lp (cdr l) acc)))))
(define (lset-difference = list1 . rest)
(if (null? rest)
list1
(let lp ((l list1) (acc '()))
(if (null? l)
(reverse! acc)
(if (any (lambda (ll) (member (car l) ll =)) rest)
(lp (cdr l) acc)
(lp (cdr l) (cons (car l) acc)))))))

198
sysa/mes-0.22/mes/module/srfi/srfi-13.mes Normal file
View file

@ -0,0 +1,198 @@
;;; -*-scheme-*-
;;; 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/>.
;;; Commentary:
;;; srfi-13.mes is the minimal srfi-13
;;; Code:
(mes-use-module (srfi srfi-14))
(define (string-join lst . delimiter+grammar)
(let ((delimiter (or (and (pair? delimiter+grammar) (car delimiter+grammar))
" "))
(grammar (or (and (pair? delimiter+grammar) (pair? (cdr delimiter+grammar)) (cadr delimiter+grammar))
'infix)))
(if (null? lst) ""
(case grammar
((infix) (if (null? (cdr lst)) (car lst)
(string-append (car lst) delimiter (string-join (cdr lst) delimiter))))
((prefix) (string-append delimiter (car lst) (apply string-join (cdr lst) delimiter+grammar)))
((suffix) (string-append (car lst) delimiter (apply string-join (cdr lst) delimiter+grammar)))))))
(define (string-copy s)
(list->string (string->list s)))
(define (string= a b . rest)
(let* ((start1 (and (pair? rest) (car rest)))
(end1 (and start1 (pair? (cdr rest)) (cadr rest)))
(start2 (and end1 (pair? (cddr rest)) (caddr rest)))
(end2 (and start2 (pair? (cdddr rest)) (cadddr rest))))
(string=? (if start1 (if end1 (substring a start1 end1)
(substring a start1))
a)
(if start2 (if end2 (substring b start2 end2)
(substring b start2))
b))))
(define (string-split s c)
(let loop ((lst (string->list s)) (result '()))
(let ((rest (memq c lst)))
(if (not rest) (append result (list (list->string lst)))
(loop (cdr rest)
(append result
(list (list->string (list-head lst (- (length lst) (length rest)))))))))))
(define (string-take s n)
(cond ((zero? n) s)
((> n 0) (list->string (list-head (string->list s) n)))
(else (error "string-take: not supported: n=" n))))
(define (string-drop s n)
(cond ((zero? n) s)
((> n 0) (list->string (list-tail (string->list s) n)))
(else s (error "string-drop: not supported: (n s)=" (cons n s)))))
(define (drop-right lst n)
(list-head lst (- (length lst) n)))
(define (string-drop-right s n)
(cond ((zero? n) s)
((> n 0) ((compose list->string (lambda (o) (drop-right o n)) string->list) s))
(else (error "string-drop-right: not supported: n=" n))))
(define (string-delete pred s)
(let ((p (if (procedure? pred) pred
(lambda (c) (not (eq? pred c))))))
(list->string (filter p (string->list s)))))
(define (string-index s pred . rest)
(let* ((start (and (pair? rest) (car rest)))
(end (and start (pair? (cdr rest)) (cadr rest)))
(pred (if (char? pred) (lambda (c) (eq? c pred)) pred)))
(if start (error "string-index: not supported: start=" start))
(if end (error "string-index: not supported: end=" end))
(let loop ((lst (string->list s)) (i 0))
(if (null? lst) #f
(if (pred (car lst)) i
(loop (cdr lst) (1+ i)))))))
(define (string-rindex s pred . rest)
(let* ((start (and (pair? rest) (car rest)))
(end (and start (pair? (cdr rest)) (cadr rest)))
(pred (if (char? pred) (lambda (c) (eq? c pred)) pred)))
(if start (error "string-rindex: not supported: start=" start))
(if end (error "string-rindex: not supported: end=" end))
(let loop ((lst (reverse (string->list s))) (i (1- (string-length s))))
(if (null? lst) #f
(if (pred (car lst)) i
(loop (cdr lst) (1- i)))))))
(define reverse-list->string (compose list->string reverse))
(define substring/copy substring)
(define substring/shared substring)
(define string-null? (compose null? string->list))
(define (string-fold cons' nil' s . rest)
(let* ((start (and (pair? rest) (car rest)))
(end (and start (pair? (cdr rest)) (cadr rest))))
(if start (error "string-fold: not supported: start=" start))
(if end (error "string-fold: not supported: end=" end))
(let loop ((lst (string->list s)) (prev nil'))
(if (null? lst) prev
(loop (cdr lst) (cons' (car lst) prev))))))
(define (string-fold-right cons' nil' s . rest)
(let* ((start (and (pair? rest) (car rest)))
(end (and start (pair? (cdr rest)) (cadr rest))))
(if start (error "string-fold-right: not supported: start=" start))
(if end (error "string-fold-right: not supported: end=" end))
(let loop ((lst (reverse (string->list s))) (prev nil'))
(if (null? lst) prev
(loop (cdr lst) (cons' (car lst) prev))))))
(define (string-contains string needle)
(let ((needle (string->list needle)))
(let loop ((string (string->list string)) (i 0))
(and (pair? string)
(let match ((start string) (needle needle) (n i))
(if (null? needle) i
(and (pair? start)
(if (eq? (car start) (car needle))
(or (match (cdr start) (cdr needle) (1+ n))
(loop (cdr string) (1+ i)))
(loop (cdr string) (1+ i))))))))))
(define (string-trim string . pred)
(list->string
(if (pair? pred) (error "string-trim: not supported: PRED=" pred)
(let loop ((lst (string->list string)))
(if (or (null? lst)
(not (char-whitespace? (car lst)))) lst
(loop (cdr lst)))))))
(define (string-trim-right string . pred)
(list->string
(reverse!
(if (pair? pred) (error "string-trim-right: not supported: PRED=" pred)
(let loop ((lst (reverse (string->list string))))
(if (or (null? lst)
(not (char-whitespace? (car lst)))) lst
(loop (cdr lst))))))))
(define (string-trim-both string . pred)
((compose string-trim string-trim-right) string))
(define (string-map f string)
(list->string (map f (string->list string))))
(define (string-replace string replace . rest)
(let* ((start1 (and (pair? rest) (car rest)))
(end1 (and start1 (pair? (cdr rest)) (cadr rest)))
(start2 (and end1 (pair? (cddr rest)) (caddr rest)))
(end2 (and start2 (pair? (cdddr rest)) (cadddr rest))))
(if start2 (error "string-replace: not supported: START2=" start2))
(if end2 (error "string-replace: not supported: END2=" end2))
(list->string
(append
(string->list (string-take string (or start1 0)))
(string->list replace)
(string->list (string-drop string (or end1 (string-length string))))))))
(define (string-downcase string)
(string-map char-downcase string))
(define (string-upcase string)
(string-map char-upcase string))
(define (string-tokenize string char-set)
(let loop ((lst (string->list string)) (result '()))
(if (null? lst) (reverse result)
(let match ((lst lst) (found '()))
(if (null? lst) (loop lst (if (null? found) (reverse result)
(cons (list->string (reverse found)) result)))
(let ((c (car lst)))
(if (not (char-set-contains? char-set c)) (loop (cdr lst)
(if (null? found) result
(cons (list->string (reverse found)) result)))
(match (cdr lst) (cons c found)))))))))

90
sysa/mes-0.22/mes/module/srfi/srfi-14.mes Normal file
View file

@ -0,0 +1,90 @@
;;; -*-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:
;;; Minimal implementation of srfi-14, for nyacc.
;;; Code:
;; FIXME: have structs
(define (char-set . x)
(cons '*char-set* x))
(define (char-set? x)
(and (pair? x) (eq? (car x) '*char-set*)))
(define (char-set= a b)
(and (char-set? a) (char-set? b)
(equal? a b)))
(define char-set:whitespace (char-set #\tab #\page #\return #\vtab #\newline #\space))
(define char-set:digit (apply char-set
(map integer->char
(map (lambda (i)
(+ i (char->integer #\0))) (iota 10)))))
(define char-set:lower-case (apply char-set
(map integer->char
(map (lambda (i)
(+ i (char->integer #\a))) (iota 26)))))
(define char-set:upper-case (apply char-set
(map integer->char
(map (lambda (i)
(+ i (char->integer #\A))) (iota 26)))))
(define (list->char-set lst)
(apply char-set lst))
(define (string->char-set x . base)
(apply char-set (append (string->list x) (if (null? base) '() (cdar base)))))
(define (string->char-set! x base)
(set-cdr! (last-pair base) (string->list x))
base)
(define (char-set-adjoin cs . chars)
(append cs chars))
(define (char-set-contains? cs x)
(and (memq x cs) #t))
(define (char-set-complement cs)
(let ((ascii (map integer->char (iota 128))))
(list->char-set (filter (lambda (c) (not (char-set-contains? cs c))) ascii))))
(define (char-whitespace? c)
(char-set-contains? char-set:whitespace c))
(define (char-set-copy cs)
(map identity cs))
(define (char-upcase c)
(if (char-set-contains? char-set:lower-case c) (integer->char (- (char->integer c)
(- (char->integer #\a)
(char->integer #\A))))
c))
(define (char-downcase c)
(if (char-set-contains? char-set:upper-case c) (integer->char (+ (char->integer c)
(- (char->integer #\a)
(char->integer #\A))))
c))

26
sysa/mes-0.22/mes/module/srfi/srfi-16.mes Normal file
View file

@ -0,0 +1,26 @@
;;; -*-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 (cond-expand-provide . rest) #t)
(include-from-path "srfi/srfi-16.scm")

129
sysa/mes-0.22/mes/module/srfi/srfi-16.scm Normal file
View file

@ -0,0 +1,129 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
;;;
;;; 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/>.
;;; From Guile-1.8
;;; srfi-16.scm --- case-lambda
;;; Author: Martin Grabmueller
;;; Commentary:
;; Implementation of SRFI-16. `case-lambda' is a syntactic form
;; which permits writing functions acting different according to the
;; number of arguments passed.
;;
;; The syntax of the `case-lambda' form is defined in the following
;; EBNF grammar.
;;
;; <case-lambda>
;; --> (case-lambda <case-lambda-clause>)
;; <case-lambda-clause>
;; --> (<signature> <definition-or-command>*)
;; <signature>
;; --> (<identifier>*)
;; | (<identifier>* . <identifier>)
;; | <identifier>
;;
;; The value returned by a `case-lambda' form is a procedure which
;; matches the number of actual arguments against the signatures in
;; the various clauses, in order. The first matching clause is
;; selected, the corresponding values from the actual parameter list
;; are bound to the variable names in the clauses and the body of the
;; clause is evaluated.
;;; Code:
(define-module (srfi srfi-16)
:export-syntax (case-lambda))
(cond-expand-provide (current-module) '(srfi-16))
(define-macro (case-lambda . clauses)
;; Return the length of the list @var{l}, but allow dotted list.
;;
(define (alength l)
(cond ((null? l) 0)
((pair? l) (+ 1 (alength (cdr l))))
(else 0)))
;; Return @code{#t} if @var{l} is a dotted list, @code{#f} if it is
;; a normal list.
;;
(define (dotted? l)
(cond ((null? l) #f)
((pair? l) (dotted? (cdr l)))
(else #t)))
;; Return the expression for accessing the @var{index}th element of
;; the list called @var{args-name}. If @var{tail?} is true, code
;; for accessing the list-tail is generated, otherwise for accessing
;; the list element itself.
;;
(define (accessor args-name index tail?)
(if tail?
(case index
((0) `,args-name)
((1) `(cdr ,args-name))
((2) `(cddr ,args-name))
((3) `(cdddr ,args-name))
((4) `(cddddr ,args-name))
(else `(list-tail ,args-name ,index)))
(case index
((0) `(car ,args-name))
((1) `(cadr ,args-name))
((2) `(caddr ,args-name))
((3) `(cadddr ,args-name))
(else `(list-ref ,args-name ,index)))))
;; Generate the binding lists of the variables of one case-lambda
;; clause. @var{vars} is the (possibly dotted) list of variables
;; and @var{args-name} is the generated name used for the argument
;; list.
;;
(define (gen-temps vars args-name)
(let lp ((v vars) (i 0))
(cond ((null? v) '())
((pair? v)
(cons `(,(car v) ,(accessor args-name i #f))
(lp (cdr v) (+ i 1))))
(else `((,v ,(accessor args-name i #t)))))))
;; Generate the cond clauses for each of the clauses of case-lambda,
;; including the parameter count check, binding of the parameters
;; and the code of the corresponding body.
;;
(define (gen-clauses l length-name args-name)
(cond ((null? l) (list '(else (error "too few arguments"))))
(else
(cons
`((,(if (dotted? (caar l)) '>= '=)
,length-name ,(alength (caar l)))
(let ,(gen-temps (caar l) args-name)
,@(cdar l)))
(gen-clauses (cdr l) length-name args-name)))))
(let ((args-name (gensym))
(length-name (gensym)))
(let ((proc
`(lambda ,args-name
(let ((,length-name (length ,args-name)))
(cond ,@(gen-clauses clauses length-name args-name))))))
proc)))
;;; srfi-16.scm ends here

28
sysa/mes-0.22/mes/module/srfi/srfi-26.mes Normal file
View file

@ -0,0 +1,28 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016 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:
;;; srfi-26.mes - cut, cute
(mes-use-module (mes scm))
(mes-use-module (mes guile))
(mes-use-module (srfi srfi-1))
(include-from-path "srfi/srfi-26.scm")

52
sysa/mes-0.22/mes/module/srfi/srfi-26.scm Normal file
View file

@ -0,0 +1,52 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
;;;
;;; 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/>.
;;; srfi-26.scm --- specializing parameters without currying.
;;; From Guile-1.8
(define-module (srfi srfi-26)
:export (cut cute))
(cond-expand-provide (current-module) '(srfi-26))
(define-macro (cut slot . slots)
(let loop ((slots (cons slot slots))
(params '())
(args '()))
(if (null? slots)
`(lambda ,(reverse! params) ,(reverse! args))
(let ((s (car slots))
(rest (cdr slots)))
(case s
((<>)
(let ((var (gensym)))
(loop rest (cons var params) (cons var args))))
((<...>)
(if (pair? rest)
(error "<...> not on the end of cut expression"))
(let ((var (gensym)))
`(lambda ,(append! (reverse! params) var)
(apply ,@(reverse! (cons var args))))))
(else
(loop rest params (cons s args))))))))
(define-macro (cute . slots)
(let ((temp (map (lambda (s) (and (not (memq s '(<> <...>))) (gensym)))
slots)))
`(let ,(delq! #f (map (lambda (t s) (and t (list t s))) temp slots))
(cut ,@(map (lambda (t s) (or t s)) temp slots)))))

42
sysa/mes-0.22/mes/module/srfi/srfi-43.mes Normal file
View file

@ -0,0 +1,42 @@
;;; -*-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:
;;; Minimal implementation of srfi-43, for nyacc.
;;; Code:
(define (vector-map f v)
(let* ((k (vector-length v))
(n (core:make-vector k)))
(let loop ((i 0))
(if (= i k) n
(begin
(vector-set! n i (f i (vector-ref v i)))
(loop (+ i 1)))))))
(define (vector-for-each f v)
(let ((k (vector-length v)))
(let loop ((i 0))
(if (< i k)
(begin
(f i (vector-ref v i))
(loop (+ i 1)))))))

29
sysa/mes-0.22/mes/module/srfi/srfi-8.mes Normal file
View file

@ -0,0 +1,29 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 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:
;;; srfi-8.mes - receive
;;; Code:
(define-macro (receive vars vals . body)
`(call-with-values (lambda () ,vals)
(lambda ,vars . ,body)))

145
sysa/mes-0.22/mes/module/srfi/srfi-9-struct.mes Normal file
View file

@ -0,0 +1,145 @@
;;; -*-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:
;;; srfi-9.mes - records, based on struct.
(define-macro (define-record-type name constructor+params predicate . fields)
(let ((type (make-record-type name (map car fields))))
`(begin
(define ,name ,type)
(define ,(car constructor+params) ,(record-constructor type name (cdr constructor+params)))
(define ,predicate ,(record-predicate type))
(define-record-accessors ,type ,@fields))))
(define (make-record-type type fields . printer)
(let ((printer (if (pair? printer) (car printer))))
(make-struct '<record-type> (cons type (list fields)) printer)))
(define (record-type? o)
(eq? (struct-vtable o) '<record-type>))
(define (struct-vtable o)
(struct-ref o 0))
(define (record-type o)
(struct-ref o 2))
(define (record-predicate type)
(lambda (o)
(and (record? o)
(eq? (record-type o) (record-type type)))))
(define (record? o)
(and (struct? o)
(record-type? (struct-vtable o))))
(define (record-constructor type name params)
(let ((fields (record-fields type))
(record-type (record-type type)))
(lambda (. o)
(if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
(let ((rest (make-list (- (length fields) (length params)))))
(make-struct type (cons name (append o rest)) record-printer))))))
(define record-printer *unspecified*) ; TODO
(define (record-printer o)
(display "#<")
(display (record-type o))
(let* ((vtable (struct-vtable o))
(fields (record-fields vtable)))
(for-each (lambda (field)
(display " ")
(display field)
(display ": ")
(display ((record-getter vtable field) o)))
fields))
(display ">"))
(define (record-fields o)
(struct-ref o 3))
(define-macro (define-record-accessors type . fields)
`(begin
,@(map (lambda (field)
`(define-record-accessor ,type ,field))
fields)))
(define-macro (define-record-accessor type field)
`(begin
(define ,(cadr field) ,(record-getter type (car field)))
(if ,(pair? (cddr field))
(define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
(define (record-getter type field)
(let ((i (record-field-index type field)))
(lambda (o . field?)
(if (not (eq? (record-type o) (record-type type))) (error "record getter: record expected" type o)
(if (pair? field?) field
(struct-ref o i))))))
(define (record-setter type field)
(let ((i (record-field-index type field)))
(lambda (o v)
(if (not (eq? (record-type o) (record-type type))) (error "record setter: record expected" type o)
(struct-set! o i v)))))
(define (record-field-index type field)
(+ 3 (or (lst-index (record-fields type) field)
(error "no such field" type field))))
(define (lst-index lst o)
(let loop ((lst lst) (i 0))
(and (pair? lst)
(if (eq? o (car lst)) i
(loop (cdr lst) (1+ i))))))
;; (define-record-type <employee>
;; (make-employee name age salary)
;; employee?
;; (name employe-name)
;; (age employee-age set-employee-age!)
;; (salary employee-salary))
;; (display <employee>)
;; (newline)
;; (display make-employee)
;; (newline)
;; (display "employee-age ")
;; (display employee-age)
;; (newline)
;; (display "set-employee-age! ")
;; (display set-employee-age!)
;; (newline)
;; (define janneke (make-employee "janneke" 49 42))
;; (display janneke)
;; (newline)
;; (display (employee-age janneke))
;; (newline)
;; (display (set-employee-age! janneke 33))
;; (newline)
;; (display (employee-age janneke))
;; (newline)

116
sysa/mes-0.22/mes/module/srfi/srfi-9-vector.mes Normal file
View file

@ -0,0 +1,116 @@
;;; -*-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:
;;; srfi-9-vector.mes - records, based on vector
(define-macro (define-record-type type constructor+params predicate . fields)
(let ((record (make-record-type type (map car fields))))
`(begin
(define ,type ,record)
(define ,(car constructor+params) ,(record-constructor record (cdr constructor+params)))
(define ,predicate ,(record-predicate record))
(define-record-accessors ,record ,@fields))))
(define (make-record-type type fields)
(list->vector (list '*record-type* type fields (length fields))))
(define (record-type? o)
(eq? (record-type o) '*record-type*))
(define (record-type o)
(vector-ref o 0))
(define (record-predicate type)
(lambda (o)
(and (vector? o)
(eq? (record-type o) type))))
(define (record-constructor type params)
(let ((fields (record-fields type)))
(lambda (. o)
(if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
(let ((rest (make-list (- (length fields) (length params)))))
(list->vector (cons type (append o rest))))))))
(define (record-fields o)
(vector-ref o 2))
(define-macro (define-record-accessors type . fields)
`(begin
,@(map (lambda (field)
`(define-record-accessor ,type ,field))
fields)))
(define-macro (define-record-accessor type field)
`(begin
(define ,(cadr field) ,(record-getter type (car field)))
(if ,(pair? (cddr field))
(define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
(define (record-getter type field)
(let ((i (record-field-index type field)))
(lambda (o . field?)
(if (not (eq? (record-type o) type)) (error "record getter: record expected" type o)
(if (pair? field?) field
(vector-ref o i))))))
(define (record-setter type field)
(let ((i (record-field-index type field)))
(lambda (o v)
(if (not (eq? (record-type o) type)) (error "record setter: record expected" type o)
(vector-set! o i v)))))
(define (record-field-index type field)
(1+ (or (lst-index (record-fields type) field)
(error "no such field" type field))))
(define (lst-index lst o)
(let loop ((lst lst) (i 0))
(and (pair? lst)
(if (eq? o (car lst)) i
(loop (cdr lst) (1+ i))))))
;; (define-record-type <employee> (make-employee name age salary) employee? (name employe-name) (age employee-age set-employee-age!) (salary employee-salary))
;; (display <employee>)
;; (newline)
;; (display make-employee)
;; (newline)
;; (display "employee-age ")
;; (display employee-age)
;; (newline)
;; (display "set-employee-age! ")
;; (display set-employee-age!)
;; (newline)
;; (define janneke (make-employee "janneke" 49 42))
;; (display janneke)
;; (newline)
;; (display (employee-age janneke))
;; (newline)
;; (display (set-employee-age! janneke 33))
;; (newline)
;; (display (employee-age janneke))
;; (newline)

1
sysa/mes-0.22/mes/module/srfi/srfi-9.mes Symbolic link
View file

@ -0,0 +1 @@
srfi-9-struct.mes

38
sysa/mes-0.22/mes/module/srfi/srfi-9/gnu-struct.mes Normal file
View file

@ -0,0 +1,38 @@
;;; -*-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:
;;; srfi-9.mes - GNU immutable records.
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
(define-macro (set-field o getters value)
`(let ((getter ,(car getters)))
(let* ((type (struct-vtable ,o))
(name (record-type ,o))
(set (getter ,o #t)))
(define (field->value field)
(if (eq? set field) ,value
((record-getter type field) ,o)))
(let* ((fields (record-fields type))
(values (map field->value fields)))
(apply (record-constructor type name fields) values)))))

37
sysa/mes-0.22/mes/module/srfi/srfi-9/gnu-vector.mes Normal file
View file

@ -0,0 +1,37 @@
;;; -*-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:
;;; srfi-9.mes - GNU immutable records.
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
(define-macro (set-field o getters value)
`(let ((getter ,(car getters)))
(let ((type (record-type ,o))
(set (getter ,o #t)))
(define (field->value field)
(if (eq? set field) ,value
((record-getter type field) ,o)))
(let* ((fields (record-fields type))
(values (map field->value fields)))
(apply (record-constructor type fields) values)))))

1
sysa/mes-0.22/mes/module/srfi/srfi-9/gnu.mes Symbolic link
View file

@ -0,0 +1 @@
gnu-struct.mes