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

mescc: Run mini-mes.

Browse source 
* .gitignore: Ignore tiny-mes and tiny .mo's.
* doc/examples/tiny-mes.c: Simplify.
* doc/examples/mini-mes.c: Use simplifications from tiny-mes.
* doc/examples/t.c (read_test, struct_test): New functions.
  (test): Add tests for arena, g_cells globals.
* module/mes/elf-util.mes (dec->hex): New function.
  (lambda/label->list): Add text-address parameter.  Update callers.
* module/language/c99/compiler.mes (make, info, clone): Add init field.
  (.init): New function.
  (ident->accu): Add exceptions for globals.
* module/mes/elf-util.scm: Export it.
* module/mes/libc-i386.mes (i386:accu->base-ref,
  i386:byte-accu->base-ref, i386:accu->base-ref+n,
  i386:accu->global-ref, i386:global-ref->accu, i386:global-ref->base,
  i386:global-add, i386:global->accu):, i386:local-ref->accu,
  i386:local-ptr->accu, i386:local-ptr->base): New functions.
* module/mes/libc-i386.scm: Export them.
This commit is contained in:
Jan Nieuwenhuizen 2017-01-29 15:22:39 +01:00
parent 8692fa3bb8
commit 70e4aec861
11 changed files with 1889 additions and 1128 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
.gitignore vendored
View file

@ -15,6 +15,9 @@
/mes /mes
/micro-mes /micro-mes
/mini-mes /mini-mes
/tiny-mes
/module/mes/hack-32.mo
/module/mes/read-0-32.mo
/module/mes/read-0.mo /module/mes/read-0.mo
/out /out
? ?

9
HACKING
View file

@ -107,3 +107,12 @@ sc: http://sph.mn/content/3d3
*** [[http://www.scheme-reports.org/][Scheme Reports]] *** [[http://www.scheme-reports.org/][Scheme Reports]]
*** [[ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-349.pdf][Scheme - Report on Scheme]] *** [[ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-349.pdf][Scheme - Report on Scheme]]
*** [[ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-452.pdf][RRS - Revised Report on Scheme]] *** [[ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-452.pdf][RRS - Revised Report on Scheme]]
** tiny schemes
http://forum.osdev.org/viewtopic.php?f=15&t=19937
http://www.stripedgazelle.org/joey/dreamos.html
http://armpit.sourceforge.net/
http://common-lisp.net/project/movitz/movitz.html
<civodul> janneke: https://github.com/namin/inc looks interesting [15:18]

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

File diff suppressed because it is too large Load diff

42
module/mes/elf-util.mes
View file

@ -31,21 +31,47 @@
(mes (mes
(mes-use-module (srfi srfi-1)))) (mes-use-module (srfi srfi-1))))
(define (make-global name type pointer value)
(cons name (list type pointer value)))
(define global:type car)
(define global:pointer cadr)
(define global:value caddr)
(define (dec->hex o)
(cond ((number? o) (number->string o 16))
((char? o) (number->string (char->integer o) 16))))
(define (functions->lambdas functions) (define (functions->lambdas functions)
(append-map cdr functions)) (append-map cdr functions))
(define (lambda/label->list f g t d) (define (lambda/label->list f g ta t d)
(lambda (l/l) (lambda (l/l)
(if (not (procedure? l/l)) '() (l/l f g t d)))) (if (not (procedure? l/l)) '() (l/l f g ta t d))))
(define (text->list o) (define (text->list o)
(append-map (lambda/label->list '() '() 0 0) o)) (append-map (lambda/label->list '() '() 0 0 0) o))
(define (functions->text functions globals t d) (define (functions->text functions globals ta t d)
(let loop ((lambdas/labels (functions->lambdas functions)) (text '())) (let loop ((lambdas/labels (functions->lambdas functions)) (text '()))
(if (null? lambdas/labels) text (if (null? lambdas/labels) text
(loop (cdr lambdas/labels) (loop (cdr lambdas/labels)
(append text ((lambda/label->list functions globals (- (length text)) d) (car lambdas/labels))))))) (append text ((lambda/label->list functions globals ta (- (length text)) d) (car lambdas/labels)))))))
;; (define (functions->text functions globals ta t d)
;; (let loop ((functions functions) (text '()))
;; (if (null? functions) text
;; (loop (cdr functions)
;; (append '() ;;text
;; (function->text functions globals ta t d text (car functions)))))))
;; (define (function->text functions globals ta t d text function)
;; (format (current-error-port) "elf func=~a\n" (car function))
;; (let loop ((lambdas/labels (cdr function)) (text text))
;; (if (null? lambdas/labels) text
;; (loop (cdr lambdas/labels)
;; (append '() ;;text
;; ((lambda/label->list functions globals ta (- (length text)) d) (car lambdas/labels)))))))
(define (function-prefix name functions) (define (function-prefix name functions)
(member name (reverse functions) (lambda (a b) (equal? (car b) name)))) (member name (reverse functions) (lambda (a b) (equal? (car b) name))))
@ -55,7 +81,7 @@
(lambda (name functions) (lambda (name functions)
(or (assoc-ref cache name) (or (assoc-ref cache name)
(let* ((prefix (function-prefix name functions)) (let* ((prefix (function-prefix name functions))
(offset (if prefix (length (functions->text (cdr prefix) '() 0 0)) (offset (if prefix (length (functions->text (cdr prefix) '() 0 0 0))
0))) 0)))
(if (or (equal? name "exit") (> offset 0)) (set! cache (assoc-set! cache name offset))) (if (or (equal? name "exit") (> offset 0)) (set! cache (assoc-set! cache name offset)))
offset))))) offset)))))
@ -67,12 +93,12 @@
(let loop ((text (cdr function-entry))) (let loop ((text (cdr function-entry)))
(if (or (equal? (car text) label) (null? text)) 0 (if (or (equal? (car text) label) (null? text)) 0
(let* ((l/l (car text)) (let* ((l/l (car text))
(t ((lambda/label->list '() '() 0 0) l/l)) (t ((lambda/label->list '() '() 0 0 0) l/l))
(n (length t))) (n (length t)))
(+ (loop (cdr text)) n)))))))) (+ (loop (cdr text)) n))))))))
(define (globals->data globals) (define (globals->data globals)
(append-map cdr globals)) (append-map (compose global:value cdr) globals))
(define (data-offset name globals) (define (data-offset name globals)
(let* ((prefix (member name (reverse globals) (let* ((prefix (member name (reverse globals)

7
module/mes/elf-util.scm
View file

@ -25,13 +25,18 @@
(define-module (mes elf-util) (define-module (mes elf-util)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:export (data-offset #:export (data-offset
dec->hex
function-offset function-offset
label-offset label-offset
functions->lambdas functions->lambdas
functions->text functions->text
lambda/label->list lambda/label->list
text->list text->list
globals->data)) globals->data
make-global
global:type
global:pointer
global:value))
(cond-expand (cond-expand
(guile-2) (guile-2)

16
module/mes/elf.mes
View file

@ -46,7 +46,7 @@
(define elf32-off int->bv32) (define elf32-off int->bv32)
(define elf32-word int->bv32) (define elf32-word int->bv32)
(define (make-elf functions globals) (define (make-elf functions globals init)
(define vaddress #x08048000) (define vaddress #x08048000)
(define ei-magic `(#x7f ,@(string->list "ELF"))) (define ei-magic `(#x7f ,@(string->list "ELF")))
@ -181,7 +181,7 @@
(map car functions)))) (map car functions))))
(define text-length (define text-length
(length (functions->text functions globals 0 0))) (length (functions->text functions globals 0 0 0)))
(define data-offset (define data-offset
(+ text-offset text-length)) (+ text-offset text-length))
@ -240,8 +240,11 @@
(define SHF-EXEC 4) (define SHF-EXEC 4)
(define SHF-STRINGS #x20) (define SHF-STRINGS #x20)
(let* ((text (functions->text functions globals 0 data-address)) (let* ((text (functions->text functions globals text-address 0 data-address))
(data (globals->data globals)) (raw-data (globals->data globals))
(data (let loop ((data raw-data) (init init))
(if (null? init) data
(loop ((car init) functions globals text-address 0 data-address data) (cdr init)))))
(entry (+ text-offset (function-offset "_start" functions))) (entry (+ text-offset (function-offset "_start" functions)))
(sym (sym functions globals)) (sym (sym functions globals))
(str (str functions))) (str (str functions)))
@ -269,8 +272,9 @@
(define section-headers-offset (define section-headers-offset
(+ str-offset str-length)) (+ str-offset str-length))
(format (current-error-port) "ELF text=~a\n" text) (format (current-error-port) "ELF text=~a\n" (map dec->hex text))
;;(format (current-error-port) "ELF data=~a\n" data) (format (current-error-port) "ELF raw-data=~a\n" (map dec->hex raw-data))
(format (current-error-port) "ELF data=~a\n" (map dec->hex data))
(format (current-error-port) "text-offset=~a\n" text-offset) (format (current-error-port) "text-offset=~a\n" text-offset)
(format (current-error-port) "data-offset=~a\n" data-offset) (format (current-error-port) "data-offset=~a\n" data-offset)
(format (current-error-port) "_start=~a\n" (number->string entry 16)) (format (current-error-port) "_start=~a\n" (number->string entry 16))

194
module/mes/libc-i386.mes
View file

@ -31,8 +31,8 @@
(define (i386:function-locals) (define (i386:function-locals)
'(#x83 #xec #x20)) ; sub $0x10,%esp -- 8 local vars '(#x83 #xec #x20)) ; sub $0x10,%esp -- 8 local vars
(define (i386:push-global-ref o) (define (i386:push-global-address o)
(or o push-global-ref) (or o push-global-address)
`(#x68 ,@(int->bv32 o))) ; push $0x<o> `(#x68 ,@(int->bv32 o))) ; push $0x<o>
(define (i386:push-global o) (define (i386:push-global o)
@ -44,8 +44,8 @@
(or n push-local) (or n push-local)
`(#xff #x75 ,(- 0 (* 4 n)))) ; pushl 0x<n>(%ebp) `(#xff #x75 ,(- 0 (* 4 n)))) ; pushl 0x<n>(%ebp)
(define (i386:push-local-ref n) (define (i386:push-local-address n)
(or n push-local-ref) (or n push-local-address)
`(#x8d #x45 ,(- 0 (* 4 n)) ; lea 0x<n>(%ebp),%eax `(#x8d #x45 ,(- 0 (* 4 n)) ; lea 0x<n>(%ebp),%eax
#x50)) ; push %eax #x50)) ; push %eax
@ -56,30 +56,39 @@
;;#x0f #xbe #xc0 ; movsbl %al,%eax ***FIXME BYTE**** ;;#x0f #xbe #xc0 ; movsbl %al,%eax ***FIXME BYTE****
#x50)) ; push %eax #x50)) ; push %eax
(define (i386:push-accu) (define (i386:pop-accu)
`(#x50)) ; push %eax '(#x58)) ; pop %eax
(define (i386:push-arg f g t d) (define (i386:push-accu)
'(#x50)) ; push %eax
(define (i386:pop-base)
'(#x5a)) ; pop %eax
(define (i386:push-base)
'(#x52)) ; push %eax
(define (i386:push-arg f g ta t d)
(lambda (o) (lambda (o)
(or o push-arg) (or o push-arg)
(cond ((number? o) (cond ((number? o)
`(#x68 ,@(int->bv32 o))) ; push $<o> `(#x68 ,@(int->bv32 o))) ; push $<o>
((and (pair? o) (procedure? (car o))) ((and (pair? o) (procedure? (car o)))
(append-map (lambda (p) (p f g t d)) o)) (append-map (lambda (p) (p f g ta t d)) o))
((pair? o) o) ((pair? o) o)
((procedure? o) (o f g t d)) ((procedure? o) (o f g ta t d))
(_ barf)))) (_ barf))))
(define (i386:ret . rest) (define (i386:ret . rest)
(lambda (f g t d) (lambda (f g ta t d)
`( `(
,@(cond ((null? rest) '()) ,@(cond ((null? rest) '())
((number? (car rest)) ((number? (car rest))
`(#xb8 ; mov $<>,%eax `(#xb8 ; mov $<>,%eaxx
,@(int->bv32 (car rest)))) ,@(int->bv32 (car rest))))
((pair? (car rest)) (car rest)) ((pair? (car rest)) (car rest))
((procedure? (car rest)) ((procedure? (car rest))
((car rest) f g t d))) ((car rest) f g ta t d)))
#xc9 ; leave #xc9 ; leave
#xc3 ; ret #xc3 ; ret
))) )))
@ -87,14 +96,37 @@
(define (i386:accu->base) (define (i386:accu->base)
'(#x89 #xc2)) ; mov %eax,%edx '(#x89 #xc2)) ; mov %eax,%edx
(define (i386:accu->base-address)
'(#x89 #x02)) ; mov %eax,%(edx)
(define (i386:byte-accu->base-address)
'(#x88 #x02)) ; mov %al,%(edx)
(define (i386:accu->base-address+n n)
(or n accu->base-address+n)
`(#x89 #x42 ,n)) ; mov %eax,$0x<n>%(edx)
(define (i386:accu->local n) (define (i386:accu->local n)
(or n accu->local) (or n accu->local)
`(#x89 #x45 ,(- 0 (* 4 n)))) ; mov %eax,-<0xn>(%ebp) `(#x89 #x45 ,(- 0 (* 4 n)))) ; mov %eax,-<0xn>(%ebp)
(define (i386:base->local n)
(or n base->local)
`(#x89 #x55 ,(- 0 (* 4 n)))) ; mov %edx,-<0xn>(%ebp)
(define (i386:base->global n)
(or n base->global)
`(#x89 #x15 ,@(int->bv32 n))) ; mov %edx,0x0
(define (i386:accu->global n) (define (i386:accu->global n)
(or n accu->global) (or n accu->global)
`(#xa3 ,@(int->bv32 n))) ; mov %eax,0x0 `(#xa3 ,@(int->bv32 n))) ; mov %eax,0x0
(define (i386:accu->global-address n)
(or n accu->global-address)
`(#x8b #x15 ,@(int->bv32 n) ; mov 0x<n>,%edx
#x89 #x02 )) ; mov %eax,(%edx)
(define (i386:accu-zero?) (define (i386:accu-zero?)
'(#x85 #xc0)) ; cmpl %eax,%eax '(#x85 #xc0)) ; cmpl %eax,%eax
@ -103,6 +135,7 @@
(i386:xor-zf))) (i386:xor-zf)))
(define (i386:accu-shl n) (define (i386:accu-shl n)
(or n accu:shl n)
`(#xc1 #xe0 ,n)) ; shl $0x8,%eax `(#xc1 #xe0 ,n)) ; shl $0x8,%eax
(define (i386:accu+accu) (define (i386:accu+accu)
@ -111,6 +144,21 @@
(define (i386:accu+base) (define (i386:accu+base)
`(#x01 #xd0)) ; add %edx,%eax `(#x01 #xd0)) ; add %edx,%eax
(define (i386:accu+value v)
(or v accu+value)
`(#x05 ,@(int->bv32 v))) ; add %eax,%eax
(define (i386:accu-base)
`(#x29 #xd0)) ; sub %edx,%eax
;; (define (i386:accu/base)
;; '(#xf7 #xf2)) ; div %edx,%eax
(define (i386:accu/base)
'(#x86 #xd3 ; mov %edx,%ebx
#x31 #xd2 ; xor %edx,%edx
#xf7 #xf3)) ; div %ebx
(define (i386:base->accu) (define (i386:base->accu)
'(#x89 #xd0)) ; mov %edx,%eax '(#x89 #xd0)) ; mov %edx,%eax
@ -118,6 +166,15 @@
(or n local->accu) (or n local->accu)
`(#x8b #x45 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%eax `(#x8b #x45 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%eax
(define (i386:local-address->accu n)
(or n ladd)
`(#x8d #x45 ,(- 0 (* 4 n)))) ; lea 0x<n>(%ebp),%eax
(define (i386:local-ptr->accu n)
(or n local-ptr->accu)
`(#x89 #xe8 ; mov %ebp,%eax
#x83 #xc0 ,(- 0 (* 4 n)))) ; add $0x<n>,%eax
(define (i386:byte-local->accu n) (define (i386:byte-local->accu n)
(or n byte-local->accu) (or n byte-local->accu)
`(#x0f #xb6 #x45 ,(- 0 (* 4 n)))) ; movzbl 0x<n>(%ebp),%eax `(#x0f #xb6 #x45 ,(- 0 (* 4 n)))) ; movzbl 0x<n>(%ebp),%eax
@ -126,22 +183,27 @@
(or n local->base) (or n local->base)
`(#x8b #x55 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%edx `(#x8b #x55 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%edx
;; (define (i386:local-ref->base n) (define (i386:local-address->base n) ;; DE-REF
;; (or n local-ref->base) (or n local-address->base)
;; `(#x8b #x15 ,@(int->bv32 (- 0 (* 4 n))))) ; mov 0x<n>,%edx
(define (i386:local-ref->base n)
(or n local-ref->base)
`(#x8d #x55 ,(- 0 (* 4 n)))) ; lea 0x<n>(%ebp),%edx `(#x8d #x55 ,(- 0 (* 4 n)))) ; lea 0x<n>(%ebp),%edx
(define (i386:global-ref->base n) (define (i386:local-ptr->base n)
(or n global->base) (or n local-ptr->base)
`(#x8b #x15 ,@(int->bv32 n))) ; mov 0x<n>,%edx `(#x89 #xea ; mov %ebp,%edx
#x83 #xc2 ,(- 0 (* 4 n)))) ; add $0x<n>,%edx
(define (i386:global->base n) (define (i386:global->base n)
(or n global->base) (or n global->base)
`(#xba ,@(int->bv32 n))) ; mov $<n>,%edx `(#xba ,@(int->bv32 n))) ; mov $<n>,%edx
(define (i386:global-address->accu n)
(or n global-address->accu)
`(#xa1 ,@(int->bv32 n))) ; mov 0x<n>,%eax
(define (i386:global-address->base n)
(or n global-address->base)
`(#x8b #x15 ,@(int->bv32 n))) ; mov 0x<n>,%edx
(define (i386:byte-base-mem->accu) (define (i386:byte-base-mem->accu)
'(#x01 #xd0 ; add %edx,%eax '(#x01 #xd0 ; add %edx,%eax
#x0f #xb6 #x00)) ; movzbl (%eax),%eax #x0f #xb6 #x00)) ; movzbl (%eax),%eax
@ -163,44 +225,46 @@
`(#x8b #x40 ,n)) ; mov 0x<n>(%eax),%eax `(#x8b #x40 ,n)) ; mov 0x<n>(%eax),%eax
(define (i386:base-mem+n->accu n) (define (i386:base-mem+n->accu n)
(or n base-mem+n->accu)
`(#x01 #xd0 ; add %edx,%eax `(#x01 #xd0 ; add %edx,%eax
#x8b #x40 ,n)) ; mov <n>(%eax),%eax #x8b #x40 ,n)) ; mov <n>(%eax),%eax
(define (i386:global->accu o)
(or o global->accu)
`(#xb8 ,@(int->bv32 o))) ; mov $<>,%eax
(define (i386:value->accu v) (define (i386:value->accu v)
(or v value->accu) (or v urg:value->accu)
`(#xb8 ,@(int->bv32 v))) ; mov $<v>,%eax `(#xb8 ,@(int->bv32 v))) ; mov $<v>,%eax
(define (i386:value->accu-ref v) (define (i386:value->accu-address v)
(or v value->accu-ref)
`(#xc7 #x00 ,@(int->bv32 v))) ; movl $0x<v>,(%eax) `(#xc7 #x00 ,@(int->bv32 v))) ; movl $0x<v>,(%eax)
(define (i386:value->accu-ref+n n v) (define (i386:value->accu-address+n n v)
(or v urg:value->accu-address+n)
`(#xc7 #x40 ,n ,@(int->bv32 v))) ; movl $<v>,0x<n>(%eax) `(#xc7 #x40 ,n ,@(int->bv32 v))) ; movl $<v>,0x<n>(%eax)
(define (i386:base->accu-ref) (define (i386:base->accu-address)
'(#x89 #x10)) ; mov %edx,(%eax) '(#x89 #x10)) ; mov %edx,(%eax)
(define (i386:byte-base->accu-ref) (define (i386:byte-base->accu-address)
'(#x88 #x10)) ; mov %dl,(%eax) '(#x88 #x10)) ; mov %dl,(%eax)
(define (i386:byte-base->accu-address+n n)
(or n byte-base->accu-address+n)
`(#x88 #x50 ,n)) ; mov %dl,0x<n>(%eax)
(define (i386:value->base v) (define (i386:value->base v)
(or v urg:value->base)
`(#xba ,@(int->bv32 v))) ; mov $<v>,%edx `(#xba ,@(int->bv32 v))) ; mov $<v>,%edx
(define (i386:local-add n v) (define (i386:local-add n v)
(or n ladd) (or n urg:local-add)
`(#x83 #x45 ,(- 0 (* 4 n)) ,v)) ; addl $<v>,0x<n>(%ebp) `(#x83 #x45 ,(- 0 (* 4 n)) ,v)) ; addl $<v>,0x<n>(%ebp)
(define (i386:local-address->accu n) (define (i386:global-add n v)
(or n ladd) (or n urg:global-add)
`(#x8d #x45 ,(- 0 (* 4 n)))) ; lea 0x<n>(%ebp),%eax `(#x83 #x05 ,@(int->bv32 n) ,v)) ; addl $<v>,0x<n>
(define (i386:local-address->accu n) (define (i386:global->accu o)
(or n ladd) (or o urg:global->accu)
`(#x8d #x45 ,(- 0 (* 4 n)))) ; lea 0x<n>(%ebp),%eax `(#xb8 ,@(int->bv32 o))) ; mov $<>,%eax
(define (i386:value->global n v) (define (i386:value->global n v)
(or n value->global) (or n value->global)
@ -213,11 +277,12 @@
,@(int->bv32 v))) ,@(int->bv32 v)))
(define (i386:local-test n v) (define (i386:local-test n v)
(or n lt) (or n local-test)
`(#x83 #x7d ,(- 0 (* 4 n)) ,v)) ; cmpl $<v>,0x<n>(%ebp) `(#x83 #x7d ,(- 0 (* 4 n)) ,v)) ; cmpl $<v>,0x<n>(%ebp)
(define (i386:call f g t d address . arguments) (define (i386:call f g ta t d address . arguments)
(let* ((pushes (append-map (i386:push-arg f g t d) (reverse arguments))) (or address urg:call)
(let* ((pushes (append-map (i386:push-arg f g ta t d) (reverse arguments)))
(s (length pushes)) (s (length pushes))
(n (length arguments))) (n (length arguments)))
`( `(
@ -226,11 +291,31 @@
#x83 #xc4 ,(* n 4) ; add $00,%esp #x83 #xc4 ,(* n 4) ; add $00,%esp
))) )))
(define (i386:call-accu f g ta t d . arguments)
;;(or address urg:call)
(let* ((pushes (append-map (i386:push-arg f g ta t d) (reverse arguments)))
(s (length pushes))
(n (length arguments)))
`(
,@(i386:push-accu)
,@pushes ; push args
;;#xe8 ,@(int->bv32 (- address 5 s)) ; call relative
;; FIXME: add t?/address
;; #x50 ; push %eax
;; #xc3 ; ret
,@(i386:pop-accu)
;; #x05 ,@(int->bv32 t) ; add <t>,%eax
;; #x05 ,@(int->bv32 ta) ; add <ta>,%eax
#xff #xd0 ; call *%eax
#x83 #xc4 ,(* n 4) ; add $00,%esp
)))
(define (i386:accu-not) (define (i386:accu-not)
`(#x0f #x94 #xc0 ; sete %al `(#x0f #x94 #xc0 ; sete %al
#x0f #xb6 #xc0)) ; movzbl %al,%eax #x0f #xb6 #xc0)) ; movzbl %al,%eax
(define (i386:xor-accu v) (define (i386:xor-accu v)
(or n urg:xor-accu)
`(#x35 ,@(int->bv32 v))) ;xor $0xff,%eax `(#x35 ,@(int->bv32 v))) ;xor $0xff,%eax
(define (i386:xor-zf) (define (i386:xor-zf)
@ -245,44 +330,55 @@
'(#x85 #xc0)) ; test %eax,%eax '(#x85 #xc0)) ; test %eax,%eax
(define (i386:Xjump n) (define (i386:Xjump n)
`(#xe9 ,@(int->bv32 n))) ; jmp . + <n> (or n urg:Xjump)
`(#xe9 ,@(int->bv32 (if (>= n 0) n (- n 5))))) ; jmp . + <n>
(define (i386:Xjump-nz n) (define (i386:Xjump-nz n)
(or n urg:Xjump-nz)
`(#x0f #x85 ,@(int->bv32 n))) ; jnz . + <n> `(#x0f #x85 ,@(int->bv32 n))) ; jnz . + <n>
(define (i386:jump n) ;;FIXME: NEED THIS WEIRDNESS for t.c (define (i386:jump n) ;;FIXME: NEED THIS WEIRDNESS for t.c
(when (or (> n #x80) (< n #x-80))
(format (current-error-port) "JUMP n=~a\n" n)
barf)
`(#xeb ,(if (>= n 0) (- n 2) (- n 2)))) ; jmp <n> `(#xeb ,(if (>= n 0) (- n 2) (- n 2)))) ; jmp <n>
;; (define (i386:jump n)
;; `(#xeb ,(if (>= n 0) n (- n 2)))) ; jmp <n>
(define (i386:jump-c n) (define (i386:jump-c n)
(or n jump-c)
`(#x72 ,(if (>= n 0) n (- n 2)))) ; jc <n> `(#x72 ,(if (>= n 0) n (- n 2)))) ; jc <n>
(define (i386:jump-cz n) (define (i386:jump-cz n)
(or n jump-cz)
`(#x76 ,(if (>= n 0) n (- n 2)))) ; jna <n> `(#x76 ,(if (>= n 0) n (- n 2)))) ; jna <n>
(define (i386:jump-ncz n) (define (i386:jump-ncz n)
(or n jump-ncz)
`(#x77 ,(if (>= n 0) n (- n 2)))) ; ja <n> `(#x77 ,(if (>= n 0) n (- n 2)))) ; ja <n>
(define (i386:jump-nc n) (define (i386:jump-nc n)
(or n jump-nc)
`(#x73 ,(if (>= n 0) n (- n 2)))) ; jnc <n> `(#x73 ,(if (>= n 0) n (- n 2)))) ; jnc <n>
(define (i386:jump-z n) (define (i386:jump-z n)
(or n jump-z)
`(#x74 ,(if (>= n 0) n (- n 2)))) ; jz <n> `(#x74 ,(if (>= n 0) n (- n 2)))) ; jz <n>
(define (i386:jump-nz n) (define (i386:jump-nz n)
(or n jump-nz)
`(#x75 ,(if (>= n 0) n (- n 2)))) ; jnz <n> `(#x75 ,(if (>= n 0) n (- n 2)))) ; jnz <n>
(define (i386:test-jump-z n) (define (i386:test-jump-z n)
(or n jump-z)
`(#x85 #xc0 ; test %eax,%eax `(#x85 #xc0 ; test %eax,%eax
#x74 ,(if (>= n 0) n (- n 4)))) ; jz <n> #x74 ,(if (>= n 0) n (- n 4)))) ; jz <n>
(define (i386:jump-byte-nz n) (define (i386:jump-byte-nz n)
(or n jump-byte-nz)
`(#x84 #xc0 ; test %al,%al `(#x84 #xc0 ; test %al,%al
#x75 ,(if (>= n 0) n (- n 4)))) ; jne <n> #x75 ,(if (>= n 0) n (- n 4)))) ; jne <n>
(define (i386:jump-byte-z n) (define (i386:jump-byte-z n)
(or n jump-byte-z)
`(#x84 #xc0 ; test %al,%al `(#x84 #xc0 ; test %al,%al
#x74 ,(if (>= n 0) n (- n 4)))) ; jne <n> #x74 ,(if (>= n 0) n (- n 4)))) ; jne <n>
@ -305,7 +401,7 @@
`(#x29 #xc2)) ; sub %eax,%edx `(#x29 #xc2)) ; sub %eax,%edx
;;; libc bits ;;; libc bits
(define (i386:exit f g t d) (define (i386:exit f g ta t d)
`( `(
#x5b ; pop %ebx #x5b ; pop %ebx
#x5b ; pop %ebx #x5b ; pop %ebx
@ -313,7 +409,7 @@
#xcd #x80 ; int $0x80 #xcd #x80 ; int $0x80
)) ))
(define (i386:open f g t d) (define (i386:open f g ta t d)
`( `(
#x55 ; push %ebp #x55 ; push %ebp
#x89 #xe5 ; mov %esp,%ebp #x89 #xe5 ; mov %esp,%ebp
@ -328,7 +424,7 @@
#xc3 ; ret #xc3 ; ret
)) ))
(define (i386:read f g t d) (define (i386:read f g ta t d)
`( `(
#x55 ; push %ebp #x55 ; push %ebp
#x89 #xe5 ; mov %esp,%ebp #x89 #xe5 ; mov %esp,%ebp
@ -344,7 +440,7 @@
#xc3 ; ret #xc3 ; ret
)) ))
(define (i386:write f g t d) (define (i386:write f g ta t d)
`( `(
#x55 ; push %ebp #x55 ; push %ebp
#x89 #xe5 ; mov %esp,%ebp #x89 #xe5 ; mov %esp,%ebp

34
module/mes/libc-i386.scm
View file

@ -31,21 +31,32 @@
i386:accu-not i386:accu-not
i386:accu-cmp-value i386:accu-cmp-value
i386:accu->base i386:accu->base
i386:accu->base-address
i386:accu->base-address+n
i386:accu->global i386:accu->global
i386:accu->global-address
i386:accu->local i386:accu->local
i386:accu-non-zero? i386:accu-non-zero?
i386:accu-test i386:accu-test
i386:accu-zero? i386:accu-zero?
i386:accu+accu i386:accu+accu
i386:accu+base i386:accu+base
i386:accu+value
i386:accu/base
i386:accu-base
i386:accu-shl i386:accu-shl
i386:base-sub i386:base-sub
i386:base->accu i386:base->accu
i386:base->accu-ref i386:base->accu-address
i386:byte-accu->base-address
i386:base->global
i386:base->local
i386:base-mem->accu i386:base-mem->accu
i386:byte-base-sub i386:byte-base-sub
i386:byte-base->accu-ref i386:byte-base->accu-address
i386:byte-base->accu-address+n
i386:byte-base-mem->accu i386:byte-base-mem->accu
i386:local-address->accu
i386:byte-local->accu i386:byte-local->accu
i386:byte-mem->accu i386:byte-mem->accu
i386:base-mem+n->accu i386:base-mem+n->accu
@ -53,11 +64,15 @@
i386:byte-test-base i386:byte-test-base
i386:byte-sub-base i386:byte-sub-base
i386:call i386:call
i386:call-accu
i386:formal i386:formal
i386:function-locals i386:function-locals
i386:function-preamble i386:function-preamble
i386:global-add
i386:global->accu i386:global->accu
i386:global->base i386:global->base
i386:global-address->accu
i386:global-address->base
i386:jump i386:jump
i386:jump i386:jump
i386:jump-byte-nz i386:jump-byte-nz
@ -73,24 +88,29 @@
i386:local->base i386:local->base
i386:local-add i386:local-add
i386:local-address->accu i386:local-address->accu
i386:local-ref->base i386:local-ptr->accu
i386:local-ptr->base
i386:local-address->base
i386:local-test i386:local-test
i386:mem->accu i386:mem->accu
i386:mem+n->accu i386:mem+n->accu
i386:pop-accu
i386:push-accu i386:push-accu
i386:pop-base
i386:push-base
i386:push-global i386:push-global
i386:push-global-ref i386:push-global-address
i386:push-local i386:push-local
i386:push-local-de-ref i386:push-local-de-ref
i386:push-local-ref i386:push-local-address
i386:ret i386:ret
i386:ret-local i386:ret-local
i386:sub-base i386:sub-base
i386:test-base i386:test-base
i386:test-jump-z i386:test-jump-z
i386:value->accu i386:value->accu
i386:value->accu-ref i386:value->accu-address
i386:value->accu-ref+n i386:value->accu-address+n
i386:value->global i386:value->global
i386:value->local i386:value->local
i386:value->base i386:value->base

471
scaffold/mini-mes.c
View file

@ -32,6 +32,9 @@
#define NYACC_CDR nyacc_cdr #define NYACC_CDR nyacc_cdr
#endif #endif
char arena[2000];
//char buf0[400];
int g_stdin = 0; int g_stdin = 0;
#if __GNUC__ #if __GNUC__
@ -219,112 +222,92 @@ void
assert_fail (char* s) assert_fail (char* s)
{ {
eputs ("assert fail:"); eputs ("assert fail:");
#if __GNUC__
eputs (s); eputs (s);
#endif
eputs ("\n"); eputs ("\n");
#if __GNUC__
*((int*)0) = 0; *((int*)0) = 0;
#endif
} }
#if __NYACC__ || FIXME_NYACC #if __GNUC__
#define assert(x) ((x) ? (void)0 : assert_fail(0)) #define assert(x) ((x) ? (void)0 : assert_fail ("boo:" #x))
// #else #else
// NYACC //#define assert(x) ((x) ? (void)0 : assert_fail ("boo:" #x))
// #define assert(x) ((x) ? (void)0 : assert_fail(#x)) #define assert(x) ((x) ? (void)0 : assert_fail (0))
#endif #endif
#define false 0
#define true 1
typedef int bool;
int ARENA_SIZE = 100000;
typedef int SCM; typedef int SCM;
#if __GNUC__ #if __GNUC__
bool g_debug = false; int g_debug = 0;
#endif #endif
int g_free = 0; int g_free = 0;
SCM g_symbols = 0; SCM g_symbols = 0;
SCM g_stack = 0; SCM g_stack = 0;
SCM r0 = 0; // a/env // a/env
SCM r1 = 0; // param 1 SCM r0 = 0;
SCM r2 = 0; // save 2+load/dump // param 1
SCM r3 = 0; // continuation SCM r1 = 0;
// save 2+load/dump
SCM r2 = 0;
// continuation
SCM r3 = 0;
#if __NYACC__ || FIXME_NYACC #if __NYACC__ || FIXME_NYACC
enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART}; enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART};
#else #else
enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART}; enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
#endif #endif
typedef int (*f_t) (void);
typedef SCM (*function0_t) (void);
typedef SCM (*function1_t) (SCM);
typedef SCM (*function2_t) (SCM, SCM);
typedef SCM (*function3_t) (SCM, SCM, SCM);
typedef SCM (*functionn_t) (SCM);
typedef struct function_struct {
// union {
// f_t function;
// function0_t function0;
// function1_t function1;
// function2_t function2;
// function3_t function3;
// functionn_t functionn;
// } data;
f_t function;
int arity;
} function_t;
struct scm;
typedef struct scm { struct scm {
enum type_t type; enum type_t type;
union {
char const *name;
SCM string;
SCM car; SCM car;
SCM ref;
int length;
} NYACC_CAR;
union {
int value;
int function;
SCM cdr; SCM cdr;
SCM closure; };
SCM continuation;
SCM macro;
SCM vector;
int hits;
} NYACC_CDR;
} scm;
scm scm_nil = {SPECIAL, "()"}; typedef int (*f_t) (void);
scm scm_f = {SPECIAL, "#f"}; struct function {
scm scm_t = {SPECIAL, "#t"}; int (*function) (void);
scm scm_dot = {SPECIAL, "."}; int arity;
scm scm_arrow = {SPECIAL, "=>"}; };
scm scm_undefined = {SPECIAL, "*undefined*"};
scm scm_unspecified = {SPECIAL, "*unspecified*"};
scm scm_closure = {SPECIAL, "*closure*"};
scm scm_circular = {SPECIAL, "*circular*"};
scm scm_begin = {SPECIAL, "*begin*"};
scm scm_vm_apply = {SPECIAL, "core:apply"}; struct scm *g_cells = arena;
scm scm_vm_apply2 = {SPECIAL, "*vm-apply2*"};
scm scm_vm_eval = {SPECIAL, "core:eval"}; //scm *g_news = 0;
scm scm_vm_begin = {SPECIAL, "*vm-begin*"}; // struct scm scm_nil = {SPECIAL, "()"};
//scm scm_vm_begin_read_input_file = {SPECIAL, "*vm-begin-read-input-file*"}; // struct scm scm_f = {SPECIAL, "#f"};
scm scm_vm_begin2 = {SPECIAL, "*vm-begin2*"}; // struct scm scm_t = {SPECIAL, "#t"};
// struct scm_dot = {SPECIAL, "."};
// struct scm_arrow = {SPECIAL, "=>"};
// struct scm_undefined = {SPECIAL, "*undefined*"};
// struct scm_unspecified = {SPECIAL, "*unspecified*"};
// struct scm_closure = {SPECIAL, "*closure*"};
// struct scm_circular = {SPECIAL, "*circular*"};
// struct scm_begin = {SPECIAL, "*begin*"};
scm scm_vm_return = {SPECIAL, "*vm-return*"}; // struct scm_vm_apply = {SPECIAL, "core:apply"};
// struct scm_vm_apply2 = {SPECIAL, "*vm-apply2*"};
// struct scm_vm_eval = {SPECIAL, "core:eval"};
// struct scm_vm_begin = {SPECIAL, "*vm-begin*"};
// //scm scm_vm_begin_read_input_file = {SPECIAL, "*vm-begin-read-input-file*"};
// struct scm_vm_begin2 = {SPECIAL, "*vm-begin2*"};
// struct scm_vm_return = {SPECIAL, "*vm-return*"};
// //#include "mes.symbols.h"
//#include "mes.symbols.h"
#define cell_nil 1 #define cell_nil 1
#define cell_f 2 #define cell_f 2
#define cell_t 3 #define cell_t 3
#define cell_dot 4 #define cell_dot 4
#define cell_arrow 5 // #define cell_arrow 5
#define cell_undefined 6 #define cell_undefined 6
#define cell_unspecified 7 #define cell_unspecified 7
#define cell_closure 8 #define cell_closure 8
@ -348,61 +331,62 @@ scm scm_vm_return = {SPECIAL, "*vm-return*"};
#define cell_vm_return 63 #define cell_vm_return 63
#if 0
char arena[200];
struct scm *g_cells = (struct scm*)arena;
#else
struct scm g_cells[200];
#endif
//scm *g_news = 0;
SCM tmp; SCM tmp;
SCM tmp_num; SCM tmp_num;
SCM tmp_num2; SCM tmp_num2;
function_t functions[200]; int ARENA_SIZE = 200;
struct function functions[2];
int g_function = 0; int g_function = 0;
SCM make_cell (SCM type, SCM car, SCM cdr); SCM make_cell (SCM type, SCM car, SCM cdr);
function_t fun_make_cell = {&make_cell, 3}; struct function fun_make_cell = {&make_cell, 3};
scm scm_make_cell = {FUNCTION, "make-cell", 0}; struct scm scm_make_cell = {TFUNCTION,0,0};
//, "make-cell", 0};
SCM cell_make_cell; SCM cell_make_cell;
SCM cons (SCM x, SCM y); SCM cons (SCM x, SCM y);
function_t fun_cons = {&cons, 2}; struct function fun_cons = {&cons, 2};
scm scm_cons = {FUNCTION, "cons", 0}; struct scm scm_cons = {TFUNCTION,0,0};
// "cons", 0};
SCM cell_cons; SCM cell_cons;
SCM car (SCM x); SCM car (SCM x);
function_t fun_car = {&car, 1}; struct function fun_car = {&car, 1};
scm scm_car = {FUNCTION, "car", 0}; struct scm scm_car = {TFUNCTION,0,0};
// "car", 0};
SCM cell_car; SCM cell_car;
SCM cdr (SCM x); SCM cdr (SCM x);
function_t fun_cdr = {&cdr, 1}; struct function fun_cdr = {&cdr, 1};
scm scm_cdr = {FUNCTION, "cdr", 0}; struct scm scm_cdr = {TFUNCTION,0,0};
// "cdr", 0};
SCM cell_cdr; SCM cell_cdr;
// SCM eq_p (SCM x, SCM y); // SCM eq_p (SCM x, SCM y);
// function_t fun_eq_p = {&eq_p, 2}; // struct function fun_eq_p = {&eq_p, 2};
// scm scm_eq_p = {FUNCTION, "eq?", 0}; // scm scm_eq_p = {TFUNCTION,0,0};// "eq?", 0};
// SCM cell_eq_p; // SCM cell_eq_p;
#define TYPE(x) (g_cells[x].type) #define TYPE(x) (g_cells[x].type)
#define CAR(x) g_cells[x].car #define CAR(x) g_cells[x].car
#define LENGTH(x) g_cells[x].length #define LENGTH(x) g_cells[x].car
#define STRING(x) g_cells[x].string #define STRING(x) g_cells[x].car
#define CDR(x) g_cells[x].cdr #define CDR(x) g_cells[x].cdr
#define CLOSURE(x) g_cells[x].closure #if __GNUC__
//#define CLOSURE(x) g_cells[x].closure
#endif
#define CONTINUATION(x) g_cells[x].cdr #define CONTINUATION(x) g_cells[x].cdr
#define FUNCTION(x) functions[g_cells[x].function] #if __GNUC__
#define VALUE(x) g_cells[x].value //#define FUNCTION(x) functions[g_cells[x].function]
#define VECTOR(x) g_cells[x].vector #endif
#define FUNCTION(x) functions[g_cells[x].cdr]
#define VALUE(x) g_cells[x].cdr
#define VECTOR(x) g_cells[x].cdr
#define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n)) #define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n))
//#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (CONTINUATION), n, g_stack) //#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (CONTINUATION), n, g_stack)
@ -443,7 +427,7 @@ make_cell (SCM type, SCM car, SCM cdr)
if (VALUE (type) == CHAR || VALUE (type) == NUMBER) { if (VALUE (type) == CHAR || VALUE (type) == NUMBER) {
if (car) CAR (x) = CAR (car); if (car) CAR (x) = CAR (car);
if (cdr) CDR(x) = CDR(cdr); if (cdr) CDR(x) = CDR(cdr);
} else if (VALUE (type) == FUNCTION) { } else if (VALUE (type) == TFUNCTION) {
if (car) CAR (x) = car; if (car) CAR (x) = car;
if (cdr) CDR(x) = CDR(cdr); if (cdr) CDR(x) = CDR(cdr);
} else { } else {
@ -470,8 +454,13 @@ tmp_num2_ (int x)
SCM SCM
cons (SCM x, SCM y) cons (SCM x, SCM y)
{ {
#if __GNUC__
VALUE (tmp_num) = PAIR; VALUE (tmp_num) = PAIR;
return make_cell (tmp_num, x, y); return make_cell (tmp_num, x, y);
#else
//FIXME GNUC
return 0;
#endif
} }
SCM SCM
@ -498,24 +487,33 @@ cdr (SCM x)
return CDR(x); return CDR(x);
} }
SCM // SCM
eq_p (SCM x, SCM y) // eq_p (SCM x, SCM y)
{ // {
return (x == y // return (x == y
|| ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD // || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD
&& STRING (x) == STRING (y))) // && STRING (x) == STRING (y)))
|| (TYPE (x) == CHAR && TYPE (y) == CHAR // || (TYPE (x) == CHAR && TYPE (y) == CHAR
&& VALUE (x) == VALUE (y)) // && VALUE (x) == VALUE (y))
|| (TYPE (x) == NUMBER && TYPE (y) == NUMBER // || (TYPE (x) == NUMBER && TYPE (y) == NUMBER
&& VALUE (x) == VALUE (y))) // && VALUE (x) == VALUE (y)))
? cell_t : cell_f; // ? cell_t : cell_f;
} // }
SCM SCM
gc_push_frame () gc_push_frame ()
{ {
SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil)))); SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
return g_stack = cons (frame, g_stack); g_stack = cons (frame, g_stack);
return g_stack;
}
SCM
xgc_push_frame ()
{
// SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
// g_stack = cons (frame, g_stack);
return g_stack;
} }
SCM SCM
@ -540,7 +538,8 @@ pairlis (SCM x, SCM y, SCM a)
SCM SCM
assq (SCM x, SCM a) assq (SCM x, SCM a)
{ {
while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a); //while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
while (a != cell_nil && x == CAAR (a)) a = CDR (a);
return a != cell_nil ? car (a) : cell_f; return a != cell_nil ? car (a) : cell_f;
} }
@ -565,6 +564,7 @@ assert_defined (SCM x, SCM e)
SCM SCM
push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
{ {
puts ("push_cc\n");
SCM x = r3; SCM x = r3;
r3 = c; r3 = c;
r2 = p2; r2 = p2;
@ -575,6 +575,20 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
return cell_unspecified; return cell_unspecified;
} }
SCM
xpush_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
{
puts ("push_cc\n");
SCM x = r3;
r3 = c;
r2 = p2;
xgc_push_frame ();
r1 = p1;
r0 = a;
r3 = x;
return cell_unspecified;
}
SCM caar (SCM x) {return car (car (x));} SCM caar (SCM x) {return car (car (x));}
SCM cadr (SCM x) {return car (cdr (x));} SCM cadr (SCM x) {return car (cdr (x));}
SCM cdar (SCM x) {return cdr (car (x));} SCM cdar (SCM x) {return cdr (car (x));}
@ -597,9 +611,9 @@ eval_apply ()
case cell_vm_evlis2: goto evlis2; case cell_vm_evlis2: goto evlis2;
case cell_vm_evlis3: goto evlis3; case cell_vm_evlis3: goto evlis3;
#endif #endif
case cell_vm_apply: goto apply; case cell_vm_apply: {goto apply;}
case cell_vm_apply2: goto apply2; case cell_vm_apply2: {goto apply2;}
case cell_vm_eval: goto eval; case cell_vm_eval: {goto eval;}
#if 0 #if 0
#if FIXED_PRIMITIVES #if FIXED_PRIMITIVES
case cell_vm_eval_car: goto eval_car; case cell_vm_eval_car: goto eval_car;
@ -612,9 +626,9 @@ eval_apply ()
case cell_vm_eval2: goto eval2; case cell_vm_eval2: goto eval2;
case cell_vm_macro_expand: goto macro_expand; case cell_vm_macro_expand: goto macro_expand;
#endif #endif
case cell_vm_begin: goto begin; case cell_vm_begin: {goto begin;}
///case cell_vm_begin_read_input_file: goto begin_read_input_file; ///case cell_vm_begin_read_input_file: goto begin_read_input_file;
case cell_vm_begin2: goto begin2; case cell_vm_begin2: {goto begin2;}
#if 0 #if 0
case cell_vm_if: goto vm_if; case cell_vm_if: goto vm_if;
case cell_vm_if_expr: goto if_expr; case cell_vm_if_expr: goto if_expr;
@ -622,9 +636,8 @@ eval_apply ()
case cell_vm_call_with_values2: goto call_with_values2; case cell_vm_call_with_values2: goto call_with_values2;
case cell_vm_return: goto vm_return; case cell_vm_return: goto vm_return;
#endif #endif
case cell_unspecified: return r1; case cell_unspecified: {return r1;}
default: default: {assert (0);}
assert (0);
} }
SCM x = cell_nil; SCM x = cell_nil;
@ -646,7 +659,7 @@ eval_apply ()
apply: apply:
switch (TYPE (car (r1))) switch (TYPE (car (r1)))
{ {
case FUNCTION: { case TFUNCTION: {
//check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1)); //check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
goto vm_return; goto vm_return;
@ -823,7 +836,7 @@ eval_apply ()
r1 = assert_defined (r1, assq_ref_env (r1, r0)); r1 = assert_defined (r1, assq_ref_env (r1, r0));
goto vm_return; goto vm_return;
} }
default: goto vm_return; default: {goto vm_return;}
} }
// SCM macro; // SCM macro;
@ -937,7 +950,7 @@ call (SCM fn, SCM x)
if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1) if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
&& x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES) && x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES)
x = cons (CAR (x), cons (CDADAR (x), CDR (x))); x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
function_t* f = &FUNCTION (fn); struct function* f = &FUNCTION (fn);
switch (FUNCTION (fn).arity) switch (FUNCTION (fn).arity)
{ {
// case 0: return FUNCTION (fn).function0 (); // case 0: return FUNCTION (fn).function0 ();
@ -945,11 +958,12 @@ call (SCM fn, SCM x)
// case 2: return FUNCTION (fn).function2 (car (x), cadr (x)); // case 2: return FUNCTION (fn).function2 (car (x), cadr (x));
// case 3: return FUNCTION (fn).function3 (car (x), cadr (x), car (cddr (x))); // case 3: return FUNCTION (fn).function3 (car (x), cadr (x), car (cddr (x)));
// case -1: return FUNCTION (fn).functionn (x); // case -1: return FUNCTION (fn).functionn (x);
case 0: return (FUNCTION (fn).function) (); case 0: {return (FUNCTION (fn).function) ();}
case 1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x)); case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));}
case 2: return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x)); case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));}
case 3: return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x))); case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));}
case -1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x); //case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
} }
return cell_unspecified; return cell_unspecified;
@ -987,7 +1001,7 @@ mes_g_stack (SCM a) ///((internal))
// Environment setup // Environment setup
SCM SCM
make_tmps (scm* cells) make_tmps (struct scm* cells)
{ {
tmp = g_free++; tmp = g_free++;
cells[tmp].type = CHAR; cells[tmp].type = CHAR;
@ -995,6 +1009,7 @@ make_tmps (scm* cells)
cells[tmp_num].type = NUMBER; cells[tmp_num].type = NUMBER;
tmp_num2 = g_free++; tmp_num2 = g_free++;
cells[tmp_num2].type = NUMBER; cells[tmp_num2].type = NUMBER;
return 0;
} }
SCM SCM
@ -1066,67 +1081,68 @@ mes_symbols () ///((internal))
//#include "mes.symbols.i" //#include "mes.symbols.i"
#else #else
g_free++; g_free++;
g_cells[cell_nil] = scm_nil; // g_cells[cell_nil] = scm_nil;
g_free++; g_free++;
g_cells[cell_f] = scm_f; // g_cells[cell_f] = scm_f;
g_free++; g_free++;
g_cells[cell_t] = scm_t; // g_cells[cell_t] = scm_t;
g_free++; g_free++;
g_cells[cell_dot] = scm_dot; // g_cells[cell_dot] = scm_dot;
g_free++; g_free++;
g_cells[cell_arrow] = scm_arrow; // g_cells[cell_arrow] = scm_arrow;
g_free++; g_free++;
g_cells[cell_undefined] = scm_undefined; // g_cells[cell_undefined] = scm_undefined;
g_free++; g_free++;
g_cells[cell_unspecified] = scm_unspecified; // g_cells[cell_unspecified] = scm_unspecified;
g_free++; g_free++;
g_cells[cell_closure] = scm_closure; // g_cells[cell_closure] = scm_closure;
g_free++; g_free++;
g_cells[cell_circular] = scm_circular; // g_cells[cell_circular] = scm_circular;
g_free++; g_free++;
g_cells[cell_begin] = scm_begin; // g_cells[cell_begin] = scm_begin;
/// ///
g_free = 44; g_free = 44;
g_free++; g_free++;
g_cells[cell_vm_apply] = scm_vm_apply; // g_cells[cell_vm_apply] = scm_vm_apply;
g_free++; g_free++;
g_cells[cell_vm_apply2] = scm_vm_apply2; // g_cells[cell_vm_apply2] = scm_vm_apply2;
g_free++; g_free++;
g_cells[cell_vm_eval] = scm_vm_eval; // g_cells[cell_vm_eval] = scm_vm_eval;
/// ///
g_free = 55; g_free = 55;
g_free++; g_free++;
g_cells[cell_vm_begin] = scm_vm_begin; // g_cells[cell_vm_begin] = scm_vm_begin;
g_free++; g_free++;
// g_cells[cell_vm_begin_read_input_file] = scm_vm_begin_read_input_file; // g_cells[cell_vm_begin_read_input_file] = scm_vm_begin_read_input_file;
g_free++; g_free++;
g_cells[cell_vm_begin2] = scm_vm_begin2; // g_cells[cell_vm_begin2] = scm_vm_begin2;
/// ///
g_free = 62; g_free = 62;
g_free++; g_free++;
g_cells[cell_vm_return] = scm_vm_return; // g_cells[cell_vm_return] = scm_vm_return;
#endif #endif
g_symbol_max = g_free; g_symbol_max = g_free;
make_tmps (g_cells); make_tmps (g_cells);
// FIXME GNUC
g_symbols = 0; g_symbols = 0;
for (int i=1; i<g_symbol_max; i++) for (int i=1; i<g_symbol_max; i++)
g_symbols = cons (i, g_symbols); g_symbols = cons (i, g_symbols);
@ -1136,21 +1152,22 @@ g_cells[cell_vm_return] = scm_vm_return;
#if __GNUC__ && 0 #if __GNUC__ && 0
//#include "mes.symbol-names.i" //#include "mes.symbol-names.i"
#else #else
g_cells[cell_nil].car = cstring_to_list (scm_nil.name); // g_cells[cell_nil].car = cstring_to_list (scm_nil.name);
g_cells[cell_f].car = cstring_to_list (scm_f.name); // g_cells[cell_f].car = cstring_to_list (scm_f.name);
g_cells[cell_t].car = cstring_to_list (scm_t.name); // g_cells[cell_t].car = cstring_to_list (scm_t.name);
g_cells[cell_dot].car = cstring_to_list (scm_dot.name); // g_cells[cell_dot].car = cstring_to_list (scm_dot.name);
g_cells[cell_arrow].car = cstring_to_list (scm_arrow.name); // g_cells[cell_arrow].car = cstring_to_list (scm_arrow.name);
g_cells[cell_undefined].car = cstring_to_list (scm_undefined.name); // g_cells[cell_undefined].car = cstring_to_list (scm_undefined.name);
g_cells[cell_unspecified].car = cstring_to_list (scm_unspecified.name); // g_cells[cell_unspecified].car = cstring_to_list (scm_unspecified.name);
g_cells[cell_closure].car = cstring_to_list (scm_closure.name); // g_cells[cell_closure].car = cstring_to_list (scm_closure.name);
g_cells[cell_circular].car = cstring_to_list (scm_circular.name); // g_cells[cell_circular].car = cstring_to_list (scm_circular.name);
g_cells[cell_begin].car = cstring_to_list (scm_begin.name); // g_cells[cell_begin].car = cstring_to_list (scm_begin.name);
#endif #endif
// a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a); // a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
// a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a); // a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
//FIXME GNUC
a = acons (cell_symbol_dot, cell_dot, a); // a = acons (cell_symbol_dot, cell_dot, a); //
a = acons (cell_symbol_begin, cell_begin, a); a = acons (cell_symbol_begin, cell_begin, a);
a = acons (cell_closure, a, a); a = acons (cell_closure, a, a);
@ -1170,8 +1187,10 @@ make_closure (SCM args, SCM body, SCM a)
SCM SCM
mes_environment () ///((internal)) mes_environment () ///((internal))
{ {
SCM a = mes_symbols (); SCM a = 0;
return mes_g_stack (a); a = mes_symbols ();
a = mes_g_stack (a);
return a;
} }
SCM SCM
@ -1192,22 +1211,39 @@ mes_builtins (SCM a)
// #include "posix.environment.i" // #include "posix.environment.i"
// #include "reader.environment.i" // #include "reader.environment.i"
#else #else
scm_make_cell.function = g_function;
scm_make_cell.cdr = g_function;
functions[g_function++] = fun_make_cell; functions[g_function++] = fun_make_cell;
cell_make_cell = g_free++; cell_make_cell = g_free++;
g_cells[cell_make_cell] = scm_make_cell; #if __GNUC__
puts ("WOOOT=");
puts (itoa (g_free));
//FIXME GNUC
#else
g_cells[16] = scm_make_cell;
#endif
scm_cons.function = g_function; scm_cons.cdr = g_function;
functions[g_function++] = fun_cons; functions[g_function++] = fun_cons;
cell_cons = g_free++; cell_cons = g_free++;
#if __GNUC__
//FIXME GNUC
g_cells[cell_cons] = scm_cons; g_cells[cell_cons] = scm_cons;
#else
g_cells[17] = scm_cons;
#endif
scm_car.function = g_function; scm_car.cdr = g_function;
functions[g_function++] = fun_car; functions[g_function++] = fun_car;
cell_car = g_free++; cell_car = g_free++;
#if __GNUC__
//FIXME GNUC
g_cells[cell_car] = scm_car; g_cells[cell_car] = scm_car;
#endif
scm_cdr.function = g_function; #if __GNUC__
//FIXME GNUC
scm_cdr.cdr = g_function;
functions[g_function++] = fun_cdr; functions[g_function++] = fun_cdr;
cell_cdr = g_free++; cell_cdr = g_free++;
g_cells[cell_cdr] = scm_cdr; g_cells[cell_cdr] = scm_cdr;
@ -1227,6 +1263,7 @@ g_cells[cell_cdr] = scm_cdr;
// scm_cdr.string = cstring_to_list (scm_cdr.name); // scm_cdr.string = cstring_to_list (scm_cdr.name);
// g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string); // g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string);
// a = acons (make_symbol (scm_cdr.string), cell_cdr, a); // a = acons (make_symbol (scm_cdr.string), cell_cdr, a);
#endif
#endif #endif
return a; return a;
} }
@ -1250,7 +1287,7 @@ bload_env (SCM a) ///((internal))
*p++ = c; *p++ = c;
c = getchar (); c = getchar ();
} }
g_free = (p-(char*)g_cells) / sizeof (scm); g_free = (p-(char*)g_cells) / sizeof (struct scm);
gc_peek_frame (); gc_peek_frame ();
g_symbols = r1; g_symbols = r1;
g_stdin = STDIN; g_stdin = STDIN;
@ -1287,7 +1324,7 @@ fill ()
CDR (12) = 1; CDR (12) = 1;
TYPE (13) = CHAR; TYPE (13) = CHAR;
CAR (11) = 0x58585858; CAR (13) = 0x58585858;
CDR (13) = 90; CDR (13) = 90;
TYPE (14) = 0x58585858; TYPE (14) = 0x58585858;
@ -1303,18 +1340,20 @@ fill ()
CAR (10) = 11; CAR (10) = 11;
CDR (10) = 12; CDR (10) = 12;
TYPE (11) = FUNCTION; TYPE (11) = TFUNCTION;
CAR (11) = 0x58585858; CAR (11) = 0x58585858;
// 0 = make_cell // 0 = make_cell
// 1 = cons // 1 = cons
// 2 = car
CDR (11) = 1; CDR (11) = 1;
TYPE (12) = PAIR; TYPE (12) = PAIR;
CAR (12) = 13; CAR (12) = 13;
//CDR (12) = 1;
CDR (12) = 14; CDR (12) = 14;
TYPE (13) = NUMBER; TYPE (13) = NUMBER;
CAR (13) =0x58585858; CAR (13) = 0x58585858;
CDR (13) = 0; CDR (13) = 0;
TYPE (14) = PAIR; TYPE (14) = PAIR;
@ -1326,9 +1365,7 @@ fill ()
CDR (15) = 1; CDR (15) = 1;
#endif #endif
TYPE (16) = 0x3c3c3c3c;
CAR (16) = 0x2d2d2d2d;
CDR (16) = 0x2d2d2d2d;
return 0; return 0;
} }
@ -1345,7 +1382,7 @@ display_ (SCM x)
putchar (VALUE (x)); putchar (VALUE (x));
break; break;
} }
case FUNCTION: case TFUNCTION:
{ {
//puts ("<function>\n"); //puts ("<function>\n");
if (VALUE (x) == 0) if (VALUE (x) == 0)
@ -1408,29 +1445,29 @@ display_ (SCM x)
SCM SCM
simple_bload_env (SCM a) ///((internal)) simple_bload_env (SCM a) ///((internal))
{ {
//g_stdin = open ("module/mes/read-0-32.mo", 0); puts ("reading: ");
g_stdin = open ("module/mes/hack-32.mo", 0); char *mo = "module/mes/hack-32.mo";
puts (mo);
puts ("\n");
g_stdin = open (mo, 0);
if (g_stdin < 0) {eputs ("no such file: module/mes/read-0-32.mo\n");return 1;} if (g_stdin < 0) {eputs ("no such file: module/mes/read-0-32.mo\n");return 1;}
int c;
char *p = (char*)g_cells; char *p = (char*)g_cells;
char *q = (char*)g_cells; int c;
puts ("q: "); #if 0
puts (q); //__GNUC__
puts ("\n");
#if __GNUC__
puts ("fd: "); puts ("fd: ");
puts (itoa (g_stdin)); puts (itoa (g_stdin));
puts ("\n"); puts ("\n");
#endif #endif
#if __GNUC__ #if 0
//__GNUC__
assert (getchar () == 'M'); assert (getchar () == 'M');
assert (getchar () == 'E'); assert (getchar () == 'E');
assert (getchar () == 'S'); assert (getchar () == 'S');
puts ("GOT MES!\n"); puts (" *GOT MES*\n");
g_stack = getchar () << 8; g_stack = getchar () << 8;
g_stack += getchar (); g_stack += getchar ();
puts ("stack: "); puts ("stack: ");
@ -1446,8 +1483,9 @@ simple_bload_env (SCM a) ///((internal))
c = getchar (); c = getchar ();
putchar (c); putchar (c);
if (c != 'S') exit (12); if (c != 'S') exit (12);
puts ("\n"); puts (" *GOT MES*\n");
puts ("GOT MES!\n");
// skip stack
getchar (); getchar ();
getchar (); getchar ();
#endif #endif
@ -1457,13 +1495,11 @@ simple_bload_env (SCM a) ///((internal))
{ {
*p++ = c; *p++ = c;
c = getchar (); c = getchar ();
putchar (c);
} }
puts ("q: "); puts ("read done\n");
puts (q);
puts ("\n");
#if 1
//__GNUC__
g_free = (p-(char*)g_cells) / sizeof (struct scm); g_free = (p-(char*)g_cells) / sizeof (struct scm);
// gc_peek_frame (); // gc_peek_frame ();
// g_symbols = r1; // g_symbols = r1;
@ -1471,6 +1507,7 @@ simple_bload_env (SCM a) ///((internal))
g_stdin = STDIN; g_stdin = STDIN;
r0 = mes_builtins (r0); r0 = mes_builtins (r0);
#if __GNUC__
puts ("cells read: "); puts ("cells read: ");
puts (itoa (g_free)); puts (itoa (g_free));
puts ("\n"); puts ("\n");
@ -1478,33 +1515,31 @@ simple_bload_env (SCM a) ///((internal))
puts ("symbols: "); puts ("symbols: ");
puts (itoa (g_symbols)); puts (itoa (g_symbols));
puts ("\n"); puts ("\n");
display_ (g_symbols); // display_ (g_symbols);
puts ("\n"); // puts ("\n");
fill ();
r2 = 10;
puts ("\n");
puts ("program: ");
puts (itoa (r2));
puts ("\n");
display_ (r2);
puts ("\n");
#else
display_ (10);
puts ("\n");
puts ("\n");
fill ();
display_ (10);
#endif #endif
display_ (10);
puts ("\n");
fill ();
r2 = 10;
if (TYPE (12) != PAIR)
exit (33);
puts ("program[");
#if __GNUC__
puts (itoa (r2));
#endif
puts ("]: ");
display_ (r2);
//display_ (14);
puts ("\n"); puts ("\n");
g_stack = 20;
TYPE (20) = SYMBOL;
CAR (20) = 1;
r0 = 1; r0 = 1;
//g_free = 21; //r2 = 10;
r2 = 10;
return r2; return r2;
} }
@ -1551,15 +1586,24 @@ stderr_ (SCM x)
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
puts ("mini-mes!\n"); puts ("Hello mini-mes!\n");
#if __GNUC__ #if __GNUC__
//g_debug = getenv ("MES_DEBUG"); //g_debug = getenv ("MES_DEBUG");
#endif #endif
//if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA")); //if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE"); if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE");
#if __GNUC__
if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs (VERSION);}; if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs (VERSION);};
#else
if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs ("0.4");};
#endif
g_stdin = STDIN; g_stdin = STDIN;
#if 1
r0 = mes_environment (); r0 = mes_environment ();
#else
puts ("FIXME: mes_environment ()\n");
#endif
#if MES_MINI #if MES_MINI
SCM program = simple_bload_env (r0); SCM program = simple_bload_env (r0);
@ -1588,7 +1632,6 @@ main (int argc, char *argv[])
eputs ("]\n"); eputs ("]\n");
} }
#endif #endif
puts ("Hello mini-mes!\n");
return 0; return 0;
} }

258
scaffold/t.c
View file

@ -87,34 +87,42 @@ strcmp (char const* a, char const* b)
while (*a && *b && *a == *b) {a++;b++;} while (*a && *b && *a == *b) {a++;b++;}
return *a - *b; return *a - *b;
} }
int test (char *p);
#endif #endif
// struct scm { struct scm {
// int type; int type;
// int car; int car;
// int cdr; int cdr;
// }; };
char arena[20]; char arena[200];
char *g_cells = arena; struct scm *g_cells = arena;
char *g_chars = arena;
char buf[200];
int int foo () {puts ("t: foo\n"); return 0;};
main (int argc, char *argv[]) int bar () {puts ("t: bar\n"); return 0;};
{ struct function {
char *p = "t.c\n"; int (*function) (void);
puts ("t.c\n"); int arity;
};
struct function g_fun = {&exit, 1};
struct function g_foo = {&foo, 1};
struct function g_bar = {&bar, 1};
if (argc > 1 && !strcmp (argv[1], "--help")) return 1; //void *functions[2];
puts ("t: if (argc > 1 && !strcmp (argv[1], \"--help\")\n"); int functions[2];
// FIXME mescc?! struct function g_functions[2];
if (argc > 1) if (!strcmp (argv[1], "--help")) return 1; int g_function = 0;
return test (p); enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART};
return 22;
}
typedef int SCM;
int g_free = 3;
SCM tmp;
#if 1
int int
swits (int c) swits (int c)
{ {
@ -141,6 +149,128 @@ swits (int c)
return x; return x;
} }
int g = 48;
int
get ()
{
int i = g;
g++;
return i;
}
int
read_test ()
{
puts ("read test\n");
char *p = (char*)g_chars;
int i = 0;
puts ("t: read 0123456789\n");
int c = get ();
while (i < 10) {
*p++ = c;
putchar (c);
c = get ();
i++;
}
puts ("\n");
if (strcmp (g_chars, "0123456789")) return 1;
return 0;
}
int
math_test ()
{
int i;
puts ("t: 4/2=");
i = 4 / 2;
if (i!=2) return 1;
i += 48;
putchar (i);
puts ("\n");
return read_test ();
}
SCM
make_tmps_test (struct scm* cells)
{
puts ("t: tmp = g_free++\n");
tmp = g_free++;
puts ("t: cells[tmp].type = CHAR\n");
cells[tmp].type = CHAR;
return math_test();
}
#define TYPE(x) (g_cells[x].type)
#define CAR(x) g_cells[x].car
#define CDR(x) g_cells[x].cdr
struct scm scm_fun = {TFUNCTION,0,0};
SCM cell_fun;
int
struct_test ()
{
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;
CDR (3) = 0x22;
CDR (4) = 0x23;
if (CDR (3) != 0x22)
return CDR (3);
puts ("t: struct fun = {&exit, 1};\n");
struct function fun = {&exit, 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: fun.arity != 1;\n");
if (fun.arity != 1) return 1;
puts ("t: fun.function != exit;\n");
if (fun.function != &exit) return 1;
puts ("t: g_functions[g_function++] = g_foo;\n");
g_functions[g_function++] = g_foo;
int fn = 0;
puts ("t: g_functions[g_cells[fn].cdr].arity\n");
if (!g_functions[g_cells[fn].cdr].arity) return 1;
int (*functionx) (void) = 0;
functionx = g_functions[0].function;
puts ("t: *functionx == foo\n");
if (*functionx != foo) return 11;
puts ("t: (*functionx) () == foo\n");
if ((*functionx) () != 0) return 12;
fn++;
g_functions[0] = g_bar;
if (g_cells[fn].cdr != 0) return 13;
puts ("t: g_functions[g_cells[fn].cdr].function\n");
functionx = g_functions[g_cells[fn].cdr].function;
puts ("t: *functionx == bar\n");
if (*functionx != bar) return 15;
puts ("t: (*functionx) () == bar\n");
if ((*functionx) () != 0) return 16;
scm_fun.cdr = g_function;
g_functions[g_function++] = g_fun;
cell_fun = g_free++;
g_cells[cell_fun] = scm_fun;
return make_tmps_test (g_cells);
}
int int
test (char *p) test (char *p)
{ {
@ -148,6 +278,10 @@ test (char *p)
int t = 1; int t = 1;
int one = 1; int one = 1;
char c = 'C'; char c = 'C';
int i=0;
char *x = arena;
char *y = g_chars;
puts ("t: if (0)\n"); puts ("t: if (0)\n");
if (0) return 1; if (0) return 1;
@ -194,34 +328,46 @@ test (char *p)
puts ("t: if (t && !one)\n"); puts ("t: if (t && !one)\n");
if (t && !one) return 1; if (t && !one) return 1;
int i=0; puts ("t: if (f || !t)\n");
if (f || !t) return 1;
puts ("t: if (i++)\n"); puts ("t: if (i++)\n");
if (i++) return 1; if (i++) return 1;
puts ("t: if (--i)\n"); puts ("t: if (--i)\n");
if (--i) return 1; if (--i) return 1;
puts ("t: i += 2\n");
i += 2;
if (i != 2) return 1;
puts ("t: i -= 2\n");
i -= 2;
if (i != 0) return 1;
puts ("t: (one == 1) ?\n"); puts ("t: (one == 1) ?\n");
(one == 1) ? 1 : exit (1); (one == 1) ? 1 : exit (1);
puts ("t: (f) ?\n"); puts ("t: (f) ?\n");
(f) ? exit (1) : 1; (f) ? exit (1) : 1;
puts ("t: *g_cells != 'A'\n"); puts ("t: *g_chars != 'A'\n");
arena[0] = 'A'; arena[0] = 'A';
if (*g_cells != 'A') return 1; if (*g_chars != 'A') return 1;
puts ("t: *x != 'A'\n"); puts ("t: *x != 'A'\n");
char *x = g_cells;
if (*x != 'A') return 1; if (*x != 'A') return 1;
puts ("t: *y != 'A'\n");
if (*y != 'A') return 1;
puts ("t: *x != 'Q'\n"); puts ("t: *x != 'Q'\n");
g_cells[0] = 'Q'; g_chars[0] = 'Q';
if (*x != 'Q') return 1; if (*x != 'Q') return 1;
puts ("t: *x++ != 'C'\n"); puts ("t: *x++ != 'C'\n");
*x++ = c; *x++ = c;
if (*g_cells != 'C') return 1; if (*g_chars != 'C') return 1;
puts ("t: switch 0\n"); puts ("t: switch 0\n");
if (swits (0) != 0) return swits (0); if (swits (0) != 0) return swits (0);
@ -237,6 +383,10 @@ test (char *p)
return 1; return 1;
ok0: ok0:
puts ("t: if (0); return 1; else;\n");
if (0) return 1; else goto ok01;
ok01:
puts ("t: if (t)\n"); puts ("t: if (t)\n");
if (t) goto ok1; if (t) goto ok1;
return 1; return 1;
@ -291,6 +441,11 @@ test (char *p)
return 1; return 1;
ok8: ok8:
puts ("t: if (f || t)\n");
if (f || t) goto ok80;
return 1;
ok80:
puts ("t: if (++i)\n"); puts ("t: if (++i)\n");
if (++i) goto ok9; if (++i) goto ok9;
return 1; return 1;
@ -301,36 +456,59 @@ test (char *p)
return 1; return 1;
ok10: ok10:
puts ("t: *g_cells == 'B'\n"); puts ("t: *g_chars == 'B'\n");
arena[0] = 'B'; arena[0] = 'B';
if (*g_cells == 'B') goto ok11; if (*g_chars == 'B') goto ok11;
return 1; return 1;
ok11: ok11:
puts ("t: *x == 'B'\n"); puts ("t: *x == 'B'\n");
x = g_cells; x = arena;
if (*x == 'B') goto ok12; if (*x == 'B') goto ok12;
return 1; return 1;
ok12: ok12:
puts ("t: *x == 'R'\n"); puts ("t: *y == 'B'\n");
g_cells[0] = 'R'; y = g_chars;
x = g_cells; if (*y == 'B') goto ok13;
if (*x == 'R') goto ok13;
return 1; return 1;
ok13: ok13:
puts ("t: *x++ == 'C'\n"); puts ("t: *x == 'R'\n");
*x++ = c; g_chars[0] = 'R';
if (*g_cells == 'C') goto ok14; if (*x == 'R') goto ok14;
return 1; return 1;
ok14: ok14:
puts ("t: for (i=0; i<4; ++i)\n"); puts ("t: *x++ == 'C'\n");
for (i=0; i<4; ++i); *x++ = c;
if (i != 4) return i; if (*g_chars == 'C') goto ok15;
return 1;
ok15:
return 0; puts ("t: for (i=1; i<5; ++i)\n");
for (i=1; i<5; ++i);
if (i != 5) return i;
return struct_test ();
}
#endif
int
main (int argc, char *argv[])
{
char *p = "t.c\n";
puts ("t.c\n");
if (argc > 1 && !strcmp (argv[1], "--help")) return 1;
puts ("t: if (argc > 1 && !strcmp (argv[1], \"--help\")\n");
// FIXME mescc?!
if (argc > 1) if (!strcmp (argv[1], "--help")) return 1;
return test (p);
return 22;
} }
#if __GNUC__ #if __GNUC__

175
scaffold/tiny-mes.c
View file

@ -31,6 +31,8 @@
#define NYACC_CDR nyacc_cdr #define NYACC_CDR nyacc_cdr
#endif #endif
char arena[200];
int g_stdin = 0; int g_stdin = 0;
#if __GNUC__ #if __GNUC__
@ -262,12 +264,10 @@ struct scm {
SCM cdr; SCM cdr;
}; };
#if 0 //char arena[200];
char arena[200]; //struct scm *g_cells = arena;
struct scm *g_cells = (struct scm*)arena; //struct scm *g_cells = (struct scm*)arena;
#else struct scm *g_cells = arena;
struct scm g_cells[200];
#endif
#define cell_nil 1 #define cell_nil 1
#define cell_f 2 #define cell_f 2
@ -348,7 +348,7 @@ fill ()
TYPE (9) = 0x2d2d2d2d; TYPE (9) = 0x2d2d2d2d;
CAR (9) = 0x2d2d2d2d; CAR (9) = 0x2d2d2d2d;
CDR (9) = 0x3e3e3e3e; CDR (9) = 0x3e3e3e3e;
#if 0
// (A(B)) // (A(B))
TYPE (10) = PAIR; TYPE (10) = PAIR;
CAR (10) = 11; CAR (10) = 11;
@ -373,35 +373,7 @@ fill ()
TYPE (14) = 0x58585858; TYPE (14) = 0x58585858;
CAR (14) = 0x58585858; CAR (14) = 0x58585858;
CDR (14) = 0x58585858; CDR (14) = 0x58585858;
#else
// (cons 0 1)
TYPE (10) = PAIR;
CAR (10) = 11;
CDR (10) = 12;
TYPE (11) = FUNCTION;
CAR (11) = 0x58585858;
// 0 = make_cell
// 1 = cons
CDR (11) = 1;
TYPE (12) = PAIR;
CAR (12) = 13;
CDR (12) = 14;
TYPE (13) = NUMBER;
CAR (13) =0x58585858;
CDR (13) = 0;
TYPE (14) = PAIR;
CAR (14) = 15;
CDR (14) = 1;
TYPE (15) = NUMBER;
CAR (15) = 0x58585858;
CDR (15) = 1;
#endif
TYPE (16) = 0x3c3c3c3c; TYPE (16) = 0x3c3c3c3c;
CAR (16) = 0x2d2d2d2d; CAR (16) = 0x2d2d2d2d;
CDR (16) = 0x2d2d2d2d; CDR (16) = 0x2d2d2d2d;
@ -484,35 +456,18 @@ display_ (SCM x)
SCM SCM
bload_env (SCM a) ///((internal)) bload_env (SCM a) ///((internal))
{ {
//g_stdin = open ("module/mes/read-0-32.mo", 0); puts ("reading: ");
g_stdin = open ("module/mes/hack-32.mo", 0); char *mo = "module/mes/hack-32.mo";
puts (mo);
puts ("\n");
g_stdin = open (mo, 0);
if (g_stdin < 0) {eputs ("no such file: module/mes/read-0-32.mo\n");return 1;} if (g_stdin < 0) {eputs ("no such file: module/mes/read-0-32.mo\n");return 1;}
int c; // BOOM
//char *p = arena;
char *p = (char*)g_cells; char *p = (char*)g_cells;
char *q = (char*)g_cells; int c;
puts ("q: ");
puts (q);
puts ("\n");
#if __GNUC__
puts ("fd: ");
puts (itoa (g_stdin));
puts ("\n");
#endif
#if __GNUC__
assert (getchar () == 'M');
assert (getchar () == 'E');
assert (getchar () == 'S');
puts ("GOT MES!\n");
g_stack = getchar () << 8;
g_stack += getchar ();
puts ("stack: ");
puts (itoa (g_stack));
puts ("\n");
#else
c = getchar (); c = getchar ();
putchar (c); putchar (c);
if (c != 'M') exit (10); if (c != 'M') exit (10);
@ -522,54 +477,30 @@ bload_env (SCM a) ///((internal))
c = getchar (); c = getchar ();
putchar (c); putchar (c);
if (c != 'S') exit (12); if (c != 'S') exit (12);
puts ("\n"); puts (" *GOT MES*\n");
puts ("GOT MES!\n");
// skip stack
getchar (); getchar ();
getchar (); getchar ();
#endif
c = getchar (); c = getchar ();
// int i = 0;
while (c != -1) while (c != -1)
{ {
*p++ = c; *p++ = c;
//g_cells[i] = c;
// i++;
c = getchar (); c = getchar ();
//puts ("\nc:");
//putchar (c);
} }
puts ("q: "); puts ("read done\n");
puts (q);
puts ("\n");
#if 0
//__GNUC__
g_free = (p-(char*)g_cells) / sizeof (struct scm);
gc_peek_frame ();
g_symbols = r1;
g_stdin = STDIN;
r0 = mes_builtins (r0);
puts ("cells read: ");
puts (itoa (g_free));
puts ("\n");
puts ("symbols: ");
puts (itoa (g_symbols));
puts ("\n");
display_ (g_symbols);
puts ("\n");
r2 = 10;
puts ("\n");
puts ("program: ");
puts (itoa (r2));
puts ("\n");
display_ (r2);
puts ("\n");
#else
display_ (10); display_ (10);
puts ("\n"); // puts ("\n");
puts ("\n"); // fill ();
fill (); // display_ (10);
display_ (10);
#endif
puts ("\n"); puts ("\n");
return r2; return r2;
} }
@ -577,52 +508,20 @@ bload_env (SCM a) ///((internal))
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
puts ("filled sexp:\n"); // if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n");
// if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");eputs (VERSION);return eputs ("\n");};
// if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n");
// puts ("Hello tiny-mes!\n");
fill (); fill ();
puts (g_cells);
puts ("\n");
// return 22;
display_ (10); display_ (10);
puts ("\n"); puts ("\n");
#if __GNUC__
g_debug = (int)getenv ("MES_DEBUG");
#endif
//if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n");
if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");eputs (VERSION);return eputs ("\n");};
if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n");
#if __GNUC__
g_stdin = STDIN;
r0 = mes_environment ();
#endif
#if MES_MINI
puts ("Hello tiny-mes!\n");
SCM program = bload_env (r0); SCM program = bload_env (r0);
#else
SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
? bload_env (r0) : load_env (r0);
if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
push_cc (r2, cell_unspecified, r0, cell_unspecified);
r3 = cell_vm_begin;
r1 = eval_apply ();
stderr_ (r1);
eputs ("\n");
gc (g_stack);
#endif
#if __GNUC__
if (g_debug)
{
eputs ("\nstats: [");
eputs (itoa (g_free));
eputs ("]\n");
}
#endif
return 0; return 0;
} }