Package "pos"


Version:
v1.0.0
Released:
2245 days ago
Maintainer:
Matthew Martin <matt.a.martin@gmail.com>
Author:
Blake McBride <blake@mcbride.name>
Homepage:
http://algorithms.us/software/pos/index.html
Description:
POS is a portable object system for Scheme.
Keywords:
object-oriented syntax
Package form:
(package*
 pos/v1.0.0
 (provide:
  (define *no-method* '*no-method*)
  (define (make class))
  (define-syntax
   define-class
   (syntax-rules
    (superclasses cvars ivars cmeths imeths fix-args)
    ((_ class-name
        (superclasses sc1 ...)
        (cvars (cv1 icval) ...)
        (ivars (iv1 iival) ...)
        (cmeths (cmeth-name carg-list cmeth-defn ...) ...)
        (imeths (meth-name arg-list meth-defn ...) ...))
     (begin
       (define class-name
         (let ((super-classes (list sc1 ...))
               (cls-name (symbol->string 'class-name))
               (cself '())
               (cv1 icval)
               ...)
           (lambda cargs
             (define make-super-instances
               (lambda (class-list)
                 (let ((ret '()))
                   (let loop ((sc class-list))
                     (cond ((pair? sc)
                            (set! ret
                                  (append ret
                                          (list (apply (car sc)
                                                       (list 'make)))))
                            (loop (cdr sc)))
                           (else ret))))))
             (define execute-superclasses
               (lambda (scl args)
                 (let ((ret '()))
                   (let loop ((scl scl))
                     (cond ((pair? scl)
                            (set! ret (apply (car scl) args))
                            (if (eq? ret *no-method*) (loop (cdr scl)) ret))
                           (else *no-method*))))))
             (if (not (pair? cargs))
                 *no-method*
                 (case (car cargs)
                   ((make)
                    (let ((ins (let ((class '())
                                     (self '())
                                     (super-instances
                                      (make-super-instances super-classes))
                                     (iv1 iival)
                                     ...)
                                 (lambda iargs
                                   (if (not (pair? iargs))
                                       *no-method*
                                       (case (car iargs)
                                         ((class) class)
                                         ((set-class)
                                          (set! class (cadr iargs)))
                                         ((set-self) (set! self (cadr iargs)))
                                         ((super)
                                          (execute-superclasses
                                           super-instances
                                           (cdr iargs)))
                                         ((meth-name)
                                          (apply (lambda arg-list
                                                   meth-defn
                                                   ...)
                                                 (cons self (cdr iargs))))
                                         ...
                                         (else
                                          (execute-superclasses
                                           super-instances
                                           iargs))))))))
                      (ins 'set-self ins)
                      ins))
                   ((set-self) (set! cself (cadr cargs)))
                   ((name) cls-name)
                   ((class) #f)
                   ((super) (execute-superclasses super-classes (cdr cargs)))
                   ((cmeth-name)
                    (apply (lambda carg-list cmeth-defn ...)
                           (cons cself (cdr cargs))))
                   ...
                   (else (execute-superclasses super-classes cargs)))))))
       (class-name 'set-self class-name)))
    ((_ class-name (fix-args sc cv iv cm im) (superclasses arga ...) argb ...)
     (define-class
      class-name
      (fix-args (superclasses arga ...) cv iv cm im)
      argb
      ...))
    ((_ class-name (fix-args sc cv iv cm im) (cvars arga ...) argb ...)
     (define-class
      class-name
      (fix-args sc (cvars arga ...) iv cm im)
      argb
      ...))
    ((_ class-name (fix-args sc cv iv cm im) (ivars arga ...) argb ...)
     (define-class
      class-name
      (fix-args sc cv (ivars arga ...) cm im)
      argb
      ...))
    ((_ class-name (fix-args sc cv iv cm im) (cmeths arga ...) argb ...)
     (define-class
      class-name
      (fix-args sc cv iv (cmeths arga ...) im)
      argb
      ...))
    ((_ class-name (fix-args sc cv iv cm im) (imeths arga ...) argb ...)
     (define-class
      class-name
      (fix-args sc cv iv cm (imeths arga ...))
      argb
      ...))
    ((_ class-name (fix-args sc cv iv cm im))
     (define-class class-name sc cv iv cm im))
    ((_ class-name (fix-args sc cv iv cm im) arga argb ...)
     (define-class class-name (fix-args sc cv iv cm im) argb ...))
    ((_ class-name arg1 ...)
     (define-class
      class-name
      (fix-args (superclasses) (cvars) (ivars) (cmeths) (imeths))
      arg1
      ...)))))
 (maintainer: "Matthew Martin <matt.a.martin@gmail.com>")
 (author: "Blake McBride <blake@mcbride.name>")
 (homepage: "http://algorithms.us/software/pos/index.html")
 (description: "POS is a portable object system for Scheme.")
 (keywords: object-oriented syntax)
 (license: custom))