The category macro takes as its arguments a set and between zero and two lists of letrec style local bindings. The first list is a list of member operators, and the second is a list of member functions. The category macro returns a Sol category.
Categories use a simple single-inheritance mechanism in which all inherited members are ``virtual.'' Eventually a more complex inheritance mechanism may be implemented if experience proves it necessary.
(defmacro category (super s ops . funcs)
(letrec (
; Inside the body of the
; macro, all arguments are
; unevaluated. In order to
; work with the super-class in
; this environment we must
; force the evaluation of the
; super argument to get the
; category (procedure) it
; refers to.
(parent-category (eval super))
; Force evaluation of S in
; order to perform type
; checking - S could be a
; procedure which returns a
; set rather than being a set.
(this-set (eval s))
; extract the operators and
; functions of the parent
; category.
(parent-operators (if (null? parent-category)
'()
((parent-category 'get-operators))))
(parent-functions (if (null? parent-category)
'()
((parent-category 'get-functions))))
; Construct the operator and
; function lists for this
; category.
(operators (append ops parent-operators))
; Note that FUNTIONS does not
; include the
; UNIVERSAL-FUNCTIONS defined
; above.
(functions (if (null? funcs)
parent-functions
(append (car funcs) parent-functions)))
; These functions are
; available to all Sol
; categories.
(universal-functions
`((get-set (lambda () member-set))
(set-set! (function
sol ((new-set sset)) (set! member-set new-set)))
(get-operators (lambda () ',operators))
(get-operator-table (lambda () operator-table))
(get-functions (lambda () ',functions))
(get-function-table (lambda () function-table))))
; The construct-table
; procedure builds the
; operator and function
; tables.
(construct-table
(lambda (raw-table)
(if (null? raw-table)
'()
; These symbols already bound
; when construct-table is
; called.
`(cons (list ',(caar raw-table)
,(caar raw-table))
,(construct-table (cdr raw-table)))))))
; Check to see if the macro
; arguments were of the
; appropriate type.
(if (and (set? this-set) (list? ops))
; If they were, produce the
; following quasi-quoted code
; block. NOTE: This has to be
; quasi-quoted to do the
; appropriate substitutions
; with the unquote-operator.
`(letrec
((member-set ,this-set)
(member-operators ',operators)
(member-functions ',functions)
; Declare the operators and
; functions so that they are
; part of the local name space.
; Note: Need to reverse these,
; otherwise subcategories
; can't override.
,@(reverse operators)
,@(reverse (append universal-functions functions)))
(function
sol ((arg symbol))
(letrec
(
; create a table of member
; operators
(operator-table ,(construct-table operators))
; Create a table of member
; functions.
(function-table ,(construct-table
(append
universal-functions
functions)))
; Look up ARG in both tables.
(operator-match (assq arg operator-table))
(function-match (assq arg function-table)))
; If MATCH was found in
; operator-table...
(if (pair? operator-match)
; Return lambda expression
(lambda args
(apply operate
(cons* member-set
(cadr operator-match) args)))
; else try function table...
(if (pair? function-match)
; Return match
(cadr function-match)
(error "Unable to find method or field:" arg)
)))))
(error '((s sset) (ops list)) (list s ops)))))
