in the load sequence.
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.18 2006/10/01 05:37:44 cph Exp $
+$Id: compiler.pkg,v 1.19 2006/10/08 01:26:49 cph Exp $
Copyright 1993,1994,2001,2002,2006 Massachusetts Institute of Technology
lap:make-unconditional-branch)
(export (compiler top-level)
*block-associations*
- c:write-group
current-register-list
fake-compiled-block-name
free-assignments
#| -*-Scheme-*-
-$Id: cout.scm,v 1.29 2006/10/07 05:48:58 cph Exp $
+$Id: cout.scm,v 1.30 2006/10/08 01:27:47 cph Exp $
Copyright 1993,1998,2006 Massachusetts Institute of Technology
(and (exact-integer? value)
(<= guaranteed-long/lower-limit value)
(< value guaranteed-long/upper-limit)))
-\f
-;;;; Output abstraction
-
-(define-record-type <c:line>
- (c:%make-line indentation text)
- c:line?
- (indentation c:line-indentation)
- (text c:line-text))
-
-(define-guarantee c:line "C line")
-
-(define (c:line . items)
- (c:%make-line 0 (apply string-append items)))
-
-(define (c:line-items items)
- (if (pair? items)
- (if (pair? (cdr items))
- (apply string-append (map c:line-item items))
- (c:line-item (car items)))
- ""))
-
-(define (c:line-item item)
- (cond ((string? item) item)
- ((char? item) (string item))
- ((symbol? item) (symbol-name item))
- ((number? item) (number->string item))
- ((decoded-time? item) (decoded-time->iso8601-string item))
- ((not item) "false")
- ((eq? item #t) "true")
- (else (error:wrong-type-argument item "C line item" 'C:LINE-ITEM))))
-
-(define (c:make-line indentation text)
- (c:%make-line (if (or (string-null? text)
- (string-prefix? "#" text)
- (string-prefix? "\f" text))
- 0
- indentation)
- text))
-
-(define (c:write-line line port)
- (let ((qr
- (integer-divide (* (max 0 (c:line-indentation line))
- c:indentation-delta)
- c:indentation-tab-width)))
- (let ((n (integer-divide-quotient qr)))
- (do ((i 0 (+ i 1)))
- ((not (< i n)))
- (write-char #\tab port)))
- (let ((n (integer-divide-remainder qr)))
- (do ((i 0 (+ i 1)))
- ((not (< i n)))
- (write-char #\space port))))
- (write-string (c:line-text line) port)
- (newline port))
-
-(define c:indentation-delta 2)
-(define c:indentation-tab-width 8)
-
-(define (c:label-line? line)
- (string-prefix? "DEFLABEL " (c:line-text line)))
-
-(define (c:blank-line? line)
- (string-null? (c:line-text line)))
-\f
-(define-record-type <c:group>
- (c:%make-group lines)
- c:group?
- (lines c:group-lines))
-
-(define-guarantee c:group "C group")
-
-(define (c:group . items)
- (c:group* items))
-
-(define (c:group* items)
- (if (and (pair? items)
- (c:group? (car items))
- (null? (cdr items)))
- (car items)
- (c:make-group
- (append-map (lambda (item)
- (cond ((c:line? item) (list item))
- ((c:group? item) (c:group-lines item))
- ((not item) '())
- (else (error:not-c:line item 'C:GROUP*))))
- items))))
-
-(define c:make-group
- (let ((empty (c:%make-group '())))
- (lambda (lines)
- (if (null? lines)
- empty
- (c:%make-group lines)))))
-
-(define (c:group-length group)
- (length (c:group-lines group)))
-
-(define (c:indent . items)
- (c:indent* items))
-
-(define (c:indent* items)
- (c:%indent (c:group* items) 1))
-
-(define (c:exdent . items)
- (c:exdent* items))
-
-(define (c:exdent* items)
- (c:%indent (c:group* items) -1))
-
-(define (c:%indent item delta)
- (let ((indent-line
- (lambda (line)
- (c:make-line (+ (c:line-indentation line) delta)
- (c:line-text line)))))
- (cond ((c:line? item)
- (indent-line item))
- ((c:group? item)
- (c:make-group (map indent-line (c:group-lines item))))
- (else
- (error:not-c:line item 'C:%INDENT)))))
-
-(define (c:write-group group port)
- (cond ((c:line? group) (c:write-line group port))
- ((c:group? group)
- (let loop ((lines (c:group-lines group)) (prev #f))
- (if (pair? lines)
- (let ((line (car lines))
- (lines (cdr lines)))
- (if (and (c:label-line? line)
- (not (and prev
- (or (c:label-line? prev)
- (c:blank-line? prev)))))
- (newline port))
- (c:write-line line port)
- (loop lines line)))))
- (else (error:not-c:group group 'C:WRITE-GROUP))))
-\f
-(define (c:comment . content)
- (string-append "/* " (c:line-items content) " */"))
-
-(define (c:string . content)
- (string-append "\"" (c:line-items content) "\""))
-
-(define (c:parens . content)
- (string-append "(" (c:line-items content) ")"))
-
-(define (c:struct-init . exprs)
- (string-append "{ " (c:comma-list exprs) " }"))
-
-(define (c:comma-list exprs)
- (decorated-string-append "" ", " "" (map c:line-item exprs)))
-
-(define (c:hex n)
- (string-append "0x" (number->string n 16)))
-
-(define (c:page)
- (c:line "\f"))
-
-(define (c:brace-group . items)
- (c:brace-group* items))
-
-(define (c:brace-group* items)
- (c:group (c:line "{")
- (c:indent* items)
- (c:line "}")))
-
-(define (c:code-section . items)
- (apply c:ifndef "WANT_ONLY_DATA" items))
-
-(define (c:data-section . items)
- (apply c:ifndef "WANT_ONLY_CODE" items))
-
-(define (c:ifndef symbol . body)
- (c:group (c:line "#ifndef " (c:var symbol))
- (c:line)
- (c:group* body)
- (c:line)
- (c:line "#endif " (c:comment "!" symbol))))
-
-(define (c:include name)
- (c:line "#include "
- (if (and (string-prefix? "<" name)
- (string-suffix? ">" name))
- name
- (string-append "\"" name "\""))))
-
-(define (c:define symbol val)
- (c:line "#define " (c:var symbol) " " (c:expr val)))
-
-(define (c:fn static? rtype name adecls . body)
- (c:group (c:line (if static? "static " "")
- (c:type rtype))
- (c:line name
- " "
- (if (null? adecls)
- "(void)"
- (c:parens
- (c:comma-list (map (lambda (p)
- (string-append (c:type (car p))
- " "
- (c:var (cdr p))))
- adecls)))))
- (c:brace-group* body)))
-\f
-(define (c:= var val)
- (c:line (c:expr var) " = " (c:expr val) ";"))
-
-(define (c:+= var val)
- (c:line (c:expr var) " += " (c:expr val) ";"))
-
-(define (c:-= var val)
- (c:line (c:expr var) " -= " (c:expr val) ";"))
-
-(define (c:*= var val)
- (c:line (c:expr var) " *= " (c:expr val) ";"))
-
-(define (c:/= var val)
- (c:line (c:expr var) " /= " (c:expr val) ";"))
-
-(define (c:goto label)
- (c:line "goto " (c:var label) ";"))
-
-(define (c:label label)
- (c:exdent (c:scall "DEFLABEL" label)))
-
-(define (c:return expr)
- (c:line "return " (c:pexpr expr) ";"))
-
-(define (c:scall function . args)
- (c:line (apply c:call function args) ";"))
-
-(define (c:ecall function . args)
- (c:parens (apply c:call function args)))
-
-(define (c:call function . args)
- (string-append (c:expr function)
- " "
- (let ((args (map c:expr args)))
- (if (and (pair? args)
- (null? (cdr args))
- (c:%parenthesized? (car args)))
- (car args)
- (c:parens (c:comma-list args))))))
-
-(define (c:switch expr . cases)
- (c:group (c:line "switch " (c:pexpr expr))
- (c:indent (c:brace-group* cases))))
-
-(define (c:case tag . items)
- (c:group (c:exdent
- (c:line (if tag
- (string-append "case " (c:line-item tag))
- "default")
- ":"))
- (c:group* items)))
-
-(define (c:if-goto pred label)
- (c:group (c:line "if " (c:pexpr pred))
- (c:indent (c:goto label))))
-
-(define (c:while expr . body)
- (c:group (c:line "while " (c:pexpr expr))
- (c:indent (c:brace-group* body))))
-\f
-(define (c:cast type expr)
- (let ((type (c:type type))
- (expr (c:expr expr)))
- (let ((p
- (and (c:%decimal? expr)
- (assoc type c:decimal-suffixes))))
- (if p
- (string-append expr (cdr p))
- (string-append "((" type ") " expr ")")))))
-
-(define c:decimal-suffixes
- '(("long" . "L")
- ("unsigned" . "U")
- ("unsigned long" . "UL")))
-
-(define (c:%decimal? e)
- (let ((n (string-length e)))
- (let loop
- ((i
- (if (or (string-prefix? "-" e)
- (string-prefix? "+" e))
- 1
- 0)))
- (if (fix:< i n)
- (and (char-set-member? c:decimal-chars (string-ref e i))
- (loop (fix:+ i 1)))
- #t))))
-
-(define c:decimal-chars
- (ascii-range->char-set (char->integer #\0)
- (+ (char->integer #\9) 1)))
-
-(define (c:type type)
- (or (and (symbol? type)
- (let ((p (assq type type-abbrevs)))
- (and p
- (cdr p))))
- (c:line-item type)))
-
-(define type-abbrevs
- (let ((types
- (let ((types '(char short int long float double)))
- `(,@(map (lambda (t)
- (cons t (symbol-name t)))
- types)
- ,@(map (lambda (t)
- (cons (symbol 'u t)
- (string-append "unsigned " (symbol-name t))))
- types)
- (sobj . "SCHEME_OBJECT")))))
- `(,@types
- ,@(map (lambda (p)
- (cons (symbol (car p) '*)
- (string-append (cdr p) " *")))
- types))))
-
-(define (c:decl type var #!optional val)
- (c:line (c:type type) " " (c:var var)
- (if (default-object? val) "" (string-append " = " (c:expr val)))
- ";"))
-
-(define (c:var item)
- (cond ((string? item) item)
- ((symbol? item) (symbol-name item))
- (else (error:wrong-type-argument item "C variable" 'C:VAR))))
-
-(define (c:array-decl type name dim items)
- (let ((lines (list-copy items)))
- (if (pair? lines)
- (let loop ((lines lines))
- (if (pair? (cdr lines))
- (begin
- (set-car! lines (c:line (c:line-item (car lines)) ","))
- (loop (cdr lines)))
- (set-car! lines (c:line (c:line-item (car lines)))))))
- (c:group (c:line (c:type type) " " (c:var name) " [" (c:expr dim) "] =")
- (c:indent (c:group (c:line "{")
- (c:indent (c:group* lines))
- (c:line "};"))))))
-\f
-(define (c:expr expr)
- (let ((expr (c:line-item expr)))
- (if (or (c:%identifier? expr)
- (string->number expr)
- (c:%parenthesized? expr)
- (and (string-prefix? "\"" expr)
- (string-suffix? "\"" expr)))
- expr
- (string-append "(" expr ")"))))
-
-(define (c:pexpr expr)
- (let ((expr (c:line-item expr)))
- (if (c:%parenthesized? expr)
- expr
- (string-append "(" expr ")"))))
-
-(define (c:%identifier? e)
- (let ((n (string-length e)))
- (let loop ((i 0))
- (if (fix:< i n)
- (and (char-set-member? c:identifier-chars (string-ref e i))
- (loop (fix:+ i 1)))
- #t))))
-
-(define c:identifier-chars
- (char-set-union (ascii-range->char-set (char->integer #\A)
- (+ (char->integer #\Z) 1))
- (ascii-range->char-set (char->integer #\a)
- (+ (char->integer #\z) 1))
- (ascii-range->char-set (char->integer #\0)
- (+ (char->integer #\9) 1))
- (char-set #\_)))
-
-(define (c:%parenthesized? e)
- (and (string-prefix? "(" e)
- (string-suffix? ")" e)))
-
-(define (c:predec expr)
- (string-append "--" (c:expr expr)))
-
-(define (c:preinc expr)
- (string-append "++" (c:expr expr)))
-
-(define (c:postdec expr)
- (string-append (c:expr expr) "--"))
-
-(define (c:postinc expr)
- (string-append (c:expr expr) "++"))
-
-(define (c:aref array index)
- (string-append "(" (c:expr array) " [" (c:expr index) "])"))
-
-(define (c:aptr array index)
- (c:& (c:aref array index)))
-
-(define (c:?: a b c . rest)
- (apply string-append
- "("
- (c:expr a)
- " ? "
- (c:expr b)
- " : "
- (c:expr c)
- (let loop ((exprs rest))
- (if (pair? exprs)
- (begin
- (if (not (pair? (cdr exprs)))
- (error "C:?: requires even number of args."))
- (cons* " ? "
- (c:expr (car exprs))
- " : "
- (c:expr (cadr exprs))
- (loop (cddr exprs))))
- (list ")")))))
-\f
-(define (c:unary op a)
- (string-append "(" (c:line-item op) " " (c:expr a) ")"))
-
-(define (c:! a)
- (c:unary "!" a))
-
-(define (c:~ a)
- (c:unary "~" a))
-
-(define (c:binary-infix op a b)
- (string-append "(" (c:expr a) " " (c:line-item op) " " (c:expr b) ")"))
-
-(define (c:== a b)
- (c:binary-infix "==" a b))
-
-(define (c:!= a b)
- (c:binary-infix "==" a b))
-
-(define (c:> a b)
- (c:binary-infix ">" a b))
-
-(define (c:>= a b)
- (c:binary-infix ">=" a b))
-
-(define (c:< a b)
- (c:binary-infix "<" a b))
-
-(define (c:<= a b)
- (c:binary-infix "<=" a b))
-
-(define (c:\| a b)
- (c:binary-infix "|" a b))
-
-(define (c:^ a b)
- (c:binary-infix "^" a b))
-
-(define (c:&~ a b)
- (c:binary-infix "&~" a b))
-
-(define (c:/ a b)
- (c:binary-infix "/" a b))
-
-(define (c:<< a b)
- (c:binary-infix "<<" a b))
-
-(define (c:>> a b)
- (c:binary-infix ">>" a b))
-
-(define (c:ubinary op a b)
- (if (default-object? b)
- (c:unary op a)
- (c:binary-infix op a b)))
-
-(define (c:& a #!optional b)
- (c:ubinary "&" a b))
-
-(define (c:* a #!optional b)
- (c:ubinary "*" a b))
-
-(define (c:+ a #!optional b)
- (c:ubinary "+" a b))
-
-(define (c:- a #!optional b)
- (c:ubinary "-" a b))
;;; Edwin Variables:
;;; lisp-indent/c:fn: 4
#| -*-Scheme-*-
-$Id: cutl.scm,v 1.5 2006/10/06 05:00:29 cph Exp $
+$Id: cutl.scm,v 1.6 2006/10/08 01:27:53 cph Exp $
Copyright 1993,2006 Massachusetts Institute of Technology
;;; package: (compiler)
(declare (usual-integrations))
-
+\f
(define (back-end:+ x y)
(cond ((and (number? x) (number? y)) (+ x y))
((and (number? y) (= y 0)) x)
;; This is a lie, but it is used only in places where #f is the
;; correct default.
(cond ((and (number? x) (number? y)) (< x y))
- (else #f)))
\ No newline at end of file
+ (else #f)))
+\f
+;;;; Output abstraction
+
+(define-record-type <c:line>
+ (c:%make-line indentation text)
+ c:line?
+ (indentation c:line-indentation)
+ (text c:line-text))
+
+(define-guarantee c:line "C line")
+
+(define (c:line . items)
+ (c:%make-line 0 (apply string-append items)))
+
+(define (c:line-items items)
+ (if (pair? items)
+ (if (pair? (cdr items))
+ (apply string-append (map c:line-item items))
+ (c:line-item (car items)))
+ ""))
+
+(define (c:line-item item)
+ (cond ((string? item) item)
+ ((char? item) (string item))
+ ((symbol? item) (symbol-name item))
+ ((number? item) (number->string item))
+ ((decoded-time? item) (decoded-time->iso8601-string item))
+ ((not item) "false")
+ ((eq? item #t) "true")
+ (else (error:wrong-type-argument item "C line item" 'C:LINE-ITEM))))
+
+(define (c:make-line indentation text)
+ (c:%make-line (if (or (string-null? text)
+ (string-prefix? "#" text)
+ (string-prefix? "\f" text))
+ 0
+ indentation)
+ text))
+
+(define (c:write-line line port)
+ (let ((qr
+ (integer-divide (* (max 0 (c:line-indentation line))
+ c:indentation-delta)
+ c:indentation-tab-width)))
+ (let ((n (integer-divide-quotient qr)))
+ (do ((i 0 (+ i 1)))
+ ((not (< i n)))
+ (write-char #\tab port)))
+ (let ((n (integer-divide-remainder qr)))
+ (do ((i 0 (+ i 1)))
+ ((not (< i n)))
+ (write-char #\space port))))
+ (write-string (c:line-text line) port)
+ (newline port))
+
+(define c:indentation-delta 2)
+(define c:indentation-tab-width 8)
+
+(define (c:blank-line? line)
+ (string-null? (c:line-text line)))
+\f
+(define-record-type <c:group>
+ (c:%make-group lines)
+ c:group?
+ (lines c:group-lines))
+
+(define-guarantee c:group "C group")
+
+(define (c:group . items)
+ (c:group* items))
+
+(define (c:group* items)
+ (if (and (pair? items)
+ (c:group? (car items))
+ (null? (cdr items)))
+ (car items)
+ (c:make-group
+ (append-map (lambda (item)
+ (cond ((c:line? item) (list item))
+ ((c:group? item) (c:group-lines item))
+ ((not item) '())
+ (else (error:not-c:line item 'C:GROUP*))))
+ items))))
+
+(define c:make-group
+ (let ((empty (c:%make-group '())))
+ (lambda (lines)
+ (if (null? lines)
+ empty
+ (c:%make-group lines)))))
+
+(define (c:group-length group)
+ (length (c:group-lines group)))
+
+(define (c:indent . items) (c:indent* items))
+(define (c:exdent . items) (c:exdent* items))
+
+(define (c:indent* items) (c:%indent (c:group* items) 1))
+(define (c:exdent* items) (c:%indent (c:group* items) -1))
+
+(define (c:%indent item delta)
+ (let ((indent-line
+ (lambda (line)
+ (c:make-line (+ (c:line-indentation line) delta)
+ (c:line-text line)))))
+ (cond ((c:line? item)
+ (indent-line item))
+ ((c:group? item)
+ (c:make-group (map indent-line (c:group-lines item))))
+ (else
+ (error:not-c:line item 'C:%INDENT)))))
+
+(define (c:write-group group port)
+ (cond ((c:line? group) (c:write-line group port))
+ ((c:group? group)
+ (let loop ((lines (c:group-lines group)) (prev #f))
+ (if (pair? lines)
+ (let ((line (car lines))
+ (lines (cdr lines)))
+ (if (and (c:label-line? line)
+ (not (and prev
+ (or (c:label-line? prev)
+ (c:blank-line? prev)))))
+ (newline port))
+ (c:write-line line port)
+ (loop lines line)))))
+ (else (error:not-c:group group 'C:WRITE-GROUP))))
+
+(define (c:label-line? line)
+ (string-prefix? "DEFLABEL " (c:line-text line)))
+\f
+(define (c:comment . content)
+ (string-append "/* " (c:line-items content) " */"))
+
+(define (c:string . content)
+ (string-append "\"" (c:line-items content) "\""))
+
+(define (c:parens . content)
+ (string-append "(" (c:line-items content) ")"))
+
+(define (c:struct-init . exprs)
+ (string-append "{ " (c:comma-list exprs) " }"))
+
+(define (c:comma-list exprs)
+ (decorated-string-append "" ", " "" (map c:line-item exprs)))
+
+(define (c:hex n)
+ (string-append "0x" (number->string n 16)))
+
+(define (c:page)
+ (c:line "\f"))
+
+(define (c:brace-group . items)
+ (c:brace-group* items))
+
+(define (c:brace-group* items)
+ (c:group (c:line "{")
+ (c:indent* items)
+ (c:line "}")))
+
+(define (c:code-section . items) (apply c:ifndef "WANT_ONLY_DATA" items))
+(define (c:data-section . items) (apply c:ifndef "WANT_ONLY_CODE" items))
+
+(define (c:ifndef symbol . items)
+ (c:group (c:line "#ifndef " (c:var symbol))
+ (c:line)
+ (c:group* items)
+ (c:line)
+ (c:line "#endif " (c:comment "!" symbol))))
+
+(define (c:include name)
+ (c:line "#include "
+ (if (and (string-prefix? "<" name)
+ (string-suffix? ">" name))
+ name
+ (c:string name))))
+
+(define (c:define symbol val)
+ (c:line "#define " (c:var symbol) " " (c:expr val)))
+
+(define (c:fn static? rtype name adecls . items)
+ (c:group (c:line (if static? "static " "")
+ (c:type rtype))
+ (c:line name
+ " "
+ (if (null? adecls)
+ "(void)"
+ (c:parens
+ (c:comma-list (map (lambda (p)
+ (string-append (c:type (car p))
+ " "
+ (c:var (cdr p))))
+ adecls)))))
+ (c:brace-group* items)))
+\f
+(define (c:= var val) (c:line (c:expr var) " = " (c:expr val) ";"))
+(define (c:+= var val) (c:line (c:expr var) " += " (c:expr val) ";"))
+(define (c:-= var val) (c:line (c:expr var) " -= " (c:expr val) ";"))
+(define (c:*= var val) (c:line (c:expr var) " *= " (c:expr val) ";"))
+(define (c:/= var val) (c:line (c:expr var) " /= " (c:expr val) ";"))
+
+(define (c:goto label)
+ (c:line "goto " (c:var label) ";"))
+
+(define (c:label label)
+ (c:exdent (c:scall "DEFLABEL" label)))
+
+(define (c:return expr)
+ (c:line "return " (c:pexpr expr) ";"))
+
+(define (c:scall function . args)
+ (c:line (apply c:call function args) ";"))
+
+(define (c:ecall function . args)
+ (c:parens (apply c:call function args)))
+
+(define (c:call function . args)
+ (string-append (c:expr function)
+ " "
+ (let ((args (map c:expr args)))
+ (if (and (pair? args)
+ (null? (cdr args))
+ (c:%parenthesized? (car args)))
+ (car args)
+ (c:parens (c:comma-list args))))))
+
+(define (c:switch expr . cases)
+ (c:group (c:line "switch " (c:pexpr expr))
+ (c:indent (c:brace-group* cases))))
+
+(define (c:case tag . items)
+ (c:group (c:exdent
+ (c:line (if tag
+ (string-append "case " (c:line-item tag))
+ "default")
+ ":"))
+ (c:group* items)))
+
+(define (c:if-goto pred label)
+ (c:group (c:line "if " (c:pexpr pred))
+ (c:indent (c:goto label))))
+
+(define (c:while expr . body)
+ (c:group (c:line "while " (c:pexpr expr))
+ (c:indent (c:brace-group* body))))
+\f
+(define (c:cast type expr)
+ (let ((type (c:type type))
+ (expr (c:expr expr)))
+ (let ((p
+ (and (c:%decimal? expr)
+ (assoc type c:decimal-suffixes))))
+ (if p
+ (string-append expr (cdr p))
+ (string-append "((" type ") " expr ")")))))
+
+(define c:decimal-suffixes
+ '(("long" . "L")
+ ("unsigned" . "U")
+ ("unsigned long" . "UL")))
+
+(define (c:%decimal? e)
+ (let ((n (string-length e)))
+ (let loop
+ ((i
+ (if (or (string-prefix? "-" e)
+ (string-prefix? "+" e))
+ 1
+ 0)))
+ (if (fix:< i n)
+ (and (char-set-member? c:decimal-chars (string-ref e i))
+ (loop (fix:+ i 1)))
+ #t))))
+
+(define c:decimal-chars
+ (ascii-range->char-set (char->integer #\0)
+ (+ (char->integer #\9) 1)))
+
+(define (c:type type)
+ (or (and (symbol? type)
+ (let ((p (assq type type-abbrevs)))
+ (and p
+ (cdr p))))
+ (c:line-item type)))
+
+(define type-abbrevs
+ (let ((types
+ (let ((types '(char short int long float double)))
+ `(,@(map (lambda (t)
+ (cons t (symbol-name t)))
+ types)
+ ,@(map (lambda (t)
+ (cons (symbol 'u t)
+ (string-append "unsigned " (symbol-name t))))
+ types)
+ (sobj . "SCHEME_OBJECT")))))
+ `(,@types
+ ,@(map (lambda (p)
+ (cons (symbol (car p) '*)
+ (string-append (cdr p) " *")))
+ types))))
+
+(define (c:decl type var #!optional val)
+ (c:line (c:type type) " " (c:var var)
+ (if (default-object? val) "" (string-append " = " (c:expr val)))
+ ";"))
+
+(define (c:var item)
+ (cond ((string? item) item)
+ ((symbol? item) (symbol-name item))
+ (else (error:wrong-type-argument item "C variable" 'C:VAR))))
+
+(define (c:array-decl type name dim items)
+ (let ((lines (list-copy items)))
+ (if (pair? lines)
+ (let loop ((lines lines))
+ (if (pair? (cdr lines))
+ (begin
+ (set-car! lines (c:line (c:line-item (car lines)) ","))
+ (loop (cdr lines)))
+ (set-car! lines (c:line (c:line-item (car lines)))))))
+ (c:group (c:line (c:type type) " " (c:var name) " [" (c:expr dim) "] =")
+ (c:indent (c:group (c:line "{")
+ (c:indent (c:group* lines))
+ (c:line "};"))))))
+\f
+(define (c:expr expr)
+ (let ((expr (c:line-item expr)))
+ (if (or (c:%identifier? expr)
+ (string->number expr)
+ (c:%parenthesized? expr)
+ (and (string-prefix? "\"" expr)
+ (string-suffix? "\"" expr)))
+ expr
+ (string-append "(" expr ")"))))
+
+(define (c:pexpr expr)
+ (let ((expr (c:line-item expr)))
+ (if (c:%parenthesized? expr)
+ expr
+ (string-append "(" expr ")"))))
+
+(define (c:%identifier? e)
+ (let ((n (string-length e)))
+ (let loop ((i 0))
+ (if (fix:< i n)
+ (and (char-set-member? c:identifier-chars (string-ref e i))
+ (loop (fix:+ i 1)))
+ #t))))
+
+(define c:identifier-chars
+ (char-set-union (ascii-range->char-set (char->integer #\A)
+ (+ (char->integer #\Z) 1))
+ (ascii-range->char-set (char->integer #\a)
+ (+ (char->integer #\z) 1))
+ (ascii-range->char-set (char->integer #\0)
+ (+ (char->integer #\9) 1))
+ (char-set #\_)))
+
+(define (c:%parenthesized? e)
+ (and (string-prefix? "(" e)
+ (string-suffix? ")" e)))
+
+(define (c:predec expr)
+ (string-append "--" (c:expr expr)))
+
+(define (c:preinc expr)
+ (string-append "++" (c:expr expr)))
+
+(define (c:postdec expr)
+ (string-append (c:expr expr) "--"))
+
+(define (c:postinc expr)
+ (string-append (c:expr expr) "++"))
+
+(define (c:aref array index)
+ (string-append "(" (c:expr array) " [" (c:expr index) "])"))
+
+(define (c:aptr array index)
+ (c:& (c:aref array index)))
+
+(define (c:?: a b c . rest)
+ (apply string-append
+ "("
+ (c:expr a)
+ " ? "
+ (c:expr b)
+ " : "
+ (c:expr c)
+ (let loop ((exprs rest))
+ (if (pair? exprs)
+ (begin
+ (if (not (pair? (cdr exprs)))
+ (error "C:?: requires even number of args."))
+ (cons* " ? "
+ (c:expr (car exprs))
+ " : "
+ (c:expr (cadr exprs))
+ (loop (cddr exprs))))
+ (list ")")))))
+\f
+(define (c:unary op a)
+ (string-append "(" (c:line-item op) " " (c:expr a) ")"))
+
+(define (c:! a)
+ (c:unary "!" a))
+
+(define (c:~ a)
+ (c:unary "~" a))
+
+(define (c:binary-infix op a b)
+ (string-append "(" (c:expr a) " " (c:line-item op) " " (c:expr b) ")"))
+
+(define (c:== a b)
+ (c:binary-infix "==" a b))
+
+(define (c:!= a b)
+ (c:binary-infix "==" a b))
+
+(define (c:> a b)
+ (c:binary-infix ">" a b))
+
+(define (c:>= a b)
+ (c:binary-infix ">=" a b))
+
+(define (c:< a b)
+ (c:binary-infix "<" a b))
+
+(define (c:<= a b)
+ (c:binary-infix "<=" a b))
+
+(define (c:\| a b)
+ (c:binary-infix "|" a b))
+
+(define (c:^ a b)
+ (c:binary-infix "^" a b))
+
+(define (c:&~ a b)
+ (c:binary-infix "&~" a b))
+
+(define (c:/ a b)
+ (c:binary-infix "/" a b))
+
+(define (c:<< a b)
+ (c:binary-infix "<<" a b))
+
+(define (c:>> a b)
+ (c:binary-infix ">>" a b))
+
+(define (c:ubinary op a b)
+ (if (default-object? b)
+ (c:unary op a)
+ (c:binary-infix op a b)))
+
+(define (c:& a #!optional b)
+ (c:ubinary "&" a b))
+
+(define (c:* a #!optional b)
+ (c:ubinary "*" a b))
+
+(define (c:+ a #!optional b)
+ (c:ubinary "+" a b))
+
+(define (c:- a #!optional b)
+ (c:ubinary "-" a b))
+
+(define (c:make-object type datum)
+ (c:ecall "MAKE_OBJECT" type datum))
+
+(define (c:make-pointer-object type address)
+ (c:ecall "MAKE_POINTER_OBJECT" type address))
+
+(define (c:object-type expr)
+ (c:ecall "OBJECT_TYPE" expr))
+
+(define (c:object-datum expr)
+ (c:ecall "OBJECT_DATUM" expr))
+
+(define (c:object-address expr)
+ (c:ecall "OBJECT_ADDRESS" expr))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: lapgen.scm,v 1.20 2006/10/01 05:38:02 cph Exp $
+$Id: lapgen.scm,v 1.21 2006/10/08 01:27:59 cph Exp $
Copyright 1993,1998,2001,2002,2004,2006 Massachusetts Institute of Technology
(define (c:cptr index)
(c:aptr 'current_block index))
-
-(define (c:make-object type datum)
- (c:ecall "MAKE_OBJECT" type datum))
-
-(define (c:make-pointer-object type address)
- (c:ecall "MAKE_POINTER_OBJECT" type address))
-
-(define (c:object-type expr)
- (c:ecall "OBJECT_TYPE" expr))
-
-(define (c:object-datum expr)
- (c:ecall "OBJECT_DATUM" expr))
-
-(define (c:object-address expr)
- (c:ecall "OBJECT_ADDRESS" expr))
\f
;;;; Constants, Labels, and Various Caches
projects / mit-scheme.git / commitdiff