210 lines
8.6 KiB
Common Lisp
210 lines
8.6 KiB
Common Lisp
|
||
; -*- Mode: Lisp -*- Filename: pdefstr.s
|
||
|
||
; Last Revision: 30-Aug-85 1900ct
|
||
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; TI SCHEME -- PCS Compiler ;
|
||
; Copyright 1985 (c) Texas Instruments ;
|
||
; ;
|
||
; Amitabh Srivastava ;
|
||
; ;
|
||
; DEFINE-STRUCTURE and Related Routines ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
|
||
;;;
|
||
;;; - syntax is similar to DEFSTRUCT in Common Lisp
|
||
;;;
|
||
;;; Syntax : (DEFINE-STRUCTURE name slot1 slot2 ...)
|
||
;;;
|
||
;;; slots may be given default values by (slot1 init-val)
|
||
;;;
|
||
;;; e.g (DEFINE-STRUCTURE SHIP (X-VEL 0) Y-VEL)
|
||
;;;
|
||
;;; objects of this structure can be generated by using
|
||
;;; MAKE-SHIP -
|
||
;;;
|
||
;;; (MAKE-SHIP 'X-VEL 10)
|
||
;;;
|
||
;;; the predicate SHIP? can be used to check if an object is an
|
||
;;; instance of ship.
|
||
;;;
|
||
;;; (SHIP-X-VEL object) can be used to get the `x-vel' of the object,
|
||
;;; which is an instance of `ship'
|
||
;;;
|
||
;;; (SET! (SHIP-X-VEL object) 11) can be used to set the `x-vel' of the
|
||
;;; object.
|
||
;;;
|
||
;;; single-inheritance : structures can inherit from other objects by
|
||
;;; using the INCLUDE option (similar to Common Lisp DEFSTRUCT)
|
||
;;;
|
||
;;; e.g. (DEFINE-STRUCTURE (SHIP (INCLUDE FLOATING-OBJECT)) slot ...)
|
||
;;;
|
||
|
||
|
||
|
||
;;; Implementation Note
|
||
|
||
|
||
;;; The Common Lisp definition requires that the slot initialization
|
||
;;; expressions be re-evaluated each time a MAKE-name operation is
|
||
;;; performed. For consistency with the spirit of Scheme, these
|
||
;;; expressions should be evaluated in the lexical environment surrounding
|
||
;;; the DEFINE-STRUCTURE itself. Thus, DEFINE-STRUCTURE must expand into
|
||
;;; at least one LAMBDA that `freezes' the initialization expressions.
|
||
;;; This is why %DEFINE-STRUCTURE expands into a BEGIN with an embedded
|
||
;;; closure for MAKE-name. (This is important only if an initialization
|
||
;;; expression involves lexical references.)
|
||
|
||
|
||
|
||
;;; Global function used to generate predicates for all structures
|
||
|
||
|
||
(define %structure-predicate ; %STRUCTURE-PREDICATE
|
||
(lambda (object tag)
|
||
(and (vector? object)
|
||
(positive? (vector-length object))
|
||
(member tag (vector-ref object 0))
|
||
#!true)))
|
||
|
||
|
||
;;; %MAKE-STRUCTURE is used by all structures to create an instance
|
||
|
||
|
||
(define %make-structure ; %MAKE-STRUCTURE
|
||
(lambda (name constructor-name structure init-list)
|
||
(letrec ((slot-number
|
||
(lambda (slot slot-values)
|
||
(apply-if (assq slot slot-values)
|
||
cadr
|
||
(error (string-append
|
||
"Structure component unknown to "
|
||
(symbol->string constructor-name))
|
||
slot)))))
|
||
(let ((slots (getprop name '%SLOT-VALUES)))
|
||
(do ((structure structure)
|
||
(init-msg init-list (cddr init-msg)))
|
||
((null? init-msg) structure)
|
||
(vector-set! structure
|
||
(slot-number (car init-msg) slots)
|
||
(cadr init-msg)))))))
|
||
|
||
|
||
;;; %DEFINE-STRUCTURE defines a structure with specified attributes. This
|
||
;;; is the procedure that expands the macro DEFINE-STRUCTURE.
|
||
|
||
|
||
(define %define-structure ; %DEFINE-STRUCTURE
|
||
(lambda (e)
|
||
(letrec
|
||
((make-symbol ; MAKE-SYMBOL
|
||
(lambda args
|
||
(string->symbol (apply string-append args))))
|
||
|
||
(generate-slots-loop ; GENERATE-SLOTS-LOOP
|
||
(lambda (tail slots n)
|
||
(if (null? slots)
|
||
tail ;;; 2/14/86
|
||
(generate-slots-loop
|
||
(cons (if (atom? (car slots))
|
||
(cons (car slots) (cons n '()))
|
||
(cons (caar slots) (cons n (cadar slots))))
|
||
tail)
|
||
(cdr slots)
|
||
(1+ n)))))
|
||
|
||
(generate-slots ; GENERATE-SLOTS
|
||
(lambda (include-struct slots)
|
||
(if include-struct
|
||
(let ((include-slots (getprop include-struct '%SLOT-VALUES)))
|
||
(generate-slots-loop include-slots
|
||
slots
|
||
(1+ (length include-slots))))
|
||
(generate-slots-loop '() slots 1))))
|
||
|
||
(init-slots ; INIT-SLOTS
|
||
(lambda (slots)
|
||
(let loop ((tail '())
|
||
(slots slots))
|
||
(if (null? slots)
|
||
tail
|
||
(loop (if (member (cddar slots) '(() '()))
|
||
tail
|
||
(cons `(vector-set! %DS0001% ,(cadar slots)
|
||
,(cddar slots))
|
||
tail))
|
||
(cdr slots))))))
|
||
|
||
(access-macros-loop ; ACCESS-MACROS-LOOP
|
||
(lambda (name-string slots tail)
|
||
(if (null? slots)
|
||
(reverse! tail)
|
||
(access-macros-loop
|
||
name-string
|
||
(cdr slots)
|
||
(let ((name (make-symbol name-string "-"
|
||
(symbol->string (caar slots))))
|
||
(index (cadar slots)))
|
||
(cons `(define-integrable ,name
|
||
(lambda (obj) (vector-ref obj ,index)))
|
||
tail))))))
|
||
|
||
(gen-access-macros ; GEN-ACCESS-MACROS
|
||
(lambda (name-string slot-names-pos)
|
||
(access-macros-loop name-string slot-names-pos '())))
|
||
|
||
(gen-make-proc ; GEN-MAKE-PROC
|
||
(lambda (name constructor-name slot-names-pos)
|
||
`(define ,constructor-name
|
||
(lambda %DS0002%
|
||
(let ((%DS0001% (make-vector ,(1+ (length slot-names-pos))
|
||
'())))
|
||
(vector-set! %DS0001% 0 (getprop ',name '%TAG))
|
||
,@(init-slots slot-names-pos)
|
||
(if (null? %DS0002%)
|
||
%DS0001%
|
||
(%make-structure ',name ',constructor-name
|
||
%DS0001% %DS0002%)))))))
|
||
)
|
||
(begin
|
||
(pcs-chk-length>= e e 2)
|
||
(let* ((name-options (cadr e))
|
||
(name (let ((n (if (atom? name-options)
|
||
name-options
|
||
(car name-options))))
|
||
(pcs-chk-id e n)
|
||
n))
|
||
(name-string (symbol->string name))
|
||
(constructor-name (make-symbol "MAKE-" name-string))
|
||
(predicate-name (make-symbol name-string "?"))
|
||
(include-struct
|
||
(cond ((atom? name-options)
|
||
'())
|
||
((and (pair? (cdr name-options))
|
||
(pair? (cadr name-options))
|
||
(eq? (car (cadr name-options)) 'INCLUDE)
|
||
(pair? (cdr (cadr name-options))))
|
||
(let ((is (cadr (cadr name-options))))
|
||
(pcs-chk-id e is)
|
||
is))
|
||
(else
|
||
(syntax-error "Invalid option list" e))))
|
||
(slots (cddr e))
|
||
(slot-names-pos (generate-slots include-struct slots))
|
||
(tag (cons '#!STRUCTURE name))
|
||
(complex-tag (if include-struct
|
||
(cons tag (getprop include-struct '%TAG))
|
||
(list tag))))
|
||
`(begin
|
||
(putprop ',name ',complex-tag '%TAG)
|
||
(putprop ',name ',slot-names-pos '%SLOT-VALUES)
|
||
,@(gen-access-macros name-string slot-names-pos)
|
||
(define ,predicate-name
|
||
(lambda (obj)
|
||
(%structure-predicate obj ',tag)))
|
||
,(gen-make-proc name constructor-name slot-names-pos)
|
||
',name))))))
|
||
|