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

Add mes and mescc-tools-extra

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

191
sysa/mes-0.22/module/mescc.scm Normal file
View file

@ -0,0 +1,191 @@
;;; 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/>.
(define-module (mescc)
#:use-module (srfi srfi-1)
#:use-module (ice-9 getopt-long)
#:use-module (mes guile)
#:use-module (mes misc)
#:use-module (mescc mescc)
#:export (mescc:main))
(cond-expand
(mes
(define (set-port-encoding! port encoding) #t)
(mes-use-module (mes guile))
(mes-use-module (mes misc))
(mes-use-module (mes getopt-long))
(mes-use-module (mes display))
(mes-use-module (mescc mescc))
)
(guile
(define-macro (mes-use-module . rest) #t)))
(define %host-arch (or (getenv "%arch") %arch))
(define %host-kernel (or (getenv "%kernel") "linux")) ;; FIXME
(define %prefix (or (getenv "%prefix") "mes"))
(define %includedir (or (getenv "%includedir") "include"))
(define %libdir (or (getenv "%libdir") "."))
(define %version (or (getenv "%version") "0.0"))
(define %numbered-arch? (and=> (getenv "%numbered_arch") (lambda (x) (equal? x "true"))))
(when (and=> (getenv "V") (lambda (v) (and (= (string-length v) 1) (> (string->number v) 1))))
(format (current-error-port) "mescc[~a]...\n" %scheme))
(define (unclump-single o)
(cond ((string-prefix? "--" o) (list o))
((and (string-prefix? "-" o)
(> (string-length o) 2)
(not (eq? (string-ref o 2) #\space)))
(list (substring o 0 2)
(substring o 2)))
(else (list o))))
(define (parse-opts args)
(let* ((option-spec
'((align)
(arch (value #t))
(assemble (single-char #\c))
(base-address (value #t))
(compile (single-char #\S))
(define (single-char #\D) (value #t))
(debug-info (single-char #\g))
(dumpmachine)
(fno-builtin)
(fno-stack-protector)
(help (single-char #\h))
(include (single-char #\I) (value #t))
(library-dir (single-char #\L) (value #t))
(library (single-char #\l) (value #t))
(machine (single-char #\m) (value #t))
(nodefaultlibs)
(nostartfiles)
(nostdinc)
(nostdlib)
(numbered-arch?)
(preprocess (single-char #\E))
(static)
(std (value #t))
(output (single-char #\o) (value #t))
(optimize (single-char #\O) (value #t))
(version (single-char #\V))
(verbose (single-char #\v))
(write (single-char #\w) (value #t))
(language (single-char #\x) (value #t))))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(files (option-ref options '() '()))
(dumpmachine? (option-ref options 'dumpmachine #f))
(version? (option-ref options 'version #f))
(usage? (and (not dumpmachine?) (not help?) (not version?) (null? files))))
(cond (version? (format #t "mescc (GNU Mes) ~a\n" %version) (exit 0))
(else
(and (or help? usage?)
(format (or (and usage? (current-error-port)) (current-output-port)) "\
Usage: mescc [OPTION]... FILE...
C99 compiler in Scheme for bootstrapping the GNU system.
Options:
--align align globals
--arch=ARCH compile for ARCH [~a]
--kernel=ARCH compile for KERNEL [~a]
-dumpmachine display the compiler's target machine
--base-address=ADRRESS
use BaseAddress ADDRESS [0x1000000]
--numbered-arch mescc-tools use numbered arch
-D DEFINE[=VALUE] define DEFINE [VALUE=1]
-E preprocess only; do not compile, assemble or link
-g add debug info [GDB, objdump] TODO: hex2 footer
-h, --help display this help and exit
-I DIR append DIR to include path
-L DIR append DIR to library path
-l LIBNAME link with LIBNAME
-m BITS compile for BITS bits [32]
-nodefaultlibs do not use libc.o when linking
-nostartfiles do not use crt1.o when linking
-nostdlib do not use crt1.o or libc.o when linking
-o FILE write output to FILE
-O LEVEL use optimizing LEVEL
-S preprocess and compile only; do not assemble or link
--std=STANDARD assume that the input sources are for STANDARD
-V,--version display version and exit
-w,--write=TYPE dump Nyacc AST using TYPE {pretty-print,write}
-x LANGUAGE specify LANGUAGE of the following input files
Ignored for GCC compatibility
-fno-builtin
-fno-stack-protector
-no-pie
-nostdinc
-static
Environment variables:
MES=BINARY run on mes-executable BINARY {mes,guile}
MES_DEBUG=LEVEL show debug output with verbosity LEVEL {0..5}
NYACC_TRACE=1 show Nyacc progress
Report bugs to: bug-mes@gnu.org
GNU Mes home page: <http://gnu.org/software/mes/>
General help using GNU software: <http://gnu.org/gethelp/>
" %host-arch %host-kernel)
(exit (or (and usage? 2) 0)))
options))))
(define (mescc:main args)
(let* ((single-dash-options '("-dumpmachine"
"-fno-builtin"
"-fno-stack-protector"
"-no-pie"
"-nodefaultlibs"
"-nostartfiles"
"-nostdinc"
"-nostdlib"
"-static"
"-std"))
(args (map (lambda (o)
(if (member o single-dash-options) (string-append "-" o)
o))
args))
(args (append-map unclump-single args))
(options (parse-opts args))
(options (acons 'prefix %prefix options))
(options (acons 'includedir %includedir options))
(options (acons 'libdir %libdir options))
(arch (option-ref options 'arch %host-arch))
(options (if arch (acons 'arch arch options) options))
(kernel (option-ref options 'kernel %host-kernel))
(options (acons 'kernel kernel options))
(numbered-arch? (option-ref options 'numbered-arch? %numbered-arch?))
(options (acons 'numbered-arch? numbered-arch? options))
(dumpmachine? (option-ref options 'dumpmachine #f))
(preprocess? (option-ref options 'preprocess #f))
(compile? (option-ref options 'compile #f))
(assemble? (option-ref options 'assemble #f))
(verbose? (count-opt options 'verbose)))
(when verbose?
(setenv "NYACC_TRACE" "yes")
(when (> verbose? 1)
(format (current-error-port) "options=~s\n" options)))
(cond (dumpmachine? (display (mescc:get-host options)))
(preprocess? (mescc:preprocess options))
(compile? (mescc:compile options))
(assemble? (mescc:assemble options))
(else (mescc:link options)))))
(define main mescc:main)

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

@ -0,0 +1,256 @@
;;; 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:
;;; M1.scm produces stage0' M1 assembly format
;;; Code:
(define-module (mescc M1)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (system base pmatch)
#:use-module (mes misc)
#:use-module (mes guile)
#:use-module (mescc as)
#:use-module (mescc info)
#:export (info->M1
infos->M1
M1:merge-infos))
(define* (infos->M1 file-name infos #:key align? verbose?)
(let ((info (fold M1:merge-infos (make <info>) infos)))
(info->M1 file-name info #:align? align? #:verbose? verbose?)))
(define (M1:merge-infos o info)
(clone info
#:functions (alist-add (.functions info) (.functions o))
#:globals (alist-add (.globals info) (.globals o))
#:types (.types o)))
(define (alist-add a b)
(let* ((b-keys (map car b))
(a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
(a-keys (map car a)))
(append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
(define (hex2:address o)
(string-append "&" o))
(define (hex2:address8 o)
(string-append "&" o " %0")) ;; FIXME: 64bit
(define (hex2:offset o)
(string-append "%" o))
(define (hex2:offset1 o)
(string-append "!" o))
(define hex? #t)
(define (hex2:immediate o)
(if hex? (string-append "%0x" (dec->hex o))
(string-append "%" (number->string o))))
(define (hex2:immediate1 o)
(if hex? (string-append "!0x" (dec->hex o))
(string-append "!" (number->string o))))
(define (hex2:immediate2 o)
(if hex? (string-append "@0x" (dec->hex o))
(string-append "@" (number->string o))))
(define (hex2:immediate4 o)
(if hex? (string-append "%0x" (dec->hex o))
(string-append "%" (number->string o))))
(define mesc? (string=? %compiler "mesc"))
(define (hex2:immediate8 o)
;; FIXME: #x100000000 => 0 divide-by-zero when compiled with 64 bit mesc
(if hex? (string-append "%0x" (dec->hex (if mesc? 0 (modulo o #x100000000)))
" %0x" (if (< o 0) "-1"
(dec->hex (if mesc? o (quotient o #x100000000)))))
(string-append "%" (number->string (dec->hex (if mesc? 0 (modulo o #x100000000))))
" %" (if (< o 0) "-1"
(number->string (dec->hex (if mesc? o (quotient o #x100000000))))))))
(define* (display-join o #:optional (sep ""))
(let loop ((o o))
(when (pair? o)
(display (car o))
(if (pair? (cdr o))
(display sep))
(loop (cdr o)))))
(define (global-string? o)
(and (pair? o) (pair? (car o)) (eq? (caar o) #:string)))
(define (global-extern? o)
(and=> (global:storage o) (cut eq? <> 'extern)))
(define* (info->M1 file-name o #:key align? verbose?)
(let* ((functions (.functions o))
(function-names (map car functions))
(globals (.globals o))
(globals (filter (negate (compose global-extern? cdr)) globals))
(strings (filter global-string? globals))
(strings (map car strings))
(reg-size (type:size (assoc-ref (.types o) "*"))))
(define (string->label o)
(let ((index (list-index (lambda (s) (equal? s o)) strings)))
(if index
(string-append "_string_" file-name "_" (number->string index))
(if (equal? o "%0") o ; FIXME: 64b
(error "no such string:" o)))))
(define (text->M1 o)
;;
(cond
((char? o) (text->M1 (char->integer o)))
((string? o) o)
((symbol? o) (symbol->string o))
((number? o) (let ((o (if (< o #x80) o (- o #x100))))
(if hex? (string-append "!0x"
(if (and (>= o 0) (< o 16)) "0" "")
(number->string o 16))
(string-append "!" (number->string o)))))
((and (pair? o) (keyword? (car o)))
(pmatch o
;; FIXME
((#:address (#:string ,string))
(hex2:address (string->label `(#:string ,string))))
((#:address (#:address ,address)) (guard (string? address))
(hex2:address address))
((#:address (#:address ,global)) (guard (global? global))
(hex2:address (global->string global)))
((#:address ,function) (guard (function? function))
(hex2:address (function->string function)))
((#:address ,number) (guard (number? number))
(string-join (map text->M1 (int->bv32 number))))
((#:address8 (#:string ,string))
(hex2:address8 (string->label `(#:string ,string))))
((#:address8 (#:address ,address)) (guard (string? address))
(hex2:address8 address))
((#:address8 (#:address ,global)) (guard (global? global))
(hex2:address8 (global->string global)))
((#:address8 ,function) (guard (function? function))
(hex2:address8 (function->string function)))
((#:address8 ,number) (guard (number? number))
(string-join (map text->M1 (int->bv64 number))))
((#:string ,string)
(hex2:address (string->label o)))
((#:address ,address) (guard (string? address))
(hex2:address address))
((#:address ,global) (guard (global? global))
(hex2:address (global->string global)))
((#:address8 ,address) (guard (string? address))
(hex2:address8 address))
((#:address8 ,global) (guard (global? global))
(hex2:address8 (global->string global)))
((#:offset ,offset) (hex2:offset offset))
((#:offset1 ,offset1) (hex2:offset1 offset1))
((#:immediate ,immediate) (hex2:immediate immediate))
((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
((#:immediate2 ,immediate2) (hex2:immediate2 immediate2))
((#:immediate4 ,immediate4) (hex2:immediate4 immediate4))
((#:immediate8 ,immediate8) (hex2:immediate8 immediate8))
(_ (error "text->M1 no match o" o))))
((pair? o) (string-join (map text->M1 o)))
(#t (error "no such text:" o))))
(define (write-function o)
(let ((name (car o))
(text (function:text (cdr o))))
(define (line->M1 o)
(cond ((eq? (car o) #:label)
(display (string-append ":" (cadr o))))
((eq? (car o) #:comment)
(display "\t\t\t\t\t# ")
(display (text->M1 (cadr o))))
((or (string? (car o)) (symbol? (car o)))
(display "\t" )
(display-join (map text->M1 o) " "))
(else (error "line->M1 invalid line:" o)))
(newline))
(when verbose?
(display (string-append " :" name "\n") (current-error-port)))
(display (string-append "\n\n:" name "\n"))
(for-each line->M1 (apply append text))))
(define (write-global o)
(define (labelize o)
(if (not (string? o)) o
(let* ((label o)
(function? (member label function-names))
(string-label (string->label label))
(string? (not (equal? string-label "_string_#f"))))
(cond ((and (pair? o) (global? (cdr o))) (string-append "&" (global->string o)))
((and (not string?) (not function?)) (stderr "warning: unresolved label: ~s\n" label))
((equal? string-label "%0") o) ;; FIXME: 64b
(else (string-append "&" label))))))
(define (display-align size)
(let ((alignment (- reg-size (modulo size reg-size))))
(when (and align? (> reg-size alignment 0))
(display " ")
(display-join (map text->M1 (map (const 0) (iota alignment))) " "))
#t))
(let* ((label (cond
((and (pair? (car o)) (eq? (caar o) #:string))
(string->label (car o)))
((global? (cdr o)) (global->string (cdr o)))
(else (car o))))
(string? (string-prefix? "_string" label))
(foo (when (and verbose? (not (eq? (car (string->list label)) #\_)))
(display (string-append " :" label "\n") (current-error-port))))
(data ((compose global:value cdr) o))
(data (filter-map labelize data))
(len (length data))
(string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 256))
(string-data (and string? (list-head data (1- (length data))))))
(display (string-append "\n:" label "\n"))
(if (and string-data
(< len string-max)
(char? (car data))
(eq? (last data) #\nul)
(not (find (cut memq <> '(#\")) string-data))
(not (any (lambda (ch)
(or (and (not (memq ch '(#\tab #\newline)))
(< (char->integer ch) #x20))
(>= (char->integer ch) #x80))) string-data)))
(let ((text string-data))
(display (string-append "\"" (list->string string-data) "\""))
(display-align (1+ (length string-data))))
(let ((text (map text->M1 data)))
(display-join text " ")
(display-align (length text))))
(newline)))
(when verbose?
(display "M1: functions\n" (current-error-port)))
(for-each write-function (filter cdr functions))
(when (assoc-ref functions "main")
(display "\n\n:ELF_data\n") ;; FIXME
(display "\n\n:HEX2_data\n"))
(when verbose?
(display "M1: globals\n" (current-error-port)))
(for-each write-global (filter global-string? globals))
(for-each write-global (filter (negate global-string?) globals))))

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

@ -0,0 +1,77 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (mescc as)
#:use-module (srfi srfi-1)
#:use-module (mes guile)
#:use-module (mescc bytevectors)
#:use-module (mescc info)
#:export (as
dec->hex
int->bv8
int->bv16
int->bv32
int->bv64
get-r
get-r0
get-r1
get-r-1))
(define (int->bv64 value)
(let ((bv (make-bytevector 8)))
(bytevector-u64-native-set! bv 0 value)
bv))
(define (int->bv32 value)
(let ((bv (make-bytevector 4)))
(bytevector-u32-native-set! bv 0 value)
bv))
(define (int->bv16 value)
(let ((bv (make-bytevector 2)))
(bytevector-u16-native-set! bv 0 value)
bv))
(define (int->bv8 value)
(let ((bv (make-bytevector 1)))
(bytevector-u8-set! bv 0 value)
bv))
(define (dec->hex o)
(cond ((number? o) (number->string o 16))
((char? o) (number->string (char->integer o) 16))
(else (format #f "~s" o))))
(define (as info instruction . rest)
(if (pair? instruction)
(append-map (lambda (o) (apply as (cons* info o rest))) instruction)
(let ((proc (assoc-ref (.instructions info) instruction)))
(if (not proc) (error "no such instruction" instruction)
(apply proc info rest)))))
(define (get-r info)
(car (if (pair? (.allocated info)) (.allocated info) (.registers info))))
(define (get-r0 info)
(cadr (.allocated info)))
(define (get-r1 info)
(car (.allocated info)))
(define (get-r-1 info)
(caddr (.allocated info)))

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

@ -0,0 +1,74 @@
;;; 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 (mescc bytevectors)
#:use-module (mes guile)
#:export (bytevector-u64-native-set!
bytevector-u32-native-set!
bytevector-u16-native-set!
bytevector-u8-set!
make-bytevector))
;; rnrs compatibility
(define (bytevector-u64-native-set! bv index value)
(when (not (= 0 index)) (error "bytevector-u64-native-set! index not zero: " index " value: " value))
(let ((x (list
(modulo value #x100)
(modulo (ash value -8) #x100)
(modulo (ash value -16) #x100)
(modulo (ash value -24) #x100)
(modulo (ash value -32) #x100)
(modulo (ash value -40) #x100)
(modulo (ash value -48) #x100)
(modulo (ash value -56) #x100))))
(set-car! bv (car x))
(set-cdr! bv (cdr x))
x))
(define (bytevector-u32-native-set! bv index value)
(when (not (= 0 index)) (error "bytevector-u32-native-set! index not zero: " index " value: " value))
(let ((x (list
(modulo value #x100)
(modulo (ash value -8) #x100)
(modulo (ash value -16) #x100)
(modulo (ash value -24) #x100))))
(set-car! bv (car x))
(set-cdr! bv (cdr x))
x))
(define (bytevector-u16-native-set! bv index value)
(when (not (= 0 index)) (error "bytevector-u16-native-set! index not zero: " index " value: " value))
(let ((x (list
(modulo value #x100)
(modulo (ash value -8) #x100))))
(set-car! bv (car x))
(set-cdr! bv (cdr x))
x))
(define (bytevector-u8-set! bv index value)
(when (not (= 0 index)) (error "bytevector-u8-set! index not zero: " index " value: " value))
(let ((x (modulo value #x100)))
(set-car! bv x)
x))
(define (make-bytevector length)
(make-list length 0))

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

File diff suppressed because it is too large Load diff

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

@ -0,0 +1,648 @@
;;; 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:
;;; define i386 assembly
;;; Code:
(define-module (mescc i386 as)
#:use-module (mes guile)
#:use-module (mescc as)
#:use-module (mescc info)
#:export (
i386:instructions
))
(define (e->x o)
(string-drop o 1))
(define (e->l o)
(string-append (string-drop-right (string-drop o 1) 1) "l"))
(define (i386:function-preamble . rest)
'(("push___%ebp")
("mov____%esp,%ebp")))
(define (i386:function-locals . rest)
`(("sub____$i32,%esp" (#:immediate ,(+ (* 4 1025) (* 20 4)))))) ; 4*1024 buf, 20 local vars
(define (i386:r->local info n)
(or n (error "invalid value: i386:r->local: " n))
(let ((r (get-r info))
(n (- 0 (* 4 n))))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" r ",0x8(%ebp)") (#:immediate1 ,n))
`(,(string-append "mov____%" r ",0x32(%ebp)") (#:immediate ,n))))))
(define (i386:value->r info v)
(let ((r (get-r info)))
`((,(string-append "mov____$i32,%" r) (#:immediate ,v)))))
(define (i386:ret . rest)
'(("leave")
("ret")))
(define (i386:r-zero? info)
(let ((r (get-r info)))
`((,(string-append "test___%" r "," "%" r)))))
(define (i386:local->r info n)
(let ((r (get-r info))
(n (- 0 (* 4 n))))
`(,(if (< (abs n) #x80) `(,(string-append "mov____0x8(%ebp),%" r) (#:immediate1 ,n))
`(,(string-append "mov____0x32(%ebp),%" r) (#:immediate ,n))))))
(define (i386:r0+r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "add____%" r1 ",%" r0)))))
(define (i386:call-label info label n)
`((call32 (#:offset ,label))
("add____$i8,%esp" (#:immediate1 ,(* n 4)))))
(define (i386:r->arg info i)
(let ((r (get-r info)))
`((,(string-append "push___%" r)))))
(define (i386:label->arg info label i)
`(("push___$i32" (#:address ,label))))
(define (i386:r-negate info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "sete___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:r0-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "sub____%" r1 ",%" r0)))))
(define (i386:zf->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "sete___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:xor-zf info)
'(("lahf")
("xor____$i8,%ah" (#:immediate1 #x40))
("sahf")))
(define (i386:r->local+n info id n)
(let ((n (+ (- 0 (* 4 id)) n))
(r (get-r info)))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" r ",0x8(%ebp)") (#:immediate1 ,n))
`(,(string-append "mov____%" r ",0x32(%ebp)") (#:immediate ,n))))))
(define (i386:r-mem-add info v)
(let ((r (get-r info)))
`(,(if (< (abs v) #x80) `(,(string-append "add____$i8,(%" r ")") (#:immediate1 ,v))
`(,(string-append "add____$i32,(%" r ")") (#:immediate ,v))))))
(define (i386:r-byte-mem-add info v)
(let ((r (get-r info)))
`((,(string-append "addb___$i8,(%" r ")") (#:immediate1 ,v)))))
(define (i386:r-word-mem-add info v)
(let ((r (get-r info)))
`((,(string-append "addw___$i8,(%" r ")") (#:immediate2 ,v)))))
(define (i386:local-ptr->r info n)
(let ((r (get-r info)))
(let ((n (- 0 (* 4 n))))
`((,(string-append "mov____%ebp,%" r))
,(if (< (abs n) #x80) `(,(string-append "add____$i8,%" r) (#:immediate1 ,n))
`(,(string-append "add____$i32,%" r) (#:immediate ,n)))))))
(define (i386:label->r info label)
(let ((r (get-r info)))
`((,(string-append "mov____$i32,%" r) (#:address ,label)))))
(define (i386:r0->r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r0 ",%" r1)))))
(define (i386:byte-mem->r info)
(let ((r (get-r info)))
`((,(string-append "movzbl_(%" r "),%" r)))))
(define (i386:byte-r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "movzbl_%" l ",%" r)))))
(define (i386:byte-signed-r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "movsbl_%" l ",%" r)))))
(define (i386:word-r info)
(let* ((r (get-r info))
(x (e->x r)))
`((,(string-append "movzwl_%" x ",%" r)))))
(define (i386:word-signed-r info)
(let* ((r (get-r info))
(x (e->x r)))
`((,(string-append "movswl_%" x ",%" r)))))
(define (i386:jump info label)
`(("jmp32 " (#:offset ,label))))
(define (i386:jump-z info label)
`(("je32 " (#:offset ,label))))
(define (i386:jump-nz info label)
`(("jne32 " (#:offset ,label))))
(define (i386:jump-byte-z info label)
`(("test___%al,%al")
("je32 " (#:offset ,label))))
;; signed
(define (i386:jump-g info label)
`(("jg32 " (#:offset ,label))))
(define (i386:jump-ge info label)
`(("jge32 " (#:offset ,label))))
(define (i386:jump-l info label)
`(("jl32 " (#:offset ,label))))
(define (i386:jump-le info label)
`(("jle32 " (#:offset ,label))))
;; unsigned
(define (i386:jump-a info label)
`(("ja32 " (#:offset ,label))))
(define (i386:jump-ae info label)
`(("jae32 " (#:offset ,label))))
(define (i386:jump-b info label)
`(("jb32 " (#:offset ,label))))
(define (i386:jump-be info label)
`(("jbe32 " (#:offset ,label))))
(define (i386:byte-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(l0 (e->l r0)))
`((,(string-append "mov____%" l0 ",(%" r1 ")")))))
(define (i386:label-mem->r info label)
(let ((r (get-r info)))
`((,(string-append "mov____0x32,%" r) (#:address ,label)))))
(define (i386:word-mem->r info)
(let ((r (get-r info)))
`((,(string-append "movzwl_(%" r "),%" r)))))
(define (i386:mem->r info)
(let ((r (get-r info)))
`((,(string-append "mov____(%" r "),%" r)))))
(define (i386:local-add info n v)
(let ((n (- 0 (* 4 n))))
`(,(if (and (< (abs n) #x80)
(< (abs v) #x80)) `("add____$i8,0x8(%ebp)" (#:immediate1 ,n) (#:immediate1 ,v))
`("add____$i32,0x32(%ebp)" (#:immediate ,n) (#:immediate ,v))))))
(define (i386:label-mem-add info label v)
`(,(if (< (abs v) #x80) `("add____$i8,0x32" (#:address ,label) (#:immediate1 ,v))
`("add____$i32,0x32" (#:address ,label) (#:immediate ,v)))))
(define (i386:nop info)
'(("nop")))
(define (i386:swap-r0-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "xchg___%" r0 ",%" r1)))))
;; signed
(define (i386:g?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setg___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:ge?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setge__%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:l?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setl___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:le?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setle__%" l))
(,(string-append "movzbl_%" l ",%" r)))))
;; unsigned
(define (i386:a?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "seta___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:ae?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setae__%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:b?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setb___%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:be?->r info)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "setbe__%" l))
(,(string-append "movzbl_%" l ",%" r)))))
(define (i386:test-r info)
(let ((r (get-r info)))
`((,(string-append "test___%" r ",%" r)))))
(define (i386:r->label info label)
(let ((r (get-r info)))
`((,(string-append "mov____%" r ",0x32") (#:address ,label)))))
(define (i386:r->byte-label info label)
(let* ((r (get-r info))
(l (e->l r)))
`((,(string-append "movb___%" l ",0x32") (#:address ,label)))))
(define (i386:r->word-label info label)
(let* ((r (get-r info))
(x (e->x r)))
`((,(string-append "movw___%" x ",0x32") (#:address ,label)))))
(define (i386:call-r info n)
(let ((r (get-r info)))
`((,(string-append "call___*%" r))
("add____$i8,%esp" (#:immediate1 ,(* n 4))))))
(define (i386:r0*r1 info)
(let ((allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "edx" allocated))
`(,@(if (equal? r0 "eax") '()
`(("push___%eax")
(,(string-append "mov____%" r0 ",%eax"))))
(,(string-append "mul____%" r1))
,@(if (equal? r0 "eax") '()
`((,(string-append "mov____%eax,%" r0))
("pop____%eax"))))
`(("push___%eax")
("push___%ebx")
("push___%edx")
(,(string-append "mov____%" r1 ",%ebx"))
(,(string-append "mov____%" r0 ",%eax"))
(,(string-append "mul____%" r1))
("pop____%edx")
("pop____%ebx")
(,(string-append "mov____%eax,%" r0))
("pop____%eax")))))
(define (i386:r0<<r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%ecx"))
(,(string-append "shl____%cl,%" r0)))))
(define (i386:r0>>r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%ecx"))
(,(string-append "shr____%cl,%" r0)))))
(define (i386:r0-and-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "and____%" r1 ",%" r0)))))
(define (i386:r0/r1 info signed?)
(let ((signed? #f) ; nobody knows, -- all advice are belong to us?
(allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "edx" allocated))
`(,@(if (equal? r0 "eax") '()
`(("push___%eax")
(,(string-append "mov____%" r0 ",%eax"))))
,(if signed? '("cltd") '("xor____%edx,%edx"))
,(if signed? `(,(string-append "idiv___%" r1)) `(,(string-append "div___%" r1)))
,@(if (equal? r0 "eax") '()
`((,(string-append "mov____%eax,%" r0))
("pop____%eax"))))
`(("push___%eax")
("push___%ebx")
("push___%edx")
(,(string-append "mov____%" r1 ",%ebx"))
(,(string-append "mov____%" r0 ",%eax"))
,(if signed? '("cltd") '("xor____%edx,%edx"))
,(if signed? `(,(string-append "idiv___%ebx")) `(,(string-append "div___%ebx")))
("pop____%edx")
("pop____%ebx")
(,(string-append "mov____%eax,%" r0))
("pop____%eax")))))
(define (i386:r0%r1 info signed?)
(let ((signed? #f) ; nobody knows, -- all advice are belong to us?
(allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "edx" allocated))
`(,@(if (equal? r0 "eax") '()
`(("push___%eax")
(,(string-append "mov____%" r0 ",%eax"))))
,(if signed? '("cltd") '("xor____%edx,%edx"))
,(if signed? `(,(string-append "idiv___%" r1)) `(,(string-append "div___%" r1)))
(,(string-append "mov____%edx,%" r0)))
`(("push___%eax")
("push___%ebx")
("push___%edx")
(,(string-append "mov____%" r1 ",%ebx"))
(,(string-append "mov____%" r0 ",%eax"))
,(if signed? '("cltd") '("xor____%edx,%edx"))
,(if signed? `(,(string-append "idiv___%ebx")) `(,(string-append "div___%ebx")))
("pop____%edx")
("pop____%ebx")
(,(string-append "mov____%edx,%" r0))
("pop____%eax")))))
(define (i386:r+value info v)
(let ((r (get-r info)))
`(,(if (< (abs v) #x80) `(,(string-append "add____$i8,%" r) (#:immediate1 ,v))
`(,(string-append "add____$i32,%" r) (#:immediate ,v))))))
(define (i386:r0->r1-mem info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r0 ",(%" r1 ")")))))
(define (i386:byte-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(l0 (e->l r0)))
`((,(string-append "mov____%" l0 ",(%" r1 ")")))))
(define (i386:word-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(x0 (e->x r0)))
`((,(string-append "mov____%" x0 ",(%" r1 ")")))))
(define (i386:r-cmp-value info v)
(let ((r (get-r info)))
`(,(if (< (abs v) #x80) `(,(string-append "cmp____$i8,%" r) (#:immediate1 ,v))
`(,(string-append "cmp____$i32,%" r) (#:immediate ,v))))))
(define (i386:push-register info r)
`((,(string-append "push___%" r))))
(define (i386:pop-register info r)
`((,(string-append "pop____%" r))))
(define (i386:return->r info)
(let ((r (get-r info)))
(if (equal? r "eax") '()
`((,(string-append "mov____%eax,%" r))))))
(define (i386:r0-or-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "or_____%" r1 ",%" r0)))))
(define (i386:shl-r info n)
(let ((r (get-r info)))
`((,(string-append "shl____$i8,%" r) (#:immediate1 ,n)))))
(define (i386:r+r info)
(let ((r (get-r info)))
`((,(string-append "add____%" r ",%" r)))))
(define (i386:not-r info)
(let ((r (get-r info)))
`((,(string-append "not____%" r)))))
(define (i386:r0-xor-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "xor____%" r1 ",%" r0)))))
(define (i386:r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers)))
`((,(string-append "mov____(%" r0 "),%" r2))
(,(string-append "mov____%" r2 ",(%" r1 ")")))))
(define (i386:byte-r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers))
(l2 (e->l r2)))
`((,(string-append "mov____(%" r0 "),%" l2))
(,(string-append "mov____%" l2 ",(%" r1 ")")))))
(define (i386:word-r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers))
(x2 (e->x r2)))
`((,(string-append "mov____(%" r0 "),%" x2))
(,(string-append "mov____%" x2 ",(%" r1 ")")))))
(define (i386:r0+value info v)
(let ((r0 (get-r0 info)))
`(,(if (< (abs v) #x80) `(,(string-append "add____$i8,%" r0) (#:immediate1 ,v))
`(,(string-append "add____$i32,%" r0) (#:immediate ,v))))))
(define (i386:value->r0 info v)
(let ((r0 (get-r0 info)))
`((,(string-append "mov____$i32,%" r0) (#:immediate ,v)))))
(define (i386:byte-r->local+n info id n)
(let* ((n (+ (- 0 (* 4 id)) n))
(r (get-r info))
(l (e->l r) ))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" l ",0x8(%ebp)") (#:immediate1 ,n))
`(,(string-append "mov____%" l ",0x32(%ebp)") (#:immediate ,n))))))
(define (i386:word-r->local+n info id n)
(let* ((n (+ (- 0 (* 4 id)) n))
(r (get-r info))
(x (e->x r)))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" x ",0x8(%ebp)") (#:immediate1 ,n))
`(,(string-append "mov____%" x ",0x32(%ebp)") (#:immediate ,n))))))
(define (i386:r-and info v)
(let ((r (get-r info)))
`((,(string-append "and____$i32,%" r) (#:immediate ,v)))))
(define (i386:push-r0 info)
(let ((r0 (get-r0 info)))
`((,(string-append "push___%" r0)))))
(define (i386:r1->r0 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%" r0)))))
(define (i386:pop-r0 info)
(let ((r0 (get-r0 info)))
`((,(string-append "pop____%" r0)))))
(define (i386:swap-r-stack info)
(let ((r (get-r info)))
`((,(string-append "xchg___%" r ",(%esp)")))))
(define (i386:swap-r1-stack info)
(let ((r0 (get-r0 info)))
`((,(string-append "xchg___%" r0 ",(%esp)")))))
(define (i386:r2->r0 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info))
(allocated (.allocated info)))
(if (> (length allocated) 2)
(let ((r2 (cadddr allocated)))
`((,(string-append "mov____%" r2 ",%" r1))))
`((,(string-append "pop____%" r0))
(,(string-append "push___%" r0))))))
(define i386:instructions
`(
(a?->r . ,i386:a?->r)
(ae?->r . ,i386:ae?->r)
(b?->r . ,i386:b?->r)
(be?->r . ,i386:be?->r)
(byte-mem->r . ,i386:byte-mem->r)
(byte-r . ,i386:byte-r)
(byte-r->local+n . ,i386:byte-r->local+n)
(byte-r0->r1-mem . ,i386:byte-r0->r1-mem)
(byte-r0->r1-mem . ,i386:byte-r0->r1-mem)
(byte-r0-mem->r1-mem . ,i386:byte-r0-mem->r1-mem)
(byte-signed-r . ,i386:byte-signed-r)
(call-label . ,i386:call-label)
(call-r . ,i386:call-r)
(function-locals . ,i386:function-locals)
(function-preamble . ,i386:function-preamble)
(g?->r . ,i386:g?->r)
(ge?->r . ,i386:ge?->r)
(jump . ,i386:jump)
(jump-a . ,i386:jump-a)
(jump-ae . ,i386:jump-ae)
(jump-b . ,i386:jump-b)
(jump-be . ,i386:jump-be)
(jump-byte-z . ,i386:jump-byte-z)
(jump-g . , i386:jump-g)
(jump-ge . , i386:jump-ge)
(jump-l . ,i386:jump-l)
(jump-le . ,i386:jump-le)
(jump-nz . ,i386:jump-nz)
(jump-z . ,i386:jump-z)
(l?->r . ,i386:l?->r)
(label->arg . ,i386:label->arg)
(label->r . ,i386:label->r)
(label-mem->r . ,i386:label-mem->r)
(label-mem-add . ,i386:label-mem-add)
(le?->r . ,i386:le?->r)
(local->r . ,i386:local->r)
(local-add . ,i386:local-add)
(local-ptr->r . ,i386:local-ptr->r)
(long-r0->r1-mem . ,i386:r0->r1-mem)
(long-r0-mem->r1-mem . ,i386:r0-mem->r1-mem)
(mem->r . ,i386:mem->r)
(nop . ,i386:nop)
(not-r . ,i386:not-r)
(pop-r0 . ,i386:pop-r0)
(pop-register . ,i386:pop-register)
(push-r0 . ,i386:push-r0)
(push-register . ,i386:push-register)
(r+r . ,i386:r+r)
(r+value . ,i386:r+value)
(r->arg . ,i386:r->arg)
(r->byte-label . ,i386:r->byte-label)
(r->label . ,i386:r->label)
(r->local . ,i386:r->local)
(r->local+n . ,i386:r->local+n)
(r->word-label . ,i386:r->word-label)
(r-and . ,i386:r-and)
(r-byte-mem-add . ,i386:r-byte-mem-add)
(r-cmp-value . ,i386:r-cmp-value)
(r-mem-add . ,i386:r-mem-add)
(r-negate . ,i386:r-negate)
(r-word-mem-add . ,i386:r-word-mem-add)
(r-zero? . ,i386:r-zero?)
(r0%r1 . ,i386:r0%r1)
(r0*r1 . ,i386:r0*r1)
(r0+r1 . ,i386:r0+r1)
(r0+value . ,i386:r0+value)
(r0->r1 . ,i386:r0->r1)
(r0->r1-mem . ,i386:r0->r1-mem)
(r0-and-r1 . ,i386:r0-and-r1)
(r0-mem->r1-mem . ,i386:r0-mem->r1-mem)
(r0-or-r1 . ,i386:r0-or-r1)
(r0-r1 . ,i386:r0-r1)
(r0-xor-r1 . ,i386:r0-xor-r1)
(r0/r1 . ,i386:r0/r1)
(r0<<r1 . ,i386:r0<<r1)
(r0>>r1 . ,i386:r0>>r1)
(r1->r0 . ,i386:r1->r0)
(r2->r0 . ,i386:r2->r0)
(ret . ,i386:ret)
(return->r . ,i386:return->r)
(shl-r . ,i386:shl-r)
(swap-r-stack . ,i386:swap-r-stack)
(swap-r0-r1 . ,i386:swap-r0-r1)
(swap-r1-stack . ,i386:swap-r1-stack)
(test-r . ,i386:test-r)
(value->r . ,i386:value->r)
(value->r0 . ,i386:value->r0)
(word-mem->r . ,i386:word-mem->r)
(word-r . ,i386:word-r)
(word-r->local+n . ,i386:word-r->local+n)
(word-r0->r1-mem . ,i386:word-r0->r1-mem)
(word-r0-mem->r1-mem . ,i386:word-r0-mem->r1-mem)
(word-signed-r . ,i386:word-signed-r)
(xor-zf . ,i386:xor-zf)
(zf->r . ,i386:zf->r)
))

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

@ -0,0 +1,61 @@
;;; 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:
;;; Initialize MesCC as i386/x86 compiler
;;; Code:
(define-module (mescc i386 info)
#:use-module (mescc info)
#:use-module (mescc i386 as)
#:export (x86-info))
(define (x86-info)
(make <info> #:types i386:type-alist #:registers i386:registers #:instructions i386:instructions))
(define i386:registers '("eax" "ebx" "ecx" "edx" "esi" "edi"))
(define i386:type-alist
`(("char" . ,(make-type 'signed 1 #f))
("short" . ,(make-type 'signed 2 #f))
("int" . ,(make-type 'signed 4 #f))
("long" . ,(make-type 'signed 4 #f))
("default" . ,(make-type 'signed 4 #f))
("*" . ,(make-type 'unsigned 4 #f))
("long long" . ,(make-type 'signed 4 #f))
("long long int" . ,(make-type 'signed 4 #f))
("void" . ,(make-type 'void 1 #f))
("unsigned char" . ,(make-type 'unsigned 1 #f))
("unsigned short" . ,(make-type 'unsigned 2 #f))
("unsigned" . ,(make-type 'unsigned 4 #f))
("unsigned int" . ,(make-type 'unsigned 4 #f))
("unsigned long" . ,(make-type 'unsigned 4 #f))
("unsigned long long" . ,(make-type 'unsigned 4 #f))
("unsigned long long int" . ,(make-type 'unsigned 4 #f))
("float" . ,(make-type 'float 4 #f))
("double" . ,(make-type 'float 4 #f))
("long double" . ,(make-type 'float 4 #f))
("short int" . ,(make-type 'signed 2 #f))
("unsigned short int" . ,(make-type 'unsigned 2 #f))
("long int" . ,(make-type 'signed 4 #f))
("unsigned long int" . ,(make-type 'unsigned 4 #f))))

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

@ -0,0 +1,305 @@
;;; 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:
;;; info.scm defines [Guile] record data types for MesCC
;;; Code:
(define-module (mescc info)
#:use-module (ice-9 optargs)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:export (<info>
make
clone
make-<info>
info?
.types
.constants
.functions
.globals
.locals
.function
.statics
.text
.post
.break
.continue
.allocated
.pushed
.registers
.instructions
<type>
make-type
type?
type:type
type:size
type:pointer
type:description
<c-array>
make-c-array
c-array?
c-array:type
c-array:count
<pointer>
make-pointer
pointer?
pointer:type
pointer:rank
<bit-field>
make-bit-field
bit-field?
bit-field:type
bit-field:bit
bit-field:bits
<var>
var:name
var:type
var:pointer
var:c-array
<global>
make-global
global?
global:name
global:type
global:pointer
global:c-array
global:var
global:value
global:storage
global:function
global->string
<local>
make-local
local?
local:type
local:pointer
local:c-array
local:var
local:id
<function>
make-function
function?
function:name
function:type
function:text
function->string
->type
->rank
rank--
rank++
rank+=
structured-type?))
(define-immutable-record-type <info>
(make-<info> types constants functions globals locals statics function text post break continue allocated pushed registers instructions)
info?
(types .types)
(constants .constants)
(functions .functions)
(globals .globals)
(locals .locals)
(statics .statics)
(function .function)
(text .text)
(post .post)
(break .break)
(continue .continue)
(allocated .allocated)
(pushed .pushed)
(registers .registers)
(instructions .instructions))
(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '()) (allocated '()) (pushed 0) (registers '()) (instructions '()))
(cond ((eq? o <info>)
(make-<info> types constants functions globals locals statics function text post break continue allocated pushed registers instructions))))
(define (clone o . rest)
(cond ((info? o)
(let ((types (.types o))
(constants (.constants o))
(functions (.functions o))
(globals (.globals o))
(locals (.locals o))
(statics (.statics o))
(function (.function o))
(text (.text o))
(post (.post o))
(break (.break o))
(continue (.continue o))
(allocated (.allocated o))
(pushed (.pushed o))
(registers (.registers o))
(instructions (.instructions o)))
(let-keywords rest
#f
((types types)
(constants constants)
(functions functions)
(globals globals)
(locals locals)
(statics statics)
(function function)
(text text)
(post post)
(break break)
(continue continue)
(allocated allocated)
(pushed pushed)
(registers registers)
(instructions instructions))
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:statics statics #:function function #:text text #:post post #:break break #:continue continue #:allocated allocated #:pushed pushed #:registers registers #:instructions instructions))))))
;; ("int" . ,(make-type 'builtin 4 #f 0 #f))
;; (make-type 'enum 4 0 fields)
;; (make-type 'struct (apply + (map field:size fields)) 0 fields)
(define-immutable-record-type <type>
(make-type type size description)
type?
(type type:type)
(size type:size)
(description type:description))
(define-immutable-record-type <c-array>
(make-c-array type count)
c-array?
(type c-array:type)
(count c-array:count))
(define-immutable-record-type <pointer>
(make-pointer type rank)
pointer?
(type pointer:type)
(rank pointer:rank))
(define-immutable-record-type <bit-field>
(make-bit-field type bit bits)
bit-field?
(type bit-field:type)
(bit bit-field:bit)
(bits bit-field:bits))
(define-immutable-record-type <var>
(make-var name type function id value)
var?
(name var:name)
(type var:type) ; <type>
(function var:function)
(id var:id)
(value var:value))
(define-immutable-record-type <global>
(make-global- name type var value storage function)
global?
(name global:name)
(type global:type)
(var global:var) ; <var>
(value global:value)
(storage global:storage)
(function global:function))
(define (make-global name type value storage function)
(make-global- name type (make-var name type function #f value) value storage function))
(define (global->string o)
(or (and=> (global:function o) (cut string-append <> "-" (global:name o)))
(global:name o)))
(define-immutable-record-type <local>
(make-local- type var id)
local?
(type local:type)
(var local:var) ; <var>
(id local:id))
(define (make-local name type id)
(make-local- type (make-var name type #f id #f) id))
(define-immutable-record-type <function>
(make-function name type text)
function?
(name function:name)
(type function:type)
(text function:text))
(define (function->string o)
(function:name o))
(define (structured-type? o)
(cond ((type? o) (memq (type:type o) '(struct union)))
((global? o) ((compose structured-type? global:type) o))
((local? o) ((compose structured-type? local:type) o))
((and (pair? o) (eq? (car o) 'tag))) ;; FIXME: enum?
(else #f)))
(define (->type o)
(cond ((type? o) o)
((bit-field? o) o)
((pointer? o) ((compose ->type pointer:type) o))
((c-array? o) ((compose ->type c-array:type) o))
((and (pair? o) (eq? (car o) 'tag)) o)
;; FIXME
(#t
(format (current-error-port) "->type--: not a <type>: ~s\n" o)
(make-type 'builtin 4 #f))
(else (error "->type: not a <type>:" o))))
(define (->rank o)
(cond ((type? o) 0)
((pointer? o) (pointer:rank o))
((c-array? o) (1+ ((compose ->rank c-array:type) o)))
((local? o) ((compose ->rank local:type) o))
((global? o) ((compose ->rank global:type) o))
((bit-field? o) 0)
;; FIXME
(#t
(format (current-error-port) "->rank: not a type: ~s\n" o)
0)
(else (error "->rank: not a <type>:" o))))
(define (rank-- o)
(cond ((and (pointer? o) (= (pointer:rank o) 1)) (pointer:type o))
((pointer? o) (set-field o (pointer:rank) (1- (pointer:rank o))))
((c-array? o) (c-array:type o))
;; FIXME
(#t (format (current-error-port) "rank--: not a pointer: ~s\n" o)
o)
(else (error "rank--: not a pointer" o))))
(define (rank+= o i)
(cond ((pointer? o) (set-field o (pointer:rank) (+ i (pointer:rank o))))
(else (make-pointer o i))))
(define (rank++ o)
(rank+= o 1))

368
sysa/mes-0.22/module/mescc/mescc.scm Normal file
View file

@ -0,0 +1,368 @@
;;; 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/>.
(define-module (mescc mescc)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 getopt-long)
#:use-module (mes misc)
#:use-module (mescc i386 info)
#:use-module (mescc x86_64 info)
#:use-module (mescc preprocess)
#:use-module (mescc compile)
#:use-module (mescc M1)
#:export (count-opt
mescc:preprocess
mescc:get-host
mescc:compile
mescc:assemble
mescc:link
multi-opt))
(define GUILE-with-output-to-file with-output-to-file)
(define (with-output-to-file file-name thunk)
(if (equal? file-name "-") (thunk)
(GUILE-with-output-to-file file-name thunk)))
(define (mescc:preprocess options)
(let* ((pretty-print/write (string->symbol (option-ref options 'write (if guile? "pretty-print" "write"))))
(pretty-print/write (if (eq? pretty-print/write 'pretty-print) pretty-print write))
(files (option-ref options '() '("a.c")))
(input-file-name (car files))
(input-base (basename input-file-name))
(ast-file-name (cond ((and (option-ref options 'preprocess #f)
(option-ref options 'output #f)))
(else (replace-suffix input-base ".E"))))
(dir (dirname input-file-name))
(defines (reverse (filter-map (multi-opt 'define) options)))
(includes (reverse (filter-map (multi-opt 'include) options)))
(includes (cons (option-ref options 'includedir #f) includes))
(includes (cons dir includes))
(prefix (option-ref options 'prefix ""))
(machine (option-ref options 'machine "32"))
(arch (arch-get options))
(defines (cons (arch-get-define options) defines))
(verbose? (count-opt options 'verbose)))
(with-output-to-file ast-file-name
(lambda _ (for-each (cut c->ast prefix defines includes arch pretty-print/write verbose? <>) files)))))
(define (c->ast prefix defines includes arch write verbose? file-name)
(with-input-from-file file-name
(cut write (c99-input->ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?))))
(define (mescc:compile options)
(let* ((files (option-ref options '() '("a.c")))
(input-file-name (car files))
(input-base (basename input-file-name))
(M1-file-name (cond ((and (option-ref options 'compile #f)
(option-ref options 'output #f)))
((string-suffix? ".S" input-file-name) input-file-name)
(else (replace-suffix input-base ".s"))))
(infos (map (cut file->info options <>) files))
(verbose? (count-opt options 'verbose))
(align? (option-ref options 'align #f)))
(when verbose?
(stderr "dumping: ~a\n" M1-file-name))
(with-output-to-file M1-file-name
(cut infos->M1 M1-file-name infos #:align? align? #:verbose? verbose?))
M1-file-name))
(define (file->info options file-name)
(cond ((.c? file-name) (c->info options file-name))
((.E? file-name) (E->info options file-name))))
(define (c->info options file-name)
(let* ((dir (dirname file-name))
(defines (reverse (filter-map (multi-opt 'define) options)))
(includes (reverse (filter-map (multi-opt 'include) options)))
(includes (cons (option-ref options 'includedir #f) includes))
(includes (cons dir includes))
(prefix (option-ref options 'prefix ""))
(defines (cons (arch-get-define options) defines))
(arch (arch-get options))
(verbose? (count-opt options 'verbose)))
(with-input-from-file file-name
(cut c99-input->info (arch-get-info options) #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?))))
(define (E->info options file-name)
(let ((ast (with-input-from-file file-name read))
(verbose? (count-opt options 'verbose)))
(c99-ast->info (arch-get-info options) ast #:verbose? verbose?)))
(define (mescc:assemble options)
(let* ((files (option-ref options '() '("a.c")))
(input-file-name (car files))
(input-base (basename input-file-name))
(hex2-file-name (cond ((and (option-ref options 'assemble #f)
(option-ref options 'output #f)))
(else (replace-suffix input-base ".o"))))
(s-files (filter .s? files))
(hex2-files M1->hex2 ) ;; FIXME
(source-files (filter (disjoin .c? .E?) files))
(infos (map (cut file->info options <>) source-files)))
(if (and (pair? s-files) (pair? infos))
(error "mixing source and object not supported:" source-files s-files))
(when (pair? s-files)
(M1->hex2 options s-files))
(when (pair? infos)
(infos->hex2 options hex2-file-name infos))
hex2-file-name))
(define (mescc:link options)
(let* ((files (option-ref options '() '("a.c")))
(source-files (filter (disjoin .c? .E?) files))
(s-files (filter .s? files))
(o-files (filter .o? files))
(input-file-name (car files))
(hex2-file-name (if (or (string-suffix? ".hex2" input-file-name)
(string-suffix? ".o" input-file-name)) input-file-name
(replace-suffix input-file-name ".o")))
(infos (map (cut file->info options <>) source-files))
(s-files (filter .s? files))
(hex2-files (filter .o? files))
(hex2-files (if (null? s-files) hex2-files
(append hex2-files (list (M1->hex2 options s-files)))))
(hex2-files (if (null? infos) hex2-files
(append hex2-files
(list (infos->hex2 options hex2-file-name infos)))))
(default-libraries (if (or (option-ref options 'nodefaultlibs #f)
(option-ref options 'nostdlib #f)) '()
'("c")))
(libraries (filter-map (multi-opt 'library) options))
(libraries (delete-duplicates (append libraries default-libraries)))
(hex2-libraries (map (cut find-library options ".a" <>) libraries))
(hex2-files (append hex2-files hex2-libraries))
(s-files (append s-files (map (cut find-library options ".s" <>) libraries)))
(debug-info? (option-ref options 'debug-info #f))
(s-files (if (string-suffix? ".S" input-file-name) s-files
(cons (replace-suffix input-file-name ".s") s-files)))
(elf-footer (and debug-info?
(or (M1->blood-elf options s-files)
(exit 1)))))
(or (hex2->elf options hex2-files #:elf-footer elf-footer)
(exit 1))))
(define (infos->hex2 options hex2-file-name infos)
(let* ((input-file-name (car (option-ref options '() '("a.c"))))
(M1-file-name (replace-suffix hex2-file-name ".s"))
(options (acons 'compile #t options)) ; ugh
(options (acons 'output hex2-file-name options))
(verbose? (count-opt options 'verbose))
(align? (option-ref options 'align #f)))
(when verbose?
(stderr "dumping: ~a\n" M1-file-name))
(with-output-to-file M1-file-name
(cut infos->M1 M1-file-name infos #:align? align?))
(or (M1->hex2 options (list M1-file-name))
(exit 1))))
(define (M1->hex2 options M1-files)
(let* ((input-file-name (car (option-ref options '() '("a.c"))))
(input-base (basename input-file-name))
(M1-file-name (car M1-files))
(hex2-file-name (cond ((and (option-ref options 'assemble #f)
(option-ref options 'output #f)))
((option-ref options 'assemble #f)
(replace-suffix input-base ".o"))
(else (replace-suffix M1-file-name ".o"))))
(verbose? (count-opt options 'verbose))
(M1 (or (getenv "M1") "M1"))
(command `(,M1
"--LittleEndian"
,@(arch-get-architecture options)
"-f" ,(arch-find options (arch-get-m1-macros options))
,@(append-map (cut list "-f" <>) M1-files)
"-o" ,hex2-file-name)))
(when (and verbose? (> verbose? 1))
(stderr "~a\n" (string-join command)))
(and (zero? (apply assert-system* command))
hex2-file-name)))
(define* (hex2->elf options hex2-files #:key elf-footer)
(let* ((input-file-name (car (option-ref options '() '("a.c"))))
(elf-file-name (cond ((option-ref options 'output #f))
(else "a.out")))
(verbose? (count-opt options 'verbose))
(hex2 (or (getenv "HEX2") "hex2"))
(base-address (option-ref options 'base-address "0x1000000"))
(machine (arch-get-machine options))
(elf-footer
(or elf-footer
(kernel-find
options
(string-append "elf" machine "-footer-single-main.hex2"))))
(start-files (if (or (option-ref options 'nostartfiles #f)
(option-ref options 'nostdlib #f)) '()
`("-f" ,(arch-find options "crt1.o"))))
(command `(,hex2
"--LittleEndian"
,@(arch-get-architecture options)
"--BaseAddress" ,base-address
"-f" ,(kernel-find
options
(string-append "elf" machine "-header.hex2"))
,@start-files
,@(append-map (cut list "-f" <>) hex2-files)
"-f" ,elf-footer
"--exec_enable"
"-o" ,elf-file-name)))
(when (and verbose? (> verbose? 1))
(stderr "~a\n" (string-join command)))
(and (zero? (apply assert-system* command))
elf-file-name)))
(define (M1->blood-elf options M1-files)
(let* ((M1-file-name (car M1-files))
(M1-blood-elf-footer (string-append M1-file-name ".blood-elf"))
(hex2-file-name (replace-suffix M1-file-name ".o"))
(blood-elf-footer (string-append hex2-file-name ".blood-elf"))
(verbose? (count-opt options 'verbose))
(blood-elf (or (getenv "BLOOD_ELF") "blood-elf"))
(command `(,blood-elf
"-f" ,(arch-find options (arch-get-m1-macros options))
,@(append-map (cut list "-f" <>) M1-files)
"-o" ,M1-blood-elf-footer)))
(when (and verbose? (> verbose? 1))
(format (current-error-port) "~a\n" (string-join command)))
(and (zero? (apply assert-system* command))
(let* ((options (acons 'compile #t options)) ; ugh
(options (acons 'output blood-elf-footer options)))
(M1->hex2 options (list M1-blood-elf-footer))))))
(define (replace-suffix file-name suffix)
(let* ((parts (string-split file-name #\.))
(base (if (pair? (cdr parts)) (drop-right parts 1)))
(old-suffix (last parts))
(program-prefix (cond ((string-prefix? "arm-mes-" old-suffix) ".arm-mes-")
((string-prefix? "x86-mes-" old-suffix) ".x86-mes-")
((string-prefix? "x86_64-mes-" old-suffix) ".x86_64-mes-")
(else "."))))
(if (string-null? suffix)
(if (string-null? program-prefix) (string-join base ".")
(string-append (string-drop program-prefix 1) (string-join base ".")))
(string-append (string-join base ".") program-prefix (string-drop suffix 1)))))
(define (find-library options ext o)
(arch-find options (string-append "lib" o ext)))
(define* (arch-find options file-name #:key kernel)
(let* ((srcdest (or (getenv "srcdest") ""))
(srcdir-lib (string-append srcdest "lib"))
(arch (string-append (arch-get options) "-mes"))
(path (cons* "."
srcdir-lib
(option-ref options 'libdir "lib")
(filter-map (multi-opt 'library-dir) options)))
(arch-file-name (string-append arch "/" file-name))
(arch-file-name (if kernel (string-append kernel "/" arch-file-name)
arch-file-name))
(verbose? (count-opt options 'verbose)))
(let ((file (search-path path arch-file-name)))
(when (and verbose? (> verbose? 1))
(stderr "arch-find=~s\n" arch-file-name)
(stderr " path=~s\n" path)
(stderr " => ~s\n" file))
(or file
(error (format #f "mescc: file not found: ~s" arch-file-name))))))
(define (kernel-find options file-name)
(let ((kernel (option-ref options 'kernel "linux")))
(or (arch-find options file-name #:kernel kernel)
(arch-find options file-name))))
(define (assert-system* . args)
(let ((status (apply system* args)))
(when (not (zero? status))
(stderr "mescc: failed: ~a\n" (string-join args))
(exit (status:exit-val status)))
status))
(define (arch-get options)
(let* ((machine (option-ref options 'machine #f))
(arch (option-ref options 'arch #f)))
(if machine (cond ((member arch '("x86" "x86_64")) (cond ((equal? machine "32") "x86")
((equal? machine "64") "x86_64")))
((equal? arch "arm") (cond ((equal? machine "32") "arm"))))
arch)))
(define (mescc:get-host options)
(let ((cpu (arch-get options))
(kernel (option-ref options 'kernel "linux")))
(string-join (list cpu kernel "mes") "-")))
(define (arch-get-info options)
(let ((arch (arch-get options)))
(cond ((equal? arch "arm") (armv4-info))
((equal? arch "x86") (x86-info))
((equal? arch "x86_64") (x86_64-info)))))
(define (arch-get-define options)
(let ((arch (arch-get options)))
(cond ((equal? arch "arm") "__arm__=1")
((equal? arch "x86") "__i386__=1")
((equal? arch "x86_64") "__x86_64__=1"))))
(define (arch-get-machine options)
(let* ((machine (option-ref options 'machine #f))
(arch (option-ref options 'arch #f)))
(or machine
(if (member arch '("x86_64")) "64"
"32"))))
(define (arch-get-m1-macros options)
(let ((arch (arch-get options)))
(cond ((equal? arch "arm") "arm.M1")
((equal? arch "x86") "x86.M1")
((equal? arch "x86_64") "x86_64.M1"))))
(define (arch-get-architecture options)
(let* ((arch (arch-get options))
(numbered-arch? (option-ref options 'numbered-arch? #f))
(flag (if numbered-arch? "--Architecture" "--architecture")))
(list flag
(cond ((equal? arch "arm") (if numbered-arch? "40" "armv7l"))
((equal? arch "x86") (if numbered-arch? "1" "x86"))
((equal? arch "x86_64") (if numbered-arch? "2" "amd64"))))))
(define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
(define (count-opt options option-name)
(let ((lst (filter-map (multi-opt option-name) options)))
(and (pair? lst) (length lst))))
(define (.c? o) (or (string-suffix? ".c" o)
(string-suffix? ".M2" o)))
(define (.E? o) (or (string-suffix? ".E" o)
(string-suffix? ".mes-E" o)
(string-suffix? ".arm-mes-E" o)
(string-suffix? ".x86-mes-E" o)
(string-suffix? ".x86_64-mes-E" o)))
(define (.s? o) (or (string-suffix? ".s" o)
(string-suffix? ".S" o)
(string-suffix? ".mes-S" o)
(string-suffix? ".arm-mes-S" o)
(string-suffix? ".x86-mes-S" o)
(string-suffix? ".x86_64-mes-S" o)
(string-suffix? ".M1" o)))
(define (.o? o) (or (string-suffix? ".o" o)
(string-suffix? ".mes-o" o)
(string-suffix? ".arm-mes-o" o)
(string-suffix? ".x86-mes-o" o)
(string-suffix? ".x86_64-mes-o" o)
(string-suffix? ".hex2" o)))

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

@ -0,0 +1,144 @@
;;; 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 (mescc preprocess)
#:use-module (ice-9 optargs)
#:use-module (system base pmatch)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (nyacc lang c99 parser)
#:use-module (nyacc lang c99 parser)
#:use-module (nyacc version)
#:use-module (mes guile)
#:export (c99-input->ast))
(define mes-or-reproducible? #t)
(when (getenv "MESC_DEBUG")
(format (current-error-port) "*nyacc-version*=~a\n" *nyacc-version*))
;; list of which rules you want progress reported
(define need-progress
(or (assoc-ref
'(("0.85.3" (1 2 3))
("0.86.0" (1 2 3)))
*nyacc-version*)
'((1 2 3))))
(define (progress o)
(when (and o (getenv "NYACC_DEBUG"))
(display " :" (current-error-port))
(display o (current-error-port))
(display "\n" (current-error-port))))
(define (insert-progress-monitors act-v len-v)
(let ((n (vector-length act-v)))
(let loop ((ix 0))
(when (< ix n)
(if (memq ix need-progress)
(vector-set!
act-v ix
(lambda args
(progress (list-ref args (1- (vector-ref len-v ix))))
(apply (vector-ref act-v ix) args))))
(loop (1+ ix))))))
(cond-expand
(guile
(insert-progress-monitors (@@ (nyacc lang c99 parser) c99-act-v)
(@@ (nyacc lang c99 parser) c99-len-v)))
(mes
(insert-progress-monitors c99-act-v c99-len-v)))
(define (logf port string . rest)
(apply format (cons* port string rest))
(force-output port)
#t)
(define (stderr string . rest)
(apply logf (cons* (current-error-port) string rest)))
(define mes? (pair? (current-module)))
(define* (c99-input->full-ast #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
(let* ((sys-include (if (equal? prefix "") "include"
(string-append prefix "/include")))
(kernel "linux")
(kernel-include (string-append sys-include "/" kernel "/" arch))
(includes (append
includes
(cons* kernel-include
sys-include
(append (or (and=> (getenv "CPATH")
(cut string-split <> #\:)) '())
(or (and=> (getenv "C_INCLUDE_PATH")
(cut string-split <> #\:)) '())))))
(defines `(
"NULL=0"
"__linux__=1"
"_POSIX_SOURCE=0"
"SYSTEM_LIBC=0"
"__STDC__=1"
"__MESC__=1"
,(if mes-or-reproducible? "__MESC_MES__=1" "__MESC_MES__=0")
,@defines)))
(when (and verbose? (> verbose? 1))
(stderr "includes: ~s\n" includes)
(stderr "defines: ~s\n" defines))
(parse-c99
#:inc-dirs includes
#:cpp-defs defines
#:mode 'code)))
(define* (c99-input->ast #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
(when verbose?
(stderr "parsing: input\n"))
((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?)))
(define (ast-strip-comment o)
(pmatch o
((@ (comment . ,comment)) #f) ; Nyacc 0.90.2/0.93.0?
((comment . ,comment) #f)
(((comment . ,comment) . ,t) (filter-map ast-strip-comment t))
(((comment . ,comment) . ,cdr) cdr)
((,car . (comment . ,comment)) car)
((,h . ,t) (if (list? o) (filter-map ast-strip-comment o)
(cons (ast-strip-comment h) (ast-strip-comment t))))
(_ o)))
(define (ast-strip-const o)
(pmatch o
((type-qual ,qual) (if (equal? qual "const") #f o))
((pointer (type-qual-list (type-qual ,qual)) . ,rest)
(if (equal? qual "const") `(pointer ,@rest) o))
((decl-spec-list (type-qual ,qual))
(if (equal? qual "const") #f
`(decl-spec-list (type-qual ,qual))))
((decl-spec-list (type-qual ,qual) . ,rest)
(if (equal? qual "const") `(decl-spec-list ,@rest)
`(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest))))
((decl-spec-list (type-qual-list (type-qual ,qual)) . ,rest)
(if (equal? qual "const") `(decl-spec-list ,@rest)
`(decl-spec-list (type-qual-list (type-qual ,qual)) ,@(map ast-strip-const rest))))
((,h . ,t) (if (list? o) (filter-map ast-strip-const o)
(cons (ast-strip-const h) (ast-strip-const t))))
(_ o)))

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

@ -0,0 +1,782 @@
;;; 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:
;;; Define x86_64 M1 assembly
;;; Code:
(define-module (mescc x86_64 as)
#:use-module (mes guile)
#:use-module (mescc as)
#:use-module (mescc info)
#:use-module (mescc x86_64 info)
#:export (
x86_64:instructions
))
(define (r->e o)
(string-append "e" (string-drop o 1)))
(define (r->x o)
(string-drop o 1))
(define (r->l o)
(assoc-ref
'(("rax" . "al")
("rdi" . "dil")
("rsi" . "sil")
("rdx" . "dl")
("rcx" . "cl")
("r8" . "r8b")
("r9" . "r9b"))
o))
;; AMD
(define (x86_64:function-preamble info . rest)
`(("push___%rbp")
("mov____%rsp,%rbp")
("sub____$i32,%rbp" "%0x80")
,@(list-head
'(("mov____%rdi,0x8(%rbp)" "!0x10")
("mov____%rsi,0x8(%rbp)" "!0x18")
("mov____%rdx,0x8(%rbp)" "!0x20")
("mov____%rcx,0x8(%rbp)" "!0x28")
("mov____%r8,0x8(%rbp)" "!0x30")
("mov____%r9,0x8(%rbp)" "!0x38"))
(length (car rest)))))
;; traditional
(define (x86_64:function-preamble info . rest)
`(("push___%rbp")
("mov____%rsp,%rbp")))
(define (x86_64:function-locals . rest)
`(
;; FIXME: how on x86_64?
("sub____$i32,%rsp" (#:immediate ,(+ (* 4 1025) (* 20 8))))
)) ; 4*1024 buf, 20 local vars
(define (x86_64:r->local info n)
(let ((r (get-r info))
(n (- 0 (* 8 n))))
`(,(if (< (abs n) #x80)
`(,(string-append "mov____%" r ",0x8(%rbp)") (#:immediate1 ,n))
`(,(string-append "mov____%" r ",0x32(%rbp)") (#:immediate ,n))))))
(define (x86_64:value->r info v)
(or v (error "invalid value: x86_64:value->r: " v))
(let ((r (get-r info)))
(if (and (>= v 0)
(< v #xffffffff))
`((,(string-append "mov____$i32,%" r) (#:immediate ,v)))
`((,(string-append "mov____$i64,%" r) (#:immediate8 ,v))))))
;; AMD
(define (x86_64:ret . rest)
'(("add____$i32,%rbp" "%0x80")
("mov____%rbp,%rsp")
("pop____%rbp")
("ret")))
;; traditional
(define (x86_64:ret . rest)
'(("mov____%rbp,%rsp")
("pop____%rbp")
("ret")))
(define (x86_64:r-zero? info)
(let ((r (car (if (pair? (.allocated info)) (.allocated info) (.registers info)))))
`((,(string-append "test___%" r "," "%" r)))))
(define (x86_64:local->r info n)
(let ((r (car (if (pair? (.allocated info)) (.allocated info) (.registers info))))
(n (- 0 (* 8 n))))
`(,(if (< (abs n) #x80) `(,(string-append "mov____0x8(%rbp),%" r) (#:immediate1 ,n))
`(,(string-append "mov____0x32(%rbp),%" r) (#:immediate ,n))))))
(define (x86_64:call-label info label n)
`((call32 (#:offset ,label))
("add____$i8,%rsp" (#:immediate1 ,(* n 8))) ;; NOT AMD
))
(define x86_64:calling-convention-registers '("rax" "rdi" "rsi" "rdx" "rcx" "r8" "r9"))
;; AMD
(define (x86_64:r->arg info i)
(let ((r (get-r info))
(r1 (list-ref x86_64:calling-convention-registers (1+ i))))
`((,(string-append "mov____%" r ",%" r1))))) ; debug fail-safe check
(define (x86_64:label->arg info label i)
(let ((r0 (list-ref x86_64:registers (1+ i))))
(if (< label #x80000000)
`((,(string-append "mov____$i32,%" r0) (#:address ,label)))
`((,(string-append "mov____$i64,%" r0) (#:address8 ,label))))))
;; traditional
(define (x86_64:r->arg info i)
(let ((r (get-r info)))
`((,(string-append "push___%" r)))))
(define (x86_64:label->arg info label i)
`(("push___$i32" (#:address ,label))))
;; FIXME?
;; (define (x86_64:label->arg info label i)
;; `((,(string-append "mov____$i64,%r15") (#:address8 ,label))
;; ("push___%r15" (#:address ,label))))
(define (x86_64:r0+r1 info)
(let ((r1 (get-r1 info))
(r0 (get-r0 info)))
`((,(string-append "add____%" r1 ",%" r0)))))
(define (x86_64:r-negate info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "sete___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:r0-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "sub____%" r1 ",%" r0)))))
(define (x86_64:zf->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "sete___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:xor-zf info)
'(("lahf")
("xor____$i8,%ah" (#:immediate1 #x40))
("sahf")))
(define (x86_64:r->local+n info id n)
(let ((n (+ (- 0 (* 8 id)) n))
(r (get-r info)))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" r ",0x8(%rbp)") (#:immediate1 ,n))
`(,(string-append "mov____%" r ",0x32(%rbp)") (#:immediate ,n))))))
(define (x86_64:r-mem-add info v)
(let ((r (get-r info)))
`(,(if (< (abs v) #x80) `(,(string-append "add____$i8,(%" r ")") (#:immediate1 ,v))
`(,(string-append "add____$i32,(%" r ")") (#:immediate ,v)))))) ;; FIXME 64bit
(define (x86_64:r-byte-mem-add info v)
(let ((r (get-r info)))
`((,(string-append "addb___$i8,(%" r ")") (#:immediate1 ,v)))))
(define (x86_64:r-word-mem-add info v)
(let ((r (get-r info)))
`((,(string-append "addw___$i8,(%" r ")") (#:immediate2 ,v)))))
(define (x86_64:local-ptr->r info n)
(let ((r (get-r info)))
(let ((n (- 0 (* 8 n))))
`((,(string-append "mov____%rbp,%" r))
,(if (< (abs n) #x80) `(,(string-append "add____$i8,%" r) (#:immediate1 ,n))
`(,(string-append "add____$i32,%" r) (#:immediate ,n))))))) ;; FIXME 64bit
(define (x86_64:label->r info label)
(let ((r (get-r info)))
`((,(string-append "mov____$i64,%" r) (#:address8 ,label)))))
(define (x86_64:r0->r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r0 ",%" r1)))))
(define (x86_64:byte-mem->r info)
(let ((r (get-r info)))
`((,(string-append "movzbq_(%" r "),%" r)))))
(define (x86_64:byte-r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:byte-signed-r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "movsbq_%" l ",%" r)))))
(define (x86_64:word-r info)
(let* ((r (get-r info))
(x (r->x r)))
`((,(string-append "movzwq_%" x ",%" r)))))
(define (x86_64:word-signed-r info)
(let* ((r (get-r info))
(x (r->x r)))
`((,(string-append "movswq_%" x ",%" r)))))
(define (x86_64:long-r info)
(let* ((r (get-r info))
(e (r->e r)))
`((,(string-append "movzlq_%" e ",%" r)))))
(define (x86_64:long-signed-r info)
(let* ((r (get-r info))
(e (r->e r)))
`((,(string-append "movslq_%" e ",%" r)))))
(define (x86_64:jump info label)
`(("jmp32 " (#:offset ,label))))
(define (x86_64:jump-nz info label)
`(("jne32 " (#:offset ,label))))
(define (x86_64:jump-z info label)
`(("je32 " (#:offset ,label))))
(define (x86_64:jump-byte-z info label)
`(("test___%al,%al")
("je32 " (#:offset ,label))))
;; signed
(define (x86_64:jump-g info label)
`(("jg32 " (#:offset ,label))))
(define (x86_64:jump-ge info label)
`(("jge32 " (#:offset ,label))))
(define (x86_64:jump-l info label)
`(("jl32 " (#:offset ,label))))
(define (x86_64:jump-le info label)
`(("jle32 " (#:offset ,label))))
;; unsigned
(define (x86_64:jump-a info label)
`(("ja32 " (#:offset ,label))))
(define (x86_64:jump-ae info label)
`(("jae32 " (#:offset ,label))))
(define (x86_64:jump-b info label)
`(("jb32 " (#:offset ,label))))
(define (x86_64:jump-be info label)
`(("jbe32 " (#:offset ,label))))
(define (x86_64:byte-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(l0 (r->l r0)))
`((,(string-append "mov____%" l0 ",(%" r1 ")")))))
(define (x86_64:label-mem->r info label)
(let ((r (get-r info)))
`((,(string-append "mov____0x32,%" r) (#:address ,label)))))
(define (x86_64:word-mem->r info)
(let ((r (get-r info)))
`((,(string-append "movzwq_(%" r "),%" r)))))
(define (x86_64:long-mem->r info)
(let ((r (get-r info)))
`((,(string-append "movzlq_(%" r "),%" r)))))
(define (x86_64:mem->r info)
(let ((r (get-r info)))
`((,(string-append "mov____(%" r "),%" r)))))
(define (x86_64:local-add info n v)
(let ((n (- 0 (* 8 n))))
`(,(if (and (< (abs n) #x80)
(< (abs v) #x80)) `("add____$i8,0x8(%rbp)" (#:immediate1 ,n) (#:immediate1 ,v))
`("add____$i32,0x32(%rbp)" (#:immediate ,n) (#:immediate ,v)))))) ;; FIXME: 64b
(define (x86_64:label-mem-add info label v)
`(,(if (< (abs v) #x80) `("add____$i8,0x32" (#:address ,label) (#:immediate1 ,v))
`("add____$i32,0x32" (#:address ,label) (#:immediate ,v))))) ;; FIXME: 64b
(define (x86_64:nop info)
'(("nop")))
(define (x86_64:swap-r0-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "xchg___%" r0 ",%" r1)))))
;; signed
(define (x86_64:g?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setg___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:ge?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setge__%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:l?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setl___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:le?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setle__%" l))
(,(string-append "movzbq_%" l ",%" r)))))
;; unsigned
(define (x86_64:a?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "seta___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:ae?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setae__%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:b?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setb___%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:be?->r info)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "setbe__%" l))
(,(string-append "movzbq_%" l ",%" r)))))
(define (x86_64:test-r info)
(let ((r (get-r info)))
`((,(string-append "test___%" r ",%" r)))))
(define (x86_64:r->label info label)
(let ((r (get-r info)))
`((,(string-append "mov____%" r ",0x32") (#:address ,label))))) ;; FIXME: 64 bits
(define (x86_64:r->byte-label info label)
(let* ((r (get-r info))
(l (r->l r)))
`((,(string-append "movb___%" l ",0x32") (#:address ,label)))))
(define (x86_64:r->word-label info label)
(let* ((r (get-r info))
(x (r->x r)))
`((,(string-append "movw___%" x ",0x32") (#:address ,label)))))
(define (x86_64:r->long-label info label)
(let* ((r (get-r info))
(e (r->e r)))
`((,(string-append "movl___%" e ",0x32") (#:address ,label)))))
(define (x86_64:call-r info n)
(let ((r (get-r info)))
`((,(string-append "call___*%" r))
("add____$i8,%rsp" (#:immediate1 ,(* n 8)))))) ;; NOT AMD
(define (x86_64:r0*r1 info)
(let ((allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "rdx" allocated))
`(,@(if (equal? r0 "rax") '()
`(("push___%rax"
,(string-append "mov____%" r0 ",%rax"))))
(,(string-append "mul____%" r1))
,@(if (equal? r0 "rax") '()
`((,(string-append "mov____%rax,%" r0)
"pop____%rax"))))
`(("push___%rax")
("push___%rdi")
("push___%rdx")
(,(string-append "mov____%" r1 ",%rdi"))
(,(string-append "mov____%" r0 ",%rax"))
(,(string-append "mul____%" r1))
("pop____%rdx")
("pop____%rdi")
(,(string-append "mov____%rax,%" r0))
("pop____%rax")))))
(define (x86_64:r0<<r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%rcx"))
(,(string-append "shl____%cl,%" r0)))))
(define (x86_64:r0>>r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%rcx"))
(,(string-append "shr____%cl,%" r0)))))
(define (x86_64:r0-and-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "and____%" r1 ",%" r0)))))
(define (x86_64:r0/r1 info signed?)
(let ((signed? #f) ; nobody knows, -- all advice are belong to us?
(allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "rdx" allocated))
`(,@(if (equal? r0 "rax") '()
`(("push___%rax")
(,(string-append "mov____%" r0 ",%rax"))))
,(if signed? '("cqto") '("xor____%rdx,%rdx"))
,(if signed? `(,(string-append "idiv___%" r1)) `(,(string-append "div___%" r1)))
,@(if (equal? r0 "rax") '()
`((,(string-append "mov____%rax,%" r0))
("pop____%rax"))))
`(("push___%rax")
("push___%rdi")
("push___%rdx")
(,(string-append "mov____%" r1 ",%rdi"))
(,(string-append "mov____%" r0 ",%rax"))
,(if signed? '("cqto") '("xor____%rdx,%rdx"))
,(if signed? `(,(string-append "idiv___%rdi")) `(,(string-append "div___%rdi")))
("pop____%rdx")
("pop____%rdi")
(,(string-append "mov____%rax,%" r0))
("pop____%rax")))))
(define (x86_64:r0%r1 info signed?)
(let ((signed? #f) ; nobody knows, -- all advice are belong to us?
(allocated (.allocated info))
(r0 (get-r0 info))
(r1 (get-r1 info)))
(if (not (member "rdx" allocated))
`(,@(if (equal? r0 "rax") '()
`(("push___%rax")
(,(string-append "mov____%" r0 ",%rax"))))
,(if signed? '("cqto") '("xor____%rdx,%rdx"))
,(if signed? `(,(string-append "idiv___%" r1)) `(,(string-append "div___%" r1)))
(,(string-append "mov____%rdx,%" r0)))
`(("push___%rax")
("push___%rdi")
("push___%rdx")
(,(string-append "mov____%" r1 ",%rdi"))
(,(string-append "mov____%" r0 ",%rax"))
,(if signed? '("cqto") '("xor____%rdx,%rdx"))
,(if signed? `(,(string-append "idiv___%rdi")) `(,(string-append "div___%rdi")))
("pop____%rdx")
("pop____%rdi")
(,(string-append "mov____%rdx,%" r0))
("pop____%rax")))))
(define (x86_64:r+value info v)
(let ((r (get-r info)))
(cond ((< (abs v) #x80)
`((,(string-append "add____$i8,%" r) (#:immediate1 ,v))))
((< (abs v) #x80000000)
`((,(string-append "add____$i32,%" r) (#:immediate ,v))))
(else
`((,(string-append "mov____$i64,%r15") (#:immediate8 ,v))
(,(string-append "add____%r15,%" r)))))))
(define (x86_64:r0->r1-mem info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r0 ",(%" r1 ")")))))
(define (x86_64:byte-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(l0 (r->l r0)))
`((,(string-append "mov____%" l0 ",(%" r1 ")")))))
(define (x86_64:word-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(x0 (r->x r0)))
`((,(string-append "mov____%" x0 ",(%" r1 ")")))))
(define (x86_64:long-r0->r1-mem info)
(let* ((r0 (get-r0 info))
(r1 (get-r1 info))
(e0 (r->e r0)))
`((,(string-append "mov____%" e0 ",(%" r1 ")")))))
(define (x86_64:r-cmp-value info v)
(let ((r (get-r info)))
(cond ((< (abs v) #x80)
`((,(string-append "cmp____$i8,%" r) (#:immediate1 ,v))))
((and (>= v 0)
(< v #xffffffff))
`((,(string-append "cmp____$i32,%" r) (#:immediate ,v))))
(else
`(,(string-append "mov____$i64,%r15") (#:immediate8 ,v)
,(string-append "cmp____%r15,%" r))))))
(define (x86_64:push-register info r)
`((,(string-append "push___%" r))))
(define (x86_64:pop-register info r)
`((,(string-append "pop____%" r))))
(define (x86_64:return->r info)
(let ((r (car (.allocated info))))
(if (equal? r "rax") '()
`((,(string-append "mov____%rax,%" r))))))
(define (x86_64:r0-or-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "or_____%" r1 ",%" r0)))))
(define (x86_64:shl-r info n)
(let ((r (get-r info)))
`((,(string-append "shl____$i8,%" r) (#:immediate1 ,n)))))
(define (x86_64:r+r info)
(let ((r (get-r info)))
`((,(string-append "add____%" r ",%" r)))))
(define (x86_64:not-r info)
(let ((r (get-r info)))
`((,(string-append "not____%" r)))))
(define (x86_64:r0-xor-r1 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "xor____%" r1 ",%" r0)))))
(define (x86_64:r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers)))
`((,(string-append "mov____(%" r0 "),%" r2))
(,(string-append "mov____%" r2 ",(%" r1 ")")))))
(define (x86_64:byte-r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers))
(l2 (r->l r2)))
`((,(string-append "mov____(%" r0 "),%" l2))
(,(string-append "mov____%" l2 ",(%" r1 ")")))))
(define (x86_64:word-r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers))
(x2 (r->x r2)))
`((,(string-append "mov____(%" r0 "),%" x2))
(,(string-append "mov____%" x2 ",(%" r1 ")")))))
(define (x86_64:long-r0-mem->r1-mem info)
(let* ((registers (.registers info))
(r0 (get-r0 info))
(r1 (get-r1 info))
(r2 (car registers))
(e2 (r->e r2)))
`((,(string-append "mov____(%" r0 "),%" e2))
(,(string-append "mov____%" e2 ",(%" r1 ")")))))
(define (x86_64:r0+value info v)
(let ((r0 (get-r0 info)))
`(,(if (< (abs v) #x80) `(,(string-append "add____$i8,%" r0) (#:immediate1 ,v))
`(,(string-append "add____$i32,%" r0) (#:immediate ,v)))))) ; FIXME: 64bit
(define (x86_64:value->r0 info v)
(let ((r0 (get-r0 info)))
`((,(string-append "mov____$i32,%" r0) (#:immediate ,v)))))
(define (x86_64:r-long-mem-add info v)
(let ((r (get-r info)))
(cond ((< (abs v) #x80)
`((,(string-append "addl___$i8,(%" r ")") (#:immediate1 ,v))))
((and (>= v 0)
(< v #xffffffff))
`((,(string-append "addl___$i32,(%" r ")") (#:immediate ,v))))
(else
`((,(string-append "mov____$i64,%r15") (#:immediate8 ,v))
(,(string-append "add____%r15,(%" r ")")))))))
(define (x86_64:byte-r->local+n info id n)
(let* ((n (+ (- 0 (* 8 id)) n))
(r (get-r info))
(l (r->l r) ))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" l ",0x8(%rbp)") (#:immediate1 ,n))
`(,(string-append "mov____%" l ",0x32(%rbp)") (#:immediate ,n))))))
(define (x86_64:word-r->local+n info id n)
(let* ((n (+ (- 0 (* 8 id)) n))
(r (get-r info))
(x (r->x r) ))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" x ",0x8(%rbp)") (#:immediate1 ,n))
`(,(string-append "mov____%" x ",0x32(%rbp)") (#:immediate ,n))))))
(define (x86_64:long-r->local+n info id n)
(let* ((n (+ (- 0 (* 8 id)) n))
(r (get-r info))
(e (r->e r)))
`(,(if (< (abs n) #x80) `(,(string-append "mov____%" e ",0x8(%rbp)") (#:immediate1 ,n))
`(,(string-append "mov____%" e ",0x32(%rbp)") (#:immediate ,n))))))
(define (x86_64:r-and info v)
(let ((r (get-r info)))
(if (and (>= v 0)
(< v #xffffffff))
`((,(string-append "and____$i32,%" r) (#:immediate ,v)))
`((,(string-append "mov____$i64,%r15") (#:immediate8 ,v))
(,(string-append "and____%r15,%" r))))))
(define (x86_64:push-r0 info)
(let ((r0 (get-r0 info)))
`((,(string-append "push___%" r0)))))
(define (x86_64:r1->r0 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info)))
`((,(string-append "mov____%" r1 ",%" r0)))))
(define (x86_64:pop-r0 info)
(let ((r0 (get-r0 info)))
`((,(string-append "pop____%" r0)))))
(define (x86_64:swap-r-stack info)
(let ((r (get-r info)))
`((,(string-append "xchg___%" r ",(%rsp)")))))
(define (x86_64:swap-r1-stack info)
(let ((r0 (get-r0 info)))
`((,(string-append "xchg___%" r0 ",(%rsp)")))))
(define (x86_64:r2->r0 info)
(let ((r0 (get-r0 info))
(r1 (get-r1 info))
(allocated (.allocated info)))
(if (> (length allocated) 2)
(let ((r2 (cadddr allocated)))
`((,(string-append "mov____%" r2 ",%" r1))))
`((,(string-append "pop____%" r0))
(,(string-append "push___%" r0))))))
(define x86_64:instructions
`(
(a?->r . ,x86_64:a?->r)
(ae?->r . ,x86_64:ae?->r)
(b?->r . ,x86_64:b?->r)
(be?->r . ,x86_64:be?->r)
(byte-mem->r . ,x86_64:byte-mem->r)
(byte-r . ,x86_64:byte-r)
(byte-r->local+n . ,x86_64:byte-r->local+n)
(byte-r0->r1-mem . ,x86_64:byte-r0->r1-mem)
(byte-r0-mem->r1-mem . ,x86_64:byte-r0-mem->r1-mem)
(byte-signed-r . ,x86_64:byte-signed-r)
(call-label . ,x86_64:call-label)
(call-r . ,x86_64:call-r)
(function-locals . ,x86_64:function-locals)
(function-preamble . ,x86_64:function-preamble)
(g?->r . ,x86_64:g?->r)
(ge?->r . ,x86_64:ge?->r)
(jump . ,x86_64:jump)
(jump-a . ,x86_64:jump-a)
(jump-ae . ,x86_64:jump-ae)
(jump-b . ,x86_64:jump-b)
(jump-be . ,x86_64:jump-be)
(jump-byte-z . ,x86_64:jump-byte-z)
(jump-g . , x86_64:jump-g)
(jump-ge . , x86_64:jump-ge)
(jump-l . ,x86_64:jump-l)
(jump-le . ,x86_64:jump-le)
(jump-nz . ,x86_64:jump-nz)
(jump-z . ,x86_64:jump-z)
(l?->r . ,x86_64:l?->r)
(label->arg . ,x86_64:label->arg)
(label->r . ,x86_64:label->r)
(label-mem->r . ,x86_64:label-mem->r)
(label-mem-add . ,x86_64:label-mem-add)
(le?->r . ,x86_64:le?->r)
(local->r . ,x86_64:local->r)
(local-add . ,x86_64:local-add)
(local-ptr->r . ,x86_64:local-ptr->r)
(long-mem->r . ,x86_64:long-mem->r)
(long-r . ,x86_64:long-r)
(long-r->local+n . ,x86_64:long-r->local+n)
(long-r0->r1-mem . ,x86_64:long-r0->r1-mem)
(long-r0-mem->r1-mem . ,x86_64:long-r0-mem->r1-mem)
(long-signed-r . ,x86_64:long-signed-r)
(mem->r . ,x86_64:mem->r)
(nop . ,x86_64:nop)
(not-r . ,x86_64:not-r)
(pop-r0 . ,x86_64:pop-r0)
(pop-register . ,x86_64:pop-register)
(push-r0 . ,x86_64:push-r0)
(push-register . ,x86_64:push-register)
(quad-r0->r1-mem . ,x86_64:r0->r1-mem)
(r+r . ,x86_64:r+r)
(r+value . ,x86_64:r+value)
(r->arg . ,x86_64:r->arg)
(r->byte-label . ,x86_64:r->byte-label)
(r->label . ,x86_64:r->label)
(r->local . ,x86_64:r->local)
(r->local+n . ,x86_64:r->local+n)
(r->long-label . ,x86_64:r->long-label)
(r->word-label . ,x86_64:r->word-label)
(r-and . ,x86_64:r-and)
(r-byte-mem-add . ,x86_64:r-byte-mem-add)
(r-cmp-value . ,x86_64:r-cmp-value)
(r-long-mem-add . ,x86_64:r-long-mem-add)
(r-mem-add . ,x86_64:r-mem-add)
(r-negate . ,x86_64:r-negate)
(r-word-mem-add . ,x86_64:r-word-mem-add)
(r-zero? . ,x86_64:r-zero?)
(r0%r1 . ,x86_64:r0%r1)
(r0*r1 . ,x86_64:r0*r1)
(r0+r1 . ,x86_64:r0+r1)
(r0+value . ,x86_64:r0+value)
(r0->r1 . ,x86_64:r0->r1)
(r0->r1-mem . ,x86_64:r0->r1-mem)
(r0-and-r1 . ,x86_64:r0-and-r1)
(r0-mem->r1-mem . ,x86_64:r0-mem->r1-mem)
(r0-or-r1 . ,x86_64:r0-or-r1)
(r0-r1 . ,x86_64:r0-r1)
(r0-xor-r1 . ,x86_64:r0-xor-r1)
(r0/r1 . ,x86_64:r0/r1)
(r0<<r1 . ,x86_64:r0<<r1)
(r0>>r1 . ,x86_64:r0>>r1)
(r1->r0 . ,x86_64:r1->r0)
(r2->r0 . ,x86_64:r2->r0)
(ret . ,x86_64:ret)
(return->r . ,x86_64:return->r)
(shl-r . ,x86_64:shl-r)
(swap-r-stack . ,x86_64:swap-r-stack)
(swap-r0-r1 . ,x86_64:swap-r0-r1)
(swap-r1-stack . ,x86_64:swap-r1-stack)
(test-r . ,x86_64:test-r)
(value->r . ,x86_64:value->r)
(value->r0 . ,x86_64:value->r0)
(word-mem->r . ,x86_64:word-mem->r)
(word-r . ,x86_64:word-r)
(word-r->local+n . ,x86_64:word-r->local+n)
(word-r0->r1-mem . ,x86_64:word-r0->r1-mem)
(word-r0-mem->r1-mem . ,x86_64:word-r0-mem->r1-mem)
(word-signed-r . ,x86_64:word-signed-r)
(xor-zf . ,x86_64:xor-zf)
(zf->r . ,x86_64:zf->r)
))

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

@ -0,0 +1,61 @@
;;; 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:
;;; Initialize MesCC as i386/x86 compiler
;;; Code:
(define-module (mescc x86_64 info)
#:use-module (mescc info)
#:use-module (mescc x86_64 as)
#:export (x86_64-info
x86_64:registers))
(define (x86_64-info)
(make <info> #:types x86_64:type-alist #:registers x86_64:registers #:instructions x86_64:instructions))
(define x86_64:registers '("rax" "rdi" "rsi" "rdx" "rcx" "r8" "r9" "r10" "r11" "r12" "r13" "r14" "r15"))
(define x86_64:type-alist
`(("char" . ,(make-type 'signed 1 #f))
("short" . ,(make-type 'signed 2 #f))
("int" . ,(make-type 'signed 4 #f))
("long" . ,(make-type 'signed 8 #f))
("default" . ,(make-type 'signed 4 #f))
("*" . ,(make-type 'unsigned 8 #f))
("long long" . ,(make-type 'signed 8 #f))
("long long int" . ,(make-type 'signed 8 #f))
("void" . ,(make-type 'void 1 #f))
("unsigned char" . ,(make-type 'unsigned 1 #f))
("unsigned short" . ,(make-type 'unsigned 2 #f))
("unsigned" . ,(make-type 'unsigned 4 #f))
("unsigned int" . ,(make-type 'unsigned 4 #f))
("unsigned long" . ,(make-type 'unsigned 8 #f))
("unsigned long long" . ,(make-type 'unsigned 8 #f))
("unsigned long long int" . ,(make-type 'unsigned 8 #f))
("float" . ,(make-type 'float 4 #f))
("double" . ,(make-type 'float 8 #f))
("long double" . ,(make-type 'float 8 #f))
("short int" . ,(make-type 'signed 2 #f))
("unsigned short int" . ,(make-type 'unsigned 2 #f))
("long int" . ,(make-type 'signed 8 #f))
("unsigned long int" . ,(make-type 'unsigned 8 #f))))

248
sysa/mes-0.22/module/nyacc/ChangeLog Normal file
View file

@ -0,0 +1,248 @@
2018-12-24 Matt Wette <mwette@alumni.caltech.edu>
* /: removed lalr2.scm
2018-11-21 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (make-num-reader): support 0X (cap x) for hex numbers
2018-11-16 Matt Wette <mwette@alumni.caltech.edu>
* lang/sx-util.scm (sx-join): changed the way sx-split and sx-join
work with repect to attributes, the attr returned from sx-split
and passed to sx-join are the tails of '(@ (a "1") (b "2"))
instead of the entire form. One can pass '() or #f to sx-join.
2018-10-14 Matt Wette <mwette@alumni.caltech.edu>
* lang/sx-util.scm (sxm-node): cleaned up sx-match now accepts
(,_ ...) to accept all, and supports string matching
2018-09-28 Matt Wette <mwette@alumni.caltech.edu>
* lang/sx-util.scm: added make-sx;
2018-09-23 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (make-comm-reader): For comment patterns ending with
newline, when see eof-object should return match pair but was just
returning the string (i.e., was "comment" now '($lone-comm "comment"))
2018-09-05 Matt Wette <mwette@alumni.caltech.edu>
* lalr.scm (process-spec): added alt-start spec attribute in order
to prevent warning about unused LHS non-terminals; but not working
* lalr.scm (drop-dot-new): new routine to replace string-sub
and it's use; no dependence on (ice-9 regex) now
2018-08-19 Matt Wette <mwette@alumni.caltech.edu>
* lang/sx-util.scm: added sx-split, sx-split*, sx-join, sx-join*
2018-08-12 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (make-num-reader): for case (12) iter args swapped:
fixed with "5 ba" => "ba 5"
2018-08-11 Matt Wette <mwette@alumni.caltech.edu>
* lang/sx-util.scm: removed sx+attr routines, added sx-attr-add
and sx-attr-add*; updated c99/body.scm to use sx-attr-add
2018-07-29 Matt Wette <mwette@alumni.caltech.edu>
* lalr.scm (compact-machine): default for #:keep is now 0, was 3
* parse.scm: reworked the parsers; instead of one for interactive
and one for non-interative, with each handling unhashed (symbolic)
or hashed (numberic), we now have one for symbolic and one for
numeric with each handling interactive and non-interactive; I
think this is now cleaner
* lang/util.scm: removed dead sx- code; now in sx-util.scm;
moved lang-dir, xtra-dir from lang/mach.scm files to here and
renamed xtra-dir to mach-dir
2018-07-27 Matt Wette <mwette@alumni.caltech.edu>
* parse.scm: Removed dependence on srfi-43 by adding vector-map.
2018-07-25 Matt Wette <mwette@alumni.caltech.edu>
* lalr.scm (compact-machine): The default set of keepers is now
($lone-comm $code-comm) and the requires keepers list was removed
but $error is hardcoded as only required keeper. I was having
issues with the ia-parser/num because it looks for lone $default
to reduce without lookahead. I still need to think about this.
2018-07-12 Matt Wette <mwette@alumni.caltech.edu>
* parse.scm (make-lalr-ia-parser/num): broke make-lalr-ia-parser
into make-lalr-ia-parser/sym for unhashed and
make-lalr-ia-parser/num for hashed. The /num version is working;
need to recode the sym one still.
* lalr.scm (compact-machine): removed $end from required-keepers;
changed $default from -1 to 1 so that all token values are > 0.
The pat-v could potentially now be a vector.
2018-07-09 Matt Wette <mwette@alumni.caltech.edu>
* lalr.scm (compact-machine): force $end to be -2, so parsers
don't have to look up the value
* parse.scm (make-lalr-ia-parser/num): added /sym and /num parsers;
abandoning attempt to make general purpose parsers for hashed/unhashed
2018-05-12 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (make-lexer-generator): added extra keyword arg to
handle extra reader. This makes the lexer-generator a bit more
flexible for non-C languages.
(make-num-reader): update to read "12-3" as a float
2018-05-05 Matt Wette <mwette@alumni.caltech.edu>
* lang/util.scm: removed sx- routines; renamed sxml-util to
sx-util; removed sx-match; sx-match is now in sx-util
2018-03-28 Matt Wette <mwette@alumni.caltech.edu>
* lang/util.scm: sx-ref* now returns #f for non-usable xxx
2018-01-21 Matt Wette <mwette@alumni.caltech.edu>
* version.scm: release version 0.83.0
2017-11-23 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (read-c-chlit): did not parse '\177' correctly (prev
code fix may have done this). Fixed (I hope) and added test
case for escapes in C chlit and C string in test-suite.
2017-11-12 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (read-oct): changed (read-oct ch) to (read-oct) to be
consistent with (read-hex).
2017-11-11 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (read-c-chlit): removed (unread-char ch) for U but no '
This bug was causingd janneke's tccpp.c to not parse.
2017-09-23 Matt Wette <mwette@alumni.caltech.edu>
* util.scm: updated ugly-print w/ new api similar to pretty-print
2017-09-10 Matt Wette <mwette@alumni.caltech.edu>
* util.scm (ugly-print): changed letrec to letrec*. Not sure why
this has been working forever and broke in install context. Seems
to work now.
2017-08-20 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (make-comm-reader): added option to remove prefix
from comments; That is, for a multi-line comment that starts in
column 10, spaces up to column 10 will be removed in following
lines
2017-08-02 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (read-c-string): numeric escapes (e.g., \0) were
not working due to use of ch instead of c1 in numeric check
2017-07-28 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (make-num-reader): bug report from janneke: c-parser
is not parsing "0ULL". the num reader has been updated (state 12)
to handle this
(cnumstr->scm): updated to trim ULL from 0ULL.
2017-06-29 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (make-chseq-reader): make robust to <eof>
2017-06-11 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (nyacc): make-ident-like-p tested for string but not for
empty string: added `not eof-object?'
2017-06-03 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (read-c-chlit): added '\r' and '\|' moved '\\' to case
2017-05-28 Matt Wette <mwette@alumni.caltech.edu>
* lalr.scm (step4): added precedence for resolving RR conflicts!
2017-05-20 Matt Wette <mwette@alumni.caltech.edu>
* lalr.scm (lalr-spec): removed more with/prune syntax; added
reserve directive for reserved terminals (e.g., "volatile")
2017-05-06 Matt Wette <mwette@alumni.caltech.edu>
* lalr.scm: updated write-lalr-tables and write-lalr-actions to
accept a prefix string
2017-05-04 Matt Wette <mwette@alumni.caltech.edu>
* lang/util.scm (make-pp-formatter): fixed bug in column counting
that prevented line-wrap to occur.
2017-04-12 Matt Wette <mwette@alumni.caltech.edu>
* lex.scm (make-comm-reader): comments which end in newline can
now also end in #<eof>
2017-03-03 Matt Wette <mwette@alumni.caltech.edu>
* lalr.scm: added "keepers" keyword argument to compact-machine
and also added $end as default
2017-01-08 Matt Wette <mwette@alumni.caltech.edu>
* ../../test-suite/nyacc/lang/c99/exam.d/ex05.c: C99 does not
allow lone `;' outside of functions. Removed.
2017-01-07 Matt Wette <mwette@alumni.caltech.edu>
* lang/util.scm: add report-error: prints msg w/ file, line
* parse.scm (make-lalr-parser): changed printout of parse error to
(throw 'parse-error . args) and expect the full parser to catch
the error
2017-01-06 Matt Wette <mwette@alumni.caltech.edu>
* lalr.scm (process-spec): in add-el changed memq to member since
we are using strings for terminals
2016-11-25 Matt Wette <mwette@alumni.caltech.edu>
* added support for ellipsis to lang/c99/cpp.scm
2016-11-24 Matt Wette <mwette@alumni.caltech.edu>
* added (ellipsis) to lang/c99/pprint.scm
2016-04-09 Matt Wette <mwette@alumni.caltech.edu>
* bison.scm: new file providing make-lalr-machin/bison. It is
similar to make-lalr-machine but uses external bison program
instead of the default from-scratch lalr code.
2016-03-04 Matt Wette <mwette@alumni.caltech.edu>
* lalr.scm: changed grammar parser to interpret $string as
terminal. This saves typing a quote in front.
Copyright (C) 2015-2017 Matthew R. Wette
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
notice and this notice are preserved. This file is offered as-is,
without any warranty.

214
sysa/mes-0.22/module/nyacc/bison.scm Normal file
View file

@ -0,0 +1,214 @@
;;; nyacc/bison.scm - export bison
;; Copyright (C) 2016,2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the licence with this software.
;; If not, see <http://www.gnu.org/licenses/>.
;;; Code:
(define-module (nyacc bison)
#:export (make-lalr-machine/bison)
#:use-module (sxml simple)
#:use-module (sxml match)
#:use-module (sxml xpath)
#:use-module (ice-9 pretty-print)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module ((srfi srfi-43) #:select (vector-for-each vector-map))
#:use-module (nyacc export)
#:use-module (nyacc lalr)) ; gen-match-table
;; @deffn chew-on-grammar tree lhs-v rhs-v terms => a-list
;; Generate a-list that maps bison rule index to NYACC rule index.
(define (chew-on-grammar tree lhs-v rhs-v terms) ;; bison-rule => nyacc-rule map
;; match rule index, if no match return @code{-1}
;; could be improved by starting with last rule number and wrapping
(define (match-rule lhs rhs)
(let loop ((ix 0))
(if (eqv? ix (vector-length lhs-v)) -1
(if (and (equal? lhs (elt->bison (vector-ref lhs-v ix) terms))
(equal? rhs (vector->list
(vector-map
(lambda (ix val) (elt->bison val terms))
(vector-ref rhs-v ix)))))
ix
(loop (1+ ix))))))
;; this is a fold
(define (rule->index-al tree seed)
(sxml-match tree
;; Skip first bison rule: always $accept.
((rule (@ (number "0")) (lhs "$accept") . ,rest)
(acons 0 0 seed))
;; This matches all others.
((rule (@ (number ,n)) (lhs ,lhs) (rhs (symbol ,rhs) ...))
(acons (string->number n) (match-rule lhs rhs) seed))
(,otherwise seed)))
(fold rule->index-al '() ((sxpath '(// rule)) tree)))
;; @deffn chew-on-automaton tree gx-al bs->ns => a-list
;; This digests the automaton and generated the @code{pat-v} and @code{kis-v}
;; vectors for the NYACC automaton.
(define (chew-on-automaton tree gx-al bs->ns)
(define st-numb
(let ((xsnum (sxpath '(@ number *text*))))
(lambda (state)
(string->number (car (xsnum state))))))
(define (do-state state)
(let* ((b-items ((sxpath '(// item)) state))
(n-items (fold
(lambda (tree seed)
(sxml-match tree
((item (@ (rule-number ,rns) (point ,pts)) . ,rest)
(let ((rn (string->number rns))
(pt (string->number pts)))
(if (and (positive? rn) (zero? pt)) seed
(acons (assq-ref gx-al rn) pt seed))))
(,otherwise (error "broken item")))) '() b-items))
(b-trans ((sxpath '(// transition)) state))
(n-trans (map
(lambda (tree)
(sxml-match tree
((transition (@ (symbol ,symb) (state ,dest)))
(cons* (bs->ns symb) 'shift (string->number dest)))
(,otherwise (error "broken tran")))) b-trans))
(b-redxs ((sxpath '(// reduction)) state))
(n-redxs (map
(lambda (tree)
(sxml-match tree
((reduction (@ (symbol ,symb) (rule "accept")))
(cons* (bs->ns symb) 'accept 0))
((reduction (@ (symbol ,symb) (rule ,rule)))
(cons* (bs->ns symb) 'reduce
(assq-ref gx-al (string->number rule))))
(,otherwise (error "broken redx" tree)))) b-redxs)))
(list
(st-numb state)
(cons 'kis n-items)
(cons 'pat (append n-trans n-redxs)))))
(let ((xsf (sxpath '(itemset item (@ (rule-number (equal? "0"))
(point (equal? "2")))))))
(let loop ((data '()) (xtra #f) (states (cdr tree)))
(cond
((null? states) (cons xtra data))
((pair? (xsf (car states)))
(loop data (st-numb (car states)) (cdr states)))
(else
(loop (cons (do-state (car states)) data) xtra (cdr states)))))))
;; @deffn atomize symbol => string
;; This is copied from the module @code{(nyacc lalr)}.
(define (atomize terminal) ; from lalr.scm
(if (string? terminal)
(string->symbol (string-append "$:" terminal))
terminal))
;; @deffn make-bison->nyacc-symbol-mapper terminals non-terminals => proc
;; This generates a procedure to map bison symbol names, generated by the
;; NYACC @code{lalr->bison} procedure, (back) to nyacc symbols names.
(define (make-bison->nyacc-symbol-mapper terms non-ts)
(let ((bs->ns-al
(cons*
'("$default" . $default)
'("$end" . $end)
(map (lambda (symb) (cons (elt->bison symb terms) symb))
(append (map atomize terms) non-ts)))))
(lambda (name) (assoc-ref bs->ns-al name))))
;; fix-pa
;; fix parse action
(define (fix-pa pa xs)
(cond
((and (eqv? 'shift (cadr pa))
(> (cddr pa) xs))
(cons* (car pa) (cadr pa) (1- (cddr pa))))
((and (eqv? 'shift (cadr pa))
(= (cddr pa) xs))
(cons* (car pa) 'accept 0))
(else pa)))
;; @deffn fix-is is xs rhs-v
;; Convert xxx
(define (fix-is is xs rhs-v)
(let* ((gx (car is))
(rx (cdr is))
(gl (vector-length (vector-ref rhs-v gx))))
(if (= rx gl) (cons gx -1) is)))
;; @deffn spec->mac-sxml spec
;; Write bison-converted @var{spec} to file, run bison on it, and load
;; the bison-generated automaton as a SXML tree using the @code{-x} option.
(define (spec->mach-sxml spec)
(let* ((basename (tmpnam))
(bisname (string-append basename ".y"))
(xmlname (string-append basename ".xml"))
(tabname (string-append basename ".tab.c")))
(with-output-to-file bisname
(lambda () (lalr->bison spec)))
(system (string-append "bison" " --xml=" xmlname " --output=" tabname
" " bisname))
(let ((sx (call-with-input-file xmlname
(lambda (p) (xml->sxml p #:trim-whitespace? #t)))))
(delete-file bisname)
(delete-file xmlname)
(delete-file tabname)
sx)))
;; @deffn make-lalr-machine/bison spec => mach
;; Make a LALR automaton, consistent with that from @code{make-lalr-machine}
;; using external @code{bison} program.
(define (make-lalr-machine/bison spec)
(let* ((terminals (assq-ref spec 'terminals))
(non-terms (assq-ref spec 'non-terms))
(lhs-v (assq-ref spec 'lhs-v))
(rhs-v (assq-ref spec 'rhs-v))
(s0 (spec->mach-sxml spec))
(sG ((sxpath '(bison-xml-report grammar)) s0))
(sG (if (pair? sG) (car sG) sG))
(sA ((sxpath '(bison-xml-report automaton)) s0))
(sA (if (pair? sA) (car sA) sA))
(pG (chew-on-grammar sG lhs-v rhs-v terminals))
(bsym->nsym (make-bison->nyacc-symbol-mapper terminals non-terms))
(pA (chew-on-automaton sA pG bsym->nsym))
(xs (car pA))
(ns (caadr pA))
(pat-v (make-vector ns #f))
(kis-v (make-vector ns #f)))
;;(pretty-print sA)
(for-each
(lambda (state)
(let* ((sx (car state))
(sx (if (>= sx xs) (1- sx) sx))
(pat (assq-ref (cdr state) 'pat))
(pat (map (lambda (pa) (fix-pa pa xs)) pat))
(kis (assq-ref (cdr state) 'kis))
(kis (map (lambda (is) (fix-is is xs rhs-v)) kis)))
(vector-set! pat-v sx pat)
(vector-set! kis-v sx kis)))
(cdr pA))
(gen-match-table
(cons*
(cons 'pat-v pat-v)
(cons 'kis-v kis-v)
(cons 'len-v (vector-map (lambda (i v) (vector-length v)) rhs-v))
(cons 'rto-v (vector-copy lhs-v))
spec))))
;; --- last line ---

141
sysa/mes-0.22/module/nyacc/compat18.scm Normal file
View file

@ -0,0 +1,141 @@
;;; nyacc/compat18.scm - V18 compatibility, used by some for debugging
;; Copyright (C) 2017 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>
;;; Code:
(define-module (nyacc compat18)
#:export (vector-map
vector-for-each vector-any vector-fold
syntax->datum datum->syntax
bitwise-arithmetic-shift-left
bitwise-arithmetic-shift-right
)
#:export-syntax (unless when pmatch include-from-path)
#:use-syntax (ice-9 syncase))
;; replacement for same from (srfi srfi-43)
(define (vector-map proc . vecs)
(let* ((size (apply min (map vector-length vecs)))
(retv (make-vector size)))
(let loop ((ix 0))
(cond
((= ix size) retv)
(else
(vector-set! retv ix
(apply proc ix (map (lambda (v) (vector-ref v ix)) vecs)))
(loop (1+ ix)))))))
;; replacement for same from (srfi srfi-43)
(define (vector-for-each proc . vecs)
(let ((size (apply min (map vector-length vecs))))
(let loop ((ix 0))
(cond
((= ix size) (if #f #f))
(else
(apply proc ix (map (lambda (v) (vector-ref v ix)) vecs))
(loop (1+ ix)))))))
;; hack to replace same from (srfi srfi-43)
;; the real one takes more args
(define (vector-any pred? vec)
(let ((size (vector-length vec)))
(let loop ((ix 0))
(cond
((= ix size) #f)
((pred? ix (vector-ref vec ix)) #t)
(else (loop (1+ ix)))))))
;; replacement for same from (srfi srfi-43)
(define (vector-fold proc seed . vecs)
(let ((size (apply min (map vector-length vecs))))
(let loop ((seed seed) (ix 0))
(cond
((= ix size) seed)
(else
(loop
(apply proc ix seed (map (lambda (v) (vector-ref v ix)) vecs))
(1+ ix)))))))
;; change in syntax-case names
(define datum->syntax datum->syntax-object)
(define syntax->datum syntax-object->datum)
(define-syntax unless
(syntax-rules ()
((_ c e ...) (if (not c) (begin e ...)))))
(define-syntax when
(syntax-rules ()
((_ c e ...) (if c (begin e ...)))))
(define (bitwise-arithmetic-shift-right ei1 ei2)
(let loop ((ei1 ei1) (ei2 ei2))
(if (zero? ei2) ei1
(loop (quotient ei2 2) (1- ei1)))))
(define (bitwise-arithmetic-shift-left ei1 ei2)
(let loop ((ei1 ei1) (ei2 ei2))
(if (zero? ei2) ei1
(loop (* ei2 2) (1- ei1)))))
(define-syntax pmatch
(syntax-rules ()
((_ e cs ...)
(let ((v e)) (pmatch1 v cs ...)))))
(define-syntax pmatch1
(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 () (pmatch1 v cs ...))))
(ppat v pat
(if (and g ...) (let () e0 e ...) (fk))
(fk))))
((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (pmatch1 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)
(let ((vx (car v)) (vy (cdr v)))
(ppat vx x (ppat vy y kt kf) kf))
kf))
((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))
;; this works for some but not for lambda-case in srfi-16
(define-syntax include-from-path
(syntax-rules ()
((_ file)
(let* ((env (current-module))
(path (%search-load-path file))
(port (open-input-file path)))
(let loop ((exp (read port)))
(cond
((eof-object? exp) (if #f #f))
(else
(eval exp env)
(loop (read port)))))))))
;;; --- last line ---

199
sysa/mes-0.22/module/nyacc/export.scm Normal file
View file

@ -0,0 +1,199 @@
;;; nyacc/export.scm
;; Copyright (C) 2015,2017-2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the licence with this software.
;; If not, see <http://www.gnu.org/licenses/>.
;;; Code:
(define-module (nyacc export)
#:export (lalr->bison
lalr->guile
c-char token->bison elt->bison)
#:use-module ((nyacc lalr) #:select (find-terminal pp-rule lalr-start))
#:use-module (nyacc lex)
#:use-module (nyacc util)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module ((srfi srfi-43) #:select (vector-for-each))
#:use-module (ice-9 regex))
;; The code below, for exporting to guile and bison, should be moved to
;; an "export" module.
;; terminal:
;; ident-like-string -> caps
;; non-ident-like-string -> ChSeq_#_# ...
;; symbol -> if $, use _, otherwise ???
;; breakdown:
;; 1 terminal, or non-terminal:
;; 2 if non-terminal,
;; replace - with _, replace $ with _
;; 3 if terminal, (output of @code{find-terminal})
;; if symbol, use 2
;; replace char with (c-char .)
;; if length-1 string replace with (c-char .)
;; if like-c-ident string, replace with CAPS
;; otherwise use ChSeq
(define re/g regexp-substitute/global)
(define (chseq->name cs)
(let* ((iseq (string-fold (lambda (c s) (cons* (char->integer c) s)) '() cs))
(tail (string-join (map number->string iseq) "_"))
(name (string-append "ChSeq_" tail)))
name))
;; Convert char to string that works inside single quotes for C.
(define (c-char ch)
(case ch
((#\') "'\\''")
((#\\) "'\\\\'")
((#\newline) "'\\n'")
((#\tab) "'\\t'")
((#\return) "\\r")
(else (string #\' ch #\'))))
(define (token->bison tok)
(cond
((eqv? tok '$error) "error")
((symbol? tok) (symbol->bison tok))
((char? tok) (c-char tok))
((string? tok)
(cond
((like-c-ident? tok) (string-upcase tok))
((= 1 (string-length tok)) (c-char (string-ref tok 0)))
(else (chseq->name tok))))
(else (error "what?"))))
(define (symbol->bison symb)
(let* ((str0 (symbol->string symb))
(str1 (re/g #f "-" str0 'pre "_" 'post))
(str2 (re/g #f "\\$" str1 'pre "_" 'post)))
str2))
(define (elt->bison symb terms)
(let ((term (find-terminal symb terms)))
(if term
(token->bison term)
(symbol->bison symb))))
;; @deffn lalr->bison spec => to current output port
;; needs cleanup: tokens working better but p-rules need fix.
(define (lalr->bison spec . rest)
(define (setup-assc assc)
(fold (lambda (al seed)
(append (x-flip al) seed)) '() assc))
(let* ((port (if (pair? rest) (car rest) (current-output-port)))
(lhs-v (assq-ref spec 'lhs-v))
(rhs-v (assq-ref spec 'rhs-v))
(prp-v (assq-ref spec 'prp-v))
(assc (setup-assc (assq-ref spec 'assc)))
(nrule (vector-length lhs-v))
(terms (assq-ref spec 'terminals)))
;; Generate copyright notice.
(let* ((notice (assq-ref (assq-ref spec 'attr) 'notice))
(lines (if notice (string-split notice #\newline) '())))
(for-each (lambda (l) (fmt port "// ~A\n" l))
lines))
;; Write out the tokens.
(for-each
(lambda (term)
(unless (eqv? term '$error)
(fmt port "%token ~A\n" (token->bison term))))
terms)
;; Write the associativity and prececences.
(let loop ((pl '()) (ppl (assq-ref spec 'prec)))
(cond
((pair? pl)
(fmt port "%~A" (or (assq-ref assc (caar pl)) "precedence"))
(let loop2 ((pl (car pl)))
(unless (null? pl)
(fmt port " ~A" (elt->bison (car pl) terms))
(loop2 (cdr pl))))
(fmt port "\n")
(loop (cdr pl) ppl))
((pair? ppl) (loop (car ppl) (cdr ppl)))))
;; Don't compact tables.
(fmt port "%define lr.default-reduction accepting\n")
;; Provide start symbol.
(fmt port "%start ~A\n%%\n" (elt->bison (lalr-start spec) terms))
;;
(do ((i 1 (1+ i))) ((= i nrule))
(let* ((lhs (vector-ref lhs-v i)) (rhs (vector-ref rhs-v i)))
(fmt port "~A:" (elt->bison lhs terms))
(vector-for-each
(lambda (ix e) (fmt port " ~A" (elt->bison e terms)))
rhs)
(if (zero? (vector-length rhs)) (fmt port " %empty"))
(and=> (vector-ref prp-v i)
(lambda (tok) (fmt port " %prec ~A" (elt->bison tok terms))))
(fmt port " ;\n")))
(newline port)
(values)))
;; @item pp-guile-input spec => to current output port
;; total hack right now
(define (lalr->guile spec . rest)
(let* ((port (if (pair? rest) (car rest) (current-output-port)))
(lhs-v (assq-ref spec 'lhs-v))
(rhs-v (assq-ref spec 'rhs-v))
(act-v (assq-ref spec 'act-v))
(nrule (vector-length lhs-v))
(terms (assq-ref spec 'terminals))
(lhsP #f))
;;
(fmt port "(use-modules (system base lalr))\n")
(fmt port "(define parser\n")
(fmt port " (lalr-parser\n (")
(for-each
(lambda (s)
(if (> (port-column port) 60) (fmt port "\n "))
(cond
((equal? #\; s) (fmt port " C-semi"))
((symbol? s) (fmt port " ~A" s))
(else (fmt port " C-~A" s))))
terms)
(fmt port ")\n")
;;
(do ((i 1 (1+ i))) ((= i nrule))
(let* ((lhs (vector-ref lhs-v i)) (rhs (vector-ref rhs-v i)))
(if #f
(pp-rule 0 i)
(begin
(if lhsP
(if (not (eqv? lhs lhsP))
(fmt port " )\n (~S\n" lhs))
(fmt port " (~S\n" lhs))
(fmt port " (")
(do ((j 0 (1+ j) )) ((= j (vector-length rhs)))
(let ((e (vector-ref rhs j)))
(if (positive? j) (fmt port " "))
(fmt
port "~A"
(cond
((equal? #\; e) (fmtstr "C-semi"))
((char? e) (fmtstr "C-~A" e))
(else e)))))
(fmt port ") ")
(fmt port ": ~S" `(begin ,@(vector-ref act-v i)))
(fmt port "\n")
(set! lhsP lhs)))))
(fmt port " ))\n")
(fmt port " )\n")
(values)))
;;; --- last line ---

105
sysa/mes-0.22/module/nyacc/import.scm Normal file
View file

@ -0,0 +1,105 @@
;;; nyacc/import.scm
;;;
;;; Copyright (C) 2015 Matthew R. Wette
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public License
;;; along with this library; if not, see <http://www.gnu.org/licenses/>
;; Convert guile lalr grammar to nyacc grammar.
;; What is *eoi* for?
(define-module (nyacc import)
;;#:export-syntax (lalr-parser)
#:export (lalr-parser guile-lalr->nyacc-lalr)
#:use-module ((srfi srfi-1) #:select (fold-right))
)
(define (convert-tree spec0)
(let* ((terms (cons '*eoi* (car spec0)))
(start (caadr spec0))
(wrap-symb
(lambda (s) (cons (if (memq s terms) 'terminal 'non-terminal) s))))
(let loop ((prl1 '()) ; new production rules
(prl0 (cdr spec0)) ; old production rules
(lhs #f) ; LHS
(rhs1-l #f) ; new RHS list
(rhs0-l #f)) ; old RHS list
(cond
((pair? rhs0-l) ;; convert RHS
(loop prl1 prl0 lhs
(cons
(fold-right ;; s1 ... : a => (('terminal . s) ... ('$$ . a))
(lambda (symb seed) (cons (wrap-symb symb) seed))
(list (list '$$ (cdar rhs0-l)))
(caar rhs0-l))
rhs1-l)
(cdr rhs0-l)))
((null? rhs0-l) ;; roll up LHS+RHSs to new rule
(loop (cons (cons lhs (reverse rhs1-l)) prl1) prl0 #f #f #f))
((pair? prl0) ;; next production rule
(loop prl1 (cdr prl0) (caar prl0) '() (cdar prl0)))
(else ;; return spec in preliminary form
(list
'lalr-spec
`(start ,start)
`(grammar ,(reverse prl1))))))))
(define-syntax parse-rhs-list
(syntax-rules (:)
((_ (<rhs0sym> ...) : <rhs0act> <rhs1> ...)
(cons (cons '(<rhs0sym> ...) '<rhs0act>)
(parse-rhs-list <rhs1> ...)))
((_) (list))))
(define-syntax parse-prod-list
(syntax-rules ()
((_ (<lhs> <rhs> ...) <prod1> ...)
(cons (cons '<lhs> (parse-rhs-list <rhs> ...))
(parse-prod-list <prod1> ...)))
((_) (list))))
(define-syntax lalr-parser
(syntax-rules ()
((_ <tokens> <prod0> ...)
(convert-tree
(cons '<tokens> (parse-prod-list <prod0> ...))))))
(define (guile-lalr->nyacc-lalr match-table spec)
(letrec
((mark (lambda (s) (if (symbol? s) `(quote ,s) s)))
(rmt (map (lambda (p) (cons (cdr p) (mark (car p)))) match-table))
(clean
(lambda (dt)
(cond
((null? dt) '())
((pair? dt)
(case (car dt)
((non-terminal) (cdr dt))
((terminal)
(cond
((assq-ref rmt (cdr dt)))
((symbol? (cdr dt)) (simple-format #f "~A" (cdr dt)))
(else (cdr dt))))
((start) dt)
(else
(cons (clean (car dt)) (clean (cdr dt))))))
(else
dt))))
)
(clean spec)))
;;; --- last line ---

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

File diff suppressed because it is too large Load diff

330
sysa/mes-0.22/module/nyacc/lang/c99/ChangeLog Normal file
View file

@ -0,0 +1,330 @@
2019-04-27 Matt Wette <mwette@alumni.caltech.edu>
* cpp.scm (cpp-define): Now accommodates comments in CPP like
this: #define /* MAX as macro */ MAX(X,Y) (((X)>(Y))?(X):(Y))
support item 109657
2019-03-24 Matt Wette <mwette@alumni.caltech.edu>
* ffi-help.scm (cnvt-udecl): fixed error in "typedef union foo
foo_t;" by adding (fhscm-def-compound typename). The desc was
being defined but not the type. This was causing (make-foo_t)
return a void. Same issue for "typedef struct foo foo_t".
2019-02-05 Matt Wette <mwette@alumni.caltech.edu>
* ffi-help.scm (gen-lookup-proc): in-line open "/dev/null" was
generating "too many open files". Replaced with open/close in
gen-lookup-proc and added try-parse-repl
2019-01-18 Matt Wette <mwette@alumni.caltech.edu>
* mach.d: changed convention from xxxact.scm, xxxtab.scm to
xxx-act.scm, xxx-tab.scm; added xxx-xtr.scm which has extra
table to help with debugging output
2019-01-02 Matt Wette <mwette@alumni.caltech.edu>
* parser.scm: now using c99-def-help from c99/util.scm for default
inc-help ; adding this to ffi-help and others
2018-12-31 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): add attribute on declarators in structs;
had to add specifier-qualifier-list/no-attr to use for type-name
production to remove loop-conflict
2018-12-30 Matt Wette <mwette@alumni.caltech.edu>
* body.scm (make-c99-lexer-generator): pass pragma always, if
file mode, then as cpp-stmt, else pass as (pragma "opt-args")
2018-12-28 Matt Wette <mwette@alumni.caltech.edu>
* cxeval.scm (eval-sizeof-expr): updated for (string "abc" "def")
2018-11-21 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): knr was restored and then removed;
__attributes__ will appear in decl-spec-list now
2018-11-17 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): remove K&R function definition for now: it
generates a parser that does not work with attribute-specifiers
2018-11-16 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): major changes to organization of
declarations in order to deal with wide usage of __attribute__
2018-11-11 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): in attribute-expr replace ($string)
with (string-literal); problem was G_GNUC_DEPRECATED macro in
glib/gmacros.h
* body.scm (make-c99-lexer-generator): changed cpi-push,shift,pop
to cpi-push-x,shift-x,pop-x; added cpi-push, cpi-pop and calls to
properly scope typedefs; needed to deal with local typedefs in glib.h
2018-10-30 Matt Wette <mwette@alumni.caltech.edu>
* pprint.scm (pretty-print-c99): If comments look like they were
generated with `//' then use that.
2018-10-22 Matt Wette <mwette@alumni.caltech.edu>
* cxeval.scm (eval-sizeof-type): was returning #t, should return
the integer size; still needs work on random typedefs
2018-10-12 Matt Wette <mwette@alumni.caltech.edu>
* cpp.scm (rtokl->string): handle comments from scan-cpp-input
(scan-cpp-input): add keyword arg to pass through comments, and
now comments are not necessarily ignored
2018-09-05 Matt Wette <mwette@alumni.caltech.edu>
* util1.scm (get-gcc-cpp-defs): removed dependence on regex
2018-04-05 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): Committed major surgery to add handling of
attribute specifiers to be returned as attributes like
(@ ("packed" "") ("aligned" "(__alignof__(long long))"))
2018-03-10 Matt Wette <mwette@alumni.caltech.edu>
* body.scm (gen-c-lexer): Worked on x-def usage. I'm still unsure
if read-c-ident logic is all correct.
2018-02-19 Matt Wette <mwette@alumni.caltech.edu>
* ../../../../examples/nyacc/lang/c99/ffi-help.scm
(mtail->bs-desc): bug in (pointer-to typename) to (assoc-ref map
name) from (assoc-ref name map)
2017-12-23 Matt Wette <mwette@alumni.caltech.edu>
* pprint.scm (pretty-print-c99): added initializer and
initializer-list, and removed (comp declr initr)
2017-12-13 Matt Wette <mwette@alumni.caltech.edu>
* util1.scm (get-gcc-inc-dirs): update to use -Wp,-v. Note this
may break because it uses "2>&1" to get stderr. check w/ csh
please -- works for me
2017-12-10 Matt Wette <mwette@alumni.caltech.edu>
* munge.scm: note: at some point in the past changed util2.scm to
munge.scm
2017-11-18 Matt Wette <mwette@alumni.caltech.edu>
* cpp.scm (read-rest): new procedure to replace get-string-all
from (ice-9 textual-ports); remove use-module (ice-9 textual-ports)
2017-11-15 Matt Wette <mwette@alumni.caltech.edu>
* pprint.scm (pretty-print-c99): added case for wide char types
2017-11-13 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): added lone `;' in structs and unions
(struct-declaration-list production)
2017-11-11 Matt Wette <mwette@alumni.caltech.edu>
* body.scm (gen-c-lexer): Since include files now have <> or "" I
need to strip them off before looking through the helper list.
* cpp.scm (expand-cpp-macro-ref): Fixed, once again, the def-bwl.c
bug reported by Jan N:
was:
(or (expand-cpp-macro-ref repl defs (cons repl used)) repl)
is:
(or (expand-cpp-macro-ref repl defs used) repl)
2017-09-20 Matt Wette <mwette@alumni.caltech.edu>
* pprint.scm (pretty-print-c99): added enum-ref
2017-09-04 Matt Wette <mwette@alumni.caltech.edu>
* util2.scm (expand-specl-typerefs): fixed c99-06 test 1:
was => int (*baz)(..., now => int *(*bar)(...
2017-08-31 Matt Wette <mwette@alumni.caltech.edu>
* cpp.scm (cpp-define): major bug: was using drain-input when I
should be using get-string-all, same for cpp-line->stmt
2017-08-04 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): add GNU compound statement in paren's as expr
2017-08-01 Matt Wette <mwette@alumni.caltech.edu>
* cpp.scm (eval-cpp-expr): If tree is (char x) then we need to
apply string-ref to get argument for char->integer.
(rtokl->string): ugh. when CPP builds strings we need to escape
characters to reassemble. Not sure I have done it all here.
Needs more testing.
* util2.scm (canize-enum-def-list): enum values more robust:
was (p-expr (fixed "1")) or (neg (p-expr (fixed "1"))) only.
* body.scm (gen-c-lexer): added support for CPP #warning
(find-file-in-dirl): added logic to look in current directory
first, if header.
2017-07-28 Matt Wette <mwette@alumni.caltech.edu>
* cpp.scm (collect-args): when moving from iter1 to iter2 was
neglecting to unread-char the character carried from iter1. Fix
based on bug report from janneke. Thanks again, Jan.
2017-07-28 Wette <mwette@alumni.caltech.edu>
* body.scm (gen-c-lexer): bug report by janneke.
`#undef NAME' not working; was using delete, now acons #f
* mach.scm (c99-spec): bug report by janneke.
ident-like returns (ident ("foo")) instead of (ident "foo");
fixed w/ (car $1) => (sx-ref $1 1)
2017-07-16 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): change declr-fctn to abs-fctn-decl;
declr-fctn-anon to anon-fctn-declr
2017-07-15 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): for type-qualifier-list return
type-qual-list (was decl-spec-list)
2017-07-08 Matt Wette <mwette@alumni.caltech.edu>
* util2.scm (munge-decl): If arg is already udecl just return it.
2017-07-07 Matt Wette <mwette@alumni.caltech.edu>
* util2.scm (canize-enum-def-list): fixed so enums start at 0, was 1
2017-07-01 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): added GNU-C asm extension
2017-06-30 Matt Wette <mwette@alumni.caltech.edu>
* body.scm (gen-c-lexer): handle #define FOO "foo.h" #include FOO
2017-06-29 Matt Wette <mwette@alumni.caltech.edu>
* cpp.scm (eval-cpp-expr): cleaned up bitwise-or,xor,and
(cpp-include): only handled args w/ " or <, now c-ident also
2017-06-17 Matt Wette <mwette@alumni.caltech.edu>
* util2.scm (clean-field-list): fixed bug that would add comments
when there were none at all
2017-06-16 Matt Wette <mwette@alumni.caltech.edu>
* util2.scm (munge-decl): changed (decl to (udecl
2017-06-15 Matt Wette <mwette@alumni.caltech.edu>
* util2.scm (c99-trans-unit->udict): changed to fold-right
(canize-enum-def-list): now working for negative enum vals
2017-06-11 Matt Wette <mwette@alumni.caltech.edu>
* util2.scm (c99-trans-unit->udict): if include was not
getting the include's trans-unit
2017-06-03 Matt Wette <mwette@alumni.caltech.edu>
* body.scm (gen-c-lexer): fixed cpp expansion to allow
re-expansion when replacement is ident-like. This allows
#define ABC(X,Y) ((X)+(Y))
#define DEF ABC
int main { int x = DEF(1,2); }
reference: janneke bug report on def-bwl.c
2017-05-04 Matt Wette <mwette@alumni.caltech.edu>
* pprint.scm (pretty-print-c99): removed double spacing
in printed declarations
2017-03-11 Matt Wette <mwette@alumni.caltech.edu>
* parser.scm (parse-c99): added mode keyword argument to
gen-c-lexer, file mode would not have been working ...
2017-02-28 Matt Wette <mwette@alumni.caltech.edu>
* pprint.scm: (binary 'd-del .. => (binary 'd-sel
2017-02-22 Matt Wette <mwette@alumni.caltech.edu>
* cpp.scm (rtokl->string): added handler for 'string
* body.scm: added 'skip state so that if skipping #if
then no CPP if or elif arguments are evaluated
* cpp.scm: parse 0L numbers, convert c numbers (e.g.,
123L) to scheme so that string->number works. I need to update
cnumstr->snumstr in nyacc/lex.scm.
2017-02-16 Matt Wette <mwette@alumni.caltech.edu>
* cpp.scm (rtokl->string): now handled symb ## arg ## symb
(scan-cpp-input): skip-il-ws after #\(
2017-01-18 Matt Wette <mwette@alumni.caltech.edu>
* parser.scm: check for EOF in end of CPP line
* mach.scm (c99-spec): decl for translation unit was
updated to allow programs with no declarations or statements
2017-01-07 Matt Wette <mwette@alumni.caltech.edu>
* body.scm (read-cpp-line): cpp statement should not
include newline? Changed to unread final newline.
* mach.scm (c99-spec): from
2017-01-07 Jan Nieuwenhuizen <janneke@gnu.org>
mising unquote in output sx for goto: `(goto $2) => `(goto ,$2)
2017-01-06 Matt Wette <mwette@alumni.caltech.edu>
* parser.scm: default parser #:mode is now 'code; done
since the CPP should now be working (??)
2017-01-02 Matt Wette <mwette@alumni.caltech.edu>
* mach.scm (c99-spec): added hooks (cpp-ok!, no-cpp!) to
provide handshaking between parser and lexer wrt when the lexer
can pass CPP statements to the parser
* cppbody.scm (expand-cpp-mref): skip ws between ident
and left paren
2017-01-01 Matt Wette <mwette@alumni.caltech.edu>
* body.scm (gen-c-lexer): in code mode now expands includes
* pprint.scm (pretty-print-c99): added enum-dev w/o name
Copyright (C) 2017 Matthew R. Wette
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
notice and this notice are preserved. This file is offered as-is,
without any warranty.

50
sysa/mes-0.22/module/nyacc/lang/c99/README Normal file
View file

@ -0,0 +1,50 @@
nyacc/lang/c99/
Copyright (C) 2015,2016,2019 Matthew R. Wette
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
notice and this notice are preserved. This file is offered as-is,
without any warranty.
manifest:
cpp.scm C preprocessor using tables
includes: cpp-act.scm,cpp-tab.scm
cppmach.scm CPP expression grammer, machine and act/tab file generation
mach.scm C grammer, machine and act/tab file generation
depends: cpp.scm
parser.scm C file parser, C expression parser
includes: c99-act.scm, c99-tab.scm, c99x-act.scm, c99-tab.scm,
body.scm
depends: cpp.scm
body.scm included in parser.scm
cxmach.scm parse constant expressions
cxeval.scm evaluate constant expressions
pprint.scm C pretty printer, from SXML output of above parsers
util.scm utilities merge, remove trees from included files
munge.scm utilities to process information in trees
ffi-help.scm generate FFI api code from C headers
mach.d/
cpp-act.scm cpp expression parser actions, generated from cppmach.scm
cpp-tab.scm cpp expression parser tables, generated from cppmach.scm
c99-act.scm parser actions, generated from mach.scm
c99-tab.scm parser tables, generated from mach.scm
c99x-act.scm expression parser actions, generated from mach.scm
c99x-tab.scm expression parser tables, generated from mach.scm
c99cx-act.scm constant expression parser actions, generated from cxmach.scm
c99cx-tab.scm constant expression parser tables, generated from cxmach.scm

653
sysa/mes-0.22/module/nyacc/lang/c99/body.scm Normal file
View file

@ -0,0 +1,653 @@
;;; lang/c99/body.scm - parser body, inserted in parser.scm
;; Copyright (C) 2015-2019 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.
;;; Notes:
;; Notes on the code design may be found in doc/nyacc/lang/c99-hg.info
;; @section The C99 Parser Body
;; This code provides the front end to the C99 parser, including the lexical
;; analyzer and optional CPP processing. In @code{'file} mode the lex'er
;; passes CPP statements to the parser; in @code{'code} mode the lex'er
;; parses and evaluates the CPP statements. In the case of included files
;; (e.g., via @code{#include <file.h>}) the include files are parsed if
;; not in @code{inc-help}. The a-list @code{inc-help} maps
;; include file names to typenames (e.g., @code{stdio.h} to @code{FILE}) and
;; CPP defines (e.g., "INT_MAX=12344").
;; issue w/ brlev: not intended to beused with `extern "C" {'
;;; Code:
(use-modules (nyacc lang sx-util))
(use-modules (nyacc lang util))
(use-modules ((srfi srfi-1) #:select (fold-right append-reverse)))
(use-modules ((srfi srfi-9) #:select (define-record-type)))
(use-modules (ice-9 pretty-print)) ; for debugging
(define (sf fmt . args) (apply simple-format #t fmt args))
(define pp pretty-print)
;; C parser info (?)
(define-record-type cpi
(make-cpi-1)
cpi?
(debug cpi-debug set-cpi-debug!) ; debug #t #f
(shinc cpi-shinc set-cpi-shinc!) ; show includes
(defines cpi-defs set-cpi-defs!) ; #defines
(incdirs cpi-incs set-cpi-incs!) ; #includes
(inc-tynd cpi-itynd set-cpi-itynd!) ; a-l of incfile => typenames
(inc-defd cpi-idefd set-cpi-idefd!) ; a-l of incfile => defines
(ptl cpi-ptl set-cpi-ptl!) ; parent typename list
(ctl cpi-ctl set-cpi-ctl!) ; current typename list
(blev cpi-blev set-cpi-blev!) ; curr brace/block level
)
;;.@deffn Procedure split-cppdef defstr => (<name> . <repl>)| \
;; (<name> <args> . <repl>)|#f
;; Convert define string to a dict item. Examples:
;; @example
;; "ABC=123" => '("ABC" . "123")
;; "MAX(X,Y)=((X)>(Y)?(X):(Y))" => ("MAX" ("X" "Y") . "((X)>(Y)?(X):(Y))")
;; @end example
;; @end deffn
(define (split-cppdef defstr)
(let ((x2st (string-index defstr #\()) ; start of args
(x2nd (string-index defstr #\))) ; end of args
(x3 (string-index defstr #\=))) ; start of replacement
(cond
((not x3) #f)
((and x2st x3)
;;(if (not (eq? (1+ x2nd) x3)) (c99-err "bad CPP def: ~S" defstr))
(cons* (substring defstr 0 x2st)
(string-split
(string-delete #\space (substring defstr (1+ x2st) x2nd))
#\,)
(substring defstr (1+ x3))))
(else
(cons (substring defstr 0 x3) (substring defstr (1+ x3)))))))
;; @deffn Procedure make-cpi debug defines incdirs inchelp
;; I think there is a potential bug here in that the alist of cpp-defs/helpers
;; should be last-in-first-seen ordered. Probably helpers low prio.
;; The (CPP) defines can appear as pairs: then they have already been split.
;; (This is used by @code{parse-c99x}.)
;; @end deffn
(define (make-cpi debug shinc defines incdirs inchelp)
;; convert inchelp into inc-file->typenames and inc-file->defines
;; Any entry for an include file which contains `=' is considered
;; a define; otherwise, the entry is a typename.
(define (split-helper helper)
(let ((file (car helper)))
(let loop ((tyns '()) (defs '()) (ents (cdr helper)))
(cond
((null? ents) (values (cons file tyns) (cons file defs)))
((split-cppdef (car ents)) =>
(lambda (def) (loop tyns (cons def defs) (cdr ents))))
(else (loop (cons (car ents) tyns) defs (cdr ents)))))))
(define (split-if-needed def)
(if (pair? def) def (split-cppdef def)))
(let* ((cpi (make-cpi-1)))
(set-cpi-debug! cpi debug) ; print states debug
(set-cpi-shinc! cpi shinc) ; print includes
(set-cpi-defs! cpi (map split-if-needed defines)) ; def's as pairs
(set-cpi-incs! cpi incdirs) ; list of include dir's
(set-cpi-ptl! cpi '()) ; list of lists of typenames
(set-cpi-ctl! cpi '()) ; list of current typenames
(set-cpi-blev! cpi 0) ; brace/block level
;; Break up the helpers into typenames and defines.
(let loop ((itynd '()) (idefd '()) (helpers inchelp))
(cond ((null? helpers)
(set-cpi-itynd! cpi itynd)
(set-cpi-idefd! cpi idefd))
(else
(call-with-values
(lambda () (split-helper (car helpers)))
(lambda (ityns idefs)
(loop (cons ityns itynd) (cons idefs idefd) (cdr helpers)))))))
;; Assign builtins.
(and=> (assoc-ref (cpi-itynd cpi) "__builtin")
(lambda (tl) (set-cpi-ctl! cpi (append tl (cpi-ctl cpi)))))
(and=> (assoc-ref (cpi-idefd cpi) "__builtin")
(lambda (tl) (set-cpi-defs! cpi (append tl (cpi-defs cpi)))))
cpi))
(define *info* (make-fluid))
(define cpi-inc-blev!
(case-lambda
((info) (set-cpi-blev! info (1+ (cpi-blev info))))
(() (cpi-inc-blev! (fluid-ref *info*)))))
(define cpi-dec-blev!
(case-lambda
((info) (set-cpi-blev! info (1- (cpi-blev info))))
(() (cpi-dec-blev! (fluid-ref *info*)))))
(define cpi-top-blev?
(case-lambda
((info) (zero? (cpi-blev info)))
(() (cpi-top-blev? (fluid-ref *info*)))))
(define cpi-push
(case-lambda
((info)
(set-cpi-ptl! info (cons (cpi-ctl info) (cpi-ptl info)))
(set-cpi-ctl! info '())
#t)
(() (cpi-push (fluid-ref *info*)))))
(define cpi-pop
(case-lambda
((info)
(set-cpi-ctl! info (car (cpi-ptl info)))
(set-cpi-ptl! info (cdr (cpi-ptl info)))
#t)
(() (cpi-pop (fluid-ref *info*)))))
(define (cpi-push-x) ;; on #if
;;(sf "\ncpi-push-x:\n") (pp (fluid-ref *info*))
(let ((cpi (fluid-ref *info*)))
(set-cpi-ptl! cpi (cons (cpi-ctl cpi) (cpi-ptl cpi)))
(set-cpi-ctl! cpi '())))
(define (cpi-shift-x) ;; on #elif #else
;;(sf "\ncpi-shift-x:\n") (pp (fluid-ref *info*))
(set-cpi-ctl! (fluid-ref *info*) '()))
(define (cpi-pop-x) ;; on #endif
;;(sf "\ncpi-pop-x:\n") (pp (fluid-ref *info*))
(let ((cpi (fluid-ref *info*)))
(set-cpi-ctl! cpi (append (cpi-ctl cpi) (car (cpi-ptl cpi))))
(set-cpi-ptl! cpi (cdr (cpi-ptl cpi)))))
;; @deffn {Procedure} typename? name
;; Called by lexer to determine if symbol is a typename.
;; Check current sibling for each generation.
;; @end deffn
(define (typename? name)
(let ((cpi (fluid-ref *info*)))
(if (member name (cpi-ctl cpi)) #t
(let loop ((ptl (cpi-ptl cpi)))
(if (null? ptl) #f
(if (member name (car ptl)) #t
(loop (cdr ptl))))))))
;; @deffn {Procedure} add-typename name
;; Helper for @code{save-typenames}.
;; @end deffn
(define (add-typename name)
(let ((cpi (fluid-ref *info*)))
(set-cpi-ctl! cpi (cons name (cpi-ctl cpi)))))
;; @deffn {Procedure} find-new-typenames decl
;; Helper for @code{save-typenames}.
;; Given declaration return a list of new typenames (via @code{typedef}).
;; @end deffn
(define (find-new-typenames decl)
;; like declr-id in util2.scm
(define (declr->id-name declr)
(case (car declr)
((ident) (sx-ref declr 1))
((init-declr) (declr->id-name (sx-ref declr 1)))
((comp-declr) (declr->id-name (sx-ref declr 1)))
((array-of) (declr->id-name (sx-ref declr 1)))
((ptr-declr) (declr->id-name (sx-ref declr 2)))
((ftn-declr) (declr->id-name (sx-ref declr 1)))
((scope) (declr->id-name (sx-ref declr 1)))
(else (error "coding bug: " declr))))
;;(sf "\ndecl:\n") (pp decl)
(let* ((spec (sx-ref decl 1))
(stor (sx-find 'stor-spec spec))
(id-l (sx-ref decl 2)))
(if (and stor (eqv? 'typedef (caadr stor)))
(let loop ((res '()) (idl (cdr id-l)))
(if (null? idl) res
(loop (cons (declr->id-name (sx-ref (car idl) 1)) res)
(cdr idl))))
'())))
;; @deffn {Procedure} save-typenames decl
;; Save the typenames for the lexical analyzer and return the decl.
;; @end deffn
(define (save-typenames decl)
;; This finds typenames using @code{find-new-typenames} and adds via
;; @code{add-typename}. Then return the decl.
(for-each add-typename (find-new-typenames decl))
decl)
;; (string "abc" "def") -> (string "abcdef")
;; In the case that declaration-specifiers only returns a list of
;; attribute-specifiers then this has to be an empty-statemnet with
;; attributes. See:
;; https://gcc.gnu.org/onlinedocs/gcc-8.2.0/gcc/Statement-Attributes.html
(define (XXX-only-attr-specs? specs)
(let loop ((specs specs))
(cond
((null? specs) #t)
((not (eqv? 'attributes (sx-tag (car specs)))) #f)
(else (loop (cdr specs))))))
;; ------------------------------------------------------------------------
(define (c99-err . args)
(apply throw 'c99-error args))
;; @deffn {Procedure} read-cpp-line ch => #f | (cpp-xxxx)??
;; Given if ch is #\# read a cpp-statement.
;; The standard implies that comments are tossed here but we keep them
;; so that they can end up in the pretty-print output.
;; @end deffn
(define (read-cpp-line ch)
(if (not (eq? ch #\#)) #f
(let loop ((cl '()) (ch (read-char)))
(cond
;;((eof-object? ch) (throw 'cpp-error "CPP lines must end in newline"))
((eof-object? ch) (reverse-list->string cl))
((eq? ch #\newline) (unread-char ch) (reverse-list->string cl))
((eq? ch #\\)
(let ((c2 (read-char)))
(if (eq? c2 #\newline)
(loop cl (read-char))
(loop (cons* c2 ch cl) (read-char)))))
((eq? ch #\/) ;; swallow comments, even w/ newlines
(let ((c2 (read-char)))
(cond
((eqv? c2 #\*)
(let loop2 ((cl2 (cons* #\* #\/ cl)) (ch (read-char)))
(cond
((eq? ch #\*)
(let ((c2 (read-char)))
(if (eqv? c2 #\/)
(loop (cons* #\/ #\* cl2) (read-char)) ;; keep comment
(loop2 (cons #\* cl2) c2))))
(else
(loop2 (cons ch cl2) (read-char))))))
(else
(loop (cons #\/ cl) c2)))))
(else (loop (cons ch cl) (read-char)))))))
(define (def-xdef? name mode)
(not (eqv? mode 'file)))
;; @deffn {Procedure} make-c99-lexer-generator match-table raw-parser => proc
;; This generates a procedure which has the signature
;; @example
;; proc [#:mode mode] [#:xdef? proc] => procedure
;; @end example
;; to be passed to the c99 parsers.
;; The proc will generate a context-sensitive lexer for the C99 language.
;; The arg @var{match-table} is an element of a specification returned
;; by @code{make-lalr-spec} or machine generated by @code{make-lalr-machine}.
;; The argument @var{raw-parse} must be ...
;; The generated
;; lexical analyzer reads and passes comments and optionally CPP statements
;; to the parser. The keyword argument @var{mode} will determine if CPP
;; statements are passed (@code{'file} mode) or parsed and executed
;; (@code{'file} mode) as described above. Comments will be passed as
;; ``line'' comments or ``lone'' comments: lone comments appear on a line
;; without code. The @code{xdef?} keyword argument allows user to pass
;; a predicate which determines whether CPP symbols in code are expanded.
;; The default predicate is
;; @example
;; (define (def-xdef? mode name) (eqv? mode 'code))
;; @end example
;; @end deffn
(define (make-c99-lexer-generator match-table raw-parser)
;; This gets ugly in order to handle cpp. The CPP will tokenize, expand,
;; then convert back to a string.
;;
;; todo: check if @code{1.3f} gets parsed as a number.
;; todo: I think there is a bug wrt the comment reader because // ... \n
;; will end up in same mode... so after
;; int x; // comment
;; the lexer will think we are not at BOL.
;;
;; The state variable `suppress' is used to suppress re-expansion of input
;; text generated by the CPP macro expander. The CPP replacement text
;; inserted via a string-port on the port stack. When that port is fully
;; read (i.e., the reader sees eof-object) then @var{suppress} is changed
;; to @code{#t}.
(define (getdefs stmts) ; extract defines
(fold-right
(lambda (stmt seed)
;;(sx-match stmt
;; ((cpp-stmt (define . ,rest)) (cons (sx-ref stmt 1) seed))
;; (else seed)))
(if (and (eqv? 'cpp-stmt (sx-tag stmt))
(eqv? 'define (sx-tag (sx-ref stmt 1))))
(cons (sx-ref stmt 1) seed)
seed))
'() stmts))
(let* ((ident-like? (make-ident-like-p read-c-ident))
;;
(strtab (filter-mt string? match-table)) ; strings in grammar
(kwstab (filter-mt ident-like? strtab)) ; keyword strings =>
(keytab (map-mt string->symbol kwstab)) ; keywords in grammar
(chrseq (remove-mt ident-like? strtab)) ; character sequences
(symtab (filter-mt symbol? match-table)) ; symbols in grammar
(chrtab (filter-mt char? match-table)) ; characters in grammar
;;
(read-chseq (make-chseq-reader chrseq))
(assc-$ (lambda (pair)
(cons (assq-ref symtab (car pair)) (cdr pair))))
;;
(t-ident (assq-ref symtab '$ident))
(t-typename (assq-ref symtab 'typename)))
;; mode: 'code|'file|'decl
;; xdef?: (proc name mode) => #t|#f : do we expand #define?
;;(lambda* (#:key (mode 'code) xdef? show-incs)
(define* (lexer #:key (mode 'code) xdef? show-incs)
(define (run-parse)
(let ((info (fluid-ref *info*)))
(raw-parser (lexer #:mode 'decl #:show-incs (cpi-shinc info))
#:debug (cpi-debug info))))
(let ((bol #t) ; begin-of-line condition
(suppress #f) ; parsing cpp expanded text (kludge?)
(ppxs (list 'keep)) ; CPP execution state stack
(info (fluid-ref *info*)) ; info shared w/ parser
;;(brlev 0) ; brace level
(x-def? (cond ((procedure? xdef?) xdef?)
((eq? xdef? #t) (lambda (n m) #t))
(else def-xdef?))))
;; Return the first (tval . lval) pair not excluded by the CPP.
(lambda ()
(define (add-define tree)
(let* ((tail (cdr tree))
(name (car (assq-ref tail 'name)))
(args (assq-ref tail 'args))
(repl (car (assq-ref tail 'repl)))
(cell (cons name (if args (cons args repl) repl))))
(set-cpi-defs! info (cons cell (cpi-defs info)))))
(define (rem-define name)
(set-cpi-defs! info (acons name #f (cpi-defs info))))
(define (apply-helper file)
;; file will include <> or "", need to strip
(let* ((tyns (assoc-ref (cpi-itynd info) file))
(defs (assoc-ref (cpi-idefd info) file)))
(when tyns
(for-each add-typename tyns)
(set-cpi-defs! info (append defs (cpi-defs info))))
tyns))
(define (inc-stmt->file-spec stmt) ;; retain <> or ""
(let* ((arg (cadr stmt)))
(if (ident-like? arg) ;; #include MYFILE
(expand-cpp-macro-ref arg (cpi-defs info))
arg)))
(define (file-spec->file spec)
(substring/shared spec 1 (1- (string-length spec))))
(define (inc-file-spec->path spec next)
(find-incl-in-dirl spec (cpi-incs info) next))
(define (code-if stmt)
(case (car ppxs)
((skip-look skip-done skip) ;; don't eval if excluded
(set! ppxs (cons 'skip ppxs)))
(else
(let* ((defs (cpi-defs info))
(val (eval-cpp-cond-text (cadr stmt) defs
#:inc-dirs (cpi-incs info))))
(if (not val) (c99-err "unresolved: ~S" (cadr stmt)))
(if (eq? 'keep (car ppxs))
(if (zero? val)
(set! ppxs (cons 'skip-look ppxs))
(set! ppxs (cons 'keep ppxs)))
(set! ppxs (cons 'skip-done ppxs))))))
stmt)
(define (code-elif stmt)
(case (car ppxs)
((skip) #t) ;; don't eval if excluded
(else
(let* ((defs (cpi-defs info))
(val (eval-cpp-cond-text (cadr stmt) defs
#:inc-dirs (cpi-incs info))))
(if (not val) (c99-err "unresolved: ~S" (cadr stmt)))
(case (car ppxs)
((skip-look) (if (not (zero? val)) (set-car! ppxs 'keep)))
((keep) (set-car! ppxs 'skip-done))))))
stmt)
(define (code-else stmt)
(case (car ppxs)
((skip-look) (set-car! ppxs 'keep))
((keep) (set-car! ppxs 'skip-done)))
stmt)
(define (code-endif stmt)
(set! ppxs (cdr ppxs))
stmt)
(define* (eval-cpp-incl/here stmt #:optional next) ;; => stmt
(let* ((spec (inc-stmt->file-spec stmt))
(file (file-spec->file spec))
(path (inc-file-spec->path spec next)))
(if show-incs (sferr "include ~A => ~S\n" spec path))
(cond
((apply-helper file) stmt)
((not path) (c99-err "not found: ~S" file))
(else (set! bol #t)
(push-input (open-input-file path))
(if path (sx-attr-add stmt 'path path) stmt)))))
(define* (eval-cpp-incl/tree stmt #:optional next) ;; => stmt
;; include file as a new tree
(let* ((spec (inc-stmt->file-spec stmt))
(file (file-spec->file spec))
(path (inc-file-spec->path spec next)))
(if show-incs (sferr "include ~A => ~S\n" spec path))
(cond
((apply-helper file) stmt)
((not path) (c99-err "not found: ~S" file))
((with-input-from-file path run-parse) =>
(lambda (tree) ;; add tree
(for-each add-define (getdefs tree))
(append (if path (sx-attr-add stmt 'path path) stmt)
(list tree)))))))
(define (eval-cpp-stmt/code stmt) ;; => stmt
(case (car stmt)
((if) (code-if stmt))
((elif) (code-elif stmt))
((else) (code-else stmt))
((endif) (code-endif stmt))
(else
(if (eqv? 'keep (car ppxs))
(case (car stmt)
((include) (eval-cpp-incl/here stmt))
((include-next) (eval-cpp-incl/here stmt 'next))
((define) (add-define stmt) stmt)
((undef) (rem-define (cadr stmt)) stmt)
((error) (c99-err "error: #error ~A" (cadr stmt)))
((warning) (report-error "warning: ~A" (cdr stmt)))
((pragma) stmt)
((line) stmt)
(else
(sferr "stmt: ~S\n" stmt)
(error "nyacc eval-cpp-stmt/code: bad cpp flow stmt")))
stmt))))
(define (eval-cpp-stmt/decl stmt) ;; => stmt
(case (car stmt)
((if) (code-if stmt))
((elif) (code-elif stmt))
((else) (code-else stmt))
((endif) (code-endif stmt))
(else
(if (eqv? 'keep (car ppxs))
(case (car stmt)
((include) ; use tree unless inside braces
(if (cpi-top-blev? info)
(eval-cpp-incl/tree stmt)
(eval-cpp-incl/here stmt)))
((include-next) ; gcc extension
(if (cpi-top-blev? info)
(eval-cpp-incl/tree stmt 'next)
(eval-cpp-incl/here stmt 'next)))
((define) (add-define stmt) stmt)
((undef) (rem-define (cadr stmt)) stmt)
((error) (c99-err "error: #error ~A" (cadr stmt)))
((warning) (report-error "warning: ~A" (cdr stmt)) stmt)
((pragma) stmt) ;; ignore for now
((line) stmt)
(else
(sferr "stmt: ~S\n" stmt)
(error "eval-cpp-stmt/decl: bad cpp flow stmt")))
stmt))))
(define (eval-cpp-stmt/file stmt) ;; => stmt
(case (car stmt)
((if) (cpi-push-x) stmt)
((elif else) (cpi-shift-x) stmt)
((endif) (cpi-pop-x) stmt)
((include) (eval-cpp-incl/tree stmt))
((define) (add-define stmt) stmt)
((undef) (rem-define (cadr stmt)) stmt)
((error) stmt)
((warning) stmt)
((pragma) stmt)
((line) stmt)
(else
(sferr "stmt: ~S\n" stmt)
(error "eval-cpp-stmt/file: bad cpp flow stmt"))))
;; Maybe evaluate the CPP statement.
(define (eval-cpp-stmt stmt)
(with-throw-handler
'cpp-error
(lambda ()
(case mode
((code) (eval-cpp-stmt/code stmt))
((decl) (eval-cpp-stmt/decl stmt))
((file) (eval-cpp-stmt/file stmt))
(else (error "nyacc eval-cpp-stmt: coding error"))))
(lambda (key fmt . rest)
(report-error fmt rest)
(throw 'c99-error "CPP error"))))
;; Predicate to determine if we pass the cpp-stmt to the parser.
;; @itemize
;; If code mode, never
;; If file mode, all except includes between { }
;; If decl mode, only defines and includes outside {}
;; @end itemize
(define (pass-cpp-stmt stmt)
(if (eq? 'pragma (car stmt))
(if (eq? mode 'file)
`(cpp-stmt ,stmt)
`($pragma . ,(cadr stmt)))
(case mode
((code) #f)
((decl) (and (cpi-top-blev? info)
(memq (car stmt) '(include define include-next))
`(cpp-stmt . ,stmt)))
((file) (and
(or (cpi-top-blev? info)
(not (memq (car stmt) '(include include-next))))
`(cpp-stmt . ,stmt)))
(else (error "nyacc pass-cpp-stmt: coding error")))))
;; Composition of @code{read-cpp-line} and @code{eval-cpp-line}.
(define (read-cpp-stmt ch)
(and=> (read-cpp-line ch) cpp-line->stmt))
(define (read-token)
(let loop ((ch (read-char)))
(cond
((eof-object? ch)
(set! suppress #f)
(if (pop-input)
(loop (read-char))
(assc-$ '($end . "#<eof>"))))
((eq? ch #\newline) (set! bol #t) (loop (read-char)))
((char-set-contains? c:ws ch) (loop (read-char)))
(bol
(set! bol #f)
(cond ;; things that require bol
((read-c-comm ch #t #:skip-prefix #t) => assc-$)
((read-cpp-stmt ch) =>
(lambda (stmt)
(cond ((pass-cpp-stmt (eval-cpp-stmt stmt)) => assc-$)
(else (loop (read-char))))))
(else (loop ch))))
((read-c-chlit ch) => assc-$) ; before ident for [ULl]'c'
((read-c-ident ch) =>
(lambda (name)
(let ((symb (string->symbol name))
(defs (cpi-defs info)))
(cond
((and (not suppress)
(x-def? name mode)
(expand-cpp-macro-ref name defs))
=> (lambda (repl)
(set! suppress #t) ; don't rescan
(push-input (open-input-string repl))
(loop (read-char))))
((assq-ref keytab symb)
;;^minor bug: won't work on #define keyword xxx
;; try (and (not (assoc-ref name defs))
;; (assq-ref keytab symb))
=> (lambda (t) (cons t name)))
((typename? name)
(cons t-typename name))
(else
(cons t-ident name))))))
((read-c-num ch) => assc-$)
((read-c-string ch) => assc-$)
((read-c-comm ch #f #:skip-prefix #t) => assc-$)
;; Keep track of brace level and scope for typedefs.
((and (char=? ch #\{)
(eqv? 'keep (car ppxs)) (cpi-inc-blev! info)
#f) #f)
((and (char=? ch #\})
(eqv? 'keep (car ppxs)) (cpi-dec-blev! info)
#f) #f)
((read-chseq ch) => identity)
((assq-ref chrtab ch) => (lambda (t) (cons t (string ch))))
((eqv? ch #\\) ;; C allows \ at end of line to continue
(let ((ch (read-char)))
(cond ((eqv? #\newline ch) (loop (read-char))) ;; extend line
(else (unread-char ch) (cons #\\ "\\"))))) ;; parse err
(else (cons ch (string ch))))))
;; Loop between reading tokens and skipping tokens via CPP logic.
(let loop ((pair (read-token)))
;;(report-error "lx loop=>~S" (list pair))
(case (car ppxs)
((keep)
pair)
((skip-done skip-look skip)
(loop (read-token)))
(else (error "make-c99-lexer-generator: coding error")))))))
lexer))
;; --- last line ---

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

@ -0,0 +1,623 @@
;;; lang/c/cpp.scm - C preprocessor
;; Copyright (C) 2015-2019 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.
;;; Notes:
;; C preprocessor macro expansion and condition text parse-and-eval
;; ref: https://gcc.gnu.org/onlinedocs/gcc-3.0.1/cpp_3.html
;;; Code:
(define-module (nyacc lang c99 cpp)
#:export (
cpp-line->stmt
eval-cpp-cond-text
expand-cpp-macro-ref
parse-cpp-expr
find-incl-in-dirl
scan-arg-literal
eval-cpp-expr)
#:use-module (nyacc parse)
#:use-module (nyacc lex)
#:use-module (nyacc lang sx-util)
#:use-module ((nyacc lang util) #:select (report-error)))
(cond-expand
(guile-2
(use-modules (rnrs arithmetic bitwise))
(use-modules (system base pmatch)))
(else
(use-modules (ice-9 optargs))
(use-modules (nyacc compat18))))
(define c99-std-defs
'("__DATE__" "__FILE__" "__LINE__" "__STDC__" "__STDC_HOSTED__"
"__STDC_VERSION__" "__TIME__"))
(define (c99-std-def? str)
(let loop ((defs c99-std-defs))
(cond
((null? defs) #f)
((string=? (car defs) str) #t)
(else (loop (cdr defs))))))
(define (c99-std-val str)
(cond
((string=? str "__DATE__") "M01 01 2001")
((string=? str "__FILE__") "(unknown)")
((string=? str "__LINE__") "0")
((string=? str "__STDC__") "1")
((string=? str "__STDC_HOSTED__") "0")
((string=? str "__STDC_VERSION__") "201701")
((string=? str "__TIME__") "00:00:00")
(else #f)))
(define inline-whitespace (list->char-set '(#\space #\tab)))
;;.@deffn {Procedure} skip-il-ws ch
;; Skip in-line whitespace
;; @end deffn
(define (skip-il-ws ch)
(cond
((eof-object? ch) ch)
((char-set-contains? inline-whitespace ch) (skip-il-ws (read-char)))
(else ch)))
;; This reads the rest of the input, with ch and returns a string;
;; Replaces get-string-all from (ice-9 textual-ports).
(define (read-rest ch)
(list->string (let loop ((ch ch))
(if (eof-object? ch) '()
(cons ch (loop (read-char)))))))
;; Not sure about this. We want to turn a list of tokens into a string
;; with proper escapes.
(define (esc-c-str str)
(list->string
(string-fold-right
(lambda (ch chl)
(case ch
((#\\ #\") (cons* #\\ ch chl))
(else (cons ch chl))))
'() str)))
(define ident-like? (make-ident-like-p read-c-ident))
;; @deffn {Procedure} read-ellipsis ch
;; read ellipsis
;; @end deffn
(define (read-ellipsis ch)
(cond
((eof-object? ch) #f)
((char=? ch #\.) (read-char) (read-char) "...") ; assumes correct syntax
(else #f)))
;; @deffn {Procedure} find-incl-in-dirl file dirl [next] => path
;; Find path to include file expression, (i.e., @code{<foo.h>} or
;; @code{"foo.h"}. If @code{"foo.h"} form look in current directory first.
;; If @var{next} (default false) is true then remove current directory from
;; search path.
;; @*Refs:
;; @itemize
;; @item https://gcc.gnu.org/onlinedocs/cpp/Search-Path.html
;; @item https://gcc.gnu.org/onlinedocs/cpp/Wrapper-Headers.html
;; @end itemize
;; @end deffn
(define* (find-incl-in-dirl file dirl #:optional (next #f))
(let* ((cid (and=> (port-filename (current-input-port)) dirname))
(file-type (string-ref file 0)) ;; #\< or #\"
(file-name (substring file 1 (1- (string-length file))))
(dirl (if (and cid (char=? #\" file-type)) (cons cid dirl) dirl)))
(let loop ((dirl dirl))
(if (null? dirl) #f
(if (and next (string=? (car dirl) cid))
(loop (cdr dirl))
(let ((p (string-append (car dirl) "/" file-name)))
(if (access? p R_OK) p (loop (cdr dirl)))))))))
;; @deffn {Procedure} cpp-define
;; Reads CPP define from current input and generates a cooresponding sxml
;; expression.
;; @example
;; (define (name "ABC") (repl "123"))
;; OR
;; (define (name "ABC") (args "X" "Y") (repl "X+Y"))
;; @example
;; @end deffn
(define (cpp-define)
(define (p-args la) ;; parse args
(if (eq? la #\()
(let loop ((args '()) (la (skip-il-ws (read-char))))
(cond
((eq? la #\)) (reverse args))
((read-c-ident la) =>
(lambda (arg) (loop (cons arg args) (skip-il-ws (read-char)))))
((read-ellipsis la) =>
(lambda (arg) (loop (cons arg args) (skip-il-ws (read-char)))))
((eq? la #\,) (loop args (skip-il-ws (read-char))))))
(begin (if (char? la) (unread-char la)) #f)))
(define (p-rest la) (read-rest la))
(let* ((name (let loop ((ch (skip-il-ws (read-char))))
(cond
((eof-object? ch) (throw 'cpp-error "bad #define"))
((read-c-ident ch))
((cpp-comm-skipper ch) (loop (skip-il-ws (read-char))))
(else (throw 'cpp-error "bad #define")))))
(args (or (p-args (read-char)) '()))
(repl (p-rest (skip-il-ws (read-char)))))
(if (pair? args)
`(define (name ,name) (args . ,args) (repl ,repl))
`(define (name ,name) (repl ,repl)))))
;; @deffn {Procedure} cpp-include
;; Parse CPP include statement.
(define (cpp-include)
(define (loop cl ch end-ch)
(if (eq? ch end-ch) (reverse-list->string (cons ch cl))
(loop (cons ch cl) (read-char) end-ch)))
(let ((ch (skip-il-ws (read-char))))
(cond
((char=? ch #\<) (loop (list #\<) (read-char) #\>))
((char=? ch #\") (loop (list #\") (read-char) #\"))
((read-c-ident ch))
(else (throw 'cpp-error "bad include")))))
;; @deffn {Procedure} cpp-line->stmt line defs => (stmt-type text)
;; Parse a line from a CPP statement and return a parse tree.
;; @example
;; (parse-cpp-stmt "define X 123") => (define "X" "123")
;; (parse-cpp-stmt "if defined(A) && defined(B) && defined(C)"
;; => (if "defined(A) && defined(B) && defined(C)")
;; @end example
;; To evaluate the @code{if} statements use @code{parse-cpp-expr} and
;; @code{eval-cpp-expr}.
;; @end deffn
(define (cpp-line->stmt line)
(define (rd-ident) (read-c-ident (skip-il-ws (read-char))))
(define (rd-num) (and=> (read-c-num (skip-il-ws (read-char))) cdr))
(define (rd-rest) (read-rest (skip-il-ws (read-char))))
(with-input-from-string line
(lambda ()
(let ((ch (skip-il-ws (read-char))))
(cond
((read-c-ident ch) =>
(lambda (cmds)
(let ((cmd (string->symbol cmds)))
(case cmd
((include) `(include ,(cpp-include)))
((include_next) `(include-next ,(cpp-include)))
((define) (cpp-define))
((undef) `(undef ,(rd-ident)))
((ifdef)
`(if ,(string-append "defined(" (rd-ident) ")" (rd-rest))))
((ifndef)
`(if ,(string-append "!defined(" (rd-ident) ")" (rd-rest))))
((if elif else endif line error warning pragma)
(list cmd (rd-rest)))
(else
(list 'warning (simple-format #f "unknown CPP: ~S" line)))))))
((read-c-num ch) => (lambda (num) `(line ,num ,(rd-rest))))
(else (error "nyacc cpp-line->stmt: missing code")))))))
(include-from-path "nyacc/lang/c99/mach.d/cpp-tab.scm")
(include-from-path "nyacc/lang/c99/mach.d/cpp-act.scm")
(define cpp-raw-parser
(make-lalr-parser (acons 'act-v cpp-act-v cpp-tables)))
(define (cpp-err fmt . args)
(apply throw 'cpp-error fmt args))
;; Since we want to be able to get CPP statements with comment in tact
;; (e.g., for passing to @code{pretty-print-c99}) we need to remove
;; comments when parsing CPP expressions. We convert a comm-reader
;; into a comm-skipper here. And from that generate a lexer generator.
(define cpp-comm-skipper
(let ((reader (make-comm-reader '(("/*" . "*/")))))
(lambda (ch)
(reader ch #f))))
;; generate a lexical analyzer per string
(define gen-cpp-lexer
(make-lexer-generator cpp-mtab
#:comm-skipper cpp-comm-skipper
#:chlit-reader read-c-chlit
#:num-reader read-c-num))
;; @deffn {Procedure} parse-cpp-expr text => tree
;; Given a string returns a cpp parse tree. This is called by
;; @code{eval-cpp-expr}. The text will have had all CPP defined symbols
;; expanded already so no identifiers should appear in the text.
;; A @code{cpp-error} will be thrown if a parse error occurs.
;; @end deffn
(define (parse-cpp-expr text)
(with-throw-handler
'nyacc-error
(lambda ()
(with-input-from-string text
(lambda () (cpp-raw-parser (gen-cpp-lexer)))))
(lambda (key fmt . args)
(apply throw 'cpp-error fmt args))))
;; @deffn {Procedure} eval-cpp-expr tree [options] => datum
;; Evaluate a tree produced from @code{parse-cpp-expr}.
;; Options include optional dictionary for defines and values
;; and @code{#:inc-dirs} for @code{has_include} etc
;; @end deffn
(define* (eval-cpp-expr tree #:optional (dict '()) #:key (inc-dirs '()))
(letrec
((tx (lambda (tr ix) (sx-ref tr ix)))
(tx1 (lambda (tr) (sx-ref tr 1)))
(ev (lambda (ex ix) (eval-expr (sx-ref ex ix))))
(ev1 (lambda (ex) (ev ex 1))) ; eval expr in arg 1
(ev2 (lambda (ex) (ev ex 2))) ; eval expr in arg 2
(ev3 (lambda (ex) (ev ex 3))) ; eval expr in arg 3
(eval-expr
(lambda (tree)
(case (car tree)
((fixed) (string->number (cnumstr->scm (tx1 tree))))
((char) (char->integer (string-ref (tx1 tree) 0)))
((defined) (if (assoc-ref dict (tx1 tree)) 1 0))
((has-include)
(if (find-incl-in-dirl (tx1 tree) inc-dirs #f) 1 0))
((has-include-next)
(if (find-incl-in-dirl (tx1 tree) inc-dirs #t) 1 0))
((pre-inc post-inc) (1+ (ev1 tree)))
((pre-dec post-dec) (1- (ev1 tree)))
((pos) (ev1 tree))
((neg) (- (ev1 tree)))
((not) (if (zero? (ev1 tree)) 1 0))
((mul) (* (ev1 tree) (ev2 tree)))
((div) (/ (ev1 tree) (ev2 tree)))
((mod) (modulo (ev1 tree) (ev2 tree)))
((add) (+ (ev1 tree) (ev2 tree)))
((sub) (- (ev1 tree) (ev2 tree)))
((lshift) (bitwise-arithmetic-shift-left (ev1 tree) (ev2 tree)))
((rshift) (bitwise-arithmetic-shift-right (ev1 tree) (ev2 tree)))
((lt) (if (< (ev1 tree) (ev2 tree)) 1 0))
((le) (if (<= (ev1 tree) (ev2 tree)) 1 0))
((gt) (if (> (ev1 tree) (ev2 tree)) 1 0))
((ge) (if (>= (ev1 tree) (ev2 tree)) 1 0))
((eq) (if (= (ev1 tree) (ev2 tree)) 1 0))
((ne) (if (= (ev1 tree) (ev2 tree)) 0 1))
((bitwise-not) (lognot (ev1 tree)))
((bitwise-or) (logior (ev1 tree) (ev2 tree)))
((bitwise-xor) (logxor (ev1 tree) (ev2 tree)))
((bitwise-and) (logand (ev1 tree) (ev2 tree)))
((or) (if (and (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1))
((and) (if (or (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1))
((cond-expr) (if (zero? (ev1 tree)) (ev3 tree) (ev2 tree)))
;; hacks for use in util2.scm:canize-enum-def-list:
;; If ident is defined then it should have already been expanded.
;; So then only enum defs remain which should be valid expressions.
((ident) (or (and=> (assoc-ref dict (tx1 tree)) string->number) 0))
((p-expr) (ev1 tree))
((cast) (ev2 tree))
(else (error "nyacc eval-cpp-expr: incomplete implementation"))))))
(eval-expr tree)))
;;.@deffn {Procedure} rtokl->string reverse-token-list => string
;; Convert reverse token-list to string.
;; @end deffn
(define (rtokl->string tokl)
;; Turn reverse chl into a string and insert it into the string list stl.
(define (add-chl chl stl)
(if (null? chl) stl (cons (list->string chl) stl)))
;; Works like this: Scan through the list of tokens (key-val pairs or
;; lone characters). Lone characters are collected in a list (@code{chl});
;; pairs are converted into strings and combined with list of characters
;; into a list of strings. When done the list of strings is combined to
;; one string. (The token 'argval is expansion of argument.)
(let loop ((stl '()) ; list of strings to reverse-append
(chl '()) ; char list
(nxt #f) ; next string to add after chl
(tkl tokl)) ; input token list
(cond
(nxt
(loop (cons nxt (add-chl chl stl)) '() #f tkl))
((null? tkl)
(apply string-append (add-chl chl stl)))
((char? (car tkl))
(loop stl (cons (car tkl) chl) nxt (cdr tkl)))
(else
(pmatch tkl
((($ident . ,rval) $dhash ($ident . ,lval) . ,rest)
(loop stl chl nxt
(acons '$ident (string-append lval rval) (list-tail tkl 3))))
((($ident . ,arg) $hash . ,rest)
(loop stl chl (string-append "\"" arg "\"") (list-tail tkl 2)))
((($ident . ,iden) ($ident . ,lval) . ,rest)
(loop stl chl iden rest))
((($ident . ,iden) . ,rest)
(loop stl chl iden rest))
((($string . ,val) . ,rest)
(loop stl (cons #\" chl) (esc-c-str val) (cons #\" rest)))
((($echo . ,val) . ,rest)
(loop stl chl val rest))
(($space $space . ,rest)
(loop stl chl nxt rest))
(($space . ,rest)
(loop stl (cons #\space chl) nxt rest))
((($comm . ,val) . ,rest)
;; replace comment with extra trailing space
(loop stl chl (string-append "/*" val "*/ ") rest))
((,asis . ,rest)
(loop stl chl asis rest))
(,otherwise
(error "nyacc cpp rtokl->string, no match" tkl)))))))
;; We just scanned "defined", now need to scan the arg to inhibit expansion.
;; For example, we have scanned "defined"; we now scan "(FOO)" or "FOO", and
;; return "defined(FOO)" or "defined FOO".
(define (scan-defined-arg)
(let* ((ch (skip-il-ws (read-char))) (no-ec (not (char=? ch #\())))
(let loop ((chl (list ch)) (ch (skip-il-ws (read-char))))
(cond
((eof-object? ch)
(if no-ec
(list->string (cons #\space (reverse chl)))
(cpp-err "illegal argument to `defined'")))
((char-set-contains? c:ir ch)
(loop (cons ch chl) (read-char)))
(no-ec
(unread-char ch)
(list->string (cons #\space (reverse chl))))
((char=? #\) (skip-il-ws ch))
(reverse-list->string (cons #\) chl)))
(else
(cpp-err "illegal argument to `defined'"))))))
;; must be (\s*<xxx>\s*) OR (\s*"xxx"\s*) => ("<xxx>") OR ("\"xxx\"")
(define (scan-arg-literal)
(let ((ch (read-char)))
;; if exit, then did not defined __has_include(X)=__has_include__(X)
(if (or (eof-object? ch) (not (char=? #\( ch)))
(throw 'cpp-error "expedcting `('")))
(let loop ((chl '()) (ch (skip-il-ws (read-char))))
(cond
((eof-object? ch) (cpp-err "illegal argument"))
((char=? #\) ch)
(let loop2 ((res '()) (chl chl))
(cond
((null? chl)
(string-append "(\"" (esc-c-str (list->string res)) "\")"))
((and (null? res) (char-whitespace? (car chl))) (loop2 res (cdr chl)))
(else (loop2 (cons (car chl) res) (cdr chl))))))
(else (loop (cons ch chl) (read-char))))))
(define* (scan-cpp-input defs used end-tok #:key (keep-comments #t))
;; Works like this: scan for tokens (comments, parens, strings, char's, etc).
;; Tokens are collected in a (reverse ordered) list (tkl) and merged together
;; to a string on return using @code{rtokl->string}. Keep track of expanded
;; identifiers and rerun if something got expanded. Also, keep track of
;; ## and spaces so that we can parse ID /* foo */ ## /* bar */ 123
;; as well as ABC/*foo*/(123,456).
(define (trim-spaces tkl)
(if (and (pair? tkl) (eqv? '$space (car tkl)))
(trim-spaces (cdr tkl))
tkl))
(define (finish rr tkl)
(let* ((tkl (if end-tok (trim-spaces tkl) tkl))
(repl (rtokl->string tkl)))
(if (pair? rr)
(cpp-expand-text repl defs (append rr used)) ;; re-run
repl)))
(let loop ((rr '()) ; list symbols resolved
(tkl '()) ; token list of
(lv 0) ; level
(ch (skip-il-ws (read-char)))) ; next character
(cond
((eof-object? ch) (finish rr tkl))
((and (eqv? end-tok ch) (zero? lv))
(unread-char ch) (finish rr tkl))
((and end-tok (char=? #\) ch) (zero? lv))
(unread-char ch) (finish rr tkl))
((char-set-contains? c:ws ch) ; whitespace
(loop rr (cons '$space tkl) lv (skip-il-ws (read-char))))
((read-c-comm ch #f) => ; comment
(lambda (comm)
;; Normally comments in CPP def's are replaced by a space. We allow
;; comments to get passed through, hoping this does not break code.
(if keep-comments
(loop rr (acons '$comm (cdr comm) tkl) lv (skip-il-ws (read-char)))
(loop rr (cons '$space tkl) lv (skip-il-ws (read-char))))))
((read-c-ident ch) =>
(lambda (iden)
(cond
((string=? iden "defined")
(loop rr
(acons '$echo (string-append iden (scan-defined-arg)) tkl)
lv (read-char)))
((member iden '("__has_include__" "__has_include_next__"))
(cond
((scan-arg-literal) =>
(lambda (arg)
(loop rr (acons '$echo (string-append iden arg) tkl)
lv (read-char))))
(else
(loop rr (acons '$ident iden tkl) lv (read-char)))))
(else
(let ((rval (expand-cpp-macro-ref iden defs used)))
(if rval
(loop #t (cons rval tkl) lv (read-char))
(loop rr (acons '$ident iden tkl) lv (read-char))))))))
((read-c-string ch) =>
(lambda (pair) (loop rr (cons pair tkl) lv (read-char))))
((char=? #\( ch) (loop rr (cons ch tkl) (1+ lv) (read-char)))
((char=? #\) ch) (loop rr (cons ch tkl) (1- lv) (read-char)))
(else
(loop rr (cons ch tkl) lv (read-char))))))
;; @deffn {Procedure} collect-args argl defs used => argd
;; Collect arguments to a macro which appears in C code. If not looking at
;; @code{(} return @code{#f}, else scan and eat up to closing @code{)}.
;; If multiple whitespace characters are skipped at the front then only
;; one @code{#\space} is re-inserted.
;; @end deffn
(define (collect-args argl defs used)
(let loop1 ((sp #f) (ch (read-char)))
(cond
((eof-object? ch) (if sp (unread-char #\space)) #f)
((char-set-contains? inline-whitespace ch) (loop1 #t (read-char)))
((char=? #\( ch)
(let loop2 ((argl argl) (argv '()) (ch ch))
(cond
((eqv? ch #\)) (reverse argv))
((null? argl) (cpp-err "arg count"))
((and (null? (cdr argl)) (string=? (car argl) "..."))
(let ((val (scan-cpp-input defs used #\))))
(loop2 (cdr argl) (acons "__VA_ARGS__" val argv) (read-char))))
((or (char=? ch #\() (char=? ch #\,))
(let* ((val (scan-cpp-input defs used #\,)))
(loop2 (cdr argl) (acons (car argl) val argv) (read-char))))
(else
(error "nyacc cpp.scm: collect-args coding error")))))
(else (unread-char ch) (if sp (unread-char #\space)) #f))))
;; @deffn {Procedure} px-cpp-ftn-repl argd repl => string
;; pre-expand CPP function where @var{argd} is an a-list of arg name
;; and replacement and repl is the defined replacement
;;
;; argd is alist of arguments and token lists
;; if end-tok == #f ignore levels
;; ident space fixed float chseq hash dhash arg
;; need to decide if we should use `(space ,tkl) or `((space) ,tkl)
;; This should replace args and execute hash and double-hash ??
;; @end deffn
(define (px-cpp-ftn argd repl)
(with-input-from-string repl
(lambda ()
(px-cpp-ftn-1 argd))))
(define (px-cpp-ftn-1 argd)
;; Turn reverse chl into a string and insert it into the token stream.
(define (ins-chl chl stl)
(if (null? chl) stl (cons (reverse-list->string chl) stl)))
(define (rem-space chl)
(let loop ((chl chl))
(cond
((null? chl) chl)
((char-set-contains? c:ws (car chl)) (loop (cdr chl)))
(else chl))))
(define (mk-string str) (string-append "\"" (esc-c-str str) "\""))
(let loop ((stl '()) ; string list
(chl '()) ; character list
(nxt #f) ; next string after char list
(ch (read-char))) ; next character
(cond
(nxt (loop (cons nxt (ins-chl chl stl)) '() #f ch))
((eof-object? ch)
(apply string-append (reverse (ins-chl chl stl))))
((char-set-contains? c:ws ch)
(loop stl (cons #\space chl) nxt (skip-il-ws (read-char))))
((read-c-comm ch #f) (loop stl (cons #\space chl) nxt (read-char)))
((read-c-string ch) =>
(lambda (st) (loop stl chl (mk-string (cdr st)) (read-char))))
((char=? #\( ch) (loop stl (cons ch chl) nxt (read-char)))
((char=? #\) ch) (loop stl (cons ch chl) nxt (read-char)))
((read-c-ident ch) => ; replace if aval
(lambda (iden)
(loop stl chl (or (assoc-ref argd iden) iden) (read-char))))
((char=? #\# ch)
(let ((ch (read-char)))
(if (eqv? ch #\#)
(loop stl (rem-space chl) nxt (skip-il-ws (read-char)))
(let* ((aref (read-c-ident (skip-il-ws ch)))
(aval (assoc-ref argd aref)))
(if (not aref) (cpp-err "expecting arg-ref"))
(if (not aval) (cpp-err "expecting arg-val"))
(loop stl chl (mk-string aval) (read-char))))))
(else (loop stl (cons ch chl) nxt (read-char))))))
;; @deffn {Procedure} cpp-expand-text text defs [used] => string
;; Expand the string @var{text} using the provided CPP @var{defs} a-list.
;; Identifiers in the list of strings @var{used} will not be expanded.
;; @end deffn
(define* (cpp-expand-text text defs #:optional (used '()))
(with-input-from-string text
(lambda () (scan-cpp-input defs used #f))))
;; === exports =======================
;; @deffn {Procedure} eval-cpp-cond-text text [defs] => string
;; Evaluate CPP condition expression (text).
;; Undefined identifiers are replaced with @code{0}.
;; @end deffn
(define* (eval-cpp-cond-text text #:optional (defs '()) #:key (inc-dirs '()))
(with-throw-handler
'cpp-error
(lambda ()
(let* ((rhs (cpp-expand-text text defs))
(exp (parse-cpp-expr rhs)))
(eval-cpp-expr exp defs #:inc-dirs inc-dirs)))
(lambda (key fmt . args)
(report-error fmt args)
(throw 'c99-error "CPP error"))))
;; @deffn {Procedure} expand-cpp-macro-ref ident defs [used] => repl|#f
;; Given an identifier seen in the current input, this checks for associated
;; definition in @var{defs} (generated from CPP defines). If found as simple
;; macro, the expansion is returned as a string. If @var{ident} refers
;; to a macro with arguments, then the arguments will be read from the
;; current input. The format of the @code{defs} entries are
;; @example
;; ("ABC" . "123")
;; ("MAX" ("X" "Y") . "((X)>(Y)?(X):(Y))")
;; @end example
;; @noindent
;; Note that this routine will look in the current-input so if you want to
;; expand text,
;; @end deffn
(define* (expand-cpp-macro-ref ident defs #:optional (used '()))
(let ((rval (assoc-ref defs ident)))
(cond
((member ident used) #f)
((string? rval)
(let* ((used (cons ident used))
(repl (cpp-expand-text rval defs used)))
(if (ident-like? repl)
(or (expand-cpp-macro-ref repl defs used) repl)
repl)))
((pair? rval)
;; GNU CPP manual: "A function-like macro is only expanded if its name
;; appears with a pair of parentheses after it. If you just write the
;; name, it is left alone."
(and=> (collect-args (car rval) defs used)
(lambda (argd)
(let* ((used (cons ident used))
(prep (px-cpp-ftn argd (cdr rval)))
(repl (cpp-expand-text prep defs used)))
(if (ident-like? repl)
(or (expand-cpp-macro-ref repl defs used) repl)
repl)))))
((c99-std-val ident) => identity)
(else #f))))
;;; --- last line ---

134
sysa/mes-0.22/module/nyacc/lang/c99/cppmach.scm Normal file
View file

@ -0,0 +1,134 @@
;;; lang/c99/cppmach.scm - CPP expression grammar
;; Copyright (C) 2015,2016,2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.
;;; Code:
(define-module (nyacc lang c99 cppmach)
#:export (cpp-spec cpp-mach gen-cpp-files)
#:use-module (nyacc lalr)
#:use-module (nyacc parse)
#:use-module (nyacc lex)
#:use-module (nyacc lang util)
#:use-module ((srfi srfi-43) #:select (vector-map))
#:use-module (rnrs arithmetic bitwise))
(define cpp-spec
(lalr-spec
(notice (string-append "Copyright (C) 2016,2017 Matthew R. Wette"
license-lgpl3+))
(expect 0)
(start conditional-expression)
(grammar
(conditional-expression
(logical-or-expression)
(logical-or-expression "?" logical-or-expression ":" conditional-expression
($$ `(cond-expr ,$1 ,$3 ,$5))))
(logical-or-expression
(logical-and-expression)
(logical-or-expression "||" logical-and-expression ($$ `(or ,$1 ,$3))))
(logical-and-expression
(bitwise-or-expression)
(logical-and-expression "&&" bitwise-or-expression ($$ `(and ,$1 ,$3))))
(bitwise-or-expression
(bitwise-xor-expression)
(bitwise-or-expression "|" bitwise-xor-expression
($$ `(bitwise-or ,$1 ,$3))))
(bitwise-xor-expression
(bitwise-and-expression)
(bitwise-xor-expression "^" bitwise-and-expression
($$ `(bitwise-xor ,$1 ,$3))))
(bitwise-and-expression
(equality-expression)
(bitwise-and-expression "&" equality-expression
($$ `(bitwise-and ,$1 ,$3))))
(equality-expression
(relational-expression)
(equality-expression "==" relational-expression ($$ `(eq ,$1 ,$3)))
(equality-expression "!=" relational-expression ($$ `(ne ,$1 ,$3))))
(relational-expression
(shift-expression)
(relational-expression "<" shift-expression ($$ `(lt ,$1 ,$3)))
(relational-expression "<=" shift-expression ($$ `(le ,$1 ,$3)))
(relational-expression ">" shift-expression ($$ `(gt ,$1 ,$3)))
(relational-expression ">=" shift-expression ($$ `(ge ,$1 ,$3))))
(shift-expression
(additive-expression)
(shift-expression "<<" additive-expression ($$ `(lshift ,$1 ,$3)))
(shift-expression ">>" additive-expression ($$ `(rshift ,$1 ,$3))))
(additive-expression
(multiplicative-expression)
(additive-expression "+" multiplicative-expression ($$ `(add ,$1 ,$3)))
(additive-expression "-" multiplicative-expression ($$ `(sub ,$1 ,$3))))
(multiplicative-expression
(unary-expression)
(multiplicative-expression "*" unary-expression ($$ `(mul ,$1 ,$3)))
(multiplicative-expression "/" unary-expression ($$ `(div ,$1 ,$3)))
(multiplicative-expression "%" unary-expression ($$ `(mod ,$1 ,$3))))
(unary-expression
(postfix-expression)
("-" unary-expression ($$ `(neg ,$2)))
("+" unary-expression ($$ `(pos ,$2)))
("!" unary-expression ($$ `(not ,$2)))
("~" unary-expression ($$ `(bitwise-not ,$2)))
("++" unary-expression ($$ `(pre-inc ,$2)))
("--" unary-expression ($$ `(pre-dec ,$2))))
(postfix-expression
(primary-expression)
(postfix-expression "++" ($$ `(post-inc ,$1)))
(postfix-expression "--" ($$ `(post-dec ,$1))))
(primary-expression
($ident ($$ `(ident ,$1)))
($fixed ($$ `(fixed ,$1))) ; integer literal
($chlit ($$ `(char ,$1))) ; char literal
($chlit/L ($$ `(char (@ (type "wchar_t")) ,$1)))
($chlit/u ($$ `(char (@ (type "char16_t")) ,$1)))
($chlit/U ($$ `(char (@ (type "char32_t")) ,$1)))
("defined" "(" $ident ")" ($$ `(defined ,$3)))
("defined" $ident ($$ `(defined ,$2)))
("__has_include__" "(" $string ")" ($$ `(has-include ,$3)))
("__has_include_next__" "(" $string ")" ($$ `(has-include-next ,$3)))
("(" expression-list ")" ($$ $2)))
(expression-list
(conditional-expression)
(expression-list "," conditional-expression ($$ $3)))
)))
(define cpp-mach
(compact-machine
(hashify-machine
(make-lalr-machine cpp-spec))))
;;; =====================================
;; @item gen-cpp-files [dir] => #t
;; Update or generate the files @quot{cppact.scm} and @quot{cpptab.scm}.
;; If there are no changes to existing files, no update occurs.
(define (gen-cpp-files . rest)
(define (lang-dir path)
(if (pair? rest) (string-append (car rest) "/" path) path))
(define (xtra-dir path)
(lang-dir (string-append "mach.d/" path)))
(write-lalr-actions cpp-mach (xtra-dir "cpp-act.scm.new") #:prefix "cpp-")
(write-lalr-tables cpp-mach (xtra-dir "cpp-tab.scm.new") #:prefix "cpp-")
(let ((a (move-if-changed (xtra-dir "cpp-act.scm.new")
(xtra-dir "cpp-act.scm")))
(b (move-if-changed (xtra-dir "cpp-tab.scm.new")
(xtra-dir "cpp-tab.scm"))))
(or a b)))
;; --- last line ---

219
sysa/mes-0.22/module/nyacc/lang/c99/cxeval.scm Normal file
View file

@ -0,0 +1,219 @@
;;; nyacc/lang/c99/c99eval.scm - evaluate constant expressions
;; Copyright (C) 2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.
;;; Code:
(define-module (nyacc lang c99 cxeval)
#:export (parse-c99-cx eval-c99-cx)
#:use-module (nyacc lalr)
#:use-module (nyacc parse)
#:use-module (nyacc lex)
#:use-module (nyacc util)
#:use-module ((nyacc lang util) #:select (make-tl tl-append tl->list))
#:use-module (nyacc lang sx-util)
#:use-module (nyacc lang c99 cpp)
#:use-module (nyacc lang c99 munge)
#:use-module (rnrs arithmetic bitwise)
#:use-module ((srfi srfi-43) #:select (vector-map vector-for-each))
#:use-module (system foreign))
(use-modules (ice-9 pretty-print))
(define pp pretty-print)
(define (sf fmt . args) (apply simple-format #t fmt args))
(define ffi-type-map
`(("void" . ,void) ("float" . ,float) ("double" . ,double) ("short" . ,short)
("short int" . ,short) ("signed short" . ,short)
("signed short int" . ,short) ("int" . ,int) ("signed" . ,int)
("signed int" . ,int) ("long" . ,long) ("long int" . ,long)
("signed long" . ,long) ("signed long int" . ,long)
("unsigned short int" . ,unsigned-short)
("unsigned short" . ,unsigned-short)
("unsigned int" . ,unsigned-int) ("unsigned" . ,unsigned-int)
("unsigned long int" . ,unsigned-long) ("unsigned long" . ,unsigned-long)
("char" . ,int8) ("signed char" . ,int8) ("unsigned char" . ,uint8)
("wchar_t" . ,int) ("char16_t" . ,int16) ("char32_t" . ,int32)
("long long" . ,long) ("long long int" . ,long)
("signed long long" . ,long) ("signed long long int" . ,long)
("unsigned long long" . ,unsigned-long)
("unsigned long long int" . ,unsigned-long) ("_Bool" . ,int8)
("size_t" . ,size_t)))
(define (sizeof-type name)
(or (and=> (assoc-ref ffi-type-map name) sizeof)
(throw 'nyacc-error "bad type")))
;; (string "abc" "dev")
(define (sizeof-string-const value)
#f)
(include-from-path "nyacc/lang/c99/mach.d/c99cx-act.scm")
(include-from-path "nyacc/lang/c99/mach.d/c99cx-tab.scm")
(define c99cx-raw-parser
(make-lalr-parser
(acons 'act-v c99cx-act-v c99cx-tables)))
(define gen-c99cx-lexer
(let* ((reader (make-comm-reader '(("/*" . "*/"))))
(comm-skipper (lambda (ch) (reader ch #f))))
(make-lexer-generator c99cx-mtab
#:comm-skipper comm-skipper
#:chlit-reader read-c-chlit
#:num-reader read-c-num)))
(define (parse-c99cx text)
(with-throw-handler
'nyacc-error
(lambda ()
(with-input-from-string text
(lambda () (c99cx-raw-parser (gen-c99cx-lexer)))))
(lambda (key fmt . args)
(apply throw 'cpp-error fmt args))))
(define (expand-typename typename udict)
(let* ((decl `(udecl (decl-spec-list
(type-spec (typename ,typename)))
(declr (ident "_"))))
(xdecl (expand-typerefs decl udict))
(xname (and xdecl (sx-ref* xdecl 1 1 1 1))))
xname))
;; (sizeof type-name)
;; (type-name specificer-qualifier-list abstract-declarator)
;; (decl-spec-list
;; (abs-decl
(define (eval-sizeof-type tree udict)
(sx-match (sx-ref tree 1)
((type-name (decl-spec-list (type-spec (typename ,name))))
(let* ((xname (expand-typename name udict))
(ffi-type (assoc-ref ffi-type-map xname)))
(unless ffi-type
(sf "need to expand ~S\n" name) (pp tree)
(error "eval-sizeof-type: missed typedef (work to go)"))
(sizeof ffi-type)))
((type-name (decl-spec-list (type-spec (fixed-type ,name))))
(let* ((ffi-type (assoc-ref ffi-type-map name)))
(sizeof ffi-type)))
((type-name (decl-spec-list (type-spec (float-type ,name))))
(let* ((ffi-type (assoc-ref ffi-type-map name)))
(sizeof ffi-type)))
((type-name (decl-spec-list (type-spec . ,_1)) (abs-declr (pointer)))
(sizeof '*))
(else
(sf "eval-sizeof-type missed:\n") (pp (sx-ref tree 1))
(error "can't eval sizeof(type)"))))
;; (sizeof unary-expr)
;; (primary-expression ; S 6.5.1
;; (identifier ($$ `(p-expr ,$1)))
;; (constant ($$ `(p-expr ,$1)))
;; (string-literal ($$ `(p-expr ,(tl->list $1))))
;; ("(" expression ")" ($$ $2))
;; ("(" "{" block-item-list "}" ")"
;; ($$ `(stmt-expr (@ (extension "GNUC")) ,$3)))
;; )
(define (eval-sizeof-expr tree udict)
(let* ((expr (sx-ref tree 1)))
(sx-match expr
((p-expr (string . ,strl))
(let loop ((l 0) (sl strl))
(if (pair? sl) (loop (+ l (string-length (car sl))) (cdr sl)) l)))
(else #f))))
(define (eval-ident name udict ddict)
(cond
((assoc-ref ddict name) =>
(lambda (hit)
;; This should actually go through the cpp-expander first methinks.
(and (string? hit)
(let ((expr (parse-cpp-expr hit)))
(eval-c99-cx expr udict ddict)))))
(else
;;(error "missed" name)
#f)))
;; @deffn {Procedure} eval-c99-cx tree [udict [ddict]]
;; Evaluate the constant expression or return #f
;; @end deffn
(define* (eval-c99-cx tree #:optional udict ddict)
(define (fail) #f)
(letrec
((ev (lambda (ex ix) (eval-expr (sx-ref ex ix))))
(ev1 (lambda (ex) (ev ex 1))) ; eval expr in arg 1
(ev2 (lambda (ex) (ev ex 2))) ; eval expr in arg 2
(ev3 (lambda (ex) (ev ex 3))) ; eval expr in arg 3
(uop (lambda (op ex) (and op ex (op ex))))
(bop (lambda (op lt rt) (and op lt rt (op lt rt))))
(eval-expr
(lambda (tree)
(case (car tree)
((fixed) (string->number (cnumstr->scm (sx-ref tree 1))))
((float) (string->number (cnumstr->scm (sx-ref tree 1))))
((char) (char->integer (string-ref (sx-ref tree 1) 0)))
((string) (string-join (sx-tail tree 1) ""))
((pre-inc post-inc) (uop 1+ (ev1 tree)))
((pre-dec post-dec) (uop 1- (ev1 tree)))
((pos) (and tree (ev1 tree)))
((neg) (uop - (ev1 tree)))
((not) (and tree (if (equal? 0 (ev1 tree)) 1 0)))
((mul) (bop * (ev1 tree) (ev2 tree)))
((div) (bop / (ev1 tree) (ev2 tree)))
((mod) (bop modulo (ev1 tree) (ev2 tree)))
((add) (bop + (ev1 tree) (ev2 tree)))
((sub) (bop - (ev1 tree) (ev2 tree)))
((lshift) (bop bitwise-arithmetic-shift-left (ev1 tree) (ev2 tree)))
((rshift) (bop bitwise-arithmetic-shift-right (ev1 tree) (ev2 tree)))
((lt) (if (bop < (ev1 tree) (ev2 tree)) 1 0))
((le) (if (bop <= (ev1 tree) (ev2 tree)) 1 0))
((gt) (if (bop > (ev1 tree) (ev2 tree)) 1 0))
((ge) (if (bop >= (ev1 tree) (ev2 tree)) 1 0))
((eq) (if (bop = (ev1 tree) (ev2 tree)) 1 0))
((ne) (if (bop = (ev1 tree) (ev2 tree)) 0 1))
((bitwise-not) (uop lognot (ev1 tree)))
((bitwise-or) (bop logior (ev1 tree) (ev2 tree)))
((bitwise-xor) (bop logxor (ev1 tree) (ev2 tree)))
((bitwise-and) (bop logand (ev1 tree) (ev2 tree)))
;;
((or)
(let ((e1 (ev1 tree)) (e2 (ev2 tree)))
(if (and e1 e2) (if (and (zero? e1) (zero? e2)) 0 1) #f)))
((and)
(let ((e1 (ev1 tree)) (e2 (ev2 tree)))
(if (and e1 e2) (if (or (zero? e1) (zero? e2)) 0 1) #f)))
((cond-expr)
(let ((e1 (ev1 tree)) (e2 (ev2 tree)) (e3 (ev3 tree)))
(if (and e1 e2 e3) (if (zero? e1) e3 e2) #f)))
;;
((sizeof-type) (eval-sizeof-type tree udict))
((sizeof-expr) (eval-sizeof-expr tree udict))
((ident) (eval-ident (sx-ref tree 1) udict ddict))
((p-expr) (ev1 tree))
((cast) (ev2 tree))
((fctn-call) #f) ; assume not constant
;;
;; TODO
((comp-lit) (fail)) ; return a bytearray
((comma-expr) (fail))
((i-sel) (fail))
((d-sel) (fail))
((array-ref) (fail))
;;
(else (fail))))))
(eval-expr tree)))
;; --- last line ---

146
sysa/mes-0.22/module/nyacc/lang/c99/cxmach.scm Normal file
View file

@ -0,0 +1,146 @@
;;; nyacc/lang/c99/cxmach.scm - constant expression grammar
;; Copyright (C) 2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.
;;; Code:
(define-module (nyacc lang c99 cxmach)
#:export (c99cx-spec c99cx-mach gen-c99cx-files)
#:use-module (nyacc lalr)
#:use-module (nyacc parse)
#:use-module (nyacc lex)
#:use-module (nyacc util)
#:use-module (nyacc lang util)
#:use-module (rnrs arithmetic bitwise)
#:use-module ((srfi srfi-43) #:select (vector-map vector-for-each))
#:use-module (system foreign))
(define c99cx-spec
(lalr-spec
(notice (string-append "Copyright (C) 2018 Matthew R. Wette" license-lgpl3+))
(expect 0)
(start constant-expression)
(grammar
(primary-expression
(identifier ($$ `(p-expr ,$1)))
(constant ($$ `(p-expr ,$1)))
(string-literal ($$ `(p-expr ,(tl->list $1))))
("(" constant-expression ")" ($$ $2)))
(postfix-expression
(primary-expression)
(postfix-expression "[" constant-expression "]" ($$ `(array-ref ,$3 ,$1)))
(postfix-expression "." identifier ($$ `(d-sel ,$3 ,$1)))
(postfix-expression "->" identifier ($$ `(i-sel ,$3 ,$1)))
(postfix-expression "++" ($$ `(post-inc ,$1)))
(postfix-expression "--" ($$ `(post-dec ,$1))))
(unary-expression
(postfix-expression) ; S 6.5.3
("++" unary-expression ($$ `(pre-inc ,$2)))
("--" unary-expression ($$ `(pre-dec ,$2)))
(unary-operator cast-expression ($$ (list $1 $2)))
("sizeof" unary-expression ($$ `(sizeof-expr ,$2)))
;;("sizeof" "(" type-name ")" ($$ `(sizeof-type ,$3)))
)
(unary-operator ("&" ($$ 'ref-to)) ("*" ($$ 'de-ref))
("+" ($$ 'pos)) ("-" ($$ 'neg))
("~" ($$ 'bitwise-not)) ("!" ($$ 'not)))
(cast-expression
(unary-expression)
;;("(" type-name ")" cast-expression ($$ `(cast ,$2 ,$4)))
)
(multiplicative-expression
(cast-expression)
(multiplicative-expression "*" cast-expression ($$ `(mul ,$1 ,$3)))
(multiplicative-expression "/" cast-expression ($$ `(div ,$1 ,$3)))
(multiplicative-expression "%" cast-expression ($$ `(mod ,$1 ,$3))))
(additive-expression
(multiplicative-expression)
(additive-expression "+" multiplicative-expression ($$ `(add ,$1 ,$3)))
(additive-expression "-" multiplicative-expression ($$ `(sub ,$1 ,$3))))
(shift-expression
(additive-expression)
(shift-expression "<<" additive-expression ($$ `(lshift ,$1 ,$3)))
(shift-expression ">>" additive-expression ($$ `(rshift ,$1 ,$3))))
(relational-expression
(shift-expression)
(relational-expression "<" shift-expression ($$ `(lt ,$1 ,$3)))
(relational-expression ">" shift-expression ($$ `(gt ,$1 ,$3)))
(relational-expression "<=" shift-expression ($$ `(le ,$1 ,$3)))
(relational-expression ">=" shift-expression ($$ `(ge ,$1 ,$3))))
(equality-expression
(relational-expression)
(equality-expression "==" relational-expression ($$ `(eq ,$1 ,$3)))
(equality-expression "!=" relational-expression ($$ `(ne ,$1 ,$3))))
(bitwise-and-expression
(equality-expression)
(bitwise-and-expression
"&" equality-expression ($$ `(bitwise-and ,$1 ,$3))))
(bitwise-xor-expression
(bitwise-and-expression)
(bitwise-xor-expression
"^" bitwise-and-expression ($$ `(bitwise-xor ,$1 ,$3))))
(bitwise-or-expression
(bitwise-xor-expression)
(bitwise-or-expression
"|" bitwise-xor-expression ($$ `(bitwise-or ,$1 ,$3))))
(logical-and-expression
(bitwise-or-expression)
(logical-and-expression
"&&" bitwise-or-expression ($$ `(and ,$1 ,$3))))
(logical-or-expression
(logical-and-expression)
(logical-or-expression
"||" logical-and-expression ($$ `(or ,$1 ,$3))))
(conditional-expression
(logical-or-expression)
(logical-or-expression
"?" constant-expression
":" conditional-expression ($$ `(cond-expr ,$1 ,$3 ,$5))))
(constant-expression
(conditional-expression))
;;
(identifier
($ident ($$ `(ident ,$1))))
(constant
($fixed ($$ `(fixed ,$1))) ; integer literal
($float ($$ `(float ,$1))) ; floating literal
($chlit ($$ `(char ,$1))) ; char literal
($chlit/L ($$ `(char (@ (type "wchar_t")) ,$1)))
($chlit/u ($$ `(char (@ (type "char16_t")) ,$1)))
($chlit/U ($$ `(char (@ (type "char32_t")) ,$1))))
(string-literal
($string ($$ (make-tl 'string $1))) ; string-constant
(string-literal $string ($$ (tl-append $1 $2)))))))
(define c99cx-mach
(compact-machine
(hashify-machine
(make-lalr-machine c99cx-spec))))
;;; =====================================
;; @item gen-c99cx-files [dir] => #t
;; Update or generate the files @quot{cppact.scm} and @quot{cpptab.scm}.
;; If there are no changes to existing files, no update occurs.
(define* (gen-c99cx-files #:optional (path "."))
(define (mdir file) (mach-dir path file))
(write-lalr-actions c99cx-mach (mdir "c99cx-act.scm.new") #:prefix "c99cx-")
(write-lalr-tables c99cx-mach (mdir "c99cx-tab.scm.new") #:prefix "c99cx-")
(let ((a (move-if-changed (mdir "c99cx-act.scm.new") (mdir "c99cx-act.scm")))
(b (move-if-changed (mdir "c99cx-tab.scm.new") (mdir "c99cx-tab.scm"))))
(or a b)))
;; --- last line ---

2316
sysa/mes-0.22/module/nyacc/lang/c99/ffi-help.scm Normal file
View file

File diff suppressed because it is too large Load diff

1081
sysa/mes-0.22/module/nyacc/lang/c99/mach.d/c99-act.scm Normal file
View file

File diff suppressed because it is too large Load diff

1211
sysa/mes-0.22/module/nyacc/lang/c99/mach.d/c99-tab.scm Normal file
View file

File diff suppressed because it is too large Load diff

148
sysa/mes-0.22/module/nyacc/lang/c99/mach.d/c99cx-act.scm Normal file
View file

@ -0,0 +1,148 @@
;; c99cx-act.scm
;; Copyright (C) 2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;; See the file COPYING included with the this distribution.
(define c99cx-act-v
(vector
;; $start => constant-expression
(lambda ($1 . $rest) $1)
;; primary-expression => identifier
(lambda ($1 . $rest) `(p-expr ,$1))
;; primary-expression => constant
(lambda ($1 . $rest) `(p-expr ,$1))
;; primary-expression => string-literal
(lambda ($1 . $rest) `(p-expr ,(tl->list $1)))
;; primary-expression => "(" constant-expression ")"
(lambda ($3 $2 $1 . $rest) $2)
;; postfix-expression => primary-expression
(lambda ($1 . $rest) $1)
;; postfix-expression => postfix-expression "[" constant-expression "]"
(lambda ($4 $3 $2 $1 . $rest)
`(array-ref ,$3 ,$1))
;; postfix-expression => postfix-expression "." identifier
(lambda ($3 $2 $1 . $rest) `(d-sel ,$3 ,$1))
;; postfix-expression => postfix-expression "->" identifier
(lambda ($3 $2 $1 . $rest) `(i-sel ,$3 ,$1))
;; postfix-expression => postfix-expression "++"
(lambda ($2 $1 . $rest) `(post-inc ,$1))
;; postfix-expression => postfix-expression "--"
(lambda ($2 $1 . $rest) `(post-dec ,$1))
;; unary-expression => postfix-expression
(lambda ($1 . $rest) $1)
;; unary-expression => "++" unary-expression
(lambda ($2 $1 . $rest) `(pre-inc ,$2))
;; unary-expression => "--" unary-expression
(lambda ($2 $1 . $rest) `(pre-dec ,$2))
;; unary-expression => unary-operator cast-expression
(lambda ($2 $1 . $rest) (list $1 $2))
;; unary-expression => "sizeof" unary-expression
(lambda ($2 $1 . $rest) `(sizeof-expr ,$2))
;; unary-operator => "&"
(lambda ($1 . $rest) 'ref-to)
;; unary-operator => "*"
(lambda ($1 . $rest) 'de-ref)
;; unary-operator => "+"
(lambda ($1 . $rest) 'pos)
;; unary-operator => "-"
(lambda ($1 . $rest) 'neg)
;; unary-operator => "~"
(lambda ($1 . $rest) 'bitwise-not)
;; unary-operator => "!"
(lambda ($1 . $rest) 'not)
;; cast-expression => unary-expression
(lambda ($1 . $rest) $1)
;; multiplicative-expression => cast-expression
(lambda ($1 . $rest) $1)
;; multiplicative-expression => multiplicative-expression "*" cast-expre...
(lambda ($3 $2 $1 . $rest) `(mul ,$1 ,$3))
;; multiplicative-expression => multiplicative-expression "/" cast-expre...
(lambda ($3 $2 $1 . $rest) `(div ,$1 ,$3))
;; multiplicative-expression => multiplicative-expression "%" cast-expre...
(lambda ($3 $2 $1 . $rest) `(mod ,$1 ,$3))
;; additive-expression => multiplicative-expression
(lambda ($1 . $rest) $1)
;; additive-expression => additive-expression "+" multiplicative-expression
(lambda ($3 $2 $1 . $rest) `(add ,$1 ,$3))
;; additive-expression => additive-expression "-" multiplicative-expression
(lambda ($3 $2 $1 . $rest) `(sub ,$1 ,$3))
;; shift-expression => additive-expression
(lambda ($1 . $rest) $1)
;; shift-expression => shift-expression "<<" additive-expression
(lambda ($3 $2 $1 . $rest) `(lshift ,$1 ,$3))
;; shift-expression => shift-expression ">>" additive-expression
(lambda ($3 $2 $1 . $rest) `(rshift ,$1 ,$3))
;; relational-expression => shift-expression
(lambda ($1 . $rest) $1)
;; relational-expression => relational-expression "<" shift-expression
(lambda ($3 $2 $1 . $rest) `(lt ,$1 ,$3))
;; relational-expression => relational-expression ">" shift-expression
(lambda ($3 $2 $1 . $rest) `(gt ,$1 ,$3))
;; relational-expression => relational-expression "<=" shift-expression
(lambda ($3 $2 $1 . $rest) `(le ,$1 ,$3))
;; relational-expression => relational-expression ">=" shift-expression
(lambda ($3 $2 $1 . $rest) `(ge ,$1 ,$3))
;; equality-expression => relational-expression
(lambda ($1 . $rest) $1)
;; equality-expression => equality-expression "==" relational-expression
(lambda ($3 $2 $1 . $rest) `(eq ,$1 ,$3))
;; equality-expression => equality-expression "!=" relational-expression
(lambda ($3 $2 $1 . $rest) `(ne ,$1 ,$3))
;; bitwise-and-expression => equality-expression
(lambda ($1 . $rest) $1)
;; bitwise-and-expression => bitwise-and-expression "&" equality-expression
(lambda ($3 $2 $1 . $rest)
`(bitwise-and ,$1 ,$3))
;; bitwise-xor-expression => bitwise-and-expression
(lambda ($1 . $rest) $1)
;; bitwise-xor-expression => bitwise-xor-expression "^" bitwise-and-expr...
(lambda ($3 $2 $1 . $rest)
`(bitwise-xor ,$1 ,$3))
;; bitwise-or-expression => bitwise-xor-expression
(lambda ($1 . $rest) $1)
;; bitwise-or-expression => bitwise-or-expression "|" bitwise-xor-expres...
(lambda ($3 $2 $1 . $rest) `(bitwise-or ,$1 ,$3))
;; logical-and-expression => bitwise-or-expression
(lambda ($1 . $rest) $1)
;; logical-and-expression => logical-and-expression "&&" bitwise-or-expr...
(lambda ($3 $2 $1 . $rest) `(and ,$1 ,$3))
;; logical-or-expression => logical-and-expression
(lambda ($1 . $rest) $1)
;; logical-or-expression => logical-or-expression "||" logical-and-expre...
(lambda ($3 $2 $1 . $rest) `(or ,$1 ,$3))
;; conditional-expression => logical-or-expression
(lambda ($1 . $rest) $1)
;; conditional-expression => logical-or-expression "?" constant-expressi...
(lambda ($5 $4 $3 $2 $1 . $rest)
`(cond-expr ,$1 ,$3 ,$5))
;; constant-expression => conditional-expression
(lambda ($1 . $rest) $1)
;; identifier => '$ident
(lambda ($1 . $rest) `(ident ,$1))
;; constant => '$fixed
(lambda ($1 . $rest) `(fixed ,$1))
;; constant => '$float
(lambda ($1 . $rest) `(float ,$1))
;; constant => '$chlit
(lambda ($1 . $rest) `(char ,$1))
;; constant => '$chlit/L
(lambda ($1 . $rest)
`(char (@ (type "wchar_t")) ,$1))
;; constant => '$chlit/u
(lambda ($1 . $rest)
`(char (@ (type "char16_t")) ,$1))
;; constant => '$chlit/U
(lambda ($1 . $rest)
`(char (@ (type "char32_t")) ,$1))
;; string-literal => '$string
(lambda ($1 . $rest) (make-tl 'string $1))
;; string-literal => string-literal '$string
(lambda ($2 $1 . $rest) (tl-append $1 $2))
))
;;; end tables

181
sysa/mes-0.22/module/nyacc/lang/c99/mach.d/c99cx-tab.scm Normal file
View file

@ -0,0 +1,181 @@
;; c99cx-tab.scm
;; Copyright (C) 2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;; See the file COPYING included with the this distribution.
(define c99cx-mtab
'(($start . 63) ($string . 3) ($chlit/U . 4) ($chlit/u . 5) ($chlit/L . 6)
($chlit . 7) ($float . 8) ($fixed . 9) ($ident . 10) (":" . 11) ("?" . 12)
("||" . 13) ("&&" . 14) ("|" . 15) ("^" . 16) ("!=" . 17) ("==" . 18)
(">=" . 19) ("<=" . 20) (">" . 21) ("<" . 22) (">>" . 23) ("<<" . 24)
("%" . 25) ("/" . 26) ("!" . 27) ("~" . 28) ("-" . 29) ("+" . 30) ("*" .
31) ("&" . 32) ("sizeof" . 33) ("--" . 34) ("++" . 35) ("->" . 36)
("." . 37) ("]" . 38) ("[" . 39) (")" . 40) ("(" . 41) ($error . 2)
($end . 43)))
(define c99cx-ntab
'((44 . conditional-expression) (45 . logical-or-expression) (46 .
logical-and-expression) (47 . bitwise-or-expression) (48 .
bitwise-xor-expression) (49 . bitwise-and-expression) (50 .
equality-expression) (51 . relational-expression) (52 . shift-expression)
(53 . additive-expression) (54 . multiplicative-expression) (55 .
cast-expression) (56 . unary-operator) (57 . unary-expression) (58 .
postfix-expression) (59 . primary-expression) (60 . string-literal)
(61 . constant) (62 . identifier) (63 . constant-expression)))
(define c99cx-len-v
#(1 1 1 1 3 1 4 3 3 2 2 1 2 2 2 2 1 1 1 1 1 1 1 1 3 3 3 1 3 3 1 3 3 1 3 3 3
3 1 3 3 1 3 1 3 1 3 1 3 1 3 1 5 1 1 1 1 1 1 1 1 1 2))
(define c99cx-rto-v
#(#f 59 59 59 59 58 58 58 58 58 58 57 57 57 57 57 56 56 56 56 56 56 55 54
54 54 54 53 53 53 52 52 52 51 51 51 51 51 50 50 50 49 49 48 48 47 47 46 46
45 45 44 44 63 62 61 61 61 61 61 61 60 60))
(define c99cx-pat-v
#(((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8)
(41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14) (29 . 15)
(30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21) (34 . 22)
(35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 28) (52 . 29)
(51 . 30) (50 . 31) (49 . 32) (48 . 33) (47 . 34) (46 . 35) (45 . 36)
(44 . 37) (63 . 38)) ((1 . -61)) ((1 . -60)) ((1 . -59)) ((1 . -58))
((1 . -57)) ((1 . -56)) ((1 . -55)) ((1 . -54)) ((3 . 1) (4 . 2) (5 . 3)
(6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11)
(62 . 12) (27 . 13) (28 . 14) (29 . 15) (30 . 16) (31 . 17) (32 . 18)
(59 . 19) (33 . 20) (56 . 21) (34 . 22) (35 . 23) (58 . 24) (57 . 25)
(55 . 26) (54 . 27) (53 . 28) (52 . 29) (51 . 30) (50 . 31) (49 . 32)
(48 . 33) (47 . 34) (46 . 35) (45 . 36) (44 . 37) (63 . 68)) ((3 . 67)
(1 . -3)) ((1 . -2)) ((1 . -1)) ((1 . -21)) ((1 . -20)) ((1 . -19))
((1 . -18)) ((1 . -17)) ((1 . -16)) ((1 . -5)) ((3 . 1) (4 . 2) (5 . 3)
(6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11)
(62 . 12) (27 . 13) (28 . 14) (29 . 15) (30 . 16) (31 . 17) (32 . 18)
(59 . 19) (33 . 20) (56 . 21) (34 . 22) (35 . 23) (58 . 24) (57 . 66))
((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9)
(60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14) (29 . 15) (30 . 16)
(31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21) (34 . 22) (35 . 23)
(58 . 24) (57 . 25) (55 . 65)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5)
(8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13)
(28 . 14) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20)
(56 . 21) (34 . 22) (35 . 23) (58 . 24) (57 . 64)) ((3 . 1) (4 . 2)
(5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10)
(61 . 11) (62 . 12) (27 . 13) (28 . 14) (29 . 15) (30 . 16) (31 . 17)
(32 . 18) (59 . 19) (33 . 20) (56 . 21) (34 . 22) (35 . 23) (58 . 24)
(57 . 63)) ((39 . 58) (37 . 59) (36 . 60) (35 . 61) (34 . 62) (1 . -11))
((1 . -22)) ((1 . -23)) ((31 . 55) (26 . 56) (25 . 57) (1 . -27)) (
(30 . 53) (29 . 54) (1 . -30)) ((24 . 51) (23 . 52) (1 . -33)) ((22 . 47)
(21 . 48) (20 . 49) (19 . 50) (1 . -38)) ((18 . 45) (17 . 46) (1 . -41))
((32 . 44) (1 . -43)) ((16 . 43) (1 . -45)) ((15 . 42) (1 . -47)) (
(14 . 41) (1 . -49)) ((12 . 39) (13 . 40) (1 . -51)) ((1 . -53)) ((43 . 0)
) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8)
(41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14) (29 . 15)
(30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21) (34 . 22)
(35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 28) (52 . 29)
(51 . 30) (50 . 31) (49 . 32) (48 . 33) (47 . 34) (46 . 35) (45 . 36)
(44 . 37) (63 . 91)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6)
(9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14
) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21)
(34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 28)
(52 . 29) (51 . 30) (50 . 31) (49 . 32) (48 . 33) (47 . 34) (46 . 90))
((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9)
(60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14) (29 . 15) (30 . 16)
(31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21) (34 . 22) (35 . 23)
(58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 28) (52 . 29) (51 . 30)
(50 . 31) (49 . 32) (48 . 33) (47 . 89)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4)
(7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12)
(27 . 13) (28 . 14) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19)
(33 . 20) (56 . 21) (34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26)
(54 . 27) (53 . 28) (52 . 29) (51 . 30) (50 . 31) (49 . 32) (48 . 88))
((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9)
(60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14) (29 . 15) (30 . 16)
(31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21) (34 . 22) (35 . 23)
(58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 28) (52 . 29) (51 . 30)
(50 . 31) (49 . 87)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6)
(9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14
) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21)
(34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 28)
(52 . 29) (51 . 30) (50 . 86)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5)
(8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13)
(28 . 14) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20)
(56 . 21) (34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27)
(53 . 28) (52 . 29) (51 . 85)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5)
(8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13)
(28 . 14) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20)
(56 . 21) (34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27)
(53 . 28) (52 . 29) (51 . 84)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5)
(8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13)
(28 . 14) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20)
(56 . 21) (34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27)
(53 . 28) (52 . 83)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6)
(9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14
) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21)
(34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 28)
(52 . 82)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7)
(10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14)
(29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21)
(34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 28)
(52 . 81)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7)
(10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14)
(29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21)
(34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 28)
(52 . 80)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7)
(10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14)
(29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21)
(34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 79))
((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9)
(60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14) (29 . 15) (30 . 16)
(31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21) (34 . 22) (35 . 23)
(58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 78)) ((3 . 1) (4 . 2)
(5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10)
(61 . 11) (62 . 12) (27 . 13) (28 . 14) (29 . 15) (30 . 16) (31 . 17)
(32 . 18) (59 . 19) (33 . 20) (56 . 21) (34 . 22) (35 . 23) (58 . 24)
(57 . 25) (55 . 26) (54 . 77)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5)
(8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13)
(28 . 14) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20)
(56 . 21) (34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 76))
((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9)
(60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14) (29 . 15) (30 . 16)
(31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21) (34 . 22) (35 . 23)
(58 . 24) (57 . 25) (55 . 75)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5)
(8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13)
(28 . 14) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20)
(56 . 21) (34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 74)) ((3 . 1)
(4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10
) (61 . 11) (62 . 12) (27 . 13) (28 . 14) (29 . 15) (30 . 16) (31 . 17)
(32 . 18) (59 . 19) (33 . 20) (56 . 21) (34 . 22) (35 . 23) (58 . 24)
(57 . 25) (55 . 73)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4) (7 . 5) (8 . 6)
(9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12) (27 . 13) (28 . 14
) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19) (33 . 20) (56 . 21)
(34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26) (54 . 27) (53 . 28)
(52 . 29) (51 . 30) (50 . 31) (49 . 32) (48 . 33) (47 . 34) (46 . 35)
(45 . 36) (44 . 37) (63 . 72)) ((10 . 8) (62 . 71)) ((10 . 8) (62 . 70))
((1 . -9)) ((1 . -10)) ((1 . -12)) ((1 . -13)) ((1 . -14)) ((1 . -15))
((1 . -62)) ((40 . 69)) ((1 . -4)) ((1 . -8)) ((1 . -7)) ((38 . 93))
((1 . -26)) ((1 . -25)) ((1 . -24)) ((31 . 55) (26 . 56) (25 . 57)
(1 . -29)) ((31 . 55) (26 . 56) (25 . 57) (1 . -28)) ((30 . 53) (29 . 54)
(1 . -32)) ((30 . 53) (29 . 54) (1 . -31)) ((24 . 51) (23 . 52) (1 . -37))
((24 . 51) (23 . 52) (1 . -36)) ((24 . 51) (23 . 52) (1 . -35)) ((24 . 51)
(23 . 52) (1 . -34)) ((22 . 47) (21 . 48) (20 . 49) (19 . 50) (1 . -40))
((22 . 47) (21 . 48) (20 . 49) (19 . 50) (1 . -39)) ((18 . 45) (17 . 46)
(1 . -42)) ((32 . 44) (1 . -44)) ((16 . 43) (1 . -46)) ((15 . 42) (1 . -48
)) ((14 . 41) (1 . -50)) ((11 . 92)) ((3 . 1) (4 . 2) (5 . 3) (6 . 4)
(7 . 5) (8 . 6) (9 . 7) (10 . 8) (41 . 9) (60 . 10) (61 . 11) (62 . 12)
(27 . 13) (28 . 14) (29 . 15) (30 . 16) (31 . 17) (32 . 18) (59 . 19)
(33 . 20) (56 . 21) (34 . 22) (35 . 23) (58 . 24) (57 . 25) (55 . 26)
(54 . 27) (53 . 28) (52 . 29) (51 . 30) (50 . 31) (49 . 32) (48 . 33)
(47 . 34) (46 . 35) (45 . 36) (44 . 94)) ((1 . -6)) ((1 . -52))))
(define c99cx-tables
(list
(cons 'mtab c99cx-mtab)
(cons 'ntab c99cx-ntab)
(cons 'len-v c99cx-len-v)
(cons 'rto-v c99cx-rto-v)
(cons 'pat-v c99cx-pat-v)
))
;;; end tables

1081
sysa/mes-0.22/module/nyacc/lang/c99/mach.d/c99x-act.scm Normal file
View file

File diff suppressed because it is too large Load diff

1156
sysa/mes-0.22/module/nyacc/lang/c99/mach.d/c99x-tab.scm Normal file
View file

File diff suppressed because it is too large Load diff

130
sysa/mes-0.22/module/nyacc/lang/c99/mach.d/cpp-act.scm Normal file
View file

@ -0,0 +1,130 @@
;; cpp-act.scm
;; Copyright (C) 2016,2017 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;; See the file COPYING included with the this distribution.
(define cpp-act-v
(vector
;; $start => conditional-expression
(lambda ($1 . $rest) $1)
;; conditional-expression => logical-or-expression
(lambda ($1 . $rest) $1)
;; conditional-expression => logical-or-expression "?" logical-or-expres...
(lambda ($5 $4 $3 $2 $1 . $rest)
`(cond-expr ,$1 ,$3 ,$5))
;; logical-or-expression => logical-and-expression
(lambda ($1 . $rest) $1)
;; logical-or-expression => logical-or-expression "||" logical-and-expre...
(lambda ($3 $2 $1 . $rest) `(or ,$1 ,$3))
;; logical-and-expression => bitwise-or-expression
(lambda ($1 . $rest) $1)
;; logical-and-expression => logical-and-expression "&&" bitwise-or-expr...
(lambda ($3 $2 $1 . $rest) `(and ,$1 ,$3))
;; bitwise-or-expression => bitwise-xor-expression
(lambda ($1 . $rest) $1)
;; bitwise-or-expression => bitwise-or-expression "|" bitwise-xor-expres...
(lambda ($3 $2 $1 . $rest) `(bitwise-or ,$1 ,$3))
;; bitwise-xor-expression => bitwise-and-expression
(lambda ($1 . $rest) $1)
;; bitwise-xor-expression => bitwise-xor-expression "^" bitwise-and-expr...
(lambda ($3 $2 $1 . $rest)
`(bitwise-xor ,$1 ,$3))
;; bitwise-and-expression => equality-expression
(lambda ($1 . $rest) $1)
;; bitwise-and-expression => bitwise-and-expression "&" equality-expression
(lambda ($3 $2 $1 . $rest)
`(bitwise-and ,$1 ,$3))
;; equality-expression => relational-expression
(lambda ($1 . $rest) $1)
;; equality-expression => equality-expression "==" relational-expression
(lambda ($3 $2 $1 . $rest) `(eq ,$1 ,$3))
;; equality-expression => equality-expression "!=" relational-expression
(lambda ($3 $2 $1 . $rest) `(ne ,$1 ,$3))
;; relational-expression => shift-expression
(lambda ($1 . $rest) $1)
;; relational-expression => relational-expression "<" shift-expression
(lambda ($3 $2 $1 . $rest) `(lt ,$1 ,$3))
;; relational-expression => relational-expression "<=" shift-expression
(lambda ($3 $2 $1 . $rest) `(le ,$1 ,$3))
;; relational-expression => relational-expression ">" shift-expression
(lambda ($3 $2 $1 . $rest) `(gt ,$1 ,$3))
;; relational-expression => relational-expression ">=" shift-expression
(lambda ($3 $2 $1 . $rest) `(ge ,$1 ,$3))
;; shift-expression => additive-expression
(lambda ($1 . $rest) $1)
;; shift-expression => shift-expression "<<" additive-expression
(lambda ($3 $2 $1 . $rest) `(lshift ,$1 ,$3))
;; shift-expression => shift-expression ">>" additive-expression
(lambda ($3 $2 $1 . $rest) `(rshift ,$1 ,$3))
;; additive-expression => multiplicative-expression
(lambda ($1 . $rest) $1)
;; additive-expression => additive-expression "+" multiplicative-expression
(lambda ($3 $2 $1 . $rest) `(add ,$1 ,$3))
;; additive-expression => additive-expression "-" multiplicative-expression
(lambda ($3 $2 $1 . $rest) `(sub ,$1 ,$3))
;; multiplicative-expression => unary-expression
(lambda ($1 . $rest) $1)
;; multiplicative-expression => multiplicative-expression "*" unary-expr...
(lambda ($3 $2 $1 . $rest) `(mul ,$1 ,$3))
;; multiplicative-expression => multiplicative-expression "/" unary-expr...
(lambda ($3 $2 $1 . $rest) `(div ,$1 ,$3))
;; multiplicative-expression => multiplicative-expression "%" unary-expr...
(lambda ($3 $2 $1 . $rest) `(mod ,$1 ,$3))
;; unary-expression => postfix-expression
(lambda ($1 . $rest) $1)
;; unary-expression => "-" unary-expression
(lambda ($2 $1 . $rest) `(neg ,$2))
;; unary-expression => "+" unary-expression
(lambda ($2 $1 . $rest) `(pos ,$2))
;; unary-expression => "!" unary-expression
(lambda ($2 $1 . $rest) `(not ,$2))
;; unary-expression => "~" unary-expression
(lambda ($2 $1 . $rest) `(bitwise-not ,$2))
;; unary-expression => "++" unary-expression
(lambda ($2 $1 . $rest) `(pre-inc ,$2))
;; unary-expression => "--" unary-expression
(lambda ($2 $1 . $rest) `(pre-dec ,$2))
;; postfix-expression => primary-expression
(lambda ($1 . $rest) $1)
;; postfix-expression => postfix-expression "++"
(lambda ($2 $1 . $rest) `(post-inc ,$1))
;; postfix-expression => postfix-expression "--"
(lambda ($2 $1 . $rest) `(post-dec ,$1))
;; primary-expression => '$ident
(lambda ($1 . $rest) `(ident ,$1))
;; primary-expression => '$fixed
(lambda ($1 . $rest) `(fixed ,$1))
;; primary-expression => '$chlit
(lambda ($1 . $rest) `(char ,$1))
;; primary-expression => '$chlit/L
(lambda ($1 . $rest)
`(char (@ (type "wchar_t")) ,$1))
;; primary-expression => '$chlit/u
(lambda ($1 . $rest)
`(char (@ (type "char16_t")) ,$1))
;; primary-expression => '$chlit/U
(lambda ($1 . $rest)
`(char (@ (type "char32_t")) ,$1))
;; primary-expression => "defined" "(" '$ident ")"
(lambda ($4 $3 $2 $1 . $rest) `(defined ,$3))
;; primary-expression => "defined" '$ident
(lambda ($2 $1 . $rest) `(defined ,$2))
;; primary-expression => "__has_include__" "(" '$string ")"
(lambda ($4 $3 $2 $1 . $rest) `(has-include ,$3))
;; primary-expression => "__has_include_next__" "(" '$string ")"
(lambda ($4 $3 $2 $1 . $rest)
`(has-include-next ,$3))
;; primary-expression => "(" expression-list ")"
(lambda ($3 $2 $1 . $rest) $2)
;; expression-list => conditional-expression
(lambda ($1 . $rest) $1)
;; expression-list => expression-list "," conditional-expression
(lambda ($3 $2 $1 . $rest) $3)
))
;;; end tables

159
sysa/mes-0.22/module/nyacc/lang/c99/mach.d/cpp-tab.scm Normal file
View file

@ -0,0 +1,159 @@
;; cpp-tab.scm
;; Copyright (C) 2016,2017 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;; See the file COPYING included with the this distribution.
(define cpp-mtab
'(($start . 56) ("," . 3) ("__has_include_next__" . 4) ($string . 5)
("__has_include__" . 6) (")" . 7) ("(" . 8) ("defined" . 9) ($chlit/U . 10
) ($chlit/u . 11) ($chlit/L . 12) ($chlit . 13) ($fixed . 14) ($ident . 15
) ("--" . 16) ("++" . 17) ("~" . 18) ("!" . 19) ("%" . 20) ("/" . 21)
("*" . 22) ("-" . 23) ("+" . 24) (">>" . 25) ("<<" . 26) (">=" . 27)
(">" . 28) ("<=" . 29) ("<" . 30) ("!=" . 31) ("==" . 32) ("&" . 33)
("^" . 34) ("|" . 35) ("&&" . 36) ("||" . 37) (":" . 38) ("?" . 39)
($error . 2) ($end . 41)))
(define cpp-ntab
'((42 . expression-list) (43 . primary-expression) (44 . postfix-expression)
(45 . unary-expression) (46 . multiplicative-expression) (47 .
additive-expression) (48 . shift-expression) (49 . relational-expression)
(50 . equality-expression) (51 . bitwise-and-expression) (52 .
bitwise-xor-expression) (53 . bitwise-or-expression) (54 .
logical-and-expression) (55 . logical-or-expression) (56 .
conditional-expression)))
(define cpp-len-v
#(1 1 5 1 3 1 3 1 3 1 3 1 3 1 3 3 1 3 3 3 3 1 3 3 1 3 3 1 3 3 3 1 2 2 2 2 2
2 1 2 2 1 1 1 1 1 1 4 2 4 4 3 1 3))
(define cpp-rto-v
#(#f 56 56 55 55 54 54 53 53 52 52 51 51 50 50 50 49 49 49 49 49 48 48 48
47 47 47 46 46 46 46 45 45 45 45 45 45 45 44 44 44 43 43 43 43 43 43 43 43
43 43 43 42 42))
(define cpp-pat-v
#(((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7) (13 . 8)
(14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14) (19 . 15)
(24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20) (47 . 21) (48 . 22)
(49 . 23) (50 . 24) (51 . 25) (52 . 26) (53 . 27) (54 . 28) (55 . 29)
(56 . 30)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7)
(13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14)
(19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20) (47 . 21)
(48 . 22) (49 . 23) (50 . 24) (51 . 25) (52 . 26) (53 . 27) (54 . 28)
(55 . 29) (56 . 62) (42 . 63)) ((8 . 61)) ((8 . 60)) ((8 . 58) (15 . 59))
((1 . -46)) ((1 . -45)) ((1 . -44)) ((1 . -43)) ((1 . -42)) ((1 . -41))
((1 . -38)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7)
(13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14)
(19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 57)) ((8 . 1) (4 . 2)
(6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7) (13 . 8) (14 . 9) (15 . 10)
(43 . 11) (16 . 12) (17 . 13) (18 . 14) (19 . 15) (24 . 16) (23 . 17)
(44 . 18) (45 . 56)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6)
(12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13)
(18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 55)) ((8 . 1)
(4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7) (13 . 8) (14 . 9)
(15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14) (19 . 15) (24 . 16)
(23 . 17) (44 . 18) (45 . 54)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5)
(11 . 6) (12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13
) (18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 53)) ((8 . 1)
(4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7) (13 . 8) (14 . 9)
(15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14) (19 . 15) (24 . 16)
(23 . 17) (44 . 18) (45 . 52)) ((17 . 50) (16 . 51) (1 . -31)) ((1 . -27))
((22 . 47) (21 . 48) (20 . 49) (1 . -24)) ((24 . 45) (23 . 46) (1 . -21))
((26 . 43) (25 . 44) (1 . -16)) ((30 . 39) (29 . 40) (28 . 41) (27 . 42)
(1 . -13)) ((32 . 37) (31 . 38) (1 . -11)) ((33 . 36) (1 . -9)) ((34 . 35)
(1 . -7)) ((35 . 34) (1 . -5)) ((36 . 33) (1 . -3)) ((39 . 31) (37 . 32)
(1 . -1)) ((41 . 0)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6)
(12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13)
(18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20)
(47 . 21) (48 . 22) (49 . 23) (50 . 24) (51 . 25) (52 . 26) (53 . 27)
(54 . 28) (55 . 87)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6)
(12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13)
(18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20)
(47 . 21) (48 . 22) (49 . 23) (50 . 24) (51 . 25) (52 . 26) (53 . 27)
(54 . 86)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7)
(13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14)
(19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20) (47 . 21)
(48 . 22) (49 . 23) (50 . 24) (51 . 25) (52 . 26) (53 . 85)) ((8 . 1)
(4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7) (13 . 8) (14 . 9)
(15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14) (19 . 15) (24 . 16)
(23 . 17) (44 . 18) (45 . 19) (46 . 20) (47 . 21) (48 . 22) (49 . 23)
(50 . 24) (51 . 25) (52 . 84)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5)
(11 . 6) (12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13
) (18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20)
(47 . 21) (48 . 22) (49 . 23) (50 . 24) (51 . 83)) ((8 . 1) (4 . 2)
(6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7) (13 . 8) (14 . 9) (15 . 10)
(43 . 11) (16 . 12) (17 . 13) (18 . 14) (19 . 15) (24 . 16) (23 . 17)
(44 . 18) (45 . 19) (46 . 20) (47 . 21) (48 . 22) (49 . 23) (50 . 82))
((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7) (13 . 8)
(14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14) (19 . 15)
(24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20) (47 . 21) (48 . 22)
(49 . 81)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7)
(13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14)
(19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20) (47 . 21)
(48 . 22) (49 . 80)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6)
(12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13)
(18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20)
(47 . 21) (48 . 79)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6)
(12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13)
(18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20)
(47 . 21) (48 . 78)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6)
(12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13)
(18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20)
(47 . 21) (48 . 77)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6)
(12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13)
(18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20)
(47 . 21) (48 . 76)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6)
(12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13)
(18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20)
(47 . 75)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7)
(13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14)
(19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20) (47 . 74))
((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7) (13 . 8)
(14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14) (19 . 15)
(24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 73)) ((8 . 1) (4 . 2)
(6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7) (13 . 8) (14 . 9) (15 . 10)
(43 . 11) (16 . 12) (17 . 13) (18 . 14) (19 . 15) (24 . 16) (23 . 17)
(44 . 18) (45 . 19) (46 . 72)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5)
(11 . 6) (12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13
) (18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 71)) ((8 . 1)
(4 . 2) (6 . 3) (9 . 4) (10 . 5) (11 . 6) (12 . 7) (13 . 8) (14 . 9)
(15 . 10) (43 . 11) (16 . 12) (17 . 13) (18 . 14) (19 . 15) (24 . 16)
(23 . 17) (44 . 18) (45 . 70)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5)
(11 . 6) (12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13
) (18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 69)) ((1 . -39))
((1 . -40)) ((1 . -32)) ((1 . -33)) ((1 . -34)) ((1 . -35)) ((1 . -36))
((1 . -37)) ((15 . 68)) ((1 . -48)) ((5 . 67)) ((5 . 66)) ((1 . -52))
((7 . 64) (3 . 65)) ((1 . -51)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5)
(11 . 6) (12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13
) (18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20)
(47 . 21) (48 . 22) (49 . 23) (50 . 24) (51 . 25) (52 . 26) (53 . 27)
(54 . 28) (55 . 29) (56 . 92)) ((7 . 91)) ((7 . 90)) ((7 . 89)) ((1 . -30)
) ((1 . -29)) ((1 . -28)) ((22 . 47) (21 . 48) (20 . 49) (1 . -26))
((22 . 47) (21 . 48) (20 . 49) (1 . -25)) ((24 . 45) (23 . 46) (1 . -23))
((24 . 45) (23 . 46) (1 . -22)) ((26 . 43) (25 . 44) (1 . -20)) ((26 . 43)
(25 . 44) (1 . -19)) ((26 . 43) (25 . 44) (1 . -18)) ((26 . 43) (25 . 44)
(1 . -17)) ((30 . 39) (29 . 40) (28 . 41) (27 . 42) (1 . -15)) ((30 . 39)
(29 . 40) (28 . 41) (27 . 42) (1 . -14)) ((32 . 37) (31 . 38) (1 . -12))
((33 . 36) (1 . -10)) ((34 . 35) (1 . -8)) ((35 . 34) (1 . -6)) ((36 . 33)
(1 . -4)) ((38 . 88) (37 . 32)) ((8 . 1) (4 . 2) (6 . 3) (9 . 4) (10 . 5)
(11 . 6) (12 . 7) (13 . 8) (14 . 9) (15 . 10) (43 . 11) (16 . 12) (17 . 13
) (18 . 14) (19 . 15) (24 . 16) (23 . 17) (44 . 18) (45 . 19) (46 . 20)
(47 . 21) (48 . 22) (49 . 23) (50 . 24) (51 . 25) (52 . 26) (53 . 27)
(54 . 28) (55 . 29) (56 . 93)) ((1 . -47)) ((1 . -49)) ((1 . -50))
((1 . -53)) ((1 . -2))))
(define cpp-tables
(list
(cons 'mtab cpp-mtab)
(cons 'ntab cpp-ntab)
(cons 'len-v cpp-len-v)
(cons 'rto-v cpp-rto-v)
(cons 'pat-v cpp-pat-v)
))
;;; end tables

891
sysa/mes-0.22/module/nyacc/lang/c99/mach.scm Normal file
View file

@ -0,0 +1,891 @@
;;; lang/c99/mach.scm - C parser grammer
;; Copyright (C) 2015-2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.
;;; Notes:
;; This is a C parser, based on ISO-C99, with comments and CPP statements.
;; Currentl K&R function definitions are not supported:
;; int f(x) int x; { ... } => syntax error
;; because they lead to an ambiguous grammar, I believe:
;; int f(x) __attribute__((__static__)) int x; { ... }
;; See also:
;; http://www.quut.com/c/ANSI-C-grammar-y.html - C11 grammar
;; https://gcc.gnu.org/onlinedocs/gcc/C-Extensions.html#C-Extensions
;;; Code:
(define-module (nyacc lang c99 mach)
#:export (c99-spec c99-mach c99x-spec c99x-mach gen-c99-files)
#:use-module (nyacc lang c99 cpp)
#:use-module (nyacc lang util)
#:use-module (nyacc lalr)
#:use-module (nyacc parse)
#:use-module (nyacc lex)
#:use-module (nyacc util)
#:use-module ((srfi srfi-43) #:select (vector-map)))
;; @deffn {Variable} c99-spec
;; This variable is the specification a-list for the hacked ISO C99 language.
;; Well, actually, this does not produce pure C99 spec: it has been extended
;; to be able be used for practical purposes so it now parses forms like
;; @code{__asm__} and @code{__attribute__}.
;; Run this through @code{make-lalr-machine} to get an a-list for the
;; automaton. The grammar is modified to parse CPP statements and comments.
;; The output of the end parser will be a SXML tree (w/o the @code{*TOP*} node.
;; @end deffn
(define c99-spec
(lalr-spec
(notice (string-append "Copyright (C) 2016-2018 Matthew R. Wette"
license-lgpl3+))
(prec< 'then "else") ; "then/else" SR-conflict resolution
(prec< 'imp ; "implied type" SR-conflict resolution
(nonassoc "char" "short" "int" "long" "_Fract" "_Accum" "_Sat")
(nonassoc "float" "double" "_Complex"))
(prec< 'shift-on-attr ; living on the edge ...
(nonassoc "__attribute__" "__packed__" "__aligned__" "__alignof__")
'reduce-on-attr
'reduce-on-semi
(nonassoc "*" "(" '$ident))
(start translation-unit)
(grammar
;; === expressions ========================================================
(primary-expression ; S 6.5.1
(identifier ($$ `(p-expr ,$1)))
(constant ($$ `(p-expr ,$1)))
(string-literal ($$ `(p-expr ,$1)))
("(" expression ")" ($$ $2))
("(" "{" ($$ (cpi-push)) block-item-list ($$ (cpi-pop)) "}" ")"
($$ `(stmt-expr (@ (extension "GNUC")) ,$4))))
(postfix-expression ; S 6.5.2
(primary-expression)
(postfix-expression "[" expression "]" ($$ `(array-ref ,$3 ,$1)))
(postfix-expression "(" argument-expression-list ")"
($$ `(fctn-call ,$1 ,(tl->list $3))))
(postfix-expression "(" ")" ($$ `(fctn-call ,$1 (expr-list))))
(postfix-expression "." identifier ($$ `(d-sel ,$3 ,$1)))
(postfix-expression "->" identifier ($$ `(i-sel ,$3 ,$1)))
(postfix-expression "++" ($$ `(post-inc ,$1)))
(postfix-expression "--" ($$ `(post-dec ,$1)))
("(" type-name ")" "{" initializer-list "}"
($$ `(comp-lit ,$2 ,(tl->list $5))))
("(" type-name ")" "{" initializer-list "," "}"
($$ `(comp-lit ,$2 ,(tl->list $5)))))
(argument-expression-list
(assignment-expression ($$ (make-tl 'expr-list $1)))
(argument-expression-list "," assignment-expression ($$ (tl-append $1 $3)))
;; The following is a hack to deal with using abstract declarations
;; as arguments to CPP macros (e.g., see offsetof in <stddef.h>).
(arg-expr-hack ($$ (make-tl 'expr-list $1)))
(argument-expression-list "," arg-expr-hack ($$ (tl-append $1 $3))))
(arg-expr-hack
(declaration-specifiers
abstract-declarator ($$ `(param-decl ,(tl->list $1) $2)))
(declaration-specifiers ($$ `(param-decl ,(tl->list $1)))))
(unary-expression
(postfix-expression) ; S 6.5.3
("++" unary-expression ($$ `(pre-inc ,$2)))
("--" unary-expression ($$ `(pre-dec ,$2)))
(unary-operator cast-expression ($$ (list $1 $2)))
("sizeof" unary-expression ($$ `(sizeof-expr ,$2)))
("sizeof" "(" type-name ")" ($$ `(sizeof-type ,$3)))
)
(unary-operator ("&" ($$ 'ref-to)) ("*" ($$ 'de-ref))
("+" ($$ 'pos)) ("-" ($$ 'neg))
("~" ($$ 'bitwise-not)) ("!" ($$ 'not)))
(cast-expression ; S 6.5.4
(unary-expression)
("(" type-name ")" cast-expression ($$ `(cast ,$2 ,$4))))
(multiplicative-expression ; S 6.5.5
(cast-expression)
(multiplicative-expression "*" cast-expression ($$ `(mul ,$1 ,$3)))
(multiplicative-expression "/" cast-expression ($$ `(div ,$1 ,$3)))
(multiplicative-expression "%" cast-expression ($$ `(mod ,$1 ,$3))))
(additive-expression ; S 6.5.6
(multiplicative-expression)
(additive-expression "+" multiplicative-expression ($$ `(add ,$1 ,$3)))
(additive-expression "-" multiplicative-expression ($$ `(sub ,$1 ,$3))))
(shift-expression ; S 6.5.7
(additive-expression)
(shift-expression "<<" additive-expression ($$ `(lshift ,$1 ,$3)))
(shift-expression ">>" additive-expression ($$ `(rshift ,$1 ,$3))))
(relational-expression ; S 6.5.8
(shift-expression)
(relational-expression "<" shift-expression ($$ `(lt ,$1 ,$3)))
(relational-expression ">" shift-expression ($$ `(gt ,$1 ,$3)))
(relational-expression "<=" shift-expression ($$ `(le ,$1 ,$3)))
(relational-expression ">=" shift-expression ($$ `(ge ,$1 ,$3))))
(equality-expression ; S 6.5.9
(relational-expression)
(equality-expression "==" relational-expression ($$ `(eq ,$1 ,$3)))
(equality-expression "!=" relational-expression ($$ `(ne ,$1 ,$3))))
;; called AND-expression
(bitwise-and-expression ; S 6.5.10
(equality-expression)
(bitwise-and-expression "&" equality-expression
($$ `(bitwise-and ,$1 ,$3))))
;; called exclusive-OR-expression
(bitwise-xor-expression ; S 6.5.11
(bitwise-and-expression)
(bitwise-xor-expression "^" bitwise-and-expression
($$ `(bitwise-xor ,$1 ,$3))))
;; called inclusive-OR-expression
(bitwise-or-expression ; S 6.5.12
(bitwise-xor-expression)
(bitwise-or-expression "|" bitwise-xor-expression
($$ `(bitwise-or ,$1 ,$3))))
(logical-and-expression ; S 6.5.13
(bitwise-or-expression)
(logical-and-expression "&&" bitwise-or-expression
($$ `(and ,$1 ,$3))))
(logical-or-expression ; 6.5.14
(logical-and-expression)
(logical-or-expression "||" logical-and-expression
($$ `(or ,$1 ,$3))))
(conditional-expression
(logical-or-expression)
(logical-or-expression "?" expression ":" conditional-expression
($$ `(cond-expr ,$1 ,$3 ,$5))))
(assignment-expression ; S 6.5.16
(conditional-expression)
(unary-expression assignment-operator assignment-expression
($$ `(assn-expr ,$1 (op ,$2) ,$3))))
(assignment-operator
("=") ("+=") ("-=") ("*=") ("/=") ("%=")
("<<=") (">>=") ("&=") ("^=") ("|="))
(expression ; S 6.5.17
(assignment-expression)
(expression "," assignment-expression
($$ (if (eqv? 'comma-expr (sx-tag $1))
(append $1 (list $3))
`(comma-expr ,$1 ,$3)))))
(constant-expression ; S 6.6
(conditional-expression))
;; === declarations
;; TODO: check if we should move attributes or trap attribute-only spec's
(declaration ; S 6.7
(declaration-no-comment ";")
(declaration-no-comment ";" code-comment ($$ (sx-attr-add $1 $3))))
(declaration-no-comment
(declaration-specifiers
init-declarator-list
($$ (save-typenames `(decl ,$1 ,$2))))
(declaration-specifiers
($$ `(decl ,$1))))
;; --- declaration specifiers
(declaration-specifiers ; S 6.7
(declaration-specifiers-1 ($$ (process-specs (tl->list $1)))))
(declaration-specifiers-1
;; storage-class-specifiers
(storage-class-specifier
($prec 'shift-on-attr) ($$ (make-tl 'decl-spec-list $1)))
(storage-class-specifier declaration-specifiers-1 ($$ (tl-insert $2 $1)))
;; type-specifiers
(type-specifier
($prec 'reduce-on-attr) ($$ (make-tl 'decl-spec-list $1)))
(type-specifier declaration-specifiers-1 ($$ (tl-insert $2 $1)))
;; type-qualifiers
(type-qualifier
($prec 'shift-on-attr) ($$ (make-tl 'decl-spec-list $1)))
(type-qualifier declaration-specifiers-1 ($$ (tl-insert $2 $1)))
;; function-specifiers
(function-specifier
($prec 'reduce-on-attr) ($$ (make-tl 'decl-spec-list $1)))
(function-specifier declaration-specifiers-1 ($$ (tl-insert $2 $1)))
;; attribute-specifiers
(attribute-specifier
($prec 'reduce-on-semi) ($$ (make-tl 'decl-spec-list $1)))
(attribute-specifier declaration-specifiers-1 ($$ (tl-insert $2 $1))))
(storage-class-specifier ; S 6.7.1
("auto" ($$ '(stor-spec (auto))))
("extern" ($$ '(stor-spec (extern))))
("register" ($$ '(stor-spec (register))))
("static" ($$ '(stor-spec (static))))
("typedef" ($$ '(stor-spec (typedef)))))
;; I have created fixed-, float- and complex- type specifiers to capture
;; combinations like "short int" "long long" etc.
(type-specifier ; S 6.7.2
("void" ($$ '(type-spec (void))))
(fixed-type-specifier ($$ `(type-spec ,$1)))
(float-type-specifier ($$ `(type-spec ,$1)))
(fixpt-type-specifier ($$ `(type-spec ,$1)))
("_Bool" ($$/ref 's5.1.5-01 '(type-spec (fixed-type "_Bool"))))
(complex-type-specifier ($$ `(type-spec ,$1)))
(struct-or-union-specifier ($$ `(type-spec ,$1)))
(enum-specifier ($$ `(type-spec ,$1)))
(typedef-name ($$ `(type-spec ,$1))))
(fixed-type-specifier
("short" ($prec 'imp) ($$ '(fixed-type "short")))
("short" "int" ($$ '(fixed-type "short int")))
("signed" "short" ($prec 'imp) ($$ '(fixed-type "signed short")))
("signed" "short" "int" ($$ '(fixed-type "signed short int")))
("int" ($$ '(fixed-type "int")))
("signed" ($prec 'imp) ($$ '(fixed-type "signed")))
("signed" "int" ($$ '(fixed-type "signed int")))
("long" ($prec 'imp) ($$ '(fixed-type "long")))
("long" "int" ($$ '(fixed-type "long int")))
("signed" "long" ($prec 'imp) ($$ '(fixed-type "signed long")))
("signed" "long" "int" ($$ '(fixed-type "signed long int")))
("long" "long" ($prec 'imp) ($$ '(fixed-type "long long")))
("long" "long" "int" ($$ '(fixed-type "long long int")))
("signed" "long" "long" ($prec 'imp)
($$ '(fixed-type "signed long long")))
("signed" "long" "long" "int" ($$ '(fixed-type "signed long long int")))
("unsigned" "short" "int" ($$ '(fixed-type "unsigned short int")))
("unsigned" "short" ($prec 'imp) ($$ '(fixed-type "unsigned short")))
("unsigned" "int" ($$ '(fixed-type "unsigned int")))
("unsigned" ($prec 'imp) ($$ '(fixed-type "unsigned")))
("unsigned" "long" "int" ($$ '(fixed-type "unsigned long")))
("unsigned" "long" ($prec 'imp) ($$ '(fixed-type "unsigned long")))
("unsigned" "long" "long" "int"
($$ '(fixed-type "unsigned long long int")))
("unsigned" "long" "long" ($prec 'imp)
($$ '(fixed-type "unsigned long long")))
("char" ($$ '(fixed-type "char")))
("signed" "char" ($$ '(fixed-type "signed char")))
("unsigned" "char" ($$ '(fixed-type "unsigned char"))))
(float-type-specifier
("float" ($prec 'imp) ($$ '(float-type "float")))
("double" ($prec 'imp) ($$ '(float-type "double")))
("long" "double" ($$ '(float-type "long double"))))
(complex-type-specifier
("_Complex" ($$ '(complex-type "_Complex")))
("float" "_Complex" ($$ '(complex-type "float _Complex")))
("double" "_Complex" ($$ '(complex-type "double _Complex")))
("long" "double" "_Complex" ($$ '(complex-type "long double _Complex"))))
(fixpt-type-specifier
;; http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2001/n1290.pdf
("short" "_Fract" ($$ '(fixpt-type "short _Fract")))
("_Fract" ($$ '(fixpt-type "_Fract")))
("long" "_Fract" ($$ '(fixpt-type "long _Fract")))
("signed" "short" "_Fract" ($$ '(fixpt-type "signd short _Fract")))
("signed" "_Fract" ($$ '(fixpt-type "signed _Fract")))
("signed" "long _Fract" ($$ '(fixpt-type "signed long _Fract")))
("unsigned" "short" "_Fract" ($$ '(fixpt-type "unsigned short _Fract")))
("unsigned" "_Fract" ($$ '(fixpt-type "unsigned _Fract")))
("unsigned" "long _Fract" ($$ '(fixpt-type "unsigned long _Fract")))
("short" "_Accum" ($$ '(fixpt-type "short _Accum")))
("_Accum" ($$ '(fixpt-type "_Accum")))
("long _Accum" ($$ '(fixpt-type "long _Accum")))
("signed" "short" "_Accum" ($$ '(fixpt-type "signd short _Accum")))
("signed" "_Accum" ($$ '(fixpt-type "signed _Accum")))
("signed" "long" "_Accum" ($$ '(fixpt-type "signed long _Accum")))
("unsigned" "short" "_Accum" ($$ '(fixpt-type "unsigned short _Accum")))
("unsigned" "_Accum" ($$ '(fixpt-type "unsigned _Accum")))
("unsigned" "long" "_Accum" ($$ '(fixpt-type "unsigned long _Accum")))
("_Sat" "short" "_Fract" ($$ '(fixpt-type "_Sat short _Fract")))
("_Sat" "_Fract" ($$ '(fixpt-type "_Sat _Fract")))
("_Sat" "long" "_Fract" ($$ '(fixpt-type "_Sat long _Fract")))
("_Sat" "signed" "short" "_Fract"
($$ '(fixpt-type "_Sat signd short _Fract")))
("_Sat" "signed" "_Fract" ($$ '(fixpt-type "_Sat signed _Fract")))
("_Sat" "signed" "long _Fract"
($$ '(fixpt-type "_Sat signed long _Fract")))
("_Sat" "unsigned" "short" "_Fract"
($$ '(fixpt-type "_Sat unsigned short _Fract")))
("_Sat" "unsigned" "_Fract" ($$ '(fixpt-type "_Sat unsigned _Fract")))
("_Sat" "unsigned" "long" "_Fract"
($$ '(fixpt-type "_Sat unsigned long _Fract")))
("_Sat" "short" "_Accum" ($$ '(fixpt-type "_Sat short _Accum")))
("_Sat" "_Accum" ($$ '(fixpt-type "_Sat _Accum")))
("_Sat" "long" "_Accum" ($$ '(fixpt-type "_Sat long _Accum")))
("_Sat" "signed" "short" "_Accum"
($$ '(fixpt-type "_Sat signd short _Accum")))
("_Sat" "signed" "_Accum" ($$ '(fixpt-type "_Sat signed _Accum")))
("_Sat" "signed" "long" "_Accum"
($$ '(fixpt-type "_Sat signed long _Accum")))
("_Sat" "unsigned" "short" "_Accum"
($$ '(fixpt-type "_Sat unsigned short _Accum")))
("_Sat" "unsigned" "_Accum" ($$ '(fixpt-type "_Sat unsigned _Accum")))
("_Sat" "unsigned" "long" "_Accum"
($$ '(fixpt-type "_Sat unsigned long _Accum"))))
;; This one modified: split out struct-or-union = "struct"|"union"
(struct-or-union-specifier
("struct" opt-attr-specs ident-like "{" struct-declaration-list "}"
($$ (sx-join* 'struct-def $2 $3 (tl->list $5))))
("struct" opt-attr-specs "{" struct-declaration-list "}"
($$ (sx-join* 'struct-def $2 (tl->list $4))))
("struct" opt-attr-specs ident-like ($$ (sx-join* 'struct-ref $1 $3)))
("union" opt-attr-specs ident-like "{" struct-declaration-list "}"
($$ (sx-join* 'union-def $2 $3 (tl->list $5))))
("union" opt-attr-specs "{" struct-declaration-list "}"
($$ (sx-join* 'union-def $2 (tl->list $4))))
("union" opt-attr-specs ident-like ($$ (sx-join* 'union-ref $2 $3))))
;; because name following struct/union can be identifier or typeref:
(ident-like
(identifier)
(typedef-name ($$ `(ident ,(sx-ref $1 1)))))
(opt-attr-specs
($empty)
(attribute-specifiers ($$ `(@ ,(attrl->attrs $1)))))
;; Calling this field-list in the parse tree.
(struct-declaration-list ; S 6.7.2.1
(struct-declaration ($$ (make-tl 'field-list $1)))
(lone-comment ($$ (make-tl 'field-list $1)))
(struct-declaration-list struct-declaration ($$ (tl-append $1 $2)))
(struct-declaration-list lone-comment ($$ (tl-append $1 $2)))
;; Not in C99, but allowed by GNU, I believe:
(";" ($$ (make-tl 'field-list)))
(struct-declaration-list ";" ($$ $1)))
(struct-declaration ; S 6.7.2.1
(struct-declaration-no-comment ";")
(struct-declaration-no-comment ";" code-comment ($$ (sx-attr-add $1 $3))))
(struct-declaration-no-comment
(specifier-qualifier-list
struct-declarator-list ($$ `(comp-decl ,$1 ,(tl->list $2))))
(specifier-qualifier-list ($$ `(comp-decl ,$1)))) ;; <= anonymous
(specifier-qualifier-list ; S 6.7.2.1
(specifier-qualifier-list-1 ($$ (process-specs (tl->list $1)))))
(specifier-qualifier-list-1
(type-specifier ($$ (make-tl 'decl-spec-list $1)))
(type-specifier specifier-qualifier-list-1 ($$ (tl-insert $2 $1)))
(type-qualifier ($$ (make-tl 'decl-spec-list $1)))
(type-qualifier specifier-qualifier-list-1 ($$ (tl-insert $2 $1)))
(attribute-specifier ($$ (make-tl 'decl-spec-list $1)))
(attribute-specifier specifier-qualifier-list-1 ($$ (tl-insert $2 $1))))
(specifier-qualifier-list/no-attr
(specifier-qualifier-list/no-attr-1 ($$ (tl->list $1))))
(specifier-qualifier-list/no-attr-1
(type-specifier ($$ (make-tl 'decl-spec-list $1)))
(type-specifier specifier-qualifier-list/no-attr-1 ($$ (tl-insert $2 $1)))
(type-qualifier ($$ (make-tl 'decl-spec-list $1)))
(type-qualifier specifier-qualifier-list/no-attr-1 ($$ (tl-insert $2 $1))))
(struct-declarator-list ; S 6.7.2.1
(struct-declarator ($$ (make-tl 'comp-declr-list $1)))
(struct-declarator-list "," struct-declarator ($$ (tl-append $1 $3)))
(struct-declarator-list "," attribute-specifiers
struct-declarator ($$ (tl-append $1 $3 $4))))
(struct-declarator ; S 6.7.2.1
(struct-declarator-1 ($$ (process-declr $1))))
(struct-declarator-1
(declarator ($$ `(comp-declr ,$1)))
(declarator attribute-specifiers ($$ `(comp-declr ,$1 ,$2)))
(declarator ":" constant-expression
($$ `(comp-declr (bit-field ,$1 ,$3))))
(":" constant-expression ($$ `(comp-declr (bit-field ,$2)))))
(enum-specifier ; S 6.7.2.2
("enum" ident-like "{" enumerator-list "}"
($$ `(enum-def ,$2 ,(tl->list $4))))
("enum" ident-like "{" enumerator-list "," "}"
($$ `(enum-def ,$2 ,(tl->list $4))))
("enum" "{" enumerator-list "}" ($$ `(enum-def ,(tl->list $3))))
("enum" "{" enumerator-list "," "}" ($$ `(enum-def ,(tl->list $3))))
("enum" ident-like ($$ `(enum-ref ,$2))))
;; keeping old enum-def-list in parse tree
(enumerator-list ; S 6.7.2.2
(enumerator ($$ (make-tl 'enum-def-list $1)))
(enumerator-list "," enumerator ($$ (tl-append $1 $3))))
;; had to change enumeration-constant => identifier
(enumerator ; S 6.7.2.2
(identifier ($$ `(enum-defn ,$1)))
(identifier attribute-specifiers ($$ `(enum-defn ,$1 ,$2)))
(identifier "=" constant-expression ($$ `(enum-defn ,$1 ,$3))))
(type-qualifier
("const" ($$ `(type-qual ,$1)))
("volatile" ($$ `(type-qual ,$1)))
("restrict" ($$ `(type-qual ,$1))))
(function-specifier
("inline" ($$ `(fctn-spec ,$1)))
("_Noreturn" ($$ `(fctn-spec ,$1))))
;; Support for __attribute__(( ... )). See the gcc documentation.
;; The documentation does not seem rigourous about defining where the
;; attribute specifier can appear. This is my best attempt. MW 2018
;; https://gcc.gnu.org/onlinedocs/gcc-8.2.0/gcc/Attribute-Syntax.html
;; https://gcc.gnu.org/onlinedocs/gcc-8.2.0/gcc/Type-Attributes.html
;; https://gcc.gnu.org/onlinedocs/gcc-8.2.0/gcc/Variable-Attributes.html
;; https://gcc.gnu.org/onlinedocs/gcc-8.2.0/gcc/Function-Attributes.html
(attribute-specifiers
(attribute-specifier ($prec 'reduce-on-attr))
(attribute-specifiers attribute-specifier ($$ (append $1 (cdr $2)))))
;; (attributes (attribute "__static__") (attribute aligned(8)" ...)
(attribute-specifier
("__attribute__" "(" "(" attribute-list ")" ")" ($$ $4))
(attr-name ($$ `(attribute-list (attribute ,$1)))))
(attr-name
("__packed__" ($$ '(ident "__packed__")))
("__aligned__" ($$ '(ident "__aligned__")))
("__alignof__" ($$ '(ident "__alignof__"))))
(attribute-list (attribute-list-1 ($$ (tl->list $1))))
(attribute-list-1
(attribute ($$ (make-tl 'attribute-list $1)))
(attribute-list-1 "," attribute ($$ (tl-append $1 $3)))
(attribute-list-1 "," ($$ $1)))
(attribute
(attr-word ($$ `(attribute ,$1)))
(attr-word "(" attr-expr-list ")" ($$ `(attribute ,$1 ,$3)))
("const" ($$ `(attribute (ident "const")))))
(attr-word
(attr-name)
(identifier))
(attr-expr-list
(attr-expr-list-1 ($$ (tl->list $1))))
(attr-expr-list-1
(attribute-expr ($$ (make-tl 'attr-expr-list $1)))
(attr-expr-list-1 "," attribute-expr ($$ (tl-append $1 $3))))
(attribute-expr
(type-name)
($fixed ($$ `(fixed ,$1)))
(string-literal)
(identifier)
(attr-word "(" attr-expr-list ")" ($$ `(attribute ,$1 ,$3)))) ;; ???
;; --- declarators
(init-declarator-list ; S 6.7
(init-declarator-list-1 ($$ (tl->list $1))))
(init-declarator-list-1
(init-declarator ($$ (make-tl 'init-declr-list $1)))
(init-declarator-list-1 "," init-declarator ($$ (tl-append $1 $3)))
(init-declarator-list-1 "," attribute-specifiers
init-declarator ($$ (tl-append $1 $3 $4))))
(init-declarator ; S 6.7
(init-declarator-1 ($$ (process-declr $1))))
(init-declarator-1
(declarator ($$ `(init-declr ,$1)))
(declarator "=" initializer ($$ `(init-declr ,$1 ,$3)))
(declarator asm-expression ($$ `(init-declr ,$1 ,$2)))
(declarator asm-expression "=" initializer ($$ `(init-declr ,$1 ,$2 ,$4)))
(declarator attribute-specifiers ($$ `(init-declr ,$1 ,$2)))
(declarator attribute-specifiers "=" initializer
($$ `(init-declr ,$1 ,$2 ,$4)))
(declarator asm-expression attribute-specifiers
($$ `(init-declr ,$1 ,$2 ,$3))))
(declarator
(pointer direct-declarator ($$ `(ptr-declr ,$1 ,$2)))
(direct-declarator))
(pointer ; S 6.7.6
("*" type-qualifier-list pointer ($$ `(pointer ,$2 ,$3)))
("*" type-qualifier-list ($$ `(pointer ,$2)))
("*" pointer ($$ `(pointer ,$2)))
("*" attribute-specifiers pointer ($$ `(pointer ,$3)))
("*" ($$ '(pointer))))
(direct-declarator ; S 6.7.6
(identifier ($$ $1))
;;(ident-like ($$ $1))
("(" declarator ")" ($$ `(scope ,$2)))
("(" attribute-specifier declarator ")" ($$ `(scope ,$2)))
(direct-declarator
"[" type-qualifier-list assignment-expression "]"
($$ `(array-of ,$1 ,$3 ,$4)))
(direct-declarator
"[" type-qualifier-list "]" ($$ `(array-of ,$1 ,$3)))
(direct-declarator
"[" assignment-expression "]" ($$ `(array-of ,$1 ,$3)))
(direct-declarator
"[" "]" ($$ `(array-of ,$1)))
(direct-declarator
"[" "static" type-qualifier-list assignment-expression "]"
($$ `(array-of ,$1 ,$4 ,$5))) ;; FIXME $4 needs "static" added
(direct-declarator
"[" type-qualifier-list "static" assignment-expression "]"
($$ `(array-of ,$1 ,4 ,$5))) ;; FIXME $4 needs "static" added
(direct-declarator
"[" type-qualifier-list "*" "]" ; variable length array
($$ `(array-of ,$1 ,$3 (var-len))))
(direct-declarator
"[" "*" "]" ; variable length array
($$ `(array-of ,$1 (var-len))))
(direct-declarator
"(" parameter-type-list ")" ($$ `(ftn-declr ,$1 ,$3)))
(direct-declarator
"(" identifier-list ")" ($$ `(ftn-declr ,$1 ,$3)))
(direct-declarator
"(" ")" ($$ `(ftn-declr ,$1 (param-list)))))
(type-qualifier-list
(type-qualifier-list-1 ($$ (tl->list $1))))
(type-qualifier-list-1
(type-qualifier ($$ (make-tl 'type-qual-list $1)))
(type-qualifier-list-1 type-qualifier ($$ (tl-append $1 $2))))
(parameter-type-list
(parameter-list ($$ (tl->list $1)))
(parameter-list "," "..." ($$ (tl->list (tl-append $1 '(ellipsis))))))
(parameter-list
(parameter-declaration ($$ (make-tl 'param-list $1)))
(parameter-list "," parameter-declaration ($$ (tl-append $1 $3))))
(parameter-declaration
(declaration-specifiers
declarator ($$ `(param-decl ,$1 (param-declr ,$2))))
(declaration-specifiers
abstract-declarator ($$ `(param-decl ,$1 (param-declr ,$2))))
(declaration-specifiers
($$ `(param-decl ,$1))))
(identifier-list
(identifier-list-1 ($$ (tl->list $1))))
(identifier-list-1
(identifier ($$ (make-tl 'ident-list $1)))
(identifier-list-1 "," identifier ($$ (tl-append $1 $3))))
(type-name ; S 6.7.6
;; e.g., (foo_t *)
(specifier-qualifier-list/no-attr abstract-declarator
($$ `(type-name ,$1 ,$2)))
;; e.g., (int)
(declaration-specifiers ($$ `(type-name ,$1))))
(abstract-declarator ; S 6.7.6
(pointer direct-abstract-declarator ($$ `(abs-declr ,$1 ,$2)))
(pointer ($$ `(abs-declr ,$1)))
(direct-abstract-declarator ($$ `(abs-declr ,$1))))
(direct-abstract-declarator
("(" abstract-declarator ")" ($$ `(declr-scope ,$2)))
(direct-abstract-declarator
"[" type-qualifier-list assignment-expression "]"
($$ `(declr-array ,$1 ,$3 ,$4)))
(direct-abstract-declarator
"[" type-qualifier-list "]"
($$ `(declr-array ,$1 ,$3)))
(direct-abstract-declarator
"[" assignment-expression "]"
($$ `(declr-array ,$1 ,$3)))
(direct-abstract-declarator
"[" "]" ($$ `(declr-array ,$1)))
(direct-abstract-declarator
"[" "static" type-qualifier-list assignment-expression "]"
($$ `(declr-array
,$1 ,(tl->list (tl-insert $4 '(stor-spec "static"))) ,$5)))
(direct-abstract-declarator
"[" "static" type-qualifier-list "]"
($$ `(declr-array ,$1 ,(tl->list (tl-insert $4 '(stor-spec "static"))))))
(direct-abstract-declarator
"[" type-qualifier-list "static" assignment-expression "]"
($$ `(declr-array
,$1 ,(tl->list (tl-insert $3 '(stor-spec "static"))) ,$5)))
;;
("[" type-qualifier-list assignment-expression "]"
($$ `(declr-anon-array ,$2 ,$3)))
("[" type-qualifier-list "]" ($$ `(declr-anon-array ,$2)))
("[" assignment-expression "]" ($$ `(declr-anon-array ,$2)))
("[" "]" ($$ `(declr-anon-array)))
("[" "static" type-qualifier-list assignment-expression "]"
($$ `(declr-anon-array
,(tl->list (tl-insert $3 '(stor-spec "static"))) ,$4)))
("[" "static" type-qualifier-list "]"
($$ `(declr-anon-array ,(tl->list (tl-insert $3 '(stor-spec "static"))))))
("[" type-qualifier-list "static" assignment-expression "]"
($$ `(declr-anon-array
,(tl->list (tl-insert $2 '(stor-spec "static"))) ,$4)))
(direct-abstract-declarator "[" "*" "]" ($$ `(declr-star ,$1)))
("[" "*" "]" ($$ '(declr-star)))
(direct-abstract-declarator "(" parameter-type-list ")"
($$ `(abs-ftn-declr ,$1 ,$3)))
(direct-abstract-declarator "(" ")" ($$ `(abs-ftn-declr ,$1)))
("(" parameter-type-list ")" ($$ `(anon-ftn-declr ,$2)))
("(" ")" ($$ '(anon-ftn-declr))))
;; typedef-name is generated by the lexical analyzer
(typedef-name ('typename ($$ `(typename ,$1))))
;; --------------------------------
(initializer ; S 6.7.9
(assignment-expression ($$ `(initzer ,$1)))
("{" initializer-list "}" ($$ `(initzer ,(tl->list $2))))
("{" initializer-list "," "}" ($$ `(initzer ,(tl->list $2)))))
;; The designation productions are from C99.
(initializer-list
(designation initializer ($$ (make-tl 'initzer-list $1 $2)))
(initializer ($$ (make-tl 'initzer-list $1)))
(initializer-list "," designation initializer ($$ (tl-append $1 $3 $4)))
(initializer-list "," initializer ($$ (tl-append $1 $3))))
(designation ; S 6.7.8
(designator-list "=" ($$ `(desig ,$1))))
(designator-list
(designator ($$ (make-tl 'desgr-list $1)))
(designator-list designator ($$ (tl-append $1 $2))))
(designator
("[" constant-expression "]" ($$ `(array-dsgr ,$2)))
("." identifier ($$ `(sel-dsgr ,$2))))
;; === statements =========================================================
(statement
(labeled-statement)
(compound-statement)
(expression-statement)
(selection-statement)
(iteration-statement)
(jump-statement)
(asm-statement)
(pragma)
(cpp-statement))
(labeled-statement
(identifier ":" statement ($$ `(labeled-stmt ,$1 ,$3)))
(identifier ":" attribute-specifier statement
($$ `(labeled-stmt ,$1 ,$4)))
("case" constant-expression ":" statement ($$ `(case ,$2 ,$4)))
("default" ":" statement ($$ `(default ,$3))))
(compound-statement
("{" ($$ (cpi-push)) block-item-list ($$ (cpi-pop)) "}"
($$ `(compd-stmt ,(tl->list $3))))
("{" "}"
($$ `(compd-stmt (block-item-list)))))
(block-item-list
(block-item ($$ (make-tl 'block-item-list $1)))
(block-item-list block-item ($$ (tl-append $1 $2))))
(block-item
(declaration)
(statement))
(expression-statement
(expression ";" ($$ `(expr-stmt ,$1)))
(";" ($$ '(expr-stmt))))
(selection-statement
("if" "(" expression ")" statement ($prec 'then)
($$ `(if ,$3 ,$5)))
("if" "(" expression ")" statement "else" statement
($$ `(if ,$3 ,$5 ,$7)))
("switch" "(" expression ")" statement ($$ `(switch ,$3 ,$5))))
(iteration-statement
("while" "(" expression ")" statement ($$ `(while ,$3 ,$5)))
("do" statement "while" "(" expression ")" ";" ($$ `(do-while ,$2 ,$5)))
("for" "(" initial-clause opt-expression ";" opt-expression ")" statement
($$ `(for ,$3 ,$4 ,$6 ,$8))))
(initial-clause ; <= added for convenience
(expression ";")
(";" ($$ '(expr)))
(declaration))
(opt-expression ; <= added for convenience
($empty ($$ '(expr)))
(expression))
(jump-statement ; S 6.8.6
("goto" identifier ";" ($$ `(goto ,$2)))
("continue" ";" ($$ '(continue)))
("break" ";" ($$ '(break)))
("return" expression ";" ($$ `(return ,$2)))
("return" ";" ($$ `(return (expr)))))
(asm-statement
(asm-expression ";"))
(asm-expression
("__asm__" opt-asm-specifiers "(" string-literal ")"
($$ `(asm-expr (@ (extension "GNUC")) ,$4)))
("__asm__" opt-asm-specifiers "(" string-literal asm-outputs ")"
($$ `(asm-expr (@ (extension "GNUC")) ,$4 ,(tl->list $5))))
("__asm__" opt-asm-specifiers "(" string-literal asm-outputs asm-inputs ")"
($$ `(asm-expr (@ (extension "GNUC")) ,$4 ,(tl->list $5) ,(tl->list $6))))
("__asm__" opt-asm-specifiers "(" string-literal asm-outputs
asm-inputs asm-clobbers ")"
($$ `(asm-expr (@ (extension "GNUC"))
,$4 ,(tl->list $5) ,(tl->list $6) ,(tl->list $7)))))
(opt-asm-specifiers
($empty)
("volatile"))
(asm-outputs
(":" ($$ (make-tl 'asm-outputs)))
(":" asm-output ($$ (make-tl 'asm-outputs $2)))
(asm-outputs "," asm-output ($$ (tl-append $1 $3))))
(asm-output
(string-literal "(" identifier ")" ($$ `(asm-operand ,$1 ,$3)))
("[" identifier "]" string-literal "(" identifier ")"
($$ `(asm-operand ,$2 ,$4 ,$6))))
(asm-inputs
(":" ($$ (make-tl 'asm-inputs)))
(":" asm-input ($$ (make-tl 'asm-inputs $2)))
(asm-inputs "," asm-input ($$ (tl-append $1 $3))))
(asm-input
(string-literal "(" expression ")" ($$ `(asm-operand ,$1 ,$3)))
("[" identifier "]" string-literal "(" expression ")"
($$ `(asm-operand ,$2 ,$4 ,$6))))
(asm-clobbers
(":" ($$ (make-tl 'asm-clobbers)))
(":" string-literal ($$ (tl-extend (make-tl 'asm-clobbers) $2)))
(asm-clobbers "," string-literal ($$ (tl-extend $1 (cdr $3)))))
;; === top-level forms ====================================================
(translation-unit ; S 6.9
(external-declaration-list ($$ (tl->list $1))))
(external-declaration-list
($empty ($$ (make-tl 'trans-unit)))
(external-declaration-list
external-declaration
;; A ``kludge'' to deal with @code{extern "C" ...}:
($$ (if (eqv? (sx-tag $2) 'extern-block)
(tl-extend $1 (sx-tail $2 1))
(tl-append $1 $2)))))
(external-declaration ; S 6.9
(function-definition)
(declaration)
(lone-comment)
(cpp-statement)
(pragma)
("extern" $string "{"
($$ (cpi-dec-blev!)) external-declaration-list ($$ (cpi-inc-blev!)) "}"
($$ `(extern-block
(extern-begin ,$2) ,@(sx-tail (tl->list $5) 1) (extern-end))))
(";" ($$ `(decl (@ (extension "GNUC"))))))
(function-definition
(declaration-specifiers
declarator compound-statement
($$ `(fctn-defn ,$1 ,$2 ,$3)))
;; K&R function definitions are not compatible with attribute-specifiers.
;;(declaration-specifiers
;; declarator declaration-list compound-statement
;; ($$ `(knr-fctn-defn ,$1 ,$2 ,$3 ,$4)))
)
;; K&R function-definition parameter list
;;(declaration-list (declaration-list-1 ($$ (tl->list $1))))
;;(declaration-list-1
;; (declaration ($$ (make-tl 'decl-list $1)))
;; (declaration-list-1 declaration ($$ (tl-append $1 $2))))
;; non-terminal leaves
(identifier ($ident ($$ `(ident ,$1))))
(constant
($fixed ($$ `(fixed ,$1))) ; integer literal
($float ($$ `(float ,$1))) ; floating literal
($chlit ($$ `(char ,$1))) ; char literal
($chlit/L ($$ `(char (@ (type "wchar_t")) ,$1)))
($chlit/u ($$ `(char (@ (type "char16_t")) ,$1)))
($chlit/U ($$ `(char (@ (type "char32_t")) ,$1))))
(string-literal (string-literal-1 ($$ (tl->list $1))))
(string-literal-1
($string ($$ (make-tl 'string $1))) ; string-constant
(string-literal-1 $string ($$ (tl-append $1 $2))))
(code-comment ($code-comm ($$ `(comment ,$1))))
(lone-comment ($lone-comm ($$ `(comment ,$1))))
(cpp-statement ('cpp-stmt ($$ `(cpp-stmt ,$1))))
(pragma
($pragma ($$ `(pragma ,$1)))
("_Pragma" "(" string-literal ")" ($$ `(pragma ,$3))))
)))
;;; === parsers =========================
;; We setup dev parser because circular dependence between lexer and parser
;; due to parsing include files as units for code and decl mode.
;; update: This is doable now (see parser.scm) but wait until it's needed.
(define c99-mach
(compact-machine
(hashify-machine
(make-lalr-machine c99-spec))
#:keep 2
#:keepers '($code-comm $lone-comm $pragma)))
(define c99x-spec (restart-spec c99-spec 'expression))
(define c99x-mach
(compact-machine
(hashify-machine
(make-lalr-machine c99x-spec))
#:keep 2
#:keepers '($code-comm $lone-comm $pragma)))
;;; =====================================
;; @deffn {Procedure} gen-c99-files [dir] => #t
;; Update or generate the files @quot{c99act.scm} and @quot{c99tab.scm}.
;; These are the tables and actions for the C99 parser.
;; If there are no changes to existing files, no update occurs.
;; @end deffn
(define* (gen-c99-files #:optional (path "."))
(define (mdir file) (mach-dir path file))
(write-lalr-actions c99-mach (mdir "c99-act.scm.new") #:prefix "c99-")
(write-lalr-tables c99-mach (mdir "c99-tab.scm.new") #:prefix "c99-")
(write-lalr-actions c99x-mach (mdir "c99x-act.scm.new") #:prefix "c99x-")
(write-lalr-tables c99x-mach (mdir "c99x-tab.scm.new") #:prefix "c99x-")
(let ((a (move-if-changed (mdir "c99-act.scm.new") (mdir "c99-act.scm")))
(b (move-if-changed (mdir "c99-tab.scm.new") (mdir "c99-tab.scm")))
(c (move-if-changed (mdir "c99x-act.scm.new") (mdir "c99x-act.scm")))
(d (move-if-changed (mdir "c99x-tab.scm.new") (mdir "c99x-tab.scm"))))
(or a b c d)))
;; --- last line ---

1516
sysa/mes-0.22/module/nyacc/lang/c99/munge.scm Normal file
View file

File diff suppressed because it is too large Load diff

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

@ -0,0 +1,167 @@
;;; nyacc/lang/c99/parser.scm - C parser execution
;; Copyright (C) 2015-2019 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.
;;; Code:
(define-module (nyacc lang c99 parser)
#:export (parse-c99 parse-c99x gen-c99-lexer gen-c99x-lexer gen-c-lexer)
#:use-module (nyacc lex)
#:use-module (nyacc parse)
#:use-module (nyacc lang util)
#:use-module (nyacc lang c99 cpp)
#:use-module (nyacc lang c99 util)
#:re-export (c99-def-help c99-std-help))
(cond-expand
(guile-3)
(guile-2)
(guile
(use-modules (srfi srfi-16))
(use-modules (ice-9 optargs))
(use-modules (ice-9 syncase))
(use-modules (nyacc compat18)))
(else))
(include-from-path "nyacc/lang/c99/body.scm")
;; Routines to process specifier-lists and declarators, indended
;; to provide option to convert attribute-specifiers elements into
;; SXML attributes. See move-attributes in util.scm.
;;(define process-specs identity)
;;(define process-declr identity)
(define process-specs move-attributes)
(define process-declr move-attributes)
;; === file parser ====================
(include-from-path "nyacc/lang/c99/mach.d/c99-act.scm")
(include-from-path "nyacc/lang/c99/mach.d/c99-tab.scm")
(define c99-raw-parser
(make-lalr-parser
(acons 'act-v c99-act-v c99-tables)
#:skip-if-unexp '($lone-comm $code-comm $pragma)))
(define gen-c99-lexer
(make-c99-lexer-generator c99-mtab c99-raw-parser))
;; @deffn {Procedure} parse-c99 [options]
;; where options are
;; @table code
;; @item #:cpp-defs @i{defs-list}
;; @i{defs-list} is a list of strings where each string is of the form
;; @i{NAME} or @i{NAME=VALUE}.
;; @item #:inc-dirs @i{dir-list}
;; @{dir-list} is a list of strings of paths to look for directories.
;; @item #:inc-help @i{helpers}
;; @i{helpers} is an a-list where keys are include files (e.g.,
;; @code{"stdint.h"}) and the value is a list of type aliases or CPP define
;; (e.g., @code{"foo_t" "FOO_MAX=3"}).
;; @item #:mode @i{mode}
;; @i{mode} is one literal @code{'code}, @code{'file}, or @code{'decl}.
;; The default mode is @code{'code}.
;; @item #:debug @i{bool}
;; a boolean which if true prints states from the parser
;; @end table
;; @example
;; (with-input-from-file "abc.c"
;; (parse-c #:cpp-defs '("ABC=123"))
;; #:inc-dirs '(("." "./incs" "/usr/include"))
;; #:inc-help (append '("myinc.h" "foo_t" "bar_t") c99-std-help)
;; #:mode 'file))
;; @end example
;; Note: for @code{file} mode user still needs to make sure CPP conditional
;; expressions can be fully evaluated, which may mean adding compiler generated
;; defines (e.g., using @code{gen-cpp-defs}).
;; @end deffn
(define* (parse-c99 #:key
(cpp-defs '()) ; CPP defines
(inc-dirs '()) ; include dirs
(inc-help c99-def-help) ; include helpers
(mode 'code) ; mode: 'file, 'code or 'decl
(xdef? #f) ; pred to determine expand
(show-incs #f) ; show include files
(debug #f)) ; debug
(let ((info (make-cpi debug show-incs cpp-defs (cons "." inc-dirs) inc-help)))
(with-fluids ((*info* info)
(*input-stack* '()))
(catch 'c99-error
(lambda ()
(catch 'nyacc-error
(lambda () (c99-raw-parser
(gen-c99-lexer #:mode mode
#:xdef? xdef?
#:show-incs show-incs)
#:debug debug))
(lambda (key fmt . args) (apply throw 'c99-error fmt args))))
(lambda (key fmt . args)
(report-error fmt args)
#f)))))
;; === expr parser ====================
(include-from-path "nyacc/lang/c99/mach.d/c99x-act.scm")
(include-from-path "nyacc/lang/c99/mach.d/c99x-tab.scm")
(define c99x-raw-parser
(make-lalr-parser
(acons 'act-v c99x-act-v c99x-tables)
#:skip-if-unexp '($lone-comm $code-comm $pragma)))
(define gen-c99x-lexer
(make-c99-lexer-generator c99x-mtab c99x-raw-parser))
;; @deffn {Procedure} parse-c99x string [typenames] [options]
;; where @var{string} is a string C expression, @var{typenames}
;; is a list of strings to be treated as typenames
;; and @var{options} may be any of
;; @table
;; @item cpp-defs
;; a list of strings to be treated as preprocessor definitions
;; @item xdef?
;; this argument can be a boolean a predicate taking a string argument
;; @item debug
;; a boolean which if true prints states from the parser
;; @end table
;; This needs to be explained in some detail.
;; [tyns '("foo_t")]
;; @end deffn
(define* (parse-c99x expr-string
#:optional
(tyns '()) ; defined typenames
#:key
(cpp-defs '()) ; CPP defines
(xdef? #f) ; pred to determine expand
(debug #f)) ; debug?
(let ((info (make-cpi debug #f cpp-defs '(".") '())))
(set-cpi-ptl! info (cons tyns (cpi-ptl info)))
(with-fluids ((*info* info)
(*input-stack* '()))
(with-input-from-string expr-string
(lambda ()
(catch 'c99-error
(lambda ()
(catch 'nyacc-error
(lambda ()
(c99x-raw-parser (gen-c99x-lexer #:mode 'code #:xdef? xdef?)
#:debug debug))
(lambda (key fmt . args)
(apply throw 'c99-error fmt args))))
(lambda (key fmt . rest)
(report-error fmt rest)
#f)))))))
;; --- last line ---

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

@ -0,0 +1,692 @@
;;; nyacc/lang/c99/pprint.scm - C pretty-printer
;; Copyright (C) 2015-2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>
;;; Code:
(define-module (nyacc lang c99 pprint)
#:export (pretty-print-c99)
#:use-module ((srfi srfi-1) #:select (pair-for-each fold-right))
#:use-module (nyacc lang util)
#:use-module (nyacc lang sx-util)
#:use-module (ice-9 pretty-print)
)
(cond-expand ;; for MES
(guile-2 #t)
(else
(use-modules (ice-9 optargs))))
(define op-sym
(let ((ot '(("=" . eq) ("+=" . pl-eq) ("-=" . mi-eq) ("*=" . ti-eq)
("/=" . di-eq) ("%=" . mo-eq) ("<<=" . ls-eq) (">>=" . rs-eq)
("&=" . ba-eq) ("^=" . bx-eq) ("|=" bo-eq))))
(lambda (name)
(assoc-ref ot name))))
(define op-prec
;; in order of decreasing precedence
'((p-expr ident fixed float string)
(comp-lit post-inc post-dec i-sel d-sel fctn-call array-ref)
(de-ref ref-to neg pos not bitwise-not sizeof pre-inc pre-dec)
(cast)
(mul div mod)
(add sub)
(lshift rshift)
(lt gt le ge)
(eq ne)
(bitwise-and)
(bitwise-xor)
(bitwise-or)
(and)
(or)
(cond-expr)
(assn-expr)
(comma)))
(define op-assc
'((left array-ref d-sel i-sel post-inc post-dec comp-lit mul div mod add sub
lshift rshift lt gt le ge bitwise-and bitwise-xor bitwise-or and or)
(right pre-inc pre-dec sizeof bitwise-not not pos neg ref-to de-ref cast
cond assn-expr)
(nonassoc)))
;; @deffn {Procedure} scmchs->c scm-chr-str => c-chr-str
;; Convert 1-char scheme string into 1-char C string constant as typed by user.
;; That is, exscaped.
;; @example
;; (scmchstr->c "#x00") => "\\0"
;; @end example
;; @end deffn
(define (scmchs->c scm-chr-str)
(let ((ch (string-ref scm-chr-str 0)))
(case ch
((#\nul) "\\0") ((#\bel) "\\a") ((#\bs) "\\b") ((#\ht) "\\t")
((#\nl) "\\n") ((#\vt) "\\v") ((#\np) "\\f") ((#\cr) "\\r") ((#\\) "\\")
(else scm-chr-str))))
;; @deffn {Procedure} char->hex-list ch seed
;; to be documented
;; @end deffn
(define (char->hex-list ch seed)
(define (itox ival) (string-ref "0123456789ABCDEF" ival))
(let loop ((res seed) (ix 8) (val (char->integer ch)))
(cond
((zero? ix) (cons* #\\ #\U res))
((and (zero? val) (= ix 4)) (cons* #\\ #\u res))
(else
(loop (cons (itox (remainder val 16)) res) (1- ix) (quotient val 16))))))
(define (esc->ch ch)
(case ch ((#\nul) #\0) ((#\bel) #\a) ((#\bs) #\b) ((#\ht) #\t)
((#\nl) #\n) ((#\vt) #\v) ((#\np) #\f) ((#\cr) #\r)))
;; @deffn {Procedure} scmstr->c str
;; to be documented
;; @end deffn
(define (scmstr->c str)
(list->string
(string-fold-right
(lambda (ch chl)
(cond
((char-set-contains? char-set:printing ch) (cons ch chl))
((char=? ch #\space) (cons #\space chl))
((memq ch '(#\nul #\bel #\bs #\ht #\nl #\vt #\np #\cr))
(cons* #\\ (esc->ch ch) chl))
(else (char->hex-list ch chl))))
'() str)))
;;(define protect-expr? (make-protect-expr op-prec op-assc))
;; @deffn {Procedure} pretty-print-c99 tree [port] [options]
;; Convert and print a C99 sxml tree to the current output port.
;; The optional keyword argument @code{#:basic-offset} provides the
;; indent level, with default of 2.
;; @table code
;; @item #:basic-offset <n>
;; indent level for C code
;; @item #:per-line-prefix <string>
;; string
;; @item #:ugly #t|#f
;; pring ugly
;; @end table
;; @end deffn
(define* (pretty-print-c99 tree
#:optional (port (current-output-port))
#:key ugly per-line-prefix (basic-offset 2))
(define fmtr
((if ugly make-pp-formatter/ugly make-pp-formatter)
port #:per-line-prefix per-line-prefix #:basic-offset basic-offset))
(define (push-il)(fmtr 'push))
(define (pop-il) (fmtr 'pop))
(define (sf . args) (apply fmtr args))
(define (cpp-ppx tree)
(fmtr 'nlin)
(sx-match tree
((define (name ,name) (args . ,args) (repl ,repl))
(sf "#define ~A(" name)
(pair-for-each
(lambda (pair) (sf "~A" (car pair)) (if (pair? (cdr pair)) (sf ",")))
args)
(sf ") ~A\n" repl))
((define (name ,name) (repl ,repl))
(sf "#define ~A ~A\n" name repl))
((if ,text) (sf "#if ~A\n" text))
((elif ,text) (sf "#elif ~A\n" text))
((else ,text) (sf "#else ~A\n" text))
((else) (sf "#else\n"))
((endif ,text) (sf "#endif ~A\n" text))
((endif) (sf "#endif\n"))
((include ,file . ,rest) (sf "#include ~A\n" file))
((error ,text) (sf "#error ~A\n" text))
((pragma ,text) (sf "#pragma ~A\n" text))
(else (simple-format #t "\n*** pprint/cpp-ppx: NO MATCH: ~S\n" tree)))
(fmtr 'nlin))
(define protect-expr? (make-protect-expr op-prec op-assc))
(define (unary/l op rep rval)
(sf rep)
(if (protect-expr? 'rt op rval)
(ppx/p rval)
(ppx rval)))
(define (unary/r op rep lval)
(if (protect-expr? 'lt op lval)
(ppx/p lval)
(ppx lval))
(sf rep))
(define (binary op rep lval rval)
(if (protect-expr? 'lt op lval)
(ppx/p lval)
(ppx lval))
(sf rep)
(if (protect-expr? 'rt op rval)
(ppx/p rval)
(ppx rval)))
;; now ((comment xxx) (attributes "aaa;yyy;zzz"))
(define (pp-attr attr)
(string-join
(fold-right
(lambda (pair seed)
(if (eqv? 'attributes (car pair))
;; FIXME: should really parse-attributes, then ppx
(append (string-split (cadr pair) #\;) seed)
seed))
'() attr)
" "))
(define (struct-union-def struct-or-union attr name fields)
(if name
(if (pair? attr)
(sf "~A ~A ~A {\n" struct-or-union (pp-attr attr) name)
(sf "~A ~A {\n" struct-or-union name))
(if (pair? attr)
(sf "~A ~A {\n" struct-or-union (pp-attr attr))
(sf "~A {\n" struct-or-union)))
(push-il)
(for-each ppx fields)
(pop-il)
(sf "}"))
(define (comm+nl attr)
(cond
((assq 'comment attr) => (lambda (comm) (sf " ") (ppx comm)))
(else (sf "\n"))))
(define (ppx/p tree) (sf "(") (ppx tree) (sf ")"))
;; TODO: comp-lit
(define (ppx tree)
(sx-match tree
((p-expr ,expr) (ppx expr))
((ident ,name) (sf "~A" name))
((char (@ . ,al) ,value)
(let ((type (sx-attr-ref al 'type)))
(cond
((not type) (sf "'~A'" (scmchs->c value)))
((string=? type "wchar_t") (sf "L'~A'" (scmchs->c value)))
((string=? type "char16_t") (sf "u'~A'" (scmchs->c value)))
((string=? type "char32_t") (sf "U'~A'" (scmchs->c value)))
(else (throw 'c99-error "bad type")))))
((fixed ,value) (sf "~A" value))
((float ,value) (sf "~A" value))
((string . ,value-l)
(pair-for-each
(lambda (pair)
(sf "\"~A\"" (scmstr->c (car pair)))
(if (pair? (cdr pair)) (sf " ")))
value-l))
((comment ,text)
(cond
((or (string-any #\newline text) (string-suffix? " " text))
(for-each (lambda (l) (sf (scmstr->c l)) (sf "\n"))
(string-split (string-append "/*" text "*/") #\newline)))
(else (sf (string-append "//" text "\n")))))
((scope ,expr) (sf "(") (ppx expr) (sf ")"))
((array-ref ,dim ,expr)
(ppx expr) (sf "[") (ppx dim) (sf "]"))
((d-sel ,id ,ex) (binary 'd-sel "." ex id))
((i-sel ,id ,ex) (binary 'i-sel "->" ex id))
((pre-inc ,expr) (unary/l 'pre-inc "++" expr))
((pre-dec ,expr) (unary/l 'pre-dec "--" expr))
((ref-to ,expr) (unary/l 'ref-to "&" expr))
((de-ref ,expr) (unary/l 'de-ref "*" expr))
((pos ,expr) (unary/l 'pos "+" expr))
((neg ,expr) (unary/l 'neg "-" expr))
((bitwise-not ,expr) (unary/l 'bitwise-not "~" expr))
((not ,expr) (unary/l 'not "!" expr))
((sizeof-expr ,expr) (sf "sizeof(") (ppx expr) (sf ")"))
((sizeof-type ,type) (sf "sizeof(") (ppx type) (sf ")"))
((pragma ,text)
(fmtr 'nlin)
(sf "#pragma ~A\n" text))
((cast ,tn ,ex)
(sf "(") (ppx tn) (sf ")")
(if (protect-expr? 'rt 'cast ex)
(ppx/p ex)
(ppx ex)))
((add ,lval ,rval) (binary 'add " + " lval rval))
((sub ,lval ,rval) (binary 'sub " - " lval rval))
((mul ,lval ,rval) (binary 'mul "*" lval rval))
((div ,lval ,rval) (binary 'div "/" lval rval))
((mod ,lval ,rval) (binary 'mod "%" lval rval))
((lshift ,lval ,rval) (binary 'lshift "<<" lval rval))
((rshift ,lval ,rval) (binary 'lshift "<<" lval rval))
((lt ,lval ,rval) (binary 'lt " < " lval rval))
((gt ,lval ,rval) (binary 'gt " > " lval rval))
((le ,lval ,rval) (binary 'le " <= " lval rval))
((ge ,lval ,rval) (binary 'ge " >= " lval rval))
((eq ,lval ,rval) (binary 'eq " == " lval rval))
((ne ,lval ,rval) (binary 'ne " != " lval rval))
((bitwise-and ,lval ,rval) (binary 'bitwise-and " & " lval rval))
((bitwise-or ,lval ,rval) (binary 'bitwise-and " | " lval rval))
((bitwise-xor ,lval ,rval) (binary 'bitwise-xor " ^ " lval rval))
((and ,lval ,rval) (binary 'and " && " lval rval))
((or ,lval ,rval) (binary 'and " || " lval rval))
;; CHECK THIS
((cond-expr ,cond ,tval ,fval)
(ppx cond) (sf "? ") (ppx tval) (sf ": ") (ppx fval))
((post-inc ,expr) (unary/r 'post-inc "++" expr))
((post-dec ,expr) (unary/r 'post-dec "--" expr))
;; TODO: check protection
((fctn-call ,expr ,arg-list)
(if (protect-expr? 'rt 'fctn-call expr)
(ppx/p expr)
(ppx expr))
(sf "(")
(ppx arg-list)
(sf ")"))
((expr-list . ,expr-l)
(pair-for-each
(lambda (pair)
(ppx (car pair))
(if (pair? (cdr pair)) (sf ", ")))
expr-l))
((assn-expr ,lval ,op ,rval)
(binary (car op) (simple-format #f " ~A " (cadr op)) lval rval))
;; TODO: check protection
((comma-expr . ,expr-list)
(pair-for-each
(lambda (pair)
(cond
((pair? (cdr pair))
(if (protect-expr? 'rt 'comma-expr (car pair))
(ppx/p (car pair))
(ppx (car pair)))
(sf ", "))
(else (ppx (car pair)))))
expr-list))
((udecl . ,rest)
(ppx `(decl . ,rest)))
((decl (@ . ,attr) ,decl-spec-list)
(ppx decl-spec-list) (sf ";") (comm+nl attr))
((decl (@ . ,attr) ,decl-spec-list ,init-declr-list)
(ppx decl-spec-list) (sf " ") (ppx init-declr-list) (sf ";")
(comm+nl attr))
((decl-no-newline ,decl-spec-list ,init-declr-list) ; for (int i = 0;
(ppx decl-spec-list) (sf " ") (ppx init-declr-list) (sf ";"))
((comp-decl (@ . ,attr) ,spec-qual-list (comp-declr-list . ,rest2))
(ppx spec-qual-list) (sf " ") (ppx (sx-ref tree 2)) (sf ";")
(comm+nl attr))
;; anon struct or union
((comp-decl (@ . ,attr) ,spec-qual-list)
(ppx spec-qual-list) (sf ";") (comm+nl attr))
((decl-spec-list . ,dsl)
(pair-for-each
(lambda (dsl)
(case (sx-tag (car dsl))
((stor-spec) (sf "~A" (car (sx-ref (car dsl) 1))))
((type-qual) (sf "~A" (sx-ref (car dsl) 1)))
((fctn-spec) (sf "~A" (sx-ref (car dsl) 1)))
((type-spec) (ppx (car dsl)))
(else (sf "[?:~S]" (car dsl))))
(if (pair? (cdr dsl)) (sf " ")))
dsl))
((init-declr-list . ,rest)
(pair-for-each
(lambda (pair)
(ppx (car pair))
(if (pair? (cdr pair)) (sf ", ")))
rest))
((comp-declr-list . ,rest)
(pair-for-each
(lambda (pair)
(ppx (car pair))
(if (pair? (cdr pair)) (sf ", ")))
rest))
((init-declr ,declr ,item2 ,item3) (ppx declr) (ppx item2) (ppx item3))
((init-declr ,declr ,item2) (ppx declr) (ppx item2))
((init-declr ,declr) (ppx declr))
((comp-declr ,declr ,item2) (ppx declr) (ppx item2))
((comp-declr ,declr) (ppx declr))
((param-declr ,declr ,item2) (ppx declr) (ppx item2))
((param-declr ,declr) (ppx declr))
((bit-field ,ident ,expr)
(ppx ident) (sf " : ") (ppx expr))
;;((type-spec ,arg)
((type-spec (@ . ,aattr) ,arg)
(case (sx-tag arg)
((fixed-type) (sf "~A" (sx-ref arg 1)))
((float-type) (sf "~A" (sx-ref arg 1)))
((struct-ref) (ppx arg))
((struct-def) (if (pair? aattr) (sf " ~S" (pp-attr aattr))) (ppx arg))
((union-ref) (ppx arg))
((union-def) (if (pair? aattr) (sf " ~S" (pp-attr aattr))) (ppx arg))
((enum-ref) (ppx arg))
((enum-def) (ppx arg))
((typename) (sf "~A" (sx-ref arg 1)))
((void) (sf "void"))
(else (error "missing " arg))))
((struct-ref (ident ,name)) (sf "struct ~A" name))
((union-ref (ident ,name)) (sf "union ~A" name))
((struct-def (@ . ,aattr) (ident ,name) (field-list . ,fields))
(struct-union-def 'struct aattr name fields))
((struct-def (@ . ,aattr) (field-list . ,fields))
(struct-union-def 'struct aattr #f fields))
((union-def (@ . ,aattr) (ident ,name) (field-list . ,fields))
(struct-union-def 'union aattr name fields))
((union-def (@ . ,aattr) (field-list . ,fields))
(struct-union-def 'union aattr #f fields))
((enum-ref (ident ,name))
(sf "enum ~A" name))
((enum-def (ident ,name) (enum-def-list . ,edl))
(sf "enum ~A " name) (ppx `(enum-def-list . ,edl))) ; SPACE ???
((enum-def (enum-def-list . ,edl))
(sf "enum ") (ppx `(enum-def-list . ,edl))) ; SPACE ???
((enum-def-list . ,defns)
(sf "{\n") (push-il)
(for-each ppx defns)
(pop-il) (sf "}"))
((enum-defn (@ . ,attr) (ident ,name) ,expr)
(sf "~A = " name) (ppx expr) (sf ",") (comm+nl attr))
((enum-defn (@ . ,attr) (ident ,name))
(sf "~A," name) (comm+nl attr))
;;((fctn-spec "inline")
((fctn-spec ,spec)
(sf "~S " spec)) ; SPACE ???
((attribute-list . ,attrs)
(sf " __attribute__((")
(pair-for-each
(lambda (pair)
(ppx (car pair))
(if (pair? (cdr pair)) (sf ",")))
attrs)
(sf "))"))
((attribute (ident ,name))
(sf "~A" name))
((attribute (ident ,name) ,attr-expr-list)
(sf "~A(" name) (ppx attr-expr-list) (sf ")"))
((attr-expr-list . ,items)
(pair-for-each
(lambda (pair)
(ppx (car pair))
(if (pair? (cdr pair)) (sf ",")))
items))
((ptr-declr ,ptr ,dir-declr)
(ppx ptr) (ppx dir-declr))
((pointer) (sf "*"))
((pointer ,one) (sf "*") (ppx one))
((pointer ,one ,two) (sf "*") (ppx one) (ppx two))
((type-qual-list . ,tql) ; see decl-spec-list
(pair-for-each
(lambda (dsl)
(case (sx-tag (car dsl))
((type-qual) (sf "~A" (sx-ref (car dsl) 1)))
(else (sf "[?:~S]" (car dsl))))
(if (pair? (cdr dsl)) (sf " ")))
tql))
((array-of ,dir-declr ,arg)
(ppx dir-declr) (sf "[") (ppx arg) (sf "]"))
((array-of ,dir-declr)
(ppx dir-declr) (sf "[]"))
;; MORE TO GO
((ftn-declr ,dir-declr ,param-list)
(ppx dir-declr) (sf "(") (ppx param-list) (sf ")"))
((type-name ,spec-qual-list ,abs-declr)
(ppx spec-qual-list) (ppx abs-declr))
((type-name ,decl-spec-list)
(ppx decl-spec-list))
((abs-declr ,pointer ,dir-abs-declr) (ppx pointer) (ppx dir-abs-declr))
((abs-declr ,one-of-above) (ppx one-of-above))
;; declr-scope
((declr-scope ,abs-declr)
(sf "(") (ppx abs-declr) (sf ")"))
;; declr-array dir-abs-declr
;; declr-array dir-abs-declr assn-expr
;; declr-array dir-abs-declr type-qual-list
;; declr-array dir-abs-declr type-qual-list assn-expr
((declr-array ,dir-abs-declr)
(ppx dir-abs-declr) (sf "[]"))
((declr-array ,dir-abs-declr ,arg2)
(ppx dir-abs-declr) (sf "[") (ppx arg2) (sf "]"))
((declr-array ,dir-abs-declr ,arg2 ,arg3)
(ppx dir-abs-declr) (sf "[") (ppx arg2) (sf " ") (ppx arg3) (sf "]"))
;; declr-anon-array
;; declr-STAR
;; abs-ftn-declr
((abs-ftn-declr ,dir-abs-declr ,param-type-list)
(ppx dir-abs-declr) (sf "(") (ppx param-type-list) (sf ")"))
;; anon-ftn-declr
;; initializer
((initzer ,expr)
(sf " = ") (ppx expr))
;; initializer-list
((initzer-list . ,items)
(sf "{") ;; or "{ "
(pair-for-each
(lambda (pair)
(ppx (sx-ref (car pair) 1))
(if (pair? (cdr pair)) (sf ", ")))
items)
(sf "}")) ;; or " }"
((compd-stmt (block-item-list . ,items))
(sf "{\n") (push-il)
(pair-for-each
(lambda (pair)
(let ((this (car pair)) (next (and (pair? (cdr pair)) (cadr pair))))
(ppx this)
(cond ;; add blank line if next is different or fctn defn
((not next))
((eqv? (sx-tag this) (sx-tag next)))
((eqv? (sx-tag this) 'comment))
((eqv? (sx-tag next) 'comment) (sf "\n")))))
items)
(pop-il) (sf "}\n"))
((compd-stmt-no-newline (block-item-list . ,items))
(sf "{\n") (push-il) (for-each ppx items) (pop-il) (sf "} "))
;; expression-statement
((expr-stmt) (sf ";\n")) ;; add comment?
((expr-stmt (@ . ,attr) ,expr) (ppx expr) (sf ";") (comm+nl attr))
((expr) (sf "")) ; for lone expr-stmt and return-stmt
;; selection-statement
((if . ,rest)
(let ((cond-part (sx-ref tree 1))
(then-part (sx-ref tree 2)))
(sf "if (") (ppx cond-part) (sf ") ")
(ppx then-part)
(let loop ((else-l (sx-tail tree 3)))
(cond
((null? else-l) #t)
((eqv? 'else-if (caar else-l))
(sf "else if (") (ppx (sx-ref (car else-l) 1)) (sf ") ")
(ppx (sx-ref (car else-l) 2))
(loop (cdr else-l)))
(else
(sf "else ")
(ppx (car else-l)))))))
((switch ,expr (compd-stmt (block-item-list . ,items)))
(sf "switch (") (ppx expr) (sf ") {\n")
(for-each
(lambda (item)
(unless (memq (car item) '(case default)) (push-il))
(ppx item)
(unless (memq (car item) '(case default)) (pop-il)))
items)
(sf "}\n"))
;; labeled-statement
((case ,expr ,stmt)
(sf "case ") (ppx expr) (sf ":\n")
(push-il) (ppx stmt) (pop-il))
((default ,stmt)
(sf "default:\n")
(push-il) (ppx stmt) (pop-il))
;; CHECK THIS
((while ,expr ,stmt)
(sf "while (") (ppx expr) (sf ") ") (ppx stmt)
)
;; This does not meet the convention of "} while" on same line.
((do-while ,stmt ,expr)
(sf "do ")
(if (eqv? 'compd-stmt (sx-tag stmt))
(ppx `(compd-stmt-no-newline ,(sx-ref stmt 1)))
(ppx stmt))
(sf "while (") (ppx expr) (sf ");\n"))
;; for
((for (decl . ,rest) ,test ,iter ,stmt)
(sf "for (") (ppx `(decl-no-newline . ,rest))
(sf " ") (ppx test) (sf "; ") (ppx iter) (sf ") ")
(ppx stmt))
((for (decl . ,rest) ,expr2 ,expr3 ,stmt)
(sf "for (")
(ppx `(decl . ,rest)) (sf " ") (ppx expr2) (sf "; ") (ppx expr3)
(sf ") ") (ppx stmt))
((for ,expr1 ,expr2 ,expr3 ,stmt)
(sf "for (")
(ppx expr1) (sf "; ") (ppx expr2) (sf "; ") (ppx expr3)
(sf ") ") (ppx stmt))
;; jump-statement
((goto ,where)
(pop-il) ; unindent
(sf "goto ~A;" (sx-ref where 1))
;; comment?
(sf "\n")
(push-il)) ; re-indent
((continue) (sf "continue;\n"))
((break) (sf "break;\n"))
((return ,expr) (sf "return ") (ppx expr) (sf ";\n"))
((return) (sf "return;\n"))
((trans-unit . ,items)
(pair-for-each
(lambda (pair)
(let ((this (car pair)) (next (and (pair? (cdr pair)) (cadr pair))))
(ppx this)
(cond ;; add blank line if next is different or fctn defn
((not next))
((eqv? (sx-tag this) (sx-tag next)))
((eqv? (sx-tag this) 'comment))
((eqv? (sx-tag next) 'comment) (sf "\n"))
((not (eqv? (sx-tag this) (sx-tag next))) (sf "\n"))
((eqv? (sx-tag next) 'fctn-defn) (sf "\n")))))
items))
((fctn-defn . ,rest) ;; but not yet (knr-fctn-defn)
(let* ((decl-spec-list (sx-ref tree 1))
(declr (sx-ref tree 2))
(compd-stmt (sx-ref tree 3)))
(ppx decl-spec-list)
(sf " ")
(ppx declr)
(sf " ")
(ppx compd-stmt)))
((ptr-declr . ,rest)
(ppx (sx-ref tree 1)) (ppx (sx-ref tree 2)))
((ftn-declr . ,rest)
(ppx (sx-ref tree 1)) ; direct-declarator
(sf "(") (ppx (sx-ref tree 2)) (sf ")"))
((param-list . ,params)
(pair-for-each
(lambda (pair) (ppx (car pair)) (if (pair? (cdr pair)) (sf ", ")))
params))
((ellipsis) ;; should work
(sf "..."))
((param-decl ,decl-spec-list ,param-declr)
(ppx decl-spec-list) (sf " ") (ppx param-declr))
((param-decl ,decl-spec-list)
(ppx decl-spec-list))
((cpp-stmt . ,rest)
(cpp-ppx (sx-ref tree 1)))
((extern-block ,begin ,guts ,end) (ppx begin) (ppx guts) (ppx end))
((extern-begin ,lang) (sf "extern \"~A\" {\n" lang))
((extern-end) (sf "}\n"))
(,_
(simple-format #t "\n*** pprint/ppx: NO MATCH: ~S\n" (car tree))
(pretty-print tree #:per-line-prefix " ")
)))
(if (not (pair? tree)) (error "expecing sxml tree"))
(ppx tree)
(if ugly (newline)))
;; --- last line ---

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

@ -0,0 +1,368 @@
;;; nyacc/lang/c99/util.scm - C parser utilities
;; Copyright (C) 2015-2019 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.
;;; Code:
(define-module (nyacc lang c99 util)
#:export (c99-def-help
c99-std-help
get-gcc-cpp-defs
get-gcc-inc-dirs
remove-inc-trees
merge-inc-trees!
move-attributes attrl->attrs attrs->attrl extract-attr
elifify)
#:use-module (nyacc lang util)
#:use-module (nyacc lang sx-util)
#:use-module ((srfi srfi-1) #:select (append-reverse fold-right))
#:use-module (srfi srfi-2) ; and-let*
#:use-module (sxml fold)
#:use-module (ice-9 popen) ; gen-gcc-cpp-defs
#:use-module (ice-9 rdelim) ; gen-gcc-cpp-defs
)
(define c99-def-help
'(("__builtin"
"__builtin_va_list=void*"
"__inline__=inline" "__inline=__inline__"
"__restrict__=restrict" "__restrict=__restrict__"
"__signed__=signed" "__signed=__signed__"
"asm(X)=__asm__(X)" "__asm(X)=__asm__(X)"
"__attribute(X)=__attribute__(X)"
"__volatile__=volatile" "__volatile=__volatile__"
"__extension__=" "__extension=__extension__"
"asm=__asm__" "__asm=__asm__"
"__attribute(X)=__attribute__(X)"
)))
;; include-helper for C99 std
(define c99-std-help
(append
c99-def-help
'(("alloca.h")
("complex.h" "complex" "imaginary" "_Imaginary_I=C99_ANY" "I=C99_ANY")
("ctype.h")
("fenv.h" "fenv_t" "fexcept_t")
("float.h" "float_t" "FLT_MAX=C99_ANY" "DBL_MAX=C99_ANY")
("inttypes.h"
"int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
"int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
"int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
"int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t"
"imaxdiv_t")
("limits.h"
"INT_MIN=C99_ANY" "INT_MAX=C99_ANY" "LONG_MIN=C99_ANY" "LONG_MAX=C99_ANY")
("math.h" "float_t" "double_t")
("regex.h" "regex_t" "regmatch_t")
("setjmp.h" "jmp_buf")
("signal.h" "sig_atomic_t")
("stdarg.h" "va_list")
("stddef.h" "ptrdiff_t" "size_t" "wchar_t")
("stdint.h"
"int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
"int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
"int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
"int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t")
("stdio.h" "FILE" "size_t")
("stdlib.h" "div_t" "ldiv_t" "lldiv_t" "wchar_t")
("string.h" "size_t")
("strings.h" "size_t")
("time.h" "time_t" "clock_t" "size_t")
("unistd.h" "size_t" "ssize_t" "div_t" "ldiv_t")
("wchar.h" "wchar_t" "wint_t" "mbstate_t" "size_t")
("wctype.h" "wctrans_t" "wctype_t" "wint_t"))))
(define (resolve-CC CC)
(cond
(CC CC)
((getenv "CC") => identity)
(else "gcc")))
;; @deffn {Procedure} convert-def line
;; Convert string in gcc cpp defs to pair of strings for term and replacement.
;; @end deffn
(define (convert-line line)
(with-input-from-string line
(lambda ()
(let loop ((term '()) (acc '()) (st 0) (ch (read-char)))
(case st
((0) ;; skip #define
(if (char=? ch #\space)
(loop term acc 1 (read-char))
(loop term acc 0 (read-char))))
((1) ;; read term
(if (char=? ch #\space)
(loop (reverse-list->string acc) '() 2 (read-char))
(loop term (cons ch acc) st (read-char))))
((2) ;; read rest
(if (or (eof-object? ch) (char=? ch #\newline))
(string-append term "=" (reverse-list->string acc))
(loop term (cons ch acc) st (read-char)))))))))
;; @deffn {Procedure} get-gcc-cpp-defs [args] [#:CC "gcc"] => '("ABC=123" ...)
;; Generate a list of default defines produced by gcc (or other comiler).
;; If keyword arg @arg{CC} is not provided this procedure looks for environment
;; variable @code{"CC"}, else it defaults to @code{"gcc"}.
;; @end deffn
(define* (get-gcc-cpp-defs #:optional (args '()) #:key CC)
;; @code{"gcc -dM -E"} will generate lines like @code{"#define ABC 123"}.
;; We generate and return a list like @code{'(("ABC" . "123") ...)}.
(let* ((cmd (string-append (resolve-CC CC) " -dM -E - </dev/null"))
(ip (open-input-pipe cmd)))
(let loop ((line (read-line ip 'trim)))
(if (eof-object? line) '()
(cons (convert-line line) (loop (read-line ip 'trim)))))))
;; @deffn {Procedure} get-gcc-inc-dirs [args] [#:CC "gcc"] =>
;; Generate a list of compiler-internal include directories (for gcc). If
;; keyword arg @arg{CC} is not provided this procedure looks for environment
;; variable @code{"CC"}, else it defaults to @code{"gcc"}.
;; @end deffn
(define* (get-gcc-inc-dirs #:optional (args '()) #:key CC)
(let ((ip (open-input-pipe (string-append
(resolve-CC CC) " -E -Wp,-v - </dev/null 2>&1"))))
(let loop ((dirs '()) (grab #f) (line (read-line ip 'trim)))
(cond
((eof-object? line) dirs)
((string=? line "#include <...> search starts here:")
(loop dirs #t (read-line ip 'trim)))
((string=? line "End of search list.") dirs)
(grab
(loop (cons (string-trim-both line) dirs)
grab (read-line ip 'trim)))
(else
(loop dirs grab (read-line ip 'trim)))))))
;; @deffn {Procedure} remove-inc-trees tree
;; Remove the trees included with cpp-include statements.
;; @example
;; '(... (cpp-stmt (include "<foo.h>" (trans-unit ...))) ...)
;; => '(... (cpp-stmt (include "<foo.h>")) ...)
;; @end example
;; @end deffn
(define (remove-inc-trees tree)
(if (not (eqv? 'trans-unit (car tree)))
(throw 'nyacc-error "expecting c-tree"))
(let loop ((rslt (make-tl 'trans-unit))
;;(head '(trans-unit)) (tail (cdr tree))
(tree (cdr tree)))
(cond
((null? tree) (tl->list rslt))
((and (eqv? 'cpp-stmt (car (car tree)))
(eqv? 'include (caadr (car tree))))
(loop (tl-append rslt `(cpp-stmt (include ,(cadadr (car tree)))))
(cdr tree)))
(else (loop (tl-append rslt (car tree)) (cdr tree))))))
;; @deffn {Procedure} merge-inc-trees! tree => tree
;; This will (recursively) merge code from cpp-includes into the tree.
;; @example
;; (trans-unit
;; (decl (a))
;; (cpp-stmt (include "<hello.h>" (trans-unit (decl (b)))))
;; (decl (c)))
;; =>
;; (trans-unit (decl (a)) (decl (b)) (decl (c)))
;; @end example
;; @end deffn
(define (merge-inc-trees! tree)
;; @item find-span (trans-unit a b c) => ((a . +->) . (c . '())
(define (find-span tree)
(cond
((not (pair? tree)) '()) ; maybe parse failed
((not (eqv? 'trans-unit (car tree))) (throw 'c99-error "expecting c-tree"))
((null? (cdr tree)) (throw 'c99-error "null c99-tree"))
(else
(let ((fp tree)) ; first pair
(let loop ((lp tree) ; last pair
(np (cdr tree))) ; next pair
(cond
((null? np) (cons (cdr fp) lp))
;; The following is an ugly hack to find cpp-include
;; with trans-unit attached.
((and-let* ((expr (car np))
((eqv? 'cpp-stmt (car expr)))
((eqv? 'include (caadr expr)))
(rest (cddadr expr))
((pair? rest))
(span (find-span (car rest))))
(set-cdr! lp (car span))
(loop (cdr span) (cdr np))))
(else
(set-cdr! lp np)
(loop np (cdr np)))))))))
;; Use cons to generate a new reference:
;; (cons (car tree) (car (find-span tree)))
;; or not:
(find-span tree)
tree)
;; --- attributes ----------------------
(define (join-string-literal str-lit)
(sx-list 'string (sx-attr str-lit) (string-join (sx-tail str-lit) "")))
;; used in c99-spec actions for attribute-specifiers
(define (attr-expr-list->string attr-expr-list)
(string-append "(" (string-join (cdr attr-expr-list) ",") ")"))
;; ((attribute-list ...) (type-spec ...) (attribute-list ...)) =>
;; (values (attribute-list ...) ((type-spec ...) ...))
;; @deffn extract-attr tail => (values attr-tree tail)
;; Extract attributes from a sexp tail.
;; @end deffn
(define (extract-attr tail) ;; => (values attr-tree tail)
(let loop ((atl '()) (tail1 '()) (tail0 tail))
(cond
((null? tail0)
(if (null? atl)
(values '() tail)
(values `(attribute-list . ,atl) (reverse tail1))))
((eq? 'attribute-list (sx-tag (car tail0)))
(loop (append (sx-tail (car tail0)) atl) tail1 (cdr tail0)))
(else
(loop atl (cons (car tail0) tail1) (cdr tail0))))))
;; (attribute-list (attribute (ident "__packed__")) ...)
;; =>
;; (attributes "__packed__;...")
;; OR
;; () => ()
(define (attrl->attrs attr-list)
(define (spec->str spec)
(sx-match spec
((ident ,name) name)
((attribute ,name) (spec->str name))
((attribute ,name ,args)
(string-append (spec->str name) "(" (spec->str args) ")"))
((attr-expr-list . ,expr-list)
(string-join (map spec->str expr-list) ","))
((fixed ,val) val)
((float ,val) val)
((char ,val) val)
((string . ,val) (string-append "\"" (string-join val "") "\""))
((type-name (decl-spec-list (type-spec ,spec))) (spec->str spec))
((fixed-type ,name) name)
((float-type ,name) name)
(,_ (sferr "c99/util: missed ~S\n" spec) "MISSED")))
(if (null? attr-list) '()
`(attributes ,(string-join (map spec->str (sx-tail attr-list)) ";"))))
;; (attributes "__packed__;__aligned__;__alignof__(8)")
;; =>
;; (attribute-list (attribute "__packed
;; OR
;; #f => #f
(use-modules (nyacc lex))
(define (astng->atree form)
(define a-mtab
'(("(" . lparen) ((")" . rparen))
("," . comma) ($ident . ident)))
(define attlexgen (make-lexer-generator a-mtab))
(define attlex (attlexgen))
(with-input-from-string form
(lambda ()
(define (p-expr-list lx) ;; see 'lparen
(and
(eq? 'lparen (car lx))
(let loop ((args '()) (lx (attlex)))
(case (car lx)
((rparen) `(attr-expr-list . ,args))
((comma) (loop args (attlex)))
(else (p-expr lx))))))
(define (p-expr lx)
#f)
(let ((lx (attlex)))
(sferr "lx=~S\n" lx)
(case (car lx)
((ident)
(let* ((id (cdr lx)) (lx (attlex)))
(case (car lx)
(($end) `(attribute ,id))
((lparen) `(attribute ,id ,(p-expr-list lx)))
(else (throw 'nyacc-error "error ~S" lx)))))
(else (throw 'nyacc-error "missed ~S" lx)))))))
(define (attrs->attrl attr-sexp)
(and
attr-sexp
(let* ((attrs (cadr attr-sexp))
(attl (string-split attrs #\;)))
`(attribute-list ,@(map astng->atree attl)))))
;; @deffn {Procedure} move-attributes sexp
;; Given a sexpr, combine attribute-list kids and move to attribute ??
;; @example
;; (decl (decl-spec-list
;; (attributes "__packed__" "__aligned__")
;; (attributes "__alignof__(8)"))
;; (type-spec (fixed-type "int")))
;; (declr-init-list ...))
;; =>
;; (decl (decl-spec-list
;; (@ (attributes "__packed__;__aligned__;__alignof__(8)"))
;; (type-spec (fixed-type "int")))
;; (declr-init-list ...))
;; @end example
;; @end deffn
(define (move-attributes sexp)
(let ((tag (sx-tag sexp)) (attr (sx-attr sexp)) (tail (sx-tail sexp)))
(call-with-values (lambda () (extract-attr tail))
(lambda (attrl stail)
(sx-cons*
tag
(cond
((null? attrl) attr)
((null? attr)`(@ ,(attrl->attrs attrl)))
(else (append attr (list (attrl->attrs attrl)))))
stail)))))
;; --- random stuff
;; @deffn {Procedure} elifify tree => tree
;; This procedure will find patterns of
;; @example
;; (if cond-1 then-part-1
;; (if cond-2 then-part-2
;; else-part-2
;; @end example
;; @noindent
;; and convert to
;; @example
;; (if cond-1 then-part-1
;; (elif cond-2 then-part-2)
;; else-part-2
;; @end example
;; @end deffn
(define (elifify tree)
(define (fU tree)
(sx-match tree
((if ,x1 ,t1 (if ,x2 ,t2 (else-if ,x3 ,t3) . ,rest))
`(if ,x1 ,t1 (else-if ,x2 ,t2) (else-if ,x3 ,t3) . ,rest))
((if ,x1 ,t1 (if ,x2 ,t2 . ,rest))
`(if ,x1 ,t1 (else-if ,x2 ,t2) . ,rest))
(else
tree)))
(foldt fU identity tree))
;; --- last line ---

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

@ -0,0 +1,469 @@
;;; module/nyacc/sx-util.scm - runtime utilities for the parsers
;; Copyright (C) 2015-2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.
;;; Notes:
;; The syntax of SXML trees is simple:
;; @example
;; expr => (tag item @dots{}) | (tag (@@ attr @dots{}) item @dots{})
;; item => string | expr
;; attr => (tag . string)
;; @end example
;;; Code:
(define-module (nyacc lang sx-util)
#:export (make-sx
sx-tag sx-attr sx-tail sx-length sx-ref sx-ref*
sx-has-attr? sx-attr-ref sx-attr-add sx-attr-add* sx-attr-set!
sx-find
sx-split sx-split* sx-join sx-join* sx-cons* sx-list
sx-unitize
sx-match)
#:use-module ((srfi srfi-1) #:select (find fold fold-right append-reverse)))
(cond-expand
(mes)
(guile-2)
(guile (use-modules (srfi srfi-16)))
(else))
;; === sx ==============================
;; @section SXML Utility Procedures
;; Some lot of these look like existing Guile list procedures (e.g.,
;; @code{sx-tail} versus @code{list-tail} but in sx lists the optional
;; attributea are `invisible'. For example, @code{'(elt (@abc) "d")}
;; is an sx of length two: the tag @code{elt} and the payload @code{"d"}.
;; @deffn {Procedure} sx-expr? expr
;; This predicate checks if @var{expr} looks like a valid SXML form.
;; It is not exhaustive: @var{expr} is checked to be a list with first
;; element a symbol.
;; @end deffn
(define (sxml-expr? sx)
(and (pair? sx) (symbol? (car sx)) (list? sx)))
;; @deffn {Procedure} make-sx tag attr . elts
;; This will build an SXML expression from the symbolic tag, optional
;; attributes and elements. The attributes @var{attr} can be of the from
;; @code{(@ (key "val") ...)} or @code{((key "val") ...)}. If elements
;; in @var{elts} are not pairs or strings they are ignored, so elmeents of
;; @var{elts} of the form @code{#f} and @code{'()} will not end up in the
;; returned SXML form.
;; @end deffn
(define (make-sx tag attr . elts)
(let ((tail (fold-right
(lambda (elt sx)
(cond
((pair? elt) (cons elt sx))
((string? elt) (cons elt sx))
(else sx)))
'() elts)))
(if (pair? attr)
(if (eq? '@ (car attr))
(cons* tag attr tail)
(cons* tag `(@ . ,attr) tail))
(cons tag tail))))
;; @deffn {Procedure} sx-length sx => <int>
;; Return the length, don't include attributes, but do include tag
;; @end deffn
(define (sx-length sx)
(let ((ln (length sx)))
(cond
((zero? ln) 0)
((= 1 ln) 1)
((not (pair? (cadr sx))) ln)
((eq? '@ (caadr sx)) (1- ln))
(else ln))))
;; @deffn {Procedure} sx-tag sx => tag
;; Return the tag for a tree
;; @end deffn
(define (sx-tag sx)
(if (pair? sx) (car sx) #f))
;; @deffn {Procedure} sx-ref sx ix => item
;; Reference the @code{ix}-th element of the list, not counting the optional
;; attributes item. If the list is shorter than the index, return @code{#f}.
;; [note to author: The behavior to return @code{#f} if no elements is not
;; consistent with @code{list-ref}. Consider changing it. Note also there
;; is never a danger of an element being @code{#f}.]
;; @example
;; (sx-ref '(abc 1) => #f
;; (sx-ref '(abc "def") 1) => "def"
;; (sx-ref '(abc (@ (foo "1")) "def") 1) => "def"
;; @end example
;; @end deffn
(define (sx-ref sx ix)
(define (list-xref l x) (if (> (length l) x) (list-ref l x) #f))
(cond
((zero? ix) (car sx))
((null? (cdr sx)) #f)
((and (pair? (cadr sx)) (eqv? '@ (caadr sx)))
(list-xref sx (1+ ix)))
(else
(list-xref sx ix))))
;; @deffn {Procedure} sx-ref* sx ix1 ix2 ... => item
;; Equivalent to
;; @example
;; (((sx-ref (sx-ref sx ix1) ix2) ...) ...)
;; @end example
;; @end deffn
(define (sx-ref* sx . args)
(fold (lambda (ix sx) (and (pair? sx) (sx-ref sx ix))) sx args))
;; @deffn {Procedure} sx-tail sx [ix] => (list)
;; Return the ix-th tail starting after the tag and attribut list, where
;; @var{ix} must be positive. For example,
;; @example
;; (sx-tail '(tag (@ (abc . "123")) (foo) (bar)) 1) => ((foo) (bar))
;; @end example
;; Without second argument @var{ix} is 1.
;; @end deffn
(define sx-tail
(case-lambda
((sx ix)
(cond
((zero? ix) (error "sx-tail: expecting index greater than 0"))
((null? (cdr sx)) (list-tail sx ix))
((and (pair? (cadr sx)) (eqv? '@ (caadr sx))) (list-tail sx (1+ ix)))
(else (list-tail sx ix))))
((sx)
(sx-tail sx 1))))
;; @deffn {Procedure} sx-find tag sx => (tag ...)
;; @deffnx {Procedure} sx-find path sx => (tag ...)
;; In the first form @var{tag} is a symbolic tag in the first level.
;; Find the first matching element (in the first level).
;; In the second form, the argument @var{path} is a pair. Apply sxpath
;; and take it's car,
;; if found, or return @code{#f}, like lxml's @code{tree.find()} method.
;; @* NOTE: the path version is currently disabled, to remove dependence
;; on the module @code{(sxml xpath)}.
;; @end deffn
(define (sx-find tag-or-path sx)
(cond
((symbol? tag-or-path)
(find (lambda (node)
(and (pair? node) (eqv? tag-or-path (car node))))
sx))
(else
(error "sx-find: expecting first arg to be tag or sxpath"))))
;; @deffn {Procedure} sx-has-attr? sx
;; p to determine if @arg{sx} has attributes.
;; @end deffn
(define (sx-has-attr? sx)
(and (pair? (cdr sx)) (pair? (cadr sx)) (eqv? '@ (caadr sx)) #t))
;; @deffn {Procedure} sx-attr sx => ((k v) ...)
;; @example
;; (sx-attr '(abc (@ (foo "1")) def) 1) => ((foo "1"))
;; @end example
;; @end deffn
(define (sx-attr sx)
(if (and (pair? (cdr sx))
(pair? (cadr sx))
(eqv? '@ (caadr sx)))
(cdadr sx)
'()))
;; @deffn {Procedure} sx-attr-ref sx|node|tail key => val
;; Return an attribute value given the key, or @code{#f}.
;; Also works if passed the attribute node @code{(@ ...)} or its tail.
;; @end deffn
(define (sx-attr-ref sx key)
(let ((attr-tail (cond ((null? sx) sx)
((pair? (car sx)) sx)
((eqv? '@ (car sx)) (car sx))
((sx-attr sx))
(else '()))))
(and=> (assq-ref attr-tail key) car)))
;; @deffn {Procedure} sx-attr-add sx key-or-pair [val]
;; Add attribute to sx, passing either a key-val pair or key and val.
;; @end deffn
(define* (sx-attr-add sx key-or-pair #:optional val)
(let* ((pair (if val (list key-or-pair val) key-or-pair))
(key (car pair)) (val (cadr pair)))
(cons
(sx-tag sx)
(if (sx-has-attr? sx)
(cons `(@ pair
,@(let loop ((atl (sx-attr sx)))
(cond ((null? atl) '())
((eq? key (caar atl)) (loop (cdr atl)))
(else (cons (car atl) (loop (cdr atl)))))))
(cddr sx))
(cons `(@ ,pair) (cdr sx))))))
;; @deffn {Procedure} sx-attr-add* sx key val [key val [@dots{} ]] => sx
;; Add key-val pairs. @var{key} must be a symbol and @var{val} must be
;; a string. Return a new @emph{sx}.
;; @end deffn
(define (sx-attr-add* sx . rest)
(let* ((attrs (sx-attr sx))
(attrs (let loop ((kvl rest))
(if (null? kvl) attrs
(cons (list (car kvl) (cadr kvl)) (loop (cddr kvl)))))))
(cons* (sx-tag sx) (cons '@ attrs)
(if (sx-has-attr? sx) (cddr sx) (cdr sx)))))
;; @deffn {Procedure} sx-attr-set! sx key val
;; Set attribute for sx. If no attributes exist, if key does not exist,
;; add it, if it does exist, replace it.
;; @end deffn
(define (sx-attr-set! sx key val)
(if (sx-has-attr? sx)
(let ((attr (cadr sx)))
(set-cdr! attr (assoc-set! (cdr attr) key (list val))))
(set-cdr! sx (cons `(@ (,key ,val)) (cdr sx))))
sx)
;; @deffn {Procedure} sx-cons* tag attr exp ... tail => sx
;; @deffnx {Procedure} sx-list tag attr exp ... => sx
;; Generate the tag and the attr list if it exists. Note that
;; The following are equivalent:
;; @example
;; (sx-cons* tag attr elt1 elt2 '())
;; (sx-list tag attr elt1 elt2)
;; @end example
;; @noindent
;; Expressions that are @code{#f} or @code{'()} will be skipped;
;; they should be strings or pairs.
;; @end deffn
(define (sx-cons* tag attr . rest)
(if (null? rest) (error "sx-cons: expecing tail"))
(let ((attr (cond
((not attr) #f)
((null? attr) #f)
((pair? (car attr)) `(@ . ,attr))
(else attr)))
(tail (let loop ((items rest))
(cond
((null? (cdr items)) (car items))
((not (car items)) (loop (cdr items)))
((null? (car items)) (loop (cdr items)))
(else (cons (car items) (loop (cdr items))))))))
(if attr (cons* tag attr tail) (cons tag tail))))
(define (sx-list tag attr . rest)
(let ((attr (cond
((not attr) #f)
((null? attr) #f)
((pair? (car attr)) `(@ . ,attr))
(else attr)))
(tail (let loop ((items rest))
(cond
((null? items) '())
((not (car items)) (loop (cdr items)))
((null? (car items)) (loop (cdr items)))
(else (cons (car items) (loop (cdr items))))))))
(if attr (cons* tag attr tail) (cons tag tail))))
;; @deffn {Procedure} sx-split sexp => tag attr tail
;; @deffnx {Procedure} sx-split* sexp => tag attr exp ...
;; Split an SXML element into its constituent parts, as a @code{values},
;; where @var{attr} is list of pairs. If no attributes exist, @var{attr}
;; is @code{'()}.
;; @end deffn
(define (sx-split sexp)
(let ((tag (sx-tag sexp))
(attr (sx-attr sexp))
(tail (sx-tail sexp)))
(values tag attr tail)))
(define (sx-split* sexp)
(let ((tag (sx-tag sexp))
(attr (sx-attr sexp))
(tail (sx-tail sexp)))
(apply values tag attr tail)))
;; @deffn {Procedure} sx-join tag attr tail => sexp
;; @deffnx {Procedure} sx-join* tag attr exp ... => sexp
;; Build an SXML element by its parts. If @var{ATTR} is @code{'()} skip;
;; @code{sx-join*} will remove any exp that are @code{#f} or @code{'()}.
;; @end deffn
(define (sx-join tag attr tail)
(if (and attr (pair? attr))
(if (pair? (car attr))
(cons* tag `(@ . ,attr) tail)
(cons* tag `(@ ,attr) tail))
(cons tag tail)))
(define (sx-join* tag attr . tail)
(let ((tail (let loop ((tail tail))
(cond
((null? tail) '())
((not tail) (loop (cdr tail)))
((null? (car tail)) (loop (cdr tail)))
(else (cons (car tail) (loop (cdr tail))))))))
(if (and attr (pair? attr))
(if (pair? (car attr))
(cons* tag `(@ . ,attr) tail)
(cons* tag `(@ ,attr) tail))
(cons tag tail))))
;; @deffn {Procedure} sx-unitize list-tag form seed
;; Given a declaration of form @code{(tag ... (elt-list ...) ...)}
;; fold into the seed broken list of
;; @code{(tag ... elt1 ...) (tag ... elt2 ...) ... seed}.
;; Any attributes for the list form are lost.
;; @end deffn
(define (sx-unitize list-tag form seed)
(let loop ((head '()) (elts '()) (tail '()) (form form))
(if (null? elts)
(if (and (pair? (car form)) (eq? list-tag (sx-tag (car form))))
(loop head (cdar form) (cdr form) '())
(loop (cons (car form) head) elts tail (cdr form)))
(let loop2 ((elts elts))
(if (null? elts) seed
(cons (append-reverse (cons (car elts) head) tail)
(loop2 (cdr elts))))))))
;; ============================================================================
;; sx-match: somewhat like sxml-match but hoping to be more usable and more
;; efficient for nyacc. Note that sxml-match used in c99/pprint has to be
;; broken up in order to not overflow the stack during compilation.
;; This uses only syntax-rules; sxml uses syntax-case.
;; sx-haz-attr? val
;;(define (sx-haz-attr? sx)
;; (and (pair? (cdr sx)) (pair? (cadr sx)) (eqv? '@ (caadr sx)) #t))
;; Given that a tag must be ... we define the syntax of SXML as follows:
;; SXML is a text format for XML using S-expressions, sexp's whose first
;; element is a symbol for a legal XML tag. The syntax is:
;; sexp: (tag node ...) | (tag (@ sexp ...) node ...)
;; node: sexp | *text*
;; OR
;; sexp: (tag attl tail) | (tag tail)
;; attl: (@ (k "v") ...)
;; tail: (node ...)
;; node: sexp | *text*
;; where
;; tag is a Scheme symbol for a legal XML tag name
;; attl is an attribute list, a list whose first element is '@
;; tail is a list of node
;; node is sexp or a text string.
;; patterns:
;; attribute list only specified by (@ . ,<name>) where <name> is a var name
;; Specify attribute list if you want to capture the list of attributes with
;; a binding. Otherwise leave it out. The only way to test for no attributes
;; is to capture the a-list and test with @code{pair?}
;; FIX THIS:
;; (foo (@ . ,<name>) (bar ,abc) ...)
;; (foo (bar ,abc) ...)
;; (foo ... , *)
;; (* ...) any sexp
;; * any node (i.e., sexp or text)
;; or use `*any*'
;; need don't care: (foo a b c . ?) (foo a b ? c)
;; if expect text, must use , or ?
;; ideas:
;; instead of (* ...) use (*any* ...)
;; use (*text* "text") to match text or (*text* ,text)
;; kt kf are continuation syntax expresions
;; @deffn {Syntax} sx-match exp (pat body ...) ...
;; This syntax will attempt to match @var{expr} against the patterns.
;; At runtime, when @var{pat} is matched against @var{exp}, then @var{body ...}
;; will be evaluated.
;; @end deffn
(define-syntax sx-match
(syntax-rules ()
((_ e c ...)
(let ((v e)) (sx-match-1 v c ...)))))
(define-syntax sx-match-1
(syntax-rules ()
((_ v (pat exp ...) c1 ...)
(let ((kf (lambda () (sx-match-1 v c1 ...))))
(sxm-sexp v pat (begin exp ...) (kf))))
((_ v) (error "sx-match: nothing matches"))))
;; sxm-sexp val pat kt kf
;; match sexp
(define-syntax sxm-sexp
(syntax-rules (@ unquote else)
;; accept anything
((_ v (unquote w) kt kf) (let ((w v)) kt))
;; capture attributes
((_ v (tag (@ . (unquote al)) . nl) kt kf)
(sxm-tag (car v) tag
(if (sx-has-attr? v)
(let ((al (cdadr v))) (sxm-tail (cddr v) nl kt kf))
(let ((al '())) (sxm-tail (cdr v) nl kt kf)))
kf))
;; ignore attributes; (cadr v) may be an attr node. If so, ignore it.
((_ v (tag . nl) kt kf)
(sxm-tag (car v) tag
(if (sx-has-attr? v)
(sxm-tail (cddr v) nl kt kf)
(sxm-tail (cdr v) nl kt kf))
kf))
;; deprecate `else' syntax?
((_ v else kt kf) kt)))
;; sxm-tag val pat kt kf
;; match tag: foo|#(foo bar baz)|,any
(define-syntax sxm-tag
(syntax-rules (unquote)
((_ tv (unquote t0) kt kf)
(let ((t0 tv)) kt))
((_ tv (t0 t1 ...) kt kf)
(if (memq tv '(t0 t1 ...)) kt kf))
((_ tv #(t0 t1 ...) kt kf)
(if (memq tv '(t0 t1 ...)) kt kf))
((_ tv t0 kt kf)
(if (eqv? tv 't0) kt kf))))
(define (rule-error s) (error "sx-match: rule element is not SXML" s))
(define (expr-error v) (error "sx-match: expr element is not SXML" v))
;; sxm-tail val pat kt kf
;; match tail of sexp = list of nodes
(define-syntax sxm-tail
(syntax-rules (unquote)
((_ v () kt kf) (if (null? v) kt kf))
((_ v (unquote w) kt kf) (let ((w v)) kt))
((_ v (hp . tp) kt kf)
(if (pair? v)
(let ((hv (car v)) (tv (cdr v)))
(sxm-node hv hp (sxm-tail tv tp kt kf) kf))
kf))
((_ v p kt kf) kf)))
;; [ht][vp] = [head,tail][value,pattern]
;; Can this be set up to match a string constant?
(define-syntax sxm-node
(syntax-rules (unquote)
((_ v () kt kf) (if (null? v) kt kf))
((_ v (unquote w) kt kf) (let ((w v)) kt))
((_ v (hp . tp) kt kf) (if (pair? v) (sxm-sexp v (hp . tp) kt kf) kf))
((_ v s kt kf)
(begin
(unless (string? s) (rule-error s))
(unless (string? v) (expr-error v))
(if (string=? s v) kt kf)))
;;((_ v s kt kf) (if (string=? s v) kt kf))
;;^-- If not pair or unquote then must be string, right?
))
;; --- last line ---

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

@ -0,0 +1,506 @@
;;; module/nyacc/util.scm - runtime utilities for the parsers
;; Copyright (C) 2015-2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.
;;; Code:
(define-module (nyacc lang util)
#:export (license-lgpl3+
report-error
*input-stack* push-input pop-input
reset-input-stack input-stack-portinfo
make-tl tl->list ;; rename?? to tl->sx for sxml-expr
tl-append tl-insert tl-extend tl+attr tl+attr*
;; for pretty-printing
make-protect-expr make-pp-formatter make-pp-formatter/ugly
;; for ???
move-if-changed
cintstr->scm
sferr pperr
mach-dir
;; deprecated
lang-crn-lic)
#:use-module ((srfi srfi-1) #:select (find fold fold-right))
#:use-module (ice-9 pretty-print))
(cond-expand
(mes)
(guile-2)
(guile-3)
(guile
(use-modules (ice-9 optargs))
(use-modules (srfi srfi-16)))
(else))
;; This is a generic copyright/licence that will be printed in the output
;; of the examples/nyacc/lang/*/ actions.scm and tables.scm files.
(define license-lgpl3+ "
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
See the file COPYING included with the this distribution.")
(define lang-crn-lic license-lgpl3+)
(define (sferr fmt . args)
(apply simple-format (current-error-port) fmt args))
(define (pperr exp . kw-args)
(apply pretty-print exp (current-error-port) kw-args))
;; @deffn {Procedure} report-error fmt args
;; Report an error, to stderr, providing file and line num info, and add
;; newline. This also reports context of parent files.
;; @end deffn
(define (report-error fmt args)
(let ((fn (or (port-filename (current-input-port)) "(unknown)"))
(ln (1+ (port-line (current-input-port)))))
(apply simple-format (current-error-port)
(string-append "~A:~A: " fmt "\n") fn ln args)
(for-each
(lambda (pair)
(simple-format (current-error-port) " at ~A:~A\n" (car pair) (cdr pair)))
(input-stack-portinfo))))
;; === input stack =====================
(define *input-stack* (make-fluid))
(define (reset-input-stack)
(fluid-set! *input-stack* '()))
(define (push-input port)
(let ((curr (current-input-port))
(ipstk (fluid-ref *input-stack*)))
(fluid-set! *input-stack* (cons curr ipstk))
;;(sferr "~S pu=>\n" (length ipstk))
(set-current-input-port port)))
;; Return #f if empty
(define (pop-input)
(let ((ipstk (fluid-ref *input-stack*)))
(if (null? ipstk) #f
(begin
(close-port (current-input-port))
(set-current-input-port (car ipstk))
(fluid-set! *input-stack* (cdr ipstk))))))
;; @deffn {Procedure} input-stack-portinfo
;; Return a list of pairs of input stack filename and line number.
;; @end deffn
(define (input-stack-portinfo)
"- Procedure: input-stack-portinfo
Return a list of pairs of input stack filename and line number."
(define (port-info port)
(cons (or (port-filename port) "(unknown)") (1+ (port-line port))))
(fold-right (lambda (port info) (cons (port-info port) info)) '()
(fluid-ref *input-stack*)))
;; === tl ==============================
;; @section Tagged Lists
;; Tagged lists are
;; They are implemented as a cons cell with the car and the cdr a list.
;; The cdr is used to accumulate appended items and the car is used to
;; keep the tag, attributes and inserted items.
;; @example
;; tl => '(H . T), H => (c a b 'tag); T =>
;; @end example
;; @deffn {Procedure} make-tl tag [item item ...]
;; Create a tagged-list structure.
;; @end deffn
(define (make-tl tag . rest)
"- Procedure: make-tl tag [item item ...]
Create a tagged-list structure."
(let loop ((tail tag) (l rest))
(if (null? l) (cons '() tail)
(loop (cons (car l) tail) (cdr l)))))
;; @deffn {Procedure} tl->list tl
;; Convert a tagged list structure to a list. This collects added attributes
;; and puts them right after the (leading) tag, resulting in something like
;; @example
;; (<tag> (@ <attr>) <rest>)
;; @end example
;; @end deffn
(define (tl->list tl)
"- Procedure: tl->list tl
Convert a tagged list structure to a list. This collects added
attributes and puts them right after the (leading) tag, resulting
in something like
(<tag> ( <attr>) <rest>)"
(let ((heda (car tl))
(head (let loop ((head '()) (attr '()) (tl-head (car tl)))
(if (null? tl-head)
(if (pair? attr)
(cons (cons '@ attr) (reverse head))
(reverse head))
(if (and (pair? (car tl-head)) (eq? '@ (caar tl-head)))
(loop head (cons (cdar tl-head) attr) (cdr tl-head))
(loop (cons (car tl-head) head) attr (cdr tl-head)))))))
(let loop ((tail '()) (tl-tail (cdr tl)))
(if (pair? tl-tail)
(loop (cons (car tl-tail) tail) (cdr tl-tail))
(cons tl-tail (append head tail))))))
;; @deffn {Procedure} tl-insert tl item
;; Insert item at front of tagged list (but after tag).
;; @end deffn
(define (tl-insert tl item)
"- Procedure: tl-insert tl item
Insert item at front of tagged list (but after tag)."
(cons (cons item (car tl)) (cdr tl)))
;; @deffn {Procedure} tl-append tl item ...
;; Append items at end of tagged list.
;; @end deffn
(define (tl-append tl . rest)
"- Procedure: tl-append tl item ...
Append items at end of tagged list."
(cons (car tl)
(let loop ((tail (cdr tl)) (items rest))
(if (null? items) tail
(loop (cons (car items) tail) (cdr items))))))
;; @deffn {Procedure} tl-extend tl item-l
;; Extend with a list of items.
;; @end deffn
(define (tl-extend tl item-l)
"- Procedure: tl-extend tl item-l
Extend with a list of items."
(apply tl-append tl item-l))
;; @deffn {Procedure} tl-extend! tl item-l
;; Extend with a list of items. Uses @code{set-cdr!}.
;; @end deffn
(define (tl-extend! tl item-l)
"- Procedure: tl-extend! tl item-l
Extend with a list of items. Uses 'set-cdr!'."
(set-cdr! (last-pair tl) item-l)
tl)
;; @deffn {Procedure} tl+attr tl key val)
;; Add an attribute to a tagged list. Return a new tl.
;; @example
;; (tl+attr tl 'type "int")
;; @end example
;; @end deffn
(define (tl+attr tl key val)
"- Procedure: tl+attr tl key val)
Add an attribute to a tagged list. Return a new tl.
(tl+attr tl 'type \"int\")"
(tl-insert tl (cons '@ (list key val))))
;; @deffn {Procedure} tl+attr tl key val [key val [@dots{} ...]]) => tl
;; Add multiple attributes to a tagged list. Return a new tl.
;; @example
;; (tl+attr tl 'type "int")
;; @end example
;; @end deffn
(define (tl+attr* tl . rest)
"- Procedure: tl+attr tl key val [key val [... ...]]) => tl
Add multiple attributes to a tagged list. Return a new tl.
(tl+attr tl 'type \"int\")"
(if (null? rest) tl
(tl+attr* (tl+attr tl (car rest) (cadr rest)) (cddr rest))))
;; @deffn {Procedure} tl-merge tl tl1
;; Merge guts of phony-tl @code{tl1} into @code{tl}.
;; @end deffn
(define (tl-merge tl tl1)
(error "tl-merge: not implemented (yet)"))
;;; === misc ========================
(define (mach-dir path file)
(string-append path "/mach.d/" file))
;;; === pp ==========================
;; @section Pretty-Print and Other Utility Procedures
;; @deffn {Procedure} make-protect-expr op-prec op-assc => side op expr => #t|#f
;; Generate procedure @code{protect-expr} for pretty-printers, which takes
;; the form @code{(protect-expr? side op expr)} and where @code{side}
;; is @code{'lval} or @code{'rval}, @code{op} is the operator and @code{expr}
;; is the expression. The argument @arg{op-prec} is a list of equivalent
;; operators in order of decreasing precedence and @arg{op-assc} is an
;; a-list of precedence with keys @code{'left}, @code{'right} and
;; @code{nonassoc}.
;; @example
;; (protect-expr? 'left '+ '(mul ...)) => TBD
;; @end example
;; @end deffn
(define (make-protect-expr op-prec op-assc)
(define (assc-lt? op)
(memq op (assq-ref op-assc 'left)))
(define (assc-rt? op)
(memq op (assq-ref op-assc 'right)))
;; @deffn {Procedure} prec a b => '>|'<|'=|#f
;; Returns the prececence relation of @code{a}, @code{b} as
;; @code{<}, @code{>}, @code{=} or @code{#f} (no relation).
;; @end deffn
(define (prec a b)
(let loop ((ag #f) (bg #f) (opg op-prec)) ;; a-group, b-group
(cond
((null? opg) #f) ; indeterminate
((memq a (car opg))
(if bg '<
(if (memq b (car opg)) '=
(loop #t bg (cdr opg)))))
((memq b (car opg))
(if ag '>
(if (memq a (car opg)) '=
(loop ag #t (cdr opg)))))
(else
(loop ag bg (cdr opg))))))
(lambda (side op expr)
(let ((assc? (case side
((lt lval left) assc-rt?)
((rt rval right) assc-lt?)))
(vtag (car expr)))
(case (prec op vtag)
((>) #t)
((<) #f)
((=) (assc? op))
(else #f)))))
;; @deffn {Procedure} expand-tabs str [col]
;; Expand tabs where the string @var{str} starts in column @var{col}
;; (default 0).
;; @end deffn
(define* (expand-tabs str #:optional (col 0))
(define (fill-tab col chl)
(let loop ((chl (if (zero? col) (cons #\space chl) chl))
(col (if (zero? col) (1+ col) col)))
(if (zero? (modulo col 8)) chl
(loop (cons #\space chl) (1+ col)))))
(define (next-tab-col col) ;; TEST THIS !!!
;;(* 8 (quotient (+ 9 col) 8))) ???
(* 8 (quotient col 8)))
(let ((strlen (string-length str)))
(let loop ((chl '()) (col col) (ix 0))
(if (= ix strlen) (list->string (reverse chl))
(let ((ch (string-ref str ix)))
(case ch
((#\newline)
(loop (cons ch chl) 0 (1+ ix)))
((#\tab)
(loop (fill-tab col chl) (next-tab-col col) (1+ ix)))
(else
(loop (cons ch chl) (1+ col) (1+ ix)))))))))
;; @deffn {Procedure} make-pp-formatter [port] <[options> => fmtr
;; Options
;; @table @code
;; @item #:per-line-prefix
;; string to prefix each line
;; @item #:width
;; Max width of output. Default is 79 columns.
;; @end itemize
;; @example
;; (fmtr 'push) ;; push indent level
;; (fmtr 'pop) ;; pop indent level
;; (fmtr "fmt" arg1 arg2 ...)
;; @end example
;; @end deffn
(define* (make-pp-formatter #:optional (port (current-output-port))
#:key per-line-prefix (width 79) (basic-offset 2))
(letrec*
((pfxlen (string-length (expand-tabs (or per-line-prefix ""))))
(maxcol (- width (if per-line-prefix pfxlen 0)))
(maxind 36)
(column 0)
(ind-lev 0)
(ind-len 0)
(blanks " ")
(ind-str (lambda () (substring blanks 0 ind-len)))
(cnt-str (lambda () (substring blanks 0 (+ basic-offset 2 ind-len))))
;;(sf-nl (lambda () (newline) (set! column 0)))
(push-il
(lambda ()
(set! ind-lev (min maxind (1+ ind-lev)))
(set! ind-len (* basic-offset ind-lev))))
(pop-il
(lambda ()
(set! ind-lev (max 0 (1- ind-lev)))
(set! ind-len (* basic-offset ind-lev))))
(inc-column!
(lambda (inc)
(set! column (+ column inc))))
(set-column!
(lambda (val)
(set! column val)))
(sf
(lambda (fmt . args)
(let* ((str (apply simple-format #f fmt args))
(str (if (and (zero? column) per-line-prefix)
(begin
(when #f ;;(char=? #\tab (string-ref str 0))
(sferr "expand-tabs (pfxlen=~S)\n" pfxlen)
(sferr "~A\n" str)
(sferr "~A~A\n\n" per-line-prefix
(expand-tabs str pfxlen)))
(expand-tabs str pfxlen))
str))
(len (string-length str)))
(cond
((zero? column)
(if per-line-prefix (display per-line-prefix port))
(display (ind-str) port)
(inc-column! ind-len))
((> (+ column len) maxcol)
(newline port)
(if per-line-prefix (display per-line-prefix port))
(display (cnt-str) port)
(set-column! (+ ind-len 4))))
(display str port)
(inc-column! len)
(when (and (positive? len)
(eqv? #\newline (string-ref str (1- len))))
(set! column 0))))))
(lambda (arg0 . rest)
(cond
;;((string? arg0) (if (> (string-length arg0) 0) (apply sf arg0 rest)))
((string? arg0) (apply sf arg0 rest))
((eqv? 'push arg0) (push-il))
((eqv? 'pop arg0) (pop-il))
((eqv? 'nlin arg0) ;; newline if needed
(cond ((positive? column) (newline) (set! column 0))))
(else (throw 'nyacc-error "pp-formatter: bad args"))))))
;; @deffn {Procedure} make-pp-formatter/ugly => fmtr
;; Makes a @code{fmtr} like @code{make-pp-formatter} but no indentation
;; and just adds strings on ...
;; This is specific to C/C++ because it will newline if #\# seen first.
;; @end deffn
(define* (make-pp-formatter/ugly)
(let*
((maxcol 78)
(column 0)
(sf (lambda (fmt . args)
(let* ((str (apply simple-format #f fmt args))
(len (string-length str)))
(if (and (positive? len)
(char=? #\newline (string-ref str (1- len))))
(string-set! str (1- len) #\space))
(cond
((zero? len) #t) ; we reference str[0] next
((and (equal? len 1) (char=? #\newline (string-ref str 0))) #t)
((char=? #\# (string-ref str 0)) ; CPP-stmt: force newline
(when (positive? column) (newline))
(display str) ; str always ends in \n
(set! column ; if ends \n then col= 0 else len
(if (char=? #\newline (string-ref str (1- len)))
0 len)))
((zero? column)
(display str)
(set! column len))
(else
(when (> (+ column len) maxcol)
(newline)
(set! column 0))
(display str)
(set! column (+ column len))))))))
(lambda (arg0 . rest)
(cond
((string? arg0) (apply sf arg0 rest))
((eqv? 'nlin arg0) ;; newline if needed
(cond ((positive? column) (newline) (set! column 0))))
((eqv? 'push arg0) #f)
((eqv? 'pop arg0) #f)
(else (throw 'nyacc-error "pp-formatter/ugly: bad args"))))))
;; @deffn {Procedure} move-if-changed src-file dst-file [sav-file]
;; Return @code{#t} if changed.
;; @end deffn
(define (move-if-changed src-file dst-file . rest)
(define (doit)
(let ((sav-file (if (pair? rest) (car rest) #f)))
(if (and sav-file (access? sav-file W_OK))
(system (simple-format #f "mv ~A ~A" dst-file sav-file)))
(system (simple-format #f "mv ~A ~A" src-file dst-file))
#t))
(cond
;; src-file does not exist
((not (access? src-file R_OK)) #f)
;; dst-file does not exist, update anyhow
((not (access? dst-file F_OK))
(system (simple-format #f "mv ~A ~A" src-file dst-file)) #t)
;; both exist, but no changes
((zero? (system
(simple-format #f "cmp ~A ~A >/dev/null" src-file dst-file)))
(system (simple-format #f "rm ~A" src-file)) #f)
;; both exist, update
((access? dst-file W_OK)
(doit))
(else
(simple-format (current-error-port) "move-if-changed: no write access\n")
#f)))
;; @deffn {Procedure} cintstr->scm str => #f|str
;; Convert a C string for a fixed type to a Scheme string.
;; If not identified as a C int, then return @code{#f}.
;; TODO: add support for character literals (and unicode?).
;; @end deffn
(define cs:dig (string->char-set "0123456789"))
(define cs:hex (string->char-set "0123456789ABCDEFabcdef"))
(define cs:oct (string->char-set "01234567"))
(define cs:long (string->char-set "lLuU"))
(define (cintstr->scm str)
;; dl=digits, ba=base, st=state, ix=index
;; 0: "0"->1, else->2
;; 1: "x"->(base 16)2, else->(base 8)2
;; 2: "0"-"9"->(cons ch dl), else->3:
;; 3: "L","l","U","u"->3, eof->(cleanup) else->#f
(let ((ln (string-length str)))
(let loop ((dl '()) (bx "") (cs cs:dig) (st 0) (ix 0))
(if (= ix ln)
(if (null? dl) #f (string-append bx (list->string (reverse dl))))
(case st
((0) (loop (cons (string-ref str ix) dl) bx cs
(if (char=? #\0 (string-ref str ix)) 1 2)
(1+ ix)))
((1) (if (char=? #\x (string-ref str ix))
(loop '() "#x" cs:hex 2 (1+ ix))
(loop '() "#o" cs:oct 2 ix)))
((2) (if (char-set-contains? cs (string-ref str ix))
(loop (cons (string-ref str ix) dl) bx cs st (1+ ix))
(if (char-set-contains? cs:long (string-ref str ix))
(loop dl bx cs 3 (1+ ix))
#f)))
((3) #f))))))
;;; --- last line ---

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

@ -0,0 +1,696 @@
;;; nyacc/lex.scm
;; Copyright (C) 2015-2019 - Matthew R.Wette
;;
;; This library is free software; you can redistribute it and/or modify it
;; under the terms of the GNU Lesser General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or (at
;; your option) any later version.
;;
;; This library is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>
;;; Description:
;; A module providing procedures for constructing lexical analyzers.
;; '$fixed '$float '$string '$ident '$chlit '$chlit/L '$chlit/u '$chlit/U
;; todo: change lexer to return @code{cons-source} instead of @code{cons}
;; todo: to be fully compliant, C readers need to deal with \ at end of line
;; todo: figure out what readers return atoms and which pairs
;; tokens: read-c-ident
;; pairs: num-reader read-c-num read-c-string
;; issue: if returning pairs we need this for hashed parsers:
;; (define (assc-$ pair) (cons (assq-ref symbols (car pair)) (cdr pair)))
;; read-comm changed to (read-comm ch bol) where bol is begin-of-line cond
;;
;; read-c-ident
;;; Code:
(define-module (nyacc lex)
#:export (make-lexer-generator
make-ident-reader
make-comm-reader
make-string-reader
make-chseq-reader
make-num-reader
eval-reader
read-c-ident read-c$-ident
read-c-comm
read-c-string
read-c-chlit
read-c-num
read-oct read-hex
like-c-ident? like-c$-ident?
c-escape
cnumstr->scm
filter-mt remove-mt map-mt make-ident-like-p
c:ws c:if c:ir)
#:use-module ((srfi srfi-1) #:select (remove append-reverse)))
(define (sf fmt . args) (apply simple-format #t fmt args))
;; @section Constructing Lexical Analyzers
;; The @code{lex} module provides a set of procedures to build lexical
;; analyzers. The approach is to first build a set of @defn{readers} for
;; MORE TO COME
;;
;; Readers are procecures that take one character (presumably from the
;; current-input-port) and determine try to make a match. If a match is
;; made something is returned, with any lookaheads pushed back into the
;; input port. If no match is made @code{#f} is returned and the input
;; argument is still the character to work on.
;;
;; Here are the procedures used:
;; @table @code
(define digit "0123456789")
(define ucase "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(define lcase "abcdefghijklmnopqrstuvwxyz")
;; C lexemes are popular so include those.
;;(define c:ws (list->char-set '(#\space #\tab #\newline #\return )))
(define c:ws char-set:whitespace)
(define c:if (let ((cs (char-set #\_))) ; ident, first char
(string->char-set! ucase cs)
(string->char-set! lcase cs)))
(define c:ir (string->char-set digit c:if)) ; ident, rest chars
(define c:nx (string->char-set "eEdD")) ; number exponent
(define c:hx (string->char-set "abcdefABCDEF"))
(define c:sx (string->char-set "lLuU")) ; fixed suffix
(define c:fx (string->char-set "fFlL")) ; float suffix
(define c:px (string->char-set "rRhHkKlLuU")) ; fixed-point suffix
(define c:bx (string->char-set "pP")) ; binary float suffix
(define c:cx (string->char-set "LuU")) ; char prefix
(define lxlsr reverse-list->string)
;; @deffn {Procedure} eval-reader reader string => result
;; For test and debug, this procedure will evaluate a reader on a string.
;; A reader is a procedure that accepts a single character argument intended
;; to match a specific character sequence. A reader will read more characters
;; by evaluating @code{read-char} until it matches or fails. If it fails, it
;; will pushback all characters read via @code{read-char} and return @code{#f}.
;; If it succeeds the input pointer will be at the position following the
;; last matched character.
;; @end deffn
(define (eval-reader reader string)
(with-input-from-string string
(lambda () (reader (read-char)))))
;; @deffn {Procedure} make-space-skipper chset => proc
;; This routine will generate a reader to skip whitespace.
;; @end deffn
(define (make-space-skipper chset)
(lambda (ch)
(if (char-set-contains? chset ch)
(let loop ((ch (read-char)))
(cond
((char-set-contains? chset ch)
(loop (read-char)))
(else
(unread-char ch)
#t)))
#f)))
;; @deffn {Procedure} skip-c-space ch => #f|#t
;; If @code{ch} is space, skip all spaces, then return @code{#t}, else
;; return @code{#f}.
;; @end deffn
(define skip-c-space (make-space-skipper c:ws))
;; @deffn {Procedure} make-ident-reader cs-first cs-rest => ch -> #f|string
;; For identifiers, given the char-set for first character and the char-set
;; for following characters, return a return a reader for identifiers.
;; The reader takes a character as input and returns @code{#f} or @code{string}.
;; This will generate exception on @code{#<eof>}.
;; @end deffn
(define (make-ident-reader cs-first cs-rest)
(lambda (ch)
(if (char-set-contains? cs-first ch)
(let loop ((chl (list ch)) (ch (read-char)))
(cond
((eof-object? ch)
(if (null? chl) #f
(lxlsr chl)))
((char-set-contains? cs-rest ch)
(loop (cons ch chl) (read-char)))
(else (unread-char ch)
(lxlsr chl))))
#f)))
;; @deffn {Procedure} make-ident-like-p ident-reader
;; Generate a predicate, from a reader, that determines if a string qualifies
;; as an identifier.
;; @end deffn
;; Implementation may not be very efficient.
(define (make-ident-like-p reader)
(lambda (s) (and (string? s)
(positive? (string-length s))
(eval-reader reader s)
#t)))
;; @deffn {Procedure} read-c-ident ch => #f|string
;; If ident pointer at following char, else (if #f) ch still last-read.
;; @end deffn
(define read-c-ident (make-ident-reader c:if c:ir))
;; @deffn {Procedure} like-c-ident? ch
;; Determine if a string qualifies as a C identifier.
;; @end deffn
(define like-c-ident? (make-ident-like-p read-c-ident))
;; @deffn {Procedure} read-c$-ident ch => #f|string
;; Similar to @code{read-c-ident}: it allows initial @code{$}.
;; @end deffn
(define read-c$-ident
(let ((cs (char-set-copy c:if)))
(string->char-set! "$" cs)
(make-ident-reader cs c:ir)))
;; @deffn {Procedure} like-c$-ident? ch
;; Similar to @code{like-c-ident}: it allows initial @code{$}.
;; @end deffn
(define like-c$-ident? (make-ident-like-p read-c$-ident))
;; @deffn {Procedure} make-string-reader delim
;; Generate a reader that uses @code{delim} as delimiter for strings.
;; TODO: need to handle matlab-type strings.
;; TODO: need to handle multiple delim's (like python)
;; @end deffn
(define (make-string-reader delim) ;; #:xxx
(lambda (ch)
(if (eq? ch delim)
(let loop ((cl '()) (ch (read-char)))
(cond ((eq? ch #\\)
(let ((c1 (read-char)))
(if (eq? c1 #\newline)
(loop cl (read-char))
(loop (cons* c1 cl) (read-char)))))
((eq? ch delim) (cons '$string (lxlsr cl)))
(else (loop (cons ch cl) (read-char)))))
#f)))
;; @deffn {Procedure} read-oct => 123|#f
;; Read octal number, assuming @code{\0} have already been read.
;; Return integer.
;; @end deffn
(define read-oct
(let ((cs:oct (string->char-set "01234567")))
(lambda ()
(let loop ((cv 0) (ch (read-char)) (n 0))
(cond
((eof-object? ch) cv)
;;((> n 3) (unread-char ch) cv)
((char-set-contains? cs:oct ch)
(loop (+ (* 8 cv) (- (char->integer ch) 48)) (read-char) (1+ n)))
(else (unread-char ch) cv))))))
;; @deffn {Procedure} read-hex => 123|#f
;; Read hex number. Assumes prefix (e.g., "0x" has already been read).
;; Returns integer.
;; @end deffn
(define read-hex
(let ((cs:dig (string->char-set "0123456789"))
(cs:uhx (string->char-set "ABCDEF"))
(cs:lhx (string->char-set "abcdef")))
(lambda ()
(let loop ((cv 0) (ch (read-char)) (n 0))
(cond
((eof-object? ch) cv)
;;((> n 2) (unread-char ch) cv)
((char-set-contains? cs:dig ch)
(loop (+ (* 16 cv) (- (char->integer ch) 48)) (read-char) (1+ n)))
((char-set-contains? cs:uhx ch)
(loop (+ (* 16 cv) (- (char->integer ch) 55)) (read-char) (1+ n)))
((char-set-contains? cs:lhx ch)
(loop (+ (* 16 cv) (- (char->integer ch) 87)) (read-char) (1+ n)))
(else (unread-char ch) cv))))))
;; @deffn {Procedure} c-escape seed
;; After @code{\\} in a C string, read the rest of the sequence and cons
;; the character, if exists, with the seed (a list). Remember that @code{\n}
;; should, and will, just return the seed.
;; @end deffn
(define (c-escape seed)
(let* ((ch (read-char)))
(case ch
((#\newline) seed)
((#\\) (cons #\\ seed))
((#\") (cons #\" seed))
((#\') (cons #\' seed))
((#\n) (cons #\newline seed))
((#\r) (cons #\return seed))
((#\b) (cons #\bs seed))
((#\t) (cons #\tab seed))
((#\f) (cons #\page seed))
((#\a) (cons #\bel seed)) ; guile 1.8 doesn't know #\alarm
((#\v) (cons #\vt seed)) ; guile 1.8 doesn't know #\vtab
((#\0) (cons (integer->char (read-oct)) seed))
((#\1 #\2 #\3 #\4 #\5 #\6 #\7)
(unread-char ch) (cons (integer->char (read-oct)) seed))
((#\x) (cons (integer->char (read-hex)) seed))
(else (cons ch seed)))))
;; @deffn {Procedure} read-c-string ch => ($string . "foo")
;; Read a C-code string. Output to code is @code{write} not @code{display}.
;; Return #f if @var{ch} is not @code{"}. @*
;; TODO: parse trigraphs
;; ??=->#, ??/->\, ??'->^, ??(->[, ??)->], ??~->|, ??<->{, ??>->}, ??-->~
;; and digraphs <:->[, :>->], <%->{ %>->} %:->#
;; @end deffn
(define (read-c-string ch)
(if (not (eq? ch #\")) #f
(let loop ((cl '()) (ch (read-char)))
(cond ((eq? ch #\\) (loop (c-escape cl) (read-char)))
((eq? ch #\") (cons '$string (lxlsr cl)))
(else (loop (cons ch cl) (read-char)))))))
;; @deffn {Procedure} make-chlit-reader
;; Generate a reader for character literals. NOT DONE.
;; For C, this reads @code{'c'} or @code{'\n'}.
;; @end deffn
(define (make-chlit-reader . rest) (error "NOT IMPLEMENTED"))
;; @deffn {Procedure} read-c-chlit ch
;; @example
;; ... 'c' ... => (read-c-chlit #\') => '($chlit . #\c)
;; @end example
;; This will return @code{$chlit}, $code{$chlit/L} for @code{wchar_t},
;; @code{$chlit/u} for @code{char16_t}, or @code{$chlit/U} for @code{char32_t}.
;; @end deffn
(define (read-c-chlit ch)
(define (read-esc-char)
(let ((c2 (read-char)))
(case c2
((#\t) "\t") ; horizontal tab U+0009
((#\n) "\n") ; newline U+000A
((#\v) "\v") ; verticle tab U+000B
((#\f) "\f") ; formfeed U+000C
((#\r) "\r") ; return U+000D
((#\a) "\x07") ; alert U+0007
((#\b) "\x08") ; backspace U+0008 not in guile 1.8
((#\0) (string (integer->char (read-oct)))) ; octal
((#\1 #\2 #\3 #\4 #\5 #\6 #\7) ; octal
(unread-char c2) (string (integer->char (read-oct))))
((#\x) (string (integer->char (read-hex)))) ; hex
((#\\ #\' #\" #\? #\|) (string c2))
(else (error "bad escape sequence" c2)))))
(define (wchar t)
(case t ((#\L) '$chlit/L) ((#\u) '$chlit/u) ((#\U) '$chlit/U)))
(cond
((char=? ch #\')
(let* ((c1 (read-char))
(sc (if (eqv? c1 #\\) (read-esc-char) (string c1))))
(if (not (char=? #\' (read-char))) (error "bad char lit"))
(cons '$chlit sc)))
((char-set-contains? c:cx ch)
(let ((c1 (read-char)))
(cond
((char=? c1 #\') (cons (wchar ch) (cdr (read-c-chlit c1))))
(else (unread-char c1) #f))))
(else #f)))
(define (fix-dot l) (if (char=? #\. (car l)) (cons #\0 l) l))
;; @deffn {Procedure} make-num-reader => (proc ch) => #f|fixed|float
;; Where @emph{fixed} is @code{($fixed . "1")} and @emph{float} is
;; @code{($float . "1.0")}
;; This procedure reads C numeric literals (included fixed-point types).
;; Some literals are cleaned: @code{"0"} may be added before or after dot.
;; This allows use of @code{0b} prefix for binary literals even though that
;; is not C.
;; @end deffn
(define (make-num-reader)
;; This will incorrectly parse 123LUL. Does not handle hex floats.
;; 0: start; 1: p-i; 2: p-f; 3: p-e-sign; 4: p-e-d; 5: packup
;; Now handles fixed-point (returning '$fixpt)
(lambda (ch1)
;; chl: char list; ty: '$fixed or '$float; st: state; ch: next ch; ba: base
(let loop ((chl '()) (ty #f) (ba 10) (st 0) (ch ch1))
(case st
((0)
(cond
((eof-object? ch) (loop chl ty ba 5 ch))
((char=? #\0 ch) (loop (cons ch chl) '$fixed 8 10 (read-char)))
((char-numeric? ch) (loop chl '$fixed ba 1 ch))
((char=? #\. ch) (loop (cons ch chl) #f ba 15 (read-char)))
(else #f)))
((10) ;; allow x, b (C++14) after 0
(cond
((eof-object? ch) (loop chl ty ba 5 ch))
((char=? #\x ch) (loop (cons ch chl) ty 16 1 (read-char)))
((char=? #\X ch) (loop (cons ch chl) ty 16 1 (read-char)))
((char=? #\b ch) (loop (cons ch chl) ty 2 1 (read-char)))
(else (loop chl ty ba 1 ch))))
((15) ;; got `.' only
(cond
((eof-object? ch) (unread-char ch) #f)
((char-numeric? ch) (loop (cons ch chl) '$float ba 2 (read-char)))
(else (unread-char ch) #f)))
((1)
(cond
((eof-object? ch) (loop chl ty ba 5 ch))
((char-numeric? ch) (loop (cons ch chl) ty ba 1 (read-char)))
((char=? #\. ch) (loop (cons #\. chl) '$float ba 2 (read-char)))
((and (= ba 16) (char-set-contains? c:hx ch))
(loop (cons ch chl) ty ba 1 (read-char)))
((char-set-contains? c:sx ch)
(loop (cons ch chl) '$fixed ba 11 (read-char)))
((char-set-contains? c:nx ch)
(loop (cons ch chl) '$float ba 3 (read-char)))
((char-set-contains? c:px ch)
(loop (cons ch chl) '$fixpt ba 11 (read-char)))
((char-set-contains? c:if ch)
(sf "\nchl=~S ch=~S ty=~S ba=~S\n" chl ch ty ba)
(error "lex/num-reader st=1"))
(else (loop chl '$fixed ba 5 ch))))
((11) ;; got lLuU suffix, look for a second
(cond
((eof-object? ch) (cons ty (lxlsr chl)))
((char-set-contains? c:sx ch)
(loop (cons ch chl) ty ba st (read-char)))
((char-set-contains? c:px ch)
(loop (cons ch chl) '$fixpt ba st (read-char)))
(else (loop chl ty ba 5 ch))))
#;((12) ;; got lLuU suffix, look for a third
(cond
((eof-object? ch) (cons '$fixed (lxlsr chl)))
((char-set-contains? c:sx ch)
(loop (cons ch chl) '$fixed ba 5 (read-char)))
(else (loop chl '$fixed ba 5 ch))))
((2)
(cond
((eof-object? ch) (loop chl ty ba 5 ch))
((char-numeric? ch) (loop (cons ch chl) ty ba 2 (read-char)))
((char-set-contains? c:nx ch)
(loop (cons ch (fix-dot chl)) ty ba 3 (read-char)))
((char-set-contains? c:px ch)
(loop (cons ch chl) '$fixpt ba st (read-char)))
((char-set-contains? c:fx ch)
(cons '$float (lxlsr (cons ch (fix-dot chl)))))
((char-set-contains? c:if ch) (error "lex/num-reader st=2"))
(else (loop (fix-dot chl) ty ba 5 ch))))
((3)
(cond
((eof-object? ch) (loop chl ty ba 5 ch))
((or (char=? #\+ ch) (char=? #\- ch))
(loop (cons ch chl) ty ba 4 (read-char)))
((char-numeric? ch) (loop chl ty ba 4 ch))
(else (error "lex/num-reader st=3"))))
((4)
(cond
((eof-object? ch) (loop chl ty ba 5 ch))
((char-numeric? ch) (loop (cons ch chl) ty ba 4 (read-char)))
((char-set-contains? c:if ch) (error "lex/num-reader st=4"))
(else (loop chl ty ba 5 ch))))
((5)
(unless (eof-object? ch) (unread-char ch))
(cons ty (lxlsr chl)))))))
;; @deffn {Procedure} cnumstr->scm C99-str => scm-str
;; Convert C number-string (e.g, @code{0x123LL}) to Scheme numbers-string
;; (e.g., @code{#x123}).
;; This probably belongs in @code{(nyacc lang util)}.
;; @end deffn
(define (cnumstr->scm str)
(define (2- n) (1- (1- n))) (define (3- n) (1- (2- n)))
(let* ((nd (string-length str)))
(define (trim-rt st) ;; trim U, UL, ULL (and lowercase) from right
(if (char-set-contains? c:sx (string-ref str (1- nd)))
(if (char-set-contains? c:sx (string-ref str (2- nd)))
(if (char-set-contains? c:sx (string-ref str (3- nd)))
(substring str st (3- nd))
(substring str st (2- nd)))
(substring str st (1- nd)))
(substring str st nd)))
(if (< nd 2) str
(if (char=? #\0 (string-ref str 0))
(cond
((char=? #\x (string-ref str 1))
(string-append "#x" (trim-rt 2)))
((char=? #\X (string-ref str 1))
(string-append "#x" (trim-rt 2)))
((char=? #\b (string-ref str 1))
(string-append "#b" (trim-rt 2)))
((char-numeric? (string-ref str 1))
(string-append "#o" (trim-rt 1)))
(else (trim-rt 0)))
(trim-rt 0)))))
;; @deffn {Procedure} read-c-num ch => #f|string
;; Reader for unsigned numbers as used in C (or close to it).
;; @end deffn
(define read-c-num (make-num-reader))
;;.@deffn {Procedure} si-map string-list ix => a-list
;; Convert list of strings to alist of char at ix and strings.
;; This is a helper for make-tree.
;; @end deffn
(define (si-map string-list ix)
(let loop ((sal '()) (sl string-list))
(cond
((null? sl) sal)
((= ix (string-length (car sl)))
(loop (reverse (acons 'else (car sl) sal)) (cdr sl)))
((assq (string-ref (car sl) ix) sal) =>
(lambda (pair)
(set-cdr! pair (cons (car sl) (cdr pair)))
(loop sal (cdr sl))))
(else ;; Add (#\? . string) to alist.
(loop (cons (cons (string-ref (car sl) ix) (list (car sl))) sal)
(cdr sl))))))
;;.@deffn {Procedure} make-tree strtab -> tree
;; This routine takes an alist of strings and symbols and makes a tree
;; that parses one char at a time and provide @code{'else} entry for
;; signaling sequence found. That is, if @code{("ab" . 1)} is an entry
;; then a chseq-reader (see below) would stop at @code{"ab"} and
;; return @code{1}.
;; @end deffn
(define (make-tree strtab)
(define (si-cnvt string-list ix)
(map (lambda (pair)
(if (pair? (cdr pair))
(cons (car pair) (si-cnvt (cdr pair) (1+ ix)))
(cons (car pair) (assq-ref strtab (cdr pair)))))
(si-map string-list ix)))
(si-cnvt (map car strtab) 0))
;; @deffn {Procedure} make-chseq-reader strtab
;; Given alist of pairs (string, token) return a function that eats chars
;; until (token . string) is returned or @code{#f} if no match is found.
;; @end deffn
(define (make-chseq-reader strtab)
;; This code works on the assumption that the else-part is always last
;; in the list of transitions.
(let ((tree (make-tree strtab)))
(lambda (ch)
(let loop ((cl (list ch)) (node tree))
(cond
((assq-ref node (car cl)) => ;; accept or shift next character
(lambda (n)
(if (eq? (caar n) 'else) ; if only else, accept, else read on
(cons (cdar n) (lxlsr cl))
(loop (cons (read-char) cl) n))))
((assq-ref node 'else) => ; else exists, accept
(lambda (tok)
(unless (eof-object? (car cl)) (unread-char (car cl)))
(cons tok (lxlsr (cdr cl)))))
(else ;; reject
(let pushback ((cl cl))
(unless (null? (cdr cl))
(unless (eof-object? (car cl)) (unread-char (car cl)))
(pushback (cdr cl))))
#f))))))
;; @deffn {Procedure} make-comm-reader comm-table [#:eat-newline #t] => \
;; ch bol -> ('$code-comm "..")|('$lone-comm "..")|#f
;; comm-table is list of cons for (start . end) comment.
;; e.g. ("--" . "\n") ("/*" . "*/")
;; test with "/* hello **/"
;; If @code{eat-newline} is specified as true then for read comments
;; ending with a newline a newline swallowed with the comment.
;; The returned procedure has signature
;; @code{(proc ch #:optional bol #:skip-prefix #t|#f)}
;; @* Note: assumes backslash is never part of the end
;; @end deffn
(define* (make-comm-reader comm-table #:key eat-newline)
(define (mc-read-char) ;; CHECK THIS
(let ((ch (read-char)))
(if (eqv? ch #\\)
(let ((ch (read-char)))
(if (eqv? ch #\newline)
(read-char)
(begin (unread-char ch) #\\)))
ch)))
;; Skip whitespace upto columm @var{col}, and fill in partial tab, if needed.
;; @example
;; (skip-ws-to-col 4 " def" '(#\newline) => (#\d #\newline)
;; (skip-ws-to-col 6 "\tdef" '(#\newline)) => (#\d #\space #\space #\newline)
;; @end example
(define (skip-to-col col il)
(let loop ((il il) (cc 0) (ch (read-char)))
;;(simple-format #t " skip-to-col loop il=~S cc=~S ch=~S\n" il cc ch)
(cond
((= cc col) (cons ch il))
((> cc col) (loop (cons ch il) (1- cc) #\space)) ; tab over-run
((char=? ch #\space) (loop il (1+ cc) (read-char)))
((char=? ch #\tab) (loop il (* 8 (quotient (+ cc 9) 8)) (read-char)))
(else (cons ch il)))))
(let ((tree (make-tree comm-table)))
(lambda* (ch #:optional bol #:key skip-prefix)
(letrec
((scol (1- (port-column (current-input-port)))) ;; 1- since ch read
(tval (if bol '$lone-comm '$code-comm))
(match-beg ;; match start of comment, return end-string
(lambda (cl node)
(cond
((assq-ref node (car cl)) => ;; shift next character
(lambda (n) (match-beg (cons (mc-read-char) cl) n)))
((assq-ref node 'else) =>
(lambda (res) (unread-char (car cl)) res)) ; yuck?
(else
(let pushback ((cl cl))
(unless (null? (cdr cl))
(unread-char (car cl))
(pushback (cdr cl))))
#f))))
(find-end ;; find end of comment, return comment
;; cl: comm char list (cleared from ps);
;; sl: shift list (matched from ps); il: input list;
;; ps: pattern string (e.g., "*/") ; px: pattern index;
(lambda (cl sl il ps px)
(cond
((eq? px (string-length ps)) ; can Guile optimize this?
(if (and (not eat-newline) (eq? #\newline (car sl)))
(unread-char #\newline))
(if (and (pair? cl) (eqv? (car cl) #\cr))
(cons tval (lxlsr (cdr cl))) ; remove trailing \r
(cons tval (lxlsr cl))))
((null? il) (find-end cl sl (cons (mc-read-char) il) ps px))
((eof-object? (car il))
(if (char=? (string-ref ps px) #\newline) (cons tval (lxlsr cl))
(throw 'nyacc-error "open comment")))
((eqv? (car il) (string-ref ps px))
(find-end cl (cons (car il) sl) (cdr il) ps (1+ px)))
((and (char=? (car il) #\newline) skip-prefix)
;; assumes newline can only be end of ps
;;(simple-format #t "cl=~S sl=~S il=~S\n" cl sl il)
(find-end (cons #\newline (append sl cl)) '()
(skip-to-col scol (cdr il)) ps 0))
(else
(let ((il1 (append-reverse sl il)))
(find-end (cons (car il1) cl) '() (cdr il1) ps 0)))))))
(let ((ep (match-beg (list ch) tree))) ;; ep=end pattern (e.g., "*/")
(if ep (find-end '() '() (list (mc-read-char)) ep 0) #f))))))
(define read-c-comm (make-comm-reader '(("/*" . "*/") ("//" . "\n"))))
;; @deffn {Procedure} filter-mt p? al => al
;; Filter match-table based on cars of al.
;; @end deffn
(define (filter-mt p? al) (filter (lambda (x) (p? (car x))) al))
;; @deffn {Procedure} remove-mt p? al => al
;; Remove match-table based on cars of al.
;; @end deffn
(define (remove-mt p? al) (remove (lambda (x) (p? (car x))) al))
;; @deffn {Procedure} map-mt f al => al
;; Map cars of al.
;; @end deffn
(define (map-mt f al) (map (lambda (x) (cons (f (car x)) (cdr x))) al))
;; @deffn {Procedure} make-lexer-generator match-table => lexer-generator
;; @example
;; (define gen-lexer (make-lexer-generator #:ident-reader my-id-rdr))
;; (with-input-from-file "foo" (parse (gen-lexer)))
;; @end example
;;
;; Return a thunk that returns tokens.
;; Change this to have user pass the following routines (optionally?)
;; read-num, read-ident, read-comm
;; reztab = reserved ($ident, $fixed, $float ...
;; chrtab = characters
;; comm-reader : if parser does not deal with comments must return #f
;; but problem with character ..
;; extra-reader: insert an user-defined reader
;; match-table:
;; @enumerate
;; symbol -> (string . symbol)
;; reserved -> (symbol . symbol)
;; char -> (char . char)
;; @end enumerate
;; todo: add bol status
;; todo: maybe separate reading of keywords from identifiers: (keywd ch) =>
;; @end deffn
(define* (make-lexer-generator match-table
#:key
ident-reader num-reader
string-reader chlit-reader
comm-reader comm-skipper
space-chars extra-reader)
(let* ((read-ident (or ident-reader (make-ident-reader c:if c:ir)))
(read-num (or num-reader (make-num-reader)))
(read-string (or string-reader (make-string-reader #\")))
(read-chlit (or chlit-reader (lambda (ch) #f)))
(read-comm (or comm-reader (lambda (ch bol) #f)))
(skip-comm (or comm-skipper (lambda (ch) #f)))
(spaces (or space-chars " \t\r\n"))
(space-cs (cond ((string? spaces) (string->char-set spaces))
((list? spaces) (list->char-set spaces))
((char-set? spaces) spaces)
(else (error "expecting string list or char-set"))))
(read-extra (or extra-reader (lambda (ch) #f)))
;;
(ident-like? (make-ident-like-p read-ident))
;;
(strtab (filter-mt string? match-table)) ; strings in grammar
(kwstab (filter-mt ident-like? strtab)) ; keyword strings =>
(keytab (map-mt string->symbol kwstab)) ; keywords in grammar
(chrseq (remove-mt ident-like? strtab)) ; character sequences
(symtab (filter-mt symbol? match-table)) ; symbols in grammar
(chrtab (filter-mt char? match-table)) ; characters in grammar
;;
(read-chseq (make-chseq-reader chrseq))
(assc-$ (lambda (pair) (cons (assq-ref symtab (car pair)) (cdr pair)))))
(lambda ()
(let ((bol #f))
(lambda ()
(let loop ((ch (read-char)))
(cond
((eof-object? ch) (assc-$ (cons '$end ch)))
;;((eq? ch #\newline) (set! bol #t) (loop (read-char)))
((read-extra ch))
((char-set-contains? space-cs ch) (loop (read-char)))
((and (eqv? ch #\newline) (set! bol #t) #f))
((read-comm ch bol) =>
(lambda (p) (set! bol #f) (assc-$ p)))
((skip-comm ch) (loop (read-char)))
((read-num ch) => assc-$) ; => $fixed or $float
((read-string ch) => assc-$) ; => $string
((read-chlit ch) => assc-$) ; => $chlit
((read-ident ch) =>
(lambda (s) (or (and=> (assq-ref keytab (string->symbol s))
(lambda (tval) (cons tval s)))
(assc-$ (cons '$ident s)))))
((read-chseq ch) => identity)
((assq-ref chrtab ch) => (lambda (t) (cons t (string ch))))
(else (cons ch ch))))))))) ; should be error
;; @end table
;; --- last line ---

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

@ -0,0 +1,229 @@
;;; nyacc/parse.scm
;; Copyright (C) 2014-2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>
;;; Description:
;; procedures to generate parsers, given a lexical analyzer
;; one for files; one for interactive use: newline is possible end of input
;;; Code:
(define-module (nyacc parse)
#:export (make-lalr-parser
make-lalr-parser/sym
make-lalr-parser/num))
(define $default 1) ; sync w/ lalr.scm
(define $error 2) ; sync w/ lalr.scm
(define (vector-map proc vec) ; see (srfi srfi-43)
(let* ((ln (vector-length vec)) (res (make-vector ln)))
(let loop ((ix 0))
(unless (= ix ln)
(vector-set! res ix (proc ix (vector-ref vec ix)))
(loop (1+ ix))))
res))
(define (wrap-action actn) ; see util.scm
(define (mkarg i) (string->symbol (string-append "$" (number->string i))))
(define (make-arg-list n) (let loop ((r '(. $rest)) (i 1))
(if (> i n) r (loop (cons (mkarg i) r) (1+ i)))))
(cons* 'lambda (make-arg-list (car actn)) (cdr actn)))
(define (make-xct av)
(if (procedure? (vector-ref av 0))
av
(vector-map (lambda (ix f) (eval f (current-module)))
(vector-map (lambda (ix actn) (wrap-action actn)) av))))
(define (sferr fmt . args)
(apply simple-format (current-error-port) fmt args))
(define (dmsg/n s t a ntab)
(let ((t (or (assq-ref ntab t) t)))
(cond
((not a) (sferr "state ~S, token ~S\t=> parse error\n" s t))
((positive? a) (sferr "state ~S, token ~S => shift, goto ~S\n" s t a))
((negative? a) (sferr "state ~S, token ~S => reduce ~S\n" s t (- a)))
((zero? a) (sferr "state ~S, token ~S => accept\n" s t))
(else (error "coding error in (nyacc parse)")))))
(define (dmsg/s s t a)
(case (car a)
((error) (sferr "state ~S, token ~S => parse error\n" s t))
((shift) (sferr "state ~S, token ~S => shift, goto ~S\n" s t (cdr a)))
((reduce) (sferr "state ~S, token ~S => reduce ~S\n" s t (cdr a)))
((accept) (sferr "state ~S, token ~S => accept\n" s t))
(else (error "coding error in (nyacc parse)"))))
(define (parse-error state laval)
(let ((fn (or (port-filename (current-input-port)) "(unknown)"))
(ln (1+ (port-line (current-input-port)))))
(throw 'nyacc-error
"~A:~A: parse failed at state ~A, on input ~S"
fn ln (car state) (cdr laval))))
(define* (make-lalr-parser/sym mach #:key (skip-if-unexp '()) interactive)
(let* ((len-v (assq-ref mach 'len-v))
(rto-v (assq-ref mach 'rto-v))
(pat-v (assq-ref mach 'pat-v))
(xct-v (make-xct (assq-ref mach 'act-v)))
(start (assq-ref (assq-ref mach 'mtab) '$start)))
(lambda* (lexr #:key debug)
(let loop ((state (list 0)) ; state stack
(stack (list '$@)) ; semantic value stack
(nval #f) ; non-terminal from prev reduction
(lval #f)) ; lexical value (from lex'er)
(cond
((and interactive nval
(eqv? (car nval) start)
(zero? (car state))) ; done
(cdr nval))
((not (or nval lval))
(if (eqv? '$default (caar (vector-ref pat-v (car state))))
(loop state stack (cons '$default #f) lval) ; default reduction
(loop state stack nval (lexr)))) ; reload
(else
(let* ((laval (or nval lval))
(tval (car laval))
(sval (cdr laval))
(stxl (vector-ref pat-v (car state)))
(stx (or (assq-ref stxl tval) (assq-ref stxl '$default)
(cons 'error #f))))
(if debug (dmsg/s (car state) (if nval tval sval) stx))
(cond
((eq? 'error (car stx)) ; error ???
(if (memq tval skip-if-unexp)
(loop state stack #f #f)
(parse-error state laval)))
((eq? 'reduce (car stx)) ; reduce
(let* ((gx (cdr stx))
(gl (vector-ref len-v gx))
($$ (apply (vector-ref xct-v gx) stack)))
(loop (list-tail state gl)
(list-tail stack gl)
(cons (vector-ref rto-v gx) $$)
lval)))
((eq? 'shift (car stx)) ; shift
(loop (cons (cdr stx) state) (cons sval stack)
#f (if nval lval #f)))
(else ; accept
(car stack))))))))))
(define* (make-lalr-parser/num mach #:key (skip-if-unexp '()) interactive)
(let* ((len-v (assq-ref mach 'len-v))
(rto-v (assq-ref mach 'rto-v))
(pat-v (assq-ref mach 'pat-v))
(xct-v (make-xct (assq-ref mach 'act-v)))
(ntab (assq-ref mach 'ntab))
(start (assq-ref (assq-ref mach 'mtab) '$start)))
(lambda* (lexr #:key debug)
(let loop ((state (list 0)) ; state stack
(stack (list '$@)) ; semantic value stack
(nval #f) ; non-terminal from prev reduction
(lval #f)) ; lexical value (from lex'r)
(cond
((and interactive nval
(eqv? (car nval) start)
(zero? (car state))) ; done
(cdr nval))
((not (or nval lval))
(if (eqv? $default (caar (vector-ref pat-v (car state))))
(loop state stack (cons $default #f) lval) ; default reduction
(loop state stack nval (lexr)))) ; reload
(else
(let* ((laval (or nval lval))
(tval (car laval))
(sval (cdr laval))
(stxl (vector-ref pat-v (car state)))
(stx (or (assq-ref stxl tval)
(and (not (memq tval skip-if-unexp))
(assq-ref stxl $default)))))
(if debug (dmsg/n (car state) (if nval tval sval) stx ntab))
(cond
((eq? #f stx) ; error
(if (memq tval skip-if-unexp)
(loop state stack #f #f)
(parse-error state laval)))
((negative? stx) ; reduce
(let* ((gx (abs stx))
(gl (vector-ref len-v gx))
($$ (apply (vector-ref xct-v gx) stack)))
(loop (list-tail state gl)
(list-tail stack gl)
(cons (vector-ref rto-v gx) $$)
lval)))
((positive? stx) ; shift
(loop (cons stx state) (cons sval stack) #f (if nval lval #f)))
(else ; accept
(car stack))))))))))
;; @deffn {Procedure} make-lalr-parser mach [options] => parser
;; Generate a procedure for parsing a language, where @var{mach} is
;; a machine generated by @code{make-lalr-machine}.
;; This generates a procedure that takes one argument, a lexical analyzer:
;; @example
;; (parser lexical-analyzer #:debug #t)
;; @end example
;; @noindent
;; and is used as
;; @example
;; (define xyz-parse (make-lalr-parser xyz-mach))
;; (with-input-from-file "sourcefile.xyz"
;; (lambda () (xyz-parse (gen-lexer))))
;; @end example
;; @noindent
;; The generated parser is reentrant. Options are:
;; @table @code
;; @item #:skip-if-unexp
;; This is a list of tokens to skip if not expected. It is used
;; to allow comments to be skipped. The default is @code{'()}.
;; @item #:interactive
;; If @code{#t}, this tells the parser that this is being called
;; interactively, so that the token @code{$end} is not expected.
;; The default value is @code{#f}.
;; @end table
;; @noindent
;; @end deffn
(define* (make-lalr-parser mach #:key (skip-if-unexp '()) interactive)
"- Procedure: make-lalr-parser mach [options] => parser
Generate a procedure for parsing a language, where MACH is a
machine generated by 'make-lalr-machine'. This generates a
procedure that takes one argument, a lexical analyzer:
(parser lexical-analyzer #:debug #t)
and is used as
(define xyz-parse (make-lalr-parser xyz-mach))
(with-input-from-file \"sourcefile.xyz\"
(lambda () (xyz-parse (gen-lexer))))
The generated parser is reentrant. Options are:
'#:skip-if-unexp'
This is a list of tokens to skip if not expected. It is used
to allow comments to be skipped. The default is ''()'.
'#:interactive'
If '#t', this tells the parser that this is being called
interactively, so that the token '$end' is not expected. The
default value is '#f'."
(let* ((mtab (assq-ref mach 'mtab))
(siu (map (lambda (n) (assoc-ref mtab n)) skip-if-unexp))
(iact interactive))
(if (number? (caar (vector-ref (assq-ref mach 'pat-v) 0)))
;; hashed:
(make-lalr-parser/num mach #:skip-if-unexp siu #:interactive iact)
;; not hashed:
(make-lalr-parser/sym mach #:skip-if-unexp siu #:interactive iact))))
;;; --- last line ---

326
sysa/mes-0.22/module/nyacc/util.scm Normal file
View file

@ -0,0 +1,326 @@
;;; nyacc/util.scm
;; Copyright (C) 2014-2017 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>
;;; Code:
(define-module (nyacc util)
#:export (fixpoint
fmtstr fmtout fmterr fmt
wrap-action
obj->str
prune-assoc
map-attr->vector
x-flip x-comb
write-vec
ugly-print
tzort)
#:use-module ((srfi srfi-43) #:select (vector-fold)))
(cond-expand
(mes)
(guile-2)
(guile
(use-modules (ice-9 optargs))
(use-modules (nyacc compat18)))
(else))
(define (fmtstr fmt . args)
(apply simple-format #f fmt args))
(define (fmtout fmt . args)
(apply simple-format (current-output-port) fmt args))
(define (fmterr fmt . args)
(apply simple-format (current-error-port) fmt args))
(define fmt simple-format)
;; @deffn {Procedure} make-arg-list N => '($N $Nm1 $Nm2 ... $1 . $rest)
;; This is a helper for @code{mkact}.
;; @end deffn
(define (make-arg-list n)
(let ((mkarg
(lambda (i) (string->symbol (string-append "$" (number->string i))))))
(let loop ((r '(. $rest)) (i 1))
(if (> i n) r (loop (cons (mkarg i) r) (1+ i))))))
;; @deffn {Procedure} wrap-action (n . guts) => quoted procedure
;; Wrap user-specified action (body, as a quoted list of expressions) with
;; n arguments to generate a quoted lambda. That is,
;; @example
;; `(lambda ($n ... $2 $1 . $rest) ,@guts)
;; @end example
;; The rationale for the arglist format is that we @code{apply} this
;; lambda to the the semantic stack.
(define (wrap-action actn)
(cons* 'lambda (make-arg-list (car actn)) (cdr actn)))
;; @deffn obj->str object => string
;; Convert terminal (symbol, string, character) to string.
;; This is like @code{write} but will prefix symbols with @code{'}.
(define (obj->str obj)
(cond ((string? obj) (simple-format #f "~S" obj))
((symbol? obj) (string-append "'" (symbol->string obj)))
((char? obj) (simple-format #f "~S" obj))))
;; @deffn prune-assoc al
;; Prune obsolete entries from an a-list. This is order n^2.
(define (prune-assoc al)
(let loop ((al1 '()) (al0 al))
(if (null? al0) al1
(loop (if (assoc (caar al0) al1) al1 (cons (car al0) al1)) (cdr al0)))))
;; @deffn {Procedure} fixpoint proc seed
;; This generates the fixpoint for @var{proc} applied to @var{seed},
;; a list. The procedure @code{proc} takes as arguments an element from
;; the list and the entire list. Updates should be cons'd onto the front
;; of the list.
;;
;; The routine works by setting prev to the empty list and next, curr and
;; item to the seed. The item reference is propagated through the current
;; list until it reaches prev. The calls to proc will update @code{next}.
;; @example
;; next-> +---+
;; | |
;; curr-> +---+
;; | |
;; item-> | |
;; | |
;; prev-> +---+
;; | |
;; +---+
;; @end example
;; @end deffn
(define (fixpoint proc seed)
(let loop ((prev '()) (item seed) (curr seed) (next seed))
(cond
((not (eqv? item prev))
(loop prev (cdr item) curr (proc (car item) next)))
((not (eqv? next curr))
(loop curr next next next))
(else
curr))))
;; @deffn vector-fixpoint proc vec => vec
;; (proc vec) => chg (boolean)
;; Not used yet (in step3).
(define (vector-fixpoint proc vec)
(let loop ((chg #t))
(if chg (proc vec) vec)))
;; @deffn map-attr->vector list-of-alists key => vector
;; map list of attribute lists to vector of attr
;; @example
;; (map-attr->vector '(((a . 1) ...) ((a . 2) ...) ...) => #(1 2 ...)
;; @end example
(define (map-attr->vector al-l key)
(list->vector (map (lambda (al) (assq-ref al key)) al-l)))
;; @deffn flip al => a-list
;; change (a 1 2 3) to ((1 . a) (2 . a) (3 . a))
(define (x-flip al)
(let loop ((result '()) (tail (cdr al)))
(if (null? tail) result
(loop (acons (car tail) (car al) result) (cdr tail)))))
;; @deffn x-comb (a1 a2 a3) (b1 b2 b3) => (a1 b1) (a1 b2) ...
;; The implementation needs work.
(define (x-comb a b)
(let loop ((res '()) (al a) (bl b))
(cond
((null? al) res)
((pair? bl) (loop (acons (car al) (car bl) res) al (cdr bl)))
((pair? al) (loop res (cdr al) b)))))
(define (write-vec port vec)
(let* ((nv (vector-length vec)))
(fmt port " #(")
(let loop ((col 4) (ix 0))
(if (eq? ix nv) #f
(let* ((item (vector-ref vec ix))
(stng (fmt #f "~S " item))
(leng (string-length stng)))
(cond
((> (+ col leng) 78)
(fmt port "\n ~A" stng)
(loop (+ 4 leng) (1+ ix)))
(else
(fmt port "~A" stng)
(loop (+ col leng) (1+ ix)))))))
(fmt port ")")))
;; @deffn {Procedure} ugly-print sexp [port] [options]
;; This will print in compact form which shows no structure. The optional
;; keyword argument @var{#:pre-line-prefix} prints the provided string
;; at the start of each continued line. The default is four spaces.
;; @end deffn
(define* (ugly-print sexp #:optional (port (current-output-port))
#:key (per-line-prefix "") (width 79) trim-ends)
(define plplen (string-length per-line-prefix))
(define obj->str object->string)
;; @deffn {Procedure} strout column string-or-number
;; Nominally takes a column and string, prints the string and returns updated
;; column. If passed a number instead of string guarantee that many chars.
;; @end deffn
(define (strout col str)
(cond
((number? str)
(if (>= (+ col str) width) (strout col "\n") col))
((string=? "\n" str)
(newline port)
(display per-line-prefix port)
(display " " port)
(1+ plplen))
((and (string=? str ")") (= width col))
(display str port)
(1+ col))
((>= (+ col (string-length str)) width)
(cond
((string-every #\space str) (strout col "\n"))
(else (strout (strout col "\n") str))))
(else
(display str port)
(+ col (string-length str)))))
(letrec*
((loop1
(lambda (col sx)
(cond
((pair? sx)
;;(fmterr "[car sx=~S]" (car sx))
(case (car sx)
((quote) (loop2 (strout (strout col 3) "'") (cdr sx)))
((quasiquote) (loop2 (strout (strout col 3) "`") (cdr sx)))
((unquote) (loop2 (strout (strout col 2) ",") (cdr sx)))
((unquote-splicing) (loop2 (strout (strout col 3) ",@") (cdr sx)))
;;(else (strout (loop2 (strout col "(") sx) ")"))))
;; (strout col 8) is kludge to prevent lone `(' at end of line
(else (strout (loop2 (strout (strout col 8) "(") sx) ")"))))
((vector? sx)
(strout
(vector-fold
(lambda (ix col elt)
(loop1 (if (zero? ix) col (strout col " ")) elt))
(strout col "#(") sx) ")"))
;;((null? sx) (strout col "'()"))
((null? sx) (strout col "()"))
(else (strout col (obj->str sx))))))
(loop2
(lambda (col sx)
(cond
((pair? sx)
(if (null? (cdr sx))
(loop2 (loop1 col (car sx)) (cdr sx))
(loop2 (strout (loop1 col (car sx)) " ") (cdr sx))))
((null? sx) col)
(else (strout (strout col ". ") (obj->str sx)))))))
(if (not trim-ends) (strout 0 per-line-prefix))
(loop1 plplen sexp)
(if (not trim-ends) (newline port))
(if #f #f)))
;; stuff
;; @deffn {Procedure} depth-first-search graph => (values ht gv tv xl)
;; The argument @var{gfraph} is a list of verticies and adjacency nodes:
;; @example
;; graph => ((1 2 3 4) (2 6 7) ...)
;; @end example
;; @noindent
;; @table @var
;; @item ht
;; hash of vertex to index
;; @item gv
;; vector of index to vertex
;; @item tv
;; vector of (d . f)
;; @end table
;; ref: Algorithms, p 478
;; @end deffn
(define (depth-first-search graph)
(let* ((n (length graph))
(ht (make-hash-table n)) ; vertex -> index
(gv (make-vector n)) ; index -> vertex
(tv (make-vector n #f)) ; index -> times
(pv (make-vector n #f)) ; index -> predecessor :unused
(xl '()))
(letrec
((next-t (let ((t 0)) (lambda () (set! t (+ 1 t)) t)))
(visit (lambda (k)
(vector-set! tv k (cons (next-t) #f))
(let loop ((l (cdr (vector-ref gv k))))
(if (not (null? l))
(let ((ix (hashq-ref ht (car l))))
(unless (vector-ref tv ix)
(fmtout "set-pv! ~a ~a" ix k)
(vector-set! pv ix k)
(visit ix))
(loop (cdr l)))))
(set! xl (cons k xl))
(set-cdr! (vector-ref tv k) (next-t)))))
;; Set up hash of vertex to index.
(do ((i 0 (+ i 1)) (l graph (cdr l))) ((= i n))
(vector-set! gv i (car l)) ; (vector-ref gv i) = (list-ref graph i)
(hashq-set! ht (caar l) i)) ; (hash-ref ht (list-ref graph i)) = i
;; Run through vertices.
(do ((i 0 (+ 1 i))) ((= i n))
(unless (vector-ref tv i) (visit i)))
(values ht gv tv xl))))
;; @deffn tzort dag
;; Given DAG return order of nodes. The DAG is provided as list of:
;; (<node> <priors>)
;; ref: D.E.Knuth - The Art of C.P., Vol I, Sec 2.2.3
(define (tzort dag)
(let* ((n (length dag))
(ht (make-hash-table n)) ; node -> ix
(nv (make-vector n #f)) ; ix -> (node . adj-list)
(cv (make-vector n 0)) ; ix -> count
(incr (lambda (ix) (vector-set! cv ix (+ (vector-ref cv ix) 1))))
(decr (lambda (ix) (vector-set! cv ix (- (vector-ref cv ix) 1)))))
;; Set up ht and nv.
(do ((i 0 (+ i 1)) (l dag (cdr l))) ((= n i))
(vector-set! nv i (car l))
(hashq-set! ht (caar l) i))
;; set up cv
(do ((i 0 (+ i 1))) ((= n i))
(for-each (lambda (n) (incr (hashq-ref ht n)))
(cdr (vector-ref nv i))))
;; Iterate through nodes until cv all zero.
(let loop1 ((ol '()) (uh '()) ; ordered list, unordered head
(ut (let r ((l '()) (x 0)) ; unordered tail
(if (= x n) l (r (cons x l) (+ x 1))))))
(cond
((null? ut)
(if (null? uh)
(reverse (map (lambda (e) (car (vector-ref nv e))) ol))
(loop1 ol '() uh)))
(else
(let* ((ix (car ut)))
(if (zero? (vector-ref cv ix))
(loop1
(let loop2 ((l (cdr (vector-ref nv ix))))
(if (null? l) (cons ix ol)
(begin
(decr (hashq-ref ht (car l)))
(loop2 (cdr l)))))
uh
(cdr ut))
(loop1 ol (cons ix uh) (cdr ut)))))))))
;;; --- last line ---

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

@ -0,0 +1,25 @@
;;; nyacc/version.scm
;; Copyright (C) 2017-2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>
;;; Code:
(define-module (nyacc version)
#:export (*nyacc-version*))
(define *nyacc-version* "0.99.3")
;; --- last line ---