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

Add mes and mescc-tools-extra

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

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

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

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 ---