reformatting lib/web.arc; simplified parse-server-headers

; written by Mark Huetsch
; same license as Arc

($ (require openssl))
($ (xdef ssl-connect (lambda (host port)
                       (ar-init-socket
                         (lambda () (ssl-connect host port))))))

(load "lib/re.arc")
(load "lib/util.arc")

(def parse-server-cookies (s)
  (map [map trim _]
       (map [matchsplit "=" _]
            (tokens s #\;))))

(def read-headers ((o s (stdin)))
  (accum a
    (whiler line (readline s) blank
      (a line))))

(def parse-server-headers (lines)
  (let http-response (tokens car.lines)
    (list
      (map http-response '(0 1 2))
      (some [aand (begins-rest "Set-Cookie:" _) parse-server-cookies.it]
            cdr.lines))))

(def args->query-string (args)
  (if args
    (let equals-list (map [joinstr _ "="] (pair (map [coerce _ 'string] args)))
      (joinstr equals-list "&"))
    ""))

(def parse-url (url)
  (withs (url                   (if (find #\# url)
                                  (joinstr (butlast (tokens url #\#)) "")
                                  url) ; throw away anchor component
          has-trailing-slash    (endmatch "/" url)
          components            (tokens url #\/)
          first-component       (pop components)
          first-component-is-resource (endmatch ":" first-component)
          resource              (if first-component-is-resource
                                  (downcase (butlast first-component))
                                  "http") ; defaults to http
          host                  (if first-component-is-resource
                                  (pop components)
                                  first-component)
          host-tokens           (tokens host #\:)
          host                  (car host-tokens)
          port                  (if
                                  (> (len host-tokens) 1)
                                    (int (last host-tokens))
                                  (is "https" resource)
                                    443
                                    80)
          components            (tokens (if components
                                           (+ (joinstr components "/")
                                              (if has-trailing-slash "/"))
                                           "")
                                       #\?)
          filename              (if (and components (isnt "" (components 0)))
                                  (components 0))
          query                 (if (len> components 1) (components 1)))
    (obj resource resource host host port port filename filename query query)))

(def encode-cookie (o)
  (let joined-list (map [joinstr _ #\=] (tablist o))
    (+ "Cookie: "
       (if (len> joined-list 1)
         (reduce [+ _1 "; " _2] joined-list)
         (car joined-list))
       ";")))

; TODO this isn't very pretty
(def get-or-post-url (url (o args) (o method "GET") (o cookie))
  (withs (method            (upcase method)
          parsed-url        (parse-url url)
          args-query-string (args->query-string args)
          full-args         (joinstr (list args-query-string (parsed-url 'query)) "&")
          request-path      (+ "/" (parsed-url 'filename)
                               (if (and (is method "GET") (> (len full-args) 0))
                                   (+ "?" full-args)))
          header-components (list (+ method " " request-path " HTTP/1.0")
                                  (+ "Host: " (parsed-url 'host))
                                  "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; uk; rv:1.9.1.2) Gecko/20090729 Firefox/3.5.2"))
    (when (is method "POST")
      (pushend (+ "Content-Length: "
                  (len (utf-8-bytes full-args)))
               header-components)
      (pushend "Content-Type: application/x-www-form-urlencoded"
               header-components))
    (when cookie
      (push (encode-cookie cookie) header-components))
    (withs (header          (reduce [+ _1 "\r\n" _2] header-components)
            body            (if (is method "POST") (+ full-args "\r\n"))
            request-message (+ header "\r\n\r\n" body))
      (let (in out) (if (is "https" (parsed-url 'resource))
                      (ssl-connect (parsed-url 'host) (parsed-url 'port))
                      (socket-connect (parsed-url 'host) (parsed-url 'port)))
        (disp request-message out)
        (with (header (parse-server-headers (read-headers in))
               body   (tostring (whilet line (readline in) (prn line))))
          (close in out)
          (list header body))))))

(def get-url (url)
  ((get-or-post-url url) 1))

(def post-url (url args)
  ((get-or-post-url url args "POST") 1))

(def google (q)
  (get-url (+ "www.google.com/search?q=" (urlencode q))))

; just some preliminary hacking
(mac w/browser body
  `(withs (cookies* (table)
                    get-url
                    (fn (url) (let (parsed-header html) (get-or-post-url url '() "GET" cookies*)
                                (= cookies* (fill-table cookies* (flat (parsed-header 1))))
                                html))
                    post-url
                    (fn (url args) (let (parsed-header html) (get-or-post-url url args "POST" cookies*)
                                     (= cookies* (fill-table cookies* (flat (parsed-header 1))))
                                     html)))
     (do ,@body)))

; written by Mark Huetsch
; same license as Arc

($ (require openssl))
($ (xdef ssl-connect (lambda (host port)
		                   (ar-init-socket
		                     (lambda () (ssl-connect host port))))))

(load "lib/re.arc")
(load "lib/util.arc")

(def parse-server-cookies (s)
  (map [map trim _]
       (map [matchsplit "=" _]
	    (tokens s #\;))))

(def read-headers ((o s (stdin)))
  (accum a
    (whiler line (readline s) blank
	    (a line))))

(def parse-server-headers (lines)
  (withs (http-response (tokens (car lines))
	  ret
	   (list
	     (list
	       (http-response 0)
	       (http-response 1)
	       (http-response 2))
	     (some (fn (s)
		     (aand (begins-rest "Set-Cookie:" s)
			  (parse-server-cookies it)))
		   (cdr lines))))
    ret))

(def args->query-string (args)
  (if args
      (let equals-list (map [joinstr _ "="] (pair (map [coerce _ 'string] args)))
	(joinstr equals-list "&"))
      ""))

(def parse-url (url)
  (withs (url (if (find #\# url)
		  (joinstr (butlast (tokens url #\#)) "")
		  url) ; throw away anchor component
	      has-trailing-slash (endmatch "/" url)
	      components (tokens url #\/)
	      first-component (pop components)
	      first-component-is-resource (endmatch ":" first-component)
	      resource (if first-component-is-resource (downcase (butlast first-component))
			   "http") ; defaults to http
	      host (if first-component-is-resource (pop components)
		       first-component)
	      host-tokens (tokens host #\:)
	      host (car host-tokens)
	      port (if (> (len host-tokens) 1) (int (last host-tokens)) (is "https" resource) 443 80)
	      components (tokens (if components
				     (+ (joinstr components "/") (if has-trailing-slash "/"))
				     "")
				 #\?)
	      filename (if (and components (isnt "" (components 0))) (components 0))
	      query (if (> (len components) 1) (components 1)))
    (obj resource resource host host port port filename filename query query)))

(def encode-cookie (o)
  (let joined-list (map [joinstr _ #\=] (tablist o))
    (+ "Cookie: "
       (if (len> joined-list 1)
	   (reduce [+ _1 "; " _2] joined-list)
	   (car joined-list))
       ";")))

; TODO this isn't very pretty
(def get-or-post-url (url (o args) (o method "GET") (o cookie))
  (withs (method (upcase method)
		 parsed-url (parse-url url)
		 args-query-string (args->query-string args)
		 full-args (joinstr (list args-query-string (parsed-url 'query)) "&")
		 request-path (+ "/" (parsed-url 'filename)
				 (if (and (is method "GET") (> (len full-args) 0))
				     (+ "?" full-args)))
		 header-components (list (+ method " " request-path " HTTP/1.0")
					 (+ "Host: " (parsed-url 'host))
					 "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; uk; rv:1.9.1.2) Gecko/20090729 Firefox/3.5.2"))
    (when (is method "POST")
      (pushend (+ "Content-Length: " (len (utf-8-bytes full-args))) header-components)
      (pushend "Content-Type: application/x-www-form-urlencoded" header-components))
    (when cookie
      (push (encode-cookie cookie) header-components))
    (withs (header (reduce [+ _1 "\r\n" _2] header-components)
		   body (if (is method "POST") (+ full-args "\r\n"))
		   request-message (+ header "\r\n\r\n" body))
      (let (in out) (if (is "https" (parsed-url 'resource))
			(ssl-connect (parsed-url 'host) (parsed-url 'port))
			(socket-connect (parsed-url 'host) (parsed-url 'port)))
	(disp request-message out)
	(with (header (parse-server-headers (read-headers in))
		      body (tostring (whilet line (readline in) (prn line))))
	  (close in out)
	  (list header body))))))

(def get-url (url)
  ((get-or-post-url url) 1))

(def post-url (url args)
  ((get-or-post-url url args "POST") 1))

(def google (q)
  (get-url (+ "www.google.com/search?q=" (urlencode q))))

; just some preliminary hacking
(mac w/browser body
  `(withs (cookies* (table)
		    get-url
		    (fn (url) (let (parsed-header html) (get-or-post-url url '() "GET" cookies*)
				(= cookies* (fill-table cookies* (flat (parsed-header 1))))
				html))
		    post-url
		    (fn (url args) (let (parsed-header html) (get-or-post-url url args "POST" cookies*)
				     (= cookies* (fill-table cookies* (flat (parsed-header 1))))
				     html)))
     (do ,@body)))


'let compilation

'let compilation

; the compiler
; compile an s-expr into PIR code
; code is emitted on stdout

; from arc.arc (anarki)
(def makeproper (lst)
  (if (no (acons lst))
      lst
      (cons (car lst)
            (if (alist (cdr lst))
              (makeproper (cdr lst))
              (list (cdr lst))))))

(def cdddr (x)
  (cdr (cdr (cdr x))))

(def caddr (x)
  (cadr (cdr x)))

; hold compiler state

(def empty-state () (listtab '((reg 0) (lex nil))))

; register management

(def next-reg (cs)
  (string "$P" (++ cs!reg)))

(def reset-reg (cs)
  (= cs!reg 0))

(def free-reg (cs)
  (let r cs!reg
    (= cs!reg (- cs!reg 1))
    (string "$P" r)))

(= c-push next-reg)
(= c-pop free-reg)

(def top (cs)
  cs!reg)

(def alex (cs s)
  (mem s cs!lex))

(def e-type (e)
  (if
    (is e t) t
    (in e nil '()) nil
    (type e)))

; expression compiler

(def tl-compile (e)
  (withs (consts-tbl (table)
          e (mac-ex e)
          e (a-conv e)
          main-id (uniq)
          (fns consts expr) (collect-fns-and-consts e nil main-id
                                                    t nil consts-tbl)
          cs (empty-state))
    (prn ".HLL 'Arc'")
    (prn ".loadlib 'primitivearc_ops'")
    (prn ".loadlib 'primitivearc_group'")
    ; all the constants
    (prn ".sub _const_init :load :init :anon")
    (each const consts
      (compile-const (empty-state) const))
    (prn ".return ()")
    (prn ".end")
    ; entry function
    (prn ".sub _main :init :load :anon :subid('" main-id "')")
    (compile-expr cs expr nil)
    (prn "set_hll_global '***', " (c-pop cs))
    (prn ".return ()")
    (prn ".end")
    ; all the functions
    (each f fns
      (compile-fn (empty-state) f))))

(let escape-table (listtab '((#\newline "\\n")
                             (#\return "\\r")
                             (#\\ "\\\\")
                             (#\tab "\\t")
                             (#\" "\\\"")))
  (def pr-escape (x)
    (each c (coerce x 'cons)
      (aif (escape-table c)
        (pr it)
        (pr c)))))

; compile a single expression
(def compile-expr (cs e is-tail)
  (let out-reg (c-push cs)
    (case (e-type e)
      nil (prn out-reg " = get_hll_global 'nil'")
      t (prn out-reg " = get_hll_global 't'")
      string (do
               (prn out-reg " = new 'ArcStr'")
               (pr out-reg " = \"")
               (pr-escape e)
               (prn "\""))
      int (do
            (prn out-reg " = new 'ArcInt'")
            (prn out-reg " = " e))
      num (do
            (prn out-reg " = new 'ArcNum'")
            (prn out-reg " = " e))
      char (do
             (prn out-reg " = new 'ArcChar'")
             (pr out-reg " = \"")
             (pr-escape (string e))
             (prn  "\""))
      sym (if (alex cs e)
            (prn out-reg " = find_lex '" e "'")
            (prn out-reg " = arc_get_global '" e "'"))
      cons (compile-special-or-call cs e out-reg is-tail))))

(def compile-special-or-call (cs e out-reg is-tail)
  (case (car e)
    $function (compile-function cs e out-reg)
    $closure (compile-closure cs e out-reg)
    if (compile-if cs e out-reg is-tail)
    assign (compile-assign cs e out-reg)
    apply (compile-call cs (cdr e) out-reg is-tail t)
    ; else
    (if (a-let e)
      (compile-let cs e out-reg is-tail)
      (compile-call cs e out-reg is-tail nil))))

(def compile-let (cs e out-reg is-tail)
  (with (args (collect-args ((car e) 1))
         body (cddr (car e))
         vals (cdr e))
    ((afn (args vals)
        (if args
          (if (is (arg-type (car args)) 'rest)
            (emit-local-init cs (car args) vals vals)
            (do
              (emit-local-init cs (car args) (car vals) vals)
              (self (cdr args) (cdr vals))))))
     args vals)
    (let old cs!lex
      (= cs!lex (join (arg-names ((car e) 1)) cs!lex))
      (compile-seq cs body is-tail)
      (= cs!lex old))
    (prn out-reg " = " (c-pop cs))))

(def compile-call (cs e out-reg is-tail is-apply)
  ; compile function args
  (each arg e
    (compile-expr cs arg nil))
  (with (args (rev (map (fn (ignore) (c-pop cs)) e)) ; pop args registers
         _arcall (if is-apply
                  "arcall"
                  (case (- (len e) 1) ; don't count function
                    1 "arcall1"
                    2 "arcall2"
                    ; else
                    "arcall")))
    (if is-apply
      (let last (args (- (len args) 1))
        (prn last " = _list_to_array(" last ")")))
    (if is-tail
      (pr ".tailcall " _arcall "(")
      (pr out-reg " = " _arcall "("))
    (each arg (intersperse ", " args)
      (pr arg))
    (if is-apply
      (prn " :flat)")
      (prn ")"))))

;(def compile-const-ref (cs e out-reg)
;  (let name (uniq)
;    (prn ".const 'Sub' " name " = '" (cadr e) "'")
;    (prn out-reg " = " name)))

(def compile-const (cs const)
  (let emit-const (afn (e)
                    (if
                      (aquote e)
                        (self (cadr e))
                      (case (e-type e)
                        sym (prn (c-push cs) " = 'intern'('" e "')")
                        cons (do
                               (self (car e))
                               (self (cdr e))
                               (with (a (c-pop cs) b (c-pop cs))
                                 (prn (c-push cs) " = 'cons'(" b "," a ")")))
                        ; else
                        (compile-expr cs e nil))))
    ;(prn ".sub '" const!name "' :subid('" const!name "') :immediate")
    (emit-const const!expr)
    ;(prn ".return (" (c-pop cs) ")")
    ;(prn ".end")))
    (prn "set_hll_global '" const!name "', " (c-pop cs))))

(def emit-fn-head (cs name dbg-name outer)
  ;(pr ".sub '" (or dbg-name name) "' :nsentry('" name "')")
  ;(if dbg-name
  ;  (pr " :subid('" name "')"))
  (pr ".sub '" (or dbg-name name) "'")
  (pr " :subid('" name "')")
  (if (no (iso outer ""))
    (pr " :outer('" outer "')"))
  (prn))

; emit a sequence of operations
; if sequence is empty, emit code to return nil
(def compile-seq (cs seq is-tail)
  (if (no seq)
    (compile-expr cs nil is-tail)
    ((afn (e)
       (if
         (no e) nil
         (no (cdr e)) ; last expression
           (compile-expr cs (car e) is-tail)
         (do
           (compile-expr cs (car e) nil)
           (c-pop cs) ; discard ret. value
           (self (cdr e))))) seq)))

; compiles a global function expression
; takes a fn-info object
; ($fn name (arg1 ... . rest-arg) ...)
(def compile-fn (cs f)
  ;(ero "compiling: " (or f!dbg-name (cadr f!expr)))
  (withs (e f!expr
          name e.1
          args (collect-args e.2)
          body (cdddr e))
    (unless (isa name 'sym)
      (err:string "not a symbol: " name))
    (emit-fn-head cs name f!dbg-name f!outer)
    (emit-args args)
    ; emit the body
    (reset-reg cs)
    (let old cs!lex
      (= cs!lex f!lex)
      (compile-seq cs body t)
      (= cs!lex old))
    (prn ".return (" (c-pop cs) ")")
    (prn ".end")))

; compile closure creation form
; ($closure code-name)
(def compile-closure (cs expr out-reg)
;  (prn out-reg " = get_hll_global '" expr.1 "'")
;  (prn out-reg " = newclosure " out-reg))
  (let name (uniq)
    (prn ".const 'Sub' " name " = '" expr.1 "'")
    (prn out-reg " = newclosure " name)))

; compile function creation form
; ($function code-name)
(def compile-function (cs expr out-reg)
  (prn out-reg " = get_hll_global '" expr.1 "'"))

(def label ()
  (uniq))

; if form: (if t1 then1 t2 then2 ... else)
; TODO: give better names to labels
(def compile-if (cs expr out-reg is-tail)
  (let end (label)
    ((afn (expr)
       (if
         (no expr)
           (prn out-reg " = get_hll_global 'nil'")
         (no (cdr expr))
           (do
             (compile-expr cs (car expr) is-tail)
             (prn out-reg " = " (c-pop cs)))
         ; else len > 1
         (with (else (label)
                test expr.0
                then expr.1)
           (compile-expr cs test nil)
           (prn "unless " (c-pop cs) " goto " else)
           (compile-expr cs then is-tail)
           (prn out-reg " = " (c-pop cs))
           (prn "goto " end)
           (prn else ":")
           (self (cddr expr))))) (cdr expr)) ; cut 'if
     (prn end ":")))

(def compile-assign (cs expr out-reg)
  (with (name expr.1
         val expr.2)
    (unless (and (isa name 'sym) (is (len expr) 3))
      (err "wrong 'assign form: " expr))
    (compile-expr cs val nil)
    (prn out-reg " = " (c-pop cs))
    (if (alex cs name)
      (prn "store_lex '" name "', " out-reg)
      (prn "set_hll_global '" name "', " out-reg))))

(def aquote (e)
  (and (acons e) (is (car e) 'quote)))

(def a-fn (e)
  (and (acons e) (is (car e) 'fn)))

(def a-fn-assign (e)
  (and (acons e) (is (car e) 'assign) (a-fn (caddr e))))

(def mk-const (name expr)
  (listtab (list (list 'name name) (list 'expr expr))))

(def mk-fn (expr outer lex dbg-name)
  (listtab (list (list 'expr expr) (list 'outer outer)
                 (list 'lex lex) (list 'dbg-name dbg-name))))

(def arg-names (args)
  ; consider destructuring too
  ; don't count optionals (o ...) 'o symbol and init expression
  (if (isa args 'sym)
    (list args)
    (flat (map [if (is-opt _) (cadr _) _] (makeproper args)))))

(def a-let (e)
  (and (acons e) (a-fn (car e))))

(def map1-imp (f l)
  (if
    (no l) nil
    (atom l) (f l)
    (cons (f (car l)) (map1-imp f (cdr l)))))

; alpha-conversion
(def a-conv (e (o transf))
  (if
    (atom e)
      (or (cdr (assoc e transf)) e)
    (aquote e) e
    (a-fn e)
      (withs (args (arg-names (cadr e))
              new-args (map [uniq] args)
              transf (join (map cons args new-args) transf))
        (map [a-conv _ transf] e))
    ; else
    (map1-imp [a-conv _ transf] e)))

(def collect-fns-and-consts (expr lex outer is-main is-seq consts (o have-name nil))
;  (ero (string "collect: " expr))
  (if
    (in (e-type expr) 'sym 't 'nil)
      (list nil nil expr)
    (or (in (e-type expr) 'int 'num 'char 'string) (aquote expr))
      (if (consts expr)
        (list nil nil (consts expr))
        (let name (uniq)
          (= (consts expr) name)
          ;(ero (string "    name: " name " -> " expr))
          ; TODO: optimize simple constants (int, num, char, string)
          (list nil (list (mk-const name expr)) name)))
    (a-fn-assign expr)
      (let (f c e) (collect-fns-and-consts (caddr expr) lex outer is-main
                                           is-seq consts (cadr expr))
        (list f c (list 'assign (cadr expr) e)))
    (a-fn expr)
      (withs (name (uniq)
              args expr.1
              body (cddr expr)
              new-lex (join (arg-names args) lex))
        (let (fns consts expr) (collect-fns-and-consts body new-lex
                                                       name nil t consts)
          (list (cons (mk-fn (cons '$fn (cons name (cons args expr)))
                              outer new-lex have-name)
                      fns)
                consts (list (if is-main '$function '$closure) name))))
    (and (no is-seq) (a-let expr))
      (withs (args ((car expr) 1)
              body (cddr (car expr))
              (fval cval vals) (collect-fns-and-consts (cdr expr) lex outer nil
                                                       t consts)
              new-lex (join (arg-names args) lex)
              (fns consts expr) (collect-fns-and-consts body new-lex outer nil
                                                        t consts))
        (list (join fval fns) (join cval consts)
              (cons (cons 'fn (cons args expr)) vals)))
    (let res (map [collect-fns-and-consts _ lex outer is-main nil consts] expr)
      ;(ero "res: " res)
      (let res (apply map list res)
        ;(ero "  res2: " res)
        (list (apply join res.0) (apply join res.1) res.2)))))

(def mac-ex (e)
  (if (atom e)
    e
    (let op (car e)
      (if
        (is op 'fn)
          (cons 'fn (cons (cadr e) (map mac-ex (cddr e))))
        (is op 'quote)
          e
        (and (isa op 'sym)
             (bound op)
             (isa (eval op) 'mac))
          ; we have a macro
          (let expander (rep (eval op))
            (mac-ex (apply expander (cdr e))))
        ; a list
        (map mac-ex e)))))

; fn args

(def arg-name (a) a!name)
(def arg-p-name (a) a!p-name)
(def arg-type (a) a!type)
(def arg-expr (a) a!expr)

(def mk-arg (name p-name expr type)
  (listtab (list (list 'name name) (list 'p-name p-name)
                 (list 'expr expr) (list 'type type))))

(def mk-darg (name p-name expr)
  (mk-arg name p-name expr 'dest))

(def assign-str (pos gs)
  (string pos "(" gs ")"))

(def des-arg (a gs pos)
  (if
    (isa a 'sym)
      (list (mk-darg a (uniq) (assign-str pos gs)))
    (acons a)
      (let gs-2 (if (is pos 'top) gs (uniq))
        (join (if (is pos 'top)
                nil
                (list (mk-darg nil gs-2 (assign-str pos gs))))
              (des-arg (car a) gs-2 'car)
              (if (cdr a)
                (des-arg (cdr a) gs-2 'cdr)
                nil)))
    (no a)
      nil
    (err:string "Can't destructure: " a)))

(def pr-param (p-name extra)
  (prn ".param pmc " p-name extra))

(def pr-lex (name p-name)
  (prn ".lex '" name "', " p-name))

; emit code to declare a parameter
(def emit-arg-dec (a)
  (case (arg-type a)
    simple (pr-param (arg-p-name a) "")
    opt (do
          (pr-param (arg-p-name a) " :optional")
          (prn ".param int has_" (arg-p-name a) " :opt_flag"))
    dest (pr-param (arg-p-name a) "")
    rest (pr-param (arg-p-name a) " :slurpy")
   (err:string "Unknown arg type: " a)))

(def emit-arg-dest (a)
  (each loc (arg-expr a)
    (prn ".local pmc " (arg-p-name loc))
    (if (arg-name loc)
      (pr-lex (arg-name loc) (arg-p-name loc)))
    (prn (arg-p-name loc) " = " (arg-expr loc))))

; emit initialization code for arg
(def emit-arg-init (a)
  (case (arg-type a)
    simple (pr-lex (arg-name a) (arg-p-name a))
    opt (with (next (label)
               cs (empty-state))
          (pr-lex (arg-name a) (arg-p-name a))
          (prn "if has_" (arg-p-name a) " goto " next)
          (compile-expr cs (arg-expr a) nil)
          (prn (arg-p-name a) " = " (c-pop cs))
          (prn next ":"))
    dest (emit-arg-dest a)
    rest (do
           (pr-lex (arg-name a) (arg-p-name a))
           (prn (arg-p-name a) " = list(" (arg-p-name a) " :flat)"))
    (err:string "Unknown arg: " a)))

(def emit-simple-local (cs arg val)
  (compile-expr cs val nil)
  (prn ".local pmc " (arg-p-name arg))
  (pr-lex (arg-name arg) (arg-p-name arg))
  (prn (arg-p-name arg) " = " (c-pop cs)))

; like emit-arg-init, but for 'let like forms
(def emit-local-init (cs a val has-val)
  (case (arg-type a)
    simple (if has-val
             (emit-simple-local cs a val)
             (err "Wrong number of arg passed"))
    opt (if has-val
          (emit-simple-local cs a val)
          (emit-simple-local cs a (arg-expr a)))
    dest (if has-val
           (do
             (compile-expr cs val nil)
             (emit-arg-dest a))
           (err "Wrong number of arg passed"))
    rest (if has-val
           (emit-simple-local cs a (cons 'list val))
           (emit-simple-local cs a nil))
    (err "Unknow arg type")))

(def is-opt (x)
  (and (acons x) (is (car x) 'o)))

(def collect-args (args)
  (if
    (no args)
      nil
    (and args (no (acons args))) ; rest arg
      (list (mk-arg args (uniq) nil 'rest))
    (isa (car args) 'sym)
      (cons (mk-arg (car args) (uniq) nil 'simple)
            (collect-args (cdr args)))
    (is-opt (car args))
      (let o (car args)
        (cons (mk-arg (cadr o) (uniq) (caddr o) 'opt)
              (collect-args (cdr args))))
    (acons (car args))
      (let p-name (uniq)
        (cons (mk-arg nil p-name (des-arg (car args) p-name 'top) 'dest)
              (collect-args (cdr args))))
    (err:string "Unknow arg type:" args)))

(def emit-args (args)
  (each arg args
    (emit-arg-dec arg))
  (each arg args
    (emit-arg-init arg)))

; the compiler
; compile an s-expr into PIR code
; code is emitted on stdout

; from arc.arc (anarki)
(def makeproper (lst)
  (if (no (acons lst))
      lst
      (cons (car lst)
            (if (alist (cdr lst))
              (makeproper (cdr lst))
              (list (cdr lst))))))

(def cdddr (x)
  (cdr (cdr (cdr x))))

(def caddr (x)
  (cadr (cdr x)))

; hold compiler state

(def empty-state () (listtab '((reg 0) (lex nil))))

; register management

(def next-reg (cs)
  (string "$P" (++ cs!reg)))

(def reset-reg (cs)
  (= cs!reg 0))

(def free-reg (cs)
  (let r cs!reg
    (= cs!reg (- cs!reg 1))
    (string "$P" r)))

(= c-push next-reg)
(= c-pop free-reg)

(def top (cs)
  cs!reg)

(def alex (cs s)
  (mem s cs!lex))

(def e-type (e)
  (if
    (is e t) t
    (in e nil '()) nil
    (type e)))

; expression compiler

(def tl-compile (e)
  (withs (consts-tbl (table)
          e (mac-ex e)
          e (a-conv e)
          (fns consts expr) (collect-fns-and-consts e nil "" nil consts-tbl)
          cs (empty-state))
    (prn ".HLL 'Arc'")
    (prn ".loadlib 'primitivearc_ops'")
    (prn ".loadlib 'primitivearc_group'")
    ; all the constants
    (prn ".sub _const_init :load :init :anon")
    (each const consts
      (compile-const (empty-state) const))
    (prn ".return ()")
    (prn ".end")
    ; entry function
    (prn ".sub _main :init :load :anon")
    (compile-expr cs expr nil)
    (prn "set_hll_global '***', " (c-pop cs))
    (prn ".return ()")
    (prn ".end")
    ; all the functions
    (each f fns
      (compile-fn (empty-state) f))))

(let escape-table (listtab '((#\newline "\\n")
                             (#\return "\\r")
                             (#\\ "\\\\")
                             (#\tab "\\t")
                             (#\" "\\\"")))
  (def pr-escape (x)
    (each c (coerce x 'cons)
      (aif (escape-table c)
        (pr it)
        (pr c)))))

; compile a single expression
(def compile-expr (cs e is-tail)
  (let out-reg (c-push cs)
    (case (e-type e)
      nil (prn out-reg " = get_hll_global 'nil'")
      t (prn out-reg " = get_hll_global 't'")
      string (do
               (prn out-reg " = new 'ArcStr'")
               (pr out-reg " = \"")
               (pr-escape e)
               (prn "\""))
      int (do
            (prn out-reg " = new 'ArcInt'")
            (prn out-reg " = " e))
      num (do
            (prn out-reg " = new 'ArcNum'")
            (prn out-reg " = " e))
      char (do
             (prn out-reg " = new 'ArcChar'")
             (pr out-reg " = \"")
             (pr-escape (string e))
             (prn  "\""))
      sym (if (alex cs e)
            (prn out-reg " = find_lex '" e "'")
            (prn out-reg " = arc_get_global '" e "'"))
      cons (compile-special-or-call cs e out-reg is-tail))))

(def compile-special-or-call (cs e out-reg is-tail)
  (case (car e)
    $function (compile-function cs e out-reg)
    $closure (compile-closure cs e out-reg)
    if (compile-if cs e out-reg is-tail)
    assign (compile-assign cs e out-reg)
    apply (compile-call cs (cdr e) out-reg is-tail t)
    ; else
    (if (a-let e)
      (compile-let cs e out-reg is-tail)
      (compile-call cs e out-reg is-tail nil))))

(def compile-let (cs e out-reg is-tail)
  (with (args (collect-args ((car e) 1))
         body (cddr (car e))
         values (cdr e))
    (map (fn (arg val)
           (compile-expr cs val nil)
           (prn ".local pmc " (arg-p-name arg))
           (prn (arg-p-name arg) " = " (c-pop cs))
           ; FIX FIX FIX: emit-arg-init doesn't work in this case
           ; (emit-arg-init arg)
         )
         args values)
    (let old cs!lex
      (= cs!lex (join (arg-names ((car e) 1)) cs!lex))
      (compile-seq cs body is-tail)
      (= cs!lex old))
    (prn out-reg " = " (c-pop cs))))

(def compile-call (cs e out-reg is-tail is-apply)
  ; compile function args
  (each arg e
    (compile-expr cs arg nil))
  (with (args (rev (map (fn (ignore) (c-pop cs)) e)) ; pop args registers
         _arcall (if is-apply
                  "arcall"
                  (case (- (len e) 1) ; don't count function
                    1 "arcall1"
                    2 "arcall2"
                    ; else
                    "arcall")))
    (if is-apply
      (let last (args (- (len args) 1))
        (prn last " = _list_to_array(" last ")")))
    (if is-tail
      (pr ".tailcall " _arcall "(")
      (pr out-reg " = " _arcall "("))
    (each arg (intersperse ", " args)
      (pr arg))
    (if is-apply
      (prn " :flat)")
      (prn ")"))))

;(def compile-const-ref (cs e out-reg)
;  (let name (uniq)
;    (prn ".const 'Sub' " name " = '" (cadr e) "'")
;    (prn out-reg " = " name)))

(def compile-const (cs const)
  (let emit-const (afn (e)
                    (if
                      (aquote e)
                        (self (cadr e))
                      (case (e-type e)
                        sym (prn (c-push cs) " = 'intern'('" e "')")
                        cons (do
                               (self (car e))
                               (self (cdr e))
                               (with (a (c-pop cs) b (c-pop cs))
                                 (prn (c-push cs) " = 'cons'(" b "," a ")")))
                        ; else
                        (compile-expr cs e nil))))
    ;(prn ".sub '" const!name "' :subid('" const!name "') :immediate")
    (emit-const const!expr)
    ;(prn ".return (" (c-pop cs) ")")
    ;(prn ".end")))
    (prn "set_hll_global '" const!name "', " (c-pop cs))))

(def emit-fn-head (cs name dbg-name outer)
  ;(pr ".sub '" (or dbg-name name) "' :nsentry('" name "')")
  ;(if dbg-name
  ;  (pr " :subid('" name "')"))
  (pr ".sub '" (or dbg-name name) "'")
  (pr " :subid('" name "')")
  (if (no (iso outer ""))
    (pr " :outer('" outer "')"))
  (prn))

; emit a sequence of operations
; if sequence is empty, emit code to return nil
(def compile-seq (cs seq is-tail)
  (if (no seq)
    (compile-expr cs nil is-tail)
    ((afn (e)
       (if
         (no e) nil
         (no (cdr e)) ; last expression
           (compile-expr cs (car e) is-tail)
         (do
           (compile-expr cs (car e) nil)
           (c-pop cs) ; discard ret. value
           (self (cdr e))))) seq)))

; compiles a global function expression
; takes a fn-info object
; ($fn name (arg1 ... . rest-arg) ...)
(def compile-fn (cs f)
  ;(ero "compiling: " (or f!dbg-name (cadr f!expr)))
  (withs (e f!expr
          name e.1
          args (collect-args e.2)
          body (cdddr e))
    (unless (isa name 'sym)
      (err:string "not a symbol: " name))
    (emit-fn-head cs name f!dbg-name f!outer)
    (emit-args args)
    ; emit the body
    (reset-reg cs)
    (let old cs!lex
      (= cs!lex f!lex)
      (compile-seq cs body t)
      (= cs!lex old))
    (prn ".return (" (c-pop cs) ")")
    (prn ".end")))

; compile closure creation form
; ($closure code-name)
(def compile-closure (cs expr out-reg)
;  (prn out-reg " = get_hll_global '" expr.1 "'")
;  (prn out-reg " = newclosure " out-reg))
  (let name (uniq)
    (prn ".const 'Sub' " name " = '" expr.1 "'")
    (prn out-reg " = newclosure " name)))

; compile function creation form
; ($function code-name)
(def compile-function (cs expr out-reg)
  (prn out-reg " = get_hll_global '" expr.1 "'"))

(def label ()
  (uniq))

; if form: (if t1 then1 t2 then2 ... else)
; TODO: give better names to labels
(def compile-if (cs expr out-reg is-tail)
  (let end (label)
    ((afn (expr)
       (if
         (no expr)
           (prn out-reg " = get_hll_global 'nil'")
         (no (cdr expr))
           (do
             (compile-expr cs (car expr) is-tail)
             (prn out-reg " = " (c-pop cs)))
         ; else len > 1
         (with (else (label)
                test expr.0
                then expr.1)
           (compile-expr cs test nil)
           (prn "unless " (c-pop cs) " goto " else)
           (compile-expr cs then is-tail)
           (prn out-reg " = " (c-pop cs))
           (prn "goto " end)
           (prn else ":")
           (self (cddr expr))))) (cdr expr)) ; cut 'if
     (prn end ":")))

(def compile-assign (cs expr out-reg)
  (with (name expr.1
         val expr.2)
    (unless (and (isa name 'sym) (is (len expr) 3))
      (err "wrong 'assign form: " expr))
    (compile-expr cs val nil)
    (prn out-reg " = " (c-pop cs))
    (if (alex cs name)
      (prn "store_lex '" name "', " out-reg)
      (prn "set_hll_global '" name "', " out-reg))))

(def aquote (e)
  (and (acons e) (is (car e) 'quote)))

(def a-fn (e)
  (and (acons e) (is (car e) 'fn)))

(def a-fn-assign (e)
  (and (acons e) (is (car e) 'assign) (a-fn (caddr e))))

(def mk-const (name expr)
  (listtab (list (list 'name name) (list 'expr expr))))

(def mk-fn (expr outer lex dbg-name)
  (listtab (list (list 'expr expr) (list 'outer outer)
                 (list 'lex lex) (list 'dbg-name dbg-name))))

(def arg-names (args)
  ; consider destructuring too
  ; don't count optionals (o ...) 'o symbol and init expression
  (if (isa args 'sym)
    (list args)
    (flat (map [if (is-opt _) (cadr _) _] (makeproper args)))))

(def a-let (e)
  (and (acons e) (a-fn (car e))))

(def map1-imp (f l)
  (if
    (no l) nil
    (atom l) (f l)
    (cons (f (car l)) (map1-imp f (cdr l)))))

; alpha-conversion
(def a-conv (e (o transf))
  (if
    (atom e)
      (or (cdr (assoc e transf)) e)
    (aquote e) e
    (a-fn e)
      (withs (args (arg-names (cadr e))
              new-args (map [uniq] args)
              transf (join (map cons args new-args) transf))
        (map [a-conv _ transf] e))
    ; else
    (map1-imp [a-conv _ transf] e)))

(def collect-fns-and-consts (expr lex outer is-seq consts (o have-name nil))
;  (ero (string "collect: " expr))
  (if
    (in (e-type expr) 'sym 't 'nil)
      (list nil nil expr)
    (or (in (e-type expr) 'int 'num 'char 'string) (aquote expr))
      (if (consts expr)
        (list nil nil (consts expr))
        (let name (uniq)
          (= (consts expr) name)
          ;(ero (string "    name: " name " -> " expr))
          ; TODO: optimize simple constants (int, num, char, string)
          (list nil (list (mk-const name expr)) name)))
    (a-fn-assign expr)
      (let (f c e) (collect-fns-and-consts (caddr expr) lex outer
                                           is-seq consts (cadr expr))
        (list f c (list 'assign (cadr expr) e)))
    (a-fn expr)
      (withs (name (uniq)
              args expr.1
              body (cddr expr)
              new-lex (join (arg-names args) lex))
        (let (fns consts expr) (collect-fns-and-consts body new-lex
                                                       name t consts)
          (list (cons (mk-fn (cons '$fn (cons name (cons args expr)))
                              outer new-lex have-name)
                      fns)
                consts (list (if (iso outer "") '$function '$closure) name))))
    (a-let expr)
      (withs (args ((car expr) 1)
              body (cddr (car expr))
              (fval cval vals) (collect-fns-and-consts (cdr expr) lex outer t
                                                       consts)
              new-lex (join (arg-names args) lex)
              (fns consts expr) (collect-fns-and-consts body new-lex outer t
                                                        consts))
        (list (join fval fns) (join cval consts)
              (cons (cons 'fn (cons args expr)) vals)))
    (let res (map [collect-fns-and-consts _ lex outer nil consts] expr)
      ;(ero "res: " res)
      (let res (apply map list res)
        ;(ero "  res2: " res)
        (list (apply join res.0) (apply join res.1) res.2)))))

(def mac-ex (e)
  (if (atom e)
    e
    (let op (car e)
      (if
        (is op 'fn)
          (cons 'fn (cons (cadr e) (map mac-ex (cddr e))))
        (is op 'quote)
          e
        (and (isa op 'sym)
             (bound op)
             (isa (eval op) 'mac))
          ; we have a macro
          (let expander (rep (eval op))
            (mac-ex (apply expander (cdr e))))
        ; a list
        (map mac-ex e)))))

; fn args

(def arg-name (a) a!name)
(def arg-p-name (a) a!p-name)
(def arg-type (a) a!type)
(def arg-expr (a) a!expr)

(def mk-arg (name p-name expr type)
  (listtab (list (list 'name name) (list 'p-name p-name)
                 (list 'expr expr) (list 'type type))))

(def mk-darg (name p-name expr)
  (mk-arg name p-name expr 'dest))

(def assign-str (pos gs)
  (string pos "(" gs ")"))

(def des-arg (a gs pos)
  (if
    (isa a 'sym)
      (list (mk-darg a (uniq) (assign-str pos gs)))
    (acons a)
      (let gs-2 (if (is pos 'top) gs (uniq))
        (join (if (is pos 'top)
                nil
                (list (mk-darg nil gs-2 (assign-str pos gs))))
              (des-arg (car a) gs-2 'car)
              (if (cdr a)
                (des-arg (cdr a) gs-2 'cdr)
                nil)))
    (no a)
      nil
    (err:string "Can't destructure: " a)))

(def pr-param (p-name extra)
  (prn ".param pmc " p-name extra))

(def pr-lex (name p-name)
  (prn ".lex '" name "', " p-name))

; emit code to declare a parameter
(def emit-arg-dec (a)
  (case (arg-type a)
    simple (pr-param (arg-p-name a) "")
    opt (do
          (pr-param (arg-p-name a) " :optional")
          (prn ".param int has_" (arg-p-name a) " :opt_flag"))
    dest (pr-param (arg-p-name a) "")
    rest (pr-param (arg-p-name a) " :slurpy")
   (err:string "Unknown arg type: " a)))

; emit initialization code for arg
(def emit-arg-init (a)
  (case (arg-type a)
    simple (pr-lex (arg-name a) (arg-p-name a))
    opt (with (next (label)
               cs (empty-state))
          (pr-lex (arg-name a) (arg-p-name a))
          (prn "if has_" (arg-p-name a) " goto " next)
          (compile-expr cs (arg-expr a) nil)
          (prn (arg-p-name a) " = " (c-pop cs))
          (prn next ":"))
    dest (each loc (arg-expr a)
           (prn ".local pmc " (arg-p-name loc))
           (if (arg-name loc)
             (pr-lex (arg-name loc) (arg-p-name loc)))
           (prn (arg-p-name loc) " = " (arg-expr loc)))
    rest (do
           (pr-lex (arg-name a) (arg-p-name a))
           (prn (arg-p-name a) " = list(" (arg-p-name a) " :flat)"))
    (err:string "Unknown arg: " a)))

(def is-opt (x)
  (and (acons x) (is (car x) 'o)))

(def collect-args (args)
  (if
    (no args)
      nil
    (and args (no (acons args))) ; rest arg
      (list (mk-arg args (uniq) nil 'rest))
    (isa (car args) 'sym)
      (cons (mk-arg (car args) (uniq) nil 'simple)
            (collect-args (cdr args)))
    (is-opt (car args))
      (let o (car args)
        (cons (mk-arg (cadr o) (uniq) (caddr o) 'opt)
              (collect-args (cdr args))))
    (acons (car args))
      (let p-name (uniq)
        (cons (mk-arg nil p-name (des-arg (car args) p-name 'top) 'dest)
              (collect-args (cdr args))))
    (err:string "Unknow arg type:" args)))

(def emit-args (args)
  (each arg args
    (emit-arg-dec arg))
  (each arg args
    (emit-arg-init arg)))


Use counts in tokcount

Use counts in tokcount

; Code analysis. Spun off 21 Dec 07.

; Ought to do more of this in Arc.  One of the biggest advantages
; of Lisp is messing with code.

(def codelines (file)
  (w/infile in file
    (summing test
      (whilet line (readline in)
        (test (aand (find nonwhite line) (isnt it #\;)))))))

(def codeflat (file)
  (len (flat (readall (infile file)))))

(def codetree (file)
  (treewise + (fn (x) 1) (readall (infile file))))

(def code-density (file)
  (/ (codetree file) (codelines file)))

(def tokcount (files)
  (counts (mappend flat:readall:infile files)))

(def common-tokens (files)
  (let counts (tokcount files)
    (ret ranking nil
      (maptable (fn (k v)
                  (unless (nonop k)
                    (insort (compare > cadr) (list k v) ranking)))
                counts))))

(def nonop (x)
  (in x 'quote 'unquote 'quasiquote 'unquote-splicing))

(def common-operators (files)
  (keep [and (isa (car _) 'sym) (bound (car _))] (common-tokens files)))

(def top40 (xs)
  (map prn (firstn 40 xs))
  t)

(def space-eaters (files)
  (let counts (tokcount files)
    (let ranking nil
      (maptable (fn (k v)
                  (when (and (isa k 'sym) (bound k))
                    (insort (compare > [* (len (string (car _)))
                                          (cadr _)])
                            (list k v (* (len (string k)) v))
                            ranking)))
                counts)
    ranking)))

;(top40 (space-eaters allfiles*))

(mac flatlen args `(len (flat ',args)))

; Code analysis. Spun off 21 Dec 07.

; Ought to do more of this in Arc.  One of the biggest advantages
; of Lisp is messing with code.

(def codelines (file)
  (w/infile in file
    (summing test
      (whilet line (readline in)
        (test (aand (find nonwhite line) (isnt it #\;)))))))

(def codeflat (file)
  (len (flat (readall (infile file)))))

(def codetree (file)
  (treewise + (fn (x) 1) (readall (infile file))))

(def code-density (file)
  (/ (codetree file) (codelines file)))

(def tokcount (files)
  (ret counts (table)
    (each f files
      (each token (flat (readall (infile f)))
        (++ (counts token 0))))))

(def common-tokens (files)
  (let counts (tokcount files)
    (ret ranking nil
      (maptable (fn (k v)
                  (unless (nonop k)
                    (insort (compare > cadr) (list k v) ranking)))
                counts))))

(def nonop (x)
  (in x 'quote 'unquote 'quasiquote 'unquote-splicing))

(def common-operators (files)
  (keep [and (isa (car _) 'sym) (bound (car _))] (common-tokens files)))

(def top40 (xs)
  (map prn (firstn 40 xs))
  t)

(def space-eaters (files)
  (let counts (tokcount files)
    (let ranking nil
      (maptable (fn (k v)
                  (when (and (isa k 'sym) (bound k))
                    (insort (compare > [* (len (string (car _)))
                                          (cadr _)])
                            (list k v (* (len (string k)) v))
                            ranking)))
                counts)
    ranking)))

;(top40 (space-eaters allfiles*))

(mac flatlen args `(len (flat ',args)))


job #9050 - Update the archetype to handle R1505 for sorting Literal Symbolic Constants.

.//=====================================================================
.//
.// File:      create_metadata_elements_sorters.arc
.//
.//=====================================================================
.// Licensed under the Apache License, Version 2.0 (the "License"); you may not
.// use this file except in compliance with the License.  You may obtain a copy
.// of the License at
.//
.//      http://www.apache.org/licenses/LICENSE-2.0
.//
.// Unless required by applicable law or agreed to in writing, software
.// distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
.// WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.   See the
.// License for the specific language governing permissions and limitations under
.// the License.
.//=====================================================================
.//
.// The function declared below is responsible for creating the core.ui
.// action for rename. It is declared here because multiple plugins use
.// the same actions to carry out this task on the metamodel. Takes a
.// path parameter so that the comment correctly displays the generated
.// files location.
.//
./////////////////////////////////////////////////////////////////////////////
.invoke arc_env = GET_ENV_VAR( "PTC_MC_ARC_DIR" )
.assign mc_archetypes = arc_env.result
.if ( mc_archetypes == "" )
  .print "\nERROR: Environment variable PTC_MC_ARC_DIR not set."
  .exit 100
.end if
.//
.include "${mc_archetypes}/arch_utils.inc"
.//
.assign arc_dir = "arc"
.include "${arc_dir}/parse_chain.inc"
.//
.function create_type_sorter
  .param inst_ref model_class        .//O_OBJ
  .param inst_ref sorting_relation  .//R_REL
  .param string sorting_phrase
  .param string sorter_dir
  .param string core_path
  .param string core_package_name
  .param string manager_name
.//
.invoke cn = get_class_name(model_class)
.assign class_name = cn.body
.assign attr_sorter_class_name = "${class_name}Sorter"
.assign sorter_var_name = "$lr{model_class.Name}"
.//
.//
.select any part_participant related by sorting_relation->R_SIMP[R206]->R_PART[R207]
.assign other_phrase = "${part_participant.Txt_Phrs}"
.//
.if (other_phrase == sorting_phrase)
   .select any form_participant related by sorting_relation->R_SIMP[R206]->R_FORM[R208]
   .assign other_phrase = "${form_participant.Txt_Phrs}"
.end if
.//
.invoke nfn_result = get_nav_func_name( model_class, sorting_relation, "one" )
.assign primary_participant_function_name = "${nfn_result.body}$cr{sorting_phrase}"
.assign other_participant_function_name = "${nfn_result.body}$cr{other_phrase}"
.//
.assign attr_config_statement = "sortingManager.setTypeSorter(${class_name}.class, ${manager_name}.createDefaultSorterFactory(""${core_package_name}.${sorter_dir}.${attr_sorter_class_name}"")); //$$NON-NLS-1$$\n"
.//
package ${core_package_name}.${sorter_dir};

//======================================================================
//
// File: ${core_path}/${sorter_dir}/${attr_sorter_class_name}.java
//
// WARNING:      Do not edit this generated file
// Generated by: ${info.arch_file_name}
//
//======================================================================

.if ("${sorting_relation.Numb}" == "1505")
import ${core_package_name}.*;
.else
import ${core_package_name}.${class_name};
import ${core_package_name}.CorePlugin;
.end if

public class ${attr_sorter_class_name} extends BaseTypeSpecificSorter {

	public ${attr_sorter_class_name}() {
		super(${class_name}.class);
	}

	public void sort(Object[] elements) {
		if (elements.length < 2) {
			return;
		}

		${class_name}[] ${sorter_var_name}s = (${class_name}[]) elements;
		int index = 0;
		${class_name} tail = null;

		// Search from the end as there are fair chances that array is already
		// sorted.
		for (index = ${sorter_var_name}s.length - 1; index >= 0; index--) {
    .if ("${sorting_relation.Numb}" == "1505")
			LiteralSymbolicConstant_c ${sorter_var_name} = LiteralSymbolicConstant_c.getOneCNST_LSCOnR1503(LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1502(SymbolicConstant_c.getManyCNST_SYCsOnR1505Precedes(SymbolicConstant_c.getManyCNST_SYCsOnR1502(LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1503(${sorter_var_name}s[index])))));
    .else
			${class_name} ${sorter_var_name} = ${class_name}.${other_participant_function_name}(${sorter_var_name}s[index]);
    .end if
			if (${sorter_var_name} == null) {
				tail = ${sorter_var_name}s[index];
				break;
			}
		}

		if ( tail == null )
		{
			CorePlugin.logError("${model_class.Name} ordering relationship R${sorting_relation.Numb} is corrupt", null);
			return;
		}

		for (index = ${sorter_var_name}s.length - 1; index >= 0; index--) {
			${sorter_var_name}s[index] = tail;
    .if ("${sorting_relation.Numb}" == "1505")
			tail = LiteralSymbolicConstant_c.getOneCNST_LSCOnR1503(LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1502(SymbolicConstant_c.getManyCNST_SYCsOnR1505Succeeds(SymbolicConstant_c.getManyCNST_SYCsOnR1502(LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1503(tail)))));
    .else
			tail = ${class_name}.${primary_participant_function_name}(tail);
	.end if
		}
	}
}
.end function
./////////////////////////////////////////////////////////////////////////////
.function create_sortering_manager
  .param string sorter_config_statements
  .param string sorter_dir
  .param string core_path
  .param string core_package_name
  .param string manager_name
package ${core_package_name}.${sorter_dir};

//======================================================================
//
//File: ${core_path}/${sorter_dir}/${manager_name}.java
//
//WARNING:      Do not edit this generated file
//Generated by: ${info.arch_file_name}; create_sortering_manager
//
//======================================================================

import java.util.HashMap;
import java.util.List;
import java.util.Map;
import java.util.Vector;

import ${core_package_name}.*;
import org.xtuml.bp.core.common.ModelElement;
import org.xtuml.bp.core.common.NonRootModelElement;
import org.xtuml.bp.core.inspector.ObjectElement;

public class ${manager_name} {
	private Map sorterMap = new HashMap();
	private ISorterFactory defaultSorterFactory = null;

	public void setTypeSorter(Class type, ISorterFactory sorterFactory) {
		sorterMap.put(type, sorterFactory);
	}

	public void setDefaultTypeSorter(ISorterFactory sorterFactory) {
		defaultSorterFactory = sorterFactory;
	}

	public void sort(Object[] elements) {
		if (elements == null || elements.length <= 0) {
			return;
		}

		ISorterFactory sorterFactory = (ISorterFactory) sorterMap.get(elements[0].getClass());

		if (sorterFactory != null) {
			try {
				ISorter sorter = sorterFactory.createSorter(elements);
				sorter.sort(elements);
			} catch (SorterFactoryException e) {
				CorePlugin.logError("Could not create sorter", (Exception)e.getCause());
			}
		} else if (defaultSorterFactory != null) {
			try {
				ISorter sorter = defaultSorterFactory.createSorter(elements);
				if(sorter.canSort(elements)){
					sorter.sort(elements);
				}
			} catch (SorterFactoryException e) {
				CorePlugin.logError("Could not create sorter", (Exception)e.getCause());
			}
		}
	}

	public static ISorterFactory createDefaultSorterFactory(String className){
		return new DefaultSorterFactory(className);
	}

	public static ${manager_name} createDefault(){
		${manager_name} sortingManager = new ${manager_name}();
		${sorter_config_statements}
		return sortingManager;
	}

	public static interface ISorter {
		boolean canSort(Object[] elements);
		void sort(Object[] elements);
	}

	public static interface ISorterFactory {
		ISorter createSorter(Object[] elements) throws SorterFactoryException;
	}

	public static class SorterFactoryException extends Exception{
		public SorterFactoryException(String message, Throwable rootCause){
			super(message, rootCause);
		}
	}

	static class DefaultSorterFactory implements ISorterFactory {
		Class sorterClass;
		List sorters = new Vector();

		DefaultSorterFactory(String className) {
			try {
				sorterClass = Class.forName(className);
				if(!ISorter.class.isAssignableFrom(sorterClass)){
					throw new IllegalArgumentException("Class not of type ${manager_name}.ISorter");
				}
			} catch (ClassNotFoundException e) {
				throw new IllegalArgumentException("Could not create sorter class: " + e.getMessage());
			}
		}

		public ISorter createSorter(Object[] elements) throws SorterFactoryException{
			ISorter sorter = null;
			for (int i = 0; i < sorters.size(); i++) {
				sorter = (ISorter) sorters.get(i);
				if (sorter.canSort(elements)) {
					return sorter;
				}
			}

			try {
				sorter = (ISorter)sorterClass.newInstance();
				sorters.add(sorter);
				return sorter;
			} catch (InstantiationException e) {
				throw new SorterFactoryException("Could not create sorter", e);
			} catch (IllegalAccessException e) {
				throw new SorterFactoryException("Could not create sorter", e);
			}

		}

	}

	public static boolean isOrderedElement(Object element) {
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .if(node.SortingRelationNumber >= 0)
    .select any class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .invoke cn = get_class_name(class)
    .assign class_name = cn.body
		if(element.getClass() == ${class_name}.class) {
			return true;
		}
  .end if
.end for
		return false;
	}

	public static ModelElement getPreviousElement(NonRootModelElement next) {
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .if(node.SortingRelationNumber >= 0)
    .select any class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .invoke cn = get_class_name(class)
    .assign class_name = cn.body
    .select any sorting_relation from instances of R_REL where (selected.Numb == node.SortingRelationNumber)
    .select any part_participant related by sorting_relation->R_SIMP[R206]->R_PART[R207]
    .invoke nfn_result = get_nav_func_name( class, sorting_relation, "one" )
    .assign primary_participant_function_name = "${nfn_result.body}$cr{node.SortingRelationPhrase}"
		if(next.getClass() == ${class_name}.class) {
    .if(node.SortingRelationNumber == 1505)
    		return LiteralSymbolicConstant_c.getOneCNST_LSCOnR1503(LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1502(
					SymbolicConstant_c.getManyCNST_SYCsOnR1505Succeeds(SymbolicConstant_c.getManyCNST_SYCsOnR1502(
							LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1503((LiteralSymbolicConstant_c) next)))));
    .else
			return ${class_name}.${primary_participant_function_name}((${class_name}) next);
	.end if
		}
  .end if
.end for
		return null;
	}

	public static ModelElement getNextElement(NonRootModelElement previous) {
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .if(node.SortingRelationNumber >= 0)
    .select any class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .invoke cn = get_class_name(class)
    .assign class_name = cn.body
    .select any sorting_relation from instances of R_REL where (selected.Numb == node.SortingRelationNumber)
    .select any part_participant related by sorting_relation->R_SIMP[R206]->R_PART[R207]
    .assign other_phrase = "${part_participant.Txt_Phrs}"
    .if (other_phrase == node.SortingRelationPhrase)
      .select any form_participant related by sorting_relation->R_SIMP[R206]->R_FORM[R208]
      .assign other_phrase = "${form_participant.Txt_Phrs}"
    .end if
    .invoke nfn_result = get_nav_func_name( class, sorting_relation, "one" )
    .assign other_participant_function_name = "${nfn_result.body}$cr{other_phrase}"
		if(previous.getClass() == ${class_name}.class) {
    .if(node.SortingRelationNumber == 1505)
			return LiteralSymbolicConstant_c.getOneCNST_LSCOnR1503(LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1502(
					SymbolicConstant_c.getManyCNST_SYCsOnR1505Precedes(SymbolicConstant_c.getManyCNST_SYCsOnR1502(
							LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1503((LiteralSymbolicConstant_c) previous)))));
    .else
			return ${class_name}.${other_participant_function_name}((${class_name}) previous);
	.end if
		}
  .end if
.end for
		return null;
	}

	public static String getAssociationNumber(
			Object element) {
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .if(node.SortingRelationNumber >= 0)
    .select any class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .invoke cn = get_class_name(class)
    .assign class_name = cn.body
		if(element.getClass() == ${class_name}.class) {
			return "${node.SortingRelationNumber}";
		}
  .end if
.end for
		return "";
	}

	public static String getAssociationPhrase(
			Object element) {
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .if(node.SortingRelationNumber >= 0)
    .select any class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .invoke cn = get_class_name(class)
    .assign class_name = cn.body
		if(element.getClass() == ${class_name}.class) {
			return "$cr{node.SortingRelationPhrase}";
		}
  .end if
.end for
		return "";
	}
}
.end function
.//
.//
.assign sorter_dir = "sorter"
.assign core_path = "src/org/xtuml/bp/core"
.assign core_package_name = "org.xtuml.bp.core"
.assign manager_name = "MetadataSortingManager"
.//
.assign sorter_config_statements = ""
.//
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .if(node.SortingRelationNumber >= 0)
    .select any model_class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .select any sorting_relation from instances of R_REL where (selected.Numb == node.SortingRelationNumber)
    .invoke result = create_type_sorter(model_class, sorting_relation, node.SortingRelationPhrase, sorter_dir, core_path, core_package_name, manager_name)
${result.body}
    .emit to file "${core_path}/${sorter_dir}/${result.sorter_class_name}.java"
    .assign sorter_config_statements = "${sorter_config_statements}${result.config_statement}"
  .end if
.end for
.//
.invoke sm_result = create_sortering_manager(sorter_config_statements, sorter_dir, core_path, core_package_name, manager_name)
${sm_result.body}
.emit to file "${core_path}/${sorter_dir}/${manager_name}.java"

.//=====================================================================
.//
.// File:      $RCSfile: create_metadata_elements_sorters.arc,v $
.// Version:   $Revision: 1.12.88.2 $
.// Modified:  $Date: 2013/07/14 13:32:34 $
.//
.// (c) Copyright 2003-2014 Mentor Graphics Corporation All rights reserved.
.//
.//=====================================================================
.// Licensed under the Apache License, Version 2.0 (the "License"); you may not
.// use this file except in compliance with the License.  You may obtain a copy
.// of the License at
.//
.//      http://www.apache.org/licenses/LICENSE-2.0
.//
.// Unless required by applicable law or agreed to in writing, software
.// distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
.// WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.   See the
.// License for the specific language governing permissions and limitations under
.// the License.
.//=====================================================================
.//
.// The function declared below is responsible for creating the core.ui
.// action for rename. It is declared here because multiple plugins use
.// the same actions to carry out this task on the metamodel. Takes a
.// path parameter so that the comment correctly displays the generated
.// files location.
.//
./////////////////////////////////////////////////////////////////////////////
.invoke arc_env = GET_ENV_VAR( "PTC_MC_ARC_DIR" )
.assign mc_archetypes = arc_env.result
.if ( mc_archetypes == "" )
  .print "\nERROR: Environment variable PTC_MC_ARC_DIR not set."
  .exit 100
.end if
.//
.include "${mc_archetypes}/arch_utils.inc"
.//
.assign arc_dir = "arc"
.include "${arc_dir}/parse_chain.inc"
.//
.function create_type_sorter
  .param inst_ref model_class        .//O_OBJ
  .param inst_ref sorting_relation  .//R_REL
  .param string sorting_phrase
  .param string sorter_dir
  .param string core_path
  .param string core_package_name
  .param string manager_name
.//
.invoke cn = get_class_name(model_class)
.assign class_name = cn.body
.assign attr_sorter_class_name = "${class_name}Sorter"
.assign sorter_var_name = "$lr{model_class.Name}"
.//
.//
.select any part_participant related by sorting_relation->R_SIMP[R206]->R_PART[R207]
.assign other_phrase = "${part_participant.Txt_Phrs}"
.//
.if (other_phrase == sorting_phrase)
   .select any form_participant related by sorting_relation->R_SIMP[R206]->R_FORM[R208]
   .assign other_phrase = "${form_participant.Txt_Phrs}"
.end if
.//
.invoke nfn_result = get_nav_func_name( model_class, sorting_relation, "one" )
.assign primary_participant_function_name = "${nfn_result.body}$cr{sorting_phrase}"
.assign other_participant_function_name = "${nfn_result.body}$cr{other_phrase}"
.//
.assign attr_config_statement = "sortingManager.setTypeSorter(${class_name}.class, ${manager_name}.createDefaultSorterFactory(""${core_package_name}.${sorter_dir}.${attr_sorter_class_name}"")); //$$NON-NLS-1$$\n"
.//
package ${core_package_name}.${sorter_dir};

//======================================================================
//
// File: ${core_path}/${sorter_dir}/${attr_sorter_class_name}.java
//
// WARNING:      Do not edit this generated file
// Generated by: ${info.arch_file_name}
// Version:      $$Revision: 1.12.88.2 $$
//
// (c) Copyright 2004-2014 by Mentor Graphics Corp.  All rights reserved.
//
//======================================================================

import ${core_package_name}.${class_name};
import ${core_package_name}.CorePlugin;

public class ${attr_sorter_class_name} extends BaseTypeSpecificSorter {

	public ${attr_sorter_class_name}() {
		super(${class_name}.class);
	}

	public void sort(Object[] elements) {
		if (elements.length < 2) {
			return;
		}

		${class_name}[] ${sorter_var_name}s = (${class_name}[]) elements;
		int index = 0;
		${class_name} tail = null;

		// Search from the end as there are fair chances that array is already
		// sorted.
		for (index = ${sorter_var_name}s.length - 1; index >= 0; index--) {
			${class_name} ${sorter_var_name} = ${class_name}.${other_participant_function_name}(${sorter_var_name}s[index]);
			if (${sorter_var_name} == null) {
				tail = ${sorter_var_name}s[index];
				break;
			}
		}

		if ( tail == null )
		{
			CorePlugin.logError("${model_class.Name} ordering relationship R${sorting_relation.Numb} is corrupt", null);
			return;
		}

		for (index = ${sorter_var_name}s.length - 1; index >= 0; index--) {
			${sorter_var_name}s[index] = tail;
			tail = ${class_name}.${primary_participant_function_name}(tail);
		}
	}
}
.end function
./////////////////////////////////////////////////////////////////////////////
.function create_sortering_manager
  .param string sorter_config_statements
  .param string sorter_dir
  .param string core_path
  .param string core_package_name
  .param string manager_name
package ${core_package_name}.${sorter_dir};

//======================================================================
//
//File: ${core_path}/${sorter_dir}/${manager_name}.java
//
//WARNING:      Do not edit this generated file
//Generated by: ${info.arch_file_name}; create_sortering_manager
//Version:      $$Revision: 1.12.88.2 $$
//
//(c) Copyright 2004-2014 by Mentor Graphics Corp.  All rights reserved.
//
//======================================================================

import java.util.HashMap;
import java.util.List;
import java.util.Map;
import java.util.Vector;

import ${core_package_name}.*;
import org.xtuml.bp.core.common.ModelElement;
import org.xtuml.bp.core.common.NonRootModelElement;
import org.xtuml.bp.core.inspector.ObjectElement;

public class ${manager_name} {
	private Map sorterMap = new HashMap();
	private ISorterFactory defaultSorterFactory = null;

	public void setTypeSorter(Class type, ISorterFactory sorterFactory) {
		sorterMap.put(type, sorterFactory);
	}

	public void setDefaultTypeSorter(ISorterFactory sorterFactory) {
		defaultSorterFactory = sorterFactory;
	}

	public void sort(Object[] elements) {
		if (elements == null || elements.length <= 0) {
			return;
		}

		ISorterFactory sorterFactory = (ISorterFactory) sorterMap.get(elements[0].getClass());

		if (sorterFactory != null) {
			try {
				ISorter sorter = sorterFactory.createSorter(elements);
				sorter.sort(elements);
			} catch (SorterFactoryException e) {
				CorePlugin.logError("Could not create sorter", (Exception)e.getCause());
			}
		} else if (defaultSorterFactory != null) {
			try {
				ISorter sorter = defaultSorterFactory.createSorter(elements);
				if(sorter.canSort(elements)){
					sorter.sort(elements);
				}
			} catch (SorterFactoryException e) {
				CorePlugin.logError("Could not create sorter", (Exception)e.getCause());
			}
		}
	}

	public static ISorterFactory createDefaultSorterFactory(String className){
		return new DefaultSorterFactory(className);
	}

	public static ${manager_name} createDefault(){
		${manager_name} sortingManager = new ${manager_name}();
		${sorter_config_statements}
		return sortingManager;
	}

	public static interface ISorter {
		boolean canSort(Object[] elements);
		void sort(Object[] elements);
	}

	public static interface ISorterFactory {
		ISorter createSorter(Object[] elements) throws SorterFactoryException;
	}

	public static class SorterFactoryException extends Exception{
		public SorterFactoryException(String message, Throwable rootCause){
			super(message, rootCause);
		}
	}

	static class DefaultSorterFactory implements ISorterFactory {
		Class sorterClass;
		List sorters = new Vector();

		DefaultSorterFactory(String className) {
			try {
				sorterClass = Class.forName(className);
				if(!ISorter.class.isAssignableFrom(sorterClass)){
					throw new IllegalArgumentException("Class not of type ${manager_name}.ISorter");
				}
			} catch (ClassNotFoundException e) {
				throw new IllegalArgumentException("Could not create sorter class: " + e.getMessage());
			}
		}

		public ISorter createSorter(Object[] elements) throws SorterFactoryException{
			ISorter sorter = null;
			for (int i = 0; i < sorters.size(); i++) {
				sorter = (ISorter) sorters.get(i);
				if (sorter.canSort(elements)) {
					return sorter;
				}
			}

			try {
				sorter = (ISorter)sorterClass.newInstance();
				sorters.add(sorter);
				return sorter;
			} catch (InstantiationException e) {
				throw new SorterFactoryException("Could not create sorter", e);
			} catch (IllegalAccessException e) {
				throw new SorterFactoryException("Could not create sorter", e);
			}

		}

	}

	public static boolean isOrderedElement(Object element) {
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .if(node.SortingRelationNumber >= 0)
    .select any class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .invoke cn = get_class_name(class)
    .assign class_name = cn.body
		if(element.getClass() == ${class_name}.class) {
			return true;
		}
  .end if
.end for
		return false;
	}

	public static ModelElement getPreviousElement(NonRootModelElement next) {
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .if(node.SortingRelationNumber >= 0)
    .select any class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .invoke cn = get_class_name(class)
    .assign class_name = cn.body
    .select any sorting_relation from instances of R_REL where (selected.Numb == node.SortingRelationNumber)
    .select any part_participant related by sorting_relation->R_SIMP[R206]->R_PART[R207]
    .invoke nfn_result = get_nav_func_name( class, sorting_relation, "one" )
    .assign primary_participant_function_name = "${nfn_result.body}$cr{node.SortingRelationPhrase}"
		if(next.getClass() == ${class_name}.class) {
    .if(node.SortingRelationNumber == 1505)
    		return LiteralSymbolicConstant_c.getOneCNST_LSCOnR1503(LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1502(
					SymbolicConstant_c.getManyCNST_SYCsOnR1505Succeeds(SymbolicConstant_c.getManyCNST_SYCsOnR1502(
							LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1503((LiteralSymbolicConstant_c) next)))));
    .else
			return ${class_name}.${primary_participant_function_name}((${class_name}) next);
	.end if
		}
  .end if
.end for
		return null;
	}

	public static ModelElement getNextElement(NonRootModelElement previous) {
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .if(node.SortingRelationNumber >= 0)
    .select any class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .invoke cn = get_class_name(class)
    .assign class_name = cn.body
    .select any sorting_relation from instances of R_REL where (selected.Numb == node.SortingRelationNumber)
    .select any part_participant related by sorting_relation->R_SIMP[R206]->R_PART[R207]
    .assign other_phrase = "${part_participant.Txt_Phrs}"
    .if (other_phrase == node.SortingRelationPhrase)
      .select any form_participant related by sorting_relation->R_SIMP[R206]->R_FORM[R208]
      .assign other_phrase = "${form_participant.Txt_Phrs}"
    .end if
    .invoke nfn_result = get_nav_func_name( class, sorting_relation, "one" )
    .assign other_participant_function_name = "${nfn_result.body}$cr{other_phrase}"
		if(previous.getClass() == ${class_name}.class) {
    .if(node.SortingRelationNumber == 1505)
			return LiteralSymbolicConstant_c.getOneCNST_LSCOnR1503(LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1502(
					SymbolicConstant_c.getManyCNST_SYCsOnR1505Precedes(SymbolicConstant_c.getManyCNST_SYCsOnR1502(
							LeafSymbolicConstant_c.getManyCNST_LFSCsOnR1503((LiteralSymbolicConstant_c) previous)))));
    .else
			return ${class_name}.${other_participant_function_name}((${class_name}) previous);
	.end if
		}
  .end if
.end for
		return null;
	}

	public static String getAssociationNumber(
			Object element) {
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .if(node.SortingRelationNumber >= 0)
    .select any class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .invoke cn = get_class_name(class)
    .assign class_name = cn.body
		if(element.getClass() == ${class_name}.class) {
			return "${node.SortingRelationNumber}";
		}
  .end if
.end for
		return "";
	}

	public static String getAssociationPhrase(
			Object element) {
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .if(node.SortingRelationNumber >= 0)
    .select any class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .invoke cn = get_class_name(class)
    .assign class_name = cn.body
		if(element.getClass() == ${class_name}.class) {
			return "$cr{node.SortingRelationPhrase}";
		}
  .end if
.end for
		return "";
	}
}
.end function
.//
.//
.assign sorter_dir = "sorter"
.assign core_path = "src/org/xtuml/bp/core"
.assign core_package_name = "org.xtuml.bp.core"
.assign manager_name = "MetadataSortingManager"
.//
.assign sorter_config_statements = ""
.//
.select many tree_nodes from instances of T_TNS
.for each node in tree_nodes
  .// TODO: remove the below work around for association 1505.  It is added as the infrastructure did
  .// not support its situation and the class had to be hand crafted.  The SortingRelationNumber is required
  .// for sorting elsewhere so it is not turned off in the pei data
  .if((node.SortingRelationNumber >= 0) and (node.SortingRelationNumber != 1505))
    .select any model_class from instances of O_OBJ where (selected.Key_Lett == node.Key_Lett)
    .select any sorting_relation from instances of R_REL where (selected.Numb == node.SortingRelationNumber)
    .invoke result = create_type_sorter(model_class, sorting_relation, node.SortingRelationPhrase, sorter_dir, core_path, core_package_name, manager_name)
${result.body}
    .emit to file "${core_path}/${sorter_dir}/${result.sorter_class_name}.java"
    .assign sorter_config_statements = "${sorter_config_statements}${result.config_statement}"
  .end if
.end for
.//
.invoke sm_result = create_sortering_manager(sorter_config_statements, sorter_dir, core_path, core_package_name, manager_name)
${sm_result.body}
.emit to file "${core_path}/${sorter_dir}/${manager_name}.java"