243 lines
6.8 KiB
Scheme
243 lines
6.8 KiB
Scheme
|
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
|
||
|
|
|
||
|
|
; (make-vector size init)
|
||
|
|
|
||
|
|
(define-c-generator make-vector #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(let ((type (node-type call)))
|
||
|
|
(write-c-coercion type port)
|
||
|
|
(format port "malloc(sizeof(")
|
||
|
|
(display-c-type (pointer-type-to type) #f port)
|
||
|
|
(format port ") * ")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ")"))))
|
||
|
|
|
||
|
|
(define-c-generator vector-ref #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-vector-ref (call-arg call 0) (call-arg call 1) port)))
|
||
|
|
|
||
|
|
(define (generate-c-vector-ref vector index port)
|
||
|
|
(display "*(" port)
|
||
|
|
(c-value vector port)
|
||
|
|
(display " + " port)
|
||
|
|
(c-value index port)
|
||
|
|
(writec port #\)))
|
||
|
|
|
||
|
|
(define-c-generator vector-set! #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-vector-set (call-arg call 1)
|
||
|
|
(call-arg call 2)
|
||
|
|
(call-arg call 3)
|
||
|
|
port indent)))
|
||
|
|
|
||
|
|
(define (generate-c-vector-set vector index value port indent)
|
||
|
|
(indent-to port indent)
|
||
|
|
(generate-c-vector-ref vector index port)
|
||
|
|
(display " = " port)
|
||
|
|
(c-value value port)
|
||
|
|
(writec port #\;))
|
||
|
|
|
||
|
|
(define-c-generator make-string #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
; calloc is used as a hack to get a zero at the end
|
||
|
|
(format port "(char *)calloc( 1, 1 + ")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ")")))
|
||
|
|
|
||
|
|
(define-c-generator string-length #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(format port "strlen((char *) ")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ")")))
|
||
|
|
|
||
|
|
(define-c-generator string-ref #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-vector-ref (call-arg call 0) (call-arg call 1) port)))
|
||
|
|
|
||
|
|
(define-c-generator string-set! #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-vector-set (call-arg call 1)
|
||
|
|
(call-arg call 2)
|
||
|
|
(call-arg call 3)
|
||
|
|
port indent)))
|
||
|
|
|
||
|
|
(define-c-generator make-record #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(let ((type (get-record-type (literal-value (call-arg call 0)))))
|
||
|
|
(write-c-coercion type port)
|
||
|
|
(format port "malloc(sizeof(struct ")
|
||
|
|
(write-c-identifier (record-type-name type) port)
|
||
|
|
(format port "))"))))
|
||
|
|
|
||
|
|
(define-c-generator record-ref #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-record-ref (call-arg call 0)
|
||
|
|
(call-arg call 1)
|
||
|
|
(call-arg call 2)
|
||
|
|
port)))
|
||
|
|
|
||
|
|
(define (generate-c-record-ref record type field port)
|
||
|
|
(let ((field (get-record-type-field (literal-value type)
|
||
|
|
(literal-value field))))
|
||
|
|
(c-value record port)
|
||
|
|
(display "->" port)
|
||
|
|
(write-c-identifier (record-field-name field) port)))
|
||
|
|
|
||
|
|
(define-c-generator record-set! #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-record-set (call-arg call 1)
|
||
|
|
(call-arg call 2)
|
||
|
|
(call-arg call 3)
|
||
|
|
(call-arg call 4)
|
||
|
|
port indent)))
|
||
|
|
|
||
|
|
(define (generate-c-record-set record value type field port indent)
|
||
|
|
(indent-to port indent)
|
||
|
|
(generate-c-record-ref record type field port)
|
||
|
|
(display " = " port)
|
||
|
|
(c-value value port)
|
||
|
|
(writec port #\;))
|
||
|
|
|
||
|
|
(define-c-generator allocate-memory #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(write-c-coercion type/address port)
|
||
|
|
(format port "malloc(")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ")")))
|
||
|
|
|
||
|
|
(define-c-generator deallocate #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(format port "free(")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ")")))
|
||
|
|
|
||
|
|
(define-c-generator deallocate-memory #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(format port "free(")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ")")))
|
||
|
|
|
||
|
|
(define-c-generator address+ #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(simple-c-primop "+" call port)))
|
||
|
|
|
||
|
|
(define-c-generator address-difference #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(simple-c-primop "-" call port)))
|
||
|
|
|
||
|
|
(define-c-generator address= #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(simple-c-primop "==" call port)))
|
||
|
|
|
||
|
|
(define-c-generator address< #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(simple-c-primop "<" call port)))
|
||
|
|
|
||
|
|
(define-c-generator address->integer #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(format port "((long) ")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ")")))
|
||
|
|
|
||
|
|
(define-c-generator integer->address #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(format port "((char *) ")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ")")))
|
||
|
|
|
||
|
|
(define-c-generator copy-memory! #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(format port "memcpy((void *)")
|
||
|
|
(c-value (call-arg call 1) port)
|
||
|
|
(format port ", (void *)")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ",")
|
||
|
|
(c-value (call-arg call 2) port)
|
||
|
|
(format port ")")))
|
||
|
|
|
||
|
|
(define-c-generator memory-equal? #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(format port "(!memcmp((void *)")
|
||
|
|
(c-value (call-arg call 1) port)
|
||
|
|
(format port ", (void *)")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ",")
|
||
|
|
(c-value (call-arg call 2) port)
|
||
|
|
(format port "))")))
|
||
|
|
|
||
|
|
(define-c-generator byte-ref #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-memory-ref "unsigned char" (call-arg call 0) port)))
|
||
|
|
|
||
|
|
(define-c-generator word-ref #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-memory-ref "long" (call-arg call 0) port)))
|
||
|
|
|
||
|
|
(define (generate-c-memory-ref type pointer port)
|
||
|
|
(format port "*((~A *) " type)
|
||
|
|
(c-value pointer port)
|
||
|
|
(writec port #\)))
|
||
|
|
|
||
|
|
(define-c-generator byte-set! #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-memory-set! "unsigned char"
|
||
|
|
(call-arg call 1)
|
||
|
|
(call-arg call 2)
|
||
|
|
port
|
||
|
|
indent)))
|
||
|
|
|
||
|
|
(define-c-generator word-set! #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-memory-set! "long"
|
||
|
|
(call-arg call 1)
|
||
|
|
(call-arg call 2)
|
||
|
|
port
|
||
|
|
indent)))
|
||
|
|
|
||
|
|
(define (generate-c-memory-set! type pointer value port indent)
|
||
|
|
(indent-to port indent)
|
||
|
|
(generate-c-memory-ref type pointer port)
|
||
|
|
(display " = " port)
|
||
|
|
(c-value value port)
|
||
|
|
(writec port #\;))
|
||
|
|
|
||
|
|
(define-c-generator char-pointer->string #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(format port "((char *)")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ")")))
|
||
|
|
|
||
|
|
(define-c-generator char-pointer->nul-terminated-string #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(format port "((char *)")
|
||
|
|
(c-value (call-arg call 0) port)
|
||
|
|
(format port ")")))
|
||
|
|
|
||
|
|
(define-c-generator computed-goto #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-switch call port indent)))
|
||
|
|
|
||
|
|
(define (generate-c-switch call port indent)
|
||
|
|
(let ((size (call-exits call)))
|
||
|
|
(indent-to port indent)
|
||
|
|
(display "switch (" port)
|
||
|
|
(c-value (call-arg call (+ size 1)) port)
|
||
|
|
(display ") {" port)
|
||
|
|
(let ((indent (+ indent 2)))
|
||
|
|
(do ((i 0 (+ i 1))
|
||
|
|
(labels (literal-value (call-arg call size)) (cdr labels)))
|
||
|
|
((>= i size))
|
||
|
|
(for-each (lambda (l)
|
||
|
|
(indent-to port indent)
|
||
|
|
(format port "case ~D : " l))
|
||
|
|
(car labels))
|
||
|
|
(write-c-switch-case (call-arg call i) port indent)))
|
||
|
|
(indent-to port indent)
|
||
|
|
(display "}" port)))
|
||
|
|
|
||
|
|
(define (write-c-switch-case node port indent)
|
||
|
|
(writec port #\{)
|
||
|
|
(write-c-block (lambda-body node) port (+ indent 2))
|
||
|
|
(indent-to port (+ indent 2))
|
||
|
|
(display "break;" port))
|