-
-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathroot.lisp
118 lines (102 loc) · 3.99 KB
/
root.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: FMCS -*-
(in-package :fmcs)
#+sbcl
(named-readtables:in-readtable :fare-quasiquote)
;;; --------------------------------------------------------------------------
;;; Hand coded object standard-class
;;; --------------------------------------------------------------------------
(setq STANDARD-CLASS
(make-mcsobject
:env
(vector
'isit ; :isit will be set below
'standard-class ; :name
nil ; :supers
nil ; :cplist
'(isit ; :all-slots
name supers cplist all-slots all-slot-defaults own-slots
methods basicnew-fn slot-accessor-fn subclasses)
'((name nil) ; :all-slot-defaults
(supers nil)(cplist nil)(all-slots nil)(all-slot-defaults nil)
(own-slots nil)(methods (make-hash-table :test #'eq))
(basicnew-fn nil)(slot-accessor-fn nil) (subclasses nil))
'(name ; :own-slots
supers cplist all-slots all-slot-defaults own-slots
methods basicnew-fn slot-accessor-fn subclasses)
(make-hash-table :test #'eq) ; :methods
; :basicnew-fn
#'(lambda (isit &key (name nil) (supers nil) (own-slots nil))
(send-fast
(make-mcsobject
:env
(vector isit name supers nil nil nil own-slots
(make-hash-table :test #'eq)
nil nil nil))
:init name supers own-slots))
; :slot-accessor-fn
#'(lambda (slot)
(case slot
(isit (index-of-isit))
(name (index-of-name))
(supers (index-of-supers))
(cplist (index-of-cplist))
(all-slots (index-of-all-slots))
(own-slots (index-of-own-slots))
(all-slot-defaults (index-of-all-slot-defaults))
(methods (index-of-methods))
(basicnew-fn (index-of-basicnew-fn))
(slot-accessor-fn (index-of-slot-accessor-fn))
(subclasses (index-of-subclasses))
(t (error "no slot"))))
nil ; :subclasses
)))
;;; Slot 'isit of standard-class have to be set to itself
(setf (svref (mcs-env standard-class) (index-of-isit)) standard-class)
;;; ---- INSTANCE CREATOR METHOD ----
(defmethod (standard-class :new) (&rest inits)
(apply (mcs-get-slot inst-env (index-of-basicnew-fn))
self inits))
;;; ---- INITIALIZE METHOD ----
(defmethod (standard-class :init) (&rest inits)
(declare (ignore inits))
(send-self :compute-cplist)
(send-self :inherit-slots-with-defaults)
(send-self :compute-slot-accessor-fn)
(send-self :extend-subclasses-of-supers)
(send-self :compute-slot-access-methods)
(send-self :compute-basicnew-fn)
self)
;;; --------------------------------------------------------------------------
;;; Hand coded object standard-object
;;; --------------------------------------------------------------------------
(setq STANDARD-OBJECT
(make-mcsobject
:env
(vector
standard-class ; :isit
'standard-object ; :name
nil ; :supers
nil ; :cplist
'(isit) ; :all-slots
nil ; :all-slot-defaults
'(isit) ; :own-slots
(make-hash-table :test #'eq) ; :methods
#'(lambda (isit) ; :basicnew-fn
(send-fast
(make-mcsobject :env (vector isit))
:init))
#'(lambda (slot) ; :slot-accessor-fn
(case slot
(isit (index-of-isit))
(t (error "no slot"))))
(list standard-class) ; :subclasses
)))
(setf (slot-value standard-object 'cplist) (list standard-object))
(setf (slot-value standard-class 'supers) (list standard-object))
(setf (slot-value standard-class 'cplist) (list standard-class standard-object))
;;; ---- INITIALIZE METHOD ----
(defmethod (standard-object :init) (&rest inits)
(declare (ignore inits))
self)
#+sbcl
(named-readtables:in-readtable :standard)