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

mescc: Refactor variable declaration.

Browse source 
* module/language/c99/compiler.mes (decl->info): Refactor.
This commit is contained in:
Jan Nieuwenhuizen 2018-05-05 12:30:06 +02:00
parent 1b8d59fd0f
commit c9ba7a619b
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
26 changed files with 2561 additions and 1780 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -75,6 +75,7 @@ t
46-function-static
47-function-expression
48-function-destruct
49-global-static
50-assert
51-strcmp
52-itoa
@ -82,6 +83,7 @@ t
54-argv
60-math
61-array
62-array
63-struct-cell
64-make-cell
65-read
@ -205,8 +207,8 @@ tests="
50_logical_second_arg
51_static
52_unnamed_enum
55_lshift_type
54_goto
55_lshift_type
"
broken="$broken
@ -219,6 +221,7 @@ broken="$broken
27_sizeof
28_strings
31_args
32_led
34_array_assignment
37_sprintf
@ -230,7 +233,6 @@ broken="$broken
46_grep
49_bracket_evaluation
51_static
52_unnamed_enum
55_lshift_type
"

87
doc/UPDATE-0.13 Normal file
View file

@ -0,0 +1,87 @@
Subject: wip-bootstrap updated
I've updated the wip-bootstrap branch[0] for Mes[1] 0.13. It has new
mes-boot and tcc-boot packages. mes-boot is a bootstrap version of
Mes; it only depends on mescc-tools and a previously compiled mes.M1
seed. Likewise, tcc-boot depends on a precompiled tcc-seed. Also,
tcc-boot uses a heavily patched version of the tcc sources.
Mes 0.13 is the first release that can bootstrap a fairly functional
tcc-boot. This bootstrapped tcc passes 67/68 C tests that were created
for MesCC. It can compile a version if itself where float, long long
and bitfield are patched out...but linking fails. This amazing
compiler can now be played with by doing something like
--8<---------------cut here---------------start------------->8---
git checkout wip-bootstrap
make
./pre-inst-env guix build tcc-boot # may take ~2h
./pre-inst-env guix environment --ad-hoc tcc-boot
mes-tcc --help #duck and run
--8<---------------cut here---------------end--------------->8---
The next big effort will be to make this mes-tcc fully functional and
integrate this with GuixSD. To give you a taste of that,
here's latest bug I'm currently looking at (pretty printed comments
are only added when Guile runs MesCC, the problem is in LEA)
--8<---------------cut here---------------start------------->8---
$ diff -u ../mes-seed/mes.M1 src/mes.M1
--- ../mes-seed/mes.M1 2018-05-01 18:49:37.312162270 +0200
+++ src/mes.M1 2018-05-01 19:49:40.774770406 +0200
@@ -35805,12 +33091,11 @@
call32 %strcpy
add____$i8,%esp !0x8
test___%eax,%eax
- # strcpy(buf + strlen(buf), "/mes/");
- push___$i32 &_string_reader_read_list_266
+ push___$i32 &_string_reader_read_list_265
mov____%ebp,%eax
- add____$i32,%eax %0x-200
+ add____$i32,%eax %0x-800
push___%eax
- lea____0x32(%ebp),%eax %0x-200
+ lea____0x32(%ebp),%eax %0x-800
push___%eax
call32 %strlen
add____$i8,%esp !0x4
--8<---------------cut here---------------end--------------->8---
We also need to remove some shortcuts that we took, most notably:
mes-seed[3]. This seed consists of 1MB of M1 code. mes.M1 is
produced by compiling mes.c using MesCC, the C compiler written in
(Guile) Scheme that comes with Mes. Although that's really terrible,
it's probably a big step forward: currently GuixSD uses ~250MB of
binary seed: the bootstrap binaries.
The plan is to replace the mes.M1 seed with mes.M2 and compile this
new mes.M2 seed using the brand new M2-Planet[2]. M2 is basically
simple C with structs, without preprocessor. This will reduce the
seed size by a factor of 10 while making it much more readable.
An excerpt of the TODO I keep in Mes' BOOTSTRAP document
--8<---------------cut here---------------start------------->8---
* TODO
** have tcc-boot's mes-tcc compile a fully functional tcc
*** mescc: fix unknown bug.
*** mescc: support function-static.
*** mescc: support/grok global static.
*** mescc: support unsigned comparison, arithmetic.
*** mescc: support long long (do we need long long to get long long in tcc)?
*** mescc: support bitfield (do we need bitfield to get bitfield in tcc)?
*** mescc: support float (do we need float to get float in tcc)?
** have bootstrapped tcc compile gcc-4.7
** remove or upstream patches from tcc-boot
** prepare src/mes.c for M2-Planet[2] transpiler
** integrate with GuixSD
** x86_64, arm, the Hurd
--8<---------------cut here---------------end--------------->8---
Greetings,
janneke
[0] http://git.savannah.gnu.org/cgit/guix.git/log/?h=wip-bootstrap
[1] https://gitlab.com/janneke/mes
[2] https://github.com/oriansj/m2-planet
[3] https://gitlab.com/janneke/mes-seed

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

File diff suppressed because it is too large Load diff

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

@ -57,6 +57,7 @@
global:name
global:type
global:pointer
global:array
global:value
global:function
global->string
@ -66,6 +67,7 @@
local?
local:type
local:pointer
local:array
local:id
<function>
@ -109,11 +111,12 @@
(description type:description))
(define-immutable-record-type <global>
(make-global name type pointer value function)
(make-global name type pointer array value function)
global?
(name global:name)
(type global:type)
(pointer global:pointer)
(array global:array)
(value global:value)
(function global:function))
@ -122,10 +125,11 @@
(global:name o)))
(define-immutable-record-type <local>
(make-local type pointer id)
(make-local type pointer array id)
local?
(type local:type)
(pointer local:pointer)
(array local:array)
(id local:id))
(define-immutable-record-type <function>

8
module/mes/M1.mes
View file

@ -129,9 +129,11 @@
(hex2:address address))
((#:address (#:address ,global)) (guard (global? global))
(hex2:address (global->string global)))
((#:string ,string) (hex2:address (string->label o)))
((#:address ,address) (string? address) (hex2:address address))
((#:address ,global) (global? global) (error "urg1: global without a name\n"))
((#:string ,string)
(hex2:address (string->label o)))
((#:address ,address) (guard (string? address)) (hex2:address address))
((#:address ,global) (guard (global? global))
(hex2:address (global->string global)))
((#:offset ,offset) (hex2:offset offset))
((#:offset1 ,offset1) (hex2:offset1 offset1))
((#:immediate ,immediate) (hex2:immediate immediate))

25
scaffold/boot/02-identifier.scm Normal file
View file

@ -0,0 +1,25 @@
;;; 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/>.
'boo
'4a
12345
-22
+44
(list 0)
'...

56
scaffold/boot/03-big-string.scm Normal file
View file

@ -0,0 +1,56 @@
;;; 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/>.
"Mes is distributed WITHOUT ANY WARRANTY. The following
sections from the GNU General Public License, version 3, should
make that clear.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
See <http://www.gnu.org/licenses/gpl.html>, for more details.
"

28
scaffold/boot/05-big-list.scm Normal file
View file

@ -0,0 +1,28 @@
;;; 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/>.
(list 00 01 02 03 04 05 06 07 08 09
10 11 12 13 14 15 16 17 18 19
20 21 22 23 24 25 26 27 28 29
30 31 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49
50 51 52 53 54 55 56 57 58 59
60 61 62 63 64 65 66 67 68 69
70 71 72 73 74 75 76 77 78 79
80 81 82 83 84 85 86 87 88 89
90 91 92 93 94 95 96 97 98 99)

19
scaffold/boot/05-list-list.scm Normal file
View file

@ -0,0 +1,19 @@
;;; 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/>.
(list 0 1 (list 20 21) 3)

564
scaffold/boot/60-let-syntax-expanded.scm Normal file
View file

@ -0,0 +1,564 @@
;;; 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/>.
;; boot-00.scm
(define mes %version)
(define (defined? x)
(assq x (current-module)))
(define (cond-expand-expander clauses)
(if (defined? (car (car clauses)))
(cdr (car clauses))
(cond-expand-expander (cdr clauses))))
(define-macro (cond-expand . clauses)
(cons 'begin (cond-expand-expander clauses)))
;; end boot-00.scm
;; boot-01.scm
(define <cell:character> 0)
(define <cell:pair> 7)
(define <cell:string> 10)
(define (pair? x) (eq? (core:type x) <cell:pair>))
(define (not x) (if x #f #t))
(define (display x . rest)
(if (null? rest) (core:display x)
(core:display-port x (car rest))))
(define (write x . rest)
(if (null? rest) (core:write x)
(core:write-port x (car rest))))
(define (list->string lst)
(core:make-cell <cell:string> lst 0))
(define (integer->char x)
(core:make-cell <cell:character> 0 x))
(define (newline . rest)
(core:display (list->string (list (integer->char 10)))))
(define (string->list s)
(core:car s))
(define (cadr x) (car (cdr x)))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define map map1)
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
;; end boot-01.scm
;;((lambda (*program*) *program*) (primitive-load 0))
;;(primitive-load 0)
;;; 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/>.
(define-macro (and . x)
(if (null? x) #t
(if (null? (cdr x)) (car x)
(list (quote if) (car x) (cons (quote and) (cdr x))
#f))))
(define-macro (or . x)
(if (null? x) #f
(if (null? (cdr x)) (car x)
(list (list (quote lambda) (list (quote r))
(list (quote if) (quote r) (quote r)
(cons (quote or) (cdr x))))
(car x)))))
(define else #t)
(define-macro (cond . clauses)
(list 'if (pair? clauses)
(list (cons
'lambda
(cons
'(test)
(list (list 'if 'test
(if (pair? (cdr (car clauses)))
(if (eq? (car (cdr (car clauses))) '=>)
(append2 (cdr (cdr (car clauses))) '(test))
(list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
(list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
(if (pair? (cdr clauses))
(cons 'cond (cdr clauses)))))))
(car (car clauses)))))
(define (memq x lst)
(if (null? lst) #f
(if (eq? x (car lst)) lst
(memq x (cdr lst)))))
;; (cond-expand
;; (guile
;; (define closure identity)
;; (define body identity)
;; (define append2 append)
;; (define (core:apply f a m) (f a))
;; )
;; (mes
(define <cell:symbol> 11)
(define (symbol? x)
(eq? (core:type x) <cell:symbol>))
(define (string->symbol s)
(if (not (pair? (core:car s))) '()
(core:lookup-symbol (core:car s))))
(define <cell:string> 10)
(define (string? x)
(eq? (core:type x) <cell:string>))
(define <cell:vector> 14)
(define (vector? x)
(eq? (core:type x) <cell:vector>))
;; (define (body x)
;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module)))))))
;; (define (closure x)
;; (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))
;; ))
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define-macro (quasiquote x)
;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n")
(define (loop x)
;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n")
(if (vector? x) (list 'list->vector (loop (vector->list x)))
(if (not (pair? x)) (cons 'quote (cons x '()))
(if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
(if (eq? (car x) 'unquote) (cadr x)
(if (and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
((lambda (d)
(list 'append (car (cdr (car x))) d))
(loop (cdr x)))
((lambda (a d)
(if (pair? d)
(if (eq? (car d) 'quote)
(if (and (pair? a) (eq? (car a) 'quote))
(list 'quote (cons (cadr a) (cadr d)))
(if (null? (cadr d))
(list 'list a)
(list 'cons* a d)))
(if (memq (car d) '(list cons*))
(cons (car d) (cons a (cdr d)))
(list 'cons* a d)))
(list 'cons* a d)))
(loop (car x))
(loop (cdr x)))))))))
(loop x))
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define-macro (simple-let bindings . rest)
(cons (cons 'lambda (cons (map car bindings) rest))
(map cadr bindings)))
(define-macro (xsimple-let bindings rest)
`(,`(lambda ,(map car bindings) ,@rest)
,@(map cadr bindings)))
(define-macro (xnamed-let name bindings rest)
`(simple-let ((,name *unspecified*))
(set! ,name (lambda ,(map car bindings) ,@rest))
(,name ,@(map cadr bindings))))
(define-macro (let bindings-or-name . rest)
(if (symbol? bindings-or-name) ;; IF
`(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
`(xsimple-let ,bindings-or-name ,rest)))
(define (expand-let* bindings body)
(if (null? bindings)
`((lambda () ,@body))
`((lambda (,(caar bindings))
,(expand-let* (cdr bindings) body))
,@(cdar bindings))))
(define-macro (let* bindings . body)
(expand-let* bindings body))
(define (equal2? a b)
(if (and (null? a) (null? b)) #t
(if (and (pair? a) (pair? b))
(and (equal2? (car a) (car b))
(equal2? (cdr a) (cdr b)))
(if (and (string? a) (string? b))
(eq? (string->symbol a) (string->symbol b))
(if (and (vector? a) (vector? b))
(equal2? (vector->list a) (vector->list b))
(eq? a b))))))
(define equal? equal2?)
(define (member x lst)
(if (null? lst) #f
(if (equal2? x (car lst)) lst
(member x (cdr lst)))))
(define (<= . rest)
(or (apply < rest)
(apply = rest)))
(define (>= . rest)
(or (apply > rest)
(apply = rest)))
(define (list? x)
(or (null? x)
(and (pair? x) (list? (cdr x)))))
;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
;;; Copyright © 2016 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/>.
;;; Commentary:
;;; syntax.mes is loaded after scm.mes. It provides the R5RS hygienic
;;; macros define-syntax, syntax-rules and define-syntax-rule.
;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm
;;; Code:
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
;;; scheme48-1.1/COPYING
;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
;; All rights reserved.
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 1. Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;; 3. The name of the authors may not be used to endorse or promote products
;; derived from this software without specific prior written permission.
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(cond-expand
(guile)
(mes
(define-macro (define-syntax macro-name transformer . stuff)
`(define-macro (,macro-name . args)
(,transformer (cons ',macro-name args)
(lambda (x0) x0)
eq?)))))
;; Rewrite-rule compiler (a.k.a. "extend-syntax")
;; Example:
;;
;; (define-syntax or
;; (syntax-rules ()
;; ((or) #f)
;; ((or e) e)
;; ((or e1 e ...) (let ((temp e1))
;; (if temp temp (or e ...))))))
(cond-expand
(guile)
(mes
(define-syntax syntax-rules
(let ()
(define name? symbol?)
(define (segment-pattern? pattern)
(and (segment-template? pattern)
(or (null? (cddr pattern))
(syntax-error0 "segment matching not implemented" pattern))))
(define (segment-template? pattern)
(and (pair? pattern)
(pair? (cdr pattern))
(memq (cadr pattern) indicators-for-zero-or-more)))
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
(lambda (exp r c)
(define %input (r '%input)) ;Gensym these, if you like.
(define %compare (r '%compare))
(define %rename (r '%rename))
(define %tail (r '%tail))
(define %temp (r '%temp))
(define rules (cddr exp))
(define subkeywords (cadr exp))
(define (make-transformer rules)
;;(core:display-error "make-transformer:") (core:write-error rules) (core:display-error "\n")
`(lambda (,%input ,%rename ,%compare)
(let ((,%tail (cdr ,%input)))
(cond ,@(map process-rule rules)
(else
(syntax-error1
"use of macro doesn't match definition"
,%input))))))
(define (process-rule rule)
;;(core:display-error "process-rule:") (core:write-error rule) (core:display-error "\n")
(if (and (pair? rule)
(pair? (cdr rule))
(null? (cddr rule)))
(let ((pattern (cdar rule))
(template (cadr rule)))
`((and ,@(process-match %tail pattern))
(let* ,(process-pattern pattern
%tail
(lambda (x) x))
,(process-template template
0
(meta-variables pattern 0 '())))))
(syntax-error2 "ill-formed syntax rule" rule)))
;; Generate code to test whether input expression matches pattern
(define (process-match input pattern)
;;(core:display-error "process-match:") (core:write-error input) (core:display-error "\n")
;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n")
(cond ((name? pattern)
(if (member pattern subkeywords)
`((,%compare ,input (,%rename ',pattern)))
`()))
((segment-pattern? pattern)
(process-segment-match input (car pattern)))
((pair? pattern)
`((let ((,%temp ,input))
(and (pair? ,%temp)
,@(process-match `(car ,%temp) (car pattern))
,@(process-match `(cdr ,%temp) (cdr pattern))))))
((or (null? pattern) (boolean? pattern) (char? pattern))
`((eq? ,input ',pattern)))
(else
`((equal? ,input ',pattern)))))
(define (process-segment-match input pattern)
;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n")
(let ((conjuncts (process-match '(car l) pattern)))
(if (null? conjuncts)
`((list? ,input)) ;+++
`((let loop ((l ,input))
(or (null? l)
(and (pair? l)
,@conjuncts
(loop (cdr l)))))))))
;; Generate code to take apart the input expression
;; This is pretty bad, but it seems to work (can't say why).
(define (process-pattern pattern path mapit)
;;(core:display-error "process-pattern:") (core:write-error pattern) (core:display-error "\n")
;;(core:display-error " path:") (core:write-error path) (core:display-error "\n")
(cond ((name? pattern)
(if (memq pattern subkeywords)
'()
(list (list pattern (mapit path)))))
((segment-pattern? pattern)
(process-pattern (car pattern)
%temp
(lambda (x) ;temp is free in x
(mapit (if (eq? %temp x)
path ;+++
`(map (lambda (,%temp) ,x)
,path))))))
((pair? pattern)
(append (process-pattern (car pattern) `(car ,path) mapit)
(process-pattern (cdr pattern) `(cdr ,path) mapit)))
(else '())))
;; Generate code to compose the output expression according to template
(define (process-template template rank env)
;;(core:display-error "process-template:") (core:write-error template) (core:display-error "\n")
(cond ((name? template)
(let ((probe (assq template env)))
(if probe
(if (<= (cdr probe) rank)
template
(syntax-error3 "template rank error (too few ...'s?)"
template))
`(,%rename ',template))))
((segment-template? template)
(let ((vars
(free-meta-variables (car template) (+ rank 1) env '())))
(if (null? vars)
(silent-syntax-error4 "too many ...'s" template)
(let* ((x (process-template (car template)
(+ rank 1)
env))
(gen (if (equal? (list x) vars)
x ;+++
`(map (lambda ,vars ,x)
,@vars))))
(if (null? (cddr template))
gen ;+++
`(append ,gen ,(process-template (cddr template)
rank env)))))))
((pair? template)
`(cons ,(process-template (car template) rank env)
,(process-template (cdr template) rank env)))
(else `(quote ,template))))
;; Return an association list of (var . rank)
(define (meta-variables pattern rank vars)
;;(core:display-error "meta-variables:") (core:write-error pattern) (core:display-error "\n")
(cond ((name? pattern)
(if (memq pattern subkeywords)
vars
(cons (cons pattern rank) vars)))
((segment-pattern? pattern)
(meta-variables (car pattern) (+ rank 1) vars))
((pair? pattern)
(meta-variables (car pattern) rank
(meta-variables (cdr pattern) rank vars)))
(else vars)))
;; Return a list of meta-variables of given higher rank
(define (free-meta-variables template rank env free)
;;(core:display-error "meta-variables:") (core:write-error template) (core:display-error "\n")
(cond ((name? template)
(if (and (not (memq template free))
(let ((probe (assq template env)))
(and probe (>= (cdr probe) rank))))
(cons template free)
free))
((segment-template? template)
(free-meta-variables (car template)
rank env
(free-meta-variables (cddr template)
rank env free)))
((pair? template)
(free-meta-variables (car template)
rank env
(free-meta-variables (cdr template)
rank env free)))
(else free)))
c ;ignored
;; Kludge for Scheme48 linker.
;; `(cons ,(make-transformer rules)
;; ',(find-free-names-in-syntax-rules subkeywords rules))
(make-transformer rules))))))
(cond-expand
(guile)
(mes
(define-macro (let-syntax bindings . rest)
`((lambda ()
,@(map (lambda (binding)
`(define-macro (,(car binding) . args)
(,(cadr binding) (cons ',(car binding) args)
(lambda (x0) x0)
eq?)))
bindings)
,@rest)))))
(core:display
(let-syntax ((xwhen (syntax-rules ()
((xwhen condition exp ...)
(if (not condition)
(begin exp ...))))))
(xwhen #f 42)))

60
scaffold/boot/call-cc.scm Normal file
View file

@ -0,0 +1,60 @@
;;; 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/>.
;; ,expand (let loop ((i 10)) (if (eq? i 0) 0 (begin (core:display-error i) (core:display-error "\n") (loop (- i 1)))))
;; (let loop ((i 10)) (if (eq? i 0) 0 (begin (display i) (display "\n") (loop (- i 1)))))
(define global "global\n")
(define v #(0 1 2))
(define vv #(#(0 1 2) 0 1 2))
((lambda (loop)
(set! loop
(lambda (i)
(core:display global)
(core:display (values 'foobar global))
(core:display v)
(core:display vv)
(core:display "i=")
(core:display i)
(core:display "\n")
(if (eq? i 0) 0
(begin
((lambda (cont seen?)
(+ 1 (call-with-current-continuation (lambda (c) (set! cont c) 1)))
(core:display " seen?=")
(core:display seen?)
(core:display "\n")
(if seen? 0
(begin
(set! seen? #t)
(cont 2))))
#f #f)
(loop (- i 1))))))
(loop 10000))
*unspecified*)
;; ((lambda (cont seen?)
;; (+ 1 (call-with-current-continuation (lambda (c) (set! cont c) 1)))
;; (core:display "seen?=")
;; (core:display seen?)
;; (core:display "\n")
;; (if seen? 0
;; (begin
;; (set! seen? #t)
;; (cont 2))))
;; #f #f)

41
scaffold/boot/memory.scm Normal file
View file

@ -0,0 +1,41 @@
;;; 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/>.
;; ,expand (let loop ((i 10)) (if (eq? i 0) 0 (begin (core:display-error i) (core:display-error "\n") (loop (- i 1)))))
;; (let loop ((i 10)) (if (eq? i 0) 0 (begin (display i) (display "\n") (loop (- i 1)))))
((lambda (loop)
(set! loop
(lambda (i)
(if (eq? i 0) 0
(begin
(core:display i)
(core:display "\n")
(loop (- i 1))))))
(loop 10))
*unspecified*)
;; ((lambda (loop)
;; (set! loop
;; (lambda (i)
;; (if (eq? i 0) 0
;; (begin (display i)
;; (display "\n")
;; (loop (- i 1))))))
;; (loop 10))
;; *unspecified*)

1
scaffold/boot/numbers.scm Normal file
View file

@ -0,0 +1 @@
(cdr '(0 . 1))

4
scaffold/tests/21-char[].c
View file

@ -23,10 +23,10 @@
int
test ()
{
int f;
int v = 3;
char *s = "mes";
if (!s[0]) return 1;
int f;
int v = 3;
if (!s[f]) return 1;
if (s[3]) return 1;
if (s[v]) return 1;

2
scaffold/tests/23-pointer.c
View file

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software
* Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
* Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
*
* This file is part of Mes.
*

4
scaffold/tests/46-function-static.c
View file

@ -22,7 +22,9 @@ int
test ()
{
static int i = 1;
return i--;
static int foo = 0;
foo = 0;
return foo - i--;
}
static int i = 2;

0
scaffold/tests/48-global-static.c → scaffold/tests/49-global-static.c
View file

3
scaffold/tests/54-argv.c
View file

@ -26,6 +26,7 @@ main (int argc, char *argv[])
{
puts ("\n");
puts ("t: argv[0] == \"scaffold/test....\"\n");
puts ("argv0="); puts (argv[0]); puts ("\n");
if (strncmp (argv[0], "scaffold/test", 5)) return 1;
puts ("t: *argv\"\n");
@ -33,7 +34,7 @@ main (int argc, char *argv[])
puts ("\n");
puts ("t: if (argc > 1 && !strcmp (argv[1], \"--help\")\n");
if (argc > 1 && !strcmp (argv[1], "--help")) return 1;
if (argc > 1 && !strcmp (argv[1], "--help")) return 2;
return 0;
}

55
scaffold/tests/62-array.c Normal file
View file

@ -0,0 +1,55 @@
/* -*-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/>.
*/
#include <string.h>
int one_two_three[3] =
{
1, 2, 3
};
char *foo_bar_baz[3] =
{
"foo", "bar", "baz"
};
char foo_bar_baz_haha[3][4] =
{
"foo", "bar", "baz"
};
char *foo = "foo";
char *bar = "bar";
char *baz = "baz";
char *foo_bar_baz_mwhuhahaha[3] =
{
&foo, &bar, &baz
};
int
main ()
{
puts ("one:"); puts (itoa (one_two_three[0])); puts ("\n");
puts ("foo:"); puts (foo_bar_baz[1]); puts ("\n");
puts ("bar:"); puts (foo_bar_baz_haha[2]); puts ("\n");
char *p = foo_bar_baz_haha[2];
puts ("baz:"); puts (p); puts ("\n");
return strcmp (foo_bar_baz[2], "baz");
}

320
scaffold/tests/63-struct-cell.c
View file

@ -20,47 +20,47 @@
#include "30-test.i"
#include <stdio.h>
// #include <stdio.h>
#include <stdlib.h>
#include <string.h>
// #include <string.h>
int
add (int a, int b)
{
return a + b;
}
// int
// add (int a, int b)
// {
// return a + b;
// }
int
inc (int i)
{
return i + 1;
}
// int
// inc (int i)
// {
// return i + 1;
// }
struct scm {
int type;
int car;
int cdr;
};
// struct scm {
// int type;
// int car;
// int cdr;
// };
int bla = 1234;
char g_arena[84];
#if __MESC__
struct scm *g_cells = g_arena;
#else
struct scm *g_cells = (struct scm*)g_arena;
#endif
char *g_chars = g_arena;
// int bla = 1234;
// char g_arena[84];
// #if __MESC__
// struct scm *g_cells = g_arena;
// #else
// struct scm *g_cells = (struct scm*)g_arena;
// #endif
// char *g_chars = g_arena;
int foo () {puts ("t: foo\n"); return 0;};
int bar (int i) {puts ("t: bar\n"); return 0;};
// int foo () {puts ("t: foo\n"); return 0;};
// int bar (int i) {puts ("t: bar\n"); return 0;};
struct function {
int (*function) (void);
int arity;
char *name;
};
struct function g_fun = {&exit,1,"fun"};
struct function g_foo = {&foo,0,"foo"};
struct function g_bar = {&bar,1,"bar"};
// struct function g_foo = {&foo,0,"foo"};
// struct function g_bar = {&bar,1,"bar"};
//void *functions[2];
int functions[2];
@ -68,181 +68,183 @@ int functions[2];
struct function g_functions[2];
int g_function = 0;
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART};
// enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART};
typedef int SCM;
int g_free = 3;
SCM tmp;
SCM tmp_num;
// typedef int SCM;
// int g_free = 3;
// SCM tmp;
// SCM tmp_num;
int ARENA_SIZE = 200;
#define TYPE(x) g_cells[x].type
#define CAR(x) g_cells[x].car
#define CDR(x) g_cells[x].cdr
#define VALUE(x) g_cells[x].cdr
// int ARENA_SIZE = 200;
// #define TYPE(x) g_cells[x].type
// #define CAR(x) g_cells[x].car
// #define CDR(x) g_cells[x].cdr
// #define VALUE(x) g_cells[x].cdr
#define CAAR(x) CAR (CAR (x))
// #define CAAR(x) CAR (CAR (x))
struct scm scm_fun = {TFUNCTION,0,0};
SCM cell_fun;
// struct scm scm_fun = {TFUNCTION,0,0};
// SCM cell_fun;
int
test ()
{
puts ("\n");
puts ("t: g_cells[0] = g_cells[1]\n");
TYPE (1) = 1;
CAR (1) = 2;
CDR (1) = 3;
g_cells[0] = g_cells[1];
if (TYPE (0) != 1) return 1;
if (CAR (0) != 2) return 2;
if (CDR (0) != 3) return 3;
// puts ("\n");
// puts ("t: g_cells[0] = g_cells[1]\n");
// TYPE (1) = 1;
// CAR (1) = 2;
// CDR (1) = 3;
// g_cells[0] = g_cells[1];
// if (TYPE (0) != 1) return 1;
// if (CAR (0) != 2) return 2;
// if (CDR (0) != 3) return 3;
puts ("t: g_cells[i] = g_cells[j]\n");
int i = 0;
int j = 1;
TYPE (1) = 4;
CAR (1) = 5;
CDR (1) = 6;
g_cells[i] = g_cells[j];
if (TYPE (0) != 4) return 1;
if (CAR (0) != 5) return 2;
if (CDR (0) != 6) return 3;
// puts ("t: g_cells[i] = g_cells[j]\n");
// int i = 0;
// int j = 1;
// TYPE (1) = 4;
// CAR (1) = 5;
// CDR (1) = 6;
// g_cells[i] = g_cells[j];
// if (TYPE (0) != 4) return 1;
// if (CAR (0) != 5) return 2;
// if (CDR (0) != 6) return 3;
puts ("t: g_cells[0+add(0,0] = g_cells[0+inc(0)]\n");
TYPE (1) = 1;
CAR (1) = 2;
CDR (1) = 3;
g_cells[0+add(0, 0)] = g_cells[0+inc(0)];
if (TYPE (0) != 1) return 1;
if (CAR (0) != 2) return 2;
if (CDR (0) != 3) return 3;
// puts ("t: g_cells[0+add(0,0] = g_cells[0+inc(0)]\n");
// TYPE (1) = 1;
// CAR (1) = 2;
// CDR (1) = 3;
// g_cells[0+add(0, 0)] = g_cells[0+inc(0)];
// if (TYPE (0) != 1) return 1;
// if (CAR (0) != 2) return 2;
// if (CDR (0) != 3) return 3;
g_cells[0].type = TNUMBER;
g_cells[0].car = 0;
g_cells[0].cdr = 0;
g_cells[1].type = TNUMBER;
g_cells[1].car = 0;
g_cells[1].cdr = 0;
// g_cells[0].type = TNUMBER;
// g_cells[0].car = 0;
// g_cells[0].cdr = 0;
// g_cells[1].type = TNUMBER;
// g_cells[1].car = 0;
// g_cells[1].cdr = 0;
puts ("t: TYPE (0) != TYPE (1)\n");
if (TYPE (0) == TYPE (1)) goto ok;
return 1;
ok:
// puts ("t: TYPE (0) != TYPE (1)\n");
// if (TYPE (0) == TYPE (1)) goto ok;
// return 1;
// ok:
g_cells[0].car = 1;
g_cells[1].car = 2;
// g_cells[0].car = 1;
// g_cells[1].car = 2;
puts ("t: int c = VALUE (0)\n");
int c = CAR (0);
if (c != 1) return 1;
// puts ("t: int c = VALUE (0)\n");
// int c = CAR (0);
// if (c != 1) return 1;
puts ("t: CAAR (0) != 2\n");
if (CAAR (0) != 2) return 1;
// puts ("t: CAAR (0) != 2\n");
// if (CAAR (0) != 2) return 1;
puts ("t: 2 != CAAR (0)\n");
if (2 != CAAR (0)) return 1;
// puts ("t: 2 != CAAR (0)\n");
// if (2 != CAAR (0)) return 1;
g_cells[3].type = 0x64;
if (g_cells[3].type != 0x64)
return g_cells[3].type;
// g_cells[3].type = 0x64;
// if (g_cells[3].type != 0x64)
// return g_cells[3].type;
TYPE (4) = 4;
if (TYPE (4) != 4)
return 4;
// TYPE (4) = 4;
// if (TYPE (4) != 4)
// return 4;
CDR (3) = 0x22;
CDR (4) = 0x23;
if (CDR (3) != 0x22)
return CDR (3);
// CDR (3) = 0x22;
// CDR (4) = 0x23;
// if (CDR (3) != 0x22)
// return CDR (3);
puts ("t: g_fun.arity != 1;\n");
if (g_fun.arity != 1) return 1;
// puts ("t: g_fun.arity != 1;\n");
// if (g_fun.arity != 1) return 1;
puts ("t: g_fun.function != exit;\n");
if (g_fun.function != &exit) return 1;
// puts ("t: g_fun.function != exit;\n");
// if (g_fun.function != &exit) return 1;
puts ("t: struct fun = {&exit,1,\"exit\"};\n");
struct function fun = {&exit,1,"exit"};
// puts ("t: struct fun = {&exit,1,\"exit\"};\n");
// struct function fun = {&exit,1,"exit"};
puts ("t: fun.arity != 1;\n");
if (fun.arity != 1) return 1;
// puts ("t: fun.arity != 1;\n");
// if (fun.arity != 1) return 1;
puts ("t: fun.function != exit;\n");
if (fun.function != &exit) return 1;
// puts ("t: fun.function != exit;\n");
// if (fun.function != &exit) return 1;
puts ("t: puts (fun.name)\n");
if (strcmp (fun.name, "exit")) return 1;
// puts ("t: puts (fun.name)\n");
// if (strcmp (fun.name, "exit")) return 1;
puts ("t: puts (g_fun.name)\n");
if (strcmp (g_fun.name, "fun")) return 1;
// puts ("t: puts (g_fun.name)\n");
// if (strcmp (g_fun.name, "fun")) return 1;
puts ("t: g_functions[g_function++] = g_foo;\n");
g_functions[g_function++] = g_foo;
// puts ("t: g_functions[g_function++] = g_foo;\n");
// g_functions[g_function++] = g_foo;
puts ("t: pbar->arity == 1\n");
struct function* barp = &g_bar;
if (barp->arity != 1) return 1;
// puts ("t: pbar->arity == 1\n");
// struct function* barp = &g_bar;
// if (barp->arity != 1) return 1;
int fn = 0;
puts ("t: g_functions[g_cells[fn].cdr].arity\n");
if (g_functions[g_cells[fn].cdr].arity) return 1;
if (g_functions[g_cells[fn].cdr].arity != 0) return 1;
// int fn = 0;
// puts ("t: g_functions[g_cells[fn].cdr].arity\n");
// if (g_functions[g_cells[fn].cdr].arity) return 1;
// if (g_functions[g_cells[fn].cdr].arity != 0) return 1;
int (*functionx) (void) = 0;
functionx = g_functions[0].function;
puts ("t: functionx == foo\n");
if (functionx != foo) return 11;
// int (*functionx) (void) = 0;
// functionx = g_functions[0].function;
// puts ("t: functionx == foo\n");
// if (functionx != foo) return 11;
puts ("t: g_functions[0].name\n");
if (strcmp (g_functions[0].name, "foo")) return 1;
// puts ("t: g_functions[0].name\n");
// if (strcmp (g_functions[0].name, "foo")) return 1;
puts ("t: (functionx) () == foo\n");
if ((functionx) () != 0) return 12;
// puts ("t: (functionx) () == foo\n");
// if ((functionx) () != 0) return 12;
puts ("t: g_functions[<foo>].arity\n");
if (g_functions[0].arity != 0) return 17;
// puts ("t: g_functions[<foo>].arity\n");
// if (g_functions[0].arity != 0) return 17;
fn++;
g_functions[fn] = g_bar;
g_cells[fn].cdr = fn;
if (g_cells[fn].cdr != fn) return 13;
// fn++;
// g_functions[fn] = g_bar;
// g_cells[fn].cdr = fn;
// if (g_cells[fn].cdr != fn) return 13;
puts ("t: g_functions[g_cells[fn].cdr].function\n");
functionx = g_functions[g_cells[fn].cdr].function;
// puts ("t: g_functions[g_cells[fn].cdr].function\n");
// functionx = g_functions[g_cells[fn].cdr].function;
puts ("t: g_functions[1].name\n");
if (strcmp (g_functions[1].name, "bar")) return 1;
// puts ("t: g_functions[1].name\n");
// if (strcmp (g_functions[1].name, "bar")) return 1;
puts ("t: functionx == bar\n");
if (functionx != bar) return 15;
// puts ("t: functionx == bar\n");
// if (functionx != bar) return 15;
puts ("t: (functiony) (1) == bar\n");
int (*functiony) (int) = 0;
functiony = g_functions[g_cells[fn].cdr].function;
if ((functiony) (1) != 0) return 16;
// puts ("t: (functiony) (1) == bar\n");
// int (*functiony) (int) = 0;
// functiony = g_functions[g_cells[fn].cdr].function;
// if ((functiony) (1) != 0) return 16;
puts ("t: g_functions[<bar>].arity\n");
if (g_functions[fn].arity != 1) return 18;
// puts ("t: g_functions[<bar>].arity\n");
// if (g_functions[fn].arity != 1) return 18;
// fake name
scm_fun.car = 33;
scm_fun.cdr = g_function;
//g_functions[g_function++] = g_fun;
// // fake name
// scm_fun.car = 33;
// scm_fun.cdr = g_function;
// //g_functions[g_function++] = g_fun;
g_function++;
puts ("fun");
g_functions[g_function] = g_fun;
cell_fun = g_free++;
g_cells[cell_fun] = scm_fun;
// cell_fun = g_free++;
// g_cells[cell_fun] = scm_fun;
puts ("t: TYPE (cell_fun)\n");
if (TYPE (cell_fun) != TFUNCTION) return 1;
// puts ("t: TYPE (cell_fun)\n");
// if (TYPE (cell_fun) != TFUNCTION) return 1;
puts ("t: CAR (cell_fun)\n");
if (CAR (cell_fun) != 33) return 1;
// puts ("t: CAR (cell_fun)\n");
// if (CAR (cell_fun) != 33) return 1;
puts ("t: CDR (cell_fun)\n");
if (CDR (cell_fun) != g_function) return 1;
// puts ("t: CDR (cell_fun)\n");
// if (CDR (cell_fun) != g_function) return 1;
return 0;
}

7
scaffold/tests/70-printf.c
View file

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software
* Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
* Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
*
* This file is part of Mes.
*
@ -34,13 +34,14 @@ test ()
sprintf (buf, "c=%c\n", c);
if (strcmp (buf, "c=m\n")) return 1;
if (i != 3) return 15;
printf ("i=%d\n", i);
sprintf (buf, "i=%d\n", i);
if (strcmp (buf, "i=3\n")) return 1;
if (strcmp (buf, "i=3\n")) return 2;
printf ("s=%s\n", s);
sprintf (buf, "s=%s\n", s);
if (strcmp (buf, "s=mes\n")) return 1;
if (strcmp (buf, "s=mes\n")) return 3;
return 0;
}

2
scaffold/tests/71-struct-array.c
View file

@ -69,6 +69,8 @@ test ()
char *strings[] = { "one\n", "two\n", "three\n", NULL };
char **p = strings;
while (*p) puts (*p++);
if (strcmp (strings[1], "two\n"))
return 3;
strcpy (f.name, "hallo\n");
puts (f.name);

4
scaffold/tests/7i-struct-struct.c
View file

@ -54,9 +54,9 @@ test ()
struct anon a = {3,4};
a.baz = 4; // FIXME
printf ("a.bar=%d\n", a.bar);
if (a.bar != 3) return 1;
if (a.bar != 3) return 3;
printf ("a.baz=%d\n", a.baz);
if (a.baz != 4) return 1;
if (a.baz != 4) return 4;
return 0;
}

13
scaffold/tests/90-goto-var.c Normal file
View file

@ -0,0 +1,13 @@
int
main ()
{
static void *lbl = &&lbl_b;
goto *lbl;
lbl_a:
return 1;
lbl_b:
return 0;
}

34
scaffold/tests/91-goto-array.c Normal file
View file

@ -0,0 +1,34 @@
#include <stdio.h>
int main(void) {
static void *lbls[] = { &&lbl_h, &&lbl_e, &&lbl_l, &&lbl_l, &&lbl_o, &&lbl_quit };
static void **lbl = lbls;
goto **lbl;
lbl_e:
printf("e");
lbl++;
goto **lbl;
lbl_o:
printf("o");
lbl++;
goto **lbl;
lbl_h:
printf("h");
lbl++;
goto **lbl;
lbl_l:
printf("l");
lbl++;
goto **lbl;
lbl_quit:
puts("");
return 0;
}

112
scaffold/tests/t.c
View file

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software
* Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
* Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
*
* This file is part of Mes.
*
@ -18,30 +18,102 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#include "30-test.i"
char g_arena[4] = "XXX";
char *g_chars = g_arena;
int puts (char const*);
#include <string.h>
char global_arena[10];
int global_i = 1;
int global_unitialized;
char* global_string = "foo";
char global_array[8] = "XXX";
char *global_chars = global_array;
typedef int SCM;
enum type_t {TCHAR};
char *env[] = {"foo", "bar", "baz", 0};
char *list[2] = {"foo\n", "bar\n"};
struct foo {int length; char* string;};
struct foo f = {3, "foo"};
struct foo g_foes[2];
int g_foe;
struct anon {struct {int bar; int baz;};};
struct here {int and;} there;
int
test ()
main (int argc, char* argv[])
{
puts ("X\n");
if (*g_chars != 'X') return 1;
g_arena[0] = 'A';
puts ("A\n");
if (*g_chars != 'A') return 1;
int i;
int j = 1;
int k, l = 1;
if (j != 1)
return 1;
if (l != 1)
return 2;
if (global_i != 1)
return 3;
global_arena[1] = 0;
if (global_i != 1)
return 4;
if (global_unitialized != 0)
return 5;
if (strcmp (global_string, "foo"))
return 6;
char *s = "bar";
if (strcmp (s, "bar"))
return 7;
if (*global_array != 'X')
return 8;
if (*global_chars != 'X')
return 9;
SCM x = 0;
if (x != 0)
return 9;
if (TCHAR != 0)
return 11;
if (strncmp (argv[0], "scaffold/test", 5))
return 12;
if (strcmp (env[0], "foo"))
return 13;
if (strcmp (env[2], "baz"))
return 14;
if (env[3])
return 15;
if (f.length != 3)
return 16;
if (strcmp (f.string, "foo"))
return 17;
struct foo g = {4, "baar"};
if (g.length != 4)
return 16;
if (strcmp (g.string, "baar"))
return 18;
struct foo f = {3, "foo"};
g_foes[0] = f;
g_foes[1] = f;
if (g_foe)
return 19;
char *strings[] = { "one\n", "two\n", "three\n", 0 };
char **p = strings;
while (*p) puts (*p++);
if (strcmp (strings[1], "two\n"))
return 20;
p = list;
struct anon a = {3,4};
eputs ("bar:"); eputs (itoa (a.bar)); eputs ("\n");
eputs ("baz:"); eputs (itoa (a.baz)); eputs ("\n");
if (a.bar != 3) return 1;
if (a.baz != 4) return 2;
puts ("*x A\n");
char *x = g_arena;
if (*x != 'A') return 1;
puts ("*x++ A\n");
if (*x++ != 'A') return 1;
puts ("t: *x++ != 'C'\n");
*x++ = 'C';
if (g_chars[1] != 'C') return 1;
i = 1;
int lst[6] = {-1, 1 - 1, i, 2, 3};
for (int i = 0; i < 4; i++)
{
puts ("i: "); puts (itoa (lst[i])); puts ("\n");
if (lst[i+1] != i)
return i;
}
return 0;
}