;======================================================================== ; ; NLoops ; ;======================================================================== ;----------------------------------- ; declarations ;----------------------------------- extensions [table array] globals [ #objects ; the table of all class & instance data #stack ; the stack for runtime stack frames (now implemented as array) #sptr ; the stack ptr #nil ; a constant #debug# ; switch used to turn on/off debugging during development ] ;----------------------------------- ; basic utils ;----------------------------------- ; note for existing users: some of these were previously ; bundled in our NLutils.nls file ; ; debug utility for development ; to #debug [#str#] ; if the #debug# global is true if #debug# [ print #str# ] ; messages will be printed, if it is end ; false they are not printed ; ; a compromise approach to throwing an error ; to #error [#str# #stuff#] ; NL doesn't have an error primitive set #sptr 0 ; so this is a compromise print "#ERROR" ; clean up the NLoops stack, print (word "#ERROR: " #str# " - " #stuff#) ; print a suitable mesage then trip print "#ERROR" ; some kind of NL error run "LOOPS-ERROR:_check_output_for_details" end ; ; make a deep copy of a (nested) list ; to-report #copy-list [#a#] let #b# [] foreach #a# [ ifelse (is-list? ?) [ set #b# (lput (#copy-list ?) #b#) ] [ set #b# (lput ? #b#) ] ] report #b# end ; ; print the #objects table ; to #show-objects foreach (table:keys #objects) [ print (word ? " ==> " (table:to-list (table:get #objects ?))) print "" ] end ; ; take value of variable named in string ; eg if X = 5, then (#valof "X") -> 5 ; to-report #valof [var-string] report runresult var-string end ; ; test for null ; to-report #null? [#x#] report ( #x# = [] ) end ;----------------------------------- ; string utilities ;----------------------------------- ; ; returns a string with the leading/trailing spaces removed ; to-report #trim [#str#] while [ (first #str#) = " " ] [ set #str# (but-first #str#) ] while [ (last #str#) = " " ] [ set #str# (but-last #str#) ] report #str# end ; ; get the first substr delimited by token ; eg: if S = "cat.dog" then (#first-str S ".") -> "cat" ; to-report #first-str [#str# #tok#] ifelse (member? #tok# #str#) [ let #p# (position #tok# #str#) report substring #str# 0 #p# ] [ report #str# ] end ; ; get the rest of substr delimited by token ; eg: if S = "cat.dog" then (#rest-str S ".") -> "dog" ; to-report #rest-str [#str# #tok#] ifelse (member? #tok# #str#) [ let #p# (position #tok# #str#) + (length #tok#) report substring #str# #p# (length #str#) ] [ report #str# ] end ; ; returns true/false for 'dotted' str ; like "class.method" ; to-report #dotted? [#str#] report (member? "." #str#) end ;----------------------------------- ; accessors ;----------------------------------- ; ; get class/instance with given name ; to-report #get-object report table:get #objects #whoami end ; ; get slot, inheriting if necessary ; to-report #get-slot [#obnam# #slot#] ;; #debug (word "GET: obnam=" #obnam# ", slot=" #slot#) if (#obnam# = #nil) [report #nil] let #obj# table:get #objects #obnam# ifelse (table:has-key? #obj# #slot#) [ report table:get #obj# #slot# ] [ report (#get-slot (table:get #obj# "#class") #slot#) ] end ; ; set-slot, going up class hierarchy if necessary ; to #set-slot [#obnam# #slot# #val#] if (#obnam# = #nil) [ #error "cannot do set-slot using" (list #slot# #val#) ] let #obj# table:get #objects #obnam# ifelse (table:has-key? #obj# #slot#) [ table:put #obj# #slot# #val#] [ #set-slot (table:get #obj# "#class") #slot# #val# ] end ;----------------------------------- ; stack frame ;----------------------------------- ; to cope with nested method calls we need stack frame entries ; stack frames contain the following... ; slot - the name of the method called (but NB: this is only the name, not the id) ; self - the class/instance that the method was invoked on ; owner - the class that owns the method ; ; note also that def-method method descriptions in #objects contains info to ; help build stack frames, method descriptions are tables containing mapping for... ; slot - method or var name ; owner - as above ; self - as above ; ; note also: the stack used to be implemented as a list but there were big problems with ; the models slowing when the java garbage collector kicked in to #initialise-stack ;; generate a new stack of empty stack-frame tables set #sptr 0 let #stack-size 32 set #stack array:from-list n-values #stack-size [#nil] let #s# 0 repeat #stack-size [ array:set #stack #s# (table:from-list [["slot" []] ["self" []] ["owner" []]]) set #s# (#s# + 1) ] end to #push-stack-frame ; stack frame should already be prepared, see - #make-stack-frame, etc set #sptr (#sptr + 1) end to #pop-stack-frame set #sptr (#sptr - 1) end to-report #current-stack-frame report array:item #stack (#sptr - 1) end to #make-stack-frame [#owner# #self# #slot#] ;; place values in next stack frame (see note above) let #t# array:item #stack #sptr table:put #t# "owner" #owner# table:put #t# "self" #self# table:put #t# "slot" #slot# #push-stack-frame end ; ; get the NL proc name for the owner & method of the ; top stack-frame ; to-report #get-stack-frame-proc-name let #t# #current-stack-frame ;; get the proc name for the stack-frame owner report (table:get (#get-ob (table:get #t# "owner") (table:get #t# "slot")) "pname") end ;----------------------------------- ; call-strings ;----------------------------------- ; an NLoops call like: #do "m1" ["cat" 55] ; is mapped onto the string... ; "m1-proc "cat" 55" ; ; prep-args ; maps [a b c] => "a b c" ; but has to take account of string forms which ; need re-quoting ; to-report #prep-args [#args#] ifelse (is-list? #args#) [ report ifelse-value (#null? #args#) [ "" ] [ (reduce [(word ?1 " " ?2)] (map [ ifelse-value (is-string? ?) [ (word "\"" ? "\"") ] [ ? ]] #args#)) ] ] [ report (word #args#) ] end ; ; make a call string for a specified instance/owner ; to-report #make-call-str-with-owner [#who# #method# #args#] if (#dotted? #method#) [ #error "cannot use dotted slot here" #method# ] ;; make stack frame with owner & self set as #who# #make-stack-frame #who# #who# #method# report (word #get-stack-frame-proc-name " " (#prep-args #args#)) end to-report #make-anon-call-str [#method# #args#] ; ; this gets owner, self & slot infm from a method spec ; NB: to reduce garbage, etc & as convenience put owner, self & slot (where slot will ; be method or slot name) in the next stack frame. Stack ptr is not advanced yet - ; because we may be dealing witha #get or #set ; let #owner# "" let #self# "" let #slot# "" ifelse (#dotted? #method#) [ ;; form is "classname.method" set #owner# (#trim (#first-str #method# ".")) ifelse (#owner# = "super") [ let #ob# (table:get #objects (table:get #current-stack-frame "owner")) set #owner# (table:get #ob# "#class") set #self# #whoami ] [ ; owner != super set #self# #owner# ] set #slot# (#trim (#rest-str #method# ".")) ] [ ;; else not dotted set #owner# #whoami set #self# #owner# set #slot# #method# ] ;; place values in next stack frame (see note above) #make-stack-frame #owner# #self# #slot# report (word #get-stack-frame-proc-name " " (#prep-args #args#)) end ;----------------------------------- ; factories ;----------------------------------- ; ; make a new obj of stated class with initial vars ; to #add-slots [#tab# #vars#] foreach #vars# [ ifelse (is-list? ?) [ ;; assume its a var-val pair table:put #tab# (item 0 ?) (item 1 ?) ] [ ;; assume it's atomic slot name table:put #tab# ? #nil ] ] end ; ; partially make a new obj of stated class with initial vars ; to-report #make-raw-obj [#name# #class#] if not (table:has-key? #objects #class#) [ #error "super-class not found" #class# ] let #obtab# table:make ; make a table for the new obj table:put #obtab# "#name" #name# ; set its name entry table:put #obtab# "#class" #class# ; set class entry table:put #objects #name# #obtab# ; add table to #objects report #obtab# end to #build-instance [#name# #class# #slots#] let #obtab# (#make-raw-obj #name# #class#) table:put #obtab# "#type" "instance" #add-slots #obtab# (#copy-list (#get-ob #class# "#islots")) ; inherit slots from superclass ; NB: copy-list prevents vars being corrupted by different instances #add-slots #obtab# #slots# ; add the other slots let #constructor# (#get-ob #name# "constructor") ; fire the constructor if (#constructor# != #nil) ; if there is one [ #do-ob #name# "constructor" #nil] end ;----------------------------------- ; primaries ;----------------------------------- ; ; #reset-objects ; to #reset-objects set #objects table:make set #nil [] #initialise-stack set #debug# false table:put #objects #nil ;; the top superclass (simplifies stuff to have one) table:from-list [["#islots" []] ["#type" "class"]] end ; ; #def-class "super-class.class-name" [...slots...] ; to #def-class [#name# #slots#] let #class# #nil if (#dotted? #name#) [ set #class# (#first-str #name# ".") set #name# (#rest-str #name# ".") ] ;; assemble class slots & instance slots let #islots# #nil let #cslots# #nil ;; filter slots foreach #slots# [ let #s# ifelse-value (is-list? ?) [?] [ list ? #nil ] ifelse (#dotted? (first #s#)) and ((#first-str (first #s#) ".") = "class") [ ;; slot is of the form "class.name" let #new-slot# (fput (#rest-str (first #s#) ".") (but-first #s#)) set #cslots# (fput #new-slot# #cslots#) ] [ ;; slot is not dotted if (#dotted? (first #s#)) [#error "slot def not recognised" (list (first #s#))] set #islots# (fput #s# #islots#) ] ] let #obtab# (#make-raw-obj #name# #class#) ; make a table for the new obj set #islots# (sentence (#get-ob #class# "#islots") #islots#) table:put #obtab# "#name" #name# ; set its name entry table:put #obtab# "#class" #class# ; set class entry table:put #obtab# "#type" "class" table:put #obtab# "#islots" #islots# #add-slots #obtab# #cslots# ; add the other slots end ; ; #def-instance class-name.instance-name [...instance-slots...] ; to #def-instance [#name# #slots#] ; #debug (word "def-instance name=" #name# ; ", class=" #class# ", slots=" #slots# ) let #class# #nil if (member? "." #name#) [ set #class# (#trim (#first-str #name# ".")) set #name# (#trim (#rest-str #name# ".")) ] #build-instance #name# #class# #slots# end ; ; #spawn-instance class-name [...instance-slots...] ; to #spawn-instance [#class# #vars#] #build-instance who #class# #vars# end ; ; #set-method class-name.method-name proc-name ; to #set-method [#method# #val#] if (not #dotted? #method#) [ #error "incorrect method name for #def-method" (list #method#) ] let #obj# (#first-str #method# ".") set #method# (#rest-str #method# ".") let #mlis# (list (list "owner" #obj#) (list "slot" #method#) (list "pname" #val#) ) table:put (table:get #objects #obj#) #method# (table:from-list #mlis#) end ; ; #def-method class-name.method-name ; ; a simple helper so #def-method "c.m" => #set-method "c.m" "c.m" to #def-method [#method#] #set-method #method# #method# end ;----------------------------------- ; external context ;----------------------------------- to #do-ob [#who# #method# #args#] run (#make-call-str-with-owner #who# #method# #args#) #pop-stack-frame end to-report #report-ob [#who# #method# #args#] let #res# runresult (#make-call-str-with-owner #who# #method# #args#) #pop-stack-frame report #res# end to-report #get-ob [#who# #slot#] report (#get-slot #who# #slot#) end to #set-ob [#who# #slot# #val#] #set-slot #who# #slot# #val# end ;----------------------------------- ; callers - instance context ;----------------------------------- to # [#method#] #do #method# #nil end to #do [#method# #args#] run (#make-anon-call-str #method# #args#) #pop-stack-frame end to-report #report [#method# #args#] let #res# runresult (#make-anon-call-str #method# #args#) #pop-stack-frame report #res# end to-report #<= [#slot#] report #get-ob #whoami #slot# end to #=> [#slot# #val#] #set-ob #whoami #slot# #val# end ;;; duplicates because some people may want them to-report #get [#slot#] report #get-ob #whoami #slot# end to #set [#slot# #val#] #set-ob #whoami #slot# #val# end ;----------------------------------- ; killers ;----------------------------------- to #die #kill who end to #kill [#who#] table:remove #objects #who# end ;----------------------------------- ; call by state ;----------------------------------- ; NB: this is only available in instance context ; it calls NLoops methods with their names modified ; by slot values to-report #make-proc-name [#who# #root# #slots#] report (word #root# "-" (reduce [(word ?1 "-" ?2)] (map [#get-ob #who# ?] #slots#) )) end to #do-ob-modified [#who# #root# #slots# #args#] set #root# (table:get (#get-ob #who# #root#) "pname") let #pnam# (#make-proc-name #who# #root# #slots#) #make-stack-frame #who# #who# #pnam# run (word #pnam# " " (#prep-args #args#)) #pop-stack-frame end to-report #report-ob-modified [#who# #root# #slots# #args#] ;; #debug (word "rep-ob-mod:" (list #who# #root# #slots# #args#)) set #root# (table:get (#get-ob #who# #root#) "pname") let #pnam# (#make-proc-name #who# #root# #slots#) ;; #debug (word "rep-ob-mod:" (list #root# #pnam#)) #make-stack-frame #who# #who# #pnam# let #res# runresult (word #pnam# " " (#prep-args #args#)) #pop-stack-frame report #res# end to #do-modified [#root# #slots# #args#] #do-ob-modified #whoami #root# #slots# #args# end to-report #report-modified [#root# #slots# #args#] report #report-ob-modified #whoami #root# #slots# #args# end to #do-p-modified [#who# #root# #slots# #args#] let #pnam# (#make-proc-name #who# #root# #slots#) run (word #pnam# " " (#prep-args #args#)) end to-report #report-p-modified [#who# #root# #slots# #args#] let #pnam# (#make-proc-name #who# #root# #slots#) report runresult (word #pnam# " " (#prep-args #args#)) end ;----------------------------------- ; other functions ;----------------------------------- to-report #class-of [#who#] report #get-slot #who# "#class" end to-report #my-class report #get-slot #whoami "#class" end to-report #self report (table:get (array:item #stack (#sptr - 1)) "self") end to-report #ob-has-slot? [#who# #slot#] report (table:has-key? (table:get #objects #who#) #slot#) end to-report #has-slot? [#slot#] report #ob-has-slot? #whoami #slot# end to-report #whoami ; this fn looks wrong & so needs some explanation re: why we need a runresult ; on "who". the issue is that without suppressing the evaluation of 'who' ; NL assumes turtle context. I am not happy with the work-around because it ; looks hacked, if you know a better way around please let me know report ifelse-value (#sptr != 0) [#self] [runresult "who"] end