# $Id: Imakefile,v 1.7 1993/03/14 10:41:43 queinnec Exp $
# This Makefile tests Meroonet with various implementations. It gives some
# examples of how to define the define-meroonet-macro macro for various 
# implementations.

work : test.elk

clean :: cleanMakefile
	-rm TAGS
clean.all : clean
	-rm -rf o meroonet*.tar.Z 
tags : ;	etags -t meroonet.scm
TIME	= /usr/local/bin/time

SOURCES	= 	Notice 		\
		Imakefile 	\
		meroonet.scm

tar.Z : ${SOURCES}
	tar -cvf meroonet.tar ${SOURCES} variante*.scm
	compress meroonet.tar
	mv meroonet.tar.Z `date +meroonet%y%h%d.tar.Z`

tests : 	test.elk 	\
		test.sci 	\
		test.bigloo 	\
		test.scc 	\
		meroonet.tar.Z	\
		variantes

########################################################################## Elk
# Redefined list-tail since (list-tail '(a b) 11) -> () in Elk 2.0
test.elk :
	echo "						\
(define-macro (define-meroonet-macro call . body)	\
  \`(define-macro ,call . ,body) )			\
(define gensym						\
  (let ((counter 99))					\
    (lambda () 						\
      (set! counter (+ 1 counter))			\
      (string->symbol 					\
       (string-append \"G\" 				\
                      (number->string counter) ) ) ) ) )\
(load \"../tester.scm\")				\
(load \"meroonet.scm\")					\
(define (list-tail l n)					\
  (if (> n 0)						\
      (if (pair? l)					\
          (list-tail (cdr l) (- n 1))			\
          (error-handler 'list-tail) )			\
      l ) )						\
(define (test-oo file)					\
  (suite-test 						\
   file \"?? \" \"== \" #t				\
   (lambda (read check err)				\
     (set! error-handler err)				\
     (lambda ()						\
       (check (eval (read) top-level-environment)) ) )	\
   equal? ) )						\
(define the-Point 'wait)				\
(test-oo \"oo-tests.scm\")"			| ${TIME} elk -h 2000

######################################################################### sci
test.sci :
	echo "							\
(define-macro define-meroonet-macro				\
  (lambda (e m)							\
    (define (map-arguments variables parameters)		\
      (cond ((pair? variables)					\
             (cons \`( ,(car variables) (car ,parameters) )	\
                   (map-arguments (cdr variables) 		\
                                  \`(cdr ,parameters) ) ) )	\
            ((symbol? variables)				\
             (list \`( ,variables ,parameters )) )		\
            ((null? variables) '()) ) )				\
    (let* ((call (cadr e))					\
           (body (cddr e))					\
           (s2c-expander 					\
            \`(lambda (e m)					\
                (m (let ,(map-arguments (cdr call) '(cdr e))	\
                     . ,body ) m) )) )				\
       (m \`(define-macro ,(car call) ,s2c-expander) m) ) ) )	\
(define call/cc call-with-current-continuation)			\
(load \"../tester.scm\")					\
(load \"meroonet.scm\")						\
(define (test-oo file)						\
  (suite-test 							\
   file \"?? \" \"== \" #t					\
   (lambda (read check err)					\
     (lambda ()							\
       (set! *error-handler* err)				\
       (check (eval (read))) ) )				\
   equal? ) )							\
(test-oo \"oo-tests.scm\")"				| /usr/local/bin/sci

######################################################################### scc
#   In this test we compile Meroonet and link it to an interpreter where the
# three Meroonet macros can be used. Observe how is defined the macro
# define-meroonet-macro to create pervasive macros.
#   The main program is an example of a program that needs Meroonet to be
# compiled so a third definition of define-meroonet-macro is provided. It
# allows to expand calls to the three Meroonet macros. Of course the resulting
# .o file must be linked with the meroonet.o file to work. In fact a lot
# of functions of Meroonet are just needed at macroexpansion time that could
# be removed from run-time but they are leaved in place so meroonet.o can
# be used to generate interpreters.
#CC		= gcc
CFLAGS          = -O ${SCCsubCFLAGS} 
SCCFLAGS        = -sch 12 ${CFLAGS}
#SCCDIR is the repertory where are the files needed by scc
#SCCDIR		= /usr/local/lib/schemetoc
#HOSTTYPE is the type of your machine (automatically set up for you by tcsh)
#HOSTTYPE	= news_mips
#SCCsubCFLAGS are the flags needed by the C compiler when invoked by scc.
#SCCsubCFLAGS    = -Dsony_news -DSONYNEWS -Ur3000
mkdir :
	-mkdir o
	-mkdir o/${HOSTTYPE}
test.scc : mkdir
	${MAKE} ${MAKEFLAGS} o/${HOSTTYPE}/test
	o/${HOSTTYPE}/test
o/${HOSTTYPE}/test.sc :
	echo "							\
(module test (main start) (with s2cfun tester meroonet))	\
(define-macro hack						\
  (lambda (e m)							\
    (define-macro define-meroonet-macro				\
      (lambda (e m)						\
        (define (map-arguments variables parameters)		\
          (cond							\
            ((pair? variables)					\
             (cons \`( ,(car variables) (car ,parameters) )	\
                   (map-arguments (cdr variables) 		\
                                  \`(cdr ,parameters) ) ) )	\
            ((symbol? variables)				\
             (list \`( ,variables ,parameters )) )		\
            ((null? variables) '()) ) )				\
        (let* ((call (cadr e))					\
               (body (cddr e))					\
               (s2c-expander 					\
                \`(lambda (e m)					\
                    (m (let ,(map-arguments (cdr call) 		\
                                            '(cdr e) )		\
                         . ,body ) m) )) )			\
          (putprop (car call) 'scc				\
            (list (cons 'macro (eval s2c-expander))) )		\
          ''void ) ) )						\
    (loadq \"../../meroonet.scm\")				\
    ''hack ) )							\
(hack)								\
								\
(define-class Point Object (x y))				\
(define-generic (x (o)))					\
(define-method (x (o Point)) (Point-x o))			\
(display (x (make-Point 11 22)))				\
								\
(define (test-oo file)						\
  (suite-test 							\
   file \"?? \" \"== \" #t					\
   (lambda (read check err)					\
     (lambda ()							\
       (set! *error-handler* err)				\
       (check (eval (read))) ) )				\
   equal? ) )							\
(define meroonet-error 33)					\
(define (start) 						\
  (test-oo \"oo-tests.scm\") )" 		> o/${HOSTTYPE}/test.sc
o/${HOSTTYPE}/test : o/${HOSTTYPE}/test.sc o/${HOSTTYPE}/meroonet.o
	cd o/${HOSTTYPE} ; scc -o test ${SCCFLAGS} test.sc \
		meroonet.o ${HOME}/s2c/o/${HOSTTYPE}/libqnc.a

# the call to read-eval-print forces expand and define-macro 
# to be present at run-time.
o/${HOSTTYPE}/meroonet.sc : meroonet.scm
	echo "							\
(module meroonet)						\
(lambda () (read-eval-print))					\
(define-macro define-meroonet-macro				\
  (lambda (e m)							\
    (define (map-arguments variables parameters)		\
      (cond ((pair? variables)					\
             (cons \`( ,(car variables) (car ,parameters) )	\
                   (map-arguments (cdr variables) 		\
                                  \`(cdr ,parameters) ) ) )	\
            ((symbol? variables)				\
             (list \`( ,variables ,parameters )) )		\
            ((null? variables) '()) ) )				\
    (let* ((call (cadr e))					\
           (body (cddr e))					\
           (s2c-expander 					\
            \`(lambda (e m)					\
                (m (let ,(map-arguments (cdr call) '(cdr e))	\
                     . ,body ) m) )) )				\
       (m \`(eval '(define-macro ,(car call) 			\
                                 ,s2c-expander )) m) ) ) )	\
(include \"../../meroonet.scm\")"	> o/${HOSTTYPE}/meroonet.sc
# These two entries can also be written in a single one as in
#o/${HOSTTYPE}/meroonet.o : o/${HOSTTYPE}/meroonet.sc
#	cd o/${HOSTTYPE} ; scc -c ${SCCFLAGS} meroonet.sc
# but this consumes more memory than I have so I break it into two processes:
o/${HOSTTYPE}/meroonet.c : o/${HOSTTYPE}/meroonet.sc
	cd o/${HOSTTYPE} ; scc -C ${SCCFLAGS} meroonet.sc
o/${HOSTTYPE}/meroonet.o : o/${HOSTTYPE}/meroonet.c
	cd o/${HOSTTYPE} ; ${CC} -c ${CFLAGS} -I${SCCDIR} meroonet.c
clean ::
	-rm o/${HOSTTYPE}/

###################################################################### Bigloo
BIGLOOFLAGS	= -O 
#BIGLOO		= bigloo
BIGLOO	= /home/cornas/icsla/serrano/prgm/project/bigloo/bin/bigloo
# Bigloo is available from ftp.inria.fr:INRIA/icsla
test.bigloo.i :
	echo "							\
(define-macro (define-meroonet-macro call . body)		\
  \`(define-macro ,call . ,body) )				\
(define-meroonet-macro (unless condition . body)		\
  \`(if ,condition #f (begin . ,body)) )			\
(define-meroonet-macro (when condition . body)			\
  \`(if ,condition (begin . ,body)) )				\
(load \"../tester.scm\")					\
(load \"meroonet.scm\")						\
(define (test-oo file)						\
  (suite-test 							\
   file \"?? \" \"== \" #t					\
   (lambda (read check err)					\
     (lambda ()							\
       (try (check (eval (read)))				\
            (lambda (k a b c) (err a b c) ) ) ) )		\
   equal? ) )							\
(define the-Point 'wait)					\
(test-oo \"oo-tests.scm\")"				| ${BIGLOO} -i

test.bigloo.c : mkdir
	${MAKE} ${MAKEFLAGS} o/${HOSTTYPE}/bgl-test
	o/${HOSTTYPE}/bgl-test 

o/${HOSTTYPE}/meroonet.bgl : meroonet.scm 
	( echo "						\
(module meroonet						\
  (export meroonet-error *last-defined-class*			\
          (->Class name)					\
          (->Generic name)					\
          (object->class o)					\
          (Object? o)						\
          (is-a? o class)					\
          (field-value o field . i)				\
          (set-field-value! o v field . i)			\
          (field-length o field)				\
          (Field-defining-class field)				\
 Object-class Class-class Generic-class				\
 Field-class Mono-Field-class Poly-Field-class			\
          Class? Generic? Field? Mono-Field? Poly-Field?	\
 make-Class allocate-Class Class-name set-Class-name!		\
 Class-number set-Class-number! Class-fields set-Class-fields!	\
 Class-super-class set-Class-super-class! 			\
 Class-subclass-numbers set-Class-subclass-numbers!		\
 make-Generic allocate-Generic Generic-name set-Generic-name!	\
 Generic-default set-Generic-default! 				\
 Generic-dispatch-table set-Generic-dispatch-table!		\
 Field-name set-Field-name! Field-defining-class-number		\
 set-Field-defining-class-number! 				\
 make-Mono-Field allocate-Mono-Field				\
 make-Poly-Field allocate-Poly-Field				\
 (add-subclass! name super-class own-field-descriptions)	\
 (make-predicate class) (make-maker class) 			\
 (make-allocator class) (make-reader field) 			\
 (make-writer field)  (make-lengther field) 			\
 (retrieve-named-field class field-name)			\
 (register-generic generic-name default)			\
 (determine-method generic o)					\
 (register-method generic-name pre-method class-name) ) )	\
(define meroonet-error (unspecified))				\
(define-macro (unless condition . body)				\
  \`(if ,condition #f (begin . ,body)) )			\
(define-macro (when condition . body)				\
  \`(if ,condition (begin . ,body)) )				\
(define-macro (define-meroonet-macro call . body)		\
  \`(eval '(define-macro ,call . ,body)) )			\
(define-meroonet-macro (unless condition . body)		\
  \`(if ,condition #f (begin . ,body)) )			\
(define-meroonet-macro (when condition . body)			\
  \`(if ,condition (begin . ,body)) )	 "			;\
	  cat meroonet.scm	)	> o/${HOSTTYPE}/meroonet.bgl
o/${HOSTTYPE}/bgl-meroonet.o : o/${HOSTTYPE}/meroonet.bgl
	cd o/${HOSTTYPE} ; ${BIGLOO} ${BIGLOOFLAGS} meroonet.bgl -A
	cd o/${HOSTTYPE} ; mv meroonet.o bgl-meroonet.o


o/${HOSTTYPE}/bgl-test : o/${HOSTTYPE}/test.bgl \
			o/${HOSTTYPE}/bgl-meroonet.o \
			../../bigloo/o/${HOSTTYPE}/tester.o
	cd o/${HOSTTYPE} ; ${BIGLOO} -o bgl-test ${BIGLOOFLAGS} test.bgl \
		bgl-meroonet.o ../../../../bigloo/o/${HOSTTYPE}/tester.o

o/${HOSTTYPE}/test.bgl : 
	echo "							\
(module test (main start) 					\
   (import (meroonet \"meroonet.bgl\")				\
   (tester \"../../../../bigloo/o/${HOSTTYPE}/tester.bgl\") ) )	\
(define-macro (hack)						\
  (define-macro (define-meroonet-macro call . body)		\
     \`(define-macro ,call . ,body) )				\
  (define-meroonet-macro (unless condition . body)		\
    \`(if ,condition #f (begin . ,body)) )			\
  (define-meroonet-macro (when condition . body)		\
    \`(if ,condition (begin . ,body)) )				\
  (loadq \"../../meroonet.scm\")				\
  ''hack ) 							\
(hack)								\
								\
(define-class Point Object (x y))				\
(define-generic (x (o)))					\
(define-method (x (o Point)) (Point-x o))			\
(display (x (make-Point 11 22)))				\
								\
(define (test-oo file)						\
  (suite-test 							\
   file \"?? \" \"== \" #t					\
   (lambda (readd check err)					\
     (lambda ()							\
       (try (check (eval (readd)))				\
            (lambda (k a b c) 					\
              (err a b c)) ) ) )				\
   equal? ) )							\
(set! meroonet-error 33)					\
(define the-Point (unspecified))				\
(define (start argv) 						\
  (test-oo \"oo-tests.scm\") )					\
" 				> o/${HOSTTYPE}/test.bgl

######################################################################## siod
# Not finished since siod 2.8 only accept trivial dotted variable list
# In particular, it does not accept (lambda (o field . i) ...)
test.siod :
	echo "							\
(load \"/usr/local/src/siod/siod.scm\")				\
(define define-meroonet-macro 'do-define-meroonet-macro)	\
(define do-define-meroonet-macro				\
  (lambda (call)						\
    (let ((name (car (car (cdr call)))))			\
      (let ((mac (symbolconc 'do- name)))			\
        \`(begin						\
           (define ,name ',mac)					\
           (define ,mac						\
             (lambda (call)					\
               (apply (lambda ,(cdr (car (cdr call))) 		\
                         . ,(cdr (cdr call)) )			\
                      (cdr call) ) ) ) ) ) ) ) )		\
(define-meroonet-macro (let* binds . body)			\
  (if (pair? binds)						\
      \`(let (,(car binds)) (let* ,(cdr binds) . ,body))	\
      \`(begin . ,body) ) )					\
(define-meroonet-macro (unless condition . body)		\
  \`(if ,condition #f (begin . ,body)) )			\
(define-meroonet-macro (when condition . body)			\
  \`(if ,condition (begin . ,body)) )				\
(define make-vector cons-array)					\
(define #f '())							\
(load \"../tester.scm\")					\
(load \"meroonet.scm\")						\
                              errobj				\
(define (test-oo file)						\
  (suite-test 							\
   file \"?? \" \"== \" #t					\
   (lambda (read check err)					\
     (lambda ()							\
       (check (eval (read))) ) )				\
   equal? ) )							\
(test-oo \"oo-tests.scm\")"		| siod -h20000

######################################################################## Gambit
test.gambit :
	echo "							\
(##define-macro (define-meroonet-macro call . body)		\
  \`(##define-macro ,call . ,body ) )				\
'not-finished	"			| gambit

#################################################################### MacScheme
test.macscheme :
	echo "							\
(macro define-meroonet-macro					\
  (lambda (call)						\
     (if (>= (length call) 3)					\
         (let ((call (cadr call))				\
               (body (cddr call)) )				\
           \`(macro ,(car call)					\
              (lambda (c@ll)					\
                 (apply (lambda ,(cdr call) . ,body)		\
                        (cdr c@ll) ) ) ) ) ) ) )		\
'not-finished	"			| macscheme


#################################################################### PC Scheme
test.pcs :
	echo "							\
(macro define-meroonet-macro					\
   (lambda (call)						\
     \`(macro ,(car (cadr call))				\
             (lambda (call)					\
               (apply (lambda ,(cdr (cadr call)) ,@(cddr call))	\
                      (cdr call) ) ) ) ) )			\
'not-finished	"			| pcs


######################################## Testing variants for the book
# These variants contains improvements or alternatives for some functions
# of Meroonet. They are mainly used by exercises on this chapter.
variantes : variante1 variante2 variante3 variante4 variante5

#define Variant(name)					@@\
name : name.scm						@@\
	echo "						\@@\
(define-macro (define-meroonet-macro call . body)	\@@\
  \`(define-macro ,call . ,body) )			\@@\
(define gensym						\@@\
  (let ((counter 99))					\@@\
    (lambda () 						\@@\
      (set! counter (+ 1 counter))			\@@\
      (string->symbol 					\@@\
       (string-append \"G\" 				\@@\
                      (number->string counter) ) ) ) ) )\@@\
(define (list-tail l n)					\@@\
  (if (> n 0)						\@@\
      (if (pair? l)					\@@\
          (list-tail (cdr l) (- n 1))			\@@\
          (error-handler 'list-tail) )			\@@\
      l ) )						\@@\
(load \"../tester.scm\")				\@@\
(load \"meroonet.scm\")					\@@\
(define (test-oo file)					\@@\
  (suite-test 						\@@\
   file \"?? \" \"== \" #t				\@@\
   (lambda (read check err)				\@@\
     (set! error-handler err)				\@@\
     (lambda ()						\@@\
       (check (eval (read) top-level-environment)) ) )	\@@\
   equal? ) )						\@@\
(define the-Point 'wait)				\@@\
(load \"name.scm\")					\@@\
(test-oo \"oo-tests.scm\")"		| elk -h 2000	@@\
	sleep 2

Variant(variante1)
Variant(variante2)
Variant(variante3)

# an error is found since it allows methods to be defined on non 
# preexisting generic functions.
Variant(variante4)

Variant(variante5)
