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

nyacc: lots of fixes to make CPP more robust; now need to test

Browse source
This commit is contained in:
Matt Wette 2017-01-07 16:06:09 -08:00 committed by Jan Nieuwenhuizen
parent baea80d962
commit 0b46949f48
20 changed files with 1832 additions and 1842 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
module/nyacc/ChangeLog
View file

@ -1,3 +1,26 @@
2017-01-07 Matt Wette <mwette@alumni.caltech.edu>
* lang/c99/body.scm (read-cpp-line): cpp statement should not
include newline? Changed to unread final newline.
* 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
* lang/c99/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>
* lang/c99/parser.scm: default parser #:mode is now 'code; done
since the CPP should now be working (??)
* lalr.scm (process-spec): in add-el changed memq to member since
we are using strings for terminals
2017-01-02 Matt Wette <mwette@alumni.caltech.edu> 2017-01-02 Matt Wette <mwette@alumni.caltech.edu>
* lang/c99/mach.scm (c99-spec): added hooks (cpp-ok!, no-cpp!) to * lang/c99/mach.scm (c99-spec): added hooks (cpp-ok!, no-cpp!) to

8
module/nyacc/lalr.scm
View file

@ -373,7 +373,7 @@
(let* ((gram (assq-ref tree 'grammar)) (let* ((gram (assq-ref tree 'grammar))
(start-symbol (and=> (assq-ref tree 'start) atomize)) (start-symbol (and=> (assq-ref tree 'start) atomize))
(start-rule (lambda () (list start-symbol))) (start-rule (lambda () (list start-symbol)))
(add-el (lambda (e l) (if (memq e l) l (cons e l)))) (add-el (lambda (e l) (if (member e l) l (cons e l))))
(pna (prec-n-assc tree))) (pna (prec-n-assc tree)))
;; We sweep through the grammar to generate a canonical specification. ;; We sweep through the grammar to generate a canonical specification.
;; Note: the local rhs is used to hold RHS terms, but a ;; Note: the local rhs is used to hold RHS terms, but a
@ -461,10 +461,8 @@
(else '($1))))) (else '($1)))))
(if with (simple-format #t "WITH WHAT?\n")) (if with (simple-format #t "WITH WHAT?\n"))
(iter (cons lhs ll) (iter (cons lhs ll)
(cons (cons (cons* (cons 'rhs (list->vector (reverse pel)))
(cons* (cons 'rhs (list->vector (reverse pel))) (cons* 'act nrg act) (cons 'ref ref) attr) @l)
(cons* 'act nrg act) (cons 'ref ref) attr)
@l)
tl nl head prox lhs tail rhs-l attr pel #f))) tl nl head prox lhs tail rhs-l attr pel #f)))
((pair? rhs-l) ((pair? rhs-l)

326
module/nyacc/lang/c99/body.scm
View file

@ -1,6 +1,6 @@
;;; lang/c99/body.scm ;;; lang/c99/body.scm
;;; ;;;
;;; Copyright (C) 2015 Matthew R. Wette ;;; Copyright (C) 2015-2017 Matthew R. Wette
;;; ;;;
;;; This program is free software: you can redistribute it and/or modify ;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by ;;; it under the terms of the GNU General Public License as published by
@ -15,13 +15,20 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;; C parser body, with cpp and tables makes a parser ;; @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 the @code{td-dict}. The @code{td-dict} is a dictionary that maps
;; include file names to typedefs (e.g., @code{stdio.h} to @code{FILE}).
;;(use-modules (ice-9 pretty-print)) (use-modules ((srfi srfi-9) #:select (define-record-type)))
(use-modules ((sxml xpath) #:select (sxpath)))
(define std-dict (define c99-std-dict
'( '(("alloca.h")
("alloca.h")
("complex.h" "complex" "imaginary") ("complex.h" "complex" "imaginary")
("ctype.h") ("ctype.h")
("fenv.h" "fenv_t" "fexcept_t") ("fenv.h" "fenv_t" "fexcept_t")
@ -37,7 +44,6 @@
("regex.h" "regex_t" "regmatch_t") ("regex.h" "regex_t" "regmatch_t")
("setjmp.h" "jmp_buf") ("setjmp.h" "jmp_buf")
("signal.h" "sig_atomic_t") ("signal.h" "sig_atomic_t")
("string.h" "size_t")
("stdarg.h" "va_list") ("stdarg.h" "va_list")
("stddef.h" "ptrdiff_t" "size_t" "wchar_t") ("stddef.h" "ptrdiff_t" "size_t" "wchar_t")
("stdint.h" ("stdint.h"
@ -47,12 +53,59 @@
"int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t") "int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t")
("stdio.h" "FILE" "size_t") ("stdio.h" "FILE" "size_t")
("stdlib.h" "div_t" "ldiv_t" "lldiv_t" "wchar_t") ("stdlib.h" "div_t" "ldiv_t" "lldiv_t" "wchar_t")
("string.h" "size_t")
("time.h" "time_t" "clock_t" "size_t") ("time.h" "time_t" "clock_t" "size_t")
("unistd.h" "size_t" "ssize_t" "div_t" "ldiv_t") ("unistd.h" "size_t" "ssize_t" "div_t" "ldiv_t")
("wchar.h" "wchar_t" "wint_t" "mbstate_t" "size_t") ("wchar.h" "wchar_t" "wint_t" "mbstate_t" "size_t")
("wctype.h" "wctrans_t" "wctype_t" "wint_t") ("wctype.h" "wctrans_t" "wctype_t" "wint_t")
)) ))
;; @subsubsection CPP if-then-else Logic Block (ITLB) Processing
;; The parser needs to have a "CPI" (CPP processing info) stack to deal with
;; types (re)defined in multiple branches of a #if...#endif statement chain.
;; If we are in "code" mode then we may be skipping code so need to track
;; when to shift and when not to.
;;
;; The state is contained in a stack @code{ppxs}
;; States are
;; @table code
;; @item skip-done
;; skip code
;; @item skip-look
;; skipping code, but still looking for true at this level
;; @item keep
;; keep code
;; @item skip1-pop
;; skip one token and pop skip-stack
;; @end table
;; Also, if we want to pass on all the sections of an ITLB to the parser
;; we need to remove typedef names because a typedef may appear multiple
;; times, as in
;; @example
;; #ifdef SIXTYFOURBIT
;; typedef short int32_t;
;; #else
;; typedef long int32_t;
;; #endif
;; @end example
;; @noindent
;; To achieve this we keep a stack of valid typedefs. On @code{#if} we push,
;; on @code{#elif} we shift (i.e., pop, then push) and on @code{#endif} we pop.
;;
;; The grammar looks like
;; @example
;; (code
;; ("if" cond code "endif")
;; ("if" cond code "else" code "endif")
;; ("if" cond code elif-list "endif")
;; ("if" cond code elif-list "else" code "endif")
;; (other))
;; (elif-list
;; ("elif" cond code)
;; (elif-list "elif" cond code))
;; @end example
;; @noindent
(define-record-type cpi (define-record-type cpi
(make-cpi-1) (make-cpi-1)
cpi? cpi?
@ -62,24 +115,18 @@
(tn-dict cpi-tynd set-cpi-tynd!) ; typename dict (("<x>" foo_t .. (tn-dict cpi-tynd set-cpi-tynd!) ; typename dict (("<x>" foo_t ..
(ptl cpi-ptl set-cpi-ptl!) ; parent typename list (ptl cpi-ptl set-cpi-ptl!) ; parent typename list
(ctl cpi-ctl set-cpi-ctl!) ; current typename list (ctl cpi-ctl set-cpi-ctl!) ; current typename list
(cppok cpi-cppok set-cpi-cppok!) ; OK to pass CPP stmts to parser
) )
(define (make-cpi debug defines incdirs tn-dict) (define (make-cpi debug defines incdirs tn-dict)
(let* ((cpi (make-cpi-1))) (let* ((cpi (make-cpi-1)))
(set-cpi-debug! cpi debug) (set-cpi-debug! cpi debug) ; print states debug
(set-cpi-defs! cpi defines) (set-cpi-defs! cpi defines) ; list of define strings??
(set-cpi-incs! cpi incdirs) (set-cpi-incs! cpi incdirs) ; list of include dir's
(set-cpi-tynd! cpi (append tn-dict std-dict)) (set-cpi-tynd! cpi tn-dict) ; typename dict by include-file name
(set-cpi-ptl! cpi '()) ; list of lists of typedef strings (set-cpi-ptl! cpi '()) ; list of lists of typedef strings
(set-cpi-ctl! cpi '()) ; list of typedef strings (set-cpi-ctl! cpi '()) ; list of typedef strings
(set-cpi-cppok! cpi #f) ; don't assume OK to pass CPP stmts
cpi)) cpi))
;; Need to have a "CPI" stack to deal with types (re)defined in multiple
;; branches of a #if...#endif statement. If we are in "code" mode then we
;; may be skipping code so need to track when to shift and when not to.
(define *info* (make-fluid #f)) (define *info* (make-fluid #f))
;; given tyns ;; given tyns
@ -91,10 +138,7 @@
;; Called by lexer to determine if symbol is a typename. ;; Called by lexer to determine if symbol is a typename.
;; Check current sibling for each generation. ;; Check current sibling for each generation.
(define (typename? name) (define (typename? name)
;;(simple-format #t "typename? ~S\n" name)
(let ((cpi (fluid-ref *info*))) (let ((cpi (fluid-ref *info*)))
(when #f ;;(string=? name "SpiceInt")
(simple-format #t "tn? ~S ~S\n" (cpi-ctl cpi) (cpi-ptl cpi)))
(if (member name (cpi-ctl cpi)) #t (if (member name (cpi-ctl cpi)) #t
(let iter ((ptl (cpi-ptl cpi))) (let iter ((ptl (cpi-ptl cpi)))
(if (null? ptl) #f (if (null? ptl) #f
@ -104,51 +148,21 @@
;; @deffn add-typename name ;; @deffn add-typename name
;; Helper for @code{save-typenames}. ;; Helper for @code{save-typenames}.
(define (add-typename name) (define (add-typename name)
;;(simple-format #t "add-typename ~S\n" name)
(let ((cpi (fluid-ref *info*))) (let ((cpi (fluid-ref *info*)))
(set-cpi-ctl! cpi (cons name (cpi-ctl cpi))) (set-cpi-ctl! cpi (cons name (cpi-ctl cpi)))))
;;(simple-format #t "at: ~S ~S\n" (cpi-ctl cpi) (cpi-ptl cpi))
))
(define (cpi-push) ;; on #if (define (cpi-push) ;; on #if
(let ((cpi (fluid-ref *info*))) (let ((cpi (fluid-ref *info*)))
(set-cpi-ptl! cpi (cons (cpi-ctl cpi) (cpi-ptl cpi))) (set-cpi-ptl! cpi (cons (cpi-ctl cpi) (cpi-ptl cpi)))
(set-cpi-ctl! cpi '()) (set-cpi-ctl! cpi '())))
(simple-format #t "pu: ~S\n" (cpi-ctl cpi))
))
(define (cpi-shift) ;; on #elif #else (define (cpi-shift) ;; on #elif #else
(simple-format #t "sh\n")
(set-cpi-ctl! (fluid-ref *info*) '())) (set-cpi-ctl! (fluid-ref *info*) '()))
(define (cpi-pop) ;; on #endif (define (cpi-pop) ;; on #endif
(let ((cpi (fluid-ref *info*))) (let ((cpi (fluid-ref *info*)))
(simple-format #t "po<: ~S ~S\n" (cpi-ctl cpi) (cpi-ptl cpi))
(set-cpi-ctl! cpi (append (cpi-ctl cpi) (car (cpi-ptl cpi)))) (set-cpi-ctl! cpi (append (cpi-ctl cpi) (car (cpi-ptl cpi))))
(set-cpi-ptl! cpi (cdr (cpi-ptl cpi))) (set-cpi-ptl! cpi (cdr (cpi-ptl cpi)))))
(simple-format #t "po>: ~S ~S\n" (cpi-ctl cpi) (cpi-ptl cpi))
))
;; The following three routines are used to allow pass cpp-statements to the
;; parser. See how include is handled in the lexer.
(define (cpp-ok!) ;; declare OK to pass cpp-stmt to parser
(simple-format #t "cpp-ok! ~S\n" (port-line (current-input-port)))
(let ((info (fluid-ref *info*)))
(set-cpi-cppok! info #t)))
(define (no-cpp!) ;; declare not OK to pass cpp-stmt to parser
(simple-format #t "no-cpp! ~S\n" (port-line (current-input-port)))
(let ((info (fluid-ref *info*)))
(set-cpi-cppok! info #f)))
(define (cpp-ok?) ;; predicate called by lexer
;;(simple-format #t "cpp-ok? ~S\n" (port-line (current-input-port)))
(cpi-cppok (fluid-ref *info*)))
(define (no-cpp?) ;; predicate called by lexer
;;(simple-format #t "no-cpp? ~S\n" (port-line (current-input-port)))
(not (cpi-cppok (fluid-ref *info*))))
;; @deffn find-new-typenames decl ;; @deffn find-new-typenames decl
;; Helper for @code{save-typenames}. ;; Helper for @code{save-typenames}.
@ -187,6 +201,9 @@
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
(define (p-err . args)
(apply throw 'c99-error args))
;; @deffn read-cpp-line ch => #f | (cpp-xxxx)?? ;; @deffn read-cpp-line ch => #f | (cpp-xxxx)??
;; Given if ch is #\# read a cpp-statement ;; Given if ch is #\# read a cpp-statement
;; includes BUG: #define ABC 123 /* \n ;; includes BUG: #define ABC 123 /* \n
@ -194,7 +211,7 @@
(if (not (eq? ch #\#)) #f (if (not (eq? ch #\#)) #f
(let iter ((cl '()) (ch (read-char))) (let iter ((cl '()) (ch (read-char)))
(cond (cond
((eq? ch #\newline) (list->string (reverse cl))) ((eq? ch #\newline) (unread-char ch) (list->string (reverse cl)))
((eq? ch #\\) ((eq? ch #\\)
(let ((c2 (read-char))) (let ((c2 (read-char)))
(if (eq? c2 #\newline) (if (eq? c2 #\newline)
@ -225,65 +242,22 @@
(let ((p (string-append (car dirl) "/" file))) (let ((p (string-append (car dirl) "/" file)))
(if (access? p R_OK) p (iter (cdr dirl))))))) (if (access? p R_OK) p (iter (cdr dirl)))))))
;; @subsubsection CPP if-then-else Logic Block (ITLB) Processing
;; The state is contained in a stack @code{ppxs}
;; States are
;; @table code
;; @item skip-done
;; skip code
;; @item skip-look
;; skipping code, but still looking for true at this level
;; @item keep
;; keep code
;; @item skip1-pop
;; skip one token and pop skip-stack
;; @end table
;; Also, if we want to pass on all the sections of an ITLB to the parser
;; we need to remove typedef names because a typedef may appear multiple
;; times, as in
;; @example
;; #ifdef SIXTYFOURBIT
;; typedef short int32_t;
;; #else
;; typedef long int32_t;
;; #endif
;; @end example
;; @noindent
;; To achieve this we keep a stack of valid typedefs. On @code{#if} we push,
;; on @code{#elif} we shift (i.e., pop, then push) and on @code{#endif} we pop.
;; @example
;; (code
;; ("if" cond code "endif")
;; ("if" cond code "else" code "endif")
;; ("if" cond code elif-list "endif")
;; ("if" cond code elif-list "else" code "endif")
;; (other))
;; (elif-list
;; ("elif" cond code)
;; (elif-list "elif" cond code))
;; @end example
;; @noindent
;; For each level of "if" we track the state.
;; NOTE: if file mode we usually keep #ifdefs. The lone exception is
;; @code{#if 0}
;; @deffn gen-c-lexer [#:mode mode] => thunk
;; Generate a context-sensitive lexer for the C language.
;; The key-arg @var{mode} can be @code{'code} or @code{'file}. If @code{'code}
;; @enumerate
;; @item
;; CPP defines are expanded (future work)
;; @item
;; CPP if/def is executed
;; @end enumerate
(define (def-xdef? name mode) (define (def-xdef? name mode)
(eqv? mode 'code)) (eqv? mode 'code))
;; @deffn gen-c-lexer [#:mode mode] [#:xdef? proc] => thunk ;; @deffn gen-c-lexer [#:mode mode] [#:xdef? proc] => procedure
;; Generate a context-sensitive lexer for the C99 language. 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
(define gen-c-lexer (define gen-c-lexer
;; This gets ugly in order to handle cpp. ;; This gets ugly in order to handle cpp.
;;.need to add support for num's w/ letters like @code{14L} and @code{1.3f}. ;;.need to add support for num's w/ letters like @code{14L} and @code{1.3f}.
@ -313,18 +287,16 @@
(xp2 (sxpath '(decl)))) (xp2 (sxpath '(decl))))
;; mode: 'code|'file ;; mode: 'code|'file
;; xdef?: (proc name mode) => #t|#f : do we expand #define? ;; xdef?: (proc name mode) => #t|#f : do we expand #define?
;; ppev?: (proc ???) => #t|#f : do we eval-and-honor #if/#else ?
(lambda* (#:key (mode 'code) (xdef? #f)) (lambda* (#:key (mode 'code) (xdef? #f))
(let ((bol #t) ; begin-of-line condition (let ((bol #t) ; begin-of-line condition
(ppxs (list 'keep)) ; CPP execution state stack (ppxs (list 'keep)) ; CPP execution state stack
(info (fluid-ref *info*)) ; assume make and run in same thread (info (fluid-ref *info*)) ; assume make and run in same thread
(pstk '()) ; port stack
(x-def? (or xdef? def-xdef?))) (x-def? (or xdef? def-xdef?)))
;; Return the first (tval . lval) pair not excluded by the CPP. ;; Return the first (tval . lval) pair not excluded by the CPP.
(lambda () (lambda ()
(define (eval-flow?) (define (exec-cpp-stmts?) ; exec (vs pass to parser) CPP stmts?
(or (no-cpp?) (eqv? mode 'code))) (eqv? mode 'code))
(define (add-define tree) (define (add-define tree)
(let* ((tail (cdr tree)) (let* ((tail (cdr tree))
@ -337,10 +309,25 @@
(define (rem-define name) (define (rem-define name)
(set-cpi-defs! info (delete name (cpi-defs info)))) (set-cpi-defs! info (delete name (cpi-defs info))))
(define (exec-cpp line) ;; Evaluate expression text in #if of #elif statement.
(simple-format #t "exec-cpp: (cpp-ok=~S) ~S\n" (cpp-ok?) line) (define (eval-cpp-cond-text text)
;; Parse the line into a CPP stmt, execute it, and return it. (with-throw-handler
(let* ((stmt (read-cpp-stmt line))) 'cpp-error
(lambda ()
(let* ((defs (cpi-defs info))
;;(x (simple-format #t "eval-cpp-cond-text: ~S\n" text))
(rhs (cpp-expand-text text defs))
;;(x (simple-format #t " rhs=>~S\n" rhs))
(exp (parse-cpp-expr rhs))
;;(x (simple-format #t " exp=>~S\n" exp))
)
(if (not exp) (throw 'c99-error "CPP parse failed"))
(eval-cpp-expr exp defs)))
(lambda (key fmt . args)
(report-error fmt args)
(throw 'c99-error "CPP error"))))
(define (eval-cpp-stmt stmt)
(case (car stmt) (case (car stmt)
((include) ((include)
(let* ((parg (cadr stmt)) (leng (string-length parg)) (let* ((parg (cadr stmt)) (leng (string-length parg))
@ -349,79 +336,75 @@
(tynd (assoc-ref (cpi-tynd info) file))) (tynd (assoc-ref (cpi-tynd info) file)))
(cond (cond
(tynd (for-each add-typename tynd)) ; in dot-h dict (tynd (for-each add-typename tynd)) ; in dot-h dict
((or (no-cpp?) (eqv? mode 'code)) ; include flat ((not path) (p-err "not found: ~S" file))
(if (not path) (throw 'parse-error "not found: ~S" file)) ((exec-cpp-stmts?) (push-input (open-input-file path)))
(push-input (open-input-file path))
(set! stmt #f))
(else ; include as tree (else ; include as tree
(if (not path) (throw 'parse-error "not found: ~A" path))
(let* ((tree (with-input-from-file path run-parse))) (let* ((tree (with-input-from-file path run-parse)))
(if (not tree) (throw 'parse-error "~A" path)) (if (not tree) (p-err "included from ~S" path))
(for-each add-define (xp1 tree)) ; add def's (for-each add-define (xp1 tree)) ; add def's
;; Attach tree onto "include" statement. (set! stmt (append stmt (list tree)))))))
(if (pair? tree) (if (exec-cpp-stmts?) (set! ppxs (cons 'skip1-pop ppxs))))
(set! stmt (append stmt (list tree)))
stmt))))))
((define) ((define)
(add-define stmt)) (add-define stmt)
(if (exec-cpp-stmts?) (set! ppxs (cons 'skip1-pop ppxs))))
((undef) ((undef)
(rem-define (cadr stmt))) (rem-define (cadr stmt))
((if) ;; and ifdef, ifndef (if (exec-cpp-stmts?) (set! ppxs (cons 'skip1-pop ppxs))))
(cpi-push) ((if) ;; covers (if ifdef ifndef)
(if (eval-flow?)
(let* ((defs (cpi-defs info))
(rhs (cpp-expand-text (cadr stmt) defs))
(exp (parse-cpp-expr rhs))
(val (eval-cpp-expr exp defs)))
(cond (cond
((not val) ((exec-cpp-stmts?)
(throw 'parse-error "unresolved: ~S" (cadr stmt))) (let ((val (eval-cpp-cond-text (cadr stmt))))
((zero? val) (cond
(set! ppxs (cons* 'skip1-pop 'skip-look ppxs))) ((not val) (p-err "unresolved: ~S" (cadr stmt)))
(else ((zero? val) (set! ppxs (cons* 'skip1-pop 'skip-look ppxs)))
(set! ppxs (cons* 'skip1-pop (car ppxs) ppxs))))))) (else (set! ppxs (cons* 'skip1-pop (car ppxs) ppxs))))))
(else (cpi-push))))
((elif) ((elif)
(if (eval-flow?) (cond
(let* ((defs (cpi-defs info)) ((exec-cpp-stmts?)
(rhs (cpp-expand-text (cadr stmt) defs)) (let ((val (eval-cpp-cond-text (cadr stmt))))
(exp (parse-cpp-expr rhs))
(val (eval-cpp-expr exp defs)))
(cond (cond
((not val) ((not val)
(throw 'parse-error "unresolved: ~S" (cadr stmt))) (p-err "unresolved: ~S" (cadr stmt)))
((eq? 'keep (car ppxs)) ((eq? 'keep (car ppxs))
(set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs)))) (set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs))))
((zero? val) ((zero? val) (set! ppxs (cons* 'skip1-pop ppxs)))
(set! ppxs (cons* 'skip1-pop ppxs)))
((eq? 'skip-look (car ppxs)) ((eq? 'skip-look (car ppxs))
(cpi-shift)
(set! ppxs (cons* 'skip1-pop 'keep (cdr ppxs)))) (set! ppxs (cons* 'skip1-pop 'keep (cdr ppxs))))
(else (else
(cpi-shift) (set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs)))))))
(set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs)))))) (else (cpi-shift))))
(cpi-shift)))
((else) ((else)
(if (eval-flow?) (cond
((exec-cpp-stmts?)
(cond (cond
((eq? 'skip-look (car ppxs)) ((eq? 'skip-look (car ppxs))
(cpi-shift)
(set! ppxs (cons* 'skip1-pop 'keep (cdr ppxs)))) (set! ppxs (cons* 'skip1-pop 'keep (cdr ppxs))))
(else (else
(set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs))))) (set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs))))))
(cpi-shift))) (else (cpi-shift))))
((endif) ((endif)
(cpi-pop) (cond
(if (eval-flow?) ((exec-cpp-stmts?)
(set! ppxs (cons 'skip1-pop (cdr ppxs))))) (set! ppxs (cons 'skip1-pop (cdr ppxs))))
(else (cpi-pop))))
((error) ((error)
stmt) stmt)
(else (else
(error "unhandled cpp stmt"))) (error "unhandled cpp stmt")))
(if stmt (cons 'cpp-stmt stmt) '()))) (cons 'cpp-stmt stmt))
;; Composition of @code{read-cpp-line} and @code{exec-cpp}. (define (eval-cpp-line line)
(with-throw-handler
'cpp-error
(lambda () (eval-cpp-stmt (read-cpp-stmt line)))
(lambda (key fmt . rest)
(report-error fmt rest)
(throw 'c99-error "CPP error"))))
;; Composition of @code{read-cpp-line} and @code{eval-cpp-line}.
(define (read-cpp ch) (define (read-cpp ch)
(and=> (read-cpp-line ch) exec-cpp)) (and=> (read-cpp-line ch) eval-cpp-line))
(define (read-token) (define (read-token)
(let iter ((ch (read-char))) (let iter ((ch (read-char)))
@ -434,8 +417,7 @@
(cond (cond
((read-comm ch bol) => assc-$) ((read-comm ch bol) => assc-$)
((read-cpp ch) => ((read-cpp ch) =>
(lambda (res) (lambda (res) ;; if '() stmt expanded so re-read
;; not pair means expand include file, so loop again
(if (pair? res) (assc-$ res) (iter (read-char))))) (if (pair? res) (assc-$ res) (iter (read-char)))))
(else (set! bol #f) (iter ch)))) (else (set! bol #f) (iter ch))))
((read-ident ch) => ((read-ident ch) =>
@ -466,19 +448,15 @@
(else (cons ch (string ch)))))) (else (cons ch (string ch))))))
;; Loop between reading tokens and skipping tokens via CPP logic. ;; Loop between reading tokens and skipping tokens via CPP logic.
(let loop ((pair (read-token))) (let iter ((pair (read-token)))
(simple-format #t "ppxs=~S ~S\n" ppxs
(port-line (current-input-port)))
(case (car ppxs) (case (car ppxs)
((keep) ((keep)
(no-cpp!)
(simple-format #t "token=~S\n" pair)
pair) pair)
((skip-done skip-look) ((skip-done skip-look)
(loop (read-token))) (iter (read-token)))
((skip1-pop) ((skip1-pop)
(set! ppxs (cdr ppxs)) (set! ppxs (cdr ppxs))
(loop (read-token))))) (iter (read-token)))))
))))) )))))
;; --- last line --- ;; --- last line ---

5
module/nyacc/lang/c99/cpp.scm
View file

@ -1,6 +1,6 @@
;;; lang/c/cpp.scm ;;; lang/c/cpp.scm
;;; ;;;
;;; Copyright (C) 2015 Matthew R. Wette ;;; Copyright (C) 2015-2017 Matthew R. Wette
;;; ;;;
;;; This program is free software: you can redistribute it and/or modify ;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by ;;; it under the terms of the GNU General Public License as published by
@ -40,9 +40,6 @@
#| #|
#define #undef #include #if #ifdef #ifndef #else #endif #elif #define #undef #include #if #ifdef #ifndef #else #endif #elif
#line defined #-operator ##-operator #pragma #error #line defined #-operator ##-operator #pragma #error
strategy:
don't expand macro calls -- treat like function calls, but provide dict
todo: todo:
pragma pragma
#-op ##-op #-op ##-op

64
module/nyacc/lang/c99/cppbody.scm
View file

@ -1,6 +1,6 @@
;;; nyacc/lang/c99/cppbody.scm ;;; nyacc/lang/c99/cppbody.scm
;;; ;;;
;;; Copyright (C) 2016 Matthew R. Wette ;;; Copyright (C) 2016-2017 Matthew R. Wette
;;; ;;;
;;; This program is free software: you can redistribute it and/or modify ;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by ;;; it under the terms of the GNU General Public License as published by
@ -15,39 +15,50 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(define gen-cpp-lexer (make-lexer-generator mtab)) (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))))
(define gen-cpp-lexer
(make-lexer-generator mtab #:comm-skipper cpp-comm-skipper))
;; @deffn parse-cpp-expr text => tree ;; @deffn parse-cpp-expr text => tree
;; Given a string returns a cpp parse tree. This is called by ;; Given a string returns a cpp parse tree. This is called by
;; @code{parse-cpp-stmt} and @code{eval-cpp-expr}. The latter because the ;; @code{eval-cpp-expr}. The text will have had all CPP defined symbols
;; parsed expression may include terms which are cpp-defined ;; expanded already so no identifiers should appear in the text.
;; and should be evaluated lazy mode. ;; A @code{cpp-error} will be thrown if a parse error occurs.
(define (parse-cpp-expr text) (define (parse-cpp-expr text)
(catch
'nyacc-error
(lambda ()
(with-input-from-string text (with-input-from-string text
(lambda () (raw-parser (gen-cpp-lexer))))) (lambda () (raw-parser (gen-cpp-lexer)))))
(lambda (key fmt . args)
(apply throw 'cpp-error fmt args))))
;; @deffn eval-cpp-expr tree dict => datum ;; @deffn eval-cpp-expr tree dict => datum
;; Evaluate a tree produced from ;; Evaluate a tree produced from @code{parse-cpp-expr}.
;; This should be updated to use @code{expand-cpp-def}. See below. ;; The tree passed to this routine is
(use-modules (ice-9 pretty-print))
(define (eval-cpp-expr tree dict) (define (eval-cpp-expr tree dict)
;;(display "eval-cpp-expr:\n") (pretty-print tree) ;;(display "eval-cpp-expr:\n") (pretty-print tree)
(letrec (letrec
((tx (lambda (tr ix) (list-ref tr ix))) ((tx (lambda (tr ix) (list-ref tr ix)))
(tx1 (lambda (tr) (tx tr 1))) (tx1 (lambda (tr) (tx tr 1)))
(ev (lambda (ex ix) (eval-expr (list-ref ex ix)))) (ev (lambda (ex ix) (eval-expr (list-ref ex ix))))
(ev1 (lambda (ex) (ev ex 1))) (ev1 (lambda (ex) (ev ex 1))) ; eval expr in arg 1
(ev2 (lambda (ex) (ev ex 2))) (ev2 (lambda (ex) (ev ex 2))) ; eval expr in arg 2
(ev3 (lambda (ex) (ev ex 3))) (ev3 (lambda (ex) (ev ex 3))) ; eval expr in arg 3
#;(parse-and-eval
(lambda (str)
(if (not (string? str)) (throw 'parse-error "cpp-eval"))
(let ((idtr (parse-cpp-expr str)))
(eval-cpp-expr idtr dict))))
(eval-expr (eval-expr
(lambda (tree) (lambda (tree)
(case (car tree) (case (car tree)
;;((ident) (parse-and-eval (assoc-ref dict (tx1 tree))))
((fixed) (string->number (tx1 tree))) ((fixed) (string->number (tx1 tree)))
((char) (char->integer (tx1 tree))) ((char) (char->integer (tx1 tree)))
((defined) (if (assoc-ref dict (tx1 tree)) 1 0)) ((defined) (if (assoc-ref dict (tx1 tree)) 1 0))
@ -77,8 +88,9 @@
((or) (if (and (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1)) ((or) (if (and (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1))
((and) (if (or (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))) ((cond-expr) (if (zero? (ev1 tree)) (ev3 tree) (ev2 tree)))
((ident) (error "text should not have identifiers"))
(else (error "incomplete implementation")))))) (else (error "incomplete implementation"))))))
(catch 'parse-error (catch 'cpp-error
(lambda () (eval-expr tree)) (lambda () (eval-expr tree))
(lambda () #f)))) (lambda () #f))))
@ -102,7 +114,7 @@
;; E.g., scanned "defined", now scan "(FOO)", and return "defined(FOO)". ;; E.g., scanned "defined", now scan "(FOO)", and return "defined(FOO)".
(define (scan-defined) (define (scan-defined)
(let iter ((chl '()) (ch (read-char))) (let iter ((chl '()) (ch (read-char)))
(cond ((eof-object? ch) (throw 'parse-error "bad CPP defined")) (cond ((eof-object? ch) (cpp-err "bad CPP defined"))
((char=? #\) ch) ((char=? #\) ch)
(string-append "defined" (list->string (reverse (cons ch chl))))) (string-append "defined" (list->string (reverse (cons ch chl)))))
(else (iter (cons ch chl) (read-char)))))) (else (iter (cons ch chl) (read-char))))))
@ -113,7 +125,6 @@
(nxt #f) ; next string (nxt #f) ; next string
(lvl 0) ; level (lvl 0) ; level
(ch (read-char))) ; next character (ch (read-char))) ; next character
;;(simple-format #t "iter stl=~S chl=~S nxt=~S ch=~S\n" stl chl nxt ch)
(cond (cond
;; have item to add, but first add in char's ;; have item to add, but first add in char's
(nxt (iter (cons nxt (add-chl chl stl)) '() #f lvl ch)) (nxt (iter (cons nxt (add-chl chl stl)) '() #f lvl ch))
@ -136,7 +147,6 @@
(lambda (st) (iter stl chl st lvl (read-char)))) (lambda (st) (iter stl chl st lvl (read-char))))
((read-c-ident ch) => ((read-c-ident ch) =>
(lambda (iden) (lambda (iden)
;;(simple-format #t " iden=~S\n" iden)
(if (equal? iden "defined") (if (equal? iden "defined")
;; "defined" is a special case ;; "defined" is a special case
(iter stl chl (scan-defined) lvl (read-char)) (iter stl chl (scan-defined) lvl (read-char))
@ -162,25 +172,18 @@
(iter stl (cons ch chl) #f lvl (read-char)))))) (iter stl (cons ch chl) #f lvl (read-char))))))
(define (collect-args argd dict used) (define (collect-args argd dict used)
;;(simple-format #t "collect-args\n") (if (not (eqv? (skip-ws (read-char)) #\()) (cpp-err "CPP expecting `('"))
(if (not (eqv? (skip-ws (read-char)) #\())
(let ((fn (or (port-filename (current-input-port)) "(unknown)"))
(ln (1+ (port-line (current-input-port)))))
(throw 'parse-error "~A:~A: CPP expecting `('" fn ln)))
(let iter ((argl (list (scan-cpp-input argd dict used #t)))) (let iter ((argl (list (scan-cpp-input argd dict used #t))))
;;(simple-format #t "args: ~S\n" argl)
(let ((ch (read-char))) (let ((ch (read-char)))
(if (eqv? ch #\)) (reverse argl) (if (eqv? ch #\)) (reverse argl)
(iter (cons (scan-cpp-input argd dict used #t) argl)))))) (iter (cons (scan-cpp-input argd dict used #t) argl))))))
(define (expand-cpp-repl repl argd dict used) (define (expand-cpp-repl repl argd dict used)
;;(simple-format #t "expand-cpp-repl repl=~S argd=~S\n" repl argd)
(with-input-from-string repl (with-input-from-string repl
(lambda () (scan-cpp-input argd dict used #f)))) (lambda () (scan-cpp-input argd dict used #f))))
;; @deffn cpp-expand-text text dict => string ;; @deffn cpp-expand-text text dict => string
(define (cpp-expand-text text dict) (define (cpp-expand-text text dict)
;;(simple-format #t "cpp-expand-text: ~S\n" text)
(with-input-from-string text (with-input-from-string text
(lambda () (scan-cpp-input '() dict '() #f)))) (lambda () (scan-cpp-input '() dict '() #f))))
@ -191,7 +194,6 @@
;; to a macro with arguments, then the arguments will be read from the ;; to a macro with arguments, then the arguments will be read from the
;; current input. ;; current input.
(define (expand-cpp-mref ident dict . rest) (define (expand-cpp-mref ident dict . rest)
(let ((used (if (pair? rest) (car rest) '())) (let ((used (if (pair? rest) (car rest) '()))
(rval (assoc-ref dict ident))) (rval (assoc-ref dict ident)))
(cond (cond
@ -199,14 +201,12 @@
((member ident used) ident) ((member ident used) ident)
((string? rval) ((string? rval)
(let ((expd (expand-cpp-repl rval '() dict (cons ident used)))) (let ((expd (expand-cpp-repl rval '() dict (cons ident used))))
;;(simple-format #t "expand ~S => ~S\n" ident expd)
expd)) expd))
((pair? rval) ((pair? rval)
(let* ((args (car rval)) (repl (cdr rval)) (let* ((args (car rval)) (repl (cdr rval))
(argv (collect-args '() dict '())) (argv (collect-args '() dict '()))
(argd (map cons args argv)) (argd (map cons args argv))
(expd (expand-cpp-repl repl argd dict (cons ident used)))) (expd (expand-cpp-repl repl argd dict (cons ident used))))
;;(simple-format #t "expand ~S => ~S\n" ident expd)
expd))))) expd)))))
;;; --- last line --- ;;; --- last line ---

7
module/nyacc/lang/c99/cppmach.scm
View file

@ -32,7 +32,8 @@
(define cpp-spec (define cpp-spec
(lalr-spec (lalr-spec
(notice lang-crn-lic) (notice (string-append "Copyright (C) 2016,2017 Matthew R. Wette"
lang-crn-lic))
(expect 0) (expect 0)
(start conditional-expression) (start conditional-expression)
(grammar (grammar
@ -135,8 +136,6 @@
(b (move-if-changed (xtra-dir "cpptab.scm.new") (b (move-if-changed (xtra-dir "cpptab.scm.new")
(xtra-dir "cpptab.scm")))) (xtra-dir "cpptab.scm"))))
(when (or a b) (when (or a b)
(system (string-append "touch " (lang-dir "cpp.scm"))) (system (string-append "touch " (lang-dir "cpp.scm"))))))
#;(compile-file (lang-dir "cpp.scm"))
)))
;; --- last line --- ;; --- last line ---

56
module/nyacc/lang/c99/mach.d/c99act.scm
View file

@ -1,6 +1,6 @@
;; ./mach.d/c99act.scm ;; ./mach.d/c99act.scm
;; Copyright 2016,2017 Matthew R. Wette ;; Copyright (C) 2016,2017 Matthew R. Wette
;; ;;
;; This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3, ;; This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3,
;; or any later version published by the Free Software Foundation. See ;; or any later version published by the Free Software Foundation. See
@ -8,10 +8,8 @@
(define act-v (define act-v
(vector (vector
;; $start => translation-unit-proxy ;; $start => translation-unit
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; translation-unit-proxy => translation-unit
(lambda ($1 . $rest) (tl->list $1))
;; primary-expression => identifier ;; primary-expression => identifier
(lambda ($1 . $rest) `(p-expr ,$1)) (lambda ($1 . $rest) `(p-expr ,$1))
;; primary-expression => constant ;; primary-expression => constant
@ -622,23 +620,19 @@
(lambda ($3 $2 $1 . $rest) (list 'array-dsgr $2)) (lambda ($3 $2 $1 . $rest) (list 'array-dsgr $2))
;; designator => "." identifier ;; designator => "." identifier
(lambda ($2 $1 . $rest) (list 'sel-dsgr $2)) (lambda ($2 $1 . $rest) (list 'sel-dsgr $2))
;; statement => $P2 statement-1 ;; statement => labeled-statement
(lambda ($2 $1 . $rest) $2)
;; $P2 =>
(lambda $rest (cpp-ok!))
;; statement-1 => labeled-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => compound-statement ;; statement => compound-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => expression-statement ;; statement => expression-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => selection-statement ;; statement => selection-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => iteration-statement ;; statement => iteration-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => jump-statement ;; statement => jump-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => cpp-statement ;; statement => cpp-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; labeled-statement => identifier ":" statement ;; labeled-statement => identifier ":" statement
(lambda ($3 $2 $1 . $rest) (lambda ($3 $2 $1 . $rest)
@ -694,7 +688,7 @@
;; opt-expression => expression ;; opt-expression => expression
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; jump-statement => "goto" identifier ";" ;; jump-statement => "goto" identifier ";"
(lambda ($3 $2 $1 . $rest) `(goto $2)) (lambda ($3 $2 $1 . $rest) `(goto ,$2))
;; jump-statement => "continue" ";" ;; jump-statement => "continue" ";"
(lambda ($2 $1 . $rest) '(continue)) (lambda ($2 $1 . $rest) '(continue))
;; jump-statement => "break" ";" ;; jump-statement => "break" ";"
@ -703,32 +697,30 @@
(lambda ($3 $2 $1 . $rest) `(return ,$2)) (lambda ($3 $2 $1 . $rest) `(return ,$2))
;; jump-statement => "return" ";" ;; jump-statement => "return" ";"
(lambda ($2 $1 . $rest) `(return (expr))) (lambda ($2 $1 . $rest) `(return (expr)))
;; translation-unit => external-declaration ;; translation-unit => external-declaration-list
(lambda ($1 . $rest) (tl->list $1))
;; external-declaration-list => external-declaration
(lambda ($1 . $rest) (make-tl 'trans-unit $1)) (lambda ($1 . $rest) (make-tl 'trans-unit $1))
;; translation-unit => translation-unit external-declaration ;; external-declaration-list => external-declaration-list external-decla...
(lambda ($2 $1 . $rest) (lambda ($2 $1 . $rest)
(if (eqv? (sx-tag $2) 'extern-block) (if (eqv? (sx-tag $2) 'extern-block)
(tl-extend $1 (sx-tail $2)) (tl-extend $1 (sx-tail $2 2))
(tl-append $1 $2))) (tl-append $1 $2)))
;; external-declaration => $P3 external-declaration-1 ;; external-declaration => function-definition
(lambda ($2 $1 . $rest) $2)
;; $P3 =>
(lambda $rest (cpp-ok!))
;; external-declaration-1 => function-definition
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; external-declaration-1 => declaration ;; external-declaration => declaration
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; external-declaration-1 => lone-comment ;; external-declaration => lone-comment
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; external-declaration-1 => cpp-statement ;; external-declaration => cpp-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; external-declaration-1 => "extern" '$string "{" translation-unit "}" ;; external-declaration => "extern" '$string "{" external-declaration-li...
(lambda ($5 $4 $3 $2 $1 . $rest) (lambda ($5 $4 $3 $2 $1 . $rest)
`(extern-block `(extern-block
$2 ,$2
(extern-C-begin) (extern-begin ,$2)
$4 ,@(sx-tail (tl->list $4) 1)
(extern-C-end))) (extern-end)))
;; function-definition => declaration-specifiers declarator declaration-... ;; function-definition => declaration-specifiers declarator declaration-...
(lambda ($4 $3 $2 $1 . $rest) (lambda ($4 $3 $2 $1 . $rest)
`(knr-fctn-defn `(knr-fctn-defn

1556
module/nyacc/lang/c99/mach.d/c99tab.scm
View file

File diff suppressed because it is too large Load diff

62
module/nyacc/lang/c99/mach.d/c99xact.scm
View file

@ -1,10 +1,10 @@
;; ./mach.d/c99xact.scm ;; ../../../../module/nyacc/lang/c99/mach.d/c99xact.scm
;; Copyright 2016,2017 Matthew R. Wette ;; Copyright (C) 2015,2016 Matthew R. Wette
;; ;;
;; This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3, ;; This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3,
;; or any later version published by the Free Software Foundation. See ;; or any later version published by the Free Software Foundation. See the
;; the file COPYING included with the this distribution. ;; file COPYING included with the this distribution.
(define act-v (define act-v
(vector (vector
@ -399,10 +399,10 @@
;; struct-declarator => ":" constant-expression ;; struct-declarator => ":" constant-expression
(lambda ($2 $1 . $rest) (lambda ($2 $1 . $rest)
`(comp-declr (bit-field ,$2))) `(comp-declr (bit-field ,$2)))
;; enum-specifier => "enum" ident-like "{" enumerator-list "}" ;; enum-specifier => "enum" identifier "{" enumerator-list "}"
(lambda ($5 $4 $3 $2 $1 . $rest) (lambda ($5 $4 $3 $2 $1 . $rest)
`(enum-def ,$2 ,(tl->list $4))) `(enum-def ,$2 ,(tl->list $4)))
;; enum-specifier => "enum" ident-like "{" enumerator-list "," "}" ;; enum-specifier => "enum" identifier "{" enumerator-list "," "}"
(lambda ($6 $5 $4 $3 $2 $1 . $rest) (lambda ($6 $5 $4 $3 $2 $1 . $rest)
`(enum-def ,$2 ,(tl->list $4))) `(enum-def ,$2 ,(tl->list $4)))
;; enum-specifier => "enum" "{" enumerator-list "}" ;; enum-specifier => "enum" "{" enumerator-list "}"
@ -411,7 +411,7 @@
;; enum-specifier => "enum" "{" enumerator-list "," "}" ;; enum-specifier => "enum" "{" enumerator-list "," "}"
(lambda ($5 $4 $3 $2 $1 . $rest) (lambda ($5 $4 $3 $2 $1 . $rest)
`(enum-def ,(tl->list $3))) `(enum-def ,(tl->list $3)))
;; enum-specifier => "enum" ident-like ;; enum-specifier => "enum" identifier
(lambda ($2 $1 . $rest) `(enum-ref ,$2)) (lambda ($2 $1 . $rest) `(enum-ref ,$2))
;; enumerator-list => enumerator ;; enumerator-list => enumerator
(lambda ($1 . $rest) (make-tl 'enum-def-list $1)) (lambda ($1 . $rest) (make-tl 'enum-def-list $1))
@ -622,23 +622,19 @@
(lambda ($3 $2 $1 . $rest) (list 'array-dsgr $2)) (lambda ($3 $2 $1 . $rest) (list 'array-dsgr $2))
;; designator => "." identifier ;; designator => "." identifier
(lambda ($2 $1 . $rest) (list 'sel-dsgr $2)) (lambda ($2 $1 . $rest) (list 'sel-dsgr $2))
;; statement => $P2 statement-1 ;; statement => labeled-statement
(lambda ($2 $1 . $rest) $2)
;; $P2 =>
(lambda $rest (cpp-ok!))
;; statement-1 => labeled-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => compound-statement ;; statement => compound-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => expression-statement ;; statement => expression-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => selection-statement ;; statement => selection-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => iteration-statement ;; statement => iteration-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => jump-statement ;; statement => jump-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; statement-1 => cpp-statement ;; statement => cpp-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; labeled-statement => identifier ":" statement ;; labeled-statement => identifier ":" statement
(lambda ($3 $2 $1 . $rest) (lambda ($3 $2 $1 . $rest)
@ -707,28 +703,22 @@
(lambda ($1 . $rest) (make-tl 'trans-unit $1)) (lambda ($1 . $rest) (make-tl 'trans-unit $1))
;; translation-unit => translation-unit external-declaration ;; translation-unit => translation-unit external-declaration
(lambda ($2 $1 . $rest) (lambda ($2 $1 . $rest)
(if (eqv? (sx-tag $2) 'extern-block) (cond ((eqv? 'trans-unit (car $2))
(tl-extend $1 (sx-tail $2)) (let* ((t1 (tl-append $1 '(extern-C-begin)))
(tl-append $1 $2))) (t2 (tl-extend t1 (cdr $2)))
;; external-declaration => $P3 external-declaration-1 (t3 (tl-append t2 '(extern-C-end))))
(lambda ($2 $1 . $rest) $2) t3))
;; $P3 => (else (tl-append $1 $2))))
(lambda $rest (cpp-ok!)) ;; external-declaration => function-definition
;; external-declaration-1 => function-definition
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; external-declaration-1 => declaration ;; external-declaration => declaration
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; external-declaration-1 => lone-comment ;; external-declaration => lone-comment
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; external-declaration-1 => cpp-statement ;; external-declaration => cpp-statement
(lambda ($1 . $rest) $1) (lambda ($1 . $rest) $1)
;; external-declaration-1 => "extern" '$string "{" translation-unit "}" ;; external-declaration => "extern" '$string "{" translation-unit "}"
(lambda ($5 $4 $3 $2 $1 . $rest) (lambda ($5 $4 $3 $2 $1 . $rest) (tl->list $4))
`(extern-block
$2
(extern-C-begin)
$4
(extern-C-end)))
;; function-definition => declaration-specifiers declarator declaration-... ;; function-definition => declaration-specifiers declarator declaration-...
(lambda ($4 $3 $2 $1 . $rest) (lambda ($4 $3 $2 $1 . $rest)
`(knr-fctn-defn `(knr-fctn-defn

1138
module/nyacc/lang/c99/mach.d/c99xtab.scm
View file

File diff suppressed because it is too large Load diff

2
module/nyacc/lang/c99/mach.d/cppact.scm
View file

@ -1,6 +1,6 @@
;; ./mach.d/cppact.scm ;; ./mach.d/cppact.scm
;; ;; Copyright (C) 2016,2017 Matthew R. Wette
;; ;;
;; This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3, ;; This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3,
;; or any later version published by the Free Software Foundation. See ;; or any later version published by the Free Software Foundation. See

2
module/nyacc/lang/c99/mach.d/cpptab.scm
View file

@ -1,6 +1,6 @@
;; ./mach.d/cpptab.scm ;; ./mach.d/cpptab.scm
;; ;; Copyright (C) 2016,2017 Matthew R. Wette
;; ;;
;; This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3, ;; This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3,
;; or any later version published by the Free Software Foundation. See ;; or any later version published by the Free Software Foundation. See

43
module/nyacc/lang/c99/mach.scm
View file

@ -1,6 +1,6 @@
;;; lang/c99/mach.scm ;;; lang/c99/mach.scm
;;; ;;;
;;; Copyright (C) 2015,2016 Matthew R. Wette ;;; Copyright (C) 2015-2017 Matthew R. Wette
;;; ;;;
;;; This program is free software: you can redistribute it and/or modify ;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by ;;; it under the terms of the GNU General Public License as published by
@ -26,9 +26,7 @@
#:use-module (nyacc parse) #:use-module (nyacc parse)
#:use-module (nyacc lex) #:use-module (nyacc lex)
#:use-module (nyacc util) #:use-module (nyacc util)
#:use-module ((srfi srfi-9) #:select (define-record-type))
#:use-module ((srfi srfi-43) #:select (vector-map)) #:use-module ((srfi srfi-43) #:select (vector-map))
#:use-module ((sxml xpath) #:select (sxpath))
) )
;; @item c99-spec ;; @item c99-spec
@ -38,16 +36,15 @@
;; The output of the end parser will be a SXML tree (w/o the @code{*TOP*} node. ;; The output of the end parser will be a SXML tree (w/o the @code{*TOP*} node.
(define c99-spec (define c99-spec
(lalr-spec (lalr-spec
(notice (string-append "Copyright 2016,2017 Matthew R. Wette" lang-crn-lic)) (notice (string-append "Copyright (C) 2016,2017 Matthew R. Wette"
lang-crn-lic))
(prec< 'then "else") ; "then/else" SR-conflict resolution (prec< 'then "else") ; "then/else" SR-conflict resolution
(prec< 'imp ; "implied type" SR-conflict resolution (prec< 'imp ; "implied type" SR-conflict resolution
"char" "short" "int" "long" "char" "short" "int" "long"
"float" "double" "_Complex") "float" "double" "_Complex")
(start translation-unit-proxy) (start translation-unit)
(grammar (grammar
(translation-unit-proxy (translation-unit ($$ (tl->list $1))))
;; expressions ;; expressions
(primary-expression ; S 6.5.1 (primary-expression ; S 6.5.1
(identifier ($$ `(p-expr ,$1))) (identifier ($$ `(p-expr ,$1)))
@ -540,8 +537,6 @@
;; statements ;; statements
(statement (statement
(($$ (cpp-ok!)) statement-1 ($$ $2)))
(statement-1
(labeled-statement) (labeled-statement)
(compound-statement) (compound-statement)
(expression-statement) (expression-statement)
@ -602,7 +597,7 @@
(expression)) (expression))
(jump-statement ; S 6.8.6 (jump-statement ; S 6.8.6
("goto" identifier ";" ($$ `(goto $2))) ("goto" identifier ";" ($$ `(goto ,$2)))
("continue" ";" ($$ '(continue))) ("continue" ";" ($$ '(continue)))
("break" ";" ($$ '(break))) ("break" ";" ($$ '(break)))
("return" expression ";" ($$ `(return ,$2))) ("return" expression ";" ($$ `(return ,$2)))
@ -610,24 +605,25 @@
) )
;; external definitions ;; external definitions
(translation-unit (translation-unit (external-declaration-list ($$ (tl->list $1))))
(external-declaration-list
(external-declaration ($$ (make-tl 'trans-unit $1))) (external-declaration ($$ (make-tl 'trans-unit $1)))
(translation-unit (external-declaration-list
external-declaration external-declaration
($$ (if (eqv? (sx-tag $2) 'extern-block) (tl-extend $1 (sx-tail $2)) ;; A ``kludge'' to deal with @code{extern "C" ...}:
($$ (if (eqv? (sx-tag $2) 'extern-block) (tl-extend $1 (sx-tail $2 2))
(tl-append $1 $2)))) (tl-append $1 $2))))
) )
(external-declaration (external-declaration
(($$ (cpp-ok!)) external-declaration-1 ($$ $2)))
(external-declaration-1
(function-definition) (function-definition)
(declaration) (declaration)
(lone-comment) (lone-comment)
(cpp-statement) (cpp-statement)
;; The following is a kludge to deal with @code{extern "C" @{ ...}. ("extern" $string "{" external-declaration-list "}"
("extern" $string "{" translation-unit "}" ($$ `(extern-block ,$2 (extern-begin ,$2)
($$ `(extern-block $2 (extern-C-begin) $4 (extern-C-end)))) ,@(sx-tail (tl->list $4) 1) (extern-end))))
) )
(function-definition (function-definition
@ -697,15 +693,16 @@
(xdef? #f) ; expand def function: proc name mode (xdef? #f) ; expand def function: proc name mode
(debug #f)) ; debug (debug #f)) ; debug
(catch (catch
'parse-error #t ;; 'c99-error 'cpp-error 'nyacc-error
(lambda () (lambda ()
(let ((info (make-cpi debug cpp-defs (cons "." inc-dirs) td-dict))) (let ((info (make-cpi debug cpp-defs (cons "." inc-dirs) td-dict)))
(with-fluid* *info* info (with-fluid*
*info* info
(lambda () (lambda ()
(raw-parser (gen-c-lexer #:mode mode #:xdef? xdef?) (raw-parser (gen-c-lexer #:mode mode #:xdef? xdef?)
#:debug debug))))) #:debug debug)))))
(lambda (key fmt . rest) (lambda (key fmt . rest)
(apply simple-format (current-error-port) (string-append fmt "\n") rest) (report-error fmt rest)
#f))) #f)))
(define dev-parse-c dev-parse-c99) (define dev-parse-c dev-parse-c99)
@ -729,9 +726,7 @@
(b (move-if-changed (xtra-dir "c99tab.scm.new") (b (move-if-changed (xtra-dir "c99tab.scm.new")
(xtra-dir "c99tab.scm")))) (xtra-dir "c99tab.scm"))))
(when (or a b) (when (or a b)
(system (string-append "touch " (lang-dir "parser.scm"))) (system (string-append "touch " (lang-dir "parser.scm"))))))
#;(compile-file (lang-dir "parser.scm"))
)))
;; @item gen-c99x-files [dir] => #t ;; @item gen-c99x-files [dir] => #t
;; Update or generate the files @quot{c99xact.scm} and @quot{c99xtab.scm}. ;; Update or generate the files @quot{c99xact.scm} and @quot{c99xtab.scm}.

79
module/nyacc/lang/c99/parser.scm
View file

@ -1,6 +1,6 @@
;;; nyacc/lang/c99/parser.scm ;;; nyacc/lang/c99/parser.scm
;;; ;;;
;;; Copyright (C) 2015 Matthew R. Wette ;;; Copyright (C) 2015-2017 Matthew R. Wette
;;; ;;;
;;; This program is free software: you can redistribute it and/or modify ;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by ;;; it under the terms of the GNU General Public License as published by
@ -18,14 +18,15 @@
;; C parser ;; C parser
(define-module (nyacc lang c99 parser) (define-module (nyacc lang c99 parser)
#:export (parse-c parse-c99 def-xdef? std-dict) #:export (parse-c99
def-xdef? c99-std-dict
gen-c-lexer
gen-gcc-defs
)
#:use-module (nyacc lex) #:use-module (nyacc lex)
#:use-module (nyacc parse) #:use-module (nyacc parse)
#:use-module (nyacc lang util) #:use-module (nyacc lang util)
#:use-module (nyacc lang c99 cpp) #:use-module (nyacc lang c99 cpp)
#:use-module ((srfi srfi-9) #:select (define-record-type))
#:use-module ((sxml xpath) #:select (sxpath))
;;#:use-module (nyacc lang c99 my-parse)
) )
(cond-expand (cond-expand
@ -40,53 +41,75 @@
(include-from-path "nyacc/lang/c99/mach.d/c99act.scm") (include-from-path "nyacc/lang/c99/mach.d/c99act.scm")
;; Parse given a token generator. Uses fluid @code{*info*}. ;; Parse given a token generator. Uses fluid @code{*info*}.
;; A little ugly wrt re-throw but
(define raw-parser (define raw-parser
;;(make-c99-ia-parser (let ((c99-parser (make-lalr-parser
(make-lalr-parser (list (cons 'len-v len-v) (cons 'pat-v pat-v)
(list (cons 'rto-v rto-v) (cons 'mtab mtab)
(cons 'len-v len-v) (cons 'act-v act-v)))))
(cons 'pat-v pat-v) (lambda* (lexer #:key (debug #f))
(cons 'rto-v rto-v) (with-throw-handler
(cons 'mtab mtab) 'nyacc-error
(cons 'act-v act-v)))) (lambda () (c99-parser lexer #:debug debug))
(lambda (key fmt . args) (apply throw 'c99-error fmt args))))))
(define* (my-c-lexer #:key (mode 'file) (xdef? #f))
(let ((def-lxr (gen-c-lexer #:mode mode #:xdef? xdef?)))
(lambda ()
(let ((tok (def-lxr)))
;;(simple-format #t "~S\n" tok)
tok))))
;; This is used to parse included files at top level.
(define (run-parse) (define (run-parse)
(let ((info (fluid-ref *info*))) (let ((info (fluid-ref *info*)))
;;(raw-parser (my-c-lexer) #:debug (cpi-debug info))))
(raw-parser (gen-c-lexer) #:debug (cpi-debug info)))) (raw-parser (gen-c-lexer) #:debug (cpi-debug info))))
;; @item parse-c [#:cpp-defs def-a-list] [#:inc-dirs dir-list] [#:debug bool] \ ;; @deffn parse-c99 [#:cpp-defs def-a-list] [#:inc-dirs dir-list] \
;; [#:mode ('code|'file)] ;; [#:mode ('code|'file)] [#:debug bool]
;; This needs to be explained in some detail. ;; This needs to be explained in some detail.
;; tdd = typedef dict: (("<time>" time_t) ... ("<unistd.h>" ...)) ;; tdd = typedef dict: (("<time>" time_t) ... ("<unistd.h>" ...))
;; Default mode is @code{'code}.
;; @example
;; (with-input-from-file "abc.c"
;; (parse-c #:cpp-defs '(("ABC" . "123"))
;; #:inc-dirs (append '("." "./incs" "/usr/include") c99-std-dict)
;; #:td-dict '(("myinc.h" "foo_t" "bar_t"))
;; #:mode 'file))
;; @end example
(define* (parse-c99 #:key (define* (parse-c99 #:key
(cpp-defs '()) ; CPP defines (cpp-defs '()) ; CPP defines
(inc-dirs '()) ; include dirs (inc-dirs '()) ; include dirs
(td-dict '()) ; typedef dictionary (td-dict '()) ; typedef dictionary
(mode 'file) ; mdoe: 'file or 'code (mode 'code) ; mode: 'file or 'code
(xdef? #f) ; pred to determine expand (xdef? #f) ; pred to determine expand
(debug #f)) ; debug (debug #f)) ; debug
(catch (catch
'parse-error 'c99-error
(lambda () (lambda ()
(let ((info (make-cpi debug cpp-defs (cons "." inc-dirs) td-dict))) (let ((info (make-cpi debug cpp-defs (cons "." inc-dirs) td-dict)))
(with-fluid* (with-fluid*
*info* info *info* info
(lambda () (lambda ()
(if (eqv? mode 'file) (cpp-ok!) (no-cpp!)) (raw-parser (gen-c-lexer #:mode mode #:xdef? xdef?)
(raw-parser (my-c-lexer #:mode mode #:xdef? xdef?)
#:debug debug))))) #:debug debug)))))
(lambda (key fmt . rest) (lambda (key fmt . rest)
(apply simple-format (current-error-port) (string-append fmt "\n") rest) (report-error fmt rest)
#f))) #f)))
(define parse-c parse-c99) (define parse-c parse-c99)
(use-modules (ice-9 rdelim))
(use-modules (ice-9 popen))
(use-modules (ice-9 regex))
;; @deffn gen-gcc-defs args => '(("ABC" . "123") ...)
;; Generate a list of default defines produced by gcc.
(define gen-gcc-defs
;; @code{"gcc -dM -E"} will generate lines like @code{"#define ABC 123"}.
;; We generate and return a list like @code{'(("ABC" . "123") ...)}.
(let ((rx (make-regexp "#define\\s+(\\S+)\\s+(.*)")))
(lambda (args)
(map
(lambda (l)
(let ((m (regexp-exec rx l)))
(cons (match:substring m 1) (match:substring m 2))))
(let ((ip (open-input-pipe "gcc -dM -E - </dev/null")))
(let iter ((lines '()) (line (read-line ip 'trim)))
(if (eof-object? line) lines
(iter (cons line lines) (read-line ip 'trim)))))))))
;; --- last line --- ;; --- last line ---

5
module/nyacc/lang/c99/pprint.scm
View file

@ -521,8 +521,8 @@
((cpp-stmt . ,rest) ((cpp-stmt . ,rest)
(cpp-ppx (sx-ref tree 1))) (cpp-ppx (sx-ref tree 1)))
((extern-C-begin) (sf "extern \"C\" {\n")) ((extern-begin ,lang) (sf "extern \"~A\" {\n" lang))
((extern-C-end) (sf "}\n")) ((extern-end) (sf "}\n"))
(,otherwise (,otherwise
(simple-format #t "\n*** pprint/ppx: NO MATCH: ~S\n" (car tree))) (simple-format #t "\n*** pprint/ppx: NO MATCH: ~S\n" (car tree)))
@ -530,6 +530,7 @@
(define ppx ppx-1) (define ppx ppx-1)
(if (not (pair? tree)) (error "expecing sxml tree"))
(ppx tree) (ppx tree)
(if ugly (newline))) (if ugly (newline)))

17
module/nyacc/lang/c99/xparser.scm
View file

@ -49,20 +49,25 @@
;; This needs to be explained in some detail. ;; This needs to be explained in some detail.
;; [#:tyns '("foo_t")] ;; [#:tyns '("foo_t")]
(define* (parse-c99x xstr (define* (parse-c99x xstr
#:key (cpp-defs '()) (tn-dict '()) (debug #f) (tyns '())) #:key
(cpp-defs '()) ; CPP defines
(tn-dict '()) ; typedef dictionary
(xdef? #f) ; pred to determine expand
(debug #f) ; debug?
(tyns '())) ; defined typenames
(with-input-from-string xstr
(catch (catch
'parse-error #t
(lambda () (lambda ()
(let ((info (make-cpi debug cpp-defs '(".") tn-dict))) (let ((info (make-cpi debug cpp-defs '(".") tn-dict)))
(set-cpi-ptl! info (cons tyns (cpi-ptl info))) (set-cpi-ptl! info (cons tyns (cpi-ptl info)))
(with-fluid* (with-fluid*
*info* info *info* info
(lambda () (lambda ()
(with-input-from-string xstr (raw-parser (gen-c-lexer #:mode 'code #:xdef? xdef?)
(lambda () #:debug debug))))))
(raw-parser (gen-c-lexer #:mode 'code) #:debug debug)))))))
(lambda (key fmt . rest) (lambda (key fmt . rest)
(apply simple-format (current-error-port) (string-append fmt "\n") rest) (report-error fmt rest)
#f))) #f)))
(define parse-cx parse-c99x) (define parse-cx parse-c99x)

116
module/nyacc/lang/util.scm
View file

@ -9,7 +9,8 @@
;; runtime utilities for the parsers -- needs work ;; runtime utilities for the parsers -- needs work
(define-module (nyacc lang util) (define-module (nyacc lang util)
#:export (lang-crn-lic #:export (lang-crn-lic
report-error
push-input pop-input reset-input-stack push-input pop-input reset-input-stack
make-tl tl->list ;; rename?? to tl->sx for sxml-expr make-tl tl->list ;; rename?? to tl->sx for sxml-expr
tl-append tl-insert tl-extend tl+attr tl-append tl-insert tl-extend tl+attr
@ -21,8 +22,8 @@
;; for ??? ;; for ???
move-if-changed move-if-changed
fmterr) fmterr)
#:use-module ((srfi srfi-1) #:select(find)) #:use-module ((srfi srfi-1) #:select(find))
) )
(cond-expand (cond-expand
(guile-2) (guile-2)
@ -40,7 +41,15 @@ or any later version published by the Free Software Foundation. See
the file COPYING included with the this distribution.") the file COPYING included with the this distribution.")
(define (fmterr fmt . args) (define (fmterr fmt . args)
(apply simple-format (current-error-port) fmt args)) (apply simple-format (current-error-port) fmt args))
;; @deffn report-error fmt args
;; Report an error: to stderr, providing file and line num info, and add nl.
(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 "~S:~S: " fmt "\n") fn ln args)))
;; === input stack ===================== ;; === input stack =====================
@ -79,9 +88,9 @@ the file COPYING included with the this distribution.")
;; @deffn make-tl tag [item item ...] ;; @deffn make-tl tag [item item ...]
;; Create a tagged-list structure. ;; Create a tagged-list structure.
(define (make-tl tag . rest) (define (make-tl tag . rest)
(let iter ((tail tag) (l rest)) (let iter ((tail tag) (l rest))
(if (null? l) (cons '() tail) (if (null? l) (cons '() tail)
(iter (cons (car l) tail) (cdr l))))) (iter (cons (car l) tail) (cdr l)))))
;; @deffn tl->list tl ;; @deffn tl->list tl
;; Convert a tagged list structure to a list. This collects added attributes ;; Convert a tagged list structure to a list. This collects added attributes
@ -90,8 +99,8 @@ the file COPYING included with the this distribution.")
;; (<tag> (@ <attr>) <rest>) ;; (<tag> (@ <attr>) <rest>)
;; @end example ;; @end example
(define (tl->list tl) (define (tl->list tl)
(let ((heda (car tl)) (let ((heda (car tl))
(head (let iter ((head '()) (attr '()) (tl-head (car tl))) (head (let iter ((head '()) (attr '()) (tl-head (car tl)))
(if (null? tl-head) (if (null? tl-head)
(if (pair? attr) (if (pair? attr)
(cons (cons '@ attr) (reverse head)) (cons (cons '@ attr) (reverse head))
@ -99,28 +108,34 @@ the file COPYING included with the this distribution.")
(if (and (pair? (car tl-head)) (eq? '@ (caar tl-head))) (if (and (pair? (car tl-head)) (eq? '@ (caar tl-head)))
(iter head (cons (cdar tl-head) attr) (cdr tl-head)) (iter head (cons (cdar tl-head) attr) (cdr tl-head))
(iter (cons (car tl-head) head) attr (cdr tl-head))))))) (iter (cons (car tl-head) head) attr (cdr tl-head)))))))
(let iter ((tail '()) (tl-tail (cdr tl))) (let iter ((tail '()) (tl-tail (cdr tl)))
(if (pair? tl-tail) (if (pair? tl-tail)
(iter (cons (car tl-tail) tail) (cdr tl-tail)) (iter (cons (car tl-tail) tail) (cdr tl-tail))
(cons tl-tail (append head tail)))))) (cons tl-tail (append head tail))))))
;; @deffn tl-insert tl item ;; @deffn tl-insert tl item
;; Insert item at front of tagged list (but after tag). ;; Insert item at front of tagged list (but after tag).
(define (tl-insert tl item) (define (tl-insert tl item)
(cons (cons item (car tl)) (cdr tl))) (cons (cons item (car tl)) (cdr tl)))
;; @deffn tl-append tl item ... ;; @deffn tl-append tl item ...
;; Append item at end of tagged list. ;; Append items at end of tagged list.
(define (tl-append tl . rest) (define (tl-append tl . rest)
(cons (car tl) (cons (car tl)
(let iter ((tail (cdr tl)) (items rest)) (let iter ((tail (cdr tl)) (items rest))
(if (null? items) tail (if (null? items) tail
(iter (cons (car items) tail) (cdr items)))))) (iter (cons (car items) tail) (cdr items))))))
;; @deffn tl-extend tl item-l ;; @deffn tl-extend tl item-l
;; Extend with a list of items. ;; Extend with a list of items.
(define (tl-extend tl item-l) (define (tl-extend tl item-l)
(apply tl-append tl item-l)) (apply tl-append tl item-l))
;; @deffn tl-extend! tl item-l
;; Extend with a list of items. Uses @code{set-cdr!}.
(define (tl-extend! tl item-l)
(set-cdr! (last-pair tl) item-l)
tl)
;; @deffn tl+attr tl key val) ;; @deffn tl+attr tl key val)
;; Add an attribute to a tagged list. Return the tl. ;; Add an attribute to a tagged list. Return the tl.
@ -128,16 +143,20 @@ the file COPYING included with the this distribution.")
;; (tl+attr tl 'type "int") ;; (tl+attr tl 'type "int")
;; @end example ;; @end example
(define (tl+attr tl key val) (define (tl+attr tl key val)
(tl-insert tl (cons '@ (list key val)))) (tl-insert tl (cons '@ (list key val))))
;; @deffn tl-merge tl tl1 ;; @deffn tl-merge tl tl1
;; Merge guts of phony-tl @code{tl1} into @code{tl}. ;; Merge guts of phony-tl @code{tl1} into @code{tl}.
(define (tl-merge tl tl1) (define (tl-merge tl tl1)
(error "not implemented (yet)") (error "not implemented (yet)")
) )
;; === sx ============================== ;; === sx ==============================
;; @section SXML Utility Procedures ;; @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 sx-ref sx ix => item ;; @deffn sx-ref sx ix => item
;; Reference the @code{ix}-th element of the list, not counting the optional ;; Reference the @code{ix}-th element of the list, not counting the optional
@ -147,51 +166,52 @@ the file COPYING included with the this distribution.")
;; (sx-ref '(abc (@ (foo "1")) "def") 1) => "def" ;; (sx-ref '(abc (@ (foo "1")) "def") 1) => "def"
;; @end example ;; @end example
(define (sx-ref sx ix) (define (sx-ref sx ix)
(define (list-xref l x) (if (> (length l) x) (list-ref l x) #f)) (define (list-xref l x) (if (> (length l) x) (list-ref l x) #f))
(cond (cond
((zero? ix) (car sx)) ((zero? ix) (car sx))
((and (pair? (cadr sx)) (eqv? '@ (caadr sx))) ((and (pair? (cadr sx)) (eqv? '@ (caadr sx)))
(list-xref sx (1+ ix))) (list-xref sx (1+ ix)))
(else (else
(list-xref sx ix)))) (list-xref sx ix))))
;; @deffn sx-tag sx => tag ;; @deffn sx-tag sx => tag
;; Return the tag for a tree ;; Return the tag for a tree
(define (sx-tag sx) (define (sx-tag sx)
(if (pair? sx) (car sx) #f)) (if (pair? sx) (car sx) #f))
;; @deffn sx-tail sx ix => (list) ;; @deffn sx-tail sx ix => (list)
;; Return the tail starting at the ix-th cdr, starting from 0. ;; Return the tail starting at the ix-th cdr, starting from 0.
;; For example, if sx has 3 items then (sx-tail sx 2) returns '(). ;; For example, if sx has 3 items then (sx-tail sx 2) returns '().
;; BUG: not working for (sx '(foo) 1)
(define (sx-tail sx ix) (define (sx-tail sx ix)
(if (zero? ix) (error "zero index not supported")) (cond
(let ((sx (cdr sx)) (ix (1- ix))) ((zero? ix) (error "sx-tail: expecting index greater than 0"))
(cond ((and (pair? (cdr sx)) (eqv? '@ (cadr sx))) (list-tail sx (1+ ix)))
((and (null? sx) (zero? ix)) sx) (else (list-tail sx ix))))
((and (pair? (car sx)) (eqv? '@ (caar sx))) (list-tail sx (1+ ix)))
(else (list-tail sx ix)))))
;; @deffn sx-has-attr? sx ;; @deffn sx-has-attr? sx
;; p to determine if @arg{sx} has attributes. ;; p to determine if @arg{sx} has attributes.
(define (sx-has-attr? sx) (define (sx-has-attr? sx)
(and (pair? (cdr sx)) (pair? (cadr sx)) (eqv? '@ (caadr sx)))) (and (pair? (cdr sx)) (pair? (cadr sx)) (eqv? '@ (caadr sx))))
;; @deffn sx-attr sx => '(@ ...)|#f ;; @deffn sx-attr sx => '(@ ...)|#f
;; @example ;; @example
;; (sx-attr '(abc (@ (foo "1")) def) 1) => '(@ (foo "1")) ;; (sx-attr '(abc (@ (foo "1")) def) 1) => '(@ (foo "1"))
;; @end example ;; @end example
;; should change this to
;; @example
;; (sx-attr sx) => '((a . 1) (b . 2) ...)
;; @end example
(define (sx-attr sx) (define (sx-attr sx)
(if (and (pair? (cdr sx)) (pair? (cadr sx))) (if (and (pair? (cdr sx)) (pair? (cadr sx)))
(if (eqv? '@ (caadr sx)) (if (eqv? '@ (caadr sx))
(cadr sx) (cadr sx)
#f) #f)
#f)) #f))
;; @deffn sx-attr-ref sx key => val ;; @deffn sx-attr-ref sx key => val
;; Return an attribute value given the key, or @code{#f}. ;; Return an attribute value given the key, or @code{#f}.
(define (sx-attr-ref sx key) (define (sx-attr-ref sx key)
(and=> (sx-attr sx) (and=> (sx-attr sx)
(lambda (attr) (lambda (attr)
(and=> (assq-ref (cdr attr) key) car)))) (and=> (assq-ref (cdr attr) key) car))))
@ -199,20 +219,20 @@ the file COPYING included with the this distribution.")
;; Set attribute for sx. If no attributes exist, if key does not exist, ;; Set attribute for sx. If no attributes exist, if key does not exist,
;; add it, if it does exist, replace it. ;; add it, if it does exist, replace it.
(define (sx-set-attr! sx key val . rest) (define (sx-set-attr! sx key val . rest)
(if (sx-has-attr? sx) (if (sx-has-attr? sx)
(let ((attr (cadr sx))) (let ((attr (cadr sx)))
(set-cdr! attr (assoc-set! (cdr attr) key (list val)))) (set-cdr! attr (assoc-set! (cdr attr) key (list val))))
(set-cdr! sx (cons `(@ (,key ,val)) (cdr sx)))) (set-cdr! sx (cons `(@ (,key ,val)) (cdr sx))))
sx) sx)
;; @deffn sx-set-attr* sx key val [key val [key ... ]] ;; @deffn sx-set-attr* sx key val [key val [key ... ]]
;; Set attribute for sx. If no attributes exist, if key does not exist, ;; Set attribute for sx. If no attributes exist, if key does not exist,
;; add it, if it does exist, replace it. ;; add it, if it does exist, replace it.
(define (sx-set-attr* sx . rest) (define (sx-set-attr* sx . rest)
(let iter ((attr (or (and=> (sx-attr sx) cdr) '())) (kvl rest)) (let iter ((attr (or (and=> (sx-attr sx) cdr) '())) (kvl rest))
(cond (cond
((null? kvl) (cons* (sx-tag sx) (cons '@ (reverse attr)) (sx-tail sx 1))) ((null? kvl) (cons* (sx-tag sx) (cons '@ (reverse attr)) (sx-tail sx 1)))
(else (iter (cons (list (car kvl) (cadr kvl)) attr) (cddr kvl)))))) (else (iter (cons (list (car kvl) (cadr kvl)) attr) (cddr kvl))))))
;; @deffn sx-find tag sx => ((tag ...) (tag ...)) ;; @deffn sx-find tag sx => ((tag ...) (tag ...))
;; Find the first matching element (in the first level). ;; Find the first matching element (in the first level).

2
module/nyacc/lex.scm
View file

@ -385,7 +385,7 @@
;; @deffn make-comm-reader comm-table [#:eat-newline #t] => \ ;; @deffn make-comm-reader comm-table [#:eat-newline #t] => \
;; ch bol -> ('$code-comm "..")|('$lone-comm "..")|#f ;; ch bol -> ('$code-comm "..")|('$lone-comm "..")|#f
;; comm-table is list of cons for (start . end) comment. ;; comm-table is list of cons for (start . end) comment.
;; e.g. ("--" "\n") ("/*" "*/") ;; e.g. ("--" . "\n") ("/*" . "*/")
;; test with "/* hello **/" ;; test with "/* hello **/"
;; If @code{eat-newline} is specified as true then for read comments ;; If @code{eat-newline} is specified as true then for read comments
;; ending with a newline a newline swallowed with the comment. ;; ending with a newline a newline swallowed with the comment.

13
module/nyacc/parse.scm
View file

@ -20,9 +20,7 @@
;; e.g., if comment not in latok, just throw away ;; e.g., if comment not in latok, just throw away
(define-module (nyacc parse) (define-module (nyacc parse)
#:export (make-lalr-parser #:export (make-lalr-parser make-lalr-ia-parser)
make-lalr-ia-parser
)
#:use-module (ice-9 optargs) #:use-module (ice-9 optargs)
#:use-module (nyacc util) #:use-module (nyacc util)
#:use-module ((srfi srfi-43) #:select (vector-map vector-for-each)) #:use-module ((srfi srfi-43) #:select (vector-map vector-for-each))
@ -116,12 +114,9 @@
(else ;; other action: skip, error, or accept (else ;; other action: skip, error, or accept
(case oact (case oact
((skip) (iter state stack nval (lexr))) ((skip) (iter state stack nval (lexr)))
((error) ((error) (throw 'nyacc-error
(let ((fn (or (port-filename (current-input-port)) "(unknown)")) "parse failed at state ~A, on input ~S"
(ln (1+ (port-line (current-input-port))))) (car state) sval))
(fmterr "~A:~A: parse failed at state ~A, on input ~S\n"
fn ln (car state) sval)
#f))
(else ;; accept (else ;; accept
(car stack)))))))))) (car stack))))))))))

2
module/nyacc/util.scm
View file

@ -244,7 +244,7 @@
(if (not (null? l)) (if (not (null? l))
(let ((ix (hashq-ref ht (car l)))) (let ((ix (hashq-ref ht (car l))))
(unless (vector-ref tv ix) (unless (vector-ref tv ix)
(pp 0 "set-pv! ~a ~a" ix k) (fmtout "set-pv! ~a ~a" ix k)
(vector-set! pv ix k) (vector-set! pv ix k)
(visit ix)) (visit ix))
(iter (cdr l))))) (iter (cdr l)))))