home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / windows / winlisp.zip / OOPL.LZH / OOPL.WL < prev    next >
Text File  |  1989-08-05  |  27KB  |  601 lines
  1. ;===============================================================================
  2. ; WINLISP:
  3. ;
  4. ;
  5. ;                    M I N I M U M    O. O. P.    L A Y E R
  6. ;
  7. ; Follows the ObjVLisp model (P. COINTE OOPSLA '87 proceedings) minus
  8. ; the multi-inheritance feature.
  9. ;
  10. ; AUTHOR:     Hussein SHAFIE
  11. ;
  12. ; COPYRIGHT:  Gregory POPOVITCH (c) 1989
  13. ;
  14. ; REQUIRES:   'cmonlib' and 'abbrev' packages
  15. ; 
  16. ; CAVEATS:    - In this object model (unlike in the Smalltalk-80 model) class
  17. ;        variables are not inherited. That might cause some problems
  18. ;        if a class variable cv is referenced within a method of a 
  19. ;        class C:
  20. ;
  21. ;            [{MetaC} new 'name 'C
  22. ;                . . .
  23. ;                'cv        "cvstringvalue"
  24. ;                'methods    '(
  25. ;            aMess    (()
  26. ;                    . . .
  27. ;                    (if (equal #Ccv . . .
  28. ;                    . . .
  29. ;
  30. ;        and C has a subclass SubC whose class is not a kind of MetaC
  31. ;        (thus SubC instances have no acces to the cv class variable)
  32. ;        and that doesn't redefine a method for message aMess:
  33. ;
  34. ;            [{Class} new 'name 'SubC
  35. ;                 'superClass    {C}]
  36. ;
  37. ;        What do you think will happen at the execution time of:
  38. ;
  39. ;            [anInstanceOfSubC aMess]
  40. ;
  41. ;        Answer: a mess...
  42. ;
  43. ;          - For specification purposes, one may define an "empty" method 
  44. ;        for message aRequiredMess within the protocol of an abstract 
  45. ;        class AC.
  46. ;        This version of OOPL will not ensure that all non-abstract 
  47. ;        subclasses of AC actually implement a method for message 
  48. ;        aRequiredMess.
  49. ;          
  50. ;             - Redefining a method for message ooplInitialize in classes
  51. ;        other than Object and Class may be hazardous for the system.
  52. ;===============================================================================
  53.  
  54. (setq #:winlisp:colon 'oopl)
  55.  
  56. ;===============================================================================
  57. ;          if not already loaded, load abbreviations module;
  58. ;          and define some usefull functions.
  59. ;===============================================================================
  60. (unless (typefn 'get-abbrev) (loadfile "abbrev"))
  61.  
  62. (defun makelist (n s)
  63.        (if (<= n 0) () (cons s (makelist (1- n) s))))
  64. (setq :gensym-str "g" :gensym-idx 100)
  65. (defun gensym () (concat :gensym-str (incr :gensym-idx)))
  66. (synonym 'makevector 'make-vector)
  67.  
  68. ;===============================================================================
  69. ;                        E R R O R    M E S S A G E S
  70. ;===============================================================================
  71.  
  72. (defvar :notavar "not a symbol")
  73. (defvar :notalist "not a list")
  74. (defvar :badinstvarinit "usage: { <instance variable> <value> }*")
  75. (defvar :badmethdef "usage:  <name> '(' <args>  { <statements> }+  ')'")
  76. (defvar :notaninstvar "not an instance variable defined in class")
  77. (defvar :notaclassvar "not a class variable of class")
  78. (defvar :redefinstvar "instance variable redefined by subclass")
  79. (defvar :illinstvarref "reference of a class or instance variable outside a method")
  80. (defvar :doesnotunderstand "does not understand")        
  81. (defvar :sendqsyntax "usage: '[' <receiver>|super <selector> { <argument> }* ']'")        
  82. (defvar :illsendsuper "[super <selector> ... ] outside a method definition")
  83. (defvar :notaclass "not a class")
  84. (defvar :notinstantiable "abstract classes cannot be instantiated")
  85.  
  86. ;===============================================================================
  87. ;                      P R I V A T E    F U N C T I O N S
  88. ;===============================================================================
  89.  
  90. (defmacro :make-typed-vector (type length init)
  91.           ;; ------------------------------------------------------
  92.           ;; Return a vector typed <type> with <length> elements
  93.           ;; initialized to <init>.
  94.           ;; ------------------------------------------------------
  95.           `(let ( (new-vector (makevector ,length ,init)) )
  96.                 (typevector new-vector ,type)
  97.                 new-vector))
  98.  
  99. (defun :index (symbol list index)
  100.        ;; -------------------------------------------------------------
  101.        ;; Return the position index (starting at <index>) of <symbol> 
  102.        ;; in <list>.
  103.        ;; Return () if <symbol> is not a member of <list>.
  104.        ;; -------------------------------------------------------------
  105.        (when list
  106.              (if (eq symbol (car list))
  107.                  index
  108.                  ;;ELSE
  109.                  (:index symbol (cdr list) (1+ index)))))
  110.            
  111. (defun :initialize-instance (instance instvars inits)
  112.        ;; -------------------------------------------------------------
  113.        ;; Initialize some elements of vector <instance> according to
  114.        ;; the specification <inits>.
  115.        ;; <inits> is a list of associations symbolic key/value.
  116.        ;; <instvars> is a list of keys, the first key beeing a symbolic
  117.        ;; name for element 0 of the vector, the second for element 1, ...
  118.        ;; -------------------------------------------------------------
  119.        (when inits
  120.              (let* ( (instvar (car inits))
  121.                      (index   (:index instvar instvars 0)) )
  122.                    (unless index
  123.                            (error "{Class}:new"
  124.                                   :notaninstvar
  125.                                   (cons instvar 
  126.                                         (send 'name (send 'class instance)))))
  127.                    (unless (cdr inits)
  128.                            (error "{Class}:new" :badinstvarinit instvar))
  129.                    (vset instance index (cadr inits))
  130.                    (:initialize-instance instance instvars (cddr inits)))))
  131.  
  132. (defmacro :install-class (class-object class-name super-class-name)
  133.           ;; ------------------------------------------------------
  134.           ;; Define <class-name> as an abbreviation for the symbol:
  135.           ;; inheritance_path_up_to_<super-class-name>:<class-name>.
  136.           ;; Store <class-object> as the value of this "long" symbol.
  137.           ;; ------------------------------------------------------
  138.           `(let ( (class-symbol (if ,super-class-name
  139.                                     (symbol (get-abbrev ,super-class-name)
  140.                                             ,class-name)
  141.                                     ;;ELSE
  142.                                     ,class-name)) )
  143.                 (put-abbrev ,class-name class-symbol)
  144.                 (set class-symbol ,class-object)))
  145.  
  146. (defun :install-methods (class methods)
  147.        ;; -------------------------------------------------------------
  148.        ;; Install the methods <methods> defined at the class <class>
  149.        ;; creation time.
  150.        ;; -------------------------------------------------------------
  151.        (when methods
  152.              (send 'addMethod class (car methods) (cadr methods))
  153.              (:install-methods class (cddr methods))))
  154.                                  
  155. (defun :not-variablep (x)    (if (variablep x) () x))
  156.  
  157. (defun :merge-instvars (super-instvars self-instvars)
  158.        ;; -------------------------------------------------------------
  159.        ;; Check that <self-instvars> is a list of variables.
  160.        ;; Check that no element of <self-instvars> is also an element
  161.        ;; of <super-instvars>.
  162.        ;; -------------------------------------------------------------
  163.        (unless (listp self-instvars)
  164.                (error "{Class}:new" :notalist self-instvars))
  165.  
  166.        (let ( (bad-instvar (any ':not-variablep self-instvars)) )
  167.  
  168.             (when bad-instvar
  169.                   (error "{Class}:new" :notavar bad-instvar))
  170.  
  171.             (cond ( (null super-instvars)    self-instvars )
  172.                   ( (null self-instvars)    super-instvars )
  173.                   ( t                 ;CHECK FOR REDEFINED INSTANCE VARIABLES
  174.                     (setq bad-instvar
  175.                           (any '(lambda (instvar)
  176.                                         (when (member instvar super-instvars)
  177.                                               instvar))
  178.                                 self-instvars))
  179.                     (if bad-instvar
  180.                         (error "{Class}:new" :redefinstvar bad-instvar)
  181.                         ;;ELSE
  182.                         (nconc (copy super-instvars) self-instvars)) ))))
  183.                                         
  184. (defmacro :class (instance)        `(symeval (type-of ,instance)))
  185.  
  186. (defun :replace-refs (sexpr)
  187.        (when (consp sexpr)
  188.              (selectq (car sexpr)
  189.                       ( :instvar-ref
  190.                         (let* ( (instvar (cadr sexpr))
  191.                                 (index   (:index instvar *instvars* 0)) )
  192.                               (if index
  193.                                   (displace sexpr `(vref self ,index))
  194.                                   ;;ELSE
  195.                                   (error "{Class}:addMethod"
  196.                                          :notaninstvar 
  197.                                          (cons instvar *classname*)))) )
  198.                       ( :classvar-ref
  199.                         (let* ( (classvar (cadr sexpr))
  200.                                 (index    (:index classvar *classvars* 0)) )
  201.                               (if index
  202.                                   (displace sexpr 
  203.                                             `(vref (:class self) ,index))
  204.                                   ;;ELSE
  205.                                   (error "{Class}:addMethod"
  206.                                          :notaclassvar
  207.                                          (cons classvar *classname*)))) )
  208.                       ( :classname-ref
  209.                         (displace sexpr `(quote ,*classname*)) )
  210.                       ( t    
  211.                         (:replace-refs (car sexpr))
  212.                         (:replace-refs (cdr sexpr)) ))))
  213.        
  214. (defun :as-method (implementation instvars classvars classname)
  215.        ;; -------------------------------------------------------------
  216.        ;; Insert 'self' at the beginning of the lambda list starting
  217.        ;; <implementation>.
  218.        ;; Call :replace-refs in order to physically replace all instance
  219.        ;; variable references (if found in <instvars>), all class
  220.        ;; variable references (if found in <classvars>) by an equivalent
  221.        ;; call to vref and all class name references by the name of the
  222.        ;; class where the method is defined (<classname>).
  223.        ;; -------------------------------------------------------------
  224.        (let ( (*instvars*  instvars)
  225.               (*classvars* classvars)
  226.               (*classname* classname) )
  227.             (setf (car implementation) (cons 'self (car implementation)))
  228.             (:replace-refs (cdr implementation))
  229.             implementation))
  230.  
  231. ;;; ---------------------------------------------------------------------------
  232. ;;; Instance variable, class variable and class name references
  233. ;;; ---------------------------------------------------------------------------
  234.  
  235. (defmacro :instvar-ref (instvar)    `(error '|#I| :illinstvarref ,instvar))
  236.  
  237. (defsetf :instvar-ref (instvar) (val)    `(error '|#I| :illinstvarref ,instvar))
  238.  
  239. (defsharp |I| ()            `(:instvar-ref ,(read)))
  240.  
  241. (defmacro :classvar-ref (classvar)    `(error '|#C| :illinstvarref ,classvar))
  242.  
  243. (defsetf :classvar-ref (classvar) (val)    `(error '|#C| :illinstvarref ,classvar))
  244.  
  245. (defsharp |C| ()            `(:classvar-ref ,(read)))
  246.  
  247. (defmacro :classname-ref ()        `(error '|[| :illsendsuper ()))
  248.  
  249. ;;; ---------------------------------------------------------------------------
  250. ;;; The message passing syntax is:
  251. ;;;     '[' <receiver>|super <selector> { <argument> }* ']'
  252. ;;; The Lisp level syntax using send or send-super remains mandatory
  253. ;;; when the message selector has to be dynamically evaluated.
  254. ;;; ---------------------------------------------------------------------------
  255.  
  256. (dmc |]| ()        (error '|]| :sendqsyntax ()))
  257.  
  258. (dmc |[| ()
  259.      (let ( (receiver  (read)) 
  260.             (selector  (read)) )
  261.           (unless (variablep selector)
  262.                   (error '|[| :sendqsyntax selector))
  263.           (if (eq receiver 'super)
  264.               ;; |[| MUST CONS A NEW (:CLASSNAME-REF) EACH TIME IT IS CALLED
  265.               ;; BECAUSE THE PURPOSE OF THIS DUMMY FUNCTION IS TO BE PHYSICALLY 
  266.               ;; REPLACED BY AN ACTUAL CLASS NAME.
  267.               `(send-super ,(list ':classname-ref) ',selector self 
  268.                            ,.(read-delimited-list #/]))
  269.               ;;ELSE
  270.               `(send ',selector ,receiver ,.(read-delimited-list #/])))))
  271.  
  272. ;===============================================================================
  273. ;                       P U B L I C    F U N C T I O N S
  274. ;===============================================================================
  275.  
  276. ;(defun send (selector . receiver___args)
  277.        ;; -------------------------------------------------------------
  278.        ;; Send the message <selector> to the car of <receiver___args>
  279.        ;; with the cdr of <receiver___args> as arguments.
  280.        ;; -------------------------------------------------------------
  281. ;       (let ( (method (getfn (type-of (car receiver___args)) selector)) )
  282. ;            (if method
  283. ;                (apply method receiver___args)
  284. ;                ;;ELSE
  285. ;                (send 'doesNotUnderstand 
  286. ;                      (car receiver___args) 
  287. ;                      selector (cdr receiver___args)))))
  288.  
  289. (synonym 'send-super 'sendsuper)
  290. ;(defun send-super (classname selector . receiver___args)
  291.        ;; -------------------------------------------------------------
  292.        ;; Send the message <selector> to the car of <receiver___args>
  293.        ;; CONSIDERED AS BEING AN INSTANCE OF CLASS <classname>'s
  294.        ;; SUPERCLASS with the cdr of <receiver___args> as arguments.
  295.        ;; -------------------------------------------------------------
  296. ;       (let ( (method (getfn (packagecell classname) selector)) )
  297. ;            (if method
  298. ;                (apply method receiver___args)
  299. ;                ;;ELSE
  300. ;                (send-super classname 
  301. ;                            'doesNotUnderstand 
  302. ;                            (car receiver___args) 
  303. ;                            selector (cdr receiver___args)))))
  304.  
  305. ;;; ---------------------------------------------------------------------------
  306. ;;; "methods" inherited by both primitive objects and non primitive objects
  307. ;;; ---------------------------------------------------------------------------
  308. (defun class (self)        (:class self))
  309.  
  310. (defun isKindOf (self aClass)
  311.        [[self class] inheritsFrom aClass])
  312.         
  313. (defun doesNotUnderstand (self selector args)
  314.        (error 'doesNotUnderstand :doesnotunderstand (cons self selector)))
  315.  
  316.  
  317. ;===============================================================================
  318. ;                     F O U N D A T I O N    C L A S S E S
  319. ;===============================================================================
  320.  
  321. ;;; ---------------------------------------------------------------------------
  322. ;;; BOOTSTRAP PREPARATION: 
  323. ;;; In order to create the first classes 'Object' and then 'Class' the usual
  324. ;;; way (i.e. by sending the message 'new' to 'Class'), one has to do
  325. ;;; the hard way (by hand, in native lisp) first what will be automatically
  326. ;;; redone by the bootstrapped system.
  327. ;;; So the best documentation for the code that follows is its object oriented
  328. ;;; equivalent [{Class} new 'name 'Class 'superClass ...)
  329. ;;; ---------------------------------------------------------------------------
  330.  
  331. (put-abbrev 'Class '#:Object:Class)
  332.  
  333. (setq #:Object:Class
  334.       #:Object:Class:#[ Class
  335.                         ()
  336.                         (name superClass instanceVariables methods)
  337.                         () ])
  338.  
  339. (defun #:Object:Class:new (self . inits)
  340.        (let ( (name              (vref self 0))
  341.               (instanceVariables (vref self 2)) )
  342.             (send 'ooplInitialize
  343.                   (:make-typed-vector (get-abbrev name) 
  344.                                       (length instanceVariables) 
  345.                                       ())
  346.                   inits)))
  347.  
  348. (defun #:Object:Class:ooplInitialize (self inits)
  349.        (let ( (CinstanceVariables (vref (:class self) 2)) )
  350.             (:initialize-instance self CinstanceVariables inits))
  351.  
  352.        (let* ( (name               (vref self 0))
  353.                (superClass         (vref self 1))
  354.                (superClassName     (when superClass 
  355.                                          (send 'name superClass)))
  356.                (superClassInstvars (when superClass
  357.                                          (send 'instanceVariables superClass)))
  358.                (IinstanceVariables (vref self 2)) 
  359.                (methods            (vref self 3)) )
  360.              (:install-class self name superClassName)
  361.              (vset self 2 (:merge-instvars superClassInstvars 
  362.                                            IinstanceVariables))
  363.              (vset self 3 ())    
  364.              (:install-methods self methods)
  365.              self))
  366.  
  367. (defun #:Object:Class:addMethod (self selector implementation)
  368.        (let* ( (name               (get-abbrev (vref self 0)))
  369.                (functionName       (symbol name selector))
  370.                (IinstanceVariables (vref self 2))
  371.                (CinstanceVariables (vref (:class self) 2))
  372.                (methods            (vref self 3)) )
  373.              (apply 'defun (cons functionName
  374.                                  (:as-method implementation
  375.                                              IinstanceVariables
  376.                                              CinstanceVariables
  377.                                              name)))
  378.              (vset self 3 (nconc methods (list selector functionName)))))
  379.               
  380. (defun #:Object:Class:name (self)            (vref self 0))
  381.  
  382. (defun #:Object:Class:instanceVariables (self)        (vref self 2))
  383.  
  384. ;;; ---------------------------------------------------------------------------
  385. ;;; AbstractClass INSTANTIATION...
  386. ;;;    An abstract class will be used TO SPECIFY what is the structure/ 
  387. ;;;    behavior common to its subclasses and not directly as a template 
  388. ;;;    used to create objects. 
  389. ;;; ---------------------------------------------------------------------------
  390.  
  391. [{Class} new
  392.     'name        'AbstractClass
  393.         'superClass    {Class}
  394.         'methods    '(
  395.                                 
  396. new ( inits    
  397.     ;; -------------------------------------------------------------------    
  398.     ;; New is redefined to signal any attempt to instantiate an abstract
  399.     ;; class as an error.
  400.     ;; -------------------------------------------------------------------    
  401.           (error "{AbstractClass}:new" :notinstantiable self))
  402.  
  403. addMethod ((selector implementation)
  404.            ;; ------------------------------------------------------
  405.            ;; AddMethod is redefined in order to support an empty
  406.            ;; implementation for a method, this kind of definition
  407.            ;; being considered as a requirement spec for the receiver 
  408.            ;; subclasses.
  409.            ;; ------------------------------------------------------
  410.         (if (cdr implementation)
  411.                     [super addMethod selector implementation]
  412.                     ;;ELSE
  413.                     (setf #Imethods (nconc #Imethods (list selector ())))))
  414.  
  415. )]
  416.  
  417. ;;; ---------------------------------------------------------------------------
  418. ;;; Object INSTANTIATION...
  419. ;;; ---------------------------------------------------------------------------
  420.  
  421. [{AbstractClass}  new 
  422.        'name            'Object
  423.            'methods                    '(
  424.                                            
  425. ooplInitialize ((inits)
  426.            ;; ---------------------------------------------------
  427.            ;; Private - initialize the receiver as a terminal 
  428.            ;;           instance according to <inits>.
  429.            ;; ---------------------------------------------------
  430.                 (:initialize-instance self #CinstanceVariables inits)
  431.                 self)
  432.  
  433. )]
  434.  
  435. ;;; ---------------------------------------------------------------------------
  436. ;;; Class INSTANTIATION...
  437. ;;; Notice that the functions that implement new, ooplInitialize, addMethod...
  438. ;;; are overwritten during the Class instantiation WHILE THEY ARE EXECUTED!!!
  439. ;;; ---------------------------------------------------------------------------
  440. [{Class}  new
  441.            'name        'Class
  442.            'superClass        {Object}
  443.            'instanceVariables    '(name superClass instanceVariables methods)
  444.            'methods        '(
  445.  
  446. new ( inits
  447.     ;; -------------------------------------------------------------------    
  448.     ;; Non special objects basic constructor.
  449.     ;; Is able to create a new instance of the receiver initialized 
  450.     ;; according to <inits>.
  451.     ;; -------------------------------------------------------------------    
  452.       [(:make-typed-vector (get-abbrev #Iname) (length #IinstanceVariables) ())
  453.           ooplInitialize inits])
  454.  
  455. ooplInitialize ((inits)
  456.            ;; ----------------------------------------------------
  457.            ;; Private - initialize the receiver as a non terminal 
  458.            ;;           instance according to <inits>.
  459.            ;;           Implement static inheritance of instance
  460.            ;;           variables.
  461.            ;; ----------------------------------------------------
  462.                 [super ooplInitialize inits]
  463.                 (let* ( (superClass         #IsuperClass) 
  464.                         (superClassName     (when superClass 
  465.                                                   [superClass name]))
  466.                         (superClassInstvars (when superClass
  467.                                                   [superClass 
  468.                                                       instanceVariables]))
  469.                         (methods            #Imethods) )
  470.                       (:install-class self #Iname superClassName)
  471.                       (setf #IinstanceVariables 
  472.                             (:merge-instvars superClassInstvars
  473.                                              #IinstanceVariables))
  474.                       (setf #Imethods ())    
  475.                       (:install-methods self methods)
  476.                       self))
  477.              
  478. addMethod ((selector implementation)
  479.               (unless (and (variablep selector) (consp (cdr implementation)))
  480.                 (error "{Class}:addMethod" 
  481.                                :badmethdef (list selector implementation)))
  482.  
  483.                (let* ( (name         (get-abbrev #Iname))
  484.                         (functionName (symbol name selector)) )
  485.                       (apply 'defun (cons functionName
  486.                                           (:as-method implementation
  487.                                                       #IinstanceVariables
  488.                                                       #CinstanceVariables
  489.                                                       name)))
  490.                       (setf #Imethods (nconc #Imethods 
  491.                                              (list selector functionName)))))
  492.  
  493. name (()        #Iname)
  494.  
  495. superClass (()        #IsuperClass)
  496.  
  497. instanceVariables (()    #IinstanceVariables)
  498.  
  499. methods (()        #Imethods)
  500.  
  501. inheritsFrom ((aClass)
  502.           ;; -----------------------------------------------
  503.               ;; Answer t if the receiver inherits from aClass
  504.               ;; Implementation note:
  505.               ;;    without the test (equal aClass {Class})
  506.               ;;    this method loops forever due to the
  507.               ;;    reflexive nature of {Class}.
  508.           ;; -----------------------------------------------
  509.         (unless (or (equal aClass {Class}) [aClass isKindOf {Class}])
  510.                         (error "{Class}:inheritsFrom" :notaclass aClass))
  511.                 [self inheritsFromClass aClass])
  512.  
  513. inheritsFromClass ((aClass)
  514.             (or (eq #Iname [aClass name])
  515.                             (when #IsuperClass
  516.                                   [#IsuperClass inheritsFromClass aClass])))
  517.  
  518. showImplementationOf ((methodName)
  519.             (with ( (plist ':temp #Imethods) )
  520.                               (funcall 'print (valfn (getprop ':temp methodName)))))
  521.  
  522. ;prin (()        (prin "{" #Iname "}"))
  523.  
  524. )]
  525.  
  526. ;;; ---------------------------------------------------------------------------
  527. ;;; Attempt to integrate primitive objects...
  528. ;;; ---------------------------------------------------------------------------
  529.  
  530. [{Class} new
  531.       'name            'MetaPrimitiveObject
  532.           'superClass        {Class}
  533.           'instanceVariables    '(primitiveAllocator)
  534.           'methods        '(
  535.  
  536. new ( inits    (apply #IprimitiveAllocator inits))
  537.  
  538. primitiveAllocator ( userAllocator
  539.              ;; -----------------------------------------------
  540.                      ;; If <userAllocator> is provided, set primitive
  541.                      ;; allocator to that function, else answer the
  542.                      ;; value of the current primitive allocator.
  543.              ;; -----------------------------------------------
  544.                          (if userAllocator
  545.                 (setf #IprimitiveAllocator (car userAllocator))
  546.                             ;;ELSE
  547.                             #IprimitiveAllocator))
  548.  
  549. )]
  550.            
  551. [{MetaPrimitiveObject} new
  552.     'name               'symbol
  553.         'primitiveAllocator        '(lambda inits
  554.                                 (if inits
  555.                                                 (apply 'symbol inits)
  556.                                                 ;;ELSE
  557.                                                 (gensym)))]
  558.                                    
  559. [{MetaPrimitiveObject} new
  560.     'name               'string
  561.         'primitiveAllocator        '(lambda inits
  562.                                 (if inits
  563.                                                 (apply 'makestring inits)
  564.                                                 ;;ELSE
  565.                                                 (copy "")))]
  566.             
  567. [{MetaPrimitiveObject} new
  568.     'name               'vector
  569.         'primitiveAllocator        '(lambda inits
  570.                                 (if inits
  571.                                                 (apply 'makevector inits)
  572.                                                 ;;ELSE
  573.                                                 (makevector 0 ())))]
  574. [{MetaPrimitiveObject} new
  575.     'name               'cons
  576.         'primitiveAllocator        '(lambda inits
  577.                                 (if inits
  578.                                                 (apply 'makelist inits)
  579.                                                 ;;ELSE
  580.                                                 ()))]
  581.             
  582. [{MetaPrimitiveObject} new
  583.     'name               'float
  584.         'primitiveAllocator        '(lambda inits
  585.                                 (if inits
  586.                                                 (apply 'float inits)
  587.                                                 ;;ELSE
  588.                                                 0.))]
  589.             
  590. [{MetaPrimitiveObject} new
  591.     'name               'fix
  592.         'primitiveAllocator        '(lambda inits
  593.                                 (if inits
  594.                                                 (apply 'fix inits)
  595.                                                 ;;ELSE
  596.                                                 0))]
  597.             
  598. [{MetaPrimitiveObject} new
  599.     'name               'null
  600.         'primitiveAllocator        '(lambda inits ())]
  601.