kylekrein/live-bootstrap
1
0
Fork 0
mirror of https://github.com/fosslinux/live-bootstrap.git synced 2026-03-13 06:45: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

139
sysa/mes-0.22/mes/module/mes/base.mes Normal file
View file

@ -0,0 +1,139 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019 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:
;;; base.mes is being loaded after base-0.mes. It provides the minimal
;;; set of scheme primitives to run lib/test.mes. It is safe to be
;;; run by Guile.
;;; Code:
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
(define (identity x) x)
(define call/cc call-with-current-continuation)
(define (command-line) %argv)
(define (read) (read-env (current-module)))
(define-macro (and . x)
(if (null? x) #t
(if (null? (cdr x)) (car x)
(list 'if (car x) (cons 'and (cdr x))
#f))))
(define-macro (or . x)
(if (null? x) #f
(if (null? (cdr x)) (car x)
(list (list 'lambda (list 'r)
(list 'if 'r 'r
(cons 'or (cdr x))))
(car x)))))
(define (and=> value procedure) (and value (procedure value)))
(define eqv? eq?)
(define (equal? . x)
(if (or (null? x) (null? (cdr x))) #t
(if (null? (cddr x)) (equal2? (car x) (cadr x))
(and (equal2? (car x) (cadr x))
(apply equal? (cdr x))))))
(define (list? x)
(or (null? x)
(and (pair? x) (list? (cdr x)))))
(define-macro (cond . clauses)
(list 'if (pair? clauses)
(list (cons
'lambda
(cons
'(test)
(list (list 'if 'test
(if (pair? (cdr (car clauses)))
(if (eq? (car (cdr (car clauses))) '=>)
(append2 (cdr (cdr (car clauses))) '(test))
(list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
(list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
(if (pair? (cdr clauses))
(cons 'cond (cdr clauses)))))))
(car (car clauses)))))
(define else #t)
(define (procedure? p)
(cond ((builtin? p) #t)
((and (pair? p) (eq? (car p) 'lambda)))
((closure? p) #t)
(#t #f)))
(define (map f h . t)
(if (or (null? h)
(and (pair? t) (null? (car t)))
(and (pair? t) (pair? (cdr t)) (null? (cadr t)))) '()
(if (null? t) (cons (f (car h)) (map f (cdr h)))
(if (null? (cdr t))
(cons (f (car h) (caar t)) (map f (cdr h) (cdar t)))
(if (null? (cddr t))
(cons (f (car h) (caar t) (caadr t)) (map f (cdr h) (cdar t) (cdadr t)))
(if (null? (cdddr t))
(cons (f (car h) (caar t) (caadr t) (car (caddr t))) (map f (cdr h) (cdar t) (cdadr t) (cdr (caddr t))))
(error 'unsupported (cons* "map 5:" f h t))) )))))

34
sysa/mes-0.22/mes/module/mes/boot-00.scm Normal file
View file

@ -0,0 +1,34 @@
;;; 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/>.
;; boot-00.scm
(define mes %version)
(define (defined? x)
(module-variable (current-module) x))
(define (cond-expand-expander clauses)
(if (defined? (car (car clauses)))
(cdr (car clauses))
(cond-expand-expander (cdr clauses))))
(define-macro (cond-expand . clauses)
(cons 'begin (cond-expand-expander clauses)))
;; end boot-00.scm
(primitive-load 0)

70
sysa/mes-0.22/mes/module/mes/boot-01.scm Normal file
View file

@ -0,0 +1,70 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018,2019 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/>.
;; boot-00.scm
(define mes %version)
(define (defined? x)
(module-variable (current-module) x))
(define (cond-expand-expander clauses)
(if (defined? (car (car clauses)))
(cdr (car clauses))
(cond-expand-expander (cdr clauses))))
(define-macro (cond-expand . clauses)
(cons 'begin (cond-expand-expander clauses)))
;; end boot-00.scm
;; boot-01.scm
(define (not x) (if x #f #t))
(define (display x . rest)
(if (null? rest) (core:display x)
(core:display-port x (car rest))))
(define (write x . rest)
(if (null? rest) (core:write x)
(core:write-port x (car rest))))
(define (newline . rest)
(core:display "\n"))
(define (cadr x) (car (cdr x)))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define map map1)
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
;; end boot-01.scm
(primitive-load 0)

105
sysa/mes-0.22/mes/module/mes/boot-02.scm Normal file
View file

@ -0,0 +1,105 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019 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:
;;; read-0.mes - bootstrap reader. This file is read by a minimal
;;; core reader. It only supports s-exps and line-comments; quotes,
;;; character literals, string literals cannot be used here.
;;; Code:
;; boot-00.scm
(define mes %version)
(define (defined? x)
(module-variable (current-module) x))
(define (cond-expand-expander clauses)
(if (defined? (car (car clauses)))
(cdr (car clauses))
(cond-expand-expander (cdr clauses))))
(define-macro (cond-expand . clauses)
(cons 'begin (cond-expand-expander clauses)))
;; end boot-00.scm
;; boot-01.scm
(define (not x) (if x #f #t))
(define (display x . rest)
(if (null? rest) (core:display x)
(core:display-port x (car rest))))
(define (write x . rest)
(if (null? rest) (core:write x)
(core:write-port x (car rest))))
(define (newline . rest)
(core:display "\n"))
(define (cadr x) (car (cdr x)))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define (map f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map f (cdr lst)))))
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
;; end boot-01.scm
;; boot-02.scm
(define-macro (and . x)
(if (null? x) #t
(if (null? (cdr x)) (car x)
(list (quote if) (car x) (cons (quote and) (cdr x))
#f))))
(define-macro (or . x)
(if (null? x) #f
(if (null? (cdr x)) (car x)
(list (list (quote lambda) (list (quote r))
(list (quote if) (quote r) (quote r)
(cons (quote or) (cdr x))))
(car x)))))
(define-macro (mes-use-module module)
#t)
(define-macro (define-module module . rest)
#t)
;; end boot-02.scm
(primitive-load 0)

175
sysa/mes-0.22/mes/module/mes/boot-03.scm Normal file
View file

@ -0,0 +1,175 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019 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:
;;; read-0.mes - bootstrap reader. This file is read by a minimal
;;; core reader. It only supports s-exps and line-comments; quotes,
;;; character literals, string literals cannot be used here.
;;; Code:
;; boot-00.scm
(define mes %version)
(define (defined? x)
(module-variable (current-module) x))
(define (cond-expand-expander clauses)
(if (defined? (car (car clauses)))
(cdr (car clauses))
(cond-expand-expander (cdr clauses))))
(define-macro (cond-expand . clauses)
(cons 'begin (cond-expand-expander clauses)))
;; end boot-00.scm
;; boot-01.scm
(define (not x) (if x #f #t))
(define (display x . rest)
(if (null? rest) (core:display x)
(core:display-port x (car rest))))
(define (write x . rest)
(if (null? rest) (core:write x)
(core:write-port x (car rest))))
(define (newline . rest)
(core:display "\n"))
(define (cadr x) (car (cdr x)))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define (map f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map f (cdr lst)))))
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
;; end boot-01.scm
;; boot-02.scm
(define-macro (and . x)
(if (null? x) #t
(if (null? (cdr x)) (car x)
(list (quote if) (car x) (cons (quote and) (cdr x))
#f))))
(define-macro (or . x)
(if (null? x) #f
(if (null? (cdr x)) (car x)
(list (list (quote lambda) (list (quote r))
(list (quote if) (quote r) (quote r)
(cons (quote or) (cdr x))))
(car x)))))
(define-macro (mes-use-module module)
#t)
;; end boot-02.scm
;; boot-03.scm
(define guile? #f)
(define mes? #t)
(define (primitive-eval e) (core:eval e (current-module)))
(define eval core:eval)
(define (port-filename port) "<stdin>")
(define (port-line port) 0)
(define (port-column port) 0)
(define (ftell port) 0)
(define (false-if-exception x) x)
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define-macro (load file)
(list 'begin
(list 'if (list 'and (list getenv "MES_DEBUG")
(list not (list equal2? (list getenv "MES_DEBUG") "0"))
(list not (list equal2? (list getenv "MES_DEBUG") "1")))
(list 'begin
(list core:display-error ";;; read ")
(list core:display-error file)
(list core:display-error "\n")))
(list 'primitive-load file)))
(define-macro (include file) (list 'load file))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define %moduledir (string-append %datadir "/module/"))
(include (string-append %moduledir "mes/type-0.mes"))
(if (and (getenv "MES_DEBUG")
(not (equal2? (getenv "MES_DEBUG") "0"))
(not (equal2? (getenv "MES_DEBUG") "1")))
(begin
(core:display-error ";;; %moduledir=")
(core:display-error %moduledir)
(core:display-error "\n")))
(define-macro (include-from-path file)
(list 'load (list string-append %moduledir file)))
(define (string-join lst infix)
(if (null? lst) ""
(if (null? (cdr lst)) (car lst)
(string-append (car lst) infix (string-join (cdr lst) infix)))))
(include-from-path "mes/module.mes")
(mes-use-module (mes base))
(mes-use-module (mes quasiquote))
(mes-use-module (mes let))
(mes-use-module (mes scm))
(define-macro (define-module module . rest)
`(if ,(and (pair? module)
(= 1 (length module))
(symbol? (car module)))
(define (,(car module) . arguments) (main (command-line)))))
(define-macro (use-modules . rest) #t)
;; end boot-03.scm
(primitive-load 0)
(primitive-load 0)

71
sysa/mes-0.22/mes/module/mes/catch.mes Normal file
View file

@ -0,0 +1,71 @@
;;; -*-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/>.
(mes-use-module (mes let))
(mes-use-module (mes fluids))
(define %eh (make-fluid
(lambda (key . args)
(if #f ;;(defined? 'simple-format)
(simple-format (current-error-port) "unhandled exception:~a:~a\n" key args)
(begin
(core:display-error "unhandled exception:")
(core:display-error key)
(core:display-error ":")
(core:write-error args)
(core:display-error "\n")))
(core:display-error "Backtrace:\n")
(display-backtrace (make-stack) (current-error-port))
(exit 1))))
(define (catch key thunk handler)
(let ((previous-eh (fluid-ref %eh)))
(with-fluid*
%eh #f
(lambda ()
(call/cc
(lambda (cc)
(fluid-set! %eh
(lambda (k . args)
(let ((handler (if (or (eq? key #t) (eq? key k)) handler
previous-eh)))
(cc
(lambda (x)
(apply handler (cons k args)))))))
(thunk)))))))
(define (throw key . args)
(let ((handler (fluid-ref %eh)))
(apply handler (cons key args))))
(define with-throw-handler catch) ; FIXME: hack for Nyacc 0.75
(define (frame-procedure frame)
(struct-ref frame 3))
(define (display-backtrace stack port . rest)
(let* ((frames (map (lambda (i) (stack-ref stack i)) (iota (stack-length stack))))
(call-frames (filter frame-procedure frames))
(display-frames (drop-right call-frames 2)))
(for-each (lambda (f)
(core:display-error " ")
(core:display-error f)
(core:display-error "\n"))
display-frames)))

201
sysa/mes-0.22/mes/module/mes/display.mes Normal file
View file

@ -0,0 +1,201 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019 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:
(mes-use-module (mes scm))
(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 (next-xassq x a)
(and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
(lambda (a) (xassq x (cdr a)))))
(define (next-xassq2 x a)
(and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
(lambda (a)
(and=> (srfi-1:member x (cdr a) (lambda (x e) (eq? x (cdr e))))
(lambda (a) (xassq x (cdr a)))))))
(define-macro (display-cut f slot n1)
`(lambda (slot) (,f slot ,n1)))
(define-macro (display-cut2 f slot n1 n2)
`(lambda (slot) (,f slot ,n1 ,n2)))
(define (display x . rest)
(let* ((port (if (null? rest) (current-output-port) (car rest)))
(write? (and (pair? rest) (pair? (cdr rest)) (cadr rest))))
(define (display-char x port write?)
(if write?
(cond ((or (eq? x #\") (eq? x #\\))
(write-char #\\ port)
(write-char x port))
((eq? x #\nul)
(write-char #\\ port)
(write-char #\0 port))
((eq? x #\alarm)
(write-char #\\ port)
(write-char #\a port))
((eq? x #\backspace)
(write-char #\\ port)
(write-char #\b port))
((eq? x #\tab)
(write-char #\\ port)
(write-char #\t port))
((eq? x #\newline)
(write-char #\\ port)
(write-char #\n port))
((eq? x #\vtab)
(write-char #\\ port)
(write-char #\v port))
((eq? x #\page)
(write-char #\\ port)
(write-char #\f port))
(#t (write-char x port)))
(write-char x port)))
(define (d x cont? sep)
(for-each (display-cut write-char <> port) (string->list sep))
(cond
((eof-object? x)
(display "#<eof>" port))
((char? x)
(if (not write?) (write-char x port)
(let ((name (and=> (assq x '((#\nul . nul)
(#\alarm . alarm)
(#\backspace . backspace)
(#\tab . tab)
(#\newline . newline)
(#\vtab . vtab)
(#\page . page)
(#\return . return)
(#\space . space)))
cdr)))
(write-char #\# port)
(when (or name
(and (>= (char->integer 32))
(<= (char->integer 127))))
(write-char #\\ port))
(if name (display name port)
(write-char x port)))))
((closure? x)
(display "#<procedure " port)
(let ((name (and=> (next-xassq2 x (current-module)) car)))
(display name port))
(display " " port)
(display (cadr (core:cdr x)) port)
(display ">" port))
((continuation? x)
(display "#<continuation " port)
(display (core:car x) port)
(display ">" port))
((macro? x)
(display "#<macro " port)
(display (core:cdr x) port)
(display ">" port))
((port? x)
(display "#<port " port)
(display (core:cdr x) port)
(display " ")
(display (core:car x) port)
(display ">" port))
((variable? x)
(display "#<variable " port)
(write (list->string (car (core:car x))) port)
(display ">" port))
((number? x)
(display (number->string x) port))
((pair? x)
(if (not cont?) (write-char #\( port))
(cond ((eq? (car x) '*circular*)
(display "*circ* . #-1#)" port))
((eq? (car x) '*closure*)
(display "*closure* . #-1#)" port))
(#t
(display (car x) port write?)
(if (pair? (cdr x)) (d (cdr x) #t " ")
(if (and (cdr x) (not (null? (cdr x))))
(begin
(display " . " port)
(display (cdr x) port write?))))))
(if (not cont?) (write-char #\) port)))
((or (keyword? x) (special? x) (string? x) (symbol? x))
(if (and (string? x) write?) (write-char #\" port))
(if (keyword? x) (display "#:" port))
(for-each (display-cut2 display-char <> port write?) (string->list x))
(if (and (string? x) write?) (write-char #\" port)))
((builtin? x)
(display "#<procedure " port)
(display (builtin-name x) port)
(display " " port)
(display
(case (builtin-arity x)
((-1) "_")
((0) "()")
((1) "(_)")
((2) "(_ _)")
((3) "(_ _ _)"))
port)
(display ">" port))
((struct? x)
(let* ((printer (struct-ref x 1)))
(if (or (builtin? printer) (closure? printer))
(printer x)
(begin
(display "#<" port)
(for-each (lambda (i)
(let ((x (struct-ref x i)))
(d x #f (if (= i 0) "" " "))))
(iota (struct-length x)))
(display ")" port)))))
((vector? x)
(display "#(" port)
(for-each (lambda (i)
(let ((x (vector-ref x i)))
(if (vector? x)
(begin
(display (if (= i 0) "" " ") port)
(display "#(...)" port))
(d x #f (if (= i 0) "" " ")))))
(iota (vector-length x)))
(display ")" port))
((broken-heart? x)
(display "<3" port))
(#t
(display "TODO type=") (display (cell:type-name x)) (newline)))
*unspecified*)
(d x #f "")))
(define (write-char x . rest)
(apply write-byte (cons (char->integer x) rest)))
(define (write x . rest)
(let ((port (if (null? rest) (current-output-port) (car rest))))
(display x port #t)))
(define (newline . rest)
(apply display (cons "\n" rest)))

82
sysa/mes-0.22/mes/module/mes/fluids.mes Normal file
View file

@ -0,0 +1,82 @@
;;; -*-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:
;;; Code:
(mes-use-module (mes scm))
(define-macro (make-fluid . default)
((lambda (fluid)
`(begin
(module-define!
(boot-module)
',fluid
((lambda (v)
(lambda ( . rest)
(if (null? rest) v
(set! v (car rest)))))
,(and (pair? default) (car default))))
',fluid))
(symbol-append 'fluid: (gensym))))
(define (fluid-ref fluid)
(fluid))
(define (fluid-set! fluid value)
(fluid value))
(define-macro (fluid? fluid)
`(begin
(and (symbol? ,fluid)
(symbol-prefix? 'fluid: ,fluid))))
(define (with-fluid* fluid value thunk)
(let ((v (fluid)))
(fluid-set! fluid value)
(let ((r (thunk)))
(fluid-set! fluid v)
r)))
;; (define-macro (with-fluids*-macro fluids values thunk)
;; `(begin
;; ,@(map (lambda (f v) (list 'set! f v)) fluids values)
;; (,thunk)))
;; (define (with-fluids*-next fluids values thunk)
;; `(with-fluids*-macro ,fluids ,values ,thunk))
;; (define (with-fluids* fluids values thunk)
;; (primitive-eval (with-fluids*-next fluids values thunk)))
(define-macro (with-fluids bindings . bodies)
(let ((syms (map gensym bindings)))
`(let ,(map (lambda (b s) `(,s (,b))) (map car bindings) syms)
,@(map (lambda (o) `(fluid-set! ,(car o) ,(cadr o))) bindings)
(let ((r (begin ,@bodies)))
,@(map (lambda (b s) `(fluid-set! ,b ,s)) (map car bindings) syms)
r))))
(define (dynamic-wind in-guard thunk out-guard)
(in-guard)
(let ((r (thunk)))
(out-guard)
r))

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

@ -0,0 +1,29 @@
;;; -*-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:
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-9))
(mes-use-module (srfi srfi-13))
(mes-use-module (mes optargs))
(include-from-path "mes/getopt-long.scm")

124
sysa/mes-0.22/mes/module/mes/guile.mes Normal file
View file

@ -0,0 +1,124 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019 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:
(mes-use-module (srfi srfi-13))
(define-macro (cond-expand-provide . rest) #t)
(mes-use-module (mes catch))
(mes-use-module (mes posix))
(mes-use-module (srfi srfi-16))
(mes-use-module (mes display))
(mes-use-module (mes simple-format))
(define %load-path (or (and=> (getenv "GUILE_LOAD_PATH") (lambda (x) (string-split x #\:))) '()))
(define (drain-input port) (read-string))
(define (read-line . rest)
(let* ((port (if (pair? rest) (car rest) (current-input-port)))
(handle-delim (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 'trim))
(c (read-char port)))
(if (eof-object? c) c
(list->string
(let loop ((c c))
(if (or (eof-object? c) (eq? c #\newline)) (case handle-delim
((trim) '())
((concat) '(#\newline))
(else (error (format #f "not supported: handle-delim=~a" handle-delim))))
(cons c (loop (read-char port)))))))))
(define (object->string x . rest)
(with-output-to-string
(lambda () ((if (pair? rest) (car rest) write) x))))
(define (port-filename p) "<stdin>")
(define (port-line p) 0)
(define (with-input-from-string string thunk)
(let ((prev (set-current-input-port (open-input-string string)))
(r (thunk)))
(set-current-input-port prev)
r))
(define (with-input-from-file file thunk)
(let ((port (open-input-file file)))
(if (= port -1)
(error 'no-such-file file)
(let* ((save (current-input-port))
(foo (set-current-input-port port))
(r (thunk)))
(set-current-input-port save)
r))))
(define (with-output-to-file file thunk)
(let ((port (open-output-file file)))
(if (= port -1)
(error 'cannot-open file)
(let* ((save (current-output-port))
(foo (set-current-output-port port))
(r (thunk)))
(set-current-output-port save)
r))))
(define (with-error-to-file file thunk)
(let ((port (open-output-file file)))
(if (= port -1)
(error 'cannot-open file)
(let* ((save (current-error-port))
(foo (set-current-error-port port))
(r (thunk)))
(set-current-error-port save)
r))))
(define (with-output-to-port port thunk)
(let* ((save (current-output-port))
(foo (set-current-output-port port))
(r (thunk)))
(set-current-output-port save)
r))
(define core:open-input-file open-input-file)
(define (open-input-file file)
(let ((port (core:open-input-file file))
(debug (and=> (getenv "MES_DEBUG") string->number)))
(when (and debug (> debug 1))
(core:display-error (string-append "open-input-file: `" file "'"))
(when (> debug 3)
(core:display-error " port=")
(core:display-error port))
(core:display-error "\n"))
port))
(define (dirname file-name)
(let* ((lst (string-split file-name #\/))
(lst (filter (negate string-null?) lst)))
(if (null? lst) (if (string-prefix? "/" file-name) "/" ".")
(let ((dir (string-join (list-head lst (1- (length lst))) "/")))
(if (string-prefix? "/" file-name) (string-append "/" dir)
(if (string-null? dir) "."
dir))))))
(define (file-exists? o)
(access? o R_OK))

28
sysa/mes-0.22/mes/module/mes/lalr.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:
;;; lalr
(mes-use-module (mes scm))
(mes-use-module (mes syntax))
(mes-use-module (srfi srfi-9))
(include-from-path "mes/lalr.scm")

2120
sysa/mes-0.22/mes/module/mes/lalr.scm Normal file
View file

File diff suppressed because it is too large Load diff

74
sysa/mes-0.22/mes/module/mes/let.mes Normal file
View file

@ -0,0 +1,74 @@
;;; -*-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:
;;; let.mes is loaded after base and quasiquote. It provides
;;; let, let* and named let.
;;; Code:
(mes-use-module (mes base))
(mes-use-module (mes quasiquote))
(define-macro (simple-let bindings . rest)
(cons (cons 'lambda (cons (map1 car bindings) rest))
(map1 cadr bindings)))
(define-macro (xsimple-let bindings rest)
`(,`(lambda ,(map1 car bindings) ,@rest)
,@(map1 cadr bindings)))
(define-macro (xnamed-let name bindings rest)
`(simple-let ((,name *unspecified*))
(set! ,name (lambda ,(map1 car bindings) ,@rest))
(,name ,@(map1 cadr bindings))))
(define-macro (let bindings-or-name . rest)
(if (symbol? bindings-or-name)
`(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
`(xsimple-let ,bindings-or-name ,rest)))
(define (expand-let* bindings body)
(if (null? bindings)
`((lambda () ,@body))
`((lambda (,(caar bindings))
,(expand-let* (cdr bindings) body))
,@(cdar bindings))))
(define-macro (let* bindings . body)
(expand-let* bindings body))
(define (unspecified-bindings bindings params)
(if (null? bindings) params
(unspecified-bindings
(cdr bindings)
(append params (cons (cons (caar bindings) '(*unspecified*)) '())))))
(define (letrec-setters bindings setters)
(if (null? bindings) setters
(letrec-setters (cdr bindings)
(append setters
(cons (cons 'set! (car bindings)) '())))))
(define-macro (letrec bindings . body)
`(let ,(unspecified-bindings bindings '())
,@(letrec-setters bindings '())
,@body))

26
sysa/mes-0.22/mes/module/mes/match.mes Normal file
View file

@ -0,0 +1,26 @@
;;; -*-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:
;;; portable matcher
(mes-use-module (mes syntax))
(include-from-path "mes/match.scm")

934
sysa/mes-0.22/mes/module/mes/match.scm Normal file
View file

@ -0,0 +1,934 @@
;;; match.scm -- portable hygienic pattern matcher -*- coding: utf-8; mode: scheme -*-
;;
;; This code is written by Alex Shinn and placed in the
;; Public Domain. All warranties are disclaimed.
;;> @example-import[(srfi 9)]
;;> This is a full superset of the popular @hyperlink[
;;> "http://www.cs.indiana.edu/scheme-repository/code.match.html"]{match}
;;> package by Andrew Wright, written in fully portable @scheme{syntax-rules}
;;> and thus preserving hygiene.
;;> The most notable extensions are the ability to use @emph{non-linear}
;;> patterns - patterns in which the same identifier occurs multiple
;;> times, tail patterns after ellipsis, and the experimental tree patterns.
;;> @subsubsection{Patterns}
;;> Patterns are written to look like the printed representation of
;;> the objects they match. The basic usage is
;;> @scheme{(match expr (pat body ...) ...)}
;;> where the result of @var{expr} is matched against each pattern in
;;> turn, and the corresponding body is evaluated for the first to
;;> succeed. Thus, a list of three elements matches a list of three
;;> elements.
;;> @example{(let ((ls (list 1 2 3))) (match ls ((1 2 3) #t)))}
;;> If no patterns match an error is signalled.
;;> Identifiers will match anything, and make the corresponding
;;> binding available in the body.
;;> @example{(match (list 1 2 3) ((a b c) b))}
;;> If the same identifier occurs multiple times, the first instance
;;> will match anything, but subsequent instances must match a value
;;> which is @scheme{equal?} to the first.
;;> @example{(match (list 1 2 1) ((a a b) 1) ((a b a) 2))}
;;> The special identifier @scheme{_} matches anything, no matter how
;;> many times it is used, and does not bind the result in the body.
;;> @example{(match (list 1 2 1) ((_ _ b) 1) ((a b a) 2))}
;;> To match a literal identifier (or list or any other literal), use
;;> @scheme{quote}.
;;> @example{(match 'a ('b 1) ('a 2))}
;;> Analogous to its normal usage in scheme, @scheme{quasiquote} can
;;> be used to quote a mostly literally matching object with selected
;;> parts unquoted.
;;> @example|{(match (list 1 2 3) (`(1 ,b ,c) (list b c)))}|
;;> Often you want to match any number of a repeated pattern. Inside
;;> a list pattern you can append @scheme{...} after an element to
;;> match zero or more of that pattern (like a regexp Kleene star).
;;> @example{(match (list 1 2) ((1 2 3 ...) #t))}
;;> @example{(match (list 1 2 3) ((1 2 3 ...) #t))}
;;> @example{(match (list 1 2 3 3 3) ((1 2 3 ...) #t))}
;;> Pattern variables matched inside the repeated pattern are bound to
;;> a list of each matching instance in the body.
;;> @example{(match (list 1 2) ((a b c ...) c))}
;;> @example{(match (list 1 2 3) ((a b c ...) c))}
;;> @example{(match (list 1 2 3 4 5) ((a b c ...) c))}
;;> More than one @scheme{...} may not be used in the same list, since
;;> this would require exponential backtracking in the general case.
;;> However, @scheme{...} need not be the final element in the list,
;;> and may be succeeded by a fixed number of patterns.
;;> @example{(match (list 1 2 3 4) ((a b c ... d e) c))}
;;> @example{(match (list 1 2 3 4 5) ((a b c ... d e) c))}
;;> @example{(match (list 1 2 3 4 5 6 7) ((a b c ... d e) c))}
;;> @scheme{___} is provided as an alias for @scheme{...} when it is
;;> inconvenient to use the ellipsis (as in a syntax-rules template).
;;> The @scheme{..1} syntax is exactly like the @scheme{...} except
;;> that it matches one or more repetitions (like a regexp "+").
;;> @example{(match (list 1 2) ((a b c ..1) c))}
;;> @example{(match (list 1 2 3) ((a b c ..1) c))}
;;> The boolean operators @scheme{and}, @scheme{or} and @scheme{not}
;;> can be used to group and negate patterns analogously to their
;;> Scheme counterparts.
;;> The @scheme{and} operator ensures that all subpatterns match.
;;> This operator is often used with the idiom @scheme{(and x pat)} to
;;> bind @var{x} to the entire value that matches @var{pat}
;;> (c.f. "as-patterns" in ML or Haskell). Another common use is in
;;> conjunction with @scheme{not} patterns to match a general case
;;> with certain exceptions.
;;> @example{(match 1 ((and) #t))}
;;> @example{(match 1 ((and x) x))}
;;> @example{(match 1 ((and x 1) x))}
;;> The @scheme{or} operator ensures that at least one subpattern
;;> matches. If the same identifier occurs in different subpatterns,
;;> it is matched independently. All identifiers from all subpatterns
;;> are bound if the @scheme{or} operator matches, but the binding is
;;> only defined for identifiers from the subpattern which matched.
;;> @example{(match 1 ((or) #t) (else #f))}
;;> @example{(match 1 ((or x) x))}
;;> @example{(match 1 ((or x 2) x))}
;;> The @scheme{not} operator succeeds if the given pattern doesn't
;;> match. None of the identifiers used are available in the body.
;;> @example{(match 1 ((not 2) #t))}
;;> The more general operator @scheme{?} can be used to provide a
;;> predicate. The usage is @scheme{(? predicate pat ...)} where
;;> @var{predicate} is a Scheme expression evaluating to a predicate
;;> called on the value to match, and any optional patterns after the
;;> predicate are then matched as in an @scheme{and} pattern.
;;> @example{(match 1 ((? odd? x) x))}
;;> The field operator @scheme{=} is used to extract an arbitrary
;;> field and match against it. It is useful for more complex or
;;> conditional destructuring that can't be more directly expressed in
;;> the pattern syntax. The usage is @scheme{(= field pat)}, where
;;> @var{field} can be any expression, and should result in a
;;> procedure of one argument, which is applied to the value to match
;;> to generate a new value to match against @var{pat}.
;;> Thus the pattern @scheme{(and (= car x) (= cdr y))} is equivalent
;;> to @scheme{(x . y)}, except it will result in an immediate error
;;> if the value isn't a pair.
;;> @example{(match '(1 . 2) ((= car x) x))}
;;> @example{(match 4 ((= sqrt x) x))}
;;> The record operator @scheme{$} is used as a concise way to match
;;> records defined by SRFI-9 (or SRFI-99). The usage is
;;> @scheme{($ rtd field ...)}, where @var{rtd} should be the record
;;> type descriptor specified as the first argument to
;;> @scheme{define-record-type}, and each @var{field} is a subpattern
;;> matched against the fields of the record in order. Not all fields
;;> must be present.
;;> @example{
;;> (let ()
;;> (define-record-type employee
;;> (make-employee name title)
;;> employee?
;;> (name get-name)
;;> (title get-title))
;;> (match (make-employee "Bob" "Doctor")
;;> (($ employee n t) (list t n))))
;;> }
;;> The @scheme{set!} and @scheme{get!} operators are used to bind an
;;> identifier to the setter and getter of a field, respectively. The
;;> setter is a procedure of one argument, which mutates the field to
;;> that argument. The getter is a procedure of no arguments which
;;> returns the current value of the field.
;;> @example{(let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))}
;;> @example{(match '(1 . 2) ((1 . (get! g)) (g)))}
;;> The new operator @scheme{***} can be used to search a tree for
;;> subpatterns. A pattern of the form @scheme{(x *** y)} represents
;;> the subpattern @var{y} located somewhere in a tree where the path
;;> from the current object to @var{y} can be seen as a list of the
;;> form @scheme{(x ...)}. @var{y} can immediately match the current
;;> object in which case the path is the empty list. In a sense it's
;;> a 2-dimensional version of the @scheme{...} pattern.
;;> As a common case the pattern @scheme{(_ *** y)} can be used to
;;> search for @var{y} anywhere in a tree, regardless of the path
;;> used.
;;> @example{(match '(a (a (a b))) ((x *** 'b) x))}
;;> @example{(match '(a (b) (c (d e) (f g))) ((x *** 'g) x))}
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Notes
;; The implementation is a simple generative pattern matcher - each
;; pattern is expanded into the required tests, calling a failure
;; continuation if the tests fail. This makes the logic easy to
;; follow and extend, but produces sub-optimal code in cases where you
;; have many similar clauses due to repeating the same tests.
;; Nonetheless a smart compiler should be able to remove the redundant
;; tests. For MATCH-LET and DESTRUCTURING-BIND type uses there is no
;; performance hit.
;; The original version was written on 2006/11/29 and described in the
;; following Usenet post:
;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
;; and is still available at
;; http://synthcode.com/scheme/match-simple.scm
;; It's just 80 lines for the core MATCH, and an extra 40 lines for
;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar.
;;
;; A variant of this file which uses COND-EXPAND in a few places for
;; performance can be found at
;; http://synthcode.com/scheme/match-cond-expand.scm
;;
;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
;; the pattern (thanks to Stefan Israelsson Tampe)
;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic Courtès)
;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
;; 2009/11/25 - adding `***' tree search patterns
;; 2008/03/20 - fixing bug where (a ...) matched non-lists
;; 2008/03/15 - removing redundant check in vector patterns
;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
;; 2007/09/04 - fixing quasiquote patterns
;; 2007/07/21 - allowing ellipse patterns in non-final list positions
;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
;; (thanks to Taylor Campbell)
;; 2007/04/08 - clean up, commenting
;; 2006/12/24 - bugfixes
;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; force compile-time syntax errors with useful messages
(define-syntax match-syntax-error
(syntax-rules ()
((_) (match-syntax-error "invalid match-syntax-error usage"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> @subsubsection{Syntax}
;;> @subsubsubsection{@rawcode{(match expr (pattern . body) ...)@br{}
;;> (match expr (pattern (=> failure) . body) ...)}}
;;> The result of @var{expr} is matched against each @var{pattern} in
;;> turn, according to the pattern rules described in the previous
;;> section, until the the first @var{pattern} matches. When a match is
;;> found, the corresponding @var{body}s are evaluated in order,
;;> and the result of the last expression is returned as the result
;;> of the entire @scheme{match}. If a @var{failure} is provided,
;;> then it is bound to a procedure of no arguments which continues,
;;> processing at the next @var{pattern}. If no @var{pattern} matches,
;;> an error is signalled.
;; The basic interface. MATCH just performs some basic syntax
;; validation, binds the match expression to a temporary variable `v',
;; and passes it on to MATCH-NEXT. It's a constant throughout the
;; code below that the binding `v' is a direct variable reference, not
;; an expression.
(define-syntax match
(syntax-rules ()
((match)
(match-syntax-error "missing match expression"))
((match atom)
(match-syntax-error "no match clauses"))
((match (app ...) (pat . body) ...)
(let ((v (app ...)))
(match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
((match #(vec ...) (pat . body) ...)
(let ((v #(vec ...)))
(match-next v (v (set! v)) (pat . body) ...)))
((match atom (pat . body) ...)
(let ((v atom))
(match-next v (atom (set! atom)) (pat . body) ...)))
))
;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
;; clauses. `g+s' is a list of two elements, the get! and set!
;; expressions respectively.
(define-syntax match-next
(syntax-rules (=>)
;; no more clauses, the match failed
((match-next v g+s)
;; Here we call error in non-tail context, so that the backtrace
;; can show the source location of the failing match form.
(begin
(error 'match "no matching pattern" v)
#f))
;; named failure continuation
((match-next v g+s (pat (=> failure) . body) . rest)
(let ((failure (lambda () (match-next v g+s . rest))))
;; match-one analyzes the pattern for us
(match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
;; anonymous failure continuation, give it a dummy name
((match-next v g+s (pat . body) . rest)
(match-next v g+s (pat (=> failure) . body) . rest))))
;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
;; MATCH-TWO.
(define-syntax match-one
(syntax-rules ()
;; If it's a list of two or more values, check to see if the
;; second one is an ellipse and handle accordingly, otherwise go
;; to MATCH-TWO.
((match-one v (p q . r) g+s sk fk i)
(match-check-ellipse
q
(match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())
(match-two v (p q . r) g+s sk fk i)))
;; Go directly to MATCH-TWO.
((match-one . x)
(match-two . x))))
;; This is the guts of the pattern matcher. We are passed a lot of
;; information in the form:
;;
;; (match-two var pattern getter setter success-k fail-k (ids ...))
;;
;; usually abbreviated
;;
;; (match-two v p g+s sk fk i)
;;
;; where VAR is the symbol name of the current variable we are
;; matching, PATTERN is the current pattern, getter and setter are the
;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
;; continuation (which is just a thunk call and is thus safe to expand
;; multiple times) and IDS are the list of identifiers bound in the
;; pattern so far.
(define-syntax match-two
(syntax-rules (_ ___ ..1 *** quote quasiquote ? $ = and or not set! get!)
((match-two v () g+s (sk ...) fk i)
(if (null? v) (sk ... i) fk))
((match-two v (quote p) g+s (sk ...) fk i)
(if (equal? v 'p) (sk ... i) fk))
((match-two v (quasiquote p) . x)
(match-quasiquote v p . x))
((match-two v (and) g+s (sk ...) fk i) (sk ... i))
((match-two v (and p q ...) g+s sk fk i)
(match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
((match-two v (or) g+s sk fk i) fk)
((match-two v (or p) . x)
(match-one v p . x))
((match-two v (or p ...) g+s sk fk i)
(match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
((match-two v (not p) g+s (sk ...) fk i)
(match-one v p g+s (match-drop-ids fk) (sk ... i) i))
((match-two v (get! getter) (g s) (sk ...) fk i)
(let ((getter (lambda () g))) (sk ... i)))
((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
(let ((setter (lambda (x) (s ... x)))) (sk ... i)))
((match-two v (? pred . p) g+s sk fk i)
(if (pred v) (match-one v (and . p) g+s sk fk i) fk))
((match-two v (= proc p) . x)
(let ((w (proc v))) (match-one w p . x))
;;(let ((W (proc v))) (match-one W p . x))
)
((match-two v (p ___ . r) g+s sk fk i)
(match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
((match-two v (p) g+s sk fk i)
(if (and (pair? v) (null? (cdr v)))
(let ;;((w (car v)))
((W (car v)))
;;(match-one w p ((car v) (set-car! v)) sk fk i)
(match-one W p ((car v) (set-car! v)) sk fk i)
)
fk))
((match-two v (p *** q) g+s sk fk i)
(match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
((match-two v (p *** . q) g+s sk fk i)
(match-syntax-error "invalid use of ***" (p *** . q)))
((match-two v (p ..1) g+s sk fk i)
(if (pair? v)
(match-one v (p ___) g+s sk fk i)
fk))
((match-two v ($ rec p ...) g+s sk fk i)
(if (is-a? v rec)
(match-record-refs v rec 0 (p ...) g+s sk fk i)
fk))
((match-two v (p . q) g+s sk fk i)
(if (pair? v)
(let ;;((w (car v)) (x (cdr v)))
((W (car v)) (X (cdr v)))
(match-one ;;w p ((car v) (set-car! v))
W p ((car v) (set-car! v))
;;(match-one x q ((cdr v) (set-cdr! v)) sk fk)
(match-one X q ((cdr v) (set-cdr! v)) sk fk)
fk
i))
fk))
((match-two v #(p ...) g+s . x)
(match-vector v 0 () (p ...) . x))
((match-two v _ g+s (sk ...) fk i) (sk ... i))
;; Not a pair or vector or special literal, test to see if it's a
;; new symbol, in which case we just bind it, or if it's an
;; already bound symbol or some other literal, in which case we
;; compare it with EQUAL?.
(;;(match-two v x g+s (sk ...) fk (id ...))
(match-two V X g+s (sk ...) fk (id ...))
(let-syntax
((new-sym?
(syntax-rules (id ...)
;;((new-sym? x sk2 fk2) sk2)
((new-sym? X sk2 fk2) sk2)
((new-sym? y sk2 fk2) fk2))))
(new-sym? random-sym-to-match
;;(let ((x v)) (sk ... (id ... x)))
(let ((X V)) (sk ... (id ... X)))
;;(if (equal? v x) (sk ... (id ...)) fk)
(if (equal? V X) (sk ... (id ...)) fk)
)))
))
;; QUASIQUOTE patterns
(define-syntax match-quasiquote
(syntax-rules (unquote unquote-splicing quasiquote)
((_ v (unquote p) g+s sk fk i)
(match-one v p g+s sk fk i))
((_ v ((unquote-splicing p) . rest) g+s sk fk i)
(if (pair? v)
(match-one v
(p . tmp)
(match-quasiquote tmp rest g+s sk fk)
fk
i)
fk))
((_ v (quasiquote p) g+s sk fk i . depth)
(match-quasiquote v p g+s sk fk i #f . depth))
((_ v (unquote p) g+s sk fk i x . depth)
(match-quasiquote v p g+s sk fk i . depth))
((_ v (unquote-splicing p) g+s sk fk i x . depth)
(match-quasiquote v p g+s sk fk i . depth))
((_ v (p . q) g+s sk fk i . depth)
(if (pair? v)
(let ;;((w (car v)) (x (cdr v)))
((W (car v)) (X (cdr v)))
(match-quasiquote
;;w p g+s
W p g+s
;;(match-quasiquote-step x q g+s sk fk depth)
(match-quasiquote-step X q g+s sk fk depth)
fk i . depth))
fk))
((_ v #(elt ...) g+s sk fk i . depth)
(if (vector? v)
(let ((ls (vector->list v)))
(match-quasiquote ls (elt ...) g+s sk fk i . depth))
fk))
((_ v x g+s sk fk i . depth)
(match-one v 'x g+s sk fk i))))
(define-syntax match-quasiquote-step
(syntax-rules ()
((match-quasiquote-step x q g+s sk fk depth i)
(match-quasiquote x q g+s sk fk i . depth))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utilities
;; Takes two values and just expands into the first.
(define-syntax match-drop-ids
(syntax-rules ()
((_ expr ids ...) expr)))
(define-syntax match-tuck-ids
(syntax-rules ()
((_ (letish args (expr ...)) ids ...)
(letish args (expr ... ids ...)))))
(define-syntax match-drop-first-arg
(syntax-rules ()
((_ arg expr) expr)))
;; To expand an OR group we try each clause in succession, passing the
;; first that succeeds to the success continuation. On failure for
;; any clause, we just try the next clause, finally resorting to the
;; failure continuation fk if all clauses fail. The only trick is
;; that we want to unify the identifiers, so that the success
;; continuation can refer to a variable from any of the OR clauses.
(define-syntax match-gen-or
(syntax-rules ()
((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
(let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
(match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
(define-syntax match-gen-or-step
(syntax-rules ()
((_ v () g+s sk fk . x)
;; no OR clauses, call the failure continuation
fk)
((_ v (p) . x)
;; last (or only) OR clause, just expand normally
(match-one v p . x))
((_ v (p . q) g+s sk fk i)
;; match one and try the remaining on failure
(let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
(match-one v p g+s sk (fk2) i)))
))
;; We match a pattern (p ...) by matching the pattern p in a loop on
;; each element of the variable, accumulating the bound ids into lists.
;; Look at the body of the simple case - it's just a named let loop,
;; matching each element in turn to the same pattern. The only trick
;; is that we want to keep track of the lists of each extracted id, so
;; when the loop recurses we cons the ids onto their respective list
;; variables, and on success we bind the ids (what the user input and
;; expects to see in the success body) to the reversed accumulated
;; list IDs.
(define-syntax match-gen-ellipses
(syntax-rules ()
(;;(_ v p () g+s (sk ...) fk i ((id id-ls) ...))
(_ v P () g+s (sk ...) fk i ((id id-ls) ...))
(match-check-identifier
;;p
P
;; simplest case equivalent to (p ...), just bind the list
(let ;;((p v))
((P v))
(if ;;(list? p)
(list? P)
(sk ... i)
fk))
;; simple case, match all elements of the list
(let loop ((ls v) (id-ls '()) ...)
(cond
((null? ls)
(let ((id (reverse id-ls)) ...) (sk ... i)))
((pair? ls)
(let ;;((w (car ls)))
((W (car ls)))
(match-one ;;w p ((car ls) (set-car! ls))
W p ((car ls) (set-car! ls))
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
fk i)))
(else
fk)))))
((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
;; general case, trailing patterns to match, keep track of the
;; remaining list length so we don't need any backtracking
(match-verify-no-ellipses
r
(let* ((tail-len (length 'r))
(ls v)
(len (and (list? ls) (length ls))))
(if (or (not len) (< len tail-len))
fk
(let loop ((ls ls) (n len) (id-ls '()) ...)
(cond
((= n tail-len)
(let ((id (reverse id-ls)) ...)
(match-one ls r (#f #f) (sk ...) fk i)))
((pair? ls)
(let ((w (car ls)))
(match-one w p ((car ls) (set-car! ls))
(match-drop-ids
(loop (cdr ls) (- n 1) (cons id id-ls) ...))
fk
i)))
(else
fk)))))))))
;; This is just a safety check. Although unlike syntax-rules we allow
;; trailing patterns after an ellipses, we explicitly disable multiple
;; ellipses at the same level. This is because in the general case
;; such patterns are exponential in the number of ellipses, and we
;; don't want to make it easy to construct very expensive operations
;; with simple looking patterns. For example, it would be O(n^2) for
;; patterns like (a ... b ...) because we must consider every trailing
;; element for every possible break for the leading "a ...".
(define-syntax match-verify-no-ellipses
(syntax-rules ()
((_ (x . y) sk)
(match-check-ellipse
x
(match-syntax-error
"multiple ellipse patterns not allowed at same level")
(match-verify-no-ellipses y sk)))
((_ () sk)
sk)
((_ x sk)
(match-syntax-error "dotted tail not allowed after ellipse" x))))
;; To implement the tree search, we use two recursive procedures. TRY
;; attempts to match Y once, and on success it calls the normal SK on
;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we
;; call NEXT which first checks if the current value is a list
;; beginning with X, then calls TRY on each remaining element of the
;; list. Since TRY will recursively call NEXT again on failure, this
;; effects a full depth-first search.
;;
;; The failure continuation throughout is a jump to the next step in
;; the tree search, initialized with the original failure continuation
;; FK.
(define-syntax match-gen-search
(syntax-rules ()
((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
(letrec ((try (lambda (w fail id-ls ...)
(match-one w q g+s
(match-tuck-ids
(let ((id (reverse id-ls)) ...)
sk))
(next w fail id-ls ...) i)))
(next (lambda (w fail id-ls ...)
(if (not (pair? w))
(fail)
(let ((u (car w)))
(match-one
u p ((car w) (set-car! w))
(match-drop-ids
;; accumulate the head variables from
;; the p pattern, and loop over the tail
(let ((id-ls (cons id id-ls)) ...)
(let lp ((ls (cdr w)))
(if (pair? ls)
(try (car ls)
(lambda () (lp (cdr ls)))
id-ls ...)
(fail)))))
(fail) i))))))
;; the initial id-ls binding here is a dummy to get the right
;; number of '()s
(let ((id-ls '()) ...)
(try v (lambda () fk) id-ls ...))))))
;; Vector patterns are just more of the same, with the slight
;; exception that we pass around the current vector index being
;; matched.
(define-syntax match-vector
(syntax-rules (___)
((_ v n pats (p q) . x)
(match-check-ellipse q
(match-gen-vector-ellipses v n pats p . x)
(match-vector-two v n pats (p q) . x)))
((_ v n pats (p ___) sk fk i)
(match-gen-vector-ellipses v n pats p sk fk i))
((_ . x)
(match-vector-two . x))))
;; Check the exact vector length, then check each element in turn.
(define-syntax match-vector-two
(syntax-rules ()
((_ v n ((pat index) ...) () sk fk i)
(if (vector? v)
(let ((len (vector-length v)))
(if (= len n)
(match-vector-step v ((pat index) ...) sk fk i)
fk))
fk))
((_ v n (pats ...) (p . q) . x)
(match-vector v (+ n 1) (pats ... (p n)) q . x))))
(define-syntax match-vector-step
(syntax-rules ()
((_ v () (sk ...) fk i) (sk ... i))
((_ v ((pat index) . rest) sk fk i)
(let ((w (vector-ref v index)))
(match-one w pat ((vector-ref v index) (vector-set! v index))
(match-vector-step v rest sk fk)
fk i)))))
;; With a vector ellipse pattern we first check to see if the vector
;; length is at least the required length.
(define-syntax match-gen-vector-ellipses
(syntax-rules ()
((_ v n ((pat index) ...) p sk fk i)
(if (vector? v)
(let ((len (vector-length v)))
(if (>= len n)
(match-vector-step v ((pat index) ...)
(match-vector-tail v p n len sk fk)
fk i)
fk))
fk))))
(define-syntax match-vector-tail
(syntax-rules ()
((_ v p n len sk fk i)
(match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
(define-syntax match-vector-tail-two
(syntax-rules ()
((_ v p n len (sk ...) fk i ((id id-ls) ...))
(let loop ((j n) (id-ls '()) ...)
(if (>= j len)
(let ((id (reverse id-ls)) ...) (sk ... i))
(let ((w (vector-ref v j)))
(match-one w p ((vector-ref v j) (vetor-set! v j))
(match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
fk i)))))))
(define-syntax match-record-refs
(syntax-rules ()
((_ v rec n (p . q) g+s sk fk i)
(let ((w (slot-ref rec v n)))
(match-one w p ((slot-ref rec v n) (slot-set! rec v n))
(match-record-refs v rec (+ n 1) q g+s sk fk) fk i)))
((_ v rec n () g+s (sk ...) fk i)
(sk ... i))))
;; Extract all identifiers in a pattern. A little more complicated
;; than just looking for symbols, we need to ignore special keywords
;; and non-pattern forms (such as the predicate expression in ?
;; patterns), and also ignore previously bound identifiers.
;;
;; Calls the continuation with all new vars as a list of the form
;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
;; pair with the original variable (e.g. it's used in the ellipse
;; generation for list variables).
;;
;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
(define-syntax match-extract-vars
(syntax-rules (_ ___ ..1 *** ? $ = quote quasiquote and or not get! set!)
((match-extract-vars (? pred . p) . x)
(match-extract-vars p . x))
((match-extract-vars ($ rec . p) . x)
(match-extract-vars p . x))
((match-extract-vars (= proc p) . x)
(match-extract-vars p . x))
((match-extract-vars (quote x) (k ...) i v)
(k ... v))
((match-extract-vars (quasiquote x) k i v)
(match-extract-quasiquote-vars x k i v (#t)))
((match-extract-vars (and . p) . x)
(match-extract-vars p . x))
((match-extract-vars (or . p) . x)
(match-extract-vars p . x))
((match-extract-vars (not . p) . x)
(match-extract-vars p . x))
;; A non-keyword pair, expand the CAR with a continuation to
;; expand the CDR.
((match-extract-vars (p q . r) k i v)
(match-check-ellipse
q
(match-extract-vars (p . r) k i v)
(match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
((match-extract-vars (p . q) k i v)
(match-extract-vars p (match-extract-vars-step q k i v) i ()))
((match-extract-vars #(p ...) . x)
(match-extract-vars (p ...) . x))
((match-extract-vars _ (k ...) i v) (k ... v))
((match-extract-vars ___ (k ...) i v) (k ... v))
((match-extract-vars *** (k ...) i v) (k ... v))
((match-extract-vars ..1 (k ...) i v) (k ... v))
;; This is the main part, the only place where we might add a new
;; var if it's an unbound symbol.
((match-extract-vars p (k ...) (i ...) v)
(let-syntax
((new-sym?
(syntax-rules (i ...)
((new-sym? p sk fk) sk)
((new-sym? any sk fk) fk))))
(new-sym? random-sym-to-match
(k ... ((p p-ls) . v))
(k ... v))))
))
;; Stepper used in the above so it can expand the CAR and CDR
;; separately.
(define-syntax match-extract-vars-step
(syntax-rules ()
((_ p k i v ((v2 v2-ls) ...))
(match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
))
(define-syntax match-extract-quasiquote-vars
(syntax-rules (quasiquote unquote unquote-splicing)
((match-extract-quasiquote-vars (quasiquote x) k i v d)
(match-extract-quasiquote-vars x k i v (#t . d)))
((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
(match-extract-quasiquote-vars (unquote x) k i v d))
((match-extract-quasiquote-vars (unquote x) k i v (#t))
(match-extract-vars x k i v))
((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
(match-extract-quasiquote-vars x k i v d))
((match-extract-quasiquote-vars (x . y) k i v (#t . d))
(match-extract-quasiquote-vars
x
(match-extract-quasiquote-vars-step y k i v d) i ()))
((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
(match-extract-quasiquote-vars (x ...) k i v d))
((match-extract-quasiquote-vars x (k ...) i v (#t . d))
(k ... v))
))
(define-syntax match-extract-quasiquote-vars-step
(syntax-rules ()
((_ x k i v d ((v2 v2-ls) ...))
(match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Gimme some sugar baby.
;;> Shortcut for @scheme{lambda} + @scheme{match}. Creates a
;;> procedure of one argument, and matches that argument against each
;;> clause.
(define-syntax match-lambda
(syntax-rules ()
((_ (pattern . body) ...) (lambda (expr) (match expr (pattern . body) ...)))))
;;> Similar to @scheme{match-lambda}. Creates a procedure of any
;;> number of arguments, and matches the argument list against each
;;> clause.
(define-syntax match-lambda*
(syntax-rules ()
((_ (pattern . body) ...) (lambda expr (match expr (pattern . body) ...)))))
;;> Matches each var to the corresponding expression, and evaluates
;;> the body with all match variables in scope. Raises an error if
;;> any of the expressions fail to match. Syntax analogous to named
;;> let can also be used for recursive functions which match on their
;;> arguments as in @scheme{match-lambda*}.
(define-syntax match-let
(syntax-rules ()
((_ ((var value) ...) . body)
(match-let/helper let () () ((var value) ...) . body))
((_ loop ((var init) ...) . body)
(match-named-let loop ((var init) ...) . body))))
;; ;;> Similar to @scheme{match-let}, but analogously to @scheme{letrec}
;; ;;> matches and binds the variables with all match variables in scope.
;; (define-syntax match-letrec
;; (syntax-rules ()
;; ((_ ((var value) ...) . body)
;; (match-let/helper letrec () () ((var value) ...) . body))))
;; (define-syntax match-let/helper
;; (syntax-rules ()
;; ((_ let ((var expr) ...) () () . body)
;; (let ((var expr) ...) . body))
;; ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
;; (let ((var expr) ...)
;; (match-let* ((pat tmp) ...)
;; . body)))
;; ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
;; (match-let/helper
;; let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
;; ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
;; (match-let/helper
;; let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
;; ((_ let (v ...) (p ...) ((a expr) . rest) . body)
;; (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
(define-syntax match-named-let
(syntax-rules ()
((_ loop ((pat expr var) ...) () . body)
(let loop ((var expr) ...)
(match-let ((pat var) ...)
. body)))
((_ loop (v ...) ((pat expr) . rest) . body)
(match-named-let loop (v ... (pat expr tmp)) rest . body))))
;;> @subsubsubsection{@rawcode{(match-let* ((var value) ...) body ...)}}
;;> Similar to @scheme{match-let}, but analogously to @scheme{let*}
;;> matches and binds the variables in sequence, with preceding match
;;> variables in scope.
(define-syntax match-let*
(syntax-rules ()
((_ () . body)
(begin . body))
((_ ((pat expr) . rest) . body)
(match expr (pat (match-let* rest . body))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Otherwise COND-EXPANDed bits.
;; This *should* work, but doesn't :(
;; (define-syntax match-check-ellipse
;; (syntax-rules (...)
;; ((_ ... sk fk) sk)
;; ((_ x sk fk) fk)))
;; This is a little more complicated, and introduces a new let-syntax,
;; but should work portably in any R[56]RS Scheme. Taylor Campbell
;; originally came up with the idea.
(define-syntax match-check-ellipse
(syntax-rules ()
;; these two aren't necessary but provide fast-case failures
((match-check-ellipse (a . b) success-k failure-k) failure-k)
((match-check-ellipse #(a ...) success-k failure-k) failure-k)
;; matching an atom
((match-check-ellipse id success-k failure-k)
(let-syntax ((ellipse? (syntax-rules ()
;; iff `id' is `...' here then this will
;; match a list of any length
((ellipse? (foo id) sk fk) sk)
((ellipse? other sk fk) fk))))
;; this list of three elements will only many the (foo id) list
;; above if `id' is `...'
(ellipse? (a b c) success-k failure-k)))))
;; This is portable but can be more efficient with non-portable
;; extensions. This trick was originally discovered by Oleg Kiselyov.
(define-syntax match-check-identifier
(syntax-rules ()
;; fast-case failures, lists and vectors are not identifiers
((_ (x . y) success-k failure-k) failure-k)
((_ #(x ...) success-k failure-k) failure-k)
;; x is an atom
((_ x success-k failure-k)
(let-syntax
((sym?
(syntax-rules ()
;; if the symbol `abracadabra' matches x, then x is a
;; symbol
((sym? x sk fk) sk)
;; otherwise x is a non-symbol datum
((sym? y sk fk) fk))))
(sym? abracadabra success-k failure-k)))))

25
sysa/mes-0.22/mes/module/mes/mescc.mes Normal file
View file

@ -0,0 +1,25 @@
;;; -*-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:
;;; Code:
(include-from-path "mes/mescc.scm")

21
sysa/mes-0.22/mes/module/mes/misc.mes Normal file
View file

@ -0,0 +1,21 @@
;;; -*-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/>.
(include-from-path "mes/misc.scm")

64
sysa/mes-0.22/mes/module/mes/module.mes Normal file
View file

@ -0,0 +1,64 @@
;;; -*-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:
;;; Code:
(define (module->file o)
(string-append (string-join (map symbol->string o) "/") ".mes"))
(define *modules* '(mes/base-0.mes))
(define-macro (mes-use-module module)
(list 'if (list not (list memq (list string->symbol (module->file module)) '*modules*))
(list
'begin
(list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*))
(list 'load (list string-append '%moduledir (module->file module))))
(list 'if (and (getenv "MES_DEBUG") (list '> (list 'core:cdr (list 'car (list 'string->list (getenv "MES_DEBUG")))) 50))
(list 'begin
(list core:display-error ";;; already loaded: ")
(list core:display-error (list 'quote module))
(list core:display-error "\n")))))
(define *input-ports* '())
(define-macro (push! stack o)
(cons
'begin
(list
(list 'set! stack (list cons o stack))
stack)))
(define-macro (pop! stack)
(list 'let (list (list 'o (list car stack)))
(list 'set! stack (list cdr stack))
'o))
(define (mes-load-module-env module a)
(push! *input-ports* (current-input-port))
(set-current-input-port (open-input-file (string-append %moduledir (module->file module))))
(let ((x (core:eval (append2 (cons 'begin (read-input-file-env a))
'((current-module)))
a)))
(set-current-input-port (pop! *input-ports*))
x))
(define (mes-load-module-env module a)
((lambda (file-name)
(core:write-error file-name) (core:display-error "\n")
(primitive-load file-name))
(string-append %moduledir (module->file module))))

38
sysa/mes-0.22/mes/module/mes/optargs.mes Normal file
View file

@ -0,0 +1,38 @@
;;; -*-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:
;;; Optargs (define*, lambda* et al.) from Guile
;;; Code:
(mes-use-module (mes scm))
(define-macro (defmacro name args . body)
`(define-macro ,(cons name args) ,@body))
(define-macro (set-procedure-property! proc key value)
proc)
(include-from-path "mes/optargs.scm")
(define-macro (define-macro* NAME+ARGLIST . BODY)
`(define-macro ,(car NAME+ARGLIST) #f (lambda* ,(cdr NAME+ARGLIST) ,@BODY)))

41
sysa/mes-0.22/mes/module/mes/peg.mes Normal file
View file

@ -0,0 +1,41 @@
;;; -*-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:
;;; peg.mes is loaded after syntax-case: psyntax. It provides PEG
;;; from Guile-2.1.
;;; Code:
(mes-use-module (mes let))
(mes-use-module (mes scm))
(mes-use-module (mes guile))
(mes-use-module (mes pretty-print))
(mes-use-module (mes psyntax))
(mes-use-module (srfi srfi-13))
;;(mes-use-module (srfi srfi-9-psyntax))
;;(mes-use-module (srfi srfi-9))
(mes-use-module (mes pmatch))
(include-from-path "mes/peg/cache.scm")
(include-from-path "mes/peg/codegen.scm")
(include-from-path "mes/peg/string-peg.scm")
(include-from-path "mes/peg/using-parsers.scm")
(include-from-path "mes/peg/simplify-tree.scm")

47
sysa/mes-0.22/mes/module/mes/peg/cache.scm Normal file
View file

@ -0,0 +1,47 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2010, 2011 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/>.
;;; Taken from GNU Guile
;;; cache.scm --- cache the results of parsing
(define-module (ice-9 peg cache)
#:export (cg-cached-parser))
;; The results of parsing using a nonterminal are cached. Think of it like a
;; hash with no conflict resolution. Process for deciding on the cache size
;; wasn't very scientific; just ran the benchmarks and stopped a little after
;; the point of diminishing returns on my box.
(define *cache-size* 512)
(define (make-cache)
(make-vector *cache-size* #f))
;; given a syntax object which is a parser function, returns syntax
;; which, if evaluated, will become a parser function that uses a cache.
(define (cg-cached-parser parser)
#`(let ((cache (make-cache)))
(lambda (str strlen at)
(let* ((vref (vector-ref cache (modulo at *cache-size*))))
;; Check to see whether the value is cached.
(if (and vref (eq? (car vref) str) (= (cadr vref) at))
(caddr vref);; If it is return it.
(let ((fres ;; Else calculate it and cache it.
(#,parser str strlen at)))
(vector-set! cache (modulo at *cache-size*)
(list str at fres))
fres))))))

361
sysa/mes-0.22/mes/module/mes/peg/codegen.scm Normal file
View file

@ -0,0 +1,361 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2011 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/>.
;;; Taken from GNU Guile
;;; codegen.scm --- code generation for composable parsers
(define-module (ice-9 peg codegen)
#:export (compile-peg-pattern wrap-parser-for-users add-peg-compiler!)
#:use-module (ice-9 pretty-print)
#:use-module (system base pmatch))
(define-syntax single?
(syntax-rules ()
;;"Return #t if X is a list of one element."
((_ x)
(pmatch x
((_) #t)
(else #f)))))
(define-syntax single-filter
(syntax-rules ()
;;"If EXP is a list of one element, return the element. Otherwise return EXP."
((_ exp)
(pmatch exp
((,elt) elt)
(,elts elts)))))
(define-syntax push-not-null!
(syntax-rules ()
;;"If OBJ is non-null, push it onto LST, otherwise do nothing."
((_ lst obj)
(if (not (null? obj))
(push! lst obj)))))
(define-syntax push!
(syntax-rules ()
;;"Push an object onto a list."
((_ lst obj)
(set! lst (cons obj lst)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; CODE GENERATORS
;; These functions generate scheme code for parsing PEGs.
;; Conventions:
;; accum: (all name body none)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Code we generate will have a certain return structure depending on how we're
;; accumulating (the ACCUM variable).
(define (cg-generic-ret accum name body-uneval at)
;; name, body-uneval and at are syntax
#`(let ((body #,body-uneval))
#,(cond
((and (eq? accum 'all) name)
#`(list #,at
(cond
((not (list? body)) (list '#,name body))
((null? body) '#,name)
((symbol? (car body)) (list '#,name body))
(else (cons '#,name body)))))
((eq? accum 'name)
#`(list #,at '#,name))
((eq? accum 'body)
#`(list #,at
(cond
((single? body) (car body))
(else body))))
((eq? accum 'none)
#`(list #,at '()))
(else
(begin
(pretty-print `(cg-generic-ret-error ,accum ,name ,body-uneval ,at))
(pretty-print "Defaulting to accum of none.\n")
#`(list #,at '()))))))
;; The short name makes the formatting below much easier to read.
(define cggr cg-generic-ret)
;; Generates code that matches a particular string.
;; E.g.: (cg-string syntax "abc" 'body)
(define (cg-string pat accum)
(let ((plen (string-length pat)))
#`(lambda (str len pos)
(let ((end (+ pos #,plen)))
(and (<= end len)
(string= str #,pat pos end)
#,(case accum
((all) #`(list end (list 'cg-string #,pat)))
((name) #`(list end 'cg-string))
((body) #`(list end #,pat))
((none) #`(list end '()))
(else (error "bad accum" accum))))))))
;; Generates code for matching any character.
;; E.g.: (cg-peg-any syntax 'body)
(define (cg-peg-any accum)
#`(lambda (str len pos)
(and (< pos len)
#,(case accum
((all) #`(list (1+ pos)
(list 'cg-peg-any (substring str pos (1+ pos)))))
((name) #`(list (1+ pos) 'cg-peg-any))
((body) #`(list (1+ pos) (substring str pos (1+ pos))))
((none) #`(list (1+ pos) '()))
(else (error "bad accum" accum))))))
;; Generates code for matching a range of characters between start and end.
;; E.g.: (cg-range syntax #\a #\z 'body)
(define (cg-range pat accum)
(syntax-case pat ()
((start end)
(if (not (and (char? (syntax->datum #'start))
(char? (syntax->datum #'end))))
(error "range PEG should have characters after it; instead got"
#'start #'end))
#`(lambda (str len pos)
(and (< pos len)
(let ((c (string-ref str pos)))
(and (char>=? c start)
(char<=? c end)
#,(case accum
((all) #`(list (1+ pos) (list 'cg-range (string c))))
((name) #`(list (1+ pos) 'cg-range))
((body) #`(list (1+ pos) (string c)))
((none) #`(list (1+ pos) '()))
(else (error "bad accum" accum))))))))))
;; Generate code to match a pattern and do nothing with the result
(define (cg-ignore pat accum)
(syntax-case pat ()
((inner)
(compile-peg-pattern #'inner 'none))))
(define (cg-capture pat accum)
(syntax-case pat ()
((inner)
(compile-peg-pattern #'inner 'body))))
;; Filters the accum argument to compile-peg-pattern for buildings like string
;; literals (since we don't want to tag them with their name if we're doing an
;; "all" accum).
(define (builtin-accum-filter accum)
(cond
((eq? accum 'all) 'body)
((eq? accum 'name) 'name)
((eq? accum 'body) 'body)
((eq? accum 'none) 'none)))
(define baf builtin-accum-filter)
;; Top-level function builder for AND. Reduces to a call to CG-AND-INT.
(define (cg-and clauses accum)
#`(lambda (str len pos)
(let ((body '()))
#,(cg-and-int clauses (baf accum) #'str #'len #'pos #'body))))
;; Internal function builder for AND (calls itself).
(define (cg-and-int clauses accum str strlen at body)
(syntax-case clauses ()
(()
(cggr accum 'cg-and #`(reverse #,body) at))
((first rest ...)
#`(let ((res (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at)))
(and res
;; update AT and BODY then recurse
(let ((newat (car res))
(newbody (cadr res)))
(set! #,at newat)
(push-not-null! #,body (single-filter newbody))
#,(cg-and-int #'(rest ...) accum str strlen at body)))))))
;; Top-level function builder for OR. Reduces to a call to CG-OR-INT.
(define (cg-or clauses accum)
#`(lambda (str len pos)
#,(cg-or-int clauses (baf accum) #'str #'len #'pos)))
;; Internal function builder for OR (calls itself).
(define (cg-or-int clauses accum str strlen at)
(syntax-case clauses ()
(()
#f)
((first rest ...)
#`(or (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at)
#,(cg-or-int #'(rest ...) accum str strlen at)))))
(define (cg-* args accum)
(syntax-case args ()
((pat)
#`(lambda (str strlen at)
(let ((body '()))
(let lp ((end at) (count 0))
(let* ((match (#,(compile-peg-pattern #'pat (baf accum))
str strlen end))
(new-end (if match (car match) end))
(count (if (> new-end end) (1+ count) count)))
(if (> new-end end)
(push-not-null! body (single-filter (cadr match))))
(if (and (> new-end end)
#,#t)
(lp new-end count)
(let ((success #,#t))
#,#`(and success
#,(cggr (baf accum) 'cg-body
#'(reverse body) #'new-end)))))))))))
(define (cg-+ args accum)
(syntax-case args ()
((pat)
#`(lambda (str strlen at)
(let ((body '()))
(let lp ((end at) (count 0))
(let* ((match (#,(compile-peg-pattern #'pat (baf accum))
str strlen end))
(new-end (if match (car match) end))
(count (if (> new-end end) (1+ count) count)))
(if (> new-end end)
(push-not-null! body (single-filter (cadr match))))
(if (and (> new-end end)
#,#t)
(lp new-end count)
(let ((success #,#'(>= count 1)))
#,#`(and success
#,(cggr (baf accum) 'cg-body
#'(reverse body) #'new-end)))))))))))
(define (cg-? args accum)
(syntax-case args ()
((pat)
#`(lambda (str strlen at)
(let ((body '()))
(let lp ((end at) (count 0))
(let* ((match (#,(compile-peg-pattern #'pat (baf accum))
str strlen end))
(new-end (if match (car match) end))
(count (if (> new-end end) (1+ count) count)))
(if (> new-end end)
(push-not-null! body (single-filter (cadr match))))
(if (and (> new-end end)
#,#'(< count 1))
(lp new-end count)
(let ((success #,#t))
#,#`(and success
#,(cggr (baf accum) 'cg-body
#'(reverse body) #'new-end)))))))))))
(define (cg-followed-by args accum)
(syntax-case args ()
((pat)
#`(lambda (str strlen at)
(let ((body '()))
(let lp ((end at) (count 0))
(let* ((match (#,(compile-peg-pattern #'pat (baf accum))
str strlen end))
(new-end (if match (car match) end))
(count (if (> new-end end) (1+ count) count)))
(if (> new-end end)
(push-not-null! body (single-filter (cadr match))))
(if (and (> new-end end)
#,#'(< count 1))
(lp new-end count)
(let ((success #,#'(= count 1)))
#,#`(and success
#,(cggr (baf accum) 'cg-body #''() #'at)))))))))))
(define (cg-not-followed-by args accum)
(syntax-case args ()
((pat)
#`(lambda (str strlen at)
(let ((body '()))
(let lp ((end at) (count 0))
(let* ((match (#,(compile-peg-pattern #'pat (baf accum))
str strlen end))
(new-end (if match (car match) end))
(count (if (> new-end end) (1+ count) count)))
(if (> new-end end)
(push-not-null! body (single-filter (cadr match))))
(if (and (> new-end end)
#,#'(< count 1))
(lp new-end count)
(let ((success #,#'(= count 1)))
#,#`(if success
#f
#,(cggr (baf accum) 'cg-body #''() #'at)))))))))))
;; Association list of functions to handle different expressions as PEGs
(define peg-compiler-alist '())
(define (add-peg-compiler! symbol function)
(set! peg-compiler-alist
(assq-set! peg-compiler-alist symbol function)))
(add-peg-compiler! 'range cg-range)
(add-peg-compiler! 'ignore cg-ignore)
(add-peg-compiler! 'capture cg-capture)
(add-peg-compiler! 'and cg-and)
(add-peg-compiler! 'or cg-or)
(add-peg-compiler! '* cg-*)
(add-peg-compiler! '+ cg-+)
(add-peg-compiler! '? cg-?)
(add-peg-compiler! 'followed-by cg-followed-by)
(add-peg-compiler! 'not-followed-by cg-not-followed-by)
;; Takes an arbitrary expressions and accumulation variable, then parses it.
;; E.g.: (compile-peg-pattern syntax '(and "abc" (or "-" (range #\a #\z))) 'all)
(define (compile-peg-pattern pat accum)
(syntax-case pat (peg-any)
(peg-any
(cg-peg-any (baf accum)))
(sym (identifier? #'sym) ;; nonterminal
#'sym)
(str (string? (syntax->datum #'str)) ;; literal string
(cg-string (syntax->datum #'str) (baf accum)))
((name . args) (let* ((nm (syntax->datum #'name))
(entry (assq-ref peg-compiler-alist nm)))
(if entry
(entry #'args accum)
(error "Bad peg form" nm #'args
"Not one of" (map car peg-compiler-alist)))))))
;; Packages the results of a parser
(define (wrap-parser-for-users for-syntax parser accumsym s-syn)
#`(lambda (str strlen at)
(let ((res (#,parser str strlen at)))
;; Try to match the nonterminal.
(if res
;; If we matched, do some post-processing to figure out
;; what data to propagate upward.
(let ((at (car res))
(body (cadr res)))
#,(cond
((eq? accumsym 'name)
#`(list at '#,s-syn))
((eq? accumsym 'all)
#`(list (car res)
(cond
((not (list? body))
(list '#,s-syn body))
((null? body) '#,s-syn)
((symbol? (car body))
(list '#,s-syn body))
(else (cons '#,s-syn body)))))
((eq? accumsym 'none) #`(list (car res) '()))
(else #`(begin res))))
;; If we didn't match, just return false.
#f))))

100
sysa/mes-0.22/mes/module/mes/peg/simplify-tree.scm Normal file
View file

@ -0,0 +1,100 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2010, 2011 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/>.
;;; Taken from GNU Guile
;;; simplify-tree.scm --- utility functions for the PEG parser
(define-module (ice-9 peg simplify-tree)
#:export (keyword-flatten context-flatten string-collapse)
#:use-module (system base pmatch))
(define-syntax single?
(syntax-rules ()
;;"Return #t if X is a list of one element."
((_ x)
(pmatch x
((_) #t)
(else #f)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Is everything in LST true?
(define (andlst lst)
(or (null? lst)
(and (car lst) (andlst (cdr lst)))))
;; Is LST a list of strings?
(define (string-list? lst)
(and (list? lst) (not (null? lst))
(andlst (map string? lst))))
;; Groups all strings that are next to each other in LST. Used in
;; STRING-COLLAPSE.
(define (string-group lst)
(if (not (list? lst))
lst
(if (null? lst)
'()
(let ((next (string-group (cdr lst))))
(if (not (string? (car lst)))
(cons (car lst) next)
(if (and (not (null? next))
(list? (car next))
(string? (caar next)))
(cons (cons (car lst) (car next)) (cdr next))
(cons (list (car lst)) next)))))))
;; Collapses all the string in LST.
;; ("a" "b" (c d) "e" "f") -> ("ab" (c d) "ef")
(define (string-collapse lst)
(if (list? lst)
(let ((res (map (lambda (x) (if (string-list? x)
(apply string-append x)
x))
(string-group (map string-collapse lst)))))
(if (single? res) (car res) res))
lst))
;; If LST is an atom, return (list LST), else return LST.
(define (mklst lst)
(if (not (list? lst)) (list lst) lst))
;; Takes a list and "flattens" it, using the predicate TST to know when to stop
;; instead of terminating on atoms (see tutorial).
(define (context-flatten tst lst)
(if (or (not (list? lst)) (null? lst))
lst
(if (tst lst)
(list lst)
(apply append
(map (lambda (x) (mklst (context-flatten tst x)))
lst)))))
;; Takes a list and "flattens" it, using the list of keywords KEYWORD-LST to
;; know when to stop at (see tutorial).
(define (keyword-flatten keyword-lst lst)
(context-flatten
(lambda (x)
(if (or (not (list? x)) (null? x))
#t
(member (car x) keyword-lst)))
lst))

275
sysa/mes-0.22/mes/module/mes/peg/string-peg.scm Normal file
View file

@ -0,0 +1,275 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2010, 2011 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/>.
;;; Taken from GNU Guile
;;; string-peg.scm --- representing PEG grammars as strings
(define-module (ice-9 peg string-peg)
#:export (peg-as-peg
define-peg-string-patterns
peg-grammar)
#:use-module (ice-9 peg using-parsers)
#:use-module (ice-9 peg codegen)
#:use-module (ice-9 peg simplify-tree))
;; Gets the left-hand depth of a list.
(define (depth lst)
(if (or (not (list? lst)) (null? lst))
0
(+ 1 (depth (car lst)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; Parse string PEGs using sexp PEGs.
;; See the variable PEG-AS-PEG for an easier-to-read syntax.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Grammar for PEGs in PEG grammar.
(define peg-as-peg
"grammar <-- (nonterminal ('<--' / '<-' / '<') sp pattern)+
pattern <-- alternative (SLASH sp alternative)*
alternative <-- ([!&]? sp suffix)+
suffix <-- primary ([*+?] sp)*
primary <-- '(' sp pattern ')' sp / '.' sp / literal / charclass / nonterminal !'<'
literal <-- ['] (!['] .)* ['] sp
charclass <-- LB (!']' (CCrange / CCsingle))* RB sp
CCrange <-- . '-' .
CCsingle <-- .
nonterminal <-- [a-zA-Z0-9-]+ sp
sp < [ \t\n]*
SLASH < '/'
LB < '['
RB < ']'
")
(define-syntax define-sexp-parser
(lambda (x)
(syntax-case x ()
((_ sym accum pat)
(let* ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum)))
(accumsym (syntax->datum #'accum))
(syn (wrap-parser-for-users x matchf accumsym #'sym)))
#`(define sym #,syn))))))
(define-sexp-parser peg-grammar all
(+ (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern)))
(define-sexp-parser peg-pattern all
(and peg-alternative
(* (and (ignore "/") peg-sp peg-alternative))))
(define-sexp-parser peg-alternative all
(+ (and (? (or "!" "&")) peg-sp peg-suffix)))
(define-sexp-parser peg-suffix all
(and peg-primary (* (and (or "*" "+" "?") peg-sp))))
(define-sexp-parser peg-primary all
(or (and "(" peg-sp peg-pattern ")" peg-sp)
(and "." peg-sp)
peg-literal
peg-charclass
(and peg-nonterminal (not-followed-by "<"))))
(define-sexp-parser peg-literal all
(and "'" (* (and (not-followed-by "'") peg-any)) "'" peg-sp))
(define-sexp-parser peg-charclass all
(and (ignore "[")
(* (and (not-followed-by "]")
(or charclass-range charclass-single)))
(ignore "]")
peg-sp))
(define-sexp-parser charclass-range all (and peg-any "-" peg-any))
(define-sexp-parser charclass-single all peg-any)
(define-sexp-parser peg-nonterminal all
(and (+ (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-")) peg-sp))
(define-sexp-parser peg-sp none
(* (or " " "\t" "\n")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; PARSE STRING PEGS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Takes a string representing a PEG grammar and returns syntax that
;; will define all of the nonterminals in the grammar with equivalent
;; PEG s-expressions.
(define (peg-parser str for-syntax)
(let ((parsed (match-pattern peg-grammar str)))
(if (not parsed)
(begin
;; (display "Invalid PEG grammar!\n")
#f)
(let ((lst (peg:tree parsed)))
(cond
((or (not (list? lst)) (null? lst))
lst)
((eq? (car lst) 'peg-grammar)
#`(begin
#,@(map (lambda (x) (peg-nonterm->defn x for-syntax))
(context-flatten (lambda (lst) (<= (depth lst) 2))
(cdr lst))))))))))
;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and
;; defines all the appropriate nonterminals.
(define-syntax define-peg-string-patterns
(lambda (x)
(syntax-case x ()
((_ str)
(peg-parser (syntax->datum #'str) x)))))
;; lst has format (nonterm grabber pattern), where
;; nonterm is a symbol (the name of the nonterminal),
;; grabber is a string (either "<", "<-" or "<--"), and
;; pattern is the parse of a PEG pattern expressed as as string.
(define (peg-nonterm->defn lst for-syntax)
(let* ((nonterm (car lst))
(grabber (cadr lst))
(pattern (caddr lst))
(nonterm-name (datum->syntax for-syntax
(string->symbol (cadr nonterm)))))
#`(define-peg-pattern #,nonterm-name
#,(cond
((string=? grabber "<--") (datum->syntax for-syntax 'all))
((string=? grabber "<-") (datum->syntax for-syntax 'body))
(else (datum->syntax for-syntax 'none)))
#,(compressor (peg-pattern->defn pattern for-syntax) for-syntax))))
;; lst has format ('peg-pattern ...).
;; After the context-flatten, (cdr lst) has format
;; (('peg-alternative ...) ...), where the outer list is a collection
;; of elements from a '/' alternative.
(define (peg-pattern->defn lst for-syntax)
#`(or #,@(map (lambda (x) (peg-alternative->defn x for-syntax))
(context-flatten (lambda (x) (eq? (car x) 'peg-alternative))
(cdr lst)))))
;; lst has format ('peg-alternative ...).
;; After the context-flatten, (cdr lst) has the format
;; (item ...), where each item has format either ("!" ...), ("&" ...),
;; or ('peg-suffix ...).
(define (peg-alternative->defn lst for-syntax)
#`(and #,@(map (lambda (x) (peg-body->defn x for-syntax))
(context-flatten (lambda (x) (or (string? (car x))
(eq? (car x) 'peg-suffix)))
(cdr lst)))))
;; lst has the format either
;; ("!" ('peg-suffix ...)), ("&" ('peg-suffix ...)), or
;; ('peg-suffix ...).
(define (peg-body->defn lst for-syntax)
(cond
((equal? (car lst) "&")
#`(followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
((equal? (car lst) "!")
#`(not-followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
((eq? (car lst) 'peg-suffix)
(peg-suffix->defn lst for-syntax))
(else `(peg-parse-body-fail ,lst))))
;; lst has format ('peg-suffix <peg-primary> (? (/ "*" "?" "+")))
(define (peg-suffix->defn lst for-syntax)
(let ((inner-defn (peg-primary->defn (cadr lst) for-syntax)))
(cond
((null? (cddr lst))
inner-defn)
((equal? (caddr lst) "*")
#`(* #,inner-defn))
((equal? (caddr lst) "?")
#`(? #,inner-defn))
((equal? (caddr lst) "+")
#`(+ #,inner-defn)))))
;; Parse a primary.
(define (peg-primary->defn lst for-syntax)
(let ((el (cadr lst)))
(cond
((list? el)
(cond
((eq? (car el) 'peg-literal)
(peg-literal->defn el for-syntax))
((eq? (car el) 'peg-charclass)
(peg-charclass->defn el for-syntax))
((eq? (car el) 'peg-nonterminal)
(datum->syntax for-syntax (string->symbol (cadr el))))))
((string? el)
(cond
((equal? el "(")
(peg-pattern->defn (caddr lst) for-syntax))
((equal? el ".")
(datum->syntax for-syntax 'peg-any))
(else (datum->syntax for-syntax
`(peg-parse-any unknown-string ,lst)))))
(else (datum->syntax for-syntax
`(peg-parse-any unknown-el ,lst))))))
;; Trims characters off the front and end of STR.
;; (trim-1chars "'ab'") -> "ab"
(define (trim-1chars str) (substring str 1 (- (string-length str) 1)))
;; Parses a literal.
(define (peg-literal->defn lst for-syntax)
(datum->syntax for-syntax (trim-1chars (cadr lst))))
;; Parses a charclass.
(define (peg-charclass->defn lst for-syntax)
#`(or
#,@(map
(lambda (cc)
(cond
((eq? (car cc) 'charclass-range)
#`(range #,(datum->syntax
for-syntax
(string-ref (cadr cc) 0))
#,(datum->syntax
for-syntax
(string-ref (cadr cc) 2))))
((eq? (car cc) 'charclass-single)
(datum->syntax for-syntax (cadr cc)))))
(context-flatten
(lambda (x) (or (eq? (car x) 'charclass-range)
(eq? (car x) 'charclass-single)))
(cdr lst)))))
;; Compresses a list to save the optimizer work.
;; e.g. (or (and a)) -> a
(define (compressor-core lst)
(if (or (not (list? lst)) (null? lst))
lst
(cond
((and (or (eq? (car lst) 'or) (eq? (car lst) 'and))
(null? (cddr lst)))
(compressor-core (cadr lst)))
((and (eq? (car lst) 'body)
(eq? (cadr lst) 'lit)
(eq? (cadddr lst) 1))
(compressor-core (caddr lst)))
(else (map compressor-core lst)))))
(define (compressor syn for-syntax)
(datum->syntax for-syntax
(compressor-core (syntax->datum syn))))
;; Builds a lambda-expressions for the pattern STR using accum.
(define (peg-string-compile args accum)
(syntax-case args ()
((str-stx) (string? (syntax->datum #'str-stx))
(let ((string (syntax->datum #'str-stx)))
(compile-peg-pattern
(compressor
(peg-pattern->defn
(peg:tree (match-pattern peg-pattern string)) #'str-stx)
#'str-stx)
(if (eq? accum 'all) 'body accum))))
(else (error "Bad embedded PEG string" args))))
(add-peg-compiler! 'peg peg-string-compile)

118
sysa/mes-0.22/mes/module/mes/peg/using-parsers.scm Normal file
View file

@ -0,0 +1,118 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2010, 2011 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/>.
;;; Taken from GNU Guile
;;; using-parsers.scm --- utilities to make using parsers easier
(define-module (ice-9 peg using-parsers)
#:use-module (ice-9 peg simplify-tree)
#:use-module (ice-9 peg codegen)
#:use-module (ice-9 peg cache)
#:export (match-pattern define-peg-pattern search-for-pattern
prec make-prec peg:start peg:end peg:string
peg:tree peg:substring peg-record?))
;;;
;;; Helper Macros
;;;
(define-syntax until
(syntax-rules ()
;;"Evaluate TEST. If it is true, return its value. Otherwise,execute the STMTs and try again."
((_ test stmt stmt* ...)
(let lp ()
(or test
(begin stmt stmt* ... (lp)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; FOR DEFINING AND USING NONTERMINALS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parses STRING using NONTERM
(define (match-pattern nonterm string)
;; We copy the string before using it because it might have been modified
;; in-place since the last time it was parsed, which would invalidate the
;; cache. Guile uses copy-on-write for strings, so this is fast.
(let ((res (nonterm (string-copy string) (string-length string) 0)))
(if (not res)
#f
(make-prec 0 (car res) string (string-collapse (cadr res))))))
;; Defines a new nonterminal symbol accumulating with ACCUM.
(define-syntax define-peg-pattern
(lambda (x)
(syntax-case x ()
((_ sym accum pat)
(let ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum)))
(accumsym (syntax->datum #'accum)))
;; CODE is the code to parse the string if the result isn't cached.
(let ((syn (wrap-parser-for-users x matchf accumsym #'sym)))
#`(define sym #,(cg-cached-parser syn))))))))
(define (peg-like->peg pat)
(syntax-case pat ()
(str (string? (syntax->datum #'str)) #'(peg str))
(else pat)))
;; Searches through STRING for something that parses to PEG-MATCHER. Think
;; regexp search.
(define-syntax search-for-pattern
(lambda (x)
(syntax-case x ()
((_ pattern string-uncopied)
(let ((pmsym (syntax->datum #'pattern)))
(let ((matcher (compile-peg-pattern (peg-like->peg #'pattern) 'body)))
;; We copy the string before using it because it might have been
;; modified in-place since the last time it was parsed, which would
;; invalidate the cache. Guile uses copy-on-write for strings, so
;; this is fast.
#`(let ((string (string-copy string-uncopied))
(strlen (string-length string-uncopied))
(at 0))
(let ((ret (until (or (>= at strlen)
(#,matcher string strlen at))
(set! at (+ at 1)))))
(if (eq? ret #t) ;; (>= at strlen) succeeded
#f
(let ((end (car ret))
(match (cadr ret)))
(make-prec
at end string
(string-collapse match))))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; PMATCH STRUCTURE MUNGING
;; Pretty self-explanatory.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define prec
(make-record-type "peg" '(start end string tree)))
(define make-prec
(record-constructor prec '(start end string tree)))
(define (peg:start pm)
(if pm ((record-accessor prec 'start) pm) #f))
(define (peg:end pm)
(if pm ((record-accessor prec 'end) pm) #f))
(define (peg:string pm)
(if pm ((record-accessor prec 'string) pm) #f))
(define (peg:tree pm)
(if pm ((record-accessor prec 'tree) pm) #f))
(define (peg:substring pm)
(if pm (substring (peg:string pm) (peg:start pm) (peg:end pm)) #f))
(define peg-record? (record-predicate prec))

28
sysa/mes-0.22/mes/module/mes/pmatch.mes Normal file
View file

@ -0,0 +1,28 @@
;;; -*-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:
;;; Code:
;;(mes-use-module (mes guile))
(mes-use-module (mes quasiquote))
(mes-use-module (mes syntax))
(include-from-path "mes/pmatch.scm")

84
sysa/mes-0.22/mes/module/mes/pmatch.scm Normal file
View file

@ -0,0 +1,84 @@
;;; pmatch, a simple matcher
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc
;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov
;;; Copyright (C) 2007 Daniel P. Friedman
;;; Copyright (C) 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; 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/>.
;;; Taken from GNU Guile
;;; Originally written by Oleg Kiselyov for LeanTAP in Kanren, which is
;;; available under the MIT license.
;;;
;;; http://kanren.cvs.sourceforge.net/viewvc/kanren/kanren/mini/leanTAP.scm?view=log
;;;
;;; This version taken from:
;;; αKanren: A Fresh Name in Nominal Logic Programming
;;; by William E. Byrd and Daniel P. Friedman
;;; Proceedings of the 2007 Workshop on Scheme and Functional Programming
;;; Université Laval Technical Report DIUL-RT-0701
;;; To be clear: the original code is MIT-licensed, and the modifications
;;; made to it by Guile are under Guile's license (currently LGPL v3+).
;;; Code:
;; (pmatch exp <clause> ...[<else-clause>])
;; <clause> ::= (<pattern> <guard> exp ...)
;; <else-clause> ::= (else exp ...)
;; <guard> ::= boolean exp | ()
;; <pattern> :: =
;; ,var -- matches always and binds the var
;; pattern must be linear! No check is done
;; _ -- matches always
;; 'exp -- comparison with exp (using equal?) REMOVED (August 8, 2012)
;; exp -- comparison with exp (using equal?)
;; (<pattern1> <pattern2> ...) -- matches the list of patterns
;; (<pattern1> . <pattern2>) -- ditto
;; () -- matches the empty list
(define-module (system base pmatch)
#:export-syntax (pmatch))
(define-syntax pmatch
(syntax-rules (else guard)
((_ v) (if #f #f))
((_ v (else e0 e ...)) (let () e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat
(if (and g ...) (let () e0 e ...) (fk))
(fk))))
((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat (let () e0 e ...) (fk))))))
(define-syntax ppat
(syntax-rules (_ quote unquote)
((_ v _ kt kf) kt)
((_ v () kt kf) (if (null? v) kt kf))
((_ v (quote lit) kt kf)
(if (equal? v (quote lit)) kt kf))
((_ v (unquote var) kt kf) (let ((var v)) kt))
((_ v (x . y) kt kf)
(if (pair? v)
(ppat (pmatch-car v) x (ppat (pmatch-cdr v) y kt kf) kf)
kf))
((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))

73
sysa/mes-0.22/mes/module/mes/posix.mes Normal file
View file

@ -0,0 +1,73 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2017 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:
(mes-use-module (srfi srfi-13))
(define R_OK 0)
(define S_IRWXU #o700)
(define (basename file-name . ext)
(let ((base (last (string-split file-name #\/)))
(ext (and (pair? ext) (car ext))))
(if (and ext
(string-suffix? ext base)) (string-drop-right base (string-length ext))
base)))
(define (force-output . port)
*unspecified*)
(define (search-path path file-name)
(let loop ((path path))
(and (pair? path)
(let ((f (string-append (car path) "/" file-name)))
(if (access? f R_OK) f
(loop (cdr path)))))))
(define (execlp file-name args)
(let ((executable (if (string-index file-name #\/) file-name
(search-path (string-split (getenv "PATH") #\:) file-name))))
(execl executable args)))
(define (system* file-name . args)
(let ((pid (primitive-fork)))
(cond ((zero? pid)
(let ((out (current-output-port))
(err (current-error-port)))
(when (and (> out 0)
(not (= out 1)))
(dup2 out 1))
(when (and (> err 0)
(not (= err 2)))
(dup2 err 2))
(exit (apply execlp file-name (list args)))))
((= -1 pid) (error "fork failed:" file-name))
(else (let ((pid+status (waitpid 0)))
(cdr pid+status))))))
(define (waitpid pid . options)
(let ((options (if (null? options) 0 (car options))))
(core:waitpid pid options)))
(define (status:exit-val status)
(ash status -8))

27
sysa/mes-0.22/mes/module/mes/pretty-print.mes Normal file
View file

@ -0,0 +1,27 @@
;;; -*-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:
;;; Code:
(mes-use-module (mes guile))
(mes-use-module (mes optargs))
(include-from-path "mes/pretty-print.scm")

282
sysa/mes-0.22/mes/module/mes/pretty-print.scm Normal file
View file

@ -0,0 +1,282 @@
;;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2001, 2004, 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/>.
;;; Taken from GNU Guile
(define-module (ice-9 pretty-print)
:use-module (ice-9 optargs)
:export (pretty-print))
;; From SLIB.
;;"genwrite.scm" generic write used by pretty-print and truncated-print.
;; Copyright (c) 1991, Marc Feeley
;; Author: Marc Feeley (feeley@iro.umontreal.ca)
;; Distribution restrictions: none
(define genwrite:newline-str (make-string 1 #\newline))
(define (generic-write obj display? width per-line-prefix output)
(define (read-macro? l)
(define (length1? l) (and (pair? l) (null? (cdr l))))
(let ((head (car l)) (tail (cdr l)))
(case head
((quote quasiquote unquote unquote-splicing) (length1? tail))
(else #f))))
(define (read-macro-body l)
(cadr l))
(define (read-macro-prefix l)
(let ((head (car l)))
(case head
((quote) "'")
((quasiquote) "`")
((unquote) ",")
((unquote-splicing) ",@"))))
(define (out str col)
(and col (output str) (+ col (string-length str))))
(define (wr obj col)
(cond ((and (pair? obj)
(read-macro? obj))
(wr (read-macro-body obj)
(out (read-macro-prefix obj) col)))
(else
(out (object->string obj (if display? display write)) col))))
(define (pp obj col)
(define (spaces n col)
(if (> n 0)
(if (> n 7)
(spaces (- n 8) (out " " col))
(out (substring " " 0 n) col))
col))
(define (indent to col)
(and col
(if (< to col)
(and (out genwrite:newline-str col)
(out per-line-prefix 0)
(spaces to 0))
(spaces (- to col) col))))
(define (pr obj col extra pp-pair)
(if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
(let ((result '())
(left (min (+ (- (- width col) extra) 1) max-expr-width)))
(generic-write obj display? #f ""
(lambda (str)
(set! result (cons str result))
(set! left (- left (string-length str)))
(> left 0)))
(if (> left 0) ; all can be printed on one line
(out (reverse-string-append result) col)
(if (pair? obj)
(pp-pair obj col extra)
(pp-list (vector->list obj) (out "#" col) extra pp-expr))))
(wr obj col)))
(define (pp-expr expr col extra)
(if (read-macro? expr)
(pr (read-macro-body expr)
(out (read-macro-prefix expr) col)
extra
pp-expr)
(let ((head (car expr)))
(if (symbol? head)
(let ((proc (style head)))
(if proc
(proc expr col extra)
(if (> (string-length (symbol->string head))
max-call-head-width)
(pp-general expr col extra #f #f #f pp-expr)
(pp-call expr col extra pp-expr))))
(pp-list expr col extra pp-expr)))))
; (head item1
; item2
; item3)
(define (pp-call expr col extra pp-item)
(let ((col* (wr (car expr) (out "(" col))))
(and col
(pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
; (item1
; item2
; item3)
(define (pp-list l col extra pp-item)
(let ((col (out "(" col)))
(pp-down l col col extra pp-item)))
(define (pp-down l col1 col2 extra pp-item)
(let loop ((l l) (col col1))
(and col
(cond ((pair? l)
(let ((rest (cdr l)))
(let ((extra (if (null? rest) (+ extra 1) 0)))
(loop rest
(pr (car l) (indent col2 col) extra pp-item)))))
((null? l)
(out ")" col))
(else
(out ")"
(pr l
(indent col2 (out "." (indent col2 col)))
(+ extra 1)
pp-item)))))))
(define (pp-general expr col extra named? pp-1 pp-2 pp-3)
(define (tail1 rest col1 col2 col3)
(if (and pp-1 (pair? rest))
(let* ((val1 (car rest))
(rest (cdr rest))
(extra (if (null? rest) (+ extra 1) 0)))
(tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
(tail2 rest col1 col2 col3)))
(define (tail2 rest col1 col2 col3)
(if (and pp-2 (pair? rest))
(let* ((val1 (car rest))
(rest (cdr rest))
(extra (if (null? rest) (+ extra 1) 0)))
(tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
(tail3 rest col1 col2)))
(define (tail3 rest col1 col2)
(pp-down rest col2 col1 extra pp-3))
(let* ((head (car expr))
(rest (cdr expr))
(col* (wr head (out "(" col))))
(if (and named? (pair? rest))
(let* ((name (car rest))
(rest (cdr rest))
(col** (wr name (out " " col*))))
(tail1 rest (+ col indent-general) col** (+ col** 1)))
(tail1 rest (+ col indent-general) col* (+ col* 1)))))
(define (pp-expr-list l col extra)
(pp-list l col extra pp-expr))
(define (pp-LAMBDA expr col extra)
(pp-general expr col extra #f pp-expr-list #f pp-expr))
(define (pp-IF expr col extra)
(pp-general expr col extra #f pp-expr #f pp-expr))
(define (pp-COND expr col extra)
(pp-call expr col extra pp-expr-list))
(define (pp-CASE expr col extra)
(pp-general expr col extra #f pp-expr #f pp-expr-list))
(define (pp-AND expr col extra)
(pp-call expr col extra pp-expr))
(define (pp-LET expr col extra)
(let* ((rest (cdr expr))
(named? (and (pair? rest) (symbol? (car rest)))))
(pp-general expr col extra named? pp-expr-list #f pp-expr)))
(define (pp-BEGIN expr col extra)
(pp-general expr col extra #f #f #f pp-expr))
(define (pp-DO expr col extra)
(pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
; define formatting style (change these to suit your style)
(define indent-general 2)
(define max-call-head-width 5)
(define max-expr-width 50)
(define (style head)
(case head
((lambda let* letrec define) pp-LAMBDA)
((if set!) pp-IF)
((cond) pp-COND)
((case) pp-CASE)
((and or) pp-AND)
((let) pp-LET)
((begin) pp-BEGIN)
((do) pp-DO)
(else #f)))
(pr obj col 0 pp-expr))
(out per-line-prefix 0)
(if width
(out genwrite:newline-str (pp obj 0))
(wr obj 0))
;; Return `unspecified'
(if #f #f))
; (reverse-string-append l) = (apply string-append (reverse l))
(define (reverse-string-append l)
(define (rev-string-append l i)
(if (pair? l)
(let* ((str (car l))
(len (string-length str))
(result (rev-string-append (cdr l) (+ i len))))
(let loop ((j 0) (k (- (- (string-length result) i) len)))
(if (< j len)
(begin
(string-set! result k (string-ref str j))
(loop (+ j 1) (+ k 1)))
result)))
(make-string i)))
(rev-string-append l 0))
(define (pretty-print obj . opts)
"Pretty-print OBJ on PORT, which is a keyword argument defaulting to
the current output port. Formatting can be controlled by a number of
keyword arguments: Each line in the output is preceded by the string
PER-LINE-PREFIX, which is empty by default. The output lines will be
at most WIDTH characters wide; the default is 79. If DISPLAY? is
true, display rather than write representation will be used.
Instead of with a keyword argument, you can also specify the output
port directly after OBJ, like (pretty-print OBJ PORT)."
(if (pair? opts)
(if (keyword? (car opts))
(apply pretty-print-with-keys obj opts)
(apply pretty-print-with-keys obj #:port (car opts) (cdr opts)))
(pretty-print-with-keys obj)))
(define* (pretty-print-with-keys obj
#:key
(port (current-output-port))
(width 79)
(display? #f)
(per-line-prefix ""))
(generic-write obj display?
(- width (string-length per-line-prefix))
per-line-prefix
(lambda (s) (display s port) #t)))

114
sysa/mes-0.22/mes/module/mes/psyntax-0.mes Normal file
View file

@ -0,0 +1,114 @@
;;; -*-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/>.
(define (interaction-environment) (current-module))
(define (eval x . environment)
(core:eval (if (and (pair? x) (equal? (car x) "noexpand")) (cadr x) x)
(if (null? environment) (current-module) (car environment))))
(define annotation? (lambda (x) #f))
(define (self-evaluating? x)
(or (null? x) (boolean? x) (char? x) (closure? x) (keyword? x) (number? x) (string? x)))
(define (void) (if #f #f))
(define macro-expand #f)
(define sc-expand #f)
(define sc-chi #f)
(define sc-expand3 #f)
(define $sc-put-cte #f)
(define $make-environment #f)
(define environment? #f)
(define syntax->list #f)
(define syntax->vector #f)
(define literal-identifier=? #f)
(define $syntax-dispatch #f)
(define eval-when #f)
(define install-global-transformer #f)
(define syntax-dispatch #f)
(define syntax-error #f)
(define bound-identifier=? #f)
(define datum->syntax-object #f)
(define define-syntax (void))
(define fluid-let-syntax #f)
(define free-identifier=? #f)
(define generate-temporaries #f)
(define identifier? #f)
(define identifier-syntax #f)
(define let-syntax #f)
(define letrec-syntax #f)
(define syntax #f)
(define syntax-case #f)
(define syntax-object->datum #f)
(define syntax-rules #f)
(define with-syntax #f)
(define andmap
(lambda (f . lists)
(if (null? (car lists)) (and)
(if (null? (cdr (car lists))) (apply f (map car lists))
(and (apply f (map car lists))
(apply andmap f (map cdr lists)))))))
(define ormap
(lambda (proc list1)
(and (not (null? list1))
(or (proc (car list1)) (ormap proc (cdr list1))))))
(define *sc-expander-alist* '())
(define putprop #f)
(define getprop #f)
(define remprop #f)
(define properties-alist #f)
(let ((properties '()))
(set! putprop
(lambda (symbol key value)
(let ((plist (assq symbol *sc-expander-alist*)))
(if (pair? plist)
(let ((couple (assq key (cdr plist))))
(if (pair? couple)
(set-cdr! couple value)
(set-cdr! plist (cons (cons key value)
(cdr plist)))))
(let ((plist (list symbol (cons key value))))
(set! *sc-expander-alist* (cons plist *sc-expander-alist*)))))
value))
(set! getprop
(lambda (symbol key)
(let ((plist (assq symbol *sc-expander-alist*)))
(if (pair? plist)
(let ((couple (assq key (cdr plist))))
(if (pair? couple)
(cdr couple)
#f))
#f))))
(set! remprop
(lambda (symbol key)
(putprop symbol key #f)))
(set! properties-alist (lambda () *sc-expander-alist*)))
;; (define fx+ +)
;; (define fx- -)
;; (define fx= =)
;; (define fx< <)

32
sysa/mes-0.22/mes/module/mes/psyntax-1.mes Normal file
View file

@ -0,0 +1,32 @@
;;; -*-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:
;;; psyntax-1.mes - post psyntax.pp hook. psyntax-1.mes is loaded
;;; after psyntax-pp.mes.
;;; Code:
(define datum->syntax datum->syntax-object)
(define syntax->datum syntax-object->datum)
(define-macro (portable-macro-expand) #t)
(set! macro-expand sc-expand)

29
sysa/mes-0.22/mes/module/mes/psyntax.mes Normal file
View file

@ -0,0 +1,29 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 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:
(mes-use-module (mes scm))
(mes-use-module (mes psyntax-0))
(include-from-path "mes/psyntax.pp")
(mes-use-module (mes psyntax-1))
(mes-use-module (mes quasisyntax))

9652
sysa/mes-0.22/mes/module/mes/psyntax.pp Normal file
View file

File diff suppressed because it is too large Load diff

24
sysa/mes-0.22/mes/module/mes/psyntax.pp.header Normal file
View file

@ -0,0 +1,24 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2016, 2017, 2018 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/>.
;;; Commentary:
;;; This file is generated from psyntax.ss.
;;; Code:

2289
sysa/mes-0.22/mes/module/mes/psyntax.ss Normal file
View file

File diff suppressed because it is too large Load diff

59
sysa/mes-0.22/mes/module/mes/quasiquote.mes Normal file
View file

@ -0,0 +1,59 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 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:
;;; quasiquote.mes is loaded after base. It provides quasiquote
;;; written in Scheme.
;;; Code:
(mes-use-module (mes base))
(define (quasiquote-expand x)
(cond ((vector? x) (list 'list->vector (quasiquote-expand (vector->list x))))
((not (pair? x)) (cons 'quote (cons x '())))
((eq? (car x) 'quasiquote) (quasiquote-expand (quasiquote-expand
(if (null? (cddr x)) (cadr x)
(cons 'list (cdr x))))))
((eq? (car x) 'unquote) (if (null? (cddr x)) (cadr x)
(cons 'list (cdr x))))
((and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
((lambda (d)
(if (null? (cddar x)) (list 'append (cadar x) d)
(list 'quote (append (cdar x) d))))
(quasiquote-expand (cdr x))))
(else ((lambda (a d)
(if (pair? d)
(if (eq? (car d) 'quote)
(if (and (pair? a) (eq? (car a) 'quote))
(list 'quote (cons (cadr a) (cadr d)))
(if (null? (cadr d))
(list 'list a)
(list 'cons* a d)))
(if (memq (car d) '(list cons*))
(cons (car d) (cons a (cdr d)))
(list 'cons* a d)))
(list 'cons* a d)))
(quasiquote-expand (car x))
(quasiquote-expand (cdr x))))))
(define-macro (quasiquote x)
(quasiquote-expand x))

27
sysa/mes-0.22/mes/module/mes/quasisyntax.mes Normal file
View file

@ -0,0 +1,27 @@
;;; -*-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:
;;; Code:
(mes-use-module (mes psyntax))
(define syntax-violation error)
(include-from-path "mes/quasisyntax.scm")

136
sysa/mes-0.22/mes/module/mes/quasisyntax.scm Normal file
View file

@ -0,0 +1,136 @@
;; Quasisyntax in terms of syntax-case.
;;
;; Code taken from
;; <http://www.het.brown.edu/people/andre/macros/index.html>;
;; Copyright (c) 2006 Andre van Tonder. All Rights Reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
;;=========================================================
;;
;; To make nested unquote-splicing behave in a useful way,
;; the R5RS-compatible extension of quasiquote in appendix B
;; of the following paper is here ported to quasisyntax:
;;
;; Alan Bawden - Quasiquotation in Lisp
;; http://citeseer.ist.psu.edu/bawden99quasiquotation.html
;;
;; The algorithm converts a quasisyntax expression to an
;; equivalent with-syntax expression.
;; For example:
;;
;; (quasisyntax (set! #,a #,b))
;; ==> (with-syntax ((t0 a)
;; (t1 b))
;; (syntax (set! t0 t1)))
;;
;; (quasisyntax (list #,@args))
;; ==> (with-syntax (((t ...) args))
;; (syntax (list t ...)))
;;
;; Note that quasisyntax is expanded first, before any
;; ellipses act. For example:
;;
;; (quasisyntax (f ((b #,a) ...))
;; ==> (with-syntax ((t a))
;; (syntax (f ((b t) ...))))
;;
;; so that
;;
;; (let-syntax ((test-ellipses-over-unsyntax
;; (lambda (e)
;; (let ((a (syntax a)))
;; (with-syntax (((b ...) (syntax (1 2 3))))
;; (quasisyntax
;; (quote ((b #,a) ...))))))))
;; (test-ellipses-over-unsyntax))
;;
;; ==> ((1 a) (2 a) (3 a))
(define-syntax quasisyntax
(lambda (e)
;; Expand returns a list of the form
;; [template[t/e, ...] (replacement ...)]
;; Here template[t/e ...] denotes the original template
;; with unquoted expressions e replaced by fresh
;; variables t, followed by the appropriate ellipses
;; if e is also spliced.
;; The second part of the return value is the list of
;; replacements, each of the form (t e) if e is just
;; unquoted, or ((t ...) e) if e is also spliced.
;; This will be the list of bindings of the resulting
;; with-syntax expression.
(define (expand x level)
(syntax-case x (quasisyntax unsyntax unsyntax-splicing)
((quasisyntax e)
(with-syntax (((k _) x) ;; original identifier must be copied
((e* reps) (expand (syntax e) (+ level 1))))
(syntax ((k e*) reps))))
((unsyntax e)
(= level 0)
(with-syntax (((t) (generate-temporaries '(t))))
(syntax (t ((t e))))))
(((unsyntax e ...) . r)
(= level 0)
(with-syntax (((r* (rep ...)) (expand (syntax r) 0))
((t ...) (generate-temporaries (syntax (e ...)))))
(syntax ((t ... . r*)
((t e) ... rep ...)))))
(((unsyntax-splicing e ...) . r)
(= level 0)
(with-syntax (((r* (rep ...)) (expand (syntax r) 0))
((t ...) (generate-temporaries (syntax (e ...)))))
(with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
(syntax ((t ... ... . r*)
(((t ...) e) ... rep ...))))))
((k . r)
(and (> level 0)
(identifier? (syntax k))
(or (free-identifier=? (syntax k) (syntax unsyntax))
(free-identifier=? (syntax k) (syntax unsyntax-splicing))))
(with-syntax (((r* reps) (expand (syntax r) (- level 1))))
(syntax ((k . r*) reps))))
((h . t)
(with-syntax (((h* (rep1 ...)) (expand (syntax h) level))
((t* (rep2 ...)) (expand (syntax t) level)))
(syntax ((h* . t*)
(rep1 ... rep2 ...)))))
(#(e ...)
(with-syntax ((((e* ...) reps)
(expand (vector->list (syntax #(e ...))) level)))
(syntax (#(e* ...) reps))))
(other
(syntax (other ())))))
(syntax-case e ()
((_ template)
(with-syntax (((template* replacements) (expand (syntax template) 0)))
(syntax
(with-syntax replacements (syntax template*))))))))
(define-syntax unsyntax
(lambda (e)
(syntax-violation 'unsyntax "Invalid expression" e)))
(define-syntax unsyntax-splicing
(lambda (e)
(syntax-violation 'unsyntax "Invalid expression" e)))

187
sysa/mes-0.22/mes/module/mes/repl.mes Normal file
View file

@ -0,0 +1,187 @@
;;; -*-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:
;;; repl.mes defines repl, a repl for Mes.
;;; Code:
(mes-use-module (mes scm))
(mes-use-module (srfi srfi-14))
(define welcome
(string-append "GNU Mes " %version "
Copyright (C) 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
Copyright (C) 2019 Danny Milosavljevic <dannym@scratchpost.org>
GNU Mes comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
under certain conditions; type `,show c' for details.
Enter `,help' for help.
"))
(define warranty
"GNU Mes is distributed WITHOUT ANY WARRANTY. The following
sections from the GNU General Public License, version 3, should
make that clear.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
See <http://www.gnu.org/licenses/gpl.html>, for more details.
")
(define copying
"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 help-commands
"Help Commands:
,expand SEXP - Expand SEXP
,help - Show this help
,quit - Quit this session
,show TOPIC - Show info on TOPIC [c, w]
,use MODULE - load MODULE
")
(define show-commands
"Show commands:
,show c - Show details on licensing; GNU GPLv3+
,show w - Show details on the lack of warranty
")
(define (repl)
(let ((count 0)
(print-sexp? #t))
(define (expand a)
(lambda ()
(let ((sexp (read)))
(when #t print-sexp?
(display "[sexp=")
(display sexp)
(display "]")
(newline))
(core:macro-expand sexp))))
(define (help . x) (display help-commands) *unspecified*)
(define (show . x)
(define topic-alist `((#\newline . ,show-commands)
(#\c . ,copying)
(#\w . ,warranty)))
(let* ((word (read-env '()))
(topic (find (negate char-whitespace?) (symbol->list word))))
(display (assoc-ref topic-alist topic))
*unspecified*))
(define (quit . x)
(exit 0))
(define (use a)
(lambda ()
(let ((module (read)))
(mes-load-module-env module a))))
(define (meta command a)
(let ((command-alist `((expand . ,(expand a))
(help . ,help)
(quit . ,quit)
(show . ,show)
(use . ,(use a)))))
((or (assoc-ref command-alist command)
(lambda () #f)))))
(display welcome)
(let loop ((a (current-module)))
(display "mes> ")
(force-output)
(catch #t
(lambda ()
(let ((sexp (read-env a)))
(when (not (eq? sexp '()))
(when print-sexp?
(display "[sexp=")
(display sexp)
(display "]")
(newline))
(if (and (pair? sexp) (eq? (car sexp) 'mes-use-module))
(loop (mes-load-module-env (cadr sexp) a))
(let ((e (if (and (pair? sexp) (eq? (car sexp) (string->symbol "unquote")))
(meta (cadr sexp) a)
(core:eval sexp a))))
(if (eq? e *unspecified*) (loop a)
(let ((id (string->symbol (string-append "$" (number->string count)))))
(set! count (+ count 1))
(display id)
(display " = ")
(write e)
(newline)
(loop (acons id e a)))))))))
(lambda (key . args)
(if (defined? 'with-output-to-string)
(simple-format (current-error-port) "exception:~a:~a\n" key args)
(begin
(display "exception:" (current-error-port))
(display key (current-error-port))
(display ":" (current-error-port))
(display args (current-error-port))
(newline (current-error-port))))
(loop a))))))

385
sysa/mes-0.22/mes/module/mes/scm.mes Normal file
View file

@ -0,0 +1,385 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019 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:
;;; scm.mes is loaded after base, quasiquote and let. It provides
;;; basic Scheme functions bringing Mes close to basic RRS Scheme (no
;;; labels, processes, fluids or throw/catch).
;;; Code:
(mes-use-module (mes let))
(define (cadddr x) (car (cdddr x)))
(define-macro (case val . args)
(if (null? args) #f
(let ((clause (car args)))
(let ((pred (car clause)))
(let ((body (cdr clause)))
(if (pair? pred) `(if ,(if (null? (cdr pred))
`(eq? ,val ',(car pred))
`(member ,val ',pred))
(begin ,@body)
(case ,val ,@(cdr args)))
`(begin ,@body)))))))
(define-macro (when expr . body)
`(if ,expr
((lambda () ,@body))))
(define-macro (unless expr . body)
`(if (not ,expr)
((lambda () ,@body))))
(define-macro (do init test . body)
`(let loop ((,(caar init) ,(cadar init)))
(when (not ,@test)
,@body
(loop ,@(cddar init)))))
(define (for-each f l . xr)
(if (and (pair? l)
(or (null? xr)
(pair? (car xr))))
(if (null? xr) (begin (f (car l)) (for-each f (cdr l)))
(if (null? (cdr xr)) (begin (f (car l) (caar xr)) (for-each f (cdr l) (cdar xr)))))))
(define core:error error)
(define (error who . rest)
(display "error:" (current-error-port))
(display who (current-error-port))
(display ":" (current-error-port))
(display rest (current-error-port))
(newline (current-error-port))
(display "exiting...\n" (current-error-port))
(core:error (if (symbol? who) who 'error) (cons who rest)))
(define (syntax-error message . rest)
(display "syntax-error:" (current-error-port))
(display message (current-error-port))
(display ":" (current-error-port))
(display rest (current-error-port))
(newline (current-error-port))
(core:error 'syntax-error (cons message rest)))
(define integer? number?)
(define (read . port)
(if (null? port) (read-env (current-module))
(let* ((prev (set-current-input-port (car port)))
(result (read-env (current-module))))
result)))
(if (not (defined? 'peek-char))
(define (peek-char)
(integer->char (peek-byte))))
(if (not (defined? 'read-char))
(define (read-char)
(integer->char (read-byte))))
(if (not (defined? 'unread-char))
(define (unread-char c)
(integer->char (unread-byte (char->integer c)))))
(define (assq-set! alist key val)
(let ((entry (assq key alist)))
(if (not entry) (acons key val alist)
(let ((entry (set-cdr! entry val)))
alist))))
(define (assq-ref alist key)
(and alist
(let ((entry (assq key alist)))
(if entry (cdr entry)
#f))))
(define assv assq)
(define assv-ref assq-ref)
(define (assoc-ref alist key)
(and (pair? alist)
(let ((entry (assoc key alist)))
(if entry (cdr entry)
#f))))
(define (assoc-set! alist key value)
(let ((entry (assoc key alist)))
(if (not entry) (acons key value alist)
(let ((entry (set-cdr! entry value)))
alist))))
(define memv memq)
(define (member x lst)
(if (null? lst) #f
(if (equal? x (car lst)) lst
(member x (cdr lst)))))
;;; Lists
(define (make-list n . x)
(let ((fill (if (pair? x) (car x) *unspecified*)))
(let loop ((n n))
(if (= 0 n) '()
(cons fill (loop (- n 1)))))))
(define (list-ref lst k)
(let loop ((lst lst) (k k))
(if (= 0 k) (car lst)
(loop (cdr lst) (- k 1)))))
(define (list-set! lst k v)
(let loop ((lst lst) (k k))
(if (= 0 k) (set-car! lst v)
(loop (cdr lst) (- k 1)))))
(define (list-head x n)
(if (= 0 n) '()
(cons (car x) (list-head (cdr x) (- n 1)))))
(define (list-tail x n)
(if (= 0 n) x
(list-tail (cdr x) (- n 1))))
(define (iota n)
(if (<= n 0) '()
(append2 (iota (- n 1)) (list (- n 1)))))
(define (reverse lst)
(let loop ((lst lst) (r '()))
(if (null? lst) r
(loop (cdr lst) (cons (car lst) r)))))
(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 (delete x lst)
(filter (lambda (e) (not (equal? e x))) lst))
(define (delq x lst)
(filter (lambda (e) (not (eq? e x))) lst))
(define (compose proc . rest)
(if (null? rest) proc
(lambda args
(proc (apply (apply compose rest) args)))))
;; Vector
(define (vector . rest) (list->vector rest))
(define (make-vector n . x)
(if (null? x) (core:make-vector n)
(list->vector (apply make-list (cons n x)))))
(define (vector-copy x)
(list->vector (vector->list x)))
;;; Strings/srfi-13
(define (make-string n . fill)
(list->string (apply make-list n fill)))
(define (string-set! s k v)
(list->string (list-set! (string->list s) k v)))
(define (substring s start . rest)
(let* ((end (and (pair? rest) (car rest)))
(lst (list-tail (string->list s) start)))
(list->string (if (not end) lst
(list-head lst (- end start))))))
(define (string-prefix? prefix string)
(let ((length (string-length string))
(prefix-length (string-length prefix)))
(and
(>= length prefix-length)
(equal? (substring string 0 prefix-length) prefix))))
(define (string-suffix? suffix string)
(let ((length (string-length string))
(suffix-length (string-length suffix)))
(and
(>= length suffix-length)
(equal? (substring string (- length suffix-length)) suffix))))
(define (string->number s . rest)
(if (string-prefix? "#x" s) (string->number (string-drop s 2) 16)
(let ((lst (string->list s)))
(and (pair? lst)
(let* ((radix (if (null? rest) 10 (car rest)))
(sign (if (and (pair? lst) (char=? (car lst) #\-)) -1 1))
(lst (if (= sign -1) (cdr lst) lst)))
(let loop ((lst lst) (n 0))
(if (null? lst) (* sign n)
(let ((i (char->integer (car lst))))
(cond ((and (>= i (char->integer #\0))
(<= i (char->integer #\9)))
(let ((d (char->integer #\0)))
(loop (cdr lst) (+ (* n radix) (- i d)))))
((and (= radix 16)
(>= i (char->integer #\a))
(<= i (char->integer #\f)))
(let ((d (char->integer #\a)))
(loop (cdr lst) (+ (* n radix) (- i (- d 10))))))
((and (= radix 16)
(>= i (char->integer #\A))
(<= i (char->integer #\F)))
(let ((d (char->integer #\A)))
(loop (cdr lst) (+ (* n radix) (- i (- d 10))))))
((= i (char->integer #\.)) ; minimal FLOAT support
(let ((fraction (cdr lst)))
(if (null? fraction) n
(let ((fraction ((compose string->number list->string) fraction)))
(and fraction n))))) ; FLOAT as integer
(else #f))))))))))
(define inexact->exact identity)
(define (number->string n . rest)
(let* ((radix (if (null? rest) 10 (car rest)))
(sign (if (< n 0) '(#\-) '())))
(let loop ((n (abs n)) (lst '()))
(let* ((i (abs (remainder n radix)))
(lst (cons (integer->char (+ i (if (< i 10) (char->integer #\0)
(- (char->integer #\a) 10)))) lst))
(n (quotient n radix)))
(if (= 0 n) (list->string (append sign lst))
(loop n lst))))))
;;; Symbols
(define (symbol-prefix? prefix symbol)
(string-prefix? (symbol->string prefix) (symbol->string symbol)))
(define (symbol-append . rest)
(string->symbol (apply string-append (map symbol->string rest))))
(define gensym
(let ((counter 0))
(lambda (. rest)
(let ((value (number->string counter)))
(set! counter (+ counter 1))
(string->symbol (string-append "g" value))))))
;;; Keywords
(define (keyword->symbol s)
(string->symbol (keyword->string s)))
;;; Characters
(define (char=? x y)
(and (char? x) (char? y)
(eq? x y)))
(define (char<? a b) (< (char->integer a) (char->integer b)))
(define (char>? a b) (> (char->integer a) (char->integer b)))
(define (char<=? a b) (<= (char->integer a) (char->integer b)))
(define (char>=? a b) (>= (char->integer a) (char->integer b)))
(define (char-alphabetic? x)
(and (char? x)
(let ((i (char->integer x)))
(or (and (>= i (char->integer #\A)) (<= i (char->integer #\Z)))
(and (>= i (char->integer #\a)) (<= i (char->integer #\z)))))))
(define (char-numeric? x)
(and (char? x)
(let ((i (char->integer x)))
(and (>= i (char->integer #\0)) (<= i (char->integer #\9))))))
;;; Math
(define quotient /)
(define (<= . rest)
(or (apply < rest)
(apply = rest)))
(define (>= . rest)
(or (apply > rest)
(apply = rest)))
(define (remainder x y)
(- x (* (quotient x y) y)))
(define (even? x)
(= 0 (remainder x 2)))
(define (odd? x)
(= 1 (remainder x 2)))
(define (negative? x)
(< x 0))
(define (positive? x)
(> x 0))
(define (zero? x)
(= x 0))
(define (1+ x)
(+ x 1))
(define (1- x)
(- x 1))
(define (abs x)
(if (>= x 0) x (- x)))
(define (expt x y)
(let loop ((s 1) (count y))
(if (= 0 count) s
(loop (* s x) (- count 1)))))
(define (max x . rest)
(if (null? rest) x
(let ((y (car rest)))
(let ((z (if (> x y) x y)))
(apply max (cons z (cdr rest)))))))
(define (min x . rest)
(if (null? rest) x
(let ((y (car rest)))
(let ((z (if (< x y) x y)))
(apply min (cons z (cdr rest)))))))
(define (negate proc)
(lambda args
(not (apply proc args))))
(define ceil identity)
(define floor identity)
(define round identity)
(define inexact->exact identity)
(define exact->inexact identity)
(define (const . rest)
(lambda (. _)
(car rest)))

63
sysa/mes-0.22/mes/module/mes/simple-format.mes Normal file
View file

@ -0,0 +1,63 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019 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:
(mes-use-module (mes display))
(define (with-output-to-string thunk)
(define save-write-byte write-byte)
(let ((stdout '()))
(set! write-byte
(lambda (x . rest)
(let ((out? (or (null? rest) (eq? (car rest) (current-output-port)))))
(if (not out?) (apply save-write-byte (cons x rest))
(begin
(set! stdout (append stdout (list (integer->char x))))
x)))))
(thunk)
(let ((r (apply string stdout)))
(set! write-byte save-write-byte)
r)))
(define (simple-format destination format . rest)
(let ((port (if (boolean? destination) (current-output-port) destination))
(lst (string->list format)))
(define (simple-format lst args)
(if (pair? lst)
(let ((c (car lst)))
(if (not (eq? c #\~)) (begin (write-char (car lst) port)
(simple-format (cdr lst) args))
(let ((c (cadr lst)))
(case c
((#\A) (display (car args) port))
((#\a) (display (car args) port))
((#\S) (write (car args) port))
((#\s) (write (car args) port))
(else (display (car args) port)))
(simple-format (cddr lst) (cdr args)))))))
(if destination (simple-format lst rest)
(with-output-to-string
(lambda () (simple-format lst rest))))))
(define format simple-format)

54
sysa/mes-0.22/mes/module/mes/syntax.mes Normal file
View file

@ -0,0 +1,54 @@
;; -*-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:
;;; syntax.mes is loaded after scm.mes. It provides the R5RS hygienic
;;; macros define-syntax, syntax-rules and define-syntax-rule.
;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm
;;; Code:
(mes-use-module (mes scm))
(include-from-path "mes/syntax.scm")
(define (syntax-error message thing)
(display "syntax-error:" (current-error-port))
(display message (current-error-port))
(display ":" (current-error-port))
(display thing (current-error-port))
(newline (current-error-port)))
(define (silent-syntax-error message thing)
*unspecified*)
(define-macro (define-syntax-rule id-pattern . template)
`(define-syntax ,(car id-pattern)
(syntax-rules ()
((,(car id-pattern) . ,(cdr id-pattern)) ,@template))))
(define-macro (let-syntax bindings . rest)
`((lambda ()
,@(map (lambda (binding)
`(define-macro (,(car binding) . args)
(,(cadr binding) (cons ',(car binding) args)
(lambda (x0) x0)
eq?)))
bindings)
,@rest)))

251
sysa/mes-0.22/mes/module/mes/syntax.scm Normal file
View file

@ -0,0 +1,251 @@
;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
;;; 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:
;;; syntax.mes is loaded after scm.mes. It provides the R5RS hygienic
;;; macros define-syntax, syntax-rules and define-syntax-rule.
;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm
;;; Code:
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
;;; scheme48-1.1/COPYING
;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
;; All rights reserved.
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 1. Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;; 3. The name of the authors may not be used to endorse or promote products
;; derived from this software without specific prior written permission.
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define-macro (define-syntax macro-name transformer . stuff)
`(define-macro (,macro-name . args)
(,transformer (cons ',macro-name args)
(lambda (x0) x0)
eq?)))
;; Rewrite-rule compiler (a.k.a. "extend-syntax")
;; Example:
;;
;; (define-syntax or
;; (syntax-rules ()
;; ((or) #f)
;; ((or e) e)
;; ((or e1 e ...) (let ((temp e1))
;; (if temp temp (or e ...))))))
(define-syntax syntax-rules
(let ()
(define name? symbol?)
(define (segment-pattern? pattern)
(and (segment-template? pattern)
(or (null? (cddr pattern))
(syntax-error "segment matching not implemented" pattern))))
(define (segment-template? pattern)
(and (pair? pattern)
(pair? (cdr pattern))
(memq (cadr pattern) indicators-for-zero-or-more)))
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
(lambda (exp r c)
(define %input (r '%input)) ;Gensym these, if you like.
(define %compare (r '%compare))
(define %rename (r '%rename))
(define %tail (r '%tail))
(define %temp (r '%temp))
(define rules (cddr exp))
(define subkeywords (cadr exp))
(define (make-transformer rules)
`(lambda (,%input ,%rename ,%compare)
(let ((,%tail (cdr ,%input)))
(cond ,@(map process-rule rules)
(else
(syntax-error
"use of macro doesn't match definition"
,%input))))))
(define (process-rule rule)
(if (and (pair? rule)
(pair? (cdr rule))
(null? (cddr rule)))
(let ((pattern (cdar rule))
(template (cadr rule)))
`((and ,@(process-match %tail pattern))
(let* ,(process-pattern pattern
%tail
(lambda (x) x))
,(process-template template
0
(meta-variables pattern 0 '())))))
(syntax-error "ill-formed syntax rule" rule)))
;; Generate code to test whether input expression matches pattern
(define (process-match input pattern)
(cond ((name? pattern)
(if (member pattern subkeywords)
`((,%compare ,input (,%rename ',pattern)))
`()))
((segment-pattern? pattern)
(process-segment-match input (car pattern)))
((pair? pattern)
`((let ((,%temp ,input))
(and (pair? ,%temp)
,@(process-match `(car ,%temp) (car pattern))
,@(process-match `(cdr ,%temp) (cdr pattern))))))
((or (null? pattern) (boolean? pattern) (char? pattern))
`((eq? ,input ',pattern)))
(else
`((equal? ,input ',pattern)))))
(define (process-segment-match input pattern)
(let ((conjuncts (process-match '(car l) pattern)))
(if (null? conjuncts)
`((list? ,input)) ;+++
`((let loop ((l ,input))
(or (null? l)
(and (pair? l)
,@conjuncts
(loop (cdr l)))))))))
;; Generate code to take apart the input expression
;; This is pretty bad, but it seems to work (can't say why).
(define (process-pattern pattern path mapit)
(cond ((name? pattern)
(if (memq pattern subkeywords)
'()
(list (list pattern (mapit path)))))
((segment-pattern? pattern)
(process-pattern (car pattern)
%temp
(lambda (x) ;temp is free in x
(mapit (if (eq? %temp x)
path ;+++
`(map (lambda (,%temp) ,x)
,path))))))
((pair? pattern)
(append (process-pattern (car pattern) `(car ,path) mapit)
(process-pattern (cdr pattern) `(cdr ,path) mapit)))
(else '())))
;; Generate code to compose the output expression according to template
(define (process-template template rank env)
(cond ((name? template)
(let ((probe (assq template env)))
(if probe
(if (<= (cdr probe) rank)
template
(syntax-error "template rank error (too few ...'s?)"
template))
`(,%rename ',template))))
((segment-template? template)
(let ((vars
(free-meta-variables (car template) (+ rank 1) env '())))
(if (null? vars)
(silent-syntax-error "too many ...'s" template)
(let* ((x (process-template (car template)
(+ rank 1)
env))
(gen (if (equal? (list x) vars)
x ;+++
`(map (lambda ,vars ,x)
,@vars))))
(if (null? (cddr template))
gen ;+++
`(append ,gen ,(process-template (cddr template)
rank env)))))))
((pair? template)
`(cons ,(process-template (car template) rank env)
,(process-template (cdr template) rank env)))
(else `(quote ,template))))
;; Return an association list of (var . rank)
(define (meta-variables pattern rank vars)
(cond ((name? pattern)
(if (memq pattern subkeywords)
vars
(cons (cons pattern rank) vars)))
((segment-pattern? pattern)
(meta-variables (car pattern) (+ rank 1) vars))
((pair? pattern)
(meta-variables (car pattern) rank
(meta-variables (cdr pattern) rank vars)))
(else vars)))
;; Return a list of meta-variables of given higher rank
(define (free-meta-variables template rank env free)
(cond ((name? template)
(if (and (not (memq template free))
(let ((probe (assq template env)))
(and probe (>= (cdr probe) rank))))
(cons template free)
free))
((segment-template? template)
(free-meta-variables (car template)
rank env
(free-meta-variables (cddr template)
rank env free)))
((pair? template)
(free-meta-variables (car template)
rank env
(free-meta-variables (cdr template)
rank env free)))
(else free)))
c ;ignored
;; Kludge for Scheme48 linker.
;; `(cons ,(make-transformer rules)
;; ',(find-free-names-in-syntax-rules subkeywords rules))
(make-transformer rules))))

21
sysa/mes-0.22/mes/module/mes/test.mes Normal file
View file

@ -0,0 +1,21 @@
;;; -*-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/>.
(include-from-path "mes/test.scm")

1
sysa/mes-0.22/mes/module/mes/tiny-0.mes Normal file
View file

@ -0,0 +1 @@
(cons 0 1)

127
sysa/mes-0.22/mes/module/mes/type-0.mes Normal file
View file

@ -0,0 +1,127 @@
;;; -*-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:
;;; Implement core functionality that depends on implementation
;;; specifics of Mes cell types.
;;; Code:
(define cell:type-alist
(list (cons <cell:bytes> (quote <cell:bytes>))
(cons <cell:char> (quote <cell:char>))
(cons <cell:closure> (quote <cell:closure>))
(cons <cell:continuation> (quote <cell:continuation>))
(cons <cell:keyword> (quote <cell:keyword>))
(cons <cell:macro> (quote <cell:macro>))
(cons <cell:number> (quote <cell:number>))
(cons <cell:pair> (quote <cell:pair>))
(cons <cell:ref> (quote <cell:ref>))
(cons <cell:special> (quote <cell:special>))
(cons <cell:string> (quote <cell:string>))
(cons <cell:struct> (quote <cell:struct>))
(cons <cell:symbol> (quote <cell:symbol>))
(cons <cell:values> (quote <cell:values>))
(cons <cell:variable> (quote <cell:variable>))
(cons <cell:vector> (quote <cell:vector>))
(cons <cell:broken-heart> (quote <cell:broken-heart>))))
(define (cell:type-name x)
(cond ((assq (core:type x) cell:type-alist) => cdr)))
(define (bytes? x)
(eq? (core:type x) <cell:bytes>))
(define (char? x)
(and (eq? (core:type x) <cell:char>)
(> (char->integer x) -1)))
(define (eof-object? x)
(and (eq? (core:type x) <cell:char>)
(= (char->integer x) -1)))
(define (closure? x)
(eq? (core:type x) <cell:closure>))
(define (continuation? x)
(eq? (core:type x) <cell:continuation>))
(define (keyword? x)
(eq? (core:type x) <cell:keyword>))
(define (macro? x)
(eq? (core:type x) <cell:macro>))
(define (number? x)
(eq? (core:type x) <cell:number>))
(define (port? x)
(eq? (core:type x) <cell:port>))
(define (special? x)
(eq? (core:type x) <cell:special>))
(define (string? x)
(eq? (core:type x) <cell:string>))
(define (struct? x)
(eq? (core:type x) <cell:struct>))
(define (symbol? x)
(eq? (core:type x) <cell:symbol>))
(define (values? x)
(eq? (core:type x) <cell:values>))
(define (variable? x)
(eq? (core:type x) <cell:variable>))
(define (variable-global? x)
(core:cdr x))
(define (vector? x)
(eq? (core:type x) <cell:vector>))
(define (broken-heart? x)
(eq? (core:type x) <cell:broken-heart>))
(define (atom? x)
(not (pair? x)))
(define (boolean? x)
(or (eq? x #f) (eq? x #t)))
;;; core: accessors
(define (string . lst)
(list->string lst))
(define (keyword->list s)
(string->list (keyword->string s)))
(define (symbol->list s)
(string->list (symbol->string s)))
(define (integer->char x)
(core:make-cell <cell:char> 0 x))
(define (char->integer x)
(core:make-cell <cell:number> 0 x))

25
sysa/mes-0.22/mes/module/mescc.mes Normal file
View file

@ -0,0 +1,25 @@
;;; -*-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:
;;; Code:
(include-from-path "mescc.scm")

28
sysa/mes-0.22/mes/module/mescc/M1.mes Normal file
View file

@ -0,0 +1,28 @@
;;; -*-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/>.
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-26))
(mes-use-module (mes misc))
(mes-use-module (mes optargs))
(mes-use-module (mes pmatch))
(mes-use-module (mescc as))
(mes-use-module (mescc info))
(include-from-path "mescc/M1.scm")

23
sysa/mes-0.22/mes/module/mescc/as.mes Normal file
View file

@ -0,0 +1,23 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 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/>.
(mes-use-module (srfi srfi-1))
(mes-use-module (mescc bytevectors))
(include-from-path "mescc/as.scm")

21
sysa/mes-0.22/mes/module/mescc/bytevectors.mes Normal file
View file

@ -0,0 +1,21 @@
;;; -*-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/>.
(include-from-path "mescc/bytevectors.scm")

33
sysa/mes-0.22/mes/module/mescc/compile.mes Normal file
View file

@ -0,0 +1,33 @@
;;; -*-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/>.
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-13))
(mes-use-module (srfi srfi-26))
(mes-use-module (mes pmatch))
(mes-use-module (mes optargs))
(mes-use-module (mes misc))
(mes-use-module (nyacc lang c99 pprint))
(mes-use-module (mescc as))
(mes-use-module (mescc i386 as))
(mes-use-module (mescc info))
(mes-use-module (mescc M1))
(include-from-path "mescc/compile.scm")

23
sysa/mes-0.22/mes/module/mescc/i386/as.mes Normal file
View file

@ -0,0 +1,23 @@
;;; -*-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/>.
(mes-use-module (mescc as))
(mes-use-module (mescc info))
(include-from-path "mescc/i386/as.scm")

23
sysa/mes-0.22/mes/module/mescc/i386/info.mes Normal file
View file

@ -0,0 +1,23 @@
;;; -*-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/>.
(mes-use-module (mescc info))
(mes-use-module (mescc i386 as))
(include-from-path "mescc/i386/info.scm")

28
sysa/mes-0.22/mes/module/mescc/info.mes Normal file
View file

@ -0,0 +1,28 @@
;;; -*-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:
;;; Code:
(mes-use-module (srfi srfi-9))
(mes-use-module (srfi srfi-9 gnu))
(mes-use-module (mes optargs))
(include-from-path "mescc/info.scm")

33
sysa/mes-0.22/mes/module/mescc/mescc.mes Normal file
View file

@ -0,0 +1,33 @@
;;; -*-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/>.
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-13))
(mes-use-module (srfi srfi-26))
(mes-use-module (mes misc))
(mes-use-module (mes getopt-long))
(mes-use-module (mes guile))
(mes-use-module (mescc i386 info))
(mes-use-module (mescc x86_64 info))
(mes-use-module (mescc preprocess))
(mes-use-module (mescc compile))
(mes-use-module (mescc M1))
(include-from-path "mescc/mescc.scm")

28
sysa/mes-0.22/mes/module/mescc/preprocess.mes Normal file
View file

@ -0,0 +1,28 @@
;;; -*-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/>.
(mes-use-module (mes optargs))
(mes-use-module (mes pmatch))
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-13))
(mes-use-module (srfi srfi-26))
(mes-use-module (nyacc lang c99 parser))
(mes-use-module (nyacc version))
(include-from-path "mescc/preprocess.scm")

24
sysa/mes-0.22/mes/module/mescc/x86_64/as.mes Normal file
View file

@ -0,0 +1,24 @@
;;; -*-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/>.
(mes-use-module (mescc as))
(mes-use-module (mescc info))
(mes-use-module (mescc x86_64 info))
(include-from-path "mescc/x86_64/as.scm")

23
sysa/mes-0.22/mes/module/mescc/x86_64/info.mes Normal file
View file

@ -0,0 +1,23 @@
;;; -*-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/>.
(mes-use-module (mescc info))
(mes-use-module (mescc x86_64 as))
(include-from-path "mescc/x86_64/info.scm")

29
sysa/mes-0.22/mes/module/nyacc/lalr.mes Normal file
View file

@ -0,0 +1,29 @@
;;; -*-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:
;;; Code:
(mes-use-module (mes psyntax))
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-9-psyntax))
(mes-use-module (srfi srfi-43))
(include-from-path "nyacc/lalr.scm")

33
sysa/mes-0.22/mes/module/nyacc/lang/c99/cpp.mes Normal file
View file

@ -0,0 +1,33 @@
;;; -*-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:
;;; Code:
(mes-use-module (mes guile))
(mes-use-module (mes pmatch))
(mes-use-module (rnrs arithmetic bitwise))
(mes-use-module (nyacc parse))
(mes-use-module (nyacc lex))
(mes-use-module (nyacc lang sx-util))
(mes-use-module (nyacc lang util))
(include-from-path "nyacc/lang/c99/cpp.scm")

40
sysa/mes-0.22/mes/module/nyacc/lang/c99/parser.mes Normal file
View file

@ -0,0 +1,40 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2019 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:
(mes-use-module (mes guile))
(mes-use-module (mes catch))
(mes-use-module (mes fluids))
(mes-use-module (mes pretty-print))
(mes-use-module (mes optargs))
(mes-use-module (srfi srfi-9))
(mes-use-module (sxml xpath))
(mes-use-module (nyacc lex))
(mes-use-module (nyacc parse))
(mes-use-module (nyacc lang sx-util))
(mes-use-module (nyacc lang util))
(mes-use-module (nyacc lang c99 cpp))
(mes-use-module (nyacc lang c99 util))
(include-from-path "nyacc/lang/c99/parser.scm")

38
sysa/mes-0.22/mes/module/nyacc/lang/c99/pprint.mes Normal file
View file

@ -0,0 +1,38 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2017 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:
(mes-use-module (mes guile))
(mes-use-module (mes optargs))
;;(mes-use-module (srfi srfi-1))
;;(mes-use-module (nyacc lang util))
;;(mes-use-module (sxml match))
;;(mes-use-module (mes pretty-print))
;;(include-from-path "nyacc/lang/c99/pprint.scm")
;; mes does not have (sxml match), short-circuit me
(define* (pretty-print-c99 tree
#:optional (port (current-output-port))
#:key ugly per-line-prefix (basic-offset 2))
(write tree port))

45
sysa/mes-0.22/mes/module/nyacc/lang/c99/util.mes Normal file
View file

@ -0,0 +1,45 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2019 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:
(mes-use-module (mes guile))
(mes-use-module (mes catch))
(mes-use-module (mes fluids))
(mes-use-module (mes pretty-print))
(mes-use-module (mes optargs))
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-9))
(mes-use-module (sxml xpath))
;; FIXME: Nyacc 0.93.0:
;; FIXME: (mes-use-module (srfi srfi-2))
;; FIXME: (mes-use-module (sxml fold))
;; FIXME: (ice-9 popen)
;; FIXME: (ice-9 rdelim)
(define (export . rest) #t)
(define (close-port port) #t)
(mes-use-module (nyacc lang util))
(mes-use-module (nyacc lang sx-util))
(include-from-path "nyacc/lang/c99/util.scm")

30
sysa/mes-0.22/mes/module/nyacc/lang/calc/parser.mes Normal file
View file

@ -0,0 +1,30 @@
;;; -*-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:
;;; Code:
(mes-use-module (mes guile))
(mes-use-module (mes pretty-print))
(mes-use-module (nyacc lalr))
(mes-use-module (nyacc lex))
(mes-use-module (nyacc parse))
(include-from-path "nyacc/lang/calc/parser.scm")

27
sysa/mes-0.22/mes/module/nyacc/lang/sx-util.mes Normal file
View file

@ -0,0 +1,27 @@
;;; -*-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:
;;; Code:
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-16))
(include-from-path "nyacc/lang/sx-util.scm")

29
sysa/mes-0.22/mes/module/nyacc/lang/util.mes Normal file
View file

@ -0,0 +1,29 @@
;;; -*-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:
;;; Code:
(mes-use-module (mes guile))
(mes-use-module (mes fluids))
(mes-use-module (mes optargs))
(mes-use-module (srfi srfi-1))
(include-from-path "nyacc/lang/util.scm")

31
sysa/mes-0.22/mes/module/nyacc/lex.mes Normal file
View file

@ -0,0 +1,31 @@
;;; -*-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:
;;; Code:
(mes-use-module (mes guile))
(mes-use-module (mes optargs))
(mes-use-module (mes pretty-print))
(mes-use-module (mes syntax))
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-14))
(include-from-path "nyacc/lex.scm")

29
sysa/mes-0.22/mes/module/nyacc/parse.mes Normal file
View file

@ -0,0 +1,29 @@
;;; -*-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:
;;; Code:
(mes-use-module (mes guile))
(mes-use-module (mes optargs))
(mes-use-module (srfi srfi-43))
(mes-use-module (nyacc util))
(include-from-path "nyacc/parse.scm")

28
sysa/mes-0.22/mes/module/nyacc/util.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:
;;; Code:
(mes-use-module (mes guile))
(mes-use-module (mes optargs))
(mes-use-module (srfi srfi-43))
(include-from-path "nyacc/util.scm")

25
sysa/mes-0.22/mes/module/nyacc/version.mes Normal file
View file

@ -0,0 +1,25 @@
;;; -*-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:
;;; Code:
(include-from-path "nyacc/version.scm")

30
sysa/mes-0.22/mes/module/rnrs/arithmetic/bitwise.mes Normal file
View file

@ -0,0 +1,30 @@
;;; -*-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:
;;; Code:
(mes-use-module (mes scm))
(define bitwise-arithmetic-shift ash)
(define bitwise-arithmetic-shift-left bitwise-arithmetic-shift)
(define (bitwise-arithmetic-shift-right n count)
(bitwise-arithmetic-shift n (- count)))

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

26
sysa/mes-0.22/mes/module/sxml/xpath.mes Normal file
View file

@ -0,0 +1,26 @@
;;; -*-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:
;;; xpath
(mes-use-module (mes scm))
(include-from-path "sxml/xpath.scm")

496
sysa/mes-0.22/mes/module/sxml/xpath.scm Normal file
View file

@ -0,0 +1,496 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
;;; Written 2001 by Oleg Kiselyov <oleg at pobox dot com> SXPath.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/>.
;;; Taken from GNU Guile
;;; (sxml xpath) -- SXPath
;;; Commentary:
;;
;;@heading SXPath: SXML Query Language
;;
;; SXPath is a query language for SXML, an instance of XML Information
;; set (Infoset) in the form of s-expressions. See @code{(sxml ssax)}
;; for the definition of SXML and more details. SXPath is also a
;; translation into Scheme of an XML Path Language,
;; @uref{http://www.w3.org/TR/xpath,XPath}. XPath and SXPath describe
;; means of selecting a set of Infoset's items or their properties.
;;
;; To facilitate queries, XPath maps the XML Infoset into an explicit
;; tree, and introduces important notions of a location path and a
;; current, context node. A location path denotes a selection of a set of
;; nodes relative to a context node. Any XPath tree has a distinguished,
;; root node -- which serves as the context node for absolute location
;; paths. Location path is recursively defined as a location step joined
;; with a location path. A location step is a simple query of the
;; database relative to a context node. A step may include expressions
;; that further filter the selected set. Each node in the resulting set
;; is used as a context node for the adjoining location path. The result
;; of the step is a union of the sets returned by the latter location
;; paths.
;;
;; The SXML representation of the XML Infoset (see SSAX.scm) is rather
;; suitable for querying as it is. Bowing to the XPath specification,
;; we will refer to SXML information items as 'Nodes':
;;@example
;; <Node> ::= <Element> | <attributes-coll> | <attrib>
;; | "text string" | <PI>
;;@end example
;; This production can also be described as
;;@example
;; <Node> ::= (name . <Nodeset>) | "text string"
;;@end example
;; An (ordered) set of nodes is just a list of the constituent nodes:
;;@example
;; <Nodeset> ::= (<Node> ...)
;;@end example
;; Nodesets, and Nodes other than text strings are both lists. A
;; <Nodeset> however is either an empty list, or a list whose head is not
;; a symbol. A symbol at the head of a node is either an XML name (in
;; which case it's a tag of an XML element), or an administrative name
;; such as '@@'. This uniform list representation makes processing rather
;; simple and elegant, while avoiding confusion. The multi-branch tree
;; structure formed by the mutually-recursive datatypes <Node> and
;; <Nodeset> lends itself well to processing by functional languages.
;;
;; A location path is in fact a composite query over an XPath tree or
;; its branch. A singe step is a combination of a projection, selection
;; or a transitive closure. Multiple steps are combined via join and
;; union operations. This insight allows us to @emph{elegantly}
;; implement XPath as a sequence of projection and filtering primitives
;; -- converters -- joined by @dfn{combinators}. Each converter takes a
;; node and returns a nodeset which is the result of the corresponding
;; query relative to that node. A converter can also be called on a set
;; of nodes. In that case it returns a union of the corresponding
;; queries over each node in the set. The union is easily implemented as
;; a list append operation as all nodes in a SXML tree are considered
;; distinct, by XPath conventions. We also preserve the order of the
;; members in the union. Query combinators are high-order functions:
;; they take converter(s) (which is a Node|Nodeset -> Nodeset function)
;; and compose or otherwise combine them. We will be concerned with only
;; relative location paths [XPath]: an absolute location path is a
;; relative path applied to the root node.
;;
;; Similarly to XPath, SXPath defines full and abbreviated notations
;; for location paths. In both cases, the abbreviated notation can be
;; mechanically expanded into the full form by simple rewriting
;; rules. In case of SXPath the corresponding rules are given as
;; comments to a sxpath function, below. The regression test suite at
;; the end of this file shows a representative sample of SXPaths in
;; both notations, juxtaposed with the corresponding XPath
;; expressions. Most of the samples are borrowed literally from the
;; XPath specification, while the others are adjusted for our running
;; example, tree1.
;;
;;; Code:
(define-module (sxml xpath)
#:use-module (ice-9 pretty-print)
#:export (nodeset? node-typeof? node-eq? node-equal? node-pos
xpath:filter take-until take-after map-union node-reverse
node-trace select-kids node-self node-join node-reduce
node-or node-closure node-parent
sxpath))
;; Upstream version:
; $Id: SXPath.scm,v 3.5 2001/01/12 23:20:35 oleg Exp oleg $
(define (nodeset? x)
(or (and (pair? x) (not (symbol? (car x)))) (null? x)))
;-------------------------
; Basic converters and applicators
; A converter is a function
; type Converter = Node|Nodeset -> Nodeset
; A converter can also play a role of a predicate: in that case, if a
; converter, applied to a node or a nodeset, yields a non-empty
; nodeset, the converter-predicate is deemed satisfied. Throughout
; this file a nil nodeset is equivalent to #f in denoting a failure.
; The following function implements a 'Node test' as defined in
; Sec. 2.3 of XPath document. A node test is one of the components of a
; location step. It is also a converter-predicate in SXPath.
;
; The function node-typeof? takes a type criterion and returns a function,
; which, when applied to a node, will tell if the node satisfies
; the test.
; node-typeof? :: Crit -> Node -> Boolean
;
; The criterion 'crit' is a symbol, one of the following:
; id - tests if the Node has the right name (id)
; @ - tests if the Node is an <attributes-coll>
; * - tests if the Node is an <Element>
; *text* - tests if the Node is a text node
; *PI* - tests if the Node is a PI node
; *any* - #t for any type of Node
(define (node-typeof? crit)
(lambda (node)
(case crit
((*) (and (pair? node) (not (memq (car node) '(@ *PI*)))))
((*any*) #t)
((*text*) (string? node))
(else
(and (pair? node) (eq? crit (car node))))
)))
; Curried equivalence converter-predicates
(define (node-eq? other)
(lambda (node)
(eq? other node)))
(define (node-equal? other)
(lambda (node)
(equal? other node)))
; node-pos:: N -> Nodeset -> Nodeset, or
; node-pos:: N -> Converter
; Select the N'th element of a Nodeset and return as a singular Nodeset;
; Return an empty nodeset if the Nth element does not exist.
; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset,
; if exists; ((node-pos 2) Nodeset) selects the Node after that, if
; exists.
; N can also be a negative number: in that case the node is picked from
; the tail of the list.
; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset;
; ((node-pos -2) Nodeset) selects the last but one node, if exists.
(define (node-pos n)
(lambda (nodeset)
(cond
((not (nodeset? nodeset)) '())
((null? nodeset) nodeset)
((eqv? n 1) (list (car nodeset)))
((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset))
(else
(or (positive? n) (error "yikes!"))
((node-pos (1- n)) (cdr nodeset))))))
; xpath:filter:: Converter -> Converter
; A xpath:filter applicator, which introduces a xpath:filtering context. The argument
; converter is considered a predicate, with either #f or nil result meaning
; failure.
(define (xpath:filter pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))) (res '()))
(if (null? lst)
(reverse res)
(let ((pred-result (pred? (car lst))))
(loop (cdr lst)
(if (and pred-result (not (null? pred-result)))
(cons (car lst) res)
res)))))))
; take-until:: Converter -> Converter, or
; take-until:: Pred -> Node|Nodeset -> Nodeset
; Given a converter-predicate and a nodeset, apply the predicate to
; each element of the nodeset, until the predicate yields anything but #f or
; nil. Return the elements of the input nodeset that have been processed
; till that moment (that is, which fail the predicate).
; take-until is a variation of the xpath:filter above: take-until passes
; elements of an ordered input set till (but not including) the first
; element that satisfies the predicate.
; The nodeset returned by ((take-until (not pred)) nset) is a subset --
; to be more precise, a prefix -- of the nodeset returned by
; ((xpath:filter pred) nset)
(define (take-until pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))))
(if (null? lst) lst
(let ((pred-result (pred? (car lst))))
(if (and pred-result (not (null? pred-result)))
'()
(cons (car lst) (loop (cdr lst)))))
))))
; take-after:: Converter -> Converter, or
; take-after:: Pred -> Node|Nodeset -> Nodeset
; Given a converter-predicate and a nodeset, apply the predicate to
; each element of the nodeset, until the predicate yields anything but #f or
; nil. Return the elements of the input nodeset that have not been processed:
; that is, return the elements of the input nodeset that follow the first
; element that satisfied the predicate.
; take-after along with take-until partition an input nodeset into three
; parts: the first element that satisfies a predicate, all preceding
; elements and all following elements.
(define (take-after pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))))
(if (null? lst) lst
(let ((pred-result (pred? (car lst))))
(if (and pred-result (not (null? pred-result)))
(cdr lst)
(loop (cdr lst))))
))))
; Apply proc to each element of lst and return the list of results.
; if proc returns a nodeset, splice it into the result
;
; From another point of view, map-union is a function Converter->Converter,
; which places an argument-converter in a joining context.
(define (map-union proc lst)
(if (null? lst) lst
(let ((proc-res (proc (car lst))))
((if (nodeset? proc-res) append cons)
proc-res (map-union proc (cdr lst))))))
; node-reverse :: Converter, or
; node-reverse:: Node|Nodeset -> Nodeset
; Reverses the order of nodes in the nodeset
; This basic converter is needed to implement a reverse document order
; (see the XPath Recommendation).
(define node-reverse
(lambda (node-or-nodeset)
(if (not (nodeset? node-or-nodeset)) (list node-or-nodeset)
(reverse node-or-nodeset))))
; node-trace:: String -> Converter
; (node-trace title) is an identity converter. In addition it prints out
; a node or nodeset it is applied to, prefixed with the 'title'.
; This converter is very useful for debugging.
(define (node-trace title)
(lambda (node-or-nodeset)
(display "\n-->")
(display title)
(display " :")
(pretty-print node-or-nodeset)
node-or-nodeset))
;-------------------------
; Converter combinators
;
; Combinators are higher-order functions that transmogrify a converter
; or glue a sequence of converters into a single, non-trivial
; converter. The goal is to arrive at converters that correspond to
; XPath location paths.
;
; From a different point of view, a combinator is a fixed, named
; _pattern_ of applying converters. Given below is a complete set of
; such patterns that together implement XPath location path
; specification. As it turns out, all these combinators can be built
; from a small number of basic blocks: regular functional composition,
; map-union and xpath:filter applicators, and the nodeset union.
; select-kids:: Pred -> Node -> Nodeset
; Given a Node, return an (ordered) subset its children that satisfy
; the Pred (a converter, actually)
; select-kids:: Pred -> Nodeset -> Nodeset
; The same as above, but select among children of all the nodes in
; the Nodeset
;
; More succinctly, the signature of this function is
; select-kids:: Converter -> Converter
(define (select-kids test-pred?)
(lambda (node) ; node or node-set
(cond
((null? node) node)
((not (pair? node)) '()) ; No children
((symbol? (car node))
((xpath:filter test-pred?) (cdr node))) ; it's a single node
(else (map-union (select-kids test-pred?) node)))))
; node-self:: Pred -> Node -> Nodeset, or
; node-self:: Converter -> Converter
; Similar to select-kids but apply to the Node itself rather
; than to its children. The resulting Nodeset will contain either one
; component, or will be empty (if the Node failed the Pred).
(define node-self xpath:filter)
; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or
; node-join:: [Converter] -> Converter
; join the sequence of location steps or paths as described
; in the title comments above.
(define (node-join . selectors)
(lambda (nodeset) ; Nodeset or node
(let loop ((nodeset nodeset) (selectors selectors))
(if (null? selectors) nodeset
(loop
(if (nodeset? nodeset)
(map-union (car selectors) nodeset)
((car selectors) nodeset))
(cdr selectors))))))
; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or
; node-reduce:: [Converter] -> Converter
; A regular functional composition of converters.
; From a different point of view,
; ((apply node-reduce converters) nodeset)
; is equivalent to
; (foldl apply nodeset converters)
; i.e., folding, or reducing, a list of converters with the nodeset
; as a seed.
(define (node-reduce . converters)
(lambda (nodeset) ; Nodeset or node
(let loop ((nodeset nodeset) (converters converters))
(if (null? converters) nodeset
(loop ((car converters) nodeset) (cdr converters))))))
; node-or:: [Converter] -> Converter
; This combinator applies all converters to a given node and
; produces the union of their results.
; This combinator corresponds to a union, '|' operation for XPath
; location paths.
; (define (node-or . converters)
; (lambda (node-or-nodeset)
; (if (null? converters) node-or-nodeset
; (append
; ((car converters) node-or-nodeset)
; ((apply node-or (cdr converters)) node-or-nodeset)))))
; More optimal implementation follows
(define (node-or . converters)
(lambda (node-or-nodeset)
(let loop ((result '()) (converters converters))
(if (null? converters) result
(loop (append result (or ((car converters) node-or-nodeset) '()))
(cdr converters))))))
; node-closure:: Converter -> Converter
; Select all _descendants_ of a node that satisfy a converter-predicate.
; This combinator is similar to select-kids but applies to
; grand... children as well.
; This combinator implements the "descendant::" XPath axis
; Conceptually, this combinator can be expressed as
; (define (node-closure f)
; (node-or
; (select-kids f)
; (node-reduce (select-kids (node-typeof? '*)) (node-closure f))))
; This definition, as written, looks somewhat like a fixpoint, and it
; will run forever. It is obvious however that sooner or later
; (select-kids (node-typeof? '*)) will return an empty nodeset. At
; this point further iterations will no longer affect the result and
; can be stopped.
(define (node-closure test-pred?)
(lambda (node) ; Nodeset or node
(let loop ((parent node) (result '()))
(if (null? parent) result
(loop ((select-kids (node-typeof? '*)) parent)
(append result
((select-kids test-pred?) parent)))
))))
; node-parent:: RootNode -> Converter
; (node-parent rootnode) yields a converter that returns a parent of a
; node it is applied to. If applied to a nodeset, it returns the list
; of parents of nodes in the nodeset. The rootnode does not have
; to be the root node of the whole SXML tree -- it may be a root node
; of a branch of interest.
; Given the notation of Philip Wadler's paper on semantics of XSLT,
; parent(x) = { y | y=subnode*(root), x=subnode(y) }
; Therefore, node-parent is not the fundamental converter: it can be
; expressed through the existing ones. Yet node-parent is a rather
; convenient converter. It corresponds to a parent:: axis of SXPath.
; Note that the parent:: axis can be used with an attribute node as well!
(define (node-parent rootnode)
(lambda (node) ; Nodeset or node
(if (nodeset? node) (map-union (node-parent rootnode) node)
(let ((pred
(node-or
(node-reduce
(node-self (node-typeof? '*))
(select-kids (node-eq? node)))
(node-join
(select-kids (node-typeof? '@))
(select-kids (node-eq? node))))))
((node-or
(node-self pred)
(node-closure pred))
rootnode)))))
;-------------------------
; Evaluate an abbreviated SXPath
; sxpath:: AbbrPath -> Converter, or
; sxpath:: AbbrPath -> Node|Nodeset -> Nodeset
; AbbrPath is a list. It is translated to the full SXPath according
; to the following rewriting rules
; (sxpath '()) -> (node-join)
; (sxpath '(path-component ...)) ->
; (node-join (sxpath1 path-component) (sxpath '(...)))
; (sxpath1 '//) -> (node-or
; (node-self (node-typeof? '*any*))
; (node-closure (node-typeof? '*any*)))
; (sxpath1 '(equal? x)) -> (select-kids (node-equal? x))
; (sxpath1 '(eq? x)) -> (select-kids (node-eq? x))
; (sxpath1 ?symbol) -> (select-kids (node-typeof? ?symbol)
; (sxpath1 procedure) -> procedure
; (sxpath1 '(?symbol ...)) -> (sxpath1 '((?symbol) ...))
; (sxpath1 '(path reducer ...)) ->
; (node-reduce (sxpath path) (sxpathr reducer) ...)
; (sxpathr number) -> (node-pos number)
; (sxpathr path-xpath:filter) -> (xpath:filter (sxpath path-xpath:filter))
(define (sxpath path)
(lambda (nodeset)
(let loop ((nodeset nodeset) (path path))
(cond
((null? path) nodeset)
((nodeset? nodeset)
(map-union (sxpath path) nodeset))
((procedure? (car path))
(loop ((car path) nodeset) (cdr path)))
((eq? '// (car path))
(loop
((if (nodeset? nodeset) append cons) nodeset
((node-closure (node-typeof? '*any*)) nodeset))
(cdr path)))
((symbol? (car path))
(loop ((select-kids (node-typeof? (car path))) nodeset)
(cdr path)))
((and (pair? (car path)) (eq? 'equal? (caar path)))
(loop ((select-kids (apply node-equal? (cdar path))) nodeset)
(cdr path)))
((and (pair? (car path)) (eq? 'eq? (caar path)))
(loop ((select-kids (apply node-eq? (cdar path))) nodeset)
(cdr path)))
((pair? (car path))
(let reducer ((nodeset
(if (symbol? (caar path))
((select-kids (node-typeof? (caar path))) nodeset)
(loop nodeset (caar path))))
(reducing-path (cdar path)))
(cond
((null? reducing-path) (loop nodeset (cdr path)))
((number? (car reducing-path))
(reducer ((node-pos (car reducing-path)) nodeset)
(cdr reducing-path)))
(else
(reducer ((xpath:filter (sxpath (car reducing-path))) nodeset)
(cdr reducing-path))))))
(else
(error "Invalid path step: " (car path)))))))
;;; arch-tag: c4e57abf-6b61-4612-a6aa-d1536d440774
;;; xpath.scm ends here