artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Relicense imported LGPL v3+ files to GPL v3+.

Browse source 
Fixes https://savannah.nongnu.org/task/?16067.
Reported via savannah by Ineiev <ineiev@gnu.org>.

* mes/module/mes/lalr.scm,
module/mes/getopt-long.scm,
module/mes/optargs.scm: Change header to GNU Mes header with GPL v3.
This commit is contained in:
Jan (janneke) Nieuwenhuizen 2021-11-09 11:49:41 +01:00
parent f553d84de2
commit 3539572f9c
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
3 changed files with 123 additions and 115 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

154
mes/module/mes/lalr.scm
View file

@ -1,33 +1,39 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; ;;;
;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme ;;; Copyright © 1993, 2010 Dominique Boucher
;;; Copyright © 2014 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;; Copyright 2014 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; This file is part of GNU Mes.
;; Copyright 1993, 2010 Dominique Boucher ;;;
;; ;;; GNU Mes is free software; you can redistribute it and/or modify it
;; This program is free software: you can redistribute it and/or ;;; under the terms of the GNU General Public License as published by
;; modify it under the terms of the GNU Lesser General Public License ;;; the Free Software Foundation; either version 3 of the License, or (at
;; as published by the Free Software Foundation, either version 3 of ;;; your option) any later version.
;; the License, or (at your option) any later version. ;;;
;; ;;; GNU Mes is distributed in the hope that it will be useful, but
;; This program is distributed in the hope that it will be useful, ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details.
;; GNU Lesser General Public License for more details. ;;;
;; ;;; You should have received a copy of the GNU General Public License
;; You should have received a copy of the GNU General Public License ;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
;;; Code:
(define *lalr-scm-version* "2.5.0") (define *lalr-scm-version* "2.5.0")
(cond-expand (cond-expand
;; -- Gambit-C ;; -- Gambit-C
(gambit (gambit
(display "Gambit-C!") (display "Gambit-C!")
(newline) (newline)
(define-macro (def-macro form . body) (define-macro (def-macro form . body)
`(define-macro ,form (let () ,@body))) `(define-macro ,form (let () ,@body)))
@ -38,8 +44,8 @@
(define pprint pretty-print) (define pprint pretty-print)
(define lalr-keyword? keyword?) (define lalr-keyword? keyword?)
(define (note-source-location lvalue tok) lvalue)) (define (note-source-location lvalue tok) lvalue))
;; -- ;; --
(bigloo (bigloo
(define-macro (def-macro form . body) (define-macro (def-macro form . body)
`(define-macro ,form (let () ,@body))) `(define-macro ,form (let () ,@body)))
@ -50,10 +56,10 @@
(def-macro (logical-or x . y) `(bit-or ,x ,@y)) (def-macro (logical-or x . y) `(bit-or ,x ,@y))
(def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj)) (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
(define (note-source-location lvalue tok) lvalue)) (define (note-source-location lvalue tok) lvalue))
;; -- Chicken ;; -- Chicken
(chicken (chicken
(define-macro (def-macro form . body) (define-macro (def-macro form . body)
`(define-macro ,form (let () ,@body))) `(define-macro ,form (let () ,@body)))
@ -102,7 +108,7 @@
(define-macro (lalr-error msg obj) `(error ,msg ,obj)) (define-macro (lalr-error msg obj) `(error ,msg ,obj))
(define (note-source-location lvalue tok) lvalue) (define (note-source-location lvalue tok) lvalue)
(define *eoi* -1)) (define *eoi* -1))
;; -- Kawa ;; -- Kawa
(kawa (kawa
(require 'pretty-print) (require 'pretty-print)
@ -117,14 +123,14 @@
(sisc (sisc
(import logicops) (import logicops)
(import record) (import record)
(define pprint pretty-print) (define pprint pretty-print)
(define lalr-keyword? symbol?) (define lalr-keyword? symbol?)
(define-macro BITS-PER-WORD (lambda () 32)) (define-macro BITS-PER-WORD (lambda () 32))
(define-macro logical-or (lambda (x . y) `(logor ,x ,@y))) (define-macro logical-or (lambda (x . y) `(logor ,x ,@y)))
(define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj)) (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj))
(define (note-source-location lvalue tok) lvalue)) (define (note-source-location lvalue tok) lvalue))
;; -- Gauche ;; -- Gauche
(gauche (gauche
(use gauche.record) (use gauche.record)
@ -221,7 +227,7 @@
(define STATE-TABLE-SIZE 1009) (define STATE-TABLE-SIZE 1009)
;; - Tableaux ;; - Tableaux
(define rrhs #f) (define rrhs #f)
(define rlhs #f) (define rlhs #f)
(define ritem #f) (define ritem #f)
@ -1056,10 +1062,10 @@
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
;; operator precedence management ;; operator precedence management
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
;; a vector of precedence descriptors where each element ;; a vector of precedence descriptors where each element
;; is of the form (terminal type precedence) ;; is of the form (terminal type precedence)
(define the-terminals/prec #f) ; terminal symbols with precedence (define the-terminals/prec #f) ; terminal symbols with precedence
; the precedence is an integer >= 0 ; the precedence is an integer >= 0
(define (get-symbol-precedence sym) (define (get-symbol-precedence sym)
(caddr (vector-ref the-terminals/prec sym))) (caddr (vector-ref the-terminals/prec sym)))
@ -1130,13 +1136,13 @@
(if (pair? actions) (if (pair? actions)
(let ((current-action (cadr actions))) (let ((current-action (cadr actions)))
(if (not (= new-action current-action)) (if (not (= new-action current-action))
;; -- there is a conflict ;; -- there is a conflict
(begin (begin
(if (and (<= current-action 0) (<= new-action 0)) (if (and (<= current-action 0) (<= new-action 0))
;; --- reduce/reduce conflict ;; --- reduce/reduce conflict
(begin (begin
(add-conflict-message (add-conflict-message
"%% Reduce/Reduce conflict (reduce " (- new-action) ", reduce " (- current-action) "%% Reduce/Reduce conflict (reduce " (- new-action) ", reduce " (- current-action)
") on '" (get-symbol (+ symbol nvars)) "' in state " state) ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
(if (glr-driver?) (if (glr-driver?)
(set-cdr! (cdr actions) (cons new-action (cddr actions))) (set-cdr! (cdr actions) (cons new-action (cddr actions)))
@ -1157,7 +1163,7 @@
(if (glr-driver?) (if (glr-driver?)
(set-cdr! (cdr actions) (cons new-action (cddr actions))) (set-cdr! (cdr actions) (cons new-action (cddr actions)))
(set-car! (cdr actions) new-action)))))))) (set-car! (cdr actions) new-action))))))))
(vector-set! action-table state (cons (list symbol new-action) state-actions))) (vector-set! action-table state (cons (list symbol new-action) state-actions)))
)) ))
@ -1456,7 +1462,7 @@
(symbol? x)) (symbol? x))
(define (valid-terminal? x) (define (valid-terminal? x)
(symbol? x)) ; DB (symbol? x)) ; DB
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
;; Miscellaneous ;; Miscellaneous
@ -1503,7 +1509,7 @@
(if (p x) (if (p x)
(cons x (loop y)) (cons x (loop y))
(loop y)))))) (loop y))))))
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
;; Debugging tools ... ;; Debugging tools ...
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
@ -1600,7 +1606,7 @@
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
(define build-goto-table (define build-goto-table
(lambda () (lambda ()
`(vector `(vector
@ -1652,7 +1658,7 @@
'())) '()))
,(if (= nt 0) ,(if (= nt 0)
'$1 '$1
`(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp)) `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp))
,(if (eq? driver-name 'lr-driver) ,(if (eq? driver-name 'lr-driver)
`(vector-ref ___stack (- ___sp ,(length rhs))) `(vector-ref ___stack (- ___sp ,(length rhs)))
`(list-ref ___sp ,(length rhs)))))))))) `(list-ref ___sp ,(length rhs))))))))))
@ -1755,13 +1761,13 @@
(set-driver-name! options) (set-driver-name! options)
(let* ((gram/actions (gen-tables! tokens rules)) (let* ((gram/actions (gen-tables! tokens rules))
(code `(,driver-name ',action-table ,(build-goto-table) ,(build-reduction-table gram/actions)))) (code `(,driver-name ',action-table ,(build-goto-table) ,(build-reduction-table gram/actions))))
(output-table! options) (output-table! options)
(output-parser! options code) (output-parser! options code)
code)) code))
(extract-arguments arguments build-driver)) (extract-arguments arguments build-driver))
;;; ;;;
@ -1793,7 +1799,7 @@
;; This function assumes that src-location-1 and src-location-2 are source-locations ;; This function assumes that src-location-1 and src-location-2 are source-locations
;; Returns #f if they are not locations for the same input ;; Returns #f if they are not locations for the same input
(define (combine-locations src-location-1 src-location-2) (define (combine-locations src-location-1 src-location-2)
(let ((offset-1 (source-location-offset src-location-1)) (let ((offset-1 (source-location-offset src-location-1))
(offset-2 (source-location-offset src-location-2)) (offset-2 (source-location-offset src-location-2))
@ -1839,26 +1845,26 @@
(define ___lexerp #f) (define ___lexerp #f)
(define ___errorp #f) (define ___errorp #f)
(define ___stack #f) (define ___stack #f)
(define ___sp 0) (define ___sp 0)
(define ___curr-input #f) (define ___curr-input #f)
(define ___reuse-input #f) (define ___reuse-input #f)
(define ___input #f) (define ___input #f)
(define (___consume) (define (___consume)
(set! ___input (if ___reuse-input ___curr-input (___lexerp))) (set! ___input (if ___reuse-input ___curr-input (___lexerp)))
(set! ___reuse-input #f) (set! ___reuse-input #f)
(set! ___curr-input ___input)) (set! ___curr-input ___input))
(define (___pushback) (define (___pushback)
(set! ___reuse-input #t)) (set! ___reuse-input #t))
(define (___initstack) (define (___initstack)
(set! ___stack (make-vector *max-stack-size* 0)) (set! ___stack (make-vector *max-stack-size* 0))
(set! ___sp 0)) (set! ___sp 0))
(define (___growstack) (define (___growstack)
(let ((new-stack (make-vector (* 2 (vector-length ___stack)) 0))) (let ((new-stack (make-vector (* 2 (vector-length ___stack)) 0)))
(let loop ((i (- (vector-length ___stack) 1))) (let loop ((i (- (vector-length ___stack) 1)))
@ -1867,11 +1873,11 @@
(vector-set! new-stack i (vector-ref ___stack i)) (vector-set! new-stack i (vector-ref ___stack i))
(loop (- i 1))))) (loop (- i 1)))))
(set! ___stack new-stack))) (set! ___stack new-stack)))
(define (___checkstack) (define (___checkstack)
(if (>= ___sp (vector-length ___stack)) (if (>= ___sp (vector-length ___stack))
(___growstack))) (___growstack)))
(define (___push delta new-category lvalue tok) (define (___push delta new-category lvalue tok)
(set! ___sp (- ___sp (* delta 2))) (set! ___sp (- ___sp (* delta 2)))
(let* ((state (vector-ref ___stack ___sp)) (let* ((state (vector-ref ___stack ___sp))
@ -1880,20 +1886,20 @@
(___checkstack) (___checkstack)
(vector-set! ___stack ___sp new-state) (vector-set! ___stack ___sp new-state)
(vector-set! ___stack (- ___sp 1) (note-source-location lvalue tok)))) (vector-set! ___stack (- ___sp 1) (note-source-location lvalue tok))))
(define (___reduce st) (define (___reduce st)
((vector-ref ___rtable st) ___stack ___sp ___gtable ___push ___pushback)) ((vector-ref ___rtable st) ___stack ___sp ___gtable ___push ___pushback))
(define (___shift token attribute) (define (___shift token attribute)
(set! ___sp (+ ___sp 2)) (set! ___sp (+ ___sp 2))
(___checkstack) (___checkstack)
(vector-set! ___stack (- ___sp 1) attribute) (vector-set! ___stack (- ___sp 1) attribute)
(vector-set! ___stack ___sp token)) (vector-set! ___stack ___sp token))
(define (___action x l) (define (___action x l)
(let ((y (assoc x l))) (let ((y (assoc x l)))
(if y (cadr y) (cadar l)))) (if y (cadr y) (cadar l))))
(define (___recover tok) (define (___recover tok)
(let find-state ((sp ___sp)) (let find-state ((sp ___sp))
(if (< sp 0) (if (< sp 0)
@ -1905,7 +1911,7 @@
(set! ___sp sp) (set! ___sp sp)
(___sync (cadr act) tok)) (___sync (cadr act) tok))
(find-state (- sp 2))))))) (find-state (- sp 2)))))))
(define (___sync state tok) (define (___sync state tok)
(let ((sync-set (map car (cdr (vector-ref ___atable state))))) (let ((sync-set (map car (cdr (vector-ref ___atable state)))))
(set! ___sp (+ ___sp 4)) (set! ___sp (+ ___sp 4))
@ -1923,7 +1929,7 @@
(begin (begin
(___consume) (___consume)
(skip)))))))) (skip))))))))
(define (___category tok) (define (___category tok)
(if (lexical-token? tok) (if (lexical-token? tok)
(lexical-token-category tok) (lexical-token-category tok)
@ -1935,15 +1941,15 @@
(let* ((state (vector-ref ___stack ___sp)) (let* ((state (vector-ref ___stack ___sp))
(i (___category ___input)) (i (___category ___input))
(act (___action i (vector-ref ___atable state)))) (act (___action i (vector-ref ___atable state))))
(cond ((not (symbol? i)) (cond ((not (symbol? i))
(___errorp "Syntax error: invalid token: " ___input) (___errorp "Syntax error: invalid token: " ___input)
#f) #f)
;; Input succesfully parsed ;; Input succesfully parsed
((eq? act 'accept) ((eq? act 'accept)
(vector-ref ___stack 1)) (vector-ref ___stack 1))
;; Syntax error in input ;; Syntax error in input
((eq? act '*error*) ((eq? act '*error*)
(if (eq? i '*eoi*) (if (eq? i '*eoi*)
@ -1959,18 +1965,18 @@
(set! ___sp 0) (set! ___sp 0)
(set! ___input '*eoi*))) (set! ___input '*eoi*)))
(loop)))) (loop))))
;; Shift current token on top of the stack ;; Shift current token on top of the stack
((>= act 0) ((>= act 0)
(___shift act ___input) (___shift act ___input)
(set! ___input (if (eq? i '*eoi*) '*eoi* #f)) (set! ___input (if (eq? i '*eoi*) '*eoi* #f))
(loop)) (loop))
;; Reduce by rule (- act) ;; Reduce by rule (- act)
(else (else
(___reduce (- act)) (___reduce (- act))
(loop)))) (loop))))
;; no lookahead, so check if there is a default action ;; no lookahead, so check if there is a default action
;; that does not require the lookahead ;; that does not require the lookahead
(let* ((state (vector-ref ___stack ___sp)) (let* ((state (vector-ref ___stack ___sp))
@ -1980,7 +1986,7 @@
(___reduce (- defact)) (___reduce (- defact))
(___consume)) (___consume))
(loop))))) (loop)))))
(lambda (lexerp errorp) (lambda (lexerp errorp)
(set! ___errorp errorp) (set! ___errorp errorp)
@ -2001,16 +2007,16 @@
(define ___lexerp #f) (define ___lexerp #f)
(define ___errorp #f) (define ___errorp #f)
;; -- Input handling ;; -- Input handling
(define *input* #f) (define *input* #f)
(define (initialize-lexer lexer) (define (initialize-lexer lexer)
(set! ___lexerp lexer) (set! ___lexerp lexer)
(set! *input* #f)) (set! *input* #f))
(define (consume) (define (consume)
(set! *input* (___lexerp))) (set! *input* (___lexerp)))
(define (token-category tok) (define (token-category tok)
(if (lexical-token? tok) (if (lexical-token? tok)
(lexical-token-category tok) (lexical-token-category tok)
@ -2022,21 +2028,21 @@
tok)) tok))
;; -- Processes (stacks) handling ;; -- Processes (stacks) handling
(define *processes* '()) (define *processes* '())
(define (initialize-processes) (define (initialize-processes)
(set! *processes* '())) (set! *processes* '()))
(define (add-process process) (define (add-process process)
(set! *processes* (cons process *processes*))) (set! *processes* (cons process *processes*)))
(define (get-processes) (define (get-processes)
(reverse *processes*)) (reverse *processes*))
(define (for-all-processes proc) (define (for-all-processes proc)
(let ((processes (get-processes))) (let ((processes (get-processes)))
(initialize-processes) (initialize-processes)
(for-each proc processes))) (for-each proc processes)))
;; -- parses ;; -- parses
(define *parses* '()) (define *parses* '())
(define (get-parses) (define (get-parses)
@ -2045,26 +2051,26 @@
(set! *parses* '())) (set! *parses* '()))
(define (add-parse parse) (define (add-parse parse)
(set! *parses* (cons parse *parses*))) (set! *parses* (cons parse *parses*)))
(define (push delta new-category lvalue stack tok) (define (push delta new-category lvalue stack tok)
(let* ((stack (drop stack (* delta 2))) (let* ((stack (drop stack (* delta 2)))
(state (car stack)) (state (car stack))
(new-state (cdr (assv new-category (vector-ref ___gtable state))))) (new-state (cdr (assv new-category (vector-ref ___gtable state)))))
(cons new-state (cons (note-source-location lvalue tok) stack)))) (cons new-state (cons (note-source-location lvalue tok) stack))))
(define (reduce state stack) (define (reduce state stack)
((vector-ref ___rtable state) stack ___gtable push)) ((vector-ref ___rtable state) stack ___gtable push))
(define (shift state symbol stack) (define (shift state symbol stack)
(cons state (cons symbol stack))) (cons state (cons symbol stack)))
(define (get-actions token action-list) (define (get-actions token action-list)
(let ((pair (assoc token action-list))) (let ((pair (assoc token action-list)))
(if pair (if pair
(cdr pair) (cdr pair)
(cdar action-list)))) ;; get the default action (cdar action-list)))) ;; get the default action
(define (run) (define (run)
(let loop-tokens () (let loop-tokens ()
@ -2099,7 +2105,7 @@
(if (pair? (get-processes)) (if (pair? (get-processes))
(loop-tokens)))) (loop-tokens))))
(lambda (lexerp errorp) (lambda (lexerp errorp)
(set! ___errorp errorp) (set! ___errorp errorp)
(initialize-lexer lexerp) (initialize-lexer lexerp)

41
module/mes/getopt-long.scm
View file

@ -1,24 +1,25 @@
;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc. ;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;;
;;; Copyright © 1998, 2001, 2006 Free Software Foundation, Inc.
;;; 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/>.
;;;
;;; Taken from GNU Guile-1.8
;;; ;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
;;; (regexps removed by Jan (janneke) Nieuwenhuizen)
;;; (srfi-9 backport by Jan (janneke) Nieuwenhuizen)
;;; Commentary: ;;; Commentary:
;;; This module implements some complex command line option parsing, in ;;; This module implements some complex command line option parsing, in

43
module/mes/optargs.scm
View file

@ -1,24 +1,25 @@
;;;; optargs.scm -- support for optional arguments ;;; GNU Mes --- Maxwell Equations of Software
;;;; ;;;
;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006 Free Software Foundation, Inc. ;;; Copyright © 1997, 1998, 1999, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
;;;; ;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;; This library is free software; you can redistribute it and/or ;;;
;;;; modify it under the terms of the GNU Lesser General Public ;;; This file is part of GNU Mes.
;;;; License as published by the Free Software Foundation; either ;;;
;;;; version 3 of the License, or (at your option) any later version. ;;; 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
;;;; This library is distributed in the hope that it will be useful, ;;; the Free Software Foundation; either version 3 of the License, or (at
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; your option) any later version.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;
;;;; Lesser General Public License for more details. ;;; GNU Mes is distributed in the hope that it will be useful, but
;;;; ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; You should have received a copy of the GNU Lesser General Public ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; License along with this library; if not, write to the Free Software ;;; GNU General Public License for more details.
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;
;;;; ;;; You should have received a copy of the GNU General Public License
;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu> ;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;;
;;; Taken from GNU Guile-1.8
;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>
;;; Commentary: ;;; Commentary: