* c and scheme
@ 2011-04-14 18:19 Stefan Israelsson Tampe
0 siblings, 0 replies; only message in thread
From: Stefan Israelsson Tampe @ 2011-04-14 18:19 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1.1: Type: text/plain, Size: 1620 bytes --]
Here is a fun play with scheme and the fmt library. (make sure to add the
correct import path in the file)
I did a small discussion on this at http://www.advogato.org/person/tampe/
Anyway with this you can do,
(clambda->c
(<define> (int f) ((int a))
(<recur> loop ((int x a) (int s 0))
(<if> (<==> x 0)
s
(<next> loop (<-> x 1) (<+> s 314))))))
that executes (urk) to,
$1 = "int f (int a) {
{
int ret2603;
{
int x;
x = a;
int s;
s = 0;
loop:
{
int pred2604;
{
int x2605;
int y2606;
x2605 = x;
y2606 = 0;
pred2604 = x2605 == y2606;
}
if (pred2604) {
ret2603 = s;
} else {
{
{
int x2607;
int y2608;
x2607 = x;
y2608 = 1;
x = x2607 - y2608;
}
{
int x2609;
int y2610;
x2609 = s;
y2610 = 314;
s = x2609 + y2610;
}
goto loop;
}
}
}
}
return ret2603;
}
}
"
Have fun
/Stefan
[-- Attachment #1.2: Type: text/html, Size: 1960 bytes --]
[-- Attachment #2: clambda2.scm --]
[-- Type: text/x-scheme, Size: 7075 bytes --]
(define-module (language clambda clambda2)
#:use-module (ice-9 match )
#:use-module (language clambda clambda-meta )
#:use-module (language clambda meta )
#:use-module (language clambda fmt )
#:export (clambda->c *debug-clambda* f-define f-sub f-let* f-if
z f-begin f-call f-recur f-next <=> <==> <recur> <next> <call> <+> <-> <*> </>
q< q> q<= q>= <and> <or> <!=> <bit-and> <bit-or>
<bit-xor> <define> <if> <let*> <begin>
))
;; ********************* TOOLBOX ********************
(define-syntax auto-quote
(lambda (x)
(syntax-case x ()
((_ a)
(let ((v (syntax->datum #'a)))
(if (symbol? v)
#'(quote a)
#'a))))))
(define-syntax auto
(syntax-rules ()
((_ (a ...)) (a ...))
((_ a ) (z (auto-quote a)))))
(define (my-block . a)
(if (> (length a) 1)
(apply c-block `(,fmt-null ,@a))
(car a)))
(define old-pk pk)
(define *debug-clambda* #t)
(define pk (lambda (x)
(if *debug-clambda* (old-pk x) x)))
(define void-it (lambda (c) (c #f)))
(define (z x)
(lambda (v)
(match v
(#f x)
(v (c= v x)))))
(define (z-2 x)
(match x
((_ _) x)
(x `(SCM ,x))))
(define (z-3 x)
(match x
((_ _ _) x)
((s v) `(SCM ,s ,v))))
(define (clambda->c x)
(fmt #f
(fmt-let 'braceless-bodies? #f
x)))
;; ********************************** DEFINE/SUB *************************
(define (f-define f args . code)
(define function-type car)
(define function-sym cadr)
(let ((r (gensym "ret")))
(let* ((f (z-2 f))
(args (map z-2 args))
(ts (map car args)))
(c-fun (function-type f)
(function-sym f)
args
(my-block
(c-var (function-type f) r)
((apply f-begin code) r)
r)))))
(define-syntax <define>
(syntax-rules ()
((_ f (a ...) code ...)
(let ((fq (farg f))
(aq (list (farg a) ...)))
(set-symbol-property! (cadr fq) 'fkn-signature (map car aq))
(f-define fq aq (auto code) ...)))))
(define-syntax farg
(syntax-rules ()
((_ (t a)) '(t a))
((_ a ) '(SCM a))))
(define (f-sub f args . code)
(define function-type car)
(define function-sym cadr)
(let ((f (z-2 f))
(args (map z-2 args)))
(c-fun (function-type f)
(function-sym f)
args
((apply f-begin code) #f))))
#|
(f-define '(int f) '((int a)) code ...)
|#
;; ************************************ BEGIN *************************
(define (f-begin . a)
(lambda (v)
(if v
(match a
((a ... b)
(apply my-block `(,@(map void-it a) ,(b v)))))
(apply my-block (map void-it a)))))
(define-syntax <begin>
(syntax-rules ()
((_ a ...) (f-begin (auto a) ...))))
;; ************************************** if *************************
(define (f-if p x y)
(lambda (v)
(let ((pred (gensym "pred")))
(my-block
(c-var 'int pred)
(p pred)
(c-if pred (x v) (y v))))))
(define-syntax <if>
(syntax-rules ()
((_ p x y) (f-if (auto p) (auto x) (auto y)))))
;; ************************************** let* ***********************
(define (f-let* vars . code)
(lambda (v)
(define (f x)
(match x
((t s v) (c-var t s))))
(define (g x)
(match x
((t s v) (v s))))
(define (mk-vars x)
(match x
((x . l) `(,(f x) ,(g x) ,@(mk-vars l)))
(() '())))
(apply my-block `(,@(mk-vars (map z-3 (pk vars))) ,((apply f-begin code) v)))))
(define-syntax <let*>
(syntax-rules ()
((_ (v ...) code ...) (f-let* `(,(leta v) ...) code ...))))
(define-syntax leta
(syntax-rules ()
((_ a v) (z-3 (list 'a (auto v))))
((_ t a v) (z-3 (list 't 'a (auto v))))))
;; ************************************** call *******************
(define (f-call0 f ts arg)
(pk ts)
(pk arg)
(lambda (v)
(let* ((vl (map (lambda (x) (gensym "a")) ts))
(defs (map (lambda (s t) (c-var t s)) vl ts))
(sets (map (lambda (s a) (a s)) vl arg)))
(if v
(apply my-block `(,@defs ,@sets ,(c= v `(,f ,@vl))))
(apply my-block `(,@defs ,@sets `(,f ,@vl)))))))
(define (f-call f . a) (f-call0 f (symbol-property f 'fkn-signature) a))
(define-syntax <call>
(syntax-rules ()
((_ f a ...)
(f-call (auto f) (auto a) ...))))
;; ************************************** recur *******************
; TAIL CALL VERSION ONLY
(define-syntax <recur>
(syntax-rules ()
((_ sym ((a ...) ...) code ...)
(f-recur 'sym (list (leta a ...) ...) (auto code) ...))))
(define-syntax f-recur
(syntax-rules ()
((_ sym vars code ...)
(begin
(set-symbol-property! sym 'recur (map cadr (map z-3 vars)))
(f-recur0 sym vars code ...)))))
(define (f-recur0 sym vars . code)
(lambda (v)
(define (f x)
(match x
((t s v) (c-var t s))))
(define (g x)
(match x
((t s v) (v s))))
(define (mk-vars x)
(match x
((x . l) `(,(f x) ,(g x) ,@(mk-vars l)))
(() '())))
(apply my-block `(,@(mk-vars (map z-3 vars))
,(c-label sym)
,((apply f-begin code) v)))))
(define-syntax <next>
(syntax-rules ()
((_ sym a ...)
(f-next 'sym (auto a) ...))))
(define (f-next sym . as)
(lambda (v)
(let ((ss (symbol-property sym 'recur)))
(apply my-block
`(,@(map (lambda (a s) (a s)) as ss)
,(c-goto sym))))))
;; ************************************** binop *******************
(define-syntax mk-op-2
(syntax-rules ()
((_ op cop)
(define-syntax op
(syntax-rules ()
((_ op t x y)
(lambda (v)
(let ((xx (gensym "x"))
(yy (gensym "y")))
(my-block
(c-var (auto t) xx)
(c-var (auto t) yy)
((auto x) xx)
((auto y) yy)
(c= v (cop xx yy))))))
((_ x y)
(lambda (v)
(let ((xx (gensym "x"))
(yy (gensym "y")))
(my-block
(c-var 'int xx)
(c-var 'int yy)
((auto x) xx)
((auto y) yy)
(c= v (cop xx yy)))))))))))
(mk-op-2 <=> c= )
(mk-op-2 <!=> c!= )
(mk-op-2 <==> c== )
(mk-op-2 <+> c+ )
(mk-op-2 <-> c- )
(mk-op-2 <*> c* )
(mk-op-2 </> c/ )
(mk-op-2 <and> c&& )
(mk-op-2 <or> c-or )
(mk-op-2 <bit-and> c& )
(mk-op-2 <bit-or> c-bit-or)
(mk-op-2 <bit-xor> c^ )
(mk-op-2 q< c< )
(mk-op-2 q> c> )
(mk-op-2 q<= c<= )
(mk-op-2 q>= c>= )
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2011-04-14 18:19 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-04-14 18:19 c and scheme Stefan Israelsson Tampe
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).