mescc: Run mini-mes.
* .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
parent
8692fa3bb8
commit
70e4aec861
3
.gitignore
vendored
3
.gitignore
vendored
|
|
@ -15,6 +15,9 @@
|
|||
/mes
|
||||
/micro-mes
|
||||
/mini-mes
|
||||
/tiny-mes
|
||||
/module/mes/hack-32.mo
|
||||
/module/mes/read-0-32.mo
|
||||
/module/mes/read-0.mo
|
||||
/out
|
||||
?
|
||||
|
|
|
|||
9
HACKING
9
HACKING
|
|
@ -107,3 +107,12 @@ sc: http://sph.mn/content/3d3
|
|||
*** [[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-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]
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -31,21 +31,47 @@
|
|||
(mes
|
||||
(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)
|
||||
(append-map cdr functions))
|
||||
|
||||
(define (lambda/label->list f g t d)
|
||||
(define (lambda/label->list f g ta t d)
|
||||
(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)
|
||||
(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 '()))
|
||||
(if (null? lambdas/labels) text
|
||||
(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)
|
||||
(member name (reverse functions) (lambda (a b) (equal? (car b) name))))
|
||||
|
|
@ -55,7 +81,7 @@
|
|||
(lambda (name functions)
|
||||
(or (assoc-ref cache name)
|
||||
(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)))
|
||||
(if (or (equal? name "exit") (> offset 0)) (set! cache (assoc-set! cache name offset)))
|
||||
offset)))))
|
||||
|
|
@ -67,12 +93,12 @@
|
|||
(let loop ((text (cdr function-entry)))
|
||||
(if (or (equal? (car text) label) (null? text)) 0
|
||||
(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)))
|
||||
(+ (loop (cdr text)) n))))))))
|
||||
|
||||
(define (globals->data globals)
|
||||
(append-map cdr globals))
|
||||
(append-map (compose global:value cdr) globals))
|
||||
|
||||
(define (data-offset name globals)
|
||||
(let* ((prefix (member name (reverse globals)
|
||||
|
|
|
|||
|
|
@ -25,13 +25,18 @@
|
|||
(define-module (mes elf-util)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:export (data-offset
|
||||
dec->hex
|
||||
function-offset
|
||||
label-offset
|
||||
functions->lambdas
|
||||
functions->text
|
||||
lambda/label->list
|
||||
text->list
|
||||
globals->data))
|
||||
globals->data
|
||||
make-global
|
||||
global:type
|
||||
global:pointer
|
||||
global:value))
|
||||
|
||||
(cond-expand
|
||||
(guile-2)
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@
|
|||
(define elf32-off int->bv32)
|
||||
(define elf32-word int->bv32)
|
||||
|
||||
(define (make-elf functions globals)
|
||||
(define (make-elf functions globals init)
|
||||
(define vaddress #x08048000)
|
||||
|
||||
(define ei-magic `(#x7f ,@(string->list "ELF")))
|
||||
|
|
@ -181,7 +181,7 @@
|
|||
(map car functions))))
|
||||
|
||||
(define text-length
|
||||
(length (functions->text functions globals 0 0)))
|
||||
(length (functions->text functions globals 0 0 0)))
|
||||
|
||||
(define data-offset
|
||||
(+ text-offset text-length))
|
||||
|
|
@ -240,8 +240,11 @@
|
|||
(define SHF-EXEC 4)
|
||||
(define SHF-STRINGS #x20)
|
||||
|
||||
(let* ((text (functions->text functions globals 0 data-address))
|
||||
(data (globals->data globals))
|
||||
(let* ((text (functions->text functions globals text-address 0 data-address))
|
||||
(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)))
|
||||
(sym (sym functions globals))
|
||||
(str (str functions)))
|
||||
|
|
@ -269,8 +272,9 @@
|
|||
(define section-headers-offset
|
||||
(+ str-offset str-length))
|
||||
|
||||
(format (current-error-port) "ELF text=~a\n" text)
|
||||
;;(format (current-error-port) "ELF data=~a\n" data)
|
||||
(format (current-error-port) "ELF text=~a\n" (map dec->hex text))
|
||||
(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) "data-offset=~a\n" data-offset)
|
||||
(format (current-error-port) "_start=~a\n" (number->string entry 16))
|
||||
|
|
|
|||
|
|
@ -31,8 +31,8 @@
|
|||
(define (i386:function-locals)
|
||||
'(#x83 #xec #x20)) ; sub $0x10,%esp -- 8 local vars
|
||||
|
||||
(define (i386:push-global-ref o)
|
||||
(or o push-global-ref)
|
||||
(define (i386:push-global-address o)
|
||||
(or o push-global-address)
|
||||
`(#x68 ,@(int->bv32 o))) ; push $0x<o>
|
||||
|
||||
(define (i386:push-global o)
|
||||
|
|
@ -44,8 +44,8 @@
|
|||
(or n push-local)
|
||||
`(#xff #x75 ,(- 0 (* 4 n)))) ; pushl 0x<n>(%ebp)
|
||||
|
||||
(define (i386:push-local-ref n)
|
||||
(or n push-local-ref)
|
||||
(define (i386:push-local-address n)
|
||||
(or n push-local-address)
|
||||
`(#x8d #x45 ,(- 0 (* 4 n)) ; lea 0x<n>(%ebp),%eax
|
||||
#x50)) ; push %eax
|
||||
|
||||
|
|
@ -56,30 +56,39 @@
|
|||
;;#x0f #xbe #xc0 ; movsbl %al,%eax ***FIXME BYTE****
|
||||
#x50)) ; push %eax
|
||||
|
||||
(define (i386:push-accu)
|
||||
`(#x50)) ; push %eax
|
||||
(define (i386:pop-accu)
|
||||
'(#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)
|
||||
(or o push-arg)
|
||||
(cond ((number? o)
|
||||
`(#x68 ,@(int->bv32 o))) ; push $<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)
|
||||
((procedure? o) (o f g t d))
|
||||
((procedure? o) (o f g ta t d))
|
||||
(_ barf))))
|
||||
|
||||
(define (i386:ret . rest)
|
||||
(lambda (f g t d)
|
||||
(lambda (f g ta t d)
|
||||
`(
|
||||
,@(cond ((null? rest) '())
|
||||
((number? (car rest))
|
||||
`(#xb8 ; mov $<>,%eax
|
||||
`(#xb8 ; mov $<>,%eaxx
|
||||
,@(int->bv32 (car rest))))
|
||||
((pair? (car rest)) (car rest))
|
||||
((procedure? (car rest))
|
||||
((car rest) f g t d)))
|
||||
((car rest) f g ta t d)))
|
||||
#xc9 ; leave
|
||||
#xc3 ; ret
|
||||
)))
|
||||
|
|
@ -87,14 +96,37 @@
|
|||
(define (i386:accu->base)
|
||||
'(#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)
|
||||
(or n accu->local)
|
||||
`(#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)
|
||||
(or n accu->global)
|
||||
`(#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?)
|
||||
'(#x85 #xc0)) ; cmpl %eax,%eax
|
||||
|
||||
|
|
@ -103,6 +135,7 @@
|
|||
(i386:xor-zf)))
|
||||
|
||||
(define (i386:accu-shl n)
|
||||
(or n accu:shl n)
|
||||
`(#xc1 #xe0 ,n)) ; shl $0x8,%eax
|
||||
|
||||
(define (i386:accu+accu)
|
||||
|
|
@ -111,6 +144,21 @@
|
|||
(define (i386:accu+base)
|
||||
`(#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)
|
||||
'(#x89 #xd0)) ; mov %edx,%eax
|
||||
|
||||
|
|
@ -118,6 +166,15 @@
|
|||
(or n local->accu)
|
||||
`(#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)
|
||||
(or n byte-local->accu)
|
||||
`(#x0f #xb6 #x45 ,(- 0 (* 4 n)))) ; movzbl 0x<n>(%ebp),%eax
|
||||
|
|
@ -126,22 +183,27 @@
|
|||
(or n local->base)
|
||||
`(#x8b #x55 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%edx
|
||||
|
||||
;; (define (i386:local-ref->base n)
|
||||
;; (or n local-ref->base)
|
||||
;; `(#x8b #x15 ,@(int->bv32 (- 0 (* 4 n))))) ; mov 0x<n>,%edx
|
||||
|
||||
(define (i386:local-ref->base n)
|
||||
(or n local-ref->base)
|
||||
(define (i386:local-address->base n) ;; DE-REF
|
||||
(or n local-address->base)
|
||||
`(#x8d #x55 ,(- 0 (* 4 n)))) ; lea 0x<n>(%ebp),%edx
|
||||
|
||||
(define (i386:global-ref->base n)
|
||||
(or n global->base)
|
||||
`(#x8b #x15 ,@(int->bv32 n))) ; mov 0x<n>,%edx
|
||||
(define (i386:local-ptr->base n)
|
||||
(or n local-ptr->base)
|
||||
`(#x89 #xea ; mov %ebp,%edx
|
||||
#x83 #xc2 ,(- 0 (* 4 n)))) ; add $0x<n>,%edx
|
||||
|
||||
(define (i386:global->base n)
|
||||
(or n global->base)
|
||||
`(#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)
|
||||
'(#x01 #xd0 ; add %edx,%eax
|
||||
#x0f #xb6 #x00)) ; movzbl (%eax),%eax
|
||||
|
|
@ -163,44 +225,46 @@
|
|||
`(#x8b #x40 ,n)) ; mov 0x<n>(%eax),%eax
|
||||
|
||||
(define (i386:base-mem+n->accu n)
|
||||
(or n base-mem+n->accu)
|
||||
`(#x01 #xd0 ; add %edx,%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)
|
||||
(or v value->accu)
|
||||
(or v urg:value->accu)
|
||||
`(#xb8 ,@(int->bv32 v))) ; mov $<v>,%eax
|
||||
|
||||
(define (i386:value->accu-ref v)
|
||||
(or v value->accu-ref)
|
||||
(define (i386:value->accu-address v)
|
||||
`(#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)
|
||||
|
||||
(define (i386:base->accu-ref)
|
||||
(define (i386:base->accu-address)
|
||||
'(#x89 #x10)) ; mov %edx,(%eax)
|
||||
|
||||
(define (i386:byte-base->accu-ref)
|
||||
(define (i386:byte-base->accu-address)
|
||||
'(#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)
|
||||
(or v urg:value->base)
|
||||
`(#xba ,@(int->bv32 v))) ; mov $<v>,%edx
|
||||
|
||||
(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)
|
||||
|
||||
(define (i386:local-address->accu n)
|
||||
(or n ladd)
|
||||
`(#x8d #x45 ,(- 0 (* 4 n)))) ; lea 0x<n>(%ebp),%eax
|
||||
(define (i386:global-add n v)
|
||||
(or n urg:global-add)
|
||||
`(#x83 #x05 ,@(int->bv32 n) ,v)) ; addl $<v>,0x<n>
|
||||
|
||||
(define (i386:local-address->accu n)
|
||||
(or n ladd)
|
||||
`(#x8d #x45 ,(- 0 (* 4 n)))) ; lea 0x<n>(%ebp),%eax
|
||||
(define (i386:global->accu o)
|
||||
(or o urg:global->accu)
|
||||
`(#xb8 ,@(int->bv32 o))) ; mov $<>,%eax
|
||||
|
||||
(define (i386:value->global n v)
|
||||
(or n value->global)
|
||||
|
|
@ -213,11 +277,12 @@
|
|||
,@(int->bv32 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)
|
||||
|
||||
(define (i386:call f g t d address . arguments)
|
||||
(let* ((pushes (append-map (i386:push-arg f g t d) (reverse arguments)))
|
||||
(define (i386:call f g ta t d address . 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)))
|
||||
`(
|
||||
|
|
@ -226,11 +291,31 @@
|
|||
#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)
|
||||
`(#x0f #x94 #xc0 ; sete %al
|
||||
#x0f #xb6 #xc0)) ; movzbl %al,%eax
|
||||
|
||||
(define (i386:xor-accu v)
|
||||
(or n urg:xor-accu)
|
||||
`(#x35 ,@(int->bv32 v))) ;xor $0xff,%eax
|
||||
|
||||
(define (i386:xor-zf)
|
||||
|
|
@ -245,44 +330,55 @@
|
|||
'(#x85 #xc0)) ; test %eax,%eax
|
||||
|
||||
(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)
|
||||
(or n urg:Xjump-nz)
|
||||
`(#x0f #x85 ,@(int->bv32 n))) ; jnz . + <n>
|
||||
|
||||
(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>
|
||||
|
||||
;; (define (i386:jump n)
|
||||
;; `(#xeb ,(if (>= n 0) n (- n 2)))) ; jmp <n>
|
||||
|
||||
(define (i386:jump-c n)
|
||||
(or n jump-c)
|
||||
`(#x72 ,(if (>= n 0) n (- n 2)))) ; jc <n>
|
||||
|
||||
(define (i386:jump-cz n)
|
||||
(or n jump-cz)
|
||||
`(#x76 ,(if (>= n 0) n (- n 2)))) ; jna <n>
|
||||
|
||||
(define (i386:jump-ncz n)
|
||||
(or n jump-ncz)
|
||||
`(#x77 ,(if (>= n 0) n (- n 2)))) ; ja <n>
|
||||
|
||||
(define (i386:jump-nc n)
|
||||
(or n jump-nc)
|
||||
`(#x73 ,(if (>= n 0) n (- n 2)))) ; jnc <n>
|
||||
|
||||
(define (i386:jump-z n)
|
||||
(or n jump-z)
|
||||
`(#x74 ,(if (>= n 0) n (- n 2)))) ; jz <n>
|
||||
|
||||
(define (i386:jump-nz n)
|
||||
(or n jump-nz)
|
||||
`(#x75 ,(if (>= n 0) n (- n 2)))) ; jnz <n>
|
||||
|
||||
(define (i386:test-jump-z n)
|
||||
(or n jump-z)
|
||||
`(#x85 #xc0 ; test %eax,%eax
|
||||
#x74 ,(if (>= n 0) n (- n 4)))) ; jz <n>
|
||||
|
||||
(define (i386:jump-byte-nz n)
|
||||
(or n jump-byte-nz)
|
||||
`(#x84 #xc0 ; test %al,%al
|
||||
#x75 ,(if (>= n 0) n (- n 4)))) ; jne <n>
|
||||
|
||||
(define (i386:jump-byte-z n)
|
||||
(or n jump-byte-z)
|
||||
`(#x84 #xc0 ; test %al,%al
|
||||
#x74 ,(if (>= n 0) n (- n 4)))) ; jne <n>
|
||||
|
||||
|
|
@ -305,7 +401,7 @@
|
|||
`(#x29 #xc2)) ; sub %eax,%edx
|
||||
|
||||
;;; libc bits
|
||||
(define (i386:exit f g t d)
|
||||
(define (i386:exit f g ta t d)
|
||||
`(
|
||||
#x5b ; pop %ebx
|
||||
#x5b ; pop %ebx
|
||||
|
|
@ -313,7 +409,7 @@
|
|||
#xcd #x80 ; int $0x80
|
||||
))
|
||||
|
||||
(define (i386:open f g t d)
|
||||
(define (i386:open f g ta t d)
|
||||
`(
|
||||
#x55 ; push %ebp
|
||||
#x89 #xe5 ; mov %esp,%ebp
|
||||
|
|
@ -328,7 +424,7 @@
|
|||
#xc3 ; ret
|
||||
))
|
||||
|
||||
(define (i386:read f g t d)
|
||||
(define (i386:read f g ta t d)
|
||||
`(
|
||||
#x55 ; push %ebp
|
||||
#x89 #xe5 ; mov %esp,%ebp
|
||||
|
|
@ -344,7 +440,7 @@
|
|||
#xc3 ; ret
|
||||
))
|
||||
|
||||
(define (i386:write f g t d)
|
||||
(define (i386:write f g ta t d)
|
||||
`(
|
||||
#x55 ; push %ebp
|
||||
#x89 #xe5 ; mov %esp,%ebp
|
||||
|
|
|
|||
|
|
@ -31,21 +31,32 @@
|
|||
i386:accu-not
|
||||
i386:accu-cmp-value
|
||||
i386:accu->base
|
||||
i386:accu->base-address
|
||||
i386:accu->base-address+n
|
||||
i386:accu->global
|
||||
i386:accu->global-address
|
||||
i386:accu->local
|
||||
i386:accu-non-zero?
|
||||
i386:accu-test
|
||||
i386:accu-zero?
|
||||
i386:accu+accu
|
||||
i386:accu+base
|
||||
i386:accu+value
|
||||
i386:accu/base
|
||||
i386:accu-base
|
||||
i386:accu-shl
|
||||
i386:base-sub
|
||||
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: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:local-address->accu
|
||||
i386:byte-local->accu
|
||||
i386:byte-mem->accu
|
||||
i386:base-mem+n->accu
|
||||
|
|
@ -53,11 +64,15 @@
|
|||
i386:byte-test-base
|
||||
i386:byte-sub-base
|
||||
i386:call
|
||||
i386:call-accu
|
||||
i386:formal
|
||||
i386:function-locals
|
||||
i386:function-preamble
|
||||
i386:global-add
|
||||
i386:global->accu
|
||||
i386:global->base
|
||||
i386:global-address->accu
|
||||
i386:global-address->base
|
||||
i386:jump
|
||||
i386:jump
|
||||
i386:jump-byte-nz
|
||||
|
|
@ -73,24 +88,29 @@
|
|||
i386:local->base
|
||||
i386:local-add
|
||||
i386:local-address->accu
|
||||
i386:local-ref->base
|
||||
i386:local-ptr->accu
|
||||
i386:local-ptr->base
|
||||
i386:local-address->base
|
||||
i386:local-test
|
||||
i386:mem->accu
|
||||
i386:mem+n->accu
|
||||
i386:pop-accu
|
||||
i386:push-accu
|
||||
i386:pop-base
|
||||
i386:push-base
|
||||
i386:push-global
|
||||
i386:push-global-ref
|
||||
i386:push-global-address
|
||||
i386:push-local
|
||||
i386:push-local-de-ref
|
||||
i386:push-local-ref
|
||||
i386:push-local-address
|
||||
i386:ret
|
||||
i386:ret-local
|
||||
i386:sub-base
|
||||
i386:test-base
|
||||
i386:test-jump-z
|
||||
i386:value->accu
|
||||
i386:value->accu-ref
|
||||
i386:value->accu-ref+n
|
||||
i386:value->accu-address
|
||||
i386:value->accu-address+n
|
||||
i386:value->global
|
||||
i386:value->local
|
||||
i386:value->base
|
||||
|
|
|
|||
|
|
@ -32,6 +32,9 @@
|
|||
#define NYACC_CDR nyacc_cdr
|
||||
#endif
|
||||
|
||||
char arena[2000];
|
||||
//char buf0[400];
|
||||
|
||||
int g_stdin = 0;
|
||||
|
||||
#if __GNUC__
|
||||
|
|
@ -219,112 +222,92 @@ void
|
|||
assert_fail (char* s)
|
||||
{
|
||||
eputs ("assert fail:");
|
||||
#if __GNUC__
|
||||
eputs (s);
|
||||
#endif
|
||||
eputs ("\n");
|
||||
#if __GNUC__
|
||||
*((int*)0) = 0;
|
||||
#endif
|
||||
}
|
||||
|
||||
#if __NYACC__ || FIXME_NYACC
|
||||
#define assert(x) ((x) ? (void)0 : assert_fail(0))
|
||||
// #else
|
||||
// NYACC
|
||||
// #define assert(x) ((x) ? (void)0 : assert_fail(#x))
|
||||
#if __GNUC__
|
||||
#define assert(x) ((x) ? (void)0 : assert_fail ("boo:" #x))
|
||||
#else
|
||||
//#define assert(x) ((x) ? (void)0 : assert_fail ("boo:" #x))
|
||||
#define assert(x) ((x) ? (void)0 : assert_fail (0))
|
||||
#endif
|
||||
#define false 0
|
||||
#define true 1
|
||||
typedef int bool;
|
||||
|
||||
int ARENA_SIZE = 100000;
|
||||
|
||||
typedef int SCM;
|
||||
|
||||
#if __GNUC__
|
||||
bool g_debug = false;
|
||||
int g_debug = 0;
|
||||
#endif
|
||||
|
||||
int g_free = 0;
|
||||
|
||||
SCM g_symbols = 0;
|
||||
SCM g_stack = 0;
|
||||
SCM r0 = 0; // a/env
|
||||
SCM r1 = 0; // param 1
|
||||
SCM r2 = 0; // save 2+load/dump
|
||||
SCM r3 = 0; // continuation
|
||||
// a/env
|
||||
SCM r0 = 0;
|
||||
// param 1
|
||||
SCM r1 = 0;
|
||||
// save 2+load/dump
|
||||
SCM r2 = 0;
|
||||
// continuation
|
||||
SCM r3 = 0;
|
||||
|
||||
#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
|
||||
enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
|
||||
#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;
|
||||
union {
|
||||
char const *name;
|
||||
SCM string;
|
||||
SCM car;
|
||||
SCM ref;
|
||||
int length;
|
||||
} NYACC_CAR;
|
||||
union {
|
||||
int value;
|
||||
int function;
|
||||
SCM cdr;
|
||||
SCM closure;
|
||||
SCM continuation;
|
||||
SCM macro;
|
||||
SCM vector;
|
||||
int hits;
|
||||
} NYACC_CDR;
|
||||
} scm;
|
||||
};
|
||||
|
||||
scm scm_nil = {SPECIAL, "()"};
|
||||
scm scm_f = {SPECIAL, "#f"};
|
||||
scm scm_t = {SPECIAL, "#t"};
|
||||
scm scm_dot = {SPECIAL, "."};
|
||||
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*"};
|
||||
typedef int (*f_t) (void);
|
||||
struct function {
|
||||
int (*function) (void);
|
||||
int arity;
|
||||
};
|
||||
|
||||
scm scm_vm_apply = {SPECIAL, "core:apply"};
|
||||
scm scm_vm_apply2 = {SPECIAL, "*vm-apply2*"};
|
||||
struct scm *g_cells = arena;
|
||||
|
||||
scm scm_vm_eval = {SPECIAL, "core:eval"};
|
||||
//scm *g_news = 0;
|
||||
|
||||
scm scm_vm_begin = {SPECIAL, "*vm-begin*"};
|
||||
//scm scm_vm_begin_read_input_file = {SPECIAL, "*vm-begin-read-input-file*"};
|
||||
scm scm_vm_begin2 = {SPECIAL, "*vm-begin2*"};
|
||||
// struct scm scm_nil = {SPECIAL, "()"};
|
||||
// struct scm scm_f = {SPECIAL, "#f"};
|
||||
// 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_f 2
|
||||
#define cell_t 3
|
||||
#define cell_dot 4
|
||||
#define cell_arrow 5
|
||||
// #define cell_arrow 5
|
||||
#define cell_undefined 6
|
||||
#define cell_unspecified 7
|
||||
#define cell_closure 8
|
||||
|
|
@ -348,61 +331,62 @@ scm scm_vm_return = {SPECIAL, "*vm-return*"};
|
|||
|
||||
#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_num;
|
||||
SCM tmp_num2;
|
||||
|
||||
function_t functions[200];
|
||||
int ARENA_SIZE = 200;
|
||||
struct function functions[2];
|
||||
int g_function = 0;
|
||||
|
||||
|
||||
SCM make_cell (SCM type, SCM car, SCM cdr);
|
||||
function_t fun_make_cell = {&make_cell, 3};
|
||||
scm scm_make_cell = {FUNCTION, "make-cell", 0};
|
||||
struct function fun_make_cell = {&make_cell, 3};
|
||||
struct scm scm_make_cell = {TFUNCTION,0,0};
|
||||
//, "make-cell", 0};
|
||||
SCM cell_make_cell;
|
||||
|
||||
SCM cons (SCM x, SCM y);
|
||||
function_t fun_cons = {&cons, 2};
|
||||
scm scm_cons = {FUNCTION, "cons", 0};
|
||||
struct function fun_cons = {&cons, 2};
|
||||
struct scm scm_cons = {TFUNCTION,0,0};
|
||||
// "cons", 0};
|
||||
SCM cell_cons;
|
||||
|
||||
SCM car (SCM x);
|
||||
function_t fun_car = {&car, 1};
|
||||
scm scm_car = {FUNCTION, "car", 0};
|
||||
struct function fun_car = {&car, 1};
|
||||
struct scm scm_car = {TFUNCTION,0,0};
|
||||
// "car", 0};
|
||||
SCM cell_car;
|
||||
|
||||
SCM cdr (SCM x);
|
||||
function_t fun_cdr = {&cdr, 1};
|
||||
scm scm_cdr = {FUNCTION, "cdr", 0};
|
||||
struct function fun_cdr = {&cdr, 1};
|
||||
struct scm scm_cdr = {TFUNCTION,0,0};
|
||||
// "cdr", 0};
|
||||
SCM cell_cdr;
|
||||
|
||||
// SCM eq_p (SCM x, SCM y);
|
||||
// function_t fun_eq_p = {&eq_p, 2};
|
||||
// scm scm_eq_p = {FUNCTION, "eq?", 0};
|
||||
// struct function fun_eq_p = {&eq_p, 2};
|
||||
// scm scm_eq_p = {TFUNCTION,0,0};// "eq?", 0};
|
||||
// SCM cell_eq_p;
|
||||
|
||||
#define TYPE(x) (g_cells[x].type)
|
||||
|
||||
#define CAR(x) g_cells[x].car
|
||||
#define LENGTH(x) g_cells[x].length
|
||||
#define STRING(x) g_cells[x].string
|
||||
#define LENGTH(x) g_cells[x].car
|
||||
#define STRING(x) g_cells[x].car
|
||||
|
||||
#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 FUNCTION(x) functions[g_cells[x].function]
|
||||
#define VALUE(x) g_cells[x].value
|
||||
#define VECTOR(x) g_cells[x].vector
|
||||
#if __GNUC__
|
||||
//#define FUNCTION(x) functions[g_cells[x].function]
|
||||
#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_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 (car) CAR (x) = CAR (car);
|
||||
if (cdr) CDR(x) = CDR(cdr);
|
||||
} else if (VALUE (type) == FUNCTION) {
|
||||
} else if (VALUE (type) == TFUNCTION) {
|
||||
if (car) CAR (x) = car;
|
||||
if (cdr) CDR(x) = CDR(cdr);
|
||||
} else {
|
||||
|
|
@ -470,8 +454,13 @@ tmp_num2_ (int x)
|
|||
SCM
|
||||
cons (SCM x, SCM y)
|
||||
{
|
||||
#if __GNUC__
|
||||
VALUE (tmp_num) = PAIR;
|
||||
return make_cell (tmp_num, x, y);
|
||||
#else
|
||||
//FIXME GNUC
|
||||
return 0;
|
||||
#endif
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
@ -498,24 +487,33 @@ cdr (SCM x)
|
|||
return CDR(x);
|
||||
}
|
||||
|
||||
SCM
|
||||
eq_p (SCM x, SCM y)
|
||||
{
|
||||
return (x == y
|
||||
|| ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD
|
||||
&& STRING (x) == STRING (y)))
|
||||
|| (TYPE (x) == CHAR && TYPE (y) == CHAR
|
||||
&& VALUE (x) == VALUE (y))
|
||||
|| (TYPE (x) == NUMBER && TYPE (y) == NUMBER
|
||||
&& VALUE (x) == VALUE (y)))
|
||||
? cell_t : cell_f;
|
||||
}
|
||||
// SCM
|
||||
// eq_p (SCM x, SCM y)
|
||||
// {
|
||||
// return (x == y
|
||||
// || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD
|
||||
// && STRING (x) == STRING (y)))
|
||||
// || (TYPE (x) == CHAR && TYPE (y) == CHAR
|
||||
// && VALUE (x) == VALUE (y))
|
||||
// || (TYPE (x) == NUMBER && TYPE (y) == NUMBER
|
||||
// && VALUE (x) == VALUE (y)))
|
||||
// ? cell_t : cell_f;
|
||||
// }
|
||||
|
||||
SCM
|
||||
gc_push_frame ()
|
||||
{
|
||||
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
|
||||
|
|
@ -540,7 +538,8 @@ pairlis (SCM x, SCM y, SCM a)
|
|||
SCM
|
||||
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;
|
||||
}
|
||||
|
||||
|
|
@ -565,6 +564,7 @@ assert_defined (SCM x, SCM e)
|
|||
SCM
|
||||
push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
|
||||
{
|
||||
puts ("push_cc\n");
|
||||
SCM x = r3;
|
||||
r3 = c;
|
||||
r2 = p2;
|
||||
|
|
@ -575,6 +575,20 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
|
|||
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 cadr (SCM x) {return car (cdr (x));}
|
||||
SCM cdar (SCM x) {return cdr (car (x));}
|
||||
|
|
@ -597,9 +611,9 @@ eval_apply ()
|
|||
case cell_vm_evlis2: goto evlis2;
|
||||
case cell_vm_evlis3: goto evlis3;
|
||||
#endif
|
||||
case cell_vm_apply: goto apply;
|
||||
case cell_vm_apply2: goto apply2;
|
||||
case cell_vm_eval: goto eval;
|
||||
case cell_vm_apply: {goto apply;}
|
||||
case cell_vm_apply2: {goto apply2;}
|
||||
case cell_vm_eval: {goto eval;}
|
||||
#if 0
|
||||
#if FIXED_PRIMITIVES
|
||||
case cell_vm_eval_car: goto eval_car;
|
||||
|
|
@ -612,9 +626,9 @@ eval_apply ()
|
|||
case cell_vm_eval2: goto eval2;
|
||||
case cell_vm_macro_expand: goto macro_expand;
|
||||
#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_begin2: goto begin2;
|
||||
case cell_vm_begin2: {goto begin2;}
|
||||
#if 0
|
||||
case cell_vm_if: goto vm_if;
|
||||
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_return: goto vm_return;
|
||||
#endif
|
||||
case cell_unspecified: return r1;
|
||||
default:
|
||||
assert (0);
|
||||
case cell_unspecified: {return r1;}
|
||||
default: {assert (0);}
|
||||
}
|
||||
|
||||
SCM x = cell_nil;
|
||||
|
|
@ -646,7 +659,7 @@ eval_apply ()
|
|||
apply:
|
||||
switch (TYPE (car (r1)))
|
||||
{
|
||||
case FUNCTION: {
|
||||
case TFUNCTION: {
|
||||
//check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
|
||||
r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
|
||||
goto vm_return;
|
||||
|
|
@ -823,7 +836,7 @@ eval_apply ()
|
|||
r1 = assert_defined (r1, assq_ref_env (r1, r0));
|
||||
goto vm_return;
|
||||
}
|
||||
default: goto vm_return;
|
||||
default: {goto vm_return;}
|
||||
}
|
||||
|
||||
// SCM macro;
|
||||
|
|
@ -937,7 +950,7 @@ call (SCM fn, SCM x)
|
|||
if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
|
||||
&& x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES)
|
||||
x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
|
||||
function_t* f = &FUNCTION (fn);
|
||||
struct function* f = &FUNCTION (fn);
|
||||
switch (FUNCTION (fn).arity)
|
||||
{
|
||||
// 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 3: return FUNCTION (fn).function3 (car (x), cadr (x), car (cddr (x)));
|
||||
// case -1: return FUNCTION (fn).functionn (x);
|
||||
case 0: return (FUNCTION (fn).function) ();
|
||||
case 1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (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 -1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
|
||||
case 0: {return (FUNCTION (fn).function) ();}
|
||||
case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (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 -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
|
||||
default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
|
||||
}
|
||||
|
||||
return cell_unspecified;
|
||||
|
|
@ -987,7 +1001,7 @@ mes_g_stack (SCM a) ///((internal))
|
|||
|
||||
// Environment setup
|
||||
SCM
|
||||
make_tmps (scm* cells)
|
||||
make_tmps (struct scm* cells)
|
||||
{
|
||||
tmp = g_free++;
|
||||
cells[tmp].type = CHAR;
|
||||
|
|
@ -995,6 +1009,7 @@ make_tmps (scm* cells)
|
|||
cells[tmp_num].type = NUMBER;
|
||||
tmp_num2 = g_free++;
|
||||
cells[tmp_num2].type = NUMBER;
|
||||
return 0;
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
@ -1066,67 +1081,68 @@ mes_symbols () ///((internal))
|
|||
//#include "mes.symbols.i"
|
||||
#else
|
||||
g_free++;
|
||||
g_cells[cell_nil] = scm_nil;
|
||||
// g_cells[cell_nil] = scm_nil;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_f] = scm_f;
|
||||
// g_cells[cell_f] = scm_f;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_t] = scm_t;
|
||||
// g_cells[cell_t] = scm_t;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_dot] = scm_dot;
|
||||
// g_cells[cell_dot] = scm_dot;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_arrow] = scm_arrow;
|
||||
// g_cells[cell_arrow] = scm_arrow;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_undefined] = scm_undefined;
|
||||
// g_cells[cell_undefined] = scm_undefined;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_unspecified] = scm_unspecified;
|
||||
// g_cells[cell_unspecified] = scm_unspecified;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_closure] = scm_closure;
|
||||
// g_cells[cell_closure] = scm_closure;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_circular] = scm_circular;
|
||||
// g_cells[cell_circular] = scm_circular;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_begin] = scm_begin;
|
||||
// g_cells[cell_begin] = scm_begin;
|
||||
|
||||
///
|
||||
g_free = 44;
|
||||
g_free++;
|
||||
g_cells[cell_vm_apply] = scm_vm_apply;
|
||||
// g_cells[cell_vm_apply] = scm_vm_apply;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_vm_apply2] = scm_vm_apply2;
|
||||
// g_cells[cell_vm_apply2] = scm_vm_apply2;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_vm_eval] = scm_vm_eval;
|
||||
// g_cells[cell_vm_eval] = scm_vm_eval;
|
||||
|
||||
///
|
||||
g_free = 55;
|
||||
g_free++;
|
||||
g_cells[cell_vm_begin] = scm_vm_begin;
|
||||
// g_cells[cell_vm_begin] = scm_vm_begin;
|
||||
|
||||
g_free++;
|
||||
// g_cells[cell_vm_begin_read_input_file] = scm_vm_begin_read_input_file;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_vm_begin2] = scm_vm_begin2;
|
||||
// g_cells[cell_vm_begin2] = scm_vm_begin2;
|
||||
|
||||
///
|
||||
g_free = 62;
|
||||
g_free++;
|
||||
g_cells[cell_vm_return] = scm_vm_return;
|
||||
// g_cells[cell_vm_return] = scm_vm_return;
|
||||
|
||||
#endif
|
||||
|
||||
g_symbol_max = g_free;
|
||||
make_tmps (g_cells);
|
||||
|
||||
// FIXME GNUC
|
||||
g_symbols = 0;
|
||||
for (int i=1; i<g_symbol_max; i++)
|
||||
g_symbols = cons (i, g_symbols);
|
||||
|
|
@ -1136,21 +1152,22 @@ g_cells[cell_vm_return] = scm_vm_return;
|
|||
#if __GNUC__ && 0
|
||||
//#include "mes.symbol-names.i"
|
||||
#else
|
||||
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_t].car = cstring_to_list (scm_t.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_undefined].car = cstring_to_list (scm_undefined.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_circular].car = cstring_to_list (scm_circular.name);
|
||||
g_cells[cell_begin].car = cstring_to_list (scm_begin.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_t].car = cstring_to_list (scm_t.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_undefined].car = cstring_to_list (scm_undefined.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_circular].car = cstring_to_list (scm_circular.name);
|
||||
// g_cells[cell_begin].car = cstring_to_list (scm_begin.name);
|
||||
#endif
|
||||
|
||||
// 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);
|
||||
|
||||
//FIXME GNUC
|
||||
a = acons (cell_symbol_dot, cell_dot, a); //
|
||||
a = acons (cell_symbol_begin, cell_begin, a);
|
||||
a = acons (cell_closure, a, a);
|
||||
|
|
@ -1170,8 +1187,10 @@ make_closure (SCM args, SCM body, SCM a)
|
|||
SCM
|
||||
mes_environment () ///((internal))
|
||||
{
|
||||
SCM a = mes_symbols ();
|
||||
return mes_g_stack (a);
|
||||
SCM a = 0;
|
||||
a = mes_symbols ();
|
||||
a = mes_g_stack (a);
|
||||
return a;
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
@ -1192,22 +1211,39 @@ mes_builtins (SCM a)
|
|||
// #include "posix.environment.i"
|
||||
// #include "reader.environment.i"
|
||||
#else
|
||||
scm_make_cell.function = g_function;
|
||||
|
||||
scm_make_cell.cdr = g_function;
|
||||
functions[g_function++] = fun_make_cell;
|
||||
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;
|
||||
cell_cons = g_free++;
|
||||
#if __GNUC__
|
||||
//FIXME GNUC
|
||||
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;
|
||||
cell_car = g_free++;
|
||||
#if __GNUC__
|
||||
//FIXME GNUC
|
||||
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;
|
||||
cell_cdr = g_free++;
|
||||
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);
|
||||
// g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string);
|
||||
// a = acons (make_symbol (scm_cdr.string), cell_cdr, a);
|
||||
#endif
|
||||
#endif
|
||||
return a;
|
||||
}
|
||||
|
|
@ -1250,7 +1287,7 @@ bload_env (SCM a) ///((internal))
|
|||
*p++ = c;
|
||||
c = getchar ();
|
||||
}
|
||||
g_free = (p-(char*)g_cells) / sizeof (scm);
|
||||
g_free = (p-(char*)g_cells) / sizeof (struct scm);
|
||||
gc_peek_frame ();
|
||||
g_symbols = r1;
|
||||
g_stdin = STDIN;
|
||||
|
|
@ -1287,7 +1324,7 @@ fill ()
|
|||
CDR (12) = 1;
|
||||
|
||||
TYPE (13) = CHAR;
|
||||
CAR (11) = 0x58585858;
|
||||
CAR (13) = 0x58585858;
|
||||
CDR (13) = 90;
|
||||
|
||||
TYPE (14) = 0x58585858;
|
||||
|
|
@ -1303,18 +1340,20 @@ fill ()
|
|||
CAR (10) = 11;
|
||||
CDR (10) = 12;
|
||||
|
||||
TYPE (11) = FUNCTION;
|
||||
TYPE (11) = TFUNCTION;
|
||||
CAR (11) = 0x58585858;
|
||||
// 0 = make_cell
|
||||
// 1 = cons
|
||||
// 2 = car
|
||||
CDR (11) = 1;
|
||||
|
||||
TYPE (12) = PAIR;
|
||||
CAR (12) = 13;
|
||||
//CDR (12) = 1;
|
||||
CDR (12) = 14;
|
||||
|
||||
TYPE (13) = NUMBER;
|
||||
CAR (13) =0x58585858;
|
||||
CAR (13) = 0x58585858;
|
||||
CDR (13) = 0;
|
||||
|
||||
TYPE (14) = PAIR;
|
||||
|
|
@ -1326,9 +1365,7 @@ fill ()
|
|||
CDR (15) = 1;
|
||||
|
||||
#endif
|
||||
TYPE (16) = 0x3c3c3c3c;
|
||||
CAR (16) = 0x2d2d2d2d;
|
||||
CDR (16) = 0x2d2d2d2d;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
@ -1345,7 +1382,7 @@ display_ (SCM x)
|
|||
putchar (VALUE (x));
|
||||
break;
|
||||
}
|
||||
case FUNCTION:
|
||||
case TFUNCTION:
|
||||
{
|
||||
//puts ("<function>\n");
|
||||
if (VALUE (x) == 0)
|
||||
|
|
@ -1408,29 +1445,29 @@ display_ (SCM x)
|
|||
SCM
|
||||
simple_bload_env (SCM a) ///((internal))
|
||||
{
|
||||
//g_stdin = open ("module/mes/read-0-32.mo", 0);
|
||||
g_stdin = open ("module/mes/hack-32.mo", 0);
|
||||
puts ("reading: ");
|
||||
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;}
|
||||
|
||||
int c;
|
||||
char *p = (char*)g_cells;
|
||||
char *q = (char*)g_cells;
|
||||
int c;
|
||||
|
||||
puts ("q: ");
|
||||
puts (q);
|
||||
puts ("\n");
|
||||
|
||||
#if __GNUC__
|
||||
#if 0
|
||||
//__GNUC__
|
||||
puts ("fd: ");
|
||||
puts (itoa (g_stdin));
|
||||
puts ("\n");
|
||||
#endif
|
||||
|
||||
#if __GNUC__
|
||||
#if 0
|
||||
//__GNUC__
|
||||
assert (getchar () == 'M');
|
||||
assert (getchar () == 'E');
|
||||
assert (getchar () == 'S');
|
||||
puts ("GOT MES!\n");
|
||||
puts (" *GOT MES*\n");
|
||||
g_stack = getchar () << 8;
|
||||
g_stack += getchar ();
|
||||
puts ("stack: ");
|
||||
|
|
@ -1446,8 +1483,9 @@ simple_bload_env (SCM a) ///((internal))
|
|||
c = getchar ();
|
||||
putchar (c);
|
||||
if (c != 'S') exit (12);
|
||||
puts ("\n");
|
||||
puts ("GOT MES!\n");
|
||||
puts (" *GOT MES*\n");
|
||||
|
||||
// skip stack
|
||||
getchar ();
|
||||
getchar ();
|
||||
#endif
|
||||
|
|
@ -1457,13 +1495,11 @@ simple_bload_env (SCM a) ///((internal))
|
|||
{
|
||||
*p++ = c;
|
||||
c = getchar ();
|
||||
putchar (c);
|
||||
}
|
||||
|
||||
puts ("q: ");
|
||||
puts (q);
|
||||
puts ("\n");
|
||||
#if 1
|
||||
//__GNUC__
|
||||
puts ("read done\n");
|
||||
|
||||
g_free = (p-(char*)g_cells) / sizeof (struct scm);
|
||||
// gc_peek_frame ();
|
||||
// g_symbols = r1;
|
||||
|
|
@ -1471,6 +1507,7 @@ simple_bload_env (SCM a) ///((internal))
|
|||
g_stdin = STDIN;
|
||||
r0 = mes_builtins (r0);
|
||||
|
||||
#if __GNUC__
|
||||
puts ("cells read: ");
|
||||
puts (itoa (g_free));
|
||||
puts ("\n");
|
||||
|
|
@ -1478,33 +1515,31 @@ simple_bload_env (SCM a) ///((internal))
|
|||
puts ("symbols: ");
|
||||
puts (itoa (g_symbols));
|
||||
puts ("\n");
|
||||
display_ (g_symbols);
|
||||
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);
|
||||
// display_ (g_symbols);
|
||||
// puts ("\n");
|
||||
#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");
|
||||
g_stack = 20;
|
||||
TYPE (20) = SYMBOL;
|
||||
CAR (20) = 1;
|
||||
|
||||
r0 = 1;
|
||||
//g_free = 21;
|
||||
r2 = 10;
|
||||
//r2 = 10;
|
||||
return r2;
|
||||
}
|
||||
|
||||
|
|
@ -1551,15 +1586,24 @@ stderr_ (SCM x)
|
|||
int
|
||||
main (int argc, char *argv[])
|
||||
{
|
||||
puts ("mini-mes!\n");
|
||||
puts ("Hello mini-mes!\n");
|
||||
#if __GNUC__
|
||||
//g_debug = 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");
|
||||
#if __GNUC__
|
||||
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;
|
||||
|
||||
#if 1
|
||||
r0 = mes_environment ();
|
||||
#else
|
||||
puts ("FIXME: mes_environment ()\n");
|
||||
#endif
|
||||
|
||||
#if MES_MINI
|
||||
SCM program = simple_bload_env (r0);
|
||||
|
|
@ -1588,7 +1632,6 @@ main (int argc, char *argv[])
|
|||
eputs ("]\n");
|
||||
}
|
||||
#endif
|
||||
puts ("Hello mini-mes!\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
|
|||
258
scaffold/t.c
258
scaffold/t.c
|
|
@ -87,34 +87,42 @@ strcmp (char const* a, char const* b)
|
|||
while (*a && *b && *a == *b) {a++;b++;}
|
||||
return *a - *b;
|
||||
}
|
||||
int test (char *p);
|
||||
#endif
|
||||
|
||||
// struct scm {
|
||||
// int type;
|
||||
// int car;
|
||||
// int cdr;
|
||||
// };
|
||||
struct scm {
|
||||
int type;
|
||||
int car;
|
||||
int cdr;
|
||||
};
|
||||
|
||||
char arena[20];
|
||||
char *g_cells = arena;
|
||||
char arena[200];
|
||||
struct scm *g_cells = arena;
|
||||
char *g_chars = arena;
|
||||
char buf[200];
|
||||
|
||||
int
|
||||
main (int argc, char *argv[])
|
||||
{
|
||||
char *p = "t.c\n";
|
||||
puts ("t.c\n");
|
||||
int foo () {puts ("t: foo\n"); return 0;};
|
||||
int bar () {puts ("t: bar\n"); return 0;};
|
||||
struct function {
|
||||
int (*function) (void);
|
||||
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;
|
||||
puts ("t: if (argc > 1 && !strcmp (argv[1], \"--help\")\n");
|
||||
//void *functions[2];
|
||||
int functions[2];
|
||||
|
||||
// FIXME mescc?!
|
||||
if (argc > 1) if (!strcmp (argv[1], "--help")) return 1;
|
||||
struct function g_functions[2];
|
||||
int g_function = 0;
|
||||
|
||||
return test (p);
|
||||
return 22;
|
||||
}
|
||||
enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART};
|
||||
|
||||
typedef int SCM;
|
||||
int g_free = 3;
|
||||
SCM tmp;
|
||||
|
||||
#if 1
|
||||
int
|
||||
swits (int c)
|
||||
{
|
||||
|
|
@ -141,6 +149,128 @@ swits (int c)
|
|||
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
|
||||
test (char *p)
|
||||
{
|
||||
|
|
@ -148,6 +278,10 @@ test (char *p)
|
|||
int t = 1;
|
||||
int one = 1;
|
||||
char c = 'C';
|
||||
int i=0;
|
||||
|
||||
char *x = arena;
|
||||
char *y = g_chars;
|
||||
|
||||
puts ("t: if (0)\n");
|
||||
if (0) return 1;
|
||||
|
|
@ -194,34 +328,46 @@ test (char *p)
|
|||
puts ("t: if (t && !one)\n");
|
||||
if (t && !one) return 1;
|
||||
|
||||
int i=0;
|
||||
puts ("t: if (f || !t)\n");
|
||||
if (f || !t) return 1;
|
||||
|
||||
puts ("t: if (i++)\n");
|
||||
if (i++) return 1;
|
||||
|
||||
puts ("t: if (--i)\n");
|
||||
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");
|
||||
(one == 1) ? 1 : exit (1);
|
||||
|
||||
puts ("t: (f) ?\n");
|
||||
(f) ? exit (1) : 1;
|
||||
|
||||
puts ("t: *g_cells != 'A'\n");
|
||||
puts ("t: *g_chars != 'A'\n");
|
||||
arena[0] = 'A';
|
||||
if (*g_cells != 'A') return 1;
|
||||
if (*g_chars != 'A') return 1;
|
||||
|
||||
puts ("t: *x != 'A'\n");
|
||||
char *x = g_cells;
|
||||
if (*x != 'A') return 1;
|
||||
|
||||
puts ("t: *y != 'A'\n");
|
||||
if (*y != 'A') return 1;
|
||||
|
||||
puts ("t: *x != 'Q'\n");
|
||||
g_cells[0] = 'Q';
|
||||
g_chars[0] = 'Q';
|
||||
if (*x != 'Q') return 1;
|
||||
|
||||
puts ("t: *x++ != 'C'\n");
|
||||
*x++ = c;
|
||||
if (*g_cells != 'C') return 1;
|
||||
if (*g_chars != 'C') return 1;
|
||||
|
||||
puts ("t: switch 0\n");
|
||||
if (swits (0) != 0) return swits (0);
|
||||
|
|
@ -237,6 +383,10 @@ test (char *p)
|
|||
return 1;
|
||||
ok0:
|
||||
|
||||
puts ("t: if (0); return 1; else;\n");
|
||||
if (0) return 1; else goto ok01;
|
||||
ok01:
|
||||
|
||||
puts ("t: if (t)\n");
|
||||
if (t) goto ok1;
|
||||
return 1;
|
||||
|
|
@ -291,6 +441,11 @@ test (char *p)
|
|||
return 1;
|
||||
ok8:
|
||||
|
||||
puts ("t: if (f || t)\n");
|
||||
if (f || t) goto ok80;
|
||||
return 1;
|
||||
ok80:
|
||||
|
||||
puts ("t: if (++i)\n");
|
||||
if (++i) goto ok9;
|
||||
return 1;
|
||||
|
|
@ -301,36 +456,59 @@ test (char *p)
|
|||
return 1;
|
||||
ok10:
|
||||
|
||||
puts ("t: *g_cells == 'B'\n");
|
||||
puts ("t: *g_chars == 'B'\n");
|
||||
arena[0] = 'B';
|
||||
if (*g_cells == 'B') goto ok11;
|
||||
if (*g_chars == 'B') goto ok11;
|
||||
return 1;
|
||||
ok11:
|
||||
|
||||
puts ("t: *x == 'B'\n");
|
||||
x = g_cells;
|
||||
x = arena;
|
||||
if (*x == 'B') goto ok12;
|
||||
return 1;
|
||||
ok12:
|
||||
|
||||
puts ("t: *x == 'R'\n");
|
||||
g_cells[0] = 'R';
|
||||
x = g_cells;
|
||||
if (*x == 'R') goto ok13;
|
||||
puts ("t: *y == 'B'\n");
|
||||
y = g_chars;
|
||||
if (*y == 'B') goto ok13;
|
||||
return 1;
|
||||
ok13:
|
||||
|
||||
puts ("t: *x++ == 'C'\n");
|
||||
*x++ = c;
|
||||
if (*g_cells == 'C') goto ok14;
|
||||
puts ("t: *x == 'R'\n");
|
||||
g_chars[0] = 'R';
|
||||
if (*x == 'R') goto ok14;
|
||||
return 1;
|
||||
ok14:
|
||||
|
||||
puts ("t: for (i=0; i<4; ++i)\n");
|
||||
for (i=0; i<4; ++i);
|
||||
if (i != 4) return i;
|
||||
puts ("t: *x++ == 'C'\n");
|
||||
*x++ = c;
|
||||
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__
|
||||
|
|
|
|||
|
|
@ -31,6 +31,8 @@
|
|||
#define NYACC_CDR nyacc_cdr
|
||||
#endif
|
||||
|
||||
char arena[200];
|
||||
|
||||
int g_stdin = 0;
|
||||
|
||||
#if __GNUC__
|
||||
|
|
@ -262,12 +264,10 @@ struct scm {
|
|||
SCM cdr;
|
||||
};
|
||||
|
||||
#if 0
|
||||
char arena[200];
|
||||
struct scm *g_cells = (struct scm*)arena;
|
||||
#else
|
||||
struct scm g_cells[200];
|
||||
#endif
|
||||
//char arena[200];
|
||||
//struct scm *g_cells = arena;
|
||||
//struct scm *g_cells = (struct scm*)arena;
|
||||
struct scm *g_cells = arena;
|
||||
|
||||
#define cell_nil 1
|
||||
#define cell_f 2
|
||||
|
|
@ -348,7 +348,7 @@ fill ()
|
|||
TYPE (9) = 0x2d2d2d2d;
|
||||
CAR (9) = 0x2d2d2d2d;
|
||||
CDR (9) = 0x3e3e3e3e;
|
||||
#if 0
|
||||
|
||||
// (A(B))
|
||||
TYPE (10) = PAIR;
|
||||
CAR (10) = 11;
|
||||
|
|
@ -373,35 +373,7 @@ fill ()
|
|||
TYPE (14) = 0x58585858;
|
||||
CAR (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;
|
||||
CAR (16) = 0x2d2d2d2d;
|
||||
CDR (16) = 0x2d2d2d2d;
|
||||
|
|
@ -484,35 +456,18 @@ display_ (SCM x)
|
|||
SCM
|
||||
bload_env (SCM a) ///((internal))
|
||||
{
|
||||
//g_stdin = open ("module/mes/read-0-32.mo", 0);
|
||||
g_stdin = open ("module/mes/hack-32.mo", 0);
|
||||
puts ("reading: ");
|
||||
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;}
|
||||
|
||||
int c;
|
||||
// BOOM
|
||||
//char *p = arena;
|
||||
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 ();
|
||||
putchar (c);
|
||||
if (c != 'M') exit (10);
|
||||
|
|
@ -522,54 +477,30 @@ bload_env (SCM a) ///((internal))
|
|||
c = getchar ();
|
||||
putchar (c);
|
||||
if (c != 'S') exit (12);
|
||||
puts ("\n");
|
||||
puts ("GOT MES!\n");
|
||||
puts (" *GOT MES*\n");
|
||||
|
||||
// skip stack
|
||||
getchar ();
|
||||
getchar ();
|
||||
#endif
|
||||
|
||||
c = getchar ();
|
||||
// int i = 0;
|
||||
while (c != -1)
|
||||
{
|
||||
*p++ = c;
|
||||
//g_cells[i] = c;
|
||||
// i++;
|
||||
c = getchar ();
|
||||
//puts ("\nc:");
|
||||
//putchar (c);
|
||||
}
|
||||
|
||||
puts ("q: ");
|
||||
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
|
||||
puts ("read done\n");
|
||||
display_ (10);
|
||||
puts ("\n");
|
||||
puts ("\n");
|
||||
fill ();
|
||||
display_ (10);
|
||||
#endif
|
||||
// puts ("\n");
|
||||
// fill ();
|
||||
// display_ (10);
|
||||
|
||||
puts ("\n");
|
||||
return r2;
|
||||
}
|
||||
|
|
@ -577,52 +508,20 @@ bload_env (SCM a) ///((internal))
|
|||
int
|
||||
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 ();
|
||||
puts (g_cells);
|
||||
puts ("\n");
|
||||
// return 22;
|
||||
display_ (10);
|
||||
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);
|
||||
|
||||
#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;
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue