;;; -*- logo -*-
;;;
;;; LOOPS -- ucbLogo Object Oriented Programming System --
;;;
;;; ... a pretentious name for a short Berkeley Logo initializing file
;;; that makes it feasible to apply principles described in Scheme and
;;; the Art of Programming.


;;;; LOOPS

;;; object compiler

to object.maker [:&args&]
local [&proc& proc.&text &static& var.&list var.&tmp val.&list &lambda&
              &optional& formal.&names &locals& init.&static &formals&
              &method& &binding& &class&]
make "&class& first :&args& make "&args& bf :&args&
make "proc.&text text :&class&
;; parsing class optional formal parameters & binding arguments
;; most of this is done by Logo parser -- the only intervention is:
;; extracting formal names and stripping default input numbers,
;; which make no sense in this context
make "formal.&names filter [[&x] [op not.tf numberp :&x]] map [
   [&x] [(if.tf listp :&x [op first :&x] [op :&x])]] first :proc.&text
local :formal.&names
define "&optional& fput first :proc.&text [[op map "thing :formal.&names]]
(foreach apply "&optional& :&args& :formal.&names [[&a &f] [make :&f :&a]])
er (list "&optional&)
;; inheritance
if.tf equalp first first bf :proc.&text "inherit.from [
   run lput quoted :&class& first bf :proc.&text
   make "proc.&text bf :proc.&text]
;; temporary -- compile time bindings
make "proc.&text bf :proc.&text
make "&binding& first :proc.&text
(while [not (or [equalp first :&binding& "static]
                [equalp first :&binding& "lambda]
                [emptyp bf :proc.&text])]
       [run :&binding& make "proc.&text bf :proc.&text
            make "&binding& first :proc.&text])
;; setting up static storage
make "var.&list []
make "&static& first :proc.&text
;; checking for top-level object
if.tf not namep "unq.&object.name [
   local [unq.&object.name method.&stack export.&stack]
   make "unq.&object.name gensym
   make "method.&stack []
   make "export.&stack []]
make "&proc& (word :unq.&object.name ". gensym ". :&class&)
er lput (list :&proc&) [[] []]
bury lput (list :&proc&) [[] []]
(while [equalp first :&static& "static]
       [;; get names
       make "var.&tmp firsts last :&static&
       ;; get values & push method name if keyword "method.export found
       make "val.&list (map [
          [&x &y]
          [if.tf equalp first first :&x "method.export
                 [push "method.&stack :&y]]
          [op begin :&x]] bfs last :&static& :var.&tmp)
       ;; bind name-value pairs
       (foreach :var.&tmp :val.&list [[&r &l] [pprop :&proc& :&r :&l]])
       make "var.&list se :var.&list :var.&tmp
       ;; making bindings visible in next STATIC line during compile
       ;; time -- that's why all these &&&...
       local :var.&tmp
       (foreach :var.&tmp :val.&list [[&r &l] [make :&r :&l]])
       ;; try next static line
       make "proc.&text bf :proc.&text
       make "&static& first :proc.&text])
;; mandatory LAMBDA line
make "&lambda& first :proc.&text
if not (and [equalp first :&lambda& "lambda]
            [equalp first last :&lambda& ":]) [
               (pr [ERROR: Missing or incorrect LAMBDA line in:] :&class&)
               pr :&lambda&
               pr [it should look like this:]
               pr [lambda :messagename]
               throw "toplevel]
;; building object
make "&locals& list "local :var.&list
make "init.&static map.se [
   [&var]
   [op (list "make word "" :&var "gprop word "" :&proc& word "" :&var)]
] :var.&list
;; stripping column from message name
make "&formals& (list bf last :&lambda&)
;; compiling methods
make "&method& (reduce [[x y] [op (word :x ". :y)]]
                       lput "&method bl split.word :&class& ".)
if.tf or memberp :&class& :.accept.method [not definedp :&method&] [
   define :&method& compile.object fput [] insert.method bf :proc.&text
   bury :&method&
   make ".accept.method remove :&class& :.accept.method]
;; compiling object
op compile.object (fput :&formals& fput :&locals& fput :init.&static
                        (list (list "op char 40 ".and
                                    (list ".maybeoutput :&method&) char 41 )))
end

;;; auxiliary procedures

;; exporting methods from subclass
.macro method.export :class.list :method.text
foreach :class.list [[&x] [push "export.&stack :&x]]
op (list insert.invoke :method.text)
end

;; checking method before compilation
to insert.method :text
if.tf emptyp :method.&stack [op :text]
if.tf not.tf memberp :&class& :export.&stack [op :text]
if.tf not.tf listp :text [op :text]
op insert.invoke :text
end

to delegate :object :msg
if.tf definedp :object [op invoke :object :msg]
op invoke thing :object :msg
end

;; unsafe send -- for uniform syntax 'send "objectname ...'
to send [:msg.list] 2
op send.helper first :msg.list
end

to send.helper :send.object
if.tf listp :send.object ~
      [op apply :send.object (list (fput :send.object bf :msg.list))]
if.tf definedp :send.object ~
      [op apply :send.object (list (fput :send.object bf :msg.list))]
op send.helper thing :send.object
end

;; indirect addressing -- all storage classes should understand
;; message indirect
to indirect [:message] 2
op apply "send (fput send first :message "indirect bf :message)
end

;; used in DO messages -- gets the value of the object
to #self
op send "self "self
end

;; pacifying Logo 5beta
to static :ignore
end

;; pacifying Logo 5beta
to lambda
pr [ERROR: You probably tried to execute 'somename.class' procedure]
pr [USAGE: define "objectname (object.maker "somename.class [initexp ...])]
pr [|     |: then send messages ... (send "objectname "somemessage ...)]
throw "toplevel
end

;; defining top-level object -- need the object name
to new :object.name :definition
define :object.name :definition
push "loops.object.stack :object.name
end

make "loops.object.stack []

;; Emacs IDE procedures
to inspect.methods.objects :file_elisp_code
local [o.prop]
localmake "wr_elisp_code writer
localmake "printwidthlimit 2048
localmake "printdepthlimit 16
openwrite :file_elisp_code
setwrite :file_elisp_code
pr "COMPILED-METHODS:
pr []
pr filter [equalp "&method last split.word ? ".] first buried
pr []
pr "TOP-LEVEL-OBJECTS:
pr []
make "loops.object.stack filter [not memberp ? ?rest] :loops.object.stack
pr (se "base.object "loops :loops.object.stack)
pr []
pr "VIRTUAL-OBJECTS:
pr []
make "o.prop filter [make "o.prop split.word ? ".
                          (and equalp first first :o.prop "g
                               [numberp last first :o.prop] 
                               [equalp last :o.prop "class])] last buried
if not emptyp :o.prop [foreach objects.group :o.prop [pr ? pr []]]
close :file_elisp_code
setwrite :wr_elisp_code
end


to objects.group :lst
if.tf emptyp bf :lst [op (list :lst)]
local [first result]
make "first first :lst make "result objects.group bf :lst
if.tf (equalp (first split.word :first ".)
              (first split.word first bf :lst ".)) ~
              [op fput fput :first first :result bf :result]
op fput (list :first) :result
end

to show.method.object :method :file_elisp_code [:pretty "false] 3
localmake "wr_elisp_code writer
localmake "printwidthlimit 2048
localmake "printdepthlimit 64
openwrite :file_elisp_code
setwrite :file_elisp_code
ifelse.tf definedp :method [
   foreach fulltext :method [pr ?]] [
      ;localmake "virtual.o plist :method
      local "virtual.o
      make "virtual.o plist :method
      ifelse.tf :pretty [
         localmake "template
         [[x y] [show (list "localmake word "\" :x quoted :y)]]] [
            localmake "template [[x y] [show list :x :y]]]
      (foreach filter [oddp count ?rest] :virtual.o
               filter [evenp count ?rest] :virtual.o
               :template)]
close :file_elisp_code
setwrite :wr_elisp_code
end

; to show.method.object :method :file_elisp_code [:pretty "false] 3
; localmake "wr_elisp_code writer
; localmake "printwidthlimit 2048
; localmake "printdepthlimit 64
; openwrite :file_elisp_code
; setwrite :file_elisp_code
; ifelse.tf definedp :method [
;    foreach fulltext :method [pr ?]] [
;       ;localmake "virtual.o plist :method
;       local "virtual.o
;       make "virtual.o plist :method
;       ifelse.tf :pretty [
;          localmake "template
;          [[x y] [show (list "localmake word "\" :x quoted :y)]]] [
;             localmake "template [[x y] [show list :x :y]]]
;       (foreach filter [oddp count ?rest] :virtual.o
;                filter [evenp count ?rest] :virtual.o
;                :template)]
; close :file_elisp_code
; setwrite :wr_elisp_code
; end

to browse.classes :file_elisp_code
localmake "wr_elisp_code writer
localmake "printwidthlimit 2048
localmake "printdepthlimit 16
openwrite :file_elisp_code
setwrite :file_elisp_code
(foreach filter [evenp count ?rest] plist "inherit.list
         filter [oddp count ?rest] plist "inherit.list
            [[from to]
             [pprop "inheritance.tree "inherit
                   insert.tree :from :to gprop "inheritance.tree "inherit]])
inherit gprop "inheritance.tree "inherit "
erase [[] [] [inherit.list]]
close :file_elisp_code
setwrite :wr_elisp_code
end

to inherit :tree :level
if.tf emptyp :tree [stop]
if.tf wordp :tree [(pr :level :tree) stop]
inherit first :tree word :level char 9
inherit bf :tree :level
end

to inherit.from :from :to
pprop "inherit.list :to :from
end

to insert.tree :from :to :tree
if.tf or emptyp :tree [wordp :tree] [op :tree]
if.tf and equalp :from first :tree [not.tf memberp :to apply "se bf :tree] [
   op fput :from fput (list :to) bf :tree]
op fput insert.tree :from :to first :tree insert.tree :from :to bf :tree
end

to edit.classes :class :file_elisp_code
localmake "wr_elisp_code writer
localmake "printwidthlimit 2048
localmake "printdepthlimit 64
openwrite :file_elisp_code
setwrite :file_elisp_code
if.tf definedp :class [
   foreach fulltext :class [pr ?]]
close :file_elisp_code
setwrite :wr_elisp_code
end

to save.image [
   :filename& .and [type "|Enter file name (without extension) to save to: |] 
   [rw]] 1
bury (list [] (list "filename& "startup "printdepthlimit
                    "printwidthlimit "bury.list) [])
;; Structures will print to 2048 elements. This is a sefeguard for circular
;; list objects.
localmake "printwidthlimit 2048
localmake "printdepthlimit 1024
make "bury.list buried
make "startup [
   bury :bury.list (type "|Image: |  last split.word :filename& "/ "| loaded.| )]
if equalp first :filename& "" [make "filename& bf :filename&]
if equalp last split.word :filename& ". "lgimg [
   make "filename& apply "word bl split.word :filename& ".]
savel (map "se contents buried) word :filename& ".lgimg
end

;; Redefining method procedure?
make ".accept.method []

bury [[static.make object.maker delegate send send.helper base.object new
                   static lambda insert.method.h insert.method method.export
                   indirect #self inspect.methods.objects objects.group
                   show.method.object edit.classes save.image browse.classes
                   loops inherit inherit.from insert.tree]
      [.accept.method loops.object.stack] [inherit.list]]

;;; base classes

;; Base object -- source commented out, only compiled code loaded
; to base.object :message
; local [object msg]
; make "object first :message
; make "msg bf :message
; op letrec [[
;    [get.sym [[txt]
;              [condc [
;                 [[emptyp :txt] [op "#unspecified]]
;                 [[equalp first :txt "gprop]
;                  [op first split.word bf first bf :txt ".]]
;                 [else [op (get.sym bf :txt)]]]]]]]
;            [case [
;               [first :msg]
;               [[type] [op "base.object]]
;               [[erase.object]
;                [localmake "symbol
;                           (get.sym apply "se bf bf text :object)]
;                [localmake "statics filter
;                           [[x] [op equalp :symbol first split.word :x ".]]
;                           last buried]
;                [er lput :statics [[] []]]
;                [if not equalp :object "base.object [er (list :object)]]
;                [make "loops.object.stack remove :object :loops.object.stack]
;                [gc op nodes]]
;               [[error]
;                [(apply "pr combine "ERROR:\  bf :msg)]
;                [throw "toplevel]]
;               [else [(pr "ERROR: :msg "not "understood "by "object: :object)]
;                     [throw "toplevel]]]]]
; end

; to loops :message
; case [
;    [first bf :message]
;    [[new global]
;     [define first bf bf :message apply "object.maker bf bf bf :message]
;     [push "loops.object.stack first bf bf :message]
;     [op first bf bf :message]]
;    [[virtual local] [op apply "object.maker bf bf :message]]
;    [[erase.methods]
;     [erase filter [equalp last split.word ? ". "&method] first buried]
;     [gc op nodes]]
;    [else [op delegate "base.object :message]]]
; end

;; All classes requiring static storage (which is just about all),
;; should use (dotted)pair.class as the only link to static variables.
to pair.class :xinit [:yinit []] 
local "cons.cell
make "cons.cell (list :xinit) .setbf :cons.cell :yinit 
static [[pair.o :cons.cell]]
lambda :msg
op case [
   [first bf :msg]
   [[get getx self indirect] [first :pair.o]]
   [[set setx make] [.setfirst :pair.o first bf bf :msg first :pair.o]]
   [[gety] [bf :pair.o]]
   [[sety] [.setbf :pair.o first bf bf :msg bf :pair.o]]
   [[raw] [:pair.o]]
   [[p2l] [list first :pair.o bf :pair.o]]
   [[type] ["dotted.pair.object]]
   [else [delegate "base.object :msg]]]
end

;; swap.pair based on pair.class
to swap.pair.class :xinit [:yinit []] 
static [[pair.o [(send "loops "virtual "pair.class :xinit :yinit)]]]
lambda :msg
local "tmp
op case [
   [first bf :msg]
   [[swap]
    [make "tmp send "pair.o "gety]
    [ignore (send "pair.o "sety send "pair.o "get)]
    [(send "pair.o "set :tmp)]]
   [[type] ["swap.pair.object]]
   [else [delegate "pair.o :msg]]]
end

;; border.class is used to create terminal objects, that can stop execution,
;; and extract results by sending messages to other objects
to border.class :text [:objects []] [:msgs []]
static [[text.o [(send "loops "virtual "pair.class :text)]]
        [objmsg.pairs [(send "loops "virtual "pair.class :objects :msgs)]]]
lambda :message
local [self msg]
make "self first :message make "msg bf :message
case [
   [first :msg]
   [[exit.outer] [op "false]]
   [[erase.object] [op delegate "base.object :msg]]
   [else [
      ;; output text and all results of terminal object msg calls
      ;; use 'self to send msg 'exit.outer to border.class object -- as a
      ;; flag to break out of the outer loop (see queens8.class)
      op se send "text.o "get ~
      (map [[x y] [op apply "send se :x :y]]
           send "objmsg.pairs "get send "objmsg.pairs "gety)]]]
end

;; simple counter
to counter.class :init
if not numberp :init [(send "base.object "error
                            [Input must be a number!])]
static [[init.val :init]
        [pair.o [(send "loops "virtual "pair.class :init)]]]
lambda :msg
op case [
   [first bf :msg]
   [[inc] [(send "pair.o "set sum (send "pair.o "get) 1)]]
   [[dec] [(send "pair.o "set (send "pair.o "get) - 1)]]
   [[reset] [(send "pair.o "set :init.val)]]
   [[type] ["counter.object]]
   [else [delegate "pair.o :msg]]]
end

;; circular counter init -> limit , init -> limit ...
to rewinding.counter.class :init :limit
if not numberp :limit [(send "base.object "error
                            [Input must be a number!])]
static [[init.val :init] [rewind :limit]
        [counter.o [(send "loops "virtual "counter.class :init)]]]
lambda :msg
case [
   [first bf :msg]
   [[inc] [op ifelse (send "counter.o "get) < :rewind
                     [(send "counter.o "inc)]
                     [(send "counter.o "reset)]]]
   [[type] [op "rewinding.counter.object]]
   [[dec] [op delegate "base.object :msg]]
   [else [op delegate "counter.o :msg]]]
end

;; container word/list
to container.class :init
static [[container.o [(send "loops "virtual "pair.class :init)]]]
lambda :message
local [msg self]
make "msg bf :message make "self first :message
op case [
   [first :msg]
   [[bf butfirst]
    [ignore (send "container.o "sety first send "container.o "get)]
    [(send "container.o "set bf send "container.o "get)]]
   [[bl butlast]
    [ignore (send "container.o "sety last send "container.o "get)]
    [(send "container.o "set bl send "container.o "get)]]
   [[first last count pick empty? emptyp]
    [invoke :#target send "container.o "get]]
   [[word se sentence]
    [(send "self "do! fput word "\( :#target lput "\) first bf :msg)]]
   [[do] [run first bf :msg]]
   [[do!] [(send "self "set (send "self "do first bf :msg))]]
   [[item member? memberp member]
    [(invoke :#target first bf :msg send "container.o "get)]]
   [[listp list? wordp word?] [(invoke :#target send "container.o "self)]]
   [[flush]
    [(send "container.o "set ifelse listp send "container.o "get [[]] ["])]]
   [[type] ["container.object]]
   [else [delegate "container.o :message]]]
end

;; word class
to word.class [:init "]
if not wordp :init [
   (send "base.object "error [Input must be a word!])]
static [[word.o [(send "loops "virtual "container.class :init)]]]
lambda :msg
op case [
   [first bf :msg]
   [[type] ["word.object]]
   [else [delegate "word.o :msg]]]
end

;; list class
to list.class [:init []]
if not listp :init [
   (send "base.object "error [Input must be a list!])]
static [[list.o [(send "loops "virtual "container.class :init)]]]
lambda :msg
op case [
   [first bf :msg]
   [[fput lput]
    [(send "list.o "set
           (invoke :#target first bf bf :msg send "list.o "self))]]
   [[type] ["list.object]]
   [else [delegate "list.o :msg]]]
end

;; FILO structure based on list class
to stack.class
static [[holder.o [(send "loops "virtual "list.class)]]]
lambda :msg
op case [
   [first bf :msg]
   [[push] [(send "holder.o "fput first bf bf :msg)]]
   [[pop]
    [ifelse.tf send "holder.o "empty?
               [(send "holder.o "error [Stack is empty])]
               [ignore send "holder.o "bf send "holder.o "gety]]]
   [[top]
    [ifelse.tf send "holder.o "empty?
               [(send "holder.o "error [Stack is empty])]
               [send "holder.o "first]]]
   [[size] [send "holder.o "count]]
   [[type] ["stack.object]]
   [else [delegate "holder.o :msg]]]
end

;; double ended list class
to double.end.class [:init []]
if not listp :init [(send "base.object "error
                          [Input must be a list!])] 
static [[cell.o [
   (send "loops "virtual "pair.class :init ifelse emptyp :init
                 [:init]
                 [last.pair :init])]]]
lambda :message
local [msg self tmp]
make "msg bf :message make "self first :message
case [
   [first :msg]
   [[lput]
    [make "tmp (list first bf :msg)]
    [ifelse.tf emptyp send "cell.o "get
               [ignore (send "cell.o "set :tmp)]
               [.setbf (send "cell.o "gety) :tmp]]
    [op (send "cell.o "sety :tmp)]]
   [[first indirect] [op first send "cell.o "get]]
   [[bf butfirst] [op (send "cell.o "set bf send "cell.o "get)]]
   [[last] [op first send "cell.o "gety]]
   [[empty? emptyp] [op emptyp send "cell.o "get]]
   [[fput]
    [if.tf emptyp send "cell.o "get
           [op (send "self "lput first bf :msg)]]
    [make "tmp (list first bf :msg)]
    [.setbf :tmp send "cell.o "get]
    [op (send "cell.o "set :tmp)]]
   [[import]
    [ignore (send "cell.o "sety last.pair fput "x first bf :msg)]
    [op (send "cell.o "set first bf :msg)]]
   [[bl butlast] [op (send "self "import bl send "cell.o "get)]]
   [[count] [op count send "cell.o "get]]
   [[flush] [op (send "self "import [])]]
   [[member? memberp]
    [op memberp first bf :msg send "cell.o "get]]
   [[member] [op member first bf :msg send "cell.o "get]]
   [[shift.left]
    [make "tmp first send "cell.o "get]
    [ignore send "self "bf]
    [ignore (send "self "lput :tmp)]
    [op send "cell.o "get]]
   [[shift.right]
    [make "tmp first send "cell.o "gety]
    [ignore send "self "bl]
    [op (send "self "fput :tmp)]]
   [[export self] [op map "identity send "cell.o "get]]
   [[type] [op "double.ended.list.object]]
   [else [op delegate "cell.o :message]]]
end

;; queue based on double ended class
to queue.class
static [[del.o [(send "loops "virtual "double.end.class)]]]
lambda :message
local [tmp msg self]
make "msg bf :message make "self first :message
case [
   [first :msg] 
   [[enqueue] [op first (send "del.o "lput first bf :msg)]]
   [[dequeue]
    [make "tmp send "self "front]
    [ignore send "del.o "bf]
    [op :tmp]]
   [[front]
    [if.tf send "del.o "empty? [(send "del.o "error [queue is empty])]]
    [op send "del.o "first]]
   [[type] [op "queue.object]]
   [[lput fput bf butfirst bl butlast first last shift.left shift.right]
    [op delegate "base.object :message]]
   [else [op delegate "del.o :message]]]
end

;; circular list storage
to circular.class
static [[pointer [[mark]]]]
static [[start.o [localmake "cl (list :pointer) .setbf :cl :cl]
                 [(send "loops "virtual "pair.class :cl)]]]
static [[end.o [(send "loops "virtual "pair.class (send "start.o "get))]]]
lambda :message
local [tmp msg self]
make "msg bf :message make "self first :message
op letrec [[
   [open [[]
          [.setbf (send "end.o "get) []]
          [op (send "start.o "get)]]]
   [close [[]
           [.setbf (send "end.o "get) (send "start.o "get)]
           [op (send "start.o "get)]]]
   [bl.pair [[clst]
             [if.tf .eq first bf bf :clst :pointer [op :clst]]
             [op (bl.pair bf :clst)]]]]
           [case [
              [first :msg]
              [[lput]
               [make "tmp (send "end.o "get)]
               [.setbf :tmp (list first bf :msg)]
               [.setbf bf :tmp (send "start.o "get)]
               [op bf (send "end.o "set bf :tmp)]]
              [[fput]
               [make "tmp bf (send "start.o "get)] 
               [.setbf (send "start.o "get) (list first bf :msg)] 
               [.setbf bf (send "start.o "get) :tmp]
               [if.tf .eq first (send "end.o "get) :pointer [
                  ignore (send "end.o "set bf (send "start.o "get))]]
               [op (send "start.o "get)]]
              [[bf butfirst]
               [.setfirst (send "start.o "set bf (send "start.o "get))
                          :pointer]
               [make "tmp (send "start.o "get)]
               [.setbf (send "end.o "get) :tmp]
               [op :tmp]]
              [[bl butlast]
               [make "tmp (send "start.o "get)]
               [.setbf (send "end.o "set (bl.pair bf :tmp)) :tmp]
               [op :tmp]]
              [[first indirect] [op first bf (send "start.o "get)]]
              [[last] [op first (send "end.o "get)]]
              [[empty? emptyp]
               [op .eq first bf (send "start.o "get) :pointer]]
              [[count]
               [make "tmp  count bf (open)]
               [ignore (close)]
               [op :tmp]]
              [[export]
               [make "tmp map "identity bf (open)]
               [ignore (close)]
               [op :tmp]]
              [[import]
               [make "tmp (send "start.o "set fput :pointer first bf :msg)]
               [.setbf (send "end.o "set last.pair :tmp) :tmp]
               [op (send "self "export)]]
              [[flush] [op (send "self "import [])]]
              [[memberp member?]
               [make "tmp  memberp first bf :msg bf (open)]
               [ignore (close)]
               [op :tmp]]
              [[member] [op member first bf :msg (send "self "export)]]
              [[rotate]
               [make "tmp first bf (send "start.o "get)]
               [.setfirst bf (send "start.o "get) :pointer]
               [.setfirst (send "start.o "get) :tmp]
               [ignore (send "end.o "set (send "start.o "get))]
               [op (send "start.o "set bf (send "start.o "get))]]
              [[type] [op "circular.list.object]]
              [[set] [op delegate "base.object :message]]
              [else [op delegate "start.o :message]]]]]
end

;; Inheritance tree

pprop "inheritance.tree "inherit [pair.class [swap.pair.class] [counter.class [rewinding.counter.class]] [container.class [word.class] [list.class [stack.class]]] [double.end.class [queue.class]] [border.class] [circular.class]]

bury [[counter.class rewinding.counter.class queue.class
                     container.class list.class word.class stack.class
                     circular.class pair.class swap.pair.class
                     double.end.class border.class]
      [] [inheritance.tree]]

;;; compiled code

to base.object :message
local [object msg]
make "object first :message
make "msg bf :message
op run [local "get.sym make "get.sym [[txt] [run [if.tf emptyp :txt [op "#unspecified] if.tf equalp first :txt "gprop [op first split.word bf first bf :txt ".] op ( invoke :get.sym bf :txt )]]] local "dummy.letrec make "dummy.letrec [[] [run [local "#target make "#target run [first :msg] ifelse.tf memberp :#target [type] [op "base.object] [ifelse.tf memberp :#target [erase.object] [localmake "symbol ( invoke :get.sym apply "se bf bf text :object ) localmake "statics filter [[x] [op equalp :symbol first split.word :x ".]] last buried er lput :statics [[] []] if not equalp :object "base.object [er ( list :object )] make "loops.object.stack remove :object :loops.object.stack gc op nodes] [ifelse.tf memberp :#target [error] [( apply "pr combine "ERROR\:\  bf :msg ) throw "toplevel] [( pr "ERROR: :msg "not "understood "by "object: :object ) throw "toplevel]]]]]] run [( invoke :dummy.letrec )]]
end

to loops :message
run [local "#target make "#target run [first bf :message] ifelse.tf memberp :#target [new global] [define first bf bf :message apply "object.maker bf bf bf :message push "loops.object.stack first bf bf :message op first bf bf :message] [ifelse.tf memberp :#target [virtual local] [op apply "object.maker bf bf :message] [ifelse.tf memberp :#target [erase.methods] [erase filter [equalp last split.word ? ". "&method] first buried gc op nodes] [op delegate "base.object :message]]]]
end

bury [[base.object loops loops.compiler] [] []]

pr "| OOP layer OK|

;;; End of .LOOPS