577 lines
17 KiB
Scheme
577 lines
17 KiB
Scheme
(cond-expand
|
|
(guile
|
|
;;(use-modules ((system base lalr)))
|
|
)
|
|
(mes
|
|
))
|
|
|
|
(define c-parser
|
|
(lalr-parser
|
|
|
|
(lbrace rbrace lparen rparen lbracket rbracket semicolon colon dot comma
|
|
=
|
|
Identifier NumericLiteral StringLiteral
|
|
break case continue goto label
|
|
return switch
|
|
for
|
|
if else
|
|
(left: or && ! * / + -)
|
|
(left: bool double float enum void int struct)
|
|
(left: < > <= >=)
|
|
(left: ++ --)
|
|
(nonassoc: == !=)
|
|
)
|
|
|
|
(program
|
|
(translation-unit *eoi*) : `(root ,@$1))
|
|
|
|
(translation-unit
|
|
(external-declaration) : `(,$1)
|
|
(translation-unit external-declaration) : `(,@$1 ,@$2))
|
|
|
|
(external-declaration
|
|
(function-definition) : $1
|
|
(declaration) : $1
|
|
(error semicolon) : (begin (syntax-error "external declaration" @1 $1) '()))
|
|
|
|
(function-definition
|
|
(declarator compound-statement) : `(function ,$1 (signature int (formals)) ,$2)
|
|
(declaration-specifiers declarator compound-statement) : `(function ,$2 (signature ,$1 (formals)) ,$3)
|
|
(declaration-specifiers declarator declaration-list compound-statement) : `(function ,$2 (signature ,$1 ,$3) ,$4))
|
|
|
|
(declaration
|
|
(declaration-specifiers semicolon) : `(,$1)
|
|
(declaration-specifiers init-declarator-list semicolon): `((,@$1 ,@$2))
|
|
)
|
|
|
|
(declaration-list
|
|
(declaration) : `(formals ,@$1)
|
|
(declaration-list declaration) : `(,@$1 ,@(cdr $2)))
|
|
|
|
(declaration-specifiers
|
|
;;(storage-class-specifier) : `(,$1)
|
|
(type-specifier) : `(,$1)
|
|
;;(type-qualifier) : `($1)
|
|
;;(storage-class-specifier declaration-specifiers) : (cons $1 $2)
|
|
(type-specifier declaration-specifiers) : `(,$1 ,$2)
|
|
;;(type-qualifier declaration-specifiers) : (cons $1 $2)
|
|
)
|
|
|
|
;; (storage_class_specifier
|
|
;; (auto)
|
|
;; (extern)
|
|
;; (register)
|
|
;; (static)
|
|
;; (typedef))
|
|
|
|
(type-specifier
|
|
;; (char) : $1
|
|
;; (double) : $1
|
|
;; (void) : $1
|
|
;; (float)
|
|
(int) : 'int
|
|
;; (long)
|
|
;; (short)
|
|
;; (unsigned)
|
|
;; (struct-or-enum-specifier)
|
|
;; (enum-specifier)
|
|
;; (type-name)
|
|
)
|
|
|
|
;; (type-qualifier
|
|
;; (const)
|
|
;; (volatile))
|
|
|
|
;; struct_or_union_specifier:
|
|
;; struct_or_union_ident lbrace struct_declaration_list rbrace
|
|
;; | struct_or_union_ident
|
|
;; ;
|
|
|
|
;; struct_or_union_ident: struct_or_union
|
|
;; | struct_or_union Identifier
|
|
;; ;
|
|
|
|
;; struct_or_union: STRUCT { ; }
|
|
;; | UNION { ; }
|
|
;; ;
|
|
|
|
;; struct_declaration_list: struct_declaration
|
|
;; | struct_declaration_list struct_declaration
|
|
;; ;
|
|
|
|
(init-declarator-list
|
|
;; (init-declarator %prec comma) : `(,$1) HUH?
|
|
(init-declarator) : `(,$1)
|
|
(init-declarator-list comma init-declarator) : `(,$1)
|
|
)
|
|
;; init_declarator_list: init_declarator %prec comma
|
|
;; | init_declarator_list comma init_declarator
|
|
;; ;
|
|
|
|
(init-declarator
|
|
(declarator) : $1
|
|
(declarator = initializer) : `(= ,$1 ,$3)
|
|
;; | error { yyerror("init declarator error"); }
|
|
)
|
|
|
|
;; struct_declaration: specifier_qualifier_list struct_declarator_list semicolon
|
|
;; ;
|
|
|
|
;; specifier_qualifier_list: type_specifier
|
|
;; | type_qualifier
|
|
;; | type_specifier specifier_qualifier_list
|
|
;; | type_qualifier specifier_qualifier_list
|
|
;; ;
|
|
|
|
;; struct_declarator_list: struct_declarator
|
|
;; | struct_declarator_list comma struct_declarator
|
|
;; ;
|
|
|
|
;; struct_declarator: declarator
|
|
;; | COLON constant_expression { ; }
|
|
;; | declarator COLON constant_expression
|
|
;; ;
|
|
|
|
;; enum_specifier: ENUM Identifier lbrace enumerator_list rbrace { ; }
|
|
;; | ENUM lbrace enumerator_list rbrace { ; }
|
|
;; | ENUM Identifier { ; }
|
|
;; ;
|
|
|
|
;; enumerator_list: enumerator
|
|
;; | enumerator_list comma enumerator
|
|
;; ;
|
|
|
|
;; enumerator: Identifier
|
|
;; | Identifier EQ constant_expression
|
|
;; ;
|
|
|
|
(declarator
|
|
(direct-declarator) : $1
|
|
;;(pointer direct-declarator)
|
|
)
|
|
|
|
(direct-declarator
|
|
(Identifier) : $1
|
|
;; (lparen declarator rparen)
|
|
;; (direct-declarator lbracket rbracket)
|
|
;; (direct-declarator lbracket constant-expression rbracket)
|
|
;; (lbracket constant-expression rbracket)
|
|
;; (direct-declarator lparen parameter-type-list rparen)
|
|
(direct-declarator lparen rparen) : $1
|
|
;; (direct-declarator lparen identifier-list rparen)
|
|
)
|
|
|
|
;; pointer: STAR { ; }
|
|
;; | STAR pointer { ; }
|
|
;; | STAR type_qualifier_list { ; }
|
|
;; | STAR type_qualifier_list pointer { ; }
|
|
;; ;
|
|
|
|
;; type_qualifier_list: type_qualifier
|
|
;; | type_qualifier_list type_qualifier
|
|
;; ;
|
|
|
|
;; parameter_type_list: parameter_list
|
|
;; | parameter_list comma ELLIPSIS
|
|
;; ;
|
|
|
|
;; parameter_list: parameter_declaration
|
|
;; | parameter_list comma parameter_declaration
|
|
;; ;
|
|
|
|
;; parameter_declaration:
|
|
;; declaration_specifiers declarator
|
|
;; | declaration_specifiers
|
|
;; | declaration_specifiers abstract_declarator
|
|
;; ;
|
|
|
|
;; identifier_list: Identifier
|
|
;; | identifier_list comma Identifier
|
|
;; | error { yyerror("identifier list error"); }
|
|
;; ;
|
|
|
|
(initializer
|
|
;;(assignment-expression %prec comma) HUH?
|
|
(assignment-expression) : $1
|
|
;; initializer: assignment_expression %prec comma
|
|
;; | lbrace initializer_list rbrace { ; }
|
|
;; | lbrace initializer_list comma rbrace { ; }
|
|
;; ;
|
|
)
|
|
|
|
;; initializer_list: initializer %prec comma
|
|
;; | initializer_list comma initializer
|
|
;; ;
|
|
|
|
;; type_name: specifier_qualifier_list
|
|
;; | specifier_qualifier_list abstract_declarator
|
|
;; ;
|
|
|
|
;; abstract_declarator: pointer
|
|
;; | direct_abstract_declarator
|
|
;; | pointer direct_abstract_declarator
|
|
;; ;
|
|
|
|
;; direct_abstract_declarator:
|
|
;; lparen abstract_declarator rparen { ; }
|
|
;; | lbrace rbrace { ; }
|
|
;; | direct_abstract_declarator lbrace rbrace
|
|
;; | lbrace constant_expression rbrace { ; }
|
|
;; | direct_abstract_declarator lbrace constant_expression rbrace
|
|
;; | lparen rparen { ; }
|
|
;; | direct_abstract_declarator lparen rparen
|
|
;; | lparen parameter_list rparen { ; }
|
|
;; | direct_abstract_declarator lparen parameter_list rparen
|
|
;; ;
|
|
|
|
|
|
(statement
|
|
;;(labeled-statement)
|
|
(expression-statement) : $1
|
|
(compound-statement) : $1
|
|
;;(selection-statement)
|
|
(iteration-statement) : $1
|
|
(jump-statement) : $1
|
|
(semicolon) : '()
|
|
(error semicolon) : (begin (syntax-error "statement error" @1 $1) '())
|
|
(error rbrace) : (begin (syntax-error "statement error" @1 $1) '()))
|
|
|
|
|
|
;; labeled_statement:
|
|
;; Identifier COLON statement
|
|
;; | CASE x COLON statement { ; }
|
|
;; | DEFAULT COLON statement { ; }
|
|
;; ;
|
|
|
|
(expression-statement
|
|
(x semicolon) : $1)
|
|
|
|
(compound-statement
|
|
(lbrace rbrace) : '(compound)
|
|
(lbrace declaration-list rbrace) : `(compound ,$2)
|
|
(lbrace statement-list rbrace) : `(compound ,@$2)
|
|
(lbrace declaration-list statement-list rbrace) : `(compound ,$2 ,@$3))
|
|
|
|
(statement-list
|
|
(statement) : `(,$1)
|
|
(statement-list statement) : `(,@$1 ,$2))
|
|
|
|
;; selection_statement:
|
|
;; IF lparen x rparen statement { ; }
|
|
;; | IF lparen x rparen statement ELSE statement { ; }
|
|
;; | SWITCH lparen x rparen statement { ; }
|
|
;; ;
|
|
|
|
(iteration-statement
|
|
;; iteration_statement:
|
|
;; WHILE lparen x rparen statement { ; }
|
|
;; | DO statement WHILE lparen x rparen semicolon { ; }
|
|
(for lparen forcntrl rparen statement) : `(for ,@$3 ,$5))
|
|
|
|
(forcntrl
|
|
;; | semicolon semicolon x { ; }
|
|
;; | semicolon x semicolon { ; }
|
|
;; | semicolon x semicolon x { ; }
|
|
;; | x semicolon semicolon
|
|
;; | x semicolon semicolon x
|
|
;; | x semicolon x semicolon
|
|
(x semicolon x semicolon x) : `((start ,$1) (test ,$3) (step ,$5)))
|
|
|
|
(jump-statement
|
|
(goto Identifier semicolon) : `(goto ,$2)
|
|
(continue semicolon) : '(continue)
|
|
(break semicolon) : '(break)
|
|
(return semicolon) : '(return)
|
|
(return x semicolon) : `(return ,$2))
|
|
|
|
(x
|
|
(assignment-expression) : $1
|
|
(x comma assignment-expression) : `(,$1 ,@$3))
|
|
|
|
(assignment-expression
|
|
(equality-expression) : $1 ;; skip some
|
|
;;(conditional-expression) : $1
|
|
(unary-expression assignment-operator assignment-expression) : `(,$2 ,$1 ,$3))
|
|
|
|
(assignment-operator
|
|
(=) : '=)
|
|
;; | PLUSEQ { ; }
|
|
;; | MINUSEQ { ; }
|
|
;; | MUEQ { ; }
|
|
;; | DIVEQ { ; }
|
|
;; | MODEQ { ; }
|
|
;; | SLEQ { ; }
|
|
;; | SREQ { ; }
|
|
;; | ANEQ { ; }
|
|
;; | OREQ { ; }
|
|
;; | XOREQ { ; }
|
|
;; ;
|
|
|
|
;; conditional_expression: logical_or_expression
|
|
;; | logical_or_expression IF_THEN x COLON conditional_expression
|
|
;; ;
|
|
|
|
;; constant_expression: conditional_expression
|
|
;; ;
|
|
|
|
;; logical_or_expression: logical_and_expression
|
|
;; | logical_or_expression OROR logical_and_expression
|
|
;; ;
|
|
|
|
;; logical_and_expression: inclusive_or_expression
|
|
;; | logical_and_expression ANDAND inclusive_or_expression
|
|
;; ;
|
|
|
|
;; inclusive_or_expression: exclusive_or_expression
|
|
;; | inclusive_or_expression OR exclusive_or_expression
|
|
;; ;
|
|
|
|
;; exclusive_or_expression: and_expression
|
|
;; | exclusive_or_expression XOR and_expression
|
|
;; ;
|
|
|
|
;; and_expression: equality_expression
|
|
;; | and_expression AND equality_expression
|
|
;; ;
|
|
|
|
(equality-expression
|
|
(relational-expression) : $1
|
|
(equality-expression == relational-expression) : `(== ,$1 ,$3)
|
|
(equality-expression != relational-expression) : `(!= ,$1 ,$3))
|
|
|
|
(relational-expression
|
|
(shift-expression) : $1
|
|
(relational-expression < shift-expression) : `(< ,$1 ,$3)
|
|
(relational-expression <= shift-expression) : `(<= ,$1 ,$3)
|
|
(relational-expression > shift-expression) : `(> ,$1 ,$3)
|
|
(relational-expression >= shift-expression) : `(>= ,$1 ,$3))
|
|
|
|
(shift-expression
|
|
(unary-expression) : $1 ;; skip some
|
|
;; shift_expression: additive_expression
|
|
;; | shift_expression LTLT additive_expression
|
|
;; | shift_expression GTGT additive_expression
|
|
;; ;
|
|
)
|
|
;; additive_expression: multiplicative_expression
|
|
;; | additive_expression PLUS multiplicative_expression
|
|
;; | additive_expression MINUS multiplicative_expression
|
|
;; ;
|
|
|
|
;; multiplicative_expression: cast_expression
|
|
;; | multiplicative_expression STAR cast_expression
|
|
;; | multiplicative_expression DIV cast_expression
|
|
;; | multiplicative_expression MOD cast_expression
|
|
;; ;
|
|
|
|
;; cast_expression: unary_expression
|
|
;; | lparen type_name rparen cast_expression { ; }
|
|
;; ;
|
|
|
|
(unary-expression
|
|
(postfix-expression) : $1
|
|
(++ unary-expression) : `(++x ,$2)
|
|
(-- unary-expression) : `(--x ,$2)
|
|
;; | SIZEOF unary_expression { ; }
|
|
;; | SIZEOF lparen type_name rparen %prec SIZEOF { ; }
|
|
;; | STAR cast_expression { ; }
|
|
;; | AND cast_expression { ; }
|
|
;; | MINUS cast_expression { ; }
|
|
;; | PLUS cast_expression { ; }
|
|
;; | NEG cast_expression { ; }
|
|
;; | NOT cast_expression { ; }
|
|
;; ;
|
|
)
|
|
|
|
(postfix-expression
|
|
(primary-expression) : $1
|
|
;; | postfix_expression lbracket x rbracket
|
|
(postfix-expression lparen rparen) : `(call ,$1 (arguments))
|
|
(postfix-expression lparen argument-expression-list rparen) : `(call ,$1 ,$3)
|
|
;; | postfix_expression FOLLOW Identifier
|
|
;; | postfix_expression DOT Identifier
|
|
(postfix-expression ++) : `(x++ ,$1)
|
|
(postfix-expression --) : `(x-- ,$1)
|
|
)
|
|
|
|
(primary-expression
|
|
(Identifier): $1
|
|
(NumericLiteral) : $1
|
|
;; INT_LITERAL
|
|
;; CHAR_LITERAL
|
|
;; FLOAT_LITERAL
|
|
;; STRING_LITERAL
|
|
(StringLiteral) : $1
|
|
;; lparen x rparen
|
|
)
|
|
;;
|
|
|
|
(argument-expression-list
|
|
(assignment-expression) : `(arguments ,$1)
|
|
(argument-expression-list comma assignment-expression): `(,@$1 ,@(cdr $3)))))
|
|
|
|
(define (i386:exit code)
|
|
`(
|
|
#xbb ,@(int->bv32 code) ;; mov $code,%ebx
|
|
#xb8 #x01 #x00 #x00 #x00 ;; mov $0x1,%eax
|
|
#xcd #x80 ;; int $0x80
|
|
))
|
|
|
|
(define (i386:puts data length)
|
|
`(
|
|
#xba ,@(int->bv32 length) ;; mov $length,%edx
|
|
#xb9 ,@(int->bv32 data) ;; mov $data,%ecx
|
|
#xbb #x01 #x00 #x00 #x00 ;; mov $0x1,%ebx
|
|
#xb8 #x04 #x00 #x00 #x00 ;; mov $0x4,%eax
|
|
#xcd #x80 ;; int $0x80
|
|
))
|
|
|
|
(define (i386:for start test step statement)
|
|
`(
|
|
|
|
;; b:
|
|
#x89 #xe5 ;; mov %esp,%ebp
|
|
;;21:
|
|
#xc7 #x45 #xf4 ,@(int->bv32 start) ;; movl $start,-0xc(%ebp)
|
|
;;28:
|
|
#xeb ,(+ (length statement) 9) ;;x14 jmp 3e <main+0x3e>
|
|
;;2a:
|
|
;;#x83 #xec #x0c ;; sub $0xc,%esp
|
|
|
|
;; 9:
|
|
#x55 ;; push %ebp
|
|
|
|
,@statement
|
|
#x5d ;; pop %ebp
|
|
;;2d:
|
|
;;;;;;#x68 #x09 #x00 #x00 #x00 ;; push $0x9
|
|
;;32:
|
|
;;;;;;#xe8 #xfc #xff #xff #xff ;; call 33 <main+0x33>
|
|
;;37:
|
|
;;;;;;#x83 #xc4 #x10 ;; add $0x10,%esp
|
|
;;3a:
|
|
;;;;#x83 #x45 #xf4 ,step ;; addl $step,-0xc(%ebp)
|
|
;;3e:
|
|
;;;;#x83 #x7d #xf4 ,test ;; cmpl $test,-0xc(%ebp)
|
|
#x81 #x45 #xf4 ,@(int->bv32 step) ;;addl $step,-0xc(%ebp)
|
|
#x81 #x7d #xf4 ,@(int->bv32 test) ;;cmpl $0x7cff,-0xc(%ebp)
|
|
;;42:
|
|
;;;;#x7e ,(- 0 (length statement) 18) ;;#xe6 ;; jle 2a <main+0x2a>
|
|
#x75 ,(- 0 (length statement) 18) ;;#xe6 ;; jne 2a <main+0x2a>
|
|
))
|
|
|
|
|
|
(define mescc
|
|
(let ((errorp
|
|
(lambda args
|
|
(for-each display args)
|
|
(newline))))
|
|
(lambda ()
|
|
(c-parser (c-lexer errorp) errorp))))
|
|
|
|
(define (write-any x) (write-char (if (char? x) x (integer->char (if (>= x 0) x (+ x 256))))))
|
|
|
|
(define (ast:function? o)
|
|
(and (pair? o) (eq? (car o) 'function)))
|
|
|
|
(define (.name o)
|
|
(cadr o))
|
|
|
|
;; (define (.statement o)
|
|
;; (match o
|
|
;; (('function name signature statement) statement)
|
|
;; (_ #f)))
|
|
|
|
;; (define (statement->data o)
|
|
;; (match o
|
|
;; (('call 'puts ('arguments string)) (string->list string))
|
|
;; (_ '())))
|
|
|
|
;; (define (statement->text o)
|
|
;; (match o
|
|
;; (('call 'puts ('arguments string)) (list (lambda (data) (i386:puts data (string-length string)))))
|
|
;; (('return code) (list (lambda (data) (i386:exit code))))
|
|
;; (_ '())))
|
|
|
|
(define (.statement o)
|
|
(and (pair? o)
|
|
(eq? (car o) 'function)
|
|
(cadddr o)))
|
|
|
|
(define (statement->data o)
|
|
(or (and (pair? o)
|
|
(eq? (car o) 'call)
|
|
(string->list (cadr (caddr o))))
|
|
(and (pair? o) (eq? (car o) 'for)
|
|
(let ((statement (cadr (cdddr o))))
|
|
(statement->data statement)))
|
|
'()))
|
|
|
|
(define (statement->text data o)
|
|
(cond
|
|
((and (pair? o) (eq? (car o) 'call))
|
|
(let ((string (cadr (caddr o)))
|
|
(offset (length data)))
|
|
(list (lambda (data) (i386:puts (+ data offset) (string-length string))))))
|
|
((and (pair? o) (eq? (car o) 'for))
|
|
(let ((start (cadr o))
|
|
(test (caddr o))
|
|
(step (cadddr o))
|
|
(statement (cadr (cdddr o))))
|
|
(display "start:" (current-error-port))
|
|
(display start (current-error-port))
|
|
(newline (current-error-port))
|
|
|
|
(display "test:" (current-error-port))
|
|
(display test (current-error-port))
|
|
(newline (current-error-port))
|
|
|
|
(display "step:" (current-error-port))
|
|
(display step (current-error-port))
|
|
(newline (current-error-port))
|
|
|
|
(display "for-statement:" (current-error-port))
|
|
(display statement (current-error-port))
|
|
(newline (current-error-port))
|
|
|
|
(let ((start (cadr (cdadr start)))
|
|
(test (cadr (cdadr test)))
|
|
;;(step (cadr (cdadr step)))
|
|
(step 1)
|
|
(statement (car (statement->text data statement)))
|
|
)
|
|
(display "2start:" (current-error-port))
|
|
(display start (current-error-port))
|
|
(newline (current-error-port))
|
|
|
|
(display "2for-statement:" (current-error-port))
|
|
(display statement (current-error-port))
|
|
(newline (current-error-port))
|
|
|
|
(list (lambda (d) (i386:for start test step (statement d)))))))
|
|
((and (pair? o) (eq? (car o) 'return))
|
|
(list (lambda (data) (i386:exit (cadr o)))))
|
|
(else '())))
|
|
|
|
(let* ((ast (mescc))
|
|
(functions (filter ast:function? (cdr ast)))
|
|
(main (find (lambda (x) (eq? (.name x) 'main)) functions))
|
|
(statements (cdr (.statement main))))
|
|
(display "program: " (current-error-port))
|
|
(display ast (current-error-port))
|
|
(newline (current-error-port))
|
|
(let loop ((statements statements) (text '()) (data '()))
|
|
(display "text:" (current-error-port))
|
|
(display text (current-error-port))
|
|
(newline (current-error-port))
|
|
(if (null? statements)
|
|
(map write-any (make-elf (lambda (data)
|
|
(append-map (lambda (f) (f data)) text)) data))
|
|
(let* ((statement (car statements)))
|
|
(display "statement:" (current-error-port))
|
|
(display statement (current-error-port))
|
|
(newline (current-error-port))
|
|
(loop (cdr statements)
|
|
(append text (statement->text data statement))
|
|
(append data (statement->data statement)))))))
|