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

nyacc: misc updates; see ChangeLog

Browse source
This commit is contained in:
Matt Wette 2016-12-25 19:31:09 -08:00 committed by Jan Nieuwenhuizen
parent 4c4706f17e
commit e589c81c8d
9 changed files with 116 additions and 37 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
module/nyacc/ChangeLog
View file

@ -1,3 +1,11 @@
2016-11-25 Matt Wette <mwette@nautilus>
* added support for ellipsis to lang/c99/cpp.scm
2016-11-24 Matt Wette <mwette@nautilus>
* added (ellipsis) to lang/c99/pprint.scm
2016-04-09 Matt Wette <mwette@nautilus>
* bison.scm: new file providing make-lalr-machin/bison. It is

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

@ -34,32 +34,37 @@
)
(define std-dict
'(("time.h" "time_t" "clock_t" "size_t")
("stdio.h" "FILE" "size_t")
("string.h" "size_t")
("stddef.h" "ptrdiff_t" "size_t" "wchar_t")
'(
("alloca.h")
("complex.h" "complex" "imaginary")
("ctype.h")
("fenv.h" "fenv_t" "fexcept_t")
("float.h" "float_t")
("inttypes.h"
"int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
"int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
"int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
"int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t"
"imaxdiv_t")
("limits.h")
("math.h")
("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"
"int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
"int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
"int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
"int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t")
("stdio.h" "FILE" "size_t")
("stdlib.h" "div_t" "ldiv_t" "lldiv_t" "wchar_t")
("stdarg.h" "va_list")
;;("unistd.h" "div_t" "ldiv_t")
("signal.h" "sig_atomic_t")
("setjmp.h" "jmp_buf")
("float.h" "float_t")
("fenv.h" "fenv_t" "fexcept_t")
("complex.h" "complex" "imaginary")
("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")
("math.h")
))
(define (make-cpi debug defines incdirs tn-dict)

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

@ -57,6 +57,15 @@ todo:
(if (char-set-contains? c:ws ch)
(skip-ws (read-char))
ch)))
;; @deffn read-ellipsis ch
;; read ellipsis
(define (read-ellipsis ch)
(cond
((eof-object? ch) #f)
((char=? ch #\.) (read-char) (read-char) "...")
(else #f)))
;; @deffn cpp-define => #f|???
(define (cpp-define)
;; The (weak?) parse architecture is "unread la argument if no match"
@ -79,6 +88,8 @@ todo:
((eq? la #\)) (reverse args))
((read-c-ident la) =>
(lambda (arg) (iter (cons arg args) (skip-ws (read-char)))))
((read-ellipsis la) =>
(lambda (arg) (iter (cons arg args) (skip-ws (read-char)))))
((eq? la #\,)
(iter args (skip-ws (read-char))))))
(begin (if (char? la) (unread-char la)) #f)))) ;; CLEANUP

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

@ -149,7 +149,7 @@
(lambda ($1 . $rest) $1)
;; conditional-expression => logical-or-expression "?" expression ":" co...
(lambda ($5 $4 $3 $2 $1 . $rest)
`(cond-expr ,$1 ,$2 ,$3))
`(cond-expr ,$1 ,$3 ,$5))
;; assignment-expression => conditional-expression
(lambda ($1 . $rest) $1)
;; assignment-expression => unary-expression assignment-operator assignm...
@ -494,7 +494,7 @@
(lambda ($1 . $rest) $1)
;; parameter-type-list => parameter-list "," "..."
(lambda ($3 $2 $1 . $rest)
(tl-append $1 '(ellipis)))
(tl-append $1 '(ellipsis)))
;; parameter-list => parameter-declaration
(lambda ($1 . $rest) (make-tl 'param-list $1))
;; parameter-list => parameter-list "," parameter-declaration

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

@ -149,7 +149,7 @@
(lambda ($1 . $rest) $1)
;; conditional-expression => logical-or-expression "?" expression ":" co...
(lambda ($5 $4 $3 $2 $1 . $rest)
`(cond-expr ,$1 ,$2 ,$3))
`(cond-expr ,$1 ,$3 ,$5))
;; assignment-expression => conditional-expression
(lambda ($1 . $rest) $1)
;; assignment-expression => unary-expression assignment-operator assignm...
@ -494,7 +494,7 @@
(lambda ($1 . $rest) $1)
;; parameter-type-list => parameter-list "," "..."
(lambda ($3 $2 $1 . $rest)
(tl-append $1 '(ellipis)))
(tl-append $1 '(ellipsis)))
;; parameter-list => parameter-declaration
(lambda ($1 . $rest) (make-tl 'param-list $1))
;; parameter-list => parameter-list "," parameter-declaration

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

@ -171,7 +171,7 @@
(conditional-expression
(logical-or-expression)
(logical-or-expression "?" expression ":" conditional-expression
($$ `(cond-expr ,$1 ,$2 ,$3)))
($$ `(cond-expr ,$1 ,$3 ,$5)))
)
(assignment-expression ; S 6.5.16
@ -423,7 +423,7 @@
(parameter-type-list
(parameter-list ($$ $1))
(parameter-list "," "..." ($$ (tl-append $1 '(ellipis))))
(parameter-list "," "..." ($$ (tl-append $1 '(ellipsis))))
)
(parameter-list

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

@ -94,7 +94,8 @@
((pragma ,text) (sf "#pragma ~A\n" text))
(,otherwise
(simple-format #t "\n*** pprint/cpp-ppx: NO MATCH: ~S\n" tree))
))
)
(fmtr 'nlin))
(define (unary/l op rep rval)
(sf rep)
@ -103,10 +104,10 @@
(ppx rval)))
(define (unary/r op rep lval)
(sf rep)
(if (protect-expr? 'lt op lval)
(ppx/p lval)
(ppx lval)))
(ppx lval))
(sf rep))
(define (binary op rep lval rval)
(if (protect-expr? 'lt op lval)
@ -125,8 +126,10 @@
(case (sx-tag iexpr)
((initzer-list)
(sf "{")
(sf "initzer-list") ; TODO
(sf " }"))
(for-each
(lambda (expr) (ppx (sx-ref expr 1)) (sf ", "))
(sx-tail iexpr 1))
(sf "}"))
(else
(ppx iexpr))))))
@ -158,7 +161,7 @@
(if (pair? (cdr pair)) (sf " ")))
value-l))
((comment ,text) (sf "/*~A */\n" text))
((comment ,text) (sf "/*~A*/\n" text))
((scope ,expr) (sf "(") (ppx expr) (sf ")"))
@ -191,6 +194,9 @@
((div ,lval ,rval) (binary 'div "/" lval rval))
((mod ,lval ,rval) (binary 'mod "%" lval rval))
((lshift ,lval ,rval) (binary 'lshift "<<" lval rval))
((rshift ,lval ,rval) (binary 'lshift "<<" lval rval))
((lt ,lval ,rval) (binary 'lt " < " lval rval))
((gt ,lval ,rval) (binary 'gt " > " lval rval))
@ -203,6 +209,13 @@
((bitwise-or ,lval ,rval) (binary 'bitwise-and " | " lval rval))
((bitwise-xor ,lval ,rval) (binary 'bitwise-xor " ^ " lval rval))
((and ,lval ,rval) (binary 'and " && " lval rval))
((or ,lval ,rval) (binary 'and " || " lval rval))
;; CHECK THIS
((cond-expr ,cond ,tval ,fval)
(ppx cond) (sf "? ") (ppx tval) (sf ": ") (ppx fval))
((post-inc ,expr) (unary/r 'post-inc "++" expr))
((post-dec ,expr) (unary/r 'post-dec "--" expr))
@ -268,11 +281,11 @@
(let iter ((dsl dsl))
(when (pair? dsl)
(case (sx-tag (car dsl))
((stor-spec) (sf "~A" (car (sx-ref (car dsl) 1))))
((type-qual) (sf "qual=~A" (sx-ref (car dsl) 1)))
((stor-spec) (sf "~A " (car (sx-ref (car dsl) 1))))
((type-qual) (sf "~A " (sx-ref (car dsl) 1)))
((type-spec) (ppx (car dsl)))
(else (sf "[?:~S] " (car dsl))))
(if (pair? (cdr dsl)) (sf " "))
;;(if (pair? (cdr dsl)) (sf " "))
(iter (cdr dsl)))))
((init-declr-list . ,rest)
@ -419,6 +432,11 @@
(sf "default:\n")
(push-il) (ppx stmt) (pop-il))
;; CHECK THIS
((while ,expr ,stmt)
(sf "while (") (ppx expr) (sf ") ") (ppx stmt)
)
;; This does not meet the convention of "} while" on same line.
((do-while ,stmt ,expr)
(sf "do ")
@ -489,6 +507,9 @@
(lambda (pair) (ppx (car pair)) (if (pair? (cdr pair)) (sf ", ")))
params))
((ellipsis) ;; should work
(sf "..."))
((param-decl ,decl-spec-list ,param-declr)
(ppx decl-spec-list) (sf " ") (ppx param-declr))
((param-decl ,decl-spec-list)

34
module/nyacc/lang/c99/util2.scm
View file

@ -53,7 +53,7 @@
fix-fields
fixed-width-int-names
match-decl match-comp-decl
match-decl match-comp-decl match-param-decl
declr->ident
expand-decl-typerefs
)
@ -184,7 +184,7 @@
(cond
((or (not tbd) (eqv? 'comment (sx-tag tbd)))
(display "ISSUE: some decls have no init-declr-list\n")
;; no init-declr-list => struct or union def
;; no init-declr-list => struct or union def or param-decl
;;(display "spec:\n") (pretty-print spec)
(sxml-match spec
((decl-spec-list
@ -218,13 +218,14 @@
;; This will turn
;; @example
;; (comp-decl (decl-spec-list (type-spec "int"))
;; (comp-decl-list (comp-decl (ident "a")) (comp-decl (ident "b"))))
;; (comp-decl-list
;; (comp-declr (ident "a")) (comp-declr (ident "b"))))
;; @end example
;; @noindent
;; into
;; @example
;; ("a" . (comp-decl (decl-spec-list ...) (comp-decl (ident "a"))))
;; ("b" . (comp-decl (decl-spec-list ...) (comp-decl (ident "b"))))
;; ("a" . (comp-decl (decl-spec-list ...) (comp-declr (ident "a"))))
;; ("b" . (comp-decl (decl-spec-list ...) (comp-declr (ident "b"))))
;; @end example
;; @noindent
;; This is coded to be used with fold-right in order to preserve order
@ -249,6 +250,29 @@
(cons* tag spec (car idl) tail))
(iter res (cdr idl)))))))))
;; @deffn match-param-decl param-decl seed
;; This will turn
;; @example
;; (param-decl (decl-spec-list (type-spec "int")) (param-declr (ident "a")))
;; @end example
;; @noindent
;; into
;; @example
;; ("a" . (comp-decl (decl-spec-list ...) (comp-declr (ident "a"))))
;; @end example
;; @noindent
;; This is coded to be used with fold-right in order to preserve order
;; in @code{struct} and @code{union} field lists.
(define (match-param-decl decl seed)
(if (not (eqv? 'param-decl (car decl))) seed
(let* ((tag (sx-ref decl 0))
(attr (sx-attr decl))
(spec (sx-ref decl 1)) ; (type-spec ...)
(declr (sx-ref decl 2)) ; (param-declr ...)
(ident (declr->ident declr))
(name (cadr ident)))
(acons name decl seed))))
;; @deffn find-special udecl-alist seed => ..
;; NOT DONE
;; @example

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

@ -342,6 +342,7 @@ sx)
;; @deffn make-pp-formatter/ugly => fmtr
;; Makes a @code{fmtr} like @code{make-pp-formatter} but no indentation
;; and just adds strings on ...
;; This is specific to C/C++ because it will newline if #\# seen first.
(define* (make-pp-formatter/ugly)
(let*
((maxcol 78)
@ -349,16 +350,25 @@ sx)
(sf (lambda (fmt . args)
(let* ((str (apply simple-format #f fmt args))
(len (string-length str)))
(if (and (positive? len)
(char=? #\newline (string-ref str (1- len))))
(string-set! str (1- len) #\space))
(cond
((zero? len) #t)
((char=? #\# (string-ref str 0))
(display str))
((zero? len) #t) ; we reference str[0] next
((and (equal? len 1) (char=? #\newline (string-ref str 0))) #t)
((char=? #\# (string-ref str 0)) ; CPP-stmt: force newline
(when (positive? column) (newline))
(display str) ; str always ends in \n
(set! column ; if ends \n then col= 0 else len
(if (char=? #\newline (string-ref str (1- len)))
0 len)))
((zero? column)
(display str)
(set! column len))
(else
(when (> (+ column len) maxcol)
(newline)
(set! column 0))
(if (char=? #\newline (string-ref str (1- len)))
(string-set! str (1- len) #\space))
(display str)
(set! column (+ column len))))))))