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

mescc: Support functions in expression.

Browse source 
* module/language/c99/info.scm (<function>): New type.
* module/language/c99/compiler.mes (ast->type): Support function.
  (expr->type-size): Likewise.
  (expr->type): Likewise.
  (expr->accu*): Likewise.
  (function->info): Create <function>.
* module/mes/M1.mes (object->M1): Grok <function>.
* scaffold/tests/47-function-expression.c: Test it.
* build-aux/check-mescc.sh: Add it.
This commit is contained in:
Jan Nieuwenhuizen 2018-05-04 13:58:27 +02:00
parent be60b3e49b
commit e53f55f002
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
6 changed files with 244 additions and 82 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
build-aux/check-mescc.sh
View file

@ -73,6 +73,8 @@ t
44-switch
45-void-call
46-function-static
47-function-expression
48-function-destruct
50-assert
51-strcmp
52-itoa

232
module/language/c99/compiler.mes
View file

@ -59,6 +59,9 @@
(define mes? (pair? (current-module)))
(define %int-size 4)
(define %pointer-size %int-size)
(define* (c99-input->full-ast #:key (defines '()) (includes '()))
(let ((sys-include (if (equal? %prefix "") "include" (string-append %prefix "/share/include"))))
(parse-c99
@ -137,7 +140,7 @@
((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)
((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)
(_ (error ".statements: unsupported: " o))))
(_ (error ".statements: not supported: " o))))
(define (clone o . rest)
(cond ((info? o)
@ -201,7 +204,10 @@
;; ("unsigned long long int" . ,(make-type 'builtin 8 0 #f))
("unsigned long long" . ,(make-type 'builtin 4 0 #f)) ;; FIXME
("unsigned long long int" . ,(make-type 'builtin 4 0 #f))
))
("float" . ,(make-type 'builtin 4 0 #f))
("double" . ,(make-type 'builtin 8 0 #f))
("long double" . ,(make-type 'builtin 16 0 #f))))
(define (field:name o)
(pmatch o
@ -229,48 +235,50 @@
((,name ,type ,size ,pointer) type)
(_ (error (format #f "field:type: ~s\n" o)))))
(define (get-type types o)
(let ((t (assoc-ref types o)))
(define (get-type info o)
(let ((t (assoc-ref (.types info) o)))
(pmatch t
((typedef ,next) (get-type types next))
((typedef ,next) (or (get-type info next) o))
(_ t))))
(define (ast-type->type info o)
(pmatch o
((p-expr ,expr) (ast-type->type info (expr->type info o)))
((pre-inc ,expr) (ast-type->type info expr))
((post-inc ,expr) (ast-type->type info expr))
((decl-spec-list ,type-spec)
(ast-type->type info type-spec))
((decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type)))
(ast-type->type info type))
((array-ref ,index (p-expr (ident ,array)))
(ast-type->type info `(p-expr (ident ,array))))
((struct-ref (ident ,type))
(or (get-type (.types info) type)
(let ((struct (if (pair? type) type `("tag" ,type))))
(ast-type->type info struct))))
((union-ref (ident ,type))
(or (get-type (.types info) type)
(let ((struct (if (pair? type) type `("tag" ,type))))
(ast-type->type info struct))))
((void) (ast-type->type info "void"))
((type-spec ,type) (ast-type->type info type))
((fixed-type ,type) (ast-type->type info type))
((typename ,type) (ast-type->type info type))
((de-ref ,expr)
(ast-type->type info expr))
((d-sel (idend ,field) ,struct)
(let ((type0 (ast-type->type info struct)))
(field-type info type0 field)))
((i-sel (ident ,field) ,struct)
(let ((type0 (ast-type->type info struct)))
(field-type info type0 field)))
(_ (let ((type (get-type (.types info) o)))
(if type type
(begin
(stderr "types: ~s\n" (.types info))
(error "ast-type->type: unsupported: " o)))))))
(if (type? o) o
(pmatch o
((p-expr ,expr) (ast-type->type info (expr->type info o)))
((pre-inc ,expr) (ast-type->type info expr))
((post-inc ,expr) (ast-type->type info expr))
((decl-spec-list ,type-spec)
(ast-type->type info type-spec))
((decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type)))
(ast-type->type info type))
((array-ref ,index (p-expr (ident ,array)))
(ast-type->type info `(p-expr (ident ,array))))
((struct-ref (ident ,type))
(or (get-type info type)
(let ((struct (if (pair? type) type `("tag" ,type))))
(ast-type->type info struct))))
((union-ref (ident ,type))
(or (get-type info type)
(let ((struct (if (pair? type) type `("tag" ,type))))
(ast-type->type info struct))))
((void) (ast-type->type info "void"))
((type-spec ,type) (ast-type->type info type))
((fixed-type ,type) (ast-type->type info type))
((float-type ,type) (ast-type->type info type))
((typename ,type) (ast-type->type info type))
((de-ref ,expr)
(ast-type->type info expr))
((d-sel (idend ,field) ,struct)
(let ((type0 (ast-type->type info struct)))
(field-type info type0 field)))
((i-sel (ident ,field) ,struct)
(let ((type0 (ast-type->type info struct)))
(field-type info type0 field)))
(_ (let ((type (get-type info o)))
(if type type
(begin
(stderr "types: ~s\n" (.types info))
(error "ast-type->type: not supported: " o))))))))
(define (ast-type->description info o)
(let* ((type (ast-type->type info o))
@ -340,7 +348,7 @@
type)
((struct-ref (ident ,type))
`("tag" ,type))
(_ (stderr "SKIP: type=~s\n" o)
(_ (stderr "SKIP: .type=~s\n" o)
"int")))
(define (decl->ast-type o)
@ -353,7 +361,7 @@
`("tag" ,name)) ;; FIXME
((typename ,name) name)
(,name name)
(_ (error "decl->ast-type: unsupported: " o))))
(_ (error "decl->ast-type: not supported: " o))))
(define (byte->hex.m1 o)
(string-drop o 2))
@ -423,12 +431,12 @@
((array-ref ,index ,array) (ptr-dec (expr->pointer info array)))
((d-sel (ident ,field) ,struct)
(let ((type (expr->type info struct)))
(field-pointer info type field)))
(let ((type (expr->type info struct)))
(field-pointer info type field)))
((i-sel (ident ,field) ,struct)
(let ((type (expr->type info struct)))
(field-pointer info type field)))
(let ((type (expr->type info struct)))
(field-pointer info type field)))
((cast (type-name ,type) ,expr) ; FIXME: add expr?
(let* ((type (ast-type->type info type))
@ -440,10 +448,19 @@
(pointer1 (ptr-declr->pointer pointer))
(pointer2 (expr->pointer info expr)))
(+ pointer0 pointer1)))
(_ (stderr "expr->pointer: unsupported: ~s\n" o) 0)))
(define %int-size 4)
(define %pointer-size %int-size)
((type-spec ,type)
(or (and=> (ast-type->type info o) type:pointer)
(begin
(stderr "expr->pointer: not supported: ~a\n" o)
0)))
((fctn-call (p-expr (ident ,function)) . ,rest)
(or (and=> (and=> (assoc-ref (.functions info) function) function:type)
(lambda (t)
(and (type? t) (type:pointer t))))
(begin
(stderr "expr->pointer: no such function: ~a\n" function)
0)))
(_ (stderr "expr->pointer: not supported: ~s\n" o) 0)))
(define (expr->type-size info o)
(pmatch o
@ -483,7 +500,14 @@
((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr?
(let ((type (ast-type->type info type)))
(type:size type)))
(_ (stderr "expr->type-size: unsupported: ~s\n" o) 4)))
((fctn-call (p-expr (ident ,function)) . ,rest)
(or (and=> (and=> (assoc-ref (.functions info) function) function:type)
(lambda (t)
(and (type? t) (type:size t))))
(begin
(stderr "expr->type-size: no such function: ~a\n" function)
4)))
(_ (stderr "expr->type-size: not supported: ~s\n" o) 4)))
(define (expr->size info o)
(let ((ptr (expr->pointer info o)))
@ -524,11 +548,13 @@
type)
((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr?
type)
((fctn-call (p-expr (ident ,name)))
(stderr "TODO: expr->type: unsupported: ~s\n" o)
"int")
(_ ;;(error (format #f "expr->type: unsupported: ~s") o)
(stderr "TODO: expr->type: unsupported: ~s\n" o)
((fctn-call (p-expr (ident ,function)) . ,rest)
(or (and=> (assoc-ref (.functions info) function) function:type)
(begin
(stderr "expr->type: no such function: ~s\n" function)
"int")))
(_ ;;(error (format #f "expr->type: not supported: ~s") o)
(stderr "TODO: expr->type: not supported: ~s\n" o)
"int")))
(define (append-text info text)
@ -868,6 +894,12 @@
(info ((expr->accu* info) struct)))
(append-text info (wrap-as (i386:accu+value offset)))))
((i-sel (ident ,field) (fctn-call (p-expr (ident ,function)) . ,rest))
(let* ((type (expr->type info `(fctn-call (p-expr (ident ,function)) ,@rest)))
(offset (field-offset info type field))
(info ((expr->accu info) `(fctn-call (p-expr (ident ,function)) ,@rest))))
(append-text info (wrap-as (i386:accu+value offset)))))
((i-sel (ident ,field) ,struct)
(let* ((type (expr->type info struct))
(offset (field-offset info type field))
@ -884,7 +916,7 @@
(info ((expr->base info) array)))
(append-text info (wrap-as (i386:accu+base)))))
(_ (error "expr->accu*: unsupported: " o)))))
(_ (error "expr->accu*: not supported: " o)))))
(define (expr->accu info)
(lambda (o)
@ -1314,7 +1346,7 @@
(_ (let ((info ((expr->base* info) a)))
(accu->base-mem*n info (min size-a (max 4 size-b)))))))) ;; FIXME: long long = int
(_ (error "expr->accu: unsupported: " o))))))
(_ (error "expr->accu: not supported: " o))))))
(define (expr->base info)
(lambda (o)
@ -1352,7 +1384,7 @@
((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
((p-expr (fixed ,value)) (cstring->number value))
((neg (p-expr (fixed ,value))) (- (cstring->number value)))
(_ (error "case test: unsupported: " test)))))
(_ (error "case test: not supported: " test)))))
(append (wrap-as (i386:accu-cmp-value value))
(jump-z body-label))))
(define (cases+jump info cases)
@ -1569,7 +1601,7 @@
((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
`(union ,@(map (struct-field info) fields)))
(_ (error "struct-field: unsupported: " o)))))
(_ (error "struct-field: not supported: " o)))))
(define (local-var? o) ;; formals < 0, locals > 0
(positive? (local:id o)))
@ -1579,7 +1611,7 @@
((pointer) 1)
((pointer (pointer)) 2)
((pointer (pointer (pointer))) 3)
(_ (error "ptr-declr->pointer unsupported: " o))))
(_ (error "ptr-declr->pointer not supported: " o))))
(define (init-declr->name o)
(pmatch o
@ -1590,7 +1622,7 @@
((ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,params)) name)
((ptr-declr (pointer) (array-of (ident ,name))) name)
((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) name)
(_ (error "init-declr->name unsupported: " o))))
(_ (error "init-declr->name not supported: " o))))
(define (init-declr->count info o)
(pmatch o
@ -1606,7 +1638,7 @@
((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) (param-list . ,params)) (ptr-declr->pointer pointer))
((ptr-declr (pointer) (array-of (ident ,name))) -2)
((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) -2)
(_ (error "init-declr->pointer unsupported: " o))))
(_ (error "init-declr->pointer not supported: " o))))
(define (statements->clauses statements)
(let loop ((statements statements) (clauses '()))
@ -1649,7 +1681,7 @@
((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
(_ (loop2 (cdr statements) (append c (list s)))))))))
(_ (error "statements->clauses: unsupported:" s)))))))
(_ (error "statements->clauses: not supported:" s)))))))
(define (global->static function)
(lambda (o)
@ -1685,7 +1717,10 @@
locals))
(define (declare name)
(if (member name functions) info
(clone info #:functions (cons (cons name #f) functions))))
(let* ((type (function->type info o))
(function (make-function name type #f)))
(clone info #:functions (cons (cons name function) functions)))))
(pmatch o
;; FIXME: Nyacc sometimes produces extra parens: (ident (<struct-name>))
@ -1693,7 +1728,7 @@
(declare name))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
(clone info #:types (cons (cons name (get-type types type)) types)))
(clone info #:types (cons (cons name (get-type info type)) types)))
;; int foo ();
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
@ -1765,16 +1800,16 @@
info)
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
(clone info #:types (cons (cons name (or (get-type types type) `(typedef ("tag" ,type)))) types)))
(clone info #:types (cons (cons name (or (get-type info type) `(typedef ("tag" ,type)))) types)))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
(clone info #:types (cons (cons name (or (get-type types type) `(typedef ("tag" ,type)))) types)))
(clone info #:types (cons (cons name (or (get-type info type) `(typedef ("tag" ,type)))) types)))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
(clone info #:types (cons (cons name (or (get-type types type) `(typedef ,type))) types)))
(clone info #:types (cons (cons name (or (get-type info type) `(typedef ,type))) types)))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (array-of (ident ,name) ,value))))
(let* ((type (get-type types type))
(let* ((type (get-type info type))
(value (expr->number info value))
(size (* value 4))
(pointer -1)
@ -1783,7 +1818,7 @@
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
(let* ((pointer (expr->pointer info pointer))
(type (or (get-type types type) `(typedef ,type)))
(type (or (get-type info type) `(typedef ,type)))
(size 4)
(type (make-type 'typedef size pointer type)))
(clone info #:types (cons (cons name type) types))))
@ -1797,15 +1832,15 @@
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
(let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) ,field-list))))))
(types (.types info)))
(clone info #:types (cons (cons name (or (get-type types `("tag" ,type)) `(typedef ,type))) types))))
(clone info #:types (cons (cons name (or (get-type info `("tag" ,type)) `(typedef ,type))) types))))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
(let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,field-list))))))
(types (.types info)))
(clone info #:types (cons (cons name (or (get-type types `("tag" ,type)) `(typedef ,type))) types))))
(clone info #:types (cons (cons name (or (get-type info `("tag" ,type)) `(typedef ,type))) types))))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
(let* ((type (get-type types type))
(let* ((type (get-type info type))
(type (make-type (type:type type)
(type:size type)
(1+ (type:pointer type))
@ -2120,7 +2155,7 @@
(format (current-error-port) "SKIP: at=~s\n" o)
info)
((decl . _) (error "decl->info: unsupported: " o))))))
((decl . _) (error "decl->info: not supported: " o))))))
(define (ast->info info)
(lambda (o)
@ -2376,7 +2411,7 @@
(() (int->bv32 0))
((initzer ,p-expr)
(int->bv32 (expr->number info p-expr)))
(_ (error "initzer->data: unsupported: " o)))))
(_ (error "initzer->data: not supported: " o)))))
(define (initzer->accu info)
(lambda (o)
@ -2438,7 +2473,7 @@
(wrap-as (append (i386:function-preamble)
(append-map (formal->text n) formals (iota n))
(i386:function-locals)))))
(_ (error "formals->text: unsupported: " o))))
(_ (error "formals->text: not supported: " o))))
(define (formal:ptr o)
(pmatch o
@ -2461,7 +2496,43 @@
((param-list . ,formals)
(let ((n (length formals)))
(map make-local-entry (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
(_ (error "formals->locals: unsupported: " o))))
(_ (error "formals->locals: not supported: " o))))
(define (function->type info o)
(pmatch o
((fctn-defn (decl-spec-list (type-spec ,type)) (ptr-declr ,pointer ,rest) ,statement)
(let ((type (ast-type->type info type))
(pointer (ptr-declr->pointer pointer)))
(make-type (type:type type)
(type:size type)
(+ (type:pointer type) pointer)
(type:description type))))
((decl (decl-spec-list (type-spec ,type)) (init-declr (ptr-declr ,pointer (ftn-declr . ,rest))))
(let ((type (ast-type->type info type))
(pointer (ptr-declr->pointer pointer)))
(make-type (type:type type)
(type:size type)
(+ (type:pointer type) pointer)
(type:description type))))
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer (ftn-declr . ,rest)))))
(ast-type->type info type))
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ftn-declr . ,rest))))
(ast-type->type info type))
((decl (decl-spec-list (stor-spec ,store) (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer (ftn-declr . ,rest)))))
(ast-type->type info type))
((decl (decl-spec-list (stor-spec ,store) (type-spec ,type)) (init-declr-list (init-declr (ftn-declr . ,rest))))
(ast-type->type info type))
((fctn-defn (decl-spec-list (stor-spec . ,store) (type-spec ,type)) (ptr-declr ,pointer (ftn-declr . ,rest)) ,statement)
(ast-type->type info type))
((fctn-defn (decl-spec-list (stor-spec . ,store) (type-spec ,type)) . ,rest)
(ast-type->type info type))
((decl (decl-spec-list (type-spec ,type)) (init-declr (ftn-declr . ,rest)))
(ast-type->type info type))
((fctn-defn (decl-spec-list (type-spec ,type)) . ,rest)
(ast-type->type info type))
(_ (stderr "TODO: function->type: not supported: ~s\n" o)
(get-type info "info"))))
(define (function->info info)
(lambda (o)
@ -2470,6 +2541,7 @@
(if (equal? (list-tail text (- (length text) (length return))) return) text
(append text return))))
(let* ((name (.name o))
(type (function->type info o))
(formals (.formals o))
(text (formals->text formals))
(locals (formals->locals formals)))
@ -2485,7 +2557,7 @@
#:function #f
#:globals (append (.statics info) (.globals info))
#:statics '()
#:functions (append (.functions info) (list (cons name (assert-return (.text info)))))))
#:functions (append (.functions info) (list (cons name (make-function name type (assert-return (.text info))))))))
(let* ((statement (car statements)))
(loop (cdr statements)
((ast->info info) (car statements)))))))))
@ -2516,7 +2588,7 @@
(define* (info->object o)
(stderr "compiling: object\n")
`((functions . ,(.functions o))
`((functions . ,(filter (compose function:text cdr) (.functions o)))
(globals . ,(.globals o))))
(define* (c99-input->elf #:key (defines '()) (includes '()))

19
module/language/c99/info.scm
View file

@ -43,6 +43,7 @@
.break
.continue
<type>
make-type
type?
type:type
@ -50,6 +51,7 @@
type:pointer
type:description
<global>
make-global
global?
global:name
@ -59,11 +61,19 @@
global:function
global->string
<local>
make-local
local?
local:type
local:pointer
local:id))
local:id
<function>
make-function
function?
function:name
function:type
function:text))
(cond-expand
(guile-2)
@ -117,3 +127,10 @@
(type local:type)
(pointer local:pointer)
(id local:id))
(define-immutable-record-type <function>
(make-function name type text)
function?
(name function:name)
(type function:type)
(text function:text))

2
module/mes/M1.mes
View file

@ -139,7 +139,7 @@
((pair? o) (string-join (map text->M1 o)))))
(define (write-function o)
(let ((name (car o))
(text (cdr o)))
(text (function:text (cdr o))))
(define (line->M1 o)
(cond ((eq? (car o) #:label)
(display (string-append ":" (cadr o))))

33
scaffold/tests/47-function-expression.c Normal file
View file

@ -0,0 +1,33 @@
/* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software
* Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
*
* This file is part of Mes.
*
* Mes is free software; you can redistribute it and/or modify it
* under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 3 of the License, or (at
* your option) any later version.
*
* Mes is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
int g_time = 1;
int*
time ()
{
return &g_time;
}
int
main ()
{
return *time () - 1;
}

38
scaffold/tests/48-function-destruct.c Normal file
View file

@ -0,0 +1,38 @@
/* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software
* Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
*
* This file is part of Mes.
*
* Mes is free software; you can redistribute it and/or modify it
* under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 3 of the License, or (at
* your option) any later version.
*
* Mes is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
struct foo
{
int bar;
};
struct foo*
test (struct foo* f)
{
return f;
}
int
main ()
{
struct foo f = {1};
int i = test (&f)->bar;
return test (&f)->bar - i;
}