; cat-primitive instructions
(define (cat-pop s) (cdr s))
(define (cat-dup s) (cons (car s) s))
(define (cat-swap s) (cons (cadr s) (cons (car s) (cddr s))))
(define (cat-apply s) (apply (car s) (list (cdr s))))
(define (cat-unit s) (cons (list (car s)) (cdr s)))
(define (cat-cat s) (cons (append (cadr s) (car s)) (cddr s)))
(define (cat-quote s) (cons (lambda (x) (cons (car s) x)) (cdr s)))
(define (cat-car s) (cons (car s) s))
(define (cat-cdr s) (cons (cdr s) s))
(define (cat-compose s) (cons (lambda (x) (apply (cadr s) (list (apply
(car s) (list x))))) (cddr s)))
(define (cat-add s) (cons (+ (car s) (cadr s)) (cddr s)))

; used for literals
(define (make-literal x) (lambda (s) (cons x s)))
(define (make-quotation x) (lambda (s) (cat-eval x s)))

; convert a Cat program into a list of function calls
(define (cat-compile p)
  (map
   (lambda (x)
     (cond
       ((procedure? x)
        x)
       ((pair? x)
        (make-quotation (cat-compile x)))
       (else
        (make-literal x))))
   p))

; run a compiled Cat program on a particular stack
(define (cat-eval p s)
  (if (null? p)
      s
      (cat-eval (cdr p) (apply (car p) (list s)))))

; run a Cat program
(define (cat-main p) (cat-eval (cat-compile p) (list)))

; tests
(define t0 (cat-main (list 1 2 3)))
(define t1 (cat-main (list '(1) 2 3)))
(define t2 (cat-main (list 1 cat-dup)))
(define t3 (cat-main (list 1 2 cat-swap)))
(define t4 (cat-main (list 1 2 cat-pop)))
(define t5 (cat-main (list 1 cat-quote)))
(define t6 (cat-main (list 1 cat-quote cat-apply)))
(define t7 (cat-main (list 1 cat-quote 2 cat-quote cat-compose cat-
apply)))

; There is probably a better way to define these using function
(define inc (cat-compile (list 1 cat-add)))
(define dip (list cat-swap cat-quote cat-compose cat-apply))

(define t8 (cat-main (list 41 inc)))
(define t9 (cat-main (list 1 3 5 (list cat-add) dip)))

;; This converts a single cat command into a Stack -> Stack
transformation
;; The implementation of these transformations are based pretty much
on
;; code from the last post
(define-syntax cat-cmd
  (syntax-rules (pop dup swap apply unit cat quote car cdr compose
add)
    ((_ pop)     cdr)
    ((_ dup)     (lambda (s) (cons (car s) s)))
    ((_ swap)    (lambda (s) (cons (cadr s) (cons (car s) (cddr s)))))
    ((_ apply)   (lambda (s) (apply (car s) (list (cdr s)))))
    ((_ unit)    (lambda (s) (cons (list (car s)) (cdr s))))
    ((_ cat)     (lambda (s) (cons (append (cadr s) (car s)) (cdr
s))))
    ((_ quote)   (lambda (s) (cons (lambda (x) (cons (car s) x)) (cdr
s))))
    ((_ car)     (lambda (s) (cons (car s) s)))
    ((_ cdr)     (lambda (s) (cons (cdr s) s)))
    ((_ compose) (lambda (s) (cons (lambda (x) (apply (cadr s)
                                                      (list (apply
(car s) (list x)))))
                                   (cddr s))))
    ((_ add)     (lambda (s) (cons (+ (car s) (cadr s)) (cddr s))))
    ((_ (cmds ...)) (cat cmds ...))
    ((_ other)   (lambda (s)
                   (cond
                     ((procedure? other) (other s))
                     (#t                 (cons other s)))))))

;; This converts a series of cat commands into a single Stack -> Stack
transform
;; by threading the stack through all of the commands
;; This serves to 'compile' the program into a scheme lambda, that can
then be
;; optimized by the underlying implementation
(define-syntax cat
  (syntax-rules ()
    ((_ cmd)
     (cat-cmd cmd))
    ((_ cmd cmds ...)
     (lambda (s)
        ((cat cmds ...) ((cat-cmd cmd) s))))))

;; Defines a new top level procedure that operates on stacks, for
instance:
;; > (cat-define inc  (1 add))
(define-syntax cat-define
  (syntax-rules ()
    ((_ name (prog ...))
     (define name (cat prog ...)))))

;; Runs a cat program on the empty list.  Use:
;; > (cat-main 1 quote 2 quote compose apply)
;; (1 2)
(define-syntax cat-main
  (syntax-rules ()
    ((_ prog ...)
     ((cat prog ...) (list)))))

;; Some simple tests
(cat-define inc (1 add))  ;; We can define a function
(cat-main (41 inc))        ;; We can invoke cat code
(inc (list 5))                  ;; We can use the function in Scheme!

 i spent much of my summer trying to implement my compositional language
as (plt) scheme macros. (my cat is now called basecat due to an unfortunate
name clash. basecat is similar to christopher's cat, except that it's
dynamicly
typed, and used mostly as an intermediate representation in a forth
compiler)

i came to the following conclusions:

- macros written in syntax-rules cannot be composed, unless they are written

  in some form of CPS. i found out that using CPS makes them also very slow.
  implementing a dsl tends to scream for macro composition at some point.

- the alternative is to use syntax-case, which is now part of the new scheme
standard.
  this allows you to still be hygienic, but makes it easier to factor the
macro transformer
  into independent parts which are scheme code, making it easier for the
little language
  to grow.

- i see no reason for operating on a single function argument as a stack,
because
  you loose a simple notational device:
  (lambda (a b . s) (cons (+ a b) s)) is really equivalent to
  (lambda args (cons (+ (car args) (cadr args)) (caddr args)))

- it is easy to automate the 'snarfing': automaticly translate scheme
primitives to cat primitives.

- i'm not sure if it's standard, but in mzscheme (part of plt scheme) you
can distinguish
  between lexical and global/module variables in syntax-case macros. this
allows a tight
  mixing of scheme and cat code that allows you to use closures. closures
are something
  i really miss in compositional languages, so i've opted for a solution
that at least allows me
  to use it in the implementation of the language, with the possibility to
simple extend the cat
  syntax if i ever need it.

- an open question is if it makes sense to implement the variable passing
using 'values', or
  some other approach that avoids consing every time a primitive is
executed. maybe a linear
  stack (i.e. baker's linear lisp) that is copied whenever it is somehow
frozen might be a
  good idea.

since i know there are at least 2 people now interested in doing cat in
scheme, why don't
we work together a bit more? i feel i already solved a lot of problems in
the path i've traveled,
and while i very much understand the necessity of re-inventing the wheel as
a learning
experience, i'm more interested now in combining (christopher's) cat's type
system with my
language core.

( another thing to mention is that i'm really interested in implementing a
linear functional
compositional language. i've been working on Packet Forth (PF) for a couple
of years now,
and part of what i'm doing with Brood is to do PF right. PF is 'almost
linear'. It still uses pointers
that need to be explicitly managed. The thing that really would make things
fly is to make it
linear, and typed, mostly aiming at efficient compilation. )

i don't have a lot of promo material, but here are the links to the darcs
archives:

http://darcs.goto10.org/packetforth/
http://darcs.goto10.org/brood/

each of them has a 'doc/ramblings.txt' which contains most of my not so
eloquently expressed ideas.

i'm working on a paper for Brood, but i'm a bit stuck at... types :)
the draft of the paper is here:
http://darcs.goto10.org/brood/tex/brood.pdf

Welcome aboard, thanks a lot for sharing your macros with us!

I can't really provide any meaningful comments on them, since I am a
very new to programming with Scheme, but I look forward to hearing
other people's comments. I will show them to some colleagues and
hopefully I will get some useful feedback  that I can share with you.

- Christopher

On 9/15/07, Ben Chambers <bjchamb...@gmail.com> wrote:

Then I decided to start playing with more efficient ways of doing
things.  The implementation behind Chicken Scheme (Cheney on the MTA)
should be able to perform some of the stuff in registers (I think)
because it won't immediately cons arguments.  I use improper argument
lists to pull things off the stack, which in theory is a bit easier.

Unfortunately, the new version will only run on chicken-scheme because
it uses the environment extension to let me tell the difference
between a primitive and something that has been defined.  Basically, a
primitive is just a function that gets put in the primitive
environment, and all the primitives actually execute immediately when
their seen.  Other functions get put on the top of the stack and won't
run until apply.

I think this provides an interesting comparison to the older
implementation.  I'll also be interested in seeing how efficient this
version is compared to some of the other implementations available.

(require-extension syntax-case)
(require-extension environments)
(use test)

(define-syntax compose-reverse-help
 (syntax-rules ()
  ((_ args f)
   (apply f args))
  ((_ args f g ...)
   (compose-reverse-help (apply f args) g ...))))

;; Compose backwards:
;; (compose-reverse f g) = (g (f ...))
(define-syntax compose-reverse
 (syntax-rules ()
  ((_ f ...)
   (lambda args (compose-reverse-help args f ...)))))

;; An environment containing all the primitives that we've defined
(define cat-primitives (make-environment))

;; A definition of the valid primitives
(define (valid-primitive? prim)
 (environment-has-binding? cat-primitives prim))

;; Convert a single expression into a function
;; TODO: I'd like to convert this to syntax-case and put the valid-
primitive?
;; as the fender, but unfortunately the environment stuff doesn't seem
to be
;; usable in macros
(define-syntax cat-cmd
 (syntax-rules ()
  ((_ (x ...)) (lambda s (cons (cat-compile x ...) s)))
  ((_ x)
   (if (and (symbol? 'x) (valid-primitive? 'x))
    (environment-ref cat-primitives 'x)
    (lambda s (cons x s))))))

;; Convert into a cat-expression
(define-syntax cat-compile
 (syntax-rules ()
   ((_ exps ...)
    (compose-reverse (cat-cmd exps) ...))))

;; Macro for defining a new cat-primitive.  Ideally I wouldn't have
;; to pass the env in, but that would violate hygiene, and I'm not
sure
;; how to do that using syntax-rules.
(define-syntax cat-prim
 (syntax-rules (=>)
  ;; This syntax is kind of the most general -- lets them specify
  ;; an arbitrary scheme vararg expression
  ((_ env prim definition)
   (environment-extend! env 'prim definition))
  ;; This syntax allows them to specify only the arguments they need
  ;; and automatically adds it to the front of the list, also binds
  ;; top to the value on top of the stack
  ((_ env prim (args ...) top => definition ...)
   (cat-prim env prim
    (lambda (args ... . s)
     (let ((top (car s)))
       (append (reverse (list definition ...)) s)))))
  ;; This syntax allows them to specify only the arguments they need
  ;; and automatically adds it to the front of the list
  ((_ env prim (args ...) => definition ...)
   (cat-prim env prim
    (lambda (args ... . s)
       (append (reverse (list definition ...)) s))))))

;; A macro for defining a bunch of primitives
(define-syntax cat-prims
 (syntax-rules ()
  ((_ env (prim ...) ...)
   (begin
    (cat-prim env prim ...) ...))))

;; Rename apply for running cat expressions
(define run-cat apply)

;; Add the level-0 primitives
(cat-prims cat-primitives
 (add_int (x y) => (+ x y))
 (swap    (x y) => x y)
 (dup     () x  =>  x)
 (apply   (lambda (proc . s) (run-cat proc s))))

;; Run cat expression on the empty list
(define-syntax cat-main
 (syntax-rules ()
  ((_ exp ...)
   (run-cat (cat-compile exp ...) ()))))

;; Macro for defining test cases
;; usage: (cat-test (expected list) (cat expressions))
(define-syntax cat-test
 (syntax-rules (=>)
  ((_ (cat ...) => (exp ...))
   (test (list exp ...) (cat-main cat ...)))))

;; Tests for each of the individual operations
(cat-test (8 5) => (5 8))
(cat-test (8 5 swap) => (8 5))
(cat-test (8 dup) => (8 8))
(cat-test (8 5 add_int) => (13))
(cat-test ((8 5 add_int) apply) => (13))

On Sep 16, 7:31 am, "Tom Schouten" <tom.goto10....@gmail.com> wrote:

Can anyone confirm that this is a bug?

On Sep 25, 8:58 am, "Tom Schouten" <tom.goto10....@gmail.com> wrote:

(P.S if anyone cares to see my implementation of everything, just ask
and I'll post it.  My next game is going to be adding the IO stuff
from the later levels, and then toying around with type systems).

There are 150 lines of tests (all of the unit tests from levels 0 and
1), 75 lines of glue code that describe how to define new primitives
and stitch them together, and 130 lines defining all the primitives
(most primitives are one line each).

-- Ben Chambers

On Sep 25, 2:27 pm, Ben  Chambers <bjchamb...@gmail.com> wrote:

On 9/25/07, Ben Chambers <bjchamb...@gmail.com> wrote: