Objects in Scheme

;;;;-----------------------------------------------------------
;;;;  Make two argument operation and n argument operation
;;;;     The plus operation

(define extended-plus
  (lambda (l)
    (if (null? l)
        'error-no-args-not-allowed
	(if (null? (cdr l))
	    (car l)
	    (+ (car l) (extended-plus (cdr l)))))))

'(+ '(1 2 3 4))

;;;;-----------------------------------------
;;;;     The plus operation with letrec

(define ep
  (lambda l
    (letrec ((op (lambda (l^)
                   (if (null? l^)
                       'error-no-args-not-allowed
                       (if (null? (cdr l^))
                           (car l^)
	                   (+ (car l^) (op (cdr l^))))))))
	(op l))))
	
'(+ 1 2 3 4)	
	
;;;;--------------------------------------
;;;;     The times operation

(define et
  (lambda l
    (letrec ((op (lambda (l^)
                   (if (null? l^)
                       'error-no-args-not-allowed
                       (if (null? (cdr l^))
                           (car l^)
	                   (* (car l^) (op (cdr l^))))))))
	(op l))))
	
;;;;----------------------------------------------------------
;;;;  Abstract to any operation with right association

(define extended-op-maker-R
  (lambda (op)
    (lambda l
      (letrec ((eop (lambda (l^)
                      (if (null? l^)
                          'error-no-args-not-allowed
                          (if (null? (cdr l^))
                              (car l^)
                              (op (car l^) (eop (cdr l^))))))))
        (eop l)))))
	
(define f (extended-op-maker-R *))
(define g (extended-op-maker-R +))
(define h (extended-op-maker-R cons))
(define i (extended-op-maker-R /))

;;;;-------------------------------------------------------
;;;;  Do the same for operations with left association

(define extended-op-maker-L
  (lambda (op)
    (lambda l
      (letrec ((eop (lambda (l^ acc)
                      (if (null? l^)
		          acc
                          (eop (cdr l^) (op acc (car l^)))))))
        (if (null? l)
	    'error
	    (eop (cdr l) (car l)))))))
	    
(define j (extended-op-maker-L /))	    
(define k (extended-op-maker-L cons))
  
;;;;-----------------------------
;;;;   Stacks

(define stack
  (lambda (s)
    (lambda msg
      (letrec ((push (lambda (x) (stack (cons x s))))
               (pop (lambda () (stack (cdr s))))
               (top (lambda () (car s)))
               (show (lambda () s)))
        (case (car msg)
           ('top   (top))
           ('push  (push (car (cdr msg))))
           ('pop   (pop))
           ('show  (show))
           (else   '()))))))

;;;;-------------------------------
;;;;  Tests

(define destroy-stack
  (lambda (s)
    (if (null? (s 'show))
        '()
        (cons (s 'show) (destroy-stack (s 'pop))))))

(define build-stack
  (lambda (s n)
    (if (= n 0)
        '()
        (cons (s 'show) (build-stack (s 'push n) (- n 1))))))

(define build-and-destroy-stack
  (lambda (s n)
    (letrec ((bs (lambda (s^ n^) (if (= n^ 0) s^ (bs (s^ 'push n^) (- n^ 1))))))
       (append (build-stack s n) (destroy-stack (bs s n))))))

;;;;-------------------------------
;;;;  

(define base-object-maker
  (lambda (str numb)
     (lambda msg
        (letrec
	  ((stringOf (lambda () str))
           (numberOf (lambda () numb))
	   (setString (lambda (s) (object-maker s numb)))
	   (setNumber (lambda (n) (object-maker str n))))
	  (case (car msg)
	   ('stringOf (stringOf))
	   ('numberOf (numberOf))
	   ('setString (setString (car (cdr msg))))
	   ('setNumber (setNumber (car (cdr msg)))))))))