nyacc: lots of fixes to make CPP more robust; now need to test
This commit is contained in:
Matt Wette
Jan Nieuwenhuizen
parent
baea80d962
commit
0b46949f48
|
|
@ -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>
|
||||
|
||||
* lang/c99/mach.scm (c99-spec): added hooks (cpp-ok!, no-cpp!) to
|
||||
|
|
|
|||
|
|
@ -373,7 +373,7 @@
|
|||
(let* ((gram (assq-ref tree 'grammar))
|
||||
(start-symbol (and=> (assq-ref tree 'start) atomize))
|
||||
(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)))
|
||||
;; We sweep through the grammar to generate a canonical specification.
|
||||
;; Note: the local rhs is used to hold RHS terms, but a
|
||||
|
|
@ -461,10 +461,8 @@
|
|||
(else '($1)))))
|
||||
(if with (simple-format #t "WITH WHAT?\n"))
|
||||
(iter (cons lhs ll)
|
||||
(cons
|
||||
(cons* (cons 'rhs (list->vector (reverse pel)))
|
||||
(cons* 'act nrg act) (cons 'ref ref) attr)
|
||||
@l)
|
||||
(cons (cons* (cons 'rhs (list->vector (reverse pel)))
|
||||
(cons* 'act nrg act) (cons 'ref ref) attr) @l)
|
||||
tl nl head prox lhs tail rhs-l attr pel #f)))
|
||||
|
||||
((pair? rhs-l)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;; 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
|
||||
;;; 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
|
||||
'(
|
||||
("alloca.h")
|
||||
(define c99-std-dict
|
||||
'(("alloca.h")
|
||||
("complex.h" "complex" "imaginary")
|
||||
("ctype.h")
|
||||
("fenv.h" "fenv_t" "fexcept_t")
|
||||
|
|
@ -37,7 +44,6 @@
|
|||
("regex.h" "regex_t" "regmatch_t")
|
||||
("setjmp.h" "jmp_buf")
|
||||
("signal.h" "sig_atomic_t")
|
||||
("string.h" "size_t")
|
||||
("stdarg.h" "va_list")
|
||||
("stddef.h" "ptrdiff_t" "size_t" "wchar_t")
|
||||
("stdint.h"
|
||||
|
|
@ -47,12 +53,59 @@
|
|||
"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")
|
||||
("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")
|
||||
))
|
||||
|
||||
;; @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
|
||||
(make-cpi-1)
|
||||
cpi?
|
||||
|
|
@ -62,24 +115,18 @@
|
|||
(tn-dict cpi-tynd set-cpi-tynd!) ; typename dict (("<x>" foo_t ..
|
||||
(ptl cpi-ptl set-cpi-ptl!) ; parent 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)
|
||||
(let* ((cpi (make-cpi-1)))
|
||||
(set-cpi-debug! cpi debug)
|
||||
(set-cpi-defs! cpi defines)
|
||||
(set-cpi-incs! cpi incdirs)
|
||||
(set-cpi-tynd! cpi (append tn-dict std-dict))
|
||||
(set-cpi-ptl! cpi '()) ; list of lists of typedef strings
|
||||
(set-cpi-ctl! cpi '()) ; list of typedef strings
|
||||
(set-cpi-cppok! cpi #f) ; don't assume OK to pass CPP stmts
|
||||
(set-cpi-debug! cpi debug) ; print states debug
|
||||
(set-cpi-defs! cpi defines) ; list of define strings??
|
||||
(set-cpi-incs! cpi incdirs) ; list of include dir's
|
||||
(set-cpi-tynd! cpi tn-dict) ; typename dict by include-file name
|
||||
(set-cpi-ptl! cpi '()) ; list of lists of typedef strings
|
||||
(set-cpi-ctl! cpi '()) ; list of typedef strings
|
||||
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))
|
||||
|
||||
;; given tyns
|
||||
|
|
@ -91,10 +138,7 @@
|
|||
;; Called by lexer to determine if symbol is a typename.
|
||||
;; Check current sibling for each generation.
|
||||
(define (typename? name)
|
||||
;;(simple-format #t "typename? ~S\n" name)
|
||||
(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
|
||||
(let iter ((ptl (cpi-ptl cpi)))
|
||||
(if (null? ptl) #f
|
||||
|
|
@ -104,52 +148,22 @@
|
|||
;; @deffn add-typename name
|
||||
;; Helper for @code{save-typenames}.
|
||||
(define (add-typename name)
|
||||
;;(simple-format #t "add-typename ~S\n" name)
|
||||
(let ((cpi (fluid-ref *info*)))
|
||||
(set-cpi-ctl! cpi (cons name (cpi-ctl cpi)))
|
||||
;;(simple-format #t "at: ~S ~S\n" (cpi-ctl cpi) (cpi-ptl cpi))
|
||||
))
|
||||
(set-cpi-ctl! cpi (cons name (cpi-ctl cpi)))))
|
||||
|
||||
(define (cpi-push) ;; on #if
|
||||
(let ((cpi (fluid-ref *info*)))
|
||||
(set-cpi-ptl! cpi (cons (cpi-ctl cpi) (cpi-ptl cpi)))
|
||||
(set-cpi-ctl! cpi '())
|
||||
(simple-format #t "pu: ~S\n" (cpi-ctl cpi))
|
||||
))
|
||||
(set-cpi-ctl! cpi '())))
|
||||
|
||||
(define (cpi-shift) ;; on #elif #else
|
||||
(simple-format #t "sh\n")
|
||||
(set-cpi-ctl! (fluid-ref *info*) '()))
|
||||
|
||||
(define (cpi-pop) ;; on #endif
|
||||
(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-ptl! cpi (cdr (cpi-ptl cpi)))
|
||||
(simple-format #t "po>: ~S ~S\n" (cpi-ctl cpi) (cpi-ptl cpi))
|
||||
))
|
||||
(set-cpi-ptl! cpi (cdr (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
|
||||
;; Helper for @code{save-typenames}.
|
||||
;; Given declaration return a list of new typenames (via @code{typedef}).
|
||||
|
|
@ -187,6 +201,9 @@
|
|||
|
||||
;; ------------------------------------------------------------------------
|
||||
|
||||
(define (p-err . args)
|
||||
(apply throw 'c99-error args))
|
||||
|
||||
;; @deffn read-cpp-line ch => #f | (cpp-xxxx)??
|
||||
;; Given if ch is #\# read a cpp-statement
|
||||
;; includes BUG: #define ABC 123 /* \n
|
||||
|
|
@ -194,7 +211,7 @@
|
|||
(if (not (eq? ch #\#)) #f
|
||||
(let iter ((cl '()) (ch (read-char)))
|
||||
(cond
|
||||
((eq? ch #\newline) (list->string (reverse cl)))
|
||||
((eq? ch #\newline) (unread-char ch) (list->string (reverse cl)))
|
||||
((eq? ch #\\)
|
||||
(let ((c2 (read-char)))
|
||||
(if (eq? c2 #\newline)
|
||||
|
|
@ -225,65 +242,22 @@
|
|||
(let ((p (string-append (car dirl) "/" file)))
|
||||
(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)
|
||||
(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
|
||||
;; This gets ugly in order to handle cpp.
|
||||
;;.need to add support for num's w/ letters like @code{14L} and @code{1.3f}.
|
||||
|
|
@ -313,18 +287,16 @@
|
|||
(xp2 (sxpath '(decl))))
|
||||
;; mode: 'code|'file
|
||||
;; 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))
|
||||
(let ((bol #t) ; begin-of-line condition
|
||||
(ppxs (list 'keep)) ; CPP execution state stack
|
||||
(info (fluid-ref *info*)) ; assume make and run in same thread
|
||||
(pstk '()) ; port stack
|
||||
(x-def? (or xdef? def-xdef?)))
|
||||
;; Return the first (tval . lval) pair not excluded by the CPP.
|
||||
(lambda ()
|
||||
|
||||
(define (eval-flow?)
|
||||
(or (no-cpp?) (eqv? mode 'code)))
|
||||
(define (exec-cpp-stmts?) ; exec (vs pass to parser) CPP stmts?
|
||||
(eqv? mode 'code))
|
||||
|
||||
(define (add-define tree)
|
||||
(let* ((tail (cdr tree))
|
||||
|
|
@ -337,91 +309,102 @@
|
|||
(define (rem-define name)
|
||||
(set-cpi-defs! info (delete name (cpi-defs info))))
|
||||
|
||||
(define (exec-cpp line)
|
||||
(simple-format #t "exec-cpp: (cpp-ok=~S) ~S\n" (cpp-ok?) line)
|
||||
;; Parse the line into a CPP stmt, execute it, and return it.
|
||||
(let* ((stmt (read-cpp-stmt line)))
|
||||
(case (car stmt)
|
||||
((include)
|
||||
(let* ((parg (cadr stmt)) (leng (string-length parg))
|
||||
(file (substring parg 1 (1- leng)))
|
||||
(path (find-file-in-dirl file (cpi-incs info)))
|
||||
(tynd (assoc-ref (cpi-tynd info) file)))
|
||||
;; Evaluate expression text in #if of #elif statement.
|
||||
(define (eval-cpp-cond-text text)
|
||||
(with-throw-handler
|
||||
'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)
|
||||
((include)
|
||||
(let* ((parg (cadr stmt)) (leng (string-length parg))
|
||||
(file (substring parg 1 (1- leng)))
|
||||
(path (find-file-in-dirl file (cpi-incs info)))
|
||||
(tynd (assoc-ref (cpi-tynd info) file)))
|
||||
(cond
|
||||
(tynd (for-each add-typename tynd)) ; in dot-h dict
|
||||
((not path) (p-err "not found: ~S" file))
|
||||
((exec-cpp-stmts?) (push-input (open-input-file path)))
|
||||
(else ; include as tree
|
||||
(let* ((tree (with-input-from-file path run-parse)))
|
||||
(if (not tree) (p-err "included from ~S" path))
|
||||
(for-each add-define (xp1 tree)) ; add def's
|
||||
(set! stmt (append stmt (list tree)))))))
|
||||
(if (exec-cpp-stmts?) (set! ppxs (cons 'skip1-pop ppxs))))
|
||||
((define)
|
||||
(add-define stmt)
|
||||
(if (exec-cpp-stmts?) (set! ppxs (cons 'skip1-pop ppxs))))
|
||||
((undef)
|
||||
(rem-define (cadr stmt))
|
||||
(if (exec-cpp-stmts?) (set! ppxs (cons 'skip1-pop ppxs))))
|
||||
((if) ;; covers (if ifdef ifndef)
|
||||
(cond
|
||||
((exec-cpp-stmts?)
|
||||
(let ((val (eval-cpp-cond-text (cadr stmt))))
|
||||
(cond
|
||||
(tynd (for-each add-typename tynd)) ; in dot-h dict
|
||||
((or (no-cpp?) (eqv? mode 'code)) ; include flat
|
||||
(if (not path) (throw 'parse-error "not found: ~S" file))
|
||||
(push-input (open-input-file path))
|
||||
(set! stmt #f))
|
||||
(else ; include as tree
|
||||
(if (not path) (throw 'parse-error "not found: ~A" path))
|
||||
(let* ((tree (with-input-from-file path run-parse)))
|
||||
(if (not tree) (throw 'parse-error "~A" path))
|
||||
(for-each add-define (xp1 tree)) ; add def's
|
||||
;; Attach tree onto "include" statement.
|
||||
(if (pair? tree)
|
||||
(set! stmt (append stmt (list tree)))
|
||||
stmt))))))
|
||||
((define)
|
||||
(add-define stmt))
|
||||
((undef)
|
||||
(rem-define (cadr stmt)))
|
||||
((if) ;; and ifdef, ifndef
|
||||
(cpi-push)
|
||||
(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
|
||||
((not val)
|
||||
(throw 'parse-error "unresolved: ~S" (cadr stmt)))
|
||||
((zero? val)
|
||||
(set! ppxs (cons* 'skip1-pop 'skip-look ppxs)))
|
||||
(else
|
||||
(set! ppxs (cons* 'skip1-pop (car ppxs) ppxs)))))))
|
||||
((elif)
|
||||
(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
|
||||
((not val)
|
||||
(throw 'parse-error "unresolved: ~S" (cadr stmt)))
|
||||
((eq? 'keep (car ppxs))
|
||||
(set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs))))
|
||||
((zero? val)
|
||||
(set! ppxs (cons* 'skip1-pop ppxs)))
|
||||
((eq? 'skip-look (car ppxs))
|
||||
(cpi-shift)
|
||||
(set! ppxs (cons* 'skip1-pop 'keep (cdr ppxs))))
|
||||
(else
|
||||
(cpi-shift)
|
||||
(set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs))))))
|
||||
(cpi-shift)))
|
||||
((else)
|
||||
(if (eval-flow?)
|
||||
(cond
|
||||
((eq? 'skip-look (car ppxs))
|
||||
(cpi-shift)
|
||||
(set! ppxs (cons* 'skip1-pop 'keep (cdr ppxs))))
|
||||
(else
|
||||
(set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs)))))
|
||||
(cpi-shift)))
|
||||
((endif)
|
||||
(cpi-pop)
|
||||
(if (eval-flow?)
|
||||
(set! ppxs (cons 'skip1-pop (cdr ppxs)))))
|
||||
((error)
|
||||
stmt)
|
||||
(else
|
||||
(error "unhandled cpp stmt")))
|
||||
(if stmt (cons 'cpp-stmt stmt) '())))
|
||||
((not val) (p-err "unresolved: ~S" (cadr stmt)))
|
||||
((zero? val) (set! ppxs (cons* 'skip1-pop 'skip-look ppxs)))
|
||||
(else (set! ppxs (cons* 'skip1-pop (car ppxs) ppxs))))))
|
||||
(else (cpi-push))))
|
||||
((elif)
|
||||
(cond
|
||||
((exec-cpp-stmts?)
|
||||
(let ((val (eval-cpp-cond-text (cadr stmt))))
|
||||
(cond
|
||||
((not val)
|
||||
(p-err "unresolved: ~S" (cadr stmt)))
|
||||
((eq? 'keep (car ppxs))
|
||||
(set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs))))
|
||||
((zero? val) (set! ppxs (cons* 'skip1-pop ppxs)))
|
||||
((eq? 'skip-look (car ppxs))
|
||||
(set! ppxs (cons* 'skip1-pop 'keep (cdr ppxs))))
|
||||
(else
|
||||
(set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs)))))))
|
||||
(else (cpi-shift))))
|
||||
((else)
|
||||
(cond
|
||||
((exec-cpp-stmts?)
|
||||
(cond
|
||||
((eq? 'skip-look (car ppxs))
|
||||
(set! ppxs (cons* 'skip1-pop 'keep (cdr ppxs))))
|
||||
(else
|
||||
(set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs))))))
|
||||
(else (cpi-shift))))
|
||||
((endif)
|
||||
(cond
|
||||
((exec-cpp-stmts?)
|
||||
(set! ppxs (cons 'skip1-pop (cdr ppxs))))
|
||||
(else (cpi-pop))))
|
||||
((error)
|
||||
stmt)
|
||||
(else
|
||||
(error "unhandled cpp 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)
|
||||
(and=> (read-cpp-line ch) exec-cpp))
|
||||
(and=> (read-cpp-line ch) eval-cpp-line))
|
||||
|
||||
(define (read-token)
|
||||
(let iter ((ch (read-char)))
|
||||
|
|
@ -434,8 +417,7 @@
|
|||
(cond
|
||||
((read-comm ch bol) => assc-$)
|
||||
((read-cpp ch) =>
|
||||
(lambda (res)
|
||||
;; not pair means expand include file, so loop again
|
||||
(lambda (res) ;; if '() stmt expanded so re-read
|
||||
(if (pair? res) (assc-$ res) (iter (read-char)))))
|
||||
(else (set! bol #f) (iter ch))))
|
||||
((read-ident ch) =>
|
||||
|
|
@ -466,19 +448,15 @@
|
|||
(else (cons ch (string ch))))))
|
||||
|
||||
;; Loop between reading tokens and skipping tokens via CPP logic.
|
||||
(let loop ((pair (read-token)))
|
||||
(simple-format #t "ppxs=~S ~S\n" ppxs
|
||||
(port-line (current-input-port)))
|
||||
(let iter ((pair (read-token)))
|
||||
(case (car ppxs)
|
||||
((keep)
|
||||
(no-cpp!)
|
||||
(simple-format #t "token=~S\n" pair)
|
||||
pair)
|
||||
((skip-done skip-look)
|
||||
(loop (read-token)))
|
||||
(iter (read-token)))
|
||||
((skip1-pop)
|
||||
(set! ppxs (cdr ppxs))
|
||||
(loop (read-token)))))
|
||||
(iter (read-token)))))
|
||||
)))))
|
||||
|
||||
|
||||
;; --- last line ---
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;; 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
|
||||
#line defined #-operator ##-operator #pragma #error
|
||||
|
||||
strategy:
|
||||
don't expand macro calls -- treat like function calls, but provide dict
|
||||
todo:
|
||||
pragma
|
||||
#-op ##-op
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;; 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
|
||||
;;; 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
|
||||
;; 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
|
||||
;; parsed expression may include terms which are cpp-defined
|
||||
;; and should be evaluated lazy mode.
|
||||
;; @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.
|
||||
(define (parse-cpp-expr text)
|
||||
(with-input-from-string text
|
||||
(lambda () (raw-parser (gen-cpp-lexer)))))
|
||||
(catch
|
||||
'nyacc-error
|
||||
(lambda ()
|
||||
(with-input-from-string text
|
||||
(lambda () (raw-parser (gen-cpp-lexer)))))
|
||||
(lambda (key fmt . args)
|
||||
(apply throw 'cpp-error fmt args))))
|
||||
|
||||
;; @deffn eval-cpp-expr tree dict => datum
|
||||
;; Evaluate a tree produced from
|
||||
;; This should be updated to use @code{expand-cpp-def}. See below.
|
||||
(use-modules (ice-9 pretty-print))
|
||||
;; Evaluate a tree produced from @code{parse-cpp-expr}.
|
||||
;; The tree passed to this routine is
|
||||
(define (eval-cpp-expr tree dict)
|
||||
;;(display "eval-cpp-expr:\n") (pretty-print tree)
|
||||
(letrec
|
||||
((tx (lambda (tr ix) (list-ref tr ix)))
|
||||
(tx1 (lambda (tr) (tx tr 1)))
|
||||
(ev (lambda (ex ix) (eval-expr (list-ref ex ix))))
|
||||
(ev1 (lambda (ex) (ev ex 1)))
|
||||
(ev2 (lambda (ex) (ev ex 2)))
|
||||
(ev3 (lambda (ex) (ev ex 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))))
|
||||
(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)
|
||||
;;((ident) (parse-and-eval (assoc-ref dict (tx1 tree))))
|
||||
((fixed) (string->number (tx1 tree)))
|
||||
((char) (char->integer (tx1 tree)))
|
||||
((defined) (if (assoc-ref dict (tx1 tree)) 1 0))
|
||||
|
|
@ -77,8 +88,9 @@
|
|||
((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)))
|
||||
((ident) (error "text should not have identifiers"))
|
||||
(else (error "incomplete implementation"))))))
|
||||
(catch 'parse-error
|
||||
(catch 'cpp-error
|
||||
(lambda () (eval-expr tree))
|
||||
(lambda () #f))))
|
||||
|
||||
|
|
@ -102,7 +114,7 @@
|
|||
;; E.g., scanned "defined", now scan "(FOO)", and return "defined(FOO)".
|
||||
(define (scan-defined)
|
||||
(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)
|
||||
(string-append "defined" (list->string (reverse (cons ch chl)))))
|
||||
(else (iter (cons ch chl) (read-char))))))
|
||||
|
|
@ -113,7 +125,6 @@
|
|||
(nxt #f) ; next string
|
||||
(lvl 0) ; level
|
||||
(ch (read-char))) ; next character
|
||||
;;(simple-format #t "iter stl=~S chl=~S nxt=~S ch=~S\n" stl chl nxt ch)
|
||||
(cond
|
||||
;; have item to add, but first add in char's
|
||||
(nxt (iter (cons nxt (add-chl chl stl)) '() #f lvl ch))
|
||||
|
|
@ -136,7 +147,6 @@
|
|||
(lambda (st) (iter stl chl st lvl (read-char))))
|
||||
((read-c-ident ch) =>
|
||||
(lambda (iden)
|
||||
;;(simple-format #t " iden=~S\n" iden)
|
||||
(if (equal? iden "defined")
|
||||
;; "defined" is a special case
|
||||
(iter stl chl (scan-defined) lvl (read-char))
|
||||
|
|
@ -162,25 +172,18 @@
|
|||
(iter stl (cons ch chl) #f lvl (read-char))))))
|
||||
|
||||
(define (collect-args argd dict used)
|
||||
;;(simple-format #t "collect-args\n")
|
||||
(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)))
|
||||
(if (not (eqv? (skip-ws (read-char)) #\()) (cpp-err "CPP expecting `('"))
|
||||
(let iter ((argl (list (scan-cpp-input argd dict used #t))))
|
||||
;;(simple-format #t "args: ~S\n" argl)
|
||||
(let ((ch (read-char)))
|
||||
(if (eqv? ch #\)) (reverse argl)
|
||||
(iter (cons (scan-cpp-input argd dict used #t) argl))))))
|
||||
|
||||
(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
|
||||
(lambda () (scan-cpp-input argd dict used #f))))
|
||||
|
||||
;; @deffn cpp-expand-text text dict => string
|
||||
(define (cpp-expand-text text dict)
|
||||
;;(simple-format #t "cpp-expand-text: ~S\n" text)
|
||||
(with-input-from-string text
|
||||
(lambda () (scan-cpp-input '() dict '() #f))))
|
||||
|
||||
|
|
@ -191,7 +194,6 @@
|
|||
;; to a macro with arguments, then the arguments will be read from the
|
||||
;; current input.
|
||||
(define (expand-cpp-mref ident dict . rest)
|
||||
|
||||
(let ((used (if (pair? rest) (car rest) '()))
|
||||
(rval (assoc-ref dict ident)))
|
||||
(cond
|
||||
|
|
@ -199,14 +201,12 @@
|
|||
((member ident used) ident)
|
||||
((string? rval)
|
||||
(let ((expd (expand-cpp-repl rval '() dict (cons ident used))))
|
||||
;;(simple-format #t "expand ~S => ~S\n" ident expd)
|
||||
expd))
|
||||
((pair? rval)
|
||||
(let* ((args (car rval)) (repl (cdr rval))
|
||||
(argv (collect-args '() dict '()))
|
||||
(argd (map cons args argv))
|
||||
(expd (expand-cpp-repl repl argd dict (cons ident used))))
|
||||
;;(simple-format #t "expand ~S => ~S\n" ident expd)
|
||||
expd)))))
|
||||
|
||||
;;; --- last line ---
|
||||
|
|
|
|||
|
|
@ -32,7 +32,8 @@
|
|||
|
||||
(define cpp-spec
|
||||
(lalr-spec
|
||||
(notice lang-crn-lic)
|
||||
(notice (string-append "Copyright (C) 2016,2017 Matthew R. Wette"
|
||||
lang-crn-lic))
|
||||
(expect 0)
|
||||
(start conditional-expression)
|
||||
(grammar
|
||||
|
|
@ -135,8 +136,6 @@
|
|||
(b (move-if-changed (xtra-dir "cpptab.scm.new")
|
||||
(xtra-dir "cpptab.scm"))))
|
||||
(when (or a b)
|
||||
(system (string-append "touch " (lang-dir "cpp.scm")))
|
||||
#;(compile-file (lang-dir "cpp.scm"))
|
||||
)))
|
||||
(system (string-append "touch " (lang-dir "cpp.scm"))))))
|
||||
|
||||
;; --- last line ---
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;; ./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,
|
||||
;; or any later version published by the Free Software Foundation. See
|
||||
|
|
@ -8,10 +8,8 @@
|
|||
|
||||
(define act-v
|
||||
(vector
|
||||
;; $start => translation-unit-proxy
|
||||
;; $start => translation-unit
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; translation-unit-proxy => translation-unit
|
||||
(lambda ($1 . $rest) (tl->list $1))
|
||||
;; primary-expression => identifier
|
||||
(lambda ($1 . $rest) `(p-expr ,$1))
|
||||
;; primary-expression => constant
|
||||
|
|
@ -622,23 +620,19 @@
|
|||
(lambda ($3 $2 $1 . $rest) (list 'array-dsgr $2))
|
||||
;; designator => "." identifier
|
||||
(lambda ($2 $1 . $rest) (list 'sel-dsgr $2))
|
||||
;; statement => $P2 statement-1
|
||||
(lambda ($2 $1 . $rest) $2)
|
||||
;; $P2 =>
|
||||
(lambda $rest (cpp-ok!))
|
||||
;; statement-1 => labeled-statement
|
||||
;; statement => labeled-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => compound-statement
|
||||
;; statement => compound-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => expression-statement
|
||||
;; statement => expression-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => selection-statement
|
||||
;; statement => selection-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => iteration-statement
|
||||
;; statement => iteration-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => jump-statement
|
||||
;; statement => jump-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => cpp-statement
|
||||
;; statement => cpp-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; labeled-statement => identifier ":" statement
|
||||
(lambda ($3 $2 $1 . $rest)
|
||||
|
|
@ -694,7 +688,7 @@
|
|||
;; opt-expression => expression
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; jump-statement => "goto" identifier ";"
|
||||
(lambda ($3 $2 $1 . $rest) `(goto $2))
|
||||
(lambda ($3 $2 $1 . $rest) `(goto ,$2))
|
||||
;; jump-statement => "continue" ";"
|
||||
(lambda ($2 $1 . $rest) '(continue))
|
||||
;; jump-statement => "break" ";"
|
||||
|
|
@ -703,32 +697,30 @@
|
|||
(lambda ($3 $2 $1 . $rest) `(return ,$2))
|
||||
;; jump-statement => "return" ";"
|
||||
(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))
|
||||
;; translation-unit => translation-unit external-declaration
|
||||
;; external-declaration-list => external-declaration-list external-decla...
|
||||
(lambda ($2 $1 . $rest)
|
||||
(if (eqv? (sx-tag $2) 'extern-block)
|
||||
(tl-extend $1 (sx-tail $2))
|
||||
(tl-extend $1 (sx-tail $2 2))
|
||||
(tl-append $1 $2)))
|
||||
;; external-declaration => $P3 external-declaration-1
|
||||
(lambda ($2 $1 . $rest) $2)
|
||||
;; $P3 =>
|
||||
(lambda $rest (cpp-ok!))
|
||||
;; external-declaration-1 => function-definition
|
||||
;; external-declaration => function-definition
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; external-declaration-1 => declaration
|
||||
;; external-declaration => declaration
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; external-declaration-1 => lone-comment
|
||||
;; external-declaration => lone-comment
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; external-declaration-1 => cpp-statement
|
||||
;; external-declaration => cpp-statement
|
||||
(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)
|
||||
`(extern-block
|
||||
$2
|
||||
(extern-C-begin)
|
||||
$4
|
||||
(extern-C-end)))
|
||||
,$2
|
||||
(extern-begin ,$2)
|
||||
,@(sx-tail (tl->list $4) 1)
|
||||
(extern-end)))
|
||||
;; function-definition => declaration-specifiers declarator declaration-...
|
||||
(lambda ($4 $3 $2 $1 . $rest)
|
||||
`(knr-fctn-defn
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -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,
|
||||
;; or any later version published by the Free Software Foundation. See
|
||||
;; the file COPYING included with the this distribution.
|
||||
;; or any later version published by the Free Software Foundation. See the
|
||||
;; file COPYING included with the this distribution.
|
||||
|
||||
(define act-v
|
||||
(vector
|
||||
|
|
@ -399,10 +399,10 @@
|
|||
;; struct-declarator => ":" constant-expression
|
||||
(lambda ($2 $1 . $rest)
|
||||
`(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)
|
||||
`(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)
|
||||
`(enum-def ,$2 ,(tl->list $4)))
|
||||
;; enum-specifier => "enum" "{" enumerator-list "}"
|
||||
|
|
@ -411,7 +411,7 @@
|
|||
;; enum-specifier => "enum" "{" enumerator-list "," "}"
|
||||
(lambda ($5 $4 $3 $2 $1 . $rest)
|
||||
`(enum-def ,(tl->list $3)))
|
||||
;; enum-specifier => "enum" ident-like
|
||||
;; enum-specifier => "enum" identifier
|
||||
(lambda ($2 $1 . $rest) `(enum-ref ,$2))
|
||||
;; enumerator-list => enumerator
|
||||
(lambda ($1 . $rest) (make-tl 'enum-def-list $1))
|
||||
|
|
@ -622,23 +622,19 @@
|
|||
(lambda ($3 $2 $1 . $rest) (list 'array-dsgr $2))
|
||||
;; designator => "." identifier
|
||||
(lambda ($2 $1 . $rest) (list 'sel-dsgr $2))
|
||||
;; statement => $P2 statement-1
|
||||
(lambda ($2 $1 . $rest) $2)
|
||||
;; $P2 =>
|
||||
(lambda $rest (cpp-ok!))
|
||||
;; statement-1 => labeled-statement
|
||||
;; statement => labeled-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => compound-statement
|
||||
;; statement => compound-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => expression-statement
|
||||
;; statement => expression-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => selection-statement
|
||||
;; statement => selection-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => iteration-statement
|
||||
;; statement => iteration-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => jump-statement
|
||||
;; statement => jump-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; statement-1 => cpp-statement
|
||||
;; statement => cpp-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; labeled-statement => identifier ":" statement
|
||||
(lambda ($3 $2 $1 . $rest)
|
||||
|
|
@ -707,28 +703,22 @@
|
|||
(lambda ($1 . $rest) (make-tl 'trans-unit $1))
|
||||
;; translation-unit => translation-unit external-declaration
|
||||
(lambda ($2 $1 . $rest)
|
||||
(if (eqv? (sx-tag $2) 'extern-block)
|
||||
(tl-extend $1 (sx-tail $2))
|
||||
(tl-append $1 $2)))
|
||||
;; external-declaration => $P3 external-declaration-1
|
||||
(lambda ($2 $1 . $rest) $2)
|
||||
;; $P3 =>
|
||||
(lambda $rest (cpp-ok!))
|
||||
;; external-declaration-1 => function-definition
|
||||
(cond ((eqv? 'trans-unit (car $2))
|
||||
(let* ((t1 (tl-append $1 '(extern-C-begin)))
|
||||
(t2 (tl-extend t1 (cdr $2)))
|
||||
(t3 (tl-append t2 '(extern-C-end))))
|
||||
t3))
|
||||
(else (tl-append $1 $2))))
|
||||
;; external-declaration => function-definition
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; external-declaration-1 => declaration
|
||||
;; external-declaration => declaration
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; external-declaration-1 => lone-comment
|
||||
;; external-declaration => lone-comment
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; external-declaration-1 => cpp-statement
|
||||
;; external-declaration => cpp-statement
|
||||
(lambda ($1 . $rest) $1)
|
||||
;; external-declaration-1 => "extern" '$string "{" translation-unit "}"
|
||||
(lambda ($5 $4 $3 $2 $1 . $rest)
|
||||
`(extern-block
|
||||
$2
|
||||
(extern-C-begin)
|
||||
$4
|
||||
(extern-C-end)))
|
||||
;; external-declaration => "extern" '$string "{" translation-unit "}"
|
||||
(lambda ($5 $4 $3 $2 $1 . $rest) (tl->list $4))
|
||||
;; function-definition => declaration-specifiers declarator declaration-...
|
||||
(lambda ($4 $3 $2 $1 . $rest)
|
||||
`(knr-fctn-defn
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -1,6 +1,6 @@
|
|||
;; ./mach.d/cppact.scm
|
||||
|
||||
;;
|
||||
;; Copyright (C) 2016,2017 Matthew R. Wette
|
||||
;;
|
||||
;; This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3,
|
||||
;; or any later version published by the Free Software Foundation. See
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;; ./mach.d/cpptab.scm
|
||||
|
||||
;;
|
||||
;; Copyright (C) 2016,2017 Matthew R. Wette
|
||||
;;
|
||||
;; This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3,
|
||||
;; or any later version published by the Free Software Foundation. See
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;; it under the terms of the GNU General Public License as published by
|
||||
|
|
@ -26,9 +26,7 @@
|
|||
#:use-module (nyacc parse)
|
||||
#:use-module (nyacc lex)
|
||||
#:use-module (nyacc util)
|
||||
#:use-module ((srfi srfi-9) #:select (define-record-type))
|
||||
#:use-module ((srfi srfi-43) #:select (vector-map))
|
||||
#:use-module ((sxml xpath) #:select (sxpath))
|
||||
)
|
||||
|
||||
;; @item c99-spec
|
||||
|
|
@ -38,16 +36,15 @@
|
|||
;; The output of the end parser will be a SXML tree (w/o the @code{*TOP*} node.
|
||||
(define c99-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< 'imp ; "implied type" SR-conflict resolution
|
||||
"char" "short" "int" "long"
|
||||
"float" "double" "_Complex")
|
||||
(start translation-unit-proxy)
|
||||
(start translation-unit)
|
||||
(grammar
|
||||
|
||||
(translation-unit-proxy (translation-unit ($$ (tl->list $1))))
|
||||
|
||||
;; expressions
|
||||
(primary-expression ; S 6.5.1
|
||||
(identifier ($$ `(p-expr ,$1)))
|
||||
|
|
@ -540,8 +537,6 @@
|
|||
|
||||
;; statements
|
||||
(statement
|
||||
(($$ (cpp-ok!)) statement-1 ($$ $2)))
|
||||
(statement-1
|
||||
(labeled-statement)
|
||||
(compound-statement)
|
||||
(expression-statement)
|
||||
|
|
@ -602,7 +597,7 @@
|
|||
(expression))
|
||||
|
||||
(jump-statement ; S 6.8.6
|
||||
("goto" identifier ";" ($$ `(goto $2)))
|
||||
("goto" identifier ";" ($$ `(goto ,$2)))
|
||||
("continue" ";" ($$ '(continue)))
|
||||
("break" ";" ($$ '(break)))
|
||||
("return" expression ";" ($$ `(return ,$2)))
|
||||
|
|
@ -610,24 +605,25 @@
|
|||
)
|
||||
|
||||
;; external definitions
|
||||
(translation-unit
|
||||
(translation-unit (external-declaration-list ($$ (tl->list $1))))
|
||||
|
||||
(external-declaration-list
|
||||
(external-declaration ($$ (make-tl 'trans-unit $1)))
|
||||
(translation-unit
|
||||
(external-declaration-list
|
||||
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))))
|
||||
)
|
||||
|
||||
(external-declaration
|
||||
(($$ (cpp-ok!)) external-declaration-1 ($$ $2)))
|
||||
(external-declaration-1
|
||||
(function-definition)
|
||||
(declaration)
|
||||
(lone-comment)
|
||||
(cpp-statement)
|
||||
;; The following is a kludge to deal with @code{extern "C" @{ ...}.
|
||||
("extern" $string "{" translation-unit "}"
|
||||
($$ `(extern-block $2 (extern-C-begin) $4 (extern-C-end))))
|
||||
("extern" $string "{" external-declaration-list "}"
|
||||
($$ `(extern-block ,$2 (extern-begin ,$2)
|
||||
,@(sx-tail (tl->list $4) 1) (extern-end))))
|
||||
)
|
||||
|
||||
(function-definition
|
||||
|
|
@ -697,15 +693,16 @@
|
|||
(xdef? #f) ; expand def function: proc name mode
|
||||
(debug #f)) ; debug
|
||||
(catch
|
||||
'parse-error
|
||||
#t ;; 'c99-error 'cpp-error 'nyacc-error
|
||||
(lambda ()
|
||||
(let ((info (make-cpi debug cpp-defs (cons "." inc-dirs) td-dict)))
|
||||
(with-fluid* *info* info
|
||||
(lambda ()
|
||||
(raw-parser (gen-c-lexer #:mode mode #:xdef? xdef?)
|
||||
#:debug debug)))))
|
||||
(with-fluid*
|
||||
*info* info
|
||||
(lambda ()
|
||||
(raw-parser (gen-c-lexer #:mode mode #:xdef? xdef?)
|
||||
#:debug debug)))))
|
||||
(lambda (key fmt . rest)
|
||||
(apply simple-format (current-error-port) (string-append fmt "\n") rest)
|
||||
(report-error fmt rest)
|
||||
#f)))
|
||||
|
||||
(define dev-parse-c dev-parse-c99)
|
||||
|
|
@ -729,9 +726,7 @@
|
|||
(b (move-if-changed (xtra-dir "c99tab.scm.new")
|
||||
(xtra-dir "c99tab.scm"))))
|
||||
(when (or a b)
|
||||
(system (string-append "touch " (lang-dir "parser.scm")))
|
||||
#;(compile-file (lang-dir "parser.scm"))
|
||||
)))
|
||||
(system (string-append "touch " (lang-dir "parser.scm"))))))
|
||||
|
||||
;; @item gen-c99x-files [dir] => #t
|
||||
;; Update or generate the files @quot{c99xact.scm} and @quot{c99xtab.scm}.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;; it under the terms of the GNU General Public License as published by
|
||||
|
|
@ -18,14 +18,15 @@
|
|||
;; C 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 parse)
|
||||
#:use-module (nyacc lang util)
|
||||
#: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
|
||||
|
|
@ -40,53 +41,75 @@
|
|||
(include-from-path "nyacc/lang/c99/mach.d/c99act.scm")
|
||||
|
||||
;; Parse given a token generator. Uses fluid @code{*info*}.
|
||||
;; A little ugly wrt re-throw but
|
||||
(define raw-parser
|
||||
;;(make-c99-ia-parser
|
||||
(make-lalr-parser
|
||||
(list
|
||||
(cons 'len-v len-v)
|
||||
(cons 'pat-v pat-v)
|
||||
(cons 'rto-v rto-v)
|
||||
(cons 'mtab mtab)
|
||||
(cons 'act-v act-v))))
|
||||
|
||||
(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))))
|
||||
(let ((c99-parser (make-lalr-parser
|
||||
(list (cons 'len-v len-v) (cons 'pat-v pat-v)
|
||||
(cons 'rto-v rto-v) (cons 'mtab mtab)
|
||||
(cons 'act-v act-v)))))
|
||||
(lambda* (lexer #:key (debug #f))
|
||||
(with-throw-handler
|
||||
'nyacc-error
|
||||
(lambda () (c99-parser lexer #:debug debug))
|
||||
(lambda (key fmt . args) (apply throw 'c99-error fmt args))))))
|
||||
|
||||
;; This is used to parse included files at top level.
|
||||
(define (run-parse)
|
||||
(let ((info (fluid-ref *info*)))
|
||||
;;(raw-parser (my-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] \
|
||||
;; [#:mode ('code|'file)]
|
||||
;; @deffn parse-c99 [#:cpp-defs def-a-list] [#:inc-dirs dir-list] \
|
||||
;; [#:mode ('code|'file)] [#:debug bool]
|
||||
;; This needs to be explained in some detail.
|
||||
;; 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
|
||||
(cpp-defs '()) ; CPP defines
|
||||
(inc-dirs '()) ; include dirs
|
||||
(td-dict '()) ; typedef dictionary
|
||||
(mode 'file) ; mdoe: 'file or 'code
|
||||
(mode 'code) ; mode: 'file or 'code
|
||||
(xdef? #f) ; pred to determine expand
|
||||
(debug #f)) ; debug
|
||||
(catch
|
||||
'parse-error
|
||||
'c99-error
|
||||
(lambda ()
|
||||
(let ((info (make-cpi debug cpp-defs (cons "." inc-dirs) td-dict)))
|
||||
(with-fluid*
|
||||
*info* info
|
||||
(lambda ()
|
||||
(if (eqv? mode 'file) (cpp-ok!) (no-cpp!))
|
||||
(raw-parser (my-c-lexer #:mode mode #:xdef? xdef?)
|
||||
(raw-parser (gen-c-lexer #:mode mode #:xdef? xdef?)
|
||||
#:debug debug)))))
|
||||
(lambda (key fmt . rest)
|
||||
(apply simple-format (current-error-port) (string-append fmt "\n") rest)
|
||||
(report-error fmt rest)
|
||||
#f)))
|
||||
|
||||
(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 ---
|
||||
|
|
|
|||
|
|
@ -521,15 +521,16 @@
|
|||
((cpp-stmt . ,rest)
|
||||
(cpp-ppx (sx-ref tree 1)))
|
||||
|
||||
((extern-C-begin) (sf "extern \"C\" {\n"))
|
||||
((extern-C-end) (sf "}\n"))
|
||||
((extern-begin ,lang) (sf "extern \"~A\" {\n" lang))
|
||||
((extern-end) (sf "}\n"))
|
||||
|
||||
(,otherwise
|
||||
(simple-format #t "\n*** pprint/ppx: NO MATCH: ~S\n" (car tree)))
|
||||
))
|
||||
|
||||
(define ppx ppx-1)
|
||||
|
||||
|
||||
(if (not (pair? tree)) (error "expecing sxml tree"))
|
||||
(ppx tree)
|
||||
(if ugly (newline)))
|
||||
|
||||
|
|
|
|||
|
|
@ -49,20 +49,25 @@
|
|||
;; This needs to be explained in some detail.
|
||||
;; [#:tyns '("foo_t")]
|
||||
(define* (parse-c99x xstr
|
||||
#:key (cpp-defs '()) (tn-dict '()) (debug #f) (tyns '()))
|
||||
(catch
|
||||
'parse-error
|
||||
(lambda ()
|
||||
(let ((info (make-cpi debug cpp-defs '(".") tn-dict)))
|
||||
(set-cpi-ptl! info (cons tyns (cpi-ptl info)))
|
||||
(with-fluid*
|
||||
*info* info
|
||||
(lambda ()
|
||||
(with-input-from-string xstr
|
||||
(lambda ()
|
||||
(raw-parser (gen-c-lexer #:mode 'code) #:debug debug)))))))
|
||||
#: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
|
||||
#t
|
||||
(lambda ()
|
||||
(let ((info (make-cpi debug cpp-defs '(".") tn-dict)))
|
||||
(set-cpi-ptl! info (cons tyns (cpi-ptl info)))
|
||||
(with-fluid*
|
||||
*info* info
|
||||
(lambda ()
|
||||
(raw-parser (gen-c-lexer #:mode 'code #:xdef? xdef?)
|
||||
#:debug debug))))))
|
||||
(lambda (key fmt . rest)
|
||||
(apply simple-format (current-error-port) (string-append fmt "\n") rest)
|
||||
(report-error fmt rest)
|
||||
#f)))
|
||||
|
||||
(define parse-cx parse-c99x)
|
||||
|
|
|
|||
|
|
@ -9,20 +9,21 @@
|
|||
;; runtime utilities for the parsers -- needs work
|
||||
|
||||
(define-module (nyacc lang util)
|
||||
#:export (lang-crn-lic
|
||||
push-input pop-input reset-input-stack
|
||||
make-tl tl->list ;; rename?? to tl->sx for sxml-expr
|
||||
tl-append tl-insert tl-extend tl+attr
|
||||
sx-tag
|
||||
sx-attr sx-attr-ref sx-has-attr? sx-set-attr! sx-set-attr*
|
||||
sx-ref sx-tail sx-find
|
||||
;; for pretty-printing
|
||||
make-protect-expr make-pp-formatter make-pp-formatter/ugly
|
||||
;; for ???
|
||||
move-if-changed
|
||||
fmterr)
|
||||
#:use-module ((srfi srfi-1) #:select(find))
|
||||
)
|
||||
#:export (lang-crn-lic
|
||||
report-error
|
||||
push-input pop-input reset-input-stack
|
||||
make-tl tl->list ;; rename?? to tl->sx for sxml-expr
|
||||
tl-append tl-insert tl-extend tl+attr
|
||||
sx-tag
|
||||
sx-attr sx-attr-ref sx-has-attr? sx-set-attr! sx-set-attr*
|
||||
sx-ref sx-tail sx-find
|
||||
;; for pretty-printing
|
||||
make-protect-expr make-pp-formatter make-pp-formatter/ugly
|
||||
;; for ???
|
||||
move-if-changed
|
||||
fmterr)
|
||||
#:use-module ((srfi srfi-1) #:select(find))
|
||||
)
|
||||
|
||||
(cond-expand
|
||||
(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.")
|
||||
|
||||
(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 =====================
|
||||
|
||||
|
|
@ -79,9 +88,9 @@ the file COPYING included with the this distribution.")
|
|||
;; @deffn make-tl tag [item item ...]
|
||||
;; Create a tagged-list structure.
|
||||
(define (make-tl tag . rest)
|
||||
(let iter ((tail tag) (l rest))
|
||||
(if (null? l) (cons '() tail)
|
||||
(iter (cons (car l) tail) (cdr l)))))
|
||||
(let iter ((tail tag) (l rest))
|
||||
(if (null? l) (cons '() tail)
|
||||
(iter (cons (car l) tail) (cdr l)))))
|
||||
|
||||
;; @deffn tl->list tl
|
||||
;; Convert a tagged list structure to a list. This collects added attributes
|
||||
|
|
@ -90,37 +99,43 @@ the file COPYING included with the this distribution.")
|
|||
;; (<tag> (@ <attr>) <rest>)
|
||||
;; @end example
|
||||
(define (tl->list tl)
|
||||
(let ((heda (car tl))
|
||||
(head (let iter ((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)))
|
||||
(iter head (cons (cdar tl-head) attr) (cdr tl-head))
|
||||
(iter (cons (car tl-head) head) attr (cdr tl-head)))))))
|
||||
(let iter ((tail '()) (tl-tail (cdr tl)))
|
||||
(if (pair? tl-tail)
|
||||
(iter (cons (car tl-tail) tail) (cdr tl-tail))
|
||||
(cons tl-tail (append head tail))))))
|
||||
(let ((heda (car tl))
|
||||
(head (let iter ((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)))
|
||||
(iter head (cons (cdar tl-head) attr) (cdr tl-head))
|
||||
(iter (cons (car tl-head) head) attr (cdr tl-head)))))))
|
||||
(let iter ((tail '()) (tl-tail (cdr tl)))
|
||||
(if (pair? tl-tail)
|
||||
(iter (cons (car tl-tail) tail) (cdr tl-tail))
|
||||
(cons tl-tail (append head tail))))))
|
||||
|
||||
;; @deffn tl-insert tl item
|
||||
;; Insert item at front of tagged list (but after tag).
|
||||
(define (tl-insert tl item)
|
||||
(cons (cons item (car tl)) (cdr tl)))
|
||||
(cons (cons item (car tl)) (cdr tl)))
|
||||
|
||||
;; @deffn tl-append tl item ...
|
||||
;; Append item at end of tagged list.
|
||||
;; Append items at end of tagged list.
|
||||
(define (tl-append tl . rest)
|
||||
(cons (car tl)
|
||||
(let iter ((tail (cdr tl)) (items rest))
|
||||
(if (null? items) tail
|
||||
(iter (cons (car items) tail) (cdr items))))))
|
||||
(cons (car tl)
|
||||
(let iter ((tail (cdr tl)) (items rest))
|
||||
(if (null? items) tail
|
||||
(iter (cons (car items) tail) (cdr items))))))
|
||||
|
||||
;; @deffn tl-extend tl item-l
|
||||
;; Extend with a list of items.
|
||||
(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)
|
||||
;; 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")
|
||||
;; @end example
|
||||
(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
|
||||
;; Merge guts of phony-tl @code{tl1} into @code{tl}.
|
||||
(define (tl-merge tl tl1)
|
||||
(error "not implemented (yet)")
|
||||
)
|
||||
(error "not implemented (yet)")
|
||||
)
|
||||
|
||||
;; === 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 sx-ref sx ix => item
|
||||
;; Reference the @code{ix}-th element of the list, not counting the optional
|
||||
|
|
@ -147,78 +166,79 @@ the file COPYING included with the this distribution.")
|
|||
;; (sx-ref '(abc (@ (foo "1")) "def") 1) => "def"
|
||||
;; @end example
|
||||
(define (sx-ref sx ix)
|
||||
(define (list-xref l x) (if (> (length l) x) (list-ref l x) #f))
|
||||
(cond
|
||||
((zero? ix) (car sx))
|
||||
((and (pair? (cadr sx)) (eqv? '@ (caadr sx)))
|
||||
(list-xref sx (1+ ix)))
|
||||
(else
|
||||
(list-xref sx ix))))
|
||||
(define (list-xref l x) (if (> (length l) x) (list-ref l x) #f))
|
||||
(cond
|
||||
((zero? ix) (car sx))
|
||||
((and (pair? (cadr sx)) (eqv? '@ (caadr sx)))
|
||||
(list-xref sx (1+ ix)))
|
||||
(else
|
||||
(list-xref sx ix))))
|
||||
|
||||
;; @deffn sx-tag sx => tag
|
||||
;; Return the tag for a tree
|
||||
(define (sx-tag sx)
|
||||
(if (pair? sx) (car sx) #f))
|
||||
(if (pair? sx) (car sx) #f))
|
||||
|
||||
;; @deffn sx-tail sx ix => (list)
|
||||
;; 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 '().
|
||||
;; BUG: not working for (sx '(foo) 1)
|
||||
(define (sx-tail sx ix)
|
||||
(if (zero? ix) (error "zero index not supported"))
|
||||
(let ((sx (cdr sx)) (ix (1- ix)))
|
||||
(cond
|
||||
((and (null? sx) (zero? ix)) sx)
|
||||
((and (pair? (car sx)) (eqv? '@ (caar sx))) (list-tail sx (1+ ix)))
|
||||
(else (list-tail sx ix)))))
|
||||
(cond
|
||||
((zero? ix) (error "sx-tail: expecting index greater than 0"))
|
||||
((and (pair? (cdr sx)) (eqv? '@ (cadr sx))) (list-tail sx (1+ ix)))
|
||||
(else (list-tail sx ix))))
|
||||
|
||||
;; @deffn sx-has-attr? sx
|
||||
;; p to determine if @arg{sx} has attributes.
|
||||
(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
|
||||
;; @example
|
||||
;; (sx-attr '(abc (@ (foo "1")) def) 1) => '(@ (foo "1"))
|
||||
;; @end example
|
||||
;; should change this to
|
||||
;; @example
|
||||
;; (sx-attr sx) => '((a . 1) (b . 2) ...)
|
||||
;; @end example
|
||||
(define (sx-attr sx)
|
||||
(if (and (pair? (cdr sx)) (pair? (cadr sx)))
|
||||
(if (eqv? '@ (caadr sx))
|
||||
(cadr sx)
|
||||
#f)
|
||||
#f))
|
||||
(if (and (pair? (cdr sx)) (pair? (cadr sx)))
|
||||
(if (eqv? '@ (caadr sx))
|
||||
(cadr sx)
|
||||
#f)
|
||||
#f))
|
||||
|
||||
;; @deffn sx-attr-ref sx key => val
|
||||
;; Return an attribute value given the key, or @code{#f}.
|
||||
(define (sx-attr-ref sx key)
|
||||
(and=> (sx-attr sx)
|
||||
(lambda (attr)
|
||||
(and=> (assq-ref (cdr attr) key) car))))
|
||||
(and=> (sx-attr sx)
|
||||
(lambda (attr)
|
||||
(and=> (assq-ref (cdr attr) key) car))))
|
||||
|
||||
;; @deffn sx-set-attr! sx key val
|
||||
;; Set attribute for sx. If no attributes exist, if key does not exist,
|
||||
;; add it, if it does exist, replace it.
|
||||
(define (sx-set-attr! sx key val . rest)
|
||||
(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)
|
||||
(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 sx-set-attr* sx key val [key val [key ... ]]
|
||||
;; Set attribute for sx. If no attributes exist, if key does not exist,
|
||||
;; add it, if it does exist, replace it.
|
||||
(define (sx-set-attr* sx . rest)
|
||||
(let iter ((attr (or (and=> (sx-attr sx) cdr) '())) (kvl rest))
|
||||
(cond
|
||||
((null? kvl) (cons* (sx-tag sx) (cons '@ (reverse attr)) (sx-tail sx 1)))
|
||||
(else (iter (cons (list (car kvl) (cadr kvl)) attr) (cddr kvl))))))
|
||||
(let iter ((attr (or (and=> (sx-attr sx) cdr) '())) (kvl rest))
|
||||
(cond
|
||||
((null? kvl) (cons* (sx-tag sx) (cons '@ (reverse attr)) (sx-tail sx 1)))
|
||||
(else (iter (cons (list (car kvl) (cadr kvl)) attr) (cddr kvl))))))
|
||||
|
||||
;; @deffn sx-find tag sx => ((tag ...) (tag ...))
|
||||
;; Find the first matching element (in the first level).
|
||||
(define (sx-find tag sx)
|
||||
(find (lambda (node)
|
||||
(and (pair? node) (eqv? tag (car node))))
|
||||
(and (pair? node) (eqv? tag (car node))))
|
||||
sx))
|
||||
|
||||
;;; === pp ==========================
|
||||
|
|
|
|||
|
|
@ -385,7 +385,7 @@
|
|||
;; @deffn 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") ("/*" "*/")
|
||||
;; 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.
|
||||
|
|
|
|||
|
|
@ -20,9 +20,7 @@
|
|||
;; e.g., if comment not in latok, just throw away
|
||||
|
||||
(define-module (nyacc parse)
|
||||
#:export (make-lalr-parser
|
||||
make-lalr-ia-parser
|
||||
)
|
||||
#:export (make-lalr-parser make-lalr-ia-parser)
|
||||
#:use-module (ice-9 optargs)
|
||||
#:use-module (nyacc util)
|
||||
#:use-module ((srfi srfi-43) #:select (vector-map vector-for-each))
|
||||
|
|
@ -116,12 +114,9 @@
|
|||
(else ;; other action: skip, error, or accept
|
||||
(case oact
|
||||
((skip) (iter state stack nval (lexr)))
|
||||
((error)
|
||||
(let ((fn (or (port-filename (current-input-port)) "(unknown)"))
|
||||
(ln (1+ (port-line (current-input-port)))))
|
||||
(fmterr "~A:~A: parse failed at state ~A, on input ~S\n"
|
||||
fn ln (car state) sval)
|
||||
#f))
|
||||
((error) (throw 'nyacc-error
|
||||
"parse failed at state ~A, on input ~S"
|
||||
(car state) sval))
|
||||
(else ;; accept
|
||||
(car stack))))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -244,7 +244,7 @@
|
|||
(if (not (null? l))
|
||||
(let ((ix (hashq-ref ht (car l))))
|
||||
(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)
|
||||
(visit ix))
|
||||
(iter (cdr l)))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue