andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

WIP nyacc

This commit is contained in:
Jan (janneke) Nieuwenhuizen 2021-06-26 09:46:50 +02:00
parent 1fbf30b900
commit e7d2349ea0
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
15 changed files with 216 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
include/mes/builtins.h
View File

@ -38,7 +38,7 @@ struct scm *acons (struct scm *key, struct scm *value, struct scm *alist);
struct scm *length (struct scm *x);
struct scm *error (struct scm *key, struct scm *x);
struct scm *append2 (struct scm *x, struct scm *y);
struct scm *append_reverse (struct scm *x, struct scm *y);
struct scm *append_reverse_ (struct scm *x, struct scm *y);
struct scm *reverse_x_ (struct scm *x, struct scm *t);
struct scm *assq (struct scm *x, struct scm *a);
struct scm *assoc (struct scm *x, struct scm *a);

4
mes/module/ice-9/pretty-print.scm
View File

@ -21,8 +21,8 @@
;;; Taken from GNU Guile
(define-module (ice-9 pretty-print)
:use-module (ice-9 optargs)
:export (pretty-print))
;;#:use-module (ice-9 optargs)
#:export (pretty-print))
;; From SLIB.

1
mes/module/mes/boot-5.mes
View File

@ -181,6 +181,7 @@
(mes-use-module (srfi srfi-9))
(mes-use-module (mes syntax))
(mes-use-module (mes boot-6))
(include-from-path "mes/guile.scm")
(use-modules (mes main))
(top-main)
(primitive-load 0)

113
mes/module/mes/guile.mes
View File

@ -62,3 +62,116 @@
(define (port-filename p) "<stdin>")
(define (port-line p) 0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Hacks for Nyacc with modules
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Strings/srfi-13
(define reverse-list->string (compose list->string reverse))
(define string-null? (compose null? string->list))
;;; Char-sets/srfi-14
;; FIXME: have structs
(define (char-set . x)
(cons '*char-set* x))
(define char-set:whitespace (char-set #\tab #\page #\return #\vtab #\newline #\space))
(define (string->char-set x . base)
(apply char-set (append (string->list x) (if (null? base) '() (cdar base)))))
(define (string->char-set! x base)
(set-cdr! (last-pair base) (string->list x))
base)
(define (char-set-copy cs)
(map identity cs))
(define (list->char-set lst)
(apply char-set lst))
;;; ice-9 optargs/macros
(define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
(if (null? rest-arg)
'()
(let loop ((first (car rest-arg))
(rest (cdr rest-arg))
(accum '()))
(let ((next (lambda (a)
(if (null? (cdr rest))
a
(loop (cadr rest) (cddr rest) a)))))
(if (keyword? first)
(cond
((memq first keywords)
(if (null? rest)
(error "Keyword argument has no value:" first)
(next (cons (cons (keyword->symbol first)
(car rest)) accum))))
((not allow-other-keys?)
(error "Unknown keyword in arguments:" first))
(else (if (null? rest)
accum
(next accum))))
(if (null? rest)
accum
(loop (car rest) (cdr rest) accum)))))))
;; (define (make-ident-like-p . rest)
;; (warn "fubar: make-ident-like-p" rest))
;; (define (make-comm-reader . rest)
;; (warn "fubar: make-comm-reader" rest))
;; (define (make-lexer-generator . rest)
;; (warn "fubar: make-lexer-generator" rest))
;; (define (move-attributes . rest)
;; (warn "fubar: move-attributes" rest))
;; (define (read-c-ident . rest)
;; (warn "fubar: read-c-ident" rest))
;; (define (filter-mt . rest)
;; (warn "fubar: filter-mt" rest))
;; (define (map-mt . rest)
;; (warn "fubar: map-mt" rest))
;; (define (remove-mt . rest)
;; (warn "fubar: remove-mt" rest))
;; (define (make-chseq-reader . rest)
;; (warn "fubar: make-chseq-reader" rest))
;; (define (count-opt . rest)
;; (warn "fubar: count-opt" rest))
;; (define (read-c-chlit . rest)
;; (warn "fubar: read-c-chlit" rest))
;; (define (read-c-num . rest)
;; (warn "fubar: read-c-num" rest))
;; (define (make-lalr-parser . rest)
;; (warn "fubar: make-lalr-parser" "..."))
;; (define (c99-len-v . rest)
;; (warn "fubar: c99-len-v" rest))
;; (define (filter pred lst)
;; (let loop ((lst lst))
;; (if (null? lst) '()
;; (if (pred (car lst))
;; (cons (car lst) (loop (cdr lst)))
;; (loop (cdr lst))))))
;; (define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
;; (define (count-opt options option-name)
;; (let ((lst (filter identity (map (multi-opt option-name) options))))
;; (and (pair? lst) (length lst))))

3
mes/module/mes/guile.scm
View File

@ -46,10 +46,11 @@
(define (with-input-from-file file thunk)
(let ((port (open-input-file file)))
(warn "opened" file "=>" port)
(if (= port -1)
(error 'no-such-file file)
(let* ((save (current-input-port))
(foo (set-current-input-port port))
(foo (warn 'poort (set-current-input-port port)))
(r (thunk)))
(set-current-input-port save)
r))))

2
mes/module/mes/posix.mes
View File

@ -26,7 +26,7 @@
(define S_IRWXU #o700)
(define (basename file-name . ext)
(let ((base (last (string-split file-name #\/)))
(let ((base (car (last-pair (string-split file-name #\/))))
(ext (and (pair? ext) (car ext))))
(if (and ext
(string-suffix? ext base)) (string-drop-right base (string-length ext))

14
mes/module/nyacc/lang/c99/parser.mes
View File

@ -22,13 +22,13 @@
;;; Code:
(mes-use-module (mes guile))
(mes-use-module (mes catch))
(mes-use-module (mes fluids))
(mes-use-module (mes pretty-print))
(mes-use-module (mes optargs))
(mes-use-module (srfi srfi-9))
(mes-use-module (sxml xpath))
;; (mes-use-module (mes guile))
;; (mes-use-module (mes catch))
;; (mes-use-module (mes fluids))
;; (mes-use-module (mes pretty-print))
;; (mes-use-module (mes optargs))
;; (mes-use-module (srfi srfi-9))
;; (mes-use-module (sxml xpath))
(mes-use-module (nyacc lex))
(mes-use-module (nyacc parse))

4
mes/module/srfi/srfi-1.scm
View File

@ -28,6 +28,7 @@
find
filter
append-map
append-reverse
filter-map
fold
fold-right
@ -40,6 +41,7 @@
iota
srfi-1:iota
delete-duplicates
last
any
any1
every
@ -51,6 +53,8 @@
reverse!
take-while))
(define append-reverse core:append-reverse)
(define (drop-right lst n)
(list-head lst (- (length lst) n)))

33
mes/module/srfi/srfi-9-struct.scm
View File

@ -20,23 +20,26 @@
;;; Commentary:
;;; srfi-9.mes - records, based on struct.
;;; srfi-9.scm - records, based on struct.
;;; Code:
(define-module (srfi srfi-9)
#:export (define-record-type
make-record-type
record-type?
struct-vtable
record-type-name
record-type-descriptor
record-type-fields
record-predicate
record?
record-constructor
record-accessor
record-modifier))
;; FIXME: a second use-modules of srfi-9 gives STACK_FULL
;; (define-module (srfi srfi-9)
;; #:export (define-record-type
;; make-record-type
;; record-type?
;; struct-vtable
;; record-type-name
;; record-type-descriptor
;; record-type-fields
;; record-predicate
;; record?
;; record-constructor
;; record-accessor
;; record-modifier))
(define-module (srfi srfi-9))
(define-macro (define-record-type name constructor+field-names predicate . fields)
(let ((type (make-record-type name (map car fields))))
@ -113,7 +116,7 @@
(define (record-accessor type field)
(let ((i (record-field-index type field)))
(lambda (o . field?)
(if (not (eq? (record-type-descriptor o) type)) (error "record accessor: record expected" type field o)
(if (and #f (not (eq? (record-type-descriptor o) type))) (error "record accessor: record expected" type field o)
(if (pair? field?) field
(struct-ref o i))))))

6
module/mescc/compile.scm
View File

@ -27,7 +27,6 @@
#:use-module (system base pmatch)
#:use-module (ice-9 optargs)
#:use-module (ice-9 pretty-print)
#:use-module (nyacc lang c99 pprint)
#:use-module (mes guile)
#:use-module (mes misc)
@ -41,6 +40,11 @@
c99-input->info
c99-input->object))
(cond-expand
(guile
(use-modules (nyacc lang c99 pprint)))
(mes))
(define mes? (pair? (current-module)))
(define mes-or-reproducible? #t)
(define (cc-amd? info) #f) ; use AMD calling convention?

4
module/mescc/i386/info.scm
View File

@ -25,7 +25,9 @@
(define-module (mescc i386 info)
#:use-module (mescc info)
#:use-module (mescc i386 as)
#:export (x86-info))
#:export (x86-info
i386:type-alist
i386:registers))
(define (x86-info)
(make <info> #:types i386:type-alist #:registers i386:registers #:instructions i386:instructions))

40
module/mescc/mescc.scm
View File

@ -22,24 +22,37 @@
#:use-module (mes misc)
#:use-module (mes guile)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-26)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 getopt-long)
#:use-module (mescc info)
#:use-module (mescc armv4 info)
;; #:use-module (mescc armv4 info)
#:use-module (mescc i386 info)
#:use-module (mescc x86_64 info)
;; #:use-module (mescc x86_64 info)
#:use-module (mescc preprocess)
#:use-module (mescc compile)
#:use-module (mescc M1)
;;#:use-module (mescc foo-process)
;;#:use-module (mescc compile)
;;#:use-module (mescc M1)
#:export (count-opt
mescc:preprocess
mescc:get-host
mescc:compile
mescc:assemble
mescc:link
multi-opt))
multi-opt
M1->hex2
replace-suffix
arch-get
arch-get-defines
c->info
c->ast
.E?
.c?
.s?))
(define GUILE-with-output-to-file with-output-to-file)
(define (with-output-to-file file-name thunk)
@ -47,11 +60,13 @@
(GUILE-with-output-to-file file-name thunk)))
(define (mescc:preprocess options)
(warn "mescc:preprocess")
(let* ((pretty-print/write (string->symbol (option-ref options 'write (if guile? "pretty-print" "write"))))
(pretty-print/write (if (eq? pretty-print/write 'pretty-print) pretty-print write))
(files (option-ref options '() '("a.c")))
(input-file-name (car files))
(input-base (basename input-file-name))
(foo (warn "********************************"))
(ast-file-name (cond ((and (option-ref options 'preprocess #f)
(option-ref options 'output #f)))
(else (replace-suffix input-base ".E"))))
@ -60,15 +75,30 @@
(includes (reverse (filter-map (multi-opt 'include) options)))
(includes (cons (option-ref options 'includedir #f) includes))
(includes (cons dir includes))
(foo (warn "1111111111111111111111111111111111"))
(prefix (option-ref options 'prefix ""))
(machine (option-ref options 'machine "32"))
(arch (arch-get options))
(foo (warn "2222222222222222222222222222222222"))
(defines (append (arch-get-defines options) defines))
(foo (warn "3333333333333333333333333333333333"))
(verbose? (count-opt options 'verbose)))
(with-output-to-file ast-file-name
(lambda _ (for-each (cut c->ast prefix defines includes arch pretty-print/write verbose? <>) files)))))
(define (with-input-from-file file thunk)
(let ((port (open-input-file file)))
(warn "opened" file "=>" port)
(if (= port -1)
(error 'no-such-file file)
(let* ((save (current-input-port))
(foo (warn 'poort (set-current-input-port port)))
(r (thunk)))
(set-current-input-port save)
r))))
(define (c->ast prefix defines includes arch write verbose? file-name)
(warn "c->ast")
(with-input-from-file file-name
(cut write (c99-input->ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?))))

32
module/mescc/preprocess.scm
View File

@ -21,16 +21,22 @@
;;; Code:
(define-module (mescc preprocess)
#:use-module (mes guile)
#:use-module (ice-9 optargs)
#:use-module (system base pmatch)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (nyacc lang c99 parser)
#:use-module (nyacc lang c99 parser)
#:use-module (nyacc version)
#:use-module (mes guile)
#:export (c99-input->ast))
#:use-module (nyacc lang c99 paars)
;;#:use-module (nyacc lang c99 parser)
;;#:use-module (nyacc version)
#:export (c99-input->ast
c99-input->full-ast
ast-strip-attributes
ast-strip-const
ast-strip-comment))
(define *nyacc-version* "1.0.1")
(define mes-or-reproducible? #t)
(when (getenv "MESC_DEBUG")
@ -62,12 +68,12 @@
(apply (vector-ref act-v ix) args))))
(loop (1+ ix))))))
(cond-expand
(guile
(insert-progress-monitors (@@ (nyacc lang c99 parser) c99-act-v)
(@@ (nyacc lang c99 parser) c99-len-v)))
(mes
(insert-progress-monitors c99-act-v c99-len-v)))
;; (cond-expand
;; (guile
;; (insert-progress-monitors (@@ (nyacc lang c99 parser) c99-act-v)
;; (@@ (nyacc lang c99 parser) c99-len-v)))
;; (mes
;; (insert-progress-monitors c99-act-v c99-len-v)))
(define* (c99-input->full-ast #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
(let* ((sys-include (if (equal? prefix "") "include"
@ -94,14 +100,18 @@
(when (and verbose? (> verbose? 1))
(format (current-error-port) "includes: ~s\n" includes)
(format (current-error-port) "defines: ~s\n" defines))
(warn "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "gonna parse")
(parse-c99
#:inc-dirs includes
#:cpp-defs defines
#:mode 'code)))
(define* (c99-input->ast #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
(warn "hiero" "c99-input->ast")
(when verbose?
(warn "1111")
(format (current-error-port) "parsing: input\n"))
(warn "2222")
((compose ast-strip-attributes
ast-strip-const
ast-strip-comment)

2
src/builtins.c
View File

@ -148,7 +148,7 @@ mes_builtins (struct scm *a) /*:((internal)) */
a = init_builtin (builtin_type, "length", 1, &length, a);
a = init_builtin (builtin_type, "error", 2, &error, a);
a = init_builtin (builtin_type, "append2", 2, &append2, a);
a = init_builtin (builtin_type, "append-reverse", 2, &append_reverse, a);
a = init_builtin (builtin_type, "core:append-reverse", 2, &append_reverse_, a);
a = init_builtin (builtin_type, "core:reverse!", 2, &reverse_x_, a);
a = init_builtin (builtin_type, "assq", 2, &assq, a);
a = init_builtin (builtin_type, "assoc", 2, &assoc, a);

4
src/core.c
View File

@ -178,12 +178,12 @@ append2 (struct scm *x, struct scm *y)
}
struct scm *
append_reverse (struct scm *x, struct scm *y)
append_reverse_ (struct scm *x, struct scm *y)
{
if (x == cell_nil)
return y;
if (x->type != TPAIR)
error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append-reverse")));
error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("core:append-reverse")));
while (x != cell_nil)
{
y = cons (x->car, y);