;;; Copyright � 1990, 1991, 1992 by Xerox Corporation. All rights reserved.
;;; Michael Plass, May 11, 1990 2:35 pm PDT

(define (cedarsunrpcgen filename)
;; 
;; Body of cedarsunrpcgen starts here
(define closeparen
(string-ref "()" 1))

(define (identity x)
x)

(define dashoids (string->list "-_"))

(define (dash? c)
(memq c dashoids))

(define (count-string string char-predicate start end sum)
(if (< start end)
(count-string string char-predicate
(+ 1 start)
end (if (char-predicate (string-ref string start))
(+ 1 sum)
sum))
sum))

(define (mixed-case/dashes string initial?)
(define len (string-length string))
(define result
(make-string (- (string-length string)
(count-string string dash? 0 len 0))))
(let loop ((i 0)
(j 0)
(f (if initial? char-upcase identity)))
(cond ((= i len)
result)
((dash? (string-ref string i))
(loop (+ i 1)
j char-upcase))
(else
(string-set! result j (f (string-ref string i)))
(loop (+ i 1)
(+ j 1)
identity)))))

(define (mesa-field-id symbol)
(mixed-case/dashes (symbol->string symbol) #f))

(define (mesa-type-id symbol)
(mixed-case/dashes (symbol->string symbol) #t))

(define *types* '())

(define *programs* '())

(define *constants* '())

(define (make-tabl name init)
(cons '*types* (append init '())))

(define (tabl-keys tabl)
(map car (cdr tabl)))

(define (tabl-for-each proc tabl)
(for-each proc (cdr tabl)))

(define (tabl-lookup-check-missing entry name tabl)
(if entry
entry
(error (car tabl) name "unknown name")))

(define (tabl-lookup name tabl)
(tabl-lookup-check-missing (assq name (cdr tabl))
name tabl))

(define (tabl-insert! entry tabl)
(cond ((null? (cdr tabl))
(set-cdr! tabl (list entry)))
((eqv? (cadr tabl) (car entry))
(bad entry))
(else
(tabl-insert! entry (cdr tabl)))))

(define (load-rpc filename)
(set! *types*
(make-tabl '*types* <builtin-types>))
(set! *constants*
(make-tabl '*constants* <builtin-constants>))
(set! *programs*
(make-tabl '*programs* '()))
(call-with-input-file filename read-rpc-items))

(define <builtin-types> '
((void (builtin (xdr "void") (mesa "")))
(boolean (builtin (xdr "bool")
(mesa "BOOL" "SunRPCNumbers.GetBool" "SunRPCNumbers.PutBool")))
(integer (builtin (xdr "int")
(mesa "INT32" "SunRPC.GetInt32" "SunRPC.PutInt32")))
(hyper-integer (builtin (xdr "hyper")
(mesa "INT64" "SunRPCNumbers.GetInt64" "SunRPCNumbers.PutInt64")))
(cardinal (builtin (xdr "unsigned int")
(mesa "CARD32" "SunRPC.GetCard32" "SunRPC.PutCard32")))
(hyper-cardinal (builtin (xdr "unsigned hyper")
(mesa "CARD64" "SunRPCNumbers.GetCard64"
"SunRPCNumbers.PutCard64")))
(float (builtin (xdr "float") (mesa "REAL" "SunRPCNumbers.GetReal"
"SunRPCNumbers.PutReal")))
(double (builtin (xdr "double") (mesa "DREAL" "SunRPCNumbers.GetDReal"
"SunRPCNumbers.PutDReal")))))

(define <builtin-constants> '
((#t (builtin (xdr "TRUE") (mesa "TRUE")))
(#f (builtin (xdr "FALSE") (mesa "FALSE")))))

(define (mesa-builtin x)
(cadr (assq 'mesa (cdr x))))

(define (bad x)
(display "bad: ")
(write x)
(newline)
(error 'rpc x "bad"))

(define (read-rpc-items port)
(define x (read port))
(cond ((eof-object? x)
(list (tabl-keys *constants*) (tabl-keys *types*)
(tabl-keys *programs*)))
((and (pair? x)
(> (length x) 2)
(symbol? (car x)))
(tabl-insert! (cdr x) (case (car x)
((define-constant) *constants*)
((define-type) *types*)
((define-program) *programs*)
(else (bad x))))
(read-rpc-items port))
(else (bad x))))

(define entry-name car)

(define entry-value cadr)

(define (builtin? x)
(and (pair? x) (eqv? (car x) 'builtin)))

(define (mesa-constant-type-id x)
(cond ((symbol? x)
(display "---- ") ; could loop!
(mesa-constant-type-id (entry-value (tabl-lookup x *constants*))))
((and (number? x) (inexact? x))
"REAL")
((integer? x)
(if (negative? x) "INT" "CARD"))
((boolean? x) "BOOL")
((string? x) "ROPE")
(else "UNSPECIFIED")))

(define (mesa-constant-value x)
(cond ((integer? x) x)
((real? x) (exact->inexact x))
((boolean? x)
(if x "TRUE" "FALSE"))
((string? x)
(format #f "~s" x))
(else x) ; probably bad
))

(define (void-type? type)
(eq? type 'void))

(define (mesa-type name)
(define v
(tabl-lookup name *types*))
(cond ((pair? (entry-value v))
(case (car (entry-value v))
((union vector)
(string-append "REF " (mesa-type-id name)))
((builtin)
(mesa-builtin (entry-value v)))
(else (mesa-type-id name))))
(else (mesa-type-id name))))

(define dlm-stack '())

(define dlm? #f)

(define *emit-port* (current-output-port))

(define (emit-to-file filename thunk)
(call-with-output-file filename
(lambda (p)
(let ((save *emit-port*))
(set! *emit-port* p)
(thunk)
(set! *emit-port* save)))))

(define (do-indent n)
(cond ((positive? n)
(display "  " *emit-port*)
(do-indent (- n 1)))))

(define (emit1 x)
(display x *emit-port*)
(if (eqv? x #\newline)
(do-indent (length dlm-stack))))

(define (emit . args)
(emit-lst args))


(define (emit-lst args)
(if dlm?
(begin (emit1 (string-ref (car dlm-stack) 1))
(emit1 (string-ref (car dlm-stack) 2))
(set! dlm? #f)))
(for-each emit1 args))

(define <body> "{;\n}")

(define <blist> "[,\n]")
(define <scases> " ;\nENDCASE")
(define <ecases> " ,\nENDCASE")

(define (open dlms)
(emit (string-ref dlms 0))
(set! dlm-stack
(cons dlms dlm-stack))
(emit1 (string-ref dlms 2)))

(define (dlm)
(set! dlm? #t))

(define (close)
(set! dlm? #f)
(emit1 (string-ref (car dlm-stack) 2))
(emit1 (if (= (string-length (car dlm-stack)) 4)
(string-ref (car dlm-stack) 3)
(substring (car dlm-stack) 3 (string-length (car dlm-stack)))))
(set! dlm-stack (cdr dlm-stack)))

(define (emit-d . args)
(emit-lst args)
(dlm))

(define (close-d)
(close)
(dlm))

(define (emit-comment s)
(emit1 "-- ")
(emit1 s)
(emit1 " --")
(emit1 #\newline))

(define (emit-constant ce)
(if (not (builtin? (entry-value ce)))
(begin (emit (mesa-field-id (entry-name ce))
": "
(mesa-constant-type-id (entry-value ce))
" = " (mesa-constant-value (entry-value ce)))(dlm))))

(define (emit-type type)
(cond ((symbol? type)
(emit (mesa-type type)))
((pair? type)
(case (car type)
((builtin)
(emit (mesa-builtin type)))
((record)
(emit "RECORD ")
(open <blist>)
(for-each (lambda (x)
(apply emit-field-def x)(dlm))
(cdr type))
(close))
((string)
(emit "ROPE <<" (cdr type) ">>"))
((union)
(emit "RECORD ")
(open <blist>)
(emit "SELECT "
(mesa-field-id (cadadr type))
": "
(mesa-type-id (car (cddadr type)))
" FROM")
(open <ecases>)
(for-each (lambda (x)
(apply emit-select-arm x)(dlm))
(cddr type))
(close)
(close))
((vector)
(emit "RECORD ")
(open <blist>)
(emit "SEQUENCE size: CARD OF ")
(emit-type (caddr type))
(close))
((array)
(emit "ARRAY [0.."
(mesa-constant-value (cadr type))
closeparen " OF ")
(emit-type (caddr type)))
((enum)
(emit "MACHINE DEPENDENT ")
(open "{, }")
(for-each (lambda (x)
(apply emit-enum-entry x)(dlm))
(cdr type))
(close))
(else
(emit "RECORD[-- ?? " type " ?? --]"))))
(else (bad ce))))

(define (emit-enum-entry name value)
(emit (mesa-field-id name) "(" (mesa-constant-value value) ")"))

(define (emit-select-arm keys . fields)
(let loop ((tail keys))
(cond ((not (null? tail))
(if (not (eq? tail keys))
(emit1 ", "))
(emit (mesa-constant-value (car tail)))
(loop (cdr tail)))))
(emit1 " => ")
(open <blist>)
(for-each (lambda (x)
(apply emit-field-def x)(dlm))
fields)
(close))

(define (emit-field-def f name type)
(if (not (eqv? f 'field))
(bad f))
(emit (mesa-field-id name) ": ")
(emit-type type))

(define (emit-typedef ce)
(cond ((not (assq (entry-name ce) <builtin-types>))
(emit (mesa-type-id (entry-name ce))
": TYPE = ")
(emit-type (entry-value ce))(dlm))))

(define (emit-proc-header public? d name proctype . numbers)
(emit (mesa-type-id name) ": ")
(if public? (emit1 "PUBLIC "))
(emit1 "PROC ")
(open "[, ]")
(emit "h: SunRPC.Handle, c: SunRPC.Conversation, clientData: REF") (dlm)
(for-each (lambda (x)
(if (not (void-type? x)) (begin
(emit "arg: ") ; for now, allow at most one arg.
(emit-type x)(dlm))))

(cadr proctype))
(close)
(emit1 " RETURNS ")
(open "[, ]")
(for-each (lambda (x)
(if (not (void-type? x)) (begin
(emit "res: ") ; for now, allow at most one result
(emit-type x)(dlm))))
(cddr proctype))
(close))

(define (emit-unmarshal-proc-header public? ce)
(cond ((not (assq (entry-name ce) <builtin-types>))
(emit "Get"
(mesa-type-id (entry-name ce))
": ")
(if public? (emit1 "PUBLIC "))
(emit1 "PROC ")
(open "[, ]")
(emit-d "h: SunRPC.Handle")
(close)
(emit1 " RETURNS ")
(open "[, ]")
(emit "obj: " (mesa-type (entry-name ce)))
(close)
#t)
(else #f)))

(define (emit-unmarshal-proc ce)
(and (emit-unmarshal-proc-header #t ce)
(begin (emit1 " = ")
(open <body>)
(emit-unmarshal-type (entry-name ce) (entry-value ce) "obj")(dlm)
(close)
#t)))

(define (emit-unmarshal-field lhs f name type)
(emit-unmarshal-type #f type (string-append lhs "." (mesa-field-id name)))(dlm))

(define (emit-unmarshal-type typename type lhs)
(cond ((symbol? type)
(cond ((not (void-type? type))
(emit lhs)
(emit-d " := Get"(mesa-type-id type)"[h]"))))
((pair? type)
(case (car type)
((record)
(for-each (lambda (x)
(apply emit-unmarshal-field lhs x))
(cdr type)))
((string)
(emit lhs)
(emit-d " := SunRPC.GetRope[h]"))
((array)
(let ((basetype (caddr type))
(size (cadr type)))
(emit "FOR i: CARD IN [0.." (mesa-constant-value size)
closeparen " DO")
(open " ;\nENDLOOP")
(emit-unmarshal-type #f basetype (string-append lhs "[i]"))
(close-d)))
((vector)
(let ((basetype (caddr type))
(rep (mesa-type-id typename)))
(open <body>)
(emit-d "size: CARD = GetCardinal[h]")
(emit-d "v: REF "rep" = NEW["rep"[size]]")
(emit "FOR i: CARD IN [0..size"closeparen" DO")
(open " ;\nENDLOOP")
(emit-unmarshal-type #f basetype "v[i]")
(close-d)
(emit lhs " := v")
(close-d)))
((union)
(let ((tagname (cadadr type))
(tagtype (car (cddadr type)))
(rep (mesa-type-id typename)))
(define mesatagtype (mesa-type-id tagtype))
(define (emit-select-arms tags . fields)
(define (emit-select-arm name)
(define mesatagname (mesa-field-id name))
(emit mesatagname " => ")
(open <body>)
(emit-d "v: REF "rep"."mesatagname" = NEW["rep"."mesatagname"]")
(for-each (lambda (x)
(apply emit-unmarshal-field "v" x))
fields)
(emit lhs " := v")
(close-d))
(for-each emit-select-arm tags))
(open <body>)
(emit-d "tag: "mesatagtype" = Get"mesatagtype"[h]")
(emit "SELECT tag FROM")
(open <scases>)
(for-each (lambda (x)
(apply emit-select-arms x))
(cddr type))
(close-d)
(close-d)))
((enum)
(emit-d lhs " := VAL[GetCardinal[h]]"))
(else
(emit-d "-- ?? " type " ?? --"))))
(else (help))))

(define (emit-marshal-proc-header public? ce)
(cond ((not (assq (entry-name ce) <builtin-types>))
(emit "Put"
(mesa-type-id (entry-name ce))
": ")
(if public? (emit1 "PUBLIC "))
(emit1 "PROC ")
(open "[, ]")
(emit-d "h: SunRPC.Handle")
(emit "obj: " (mesa-type (entry-name ce)))
(close)
#t)
(else #f)))

(define (emit-marshal-proc ce)
(and (emit-marshal-proc-header #t ce)
(begin (emit1 " = ")
(open <body>)
(emit-marshal-type (entry-name ce) (entry-value ce) "obj")(dlm)
(close)
#t)))

(define (emit-marshal-field rhs f name type)
(emit-marshal-type #f type (string-append rhs "." (mesa-field-id name)))(dlm))

(define (emit-marshal-type typename type rhs)
(cond ((symbol? type)
(cond ((not (void-type? type))
(emit-d "Put" (mesa-type-id type) "[h, " rhs "]"))))
((pair? type)
(case (car type)
((record)
(for-each (lambda (x)
(apply emit-marshal-field rhs x))
(cdr type)))
((string)
(emit "SunRPC.PutRope[h, " rhs "]"))
((array)
(let ((basetype (caddr type))
(size (cadr type)))
(emit "FOR i: CARD IN [0.." (mesa-constant-value size)
closeparen " DO")
(open " ;\nENDLOOP")
(emit-marshal-type #f basetype (string-append rhs "[i]"))
(close)))
((vector)
(let ((basetype (caddr type))
(rep (mesa-type-id typename)))
(open <body>)
(emit-d "v: REF " rep " = " rhs)
(emit-d "PutCardinal[h, v.size]")
(emit "FOR i: CARD IN [0..v.size" closeparen " DO")
(open " ;\nENDLOOP")
(emit-marshal-type #f basetype "v[i]")
(close-d)
(close)))
((union)
(let ((tagname (cadadr type))
(tagtype (car (cddadr type)))
(rep (mesa-type-id typename)))
(define mesatagtype (mesa-type-id tagtype))
(define (emit-select-arms tags . fields)
(define (emit-select-arm name)
(define mesatagname (mesa-field-id name))
(emit "v: REF " rep "." mesatagname " => ")
(open <body>)
(emit-marshal-type #f tagtype name)
(for-each (lambda (x)
(apply emit-marshal-field "v" x))
fields)
(close-d))
(for-each emit-select-arm tags))
(emit "WITH " rhs " SELECT FROM")
(open <scases>)
(for-each (lambda (x)
(apply emit-select-arms x))
(cddr type))
(close)))
((enum)
(emit "PutCardinal[h, ORD[" rhs "]]"))
(else
(emit-d "-- ?? " type " ?? --"))))
(else (help))))

(define (prop-ref assoc-list key default)
(let ((e (assq key assoc-list)))
(if e (cadr e) default)))

(define (program-prop-ref program key default)
(prop-ref (cadr program) key default))

(define (generate-mesa-interface program)
(define interface-name
(string-append (mesa-type-id (car program))
"SunRPC"))
(define prog-num
(program-prop-ref program 'sun-rpc-program -1))
(define prog-vers
(program-prop-ref program 'sun-rpc-version 0))
(set! dlm-stack '())
(set! dlm? #f)
(display interface-name)
(display ".mesa ... ")
(emit-to-file
(string-append interface-name ".mesa")
(lambda ()
(emit "-- " interface-name ".mesa\n")
(emit "  -- Generated by RPCGenerate.scheme\n\n")
(emit "DIRECTORY Rope, SunRPC, SunRPCAuth;\n\n")
(emit interface-name ": CEDAR DEFINITIONS = ")
(open <body>)
(emit-d "ROPE: TYPE = Rope.ROPE")
(emit "GetHandles: PROC [program: CARD := " prog-num
", programVersion: CARD := " prog-vers "]")
(emit-d " RETURNS [h: SunRPC.Handle, c: SunRPCAuth.Conversation]")
(tabl-for-each emit-constant *constants*)
(tabl-for-each emit-typedef *types*)
(for-each (lambda (x)
(apply emit-proc-header #f x)(dlm))
(cddr program))
(tabl-for-each (lambda (x)
(if (emit-unmarshal-proc-header #f x)(dlm)))
*types*)
(tabl-for-each (lambda (x)
(if (emit-marshal-proc-header #f x)(dlm)))
*types*)
(close)
(emit ".\n"))))

(define (emit-builtin-marshal-procs lst)
(cond ((not (null? lst))
(let ((name (caar lst))
(m (assq 'mesa (cdadar lst))))
(cond ((and (pair? m) (> (length m) 3))
(emit "Get" (mesa-type-id name)
": PROC [h: SunRPC.Handle] RETURNS ["
(mesa-type name) "] = INLINE ")
(open <body>)
(emit "RETURN [" (caddr m) "[h]]")
(close-d)
(emit "Put" (mesa-type-id name)
": PROC [h: SunRPC.Handle, obj: " (mesa-type name)
"] = INLINE ")
(open <body>)
(emit (cadddr m) "[h, obj]")
(close-d))))
(emit-builtin-marshal-procs (cdr lst)))))

(define (generate-mesa-xdr program)
(define interface-name
(string-append (mesa-type-id (car program))
"SunRPC"))
(define module-name
(string-append (mesa-type-id (car program))
"XDRImpl"))
(set! dlm-stack '())
(set! dlm? #f)
(display module-name)
(display ".mesa ... ")
(emit-to-file
(string-append module-name ".mesa")
(lambda ()
(emit "-- "module-name".mesa\n" )
(emit "  -- Generated by RPCGenerate.scheme\n\n")
(emit "DIRECTORY "interface-name", Rope, SunRPC, SunRPCNumbers;\n\n" )
(emit  module-name": CEDAR PROGRAM IMPORTS SunRPC, SunRPCNumbers EXPORTS "interface-name" = "
 )
(open <body>)
(emit-d "OPEN " interface-name)
(emit-d "ROPE: TYPE = Rope.ROPE")
(emit-builtin-marshal-procs <builtin-types>)
(tabl-for-each (lambda (x)
(if (emit-unmarshal-proc x) (dlm)))
*types*)
(tabl-for-each (lambda (x)
(if (emit-marshal-proc x) (dlm)))
*types*)
(emit-d "NULL <<start code>>")
(close)
(emit ".\n"))))

(define (emit-client-proc prog vers d name proctype . numbers)
(define result-type (caddr proctype))
(define number (prop-ref numbers 'sun-rpc -1))
(emit-proc-header #t d name proctype)
(emit " = ")
(begin
(open <body>)
(emit-d "SunRPC.StartCall[h, c, "prog", "vers", "number"]")
(for-each (lambda (x)
(emit-marshal-type #f x "arg")(dlm))
(cadr proctype))
(emit-d "[] := SunRPC.SendCallAndReceiveReply[h, mediumTimeout, defaultRetries]")
(for-each (lambda (x)
(emit-unmarshal-type #f x "res")(dlm))
(cddr proctype))
(emit-d "SunRPC.ReleaseReply[h]")
(close-d)))

(define (generate-mesa-client program)
(define prog-num
(program-prop-ref program 'sun-rpc-program -1))
(define prog-vers
(program-prop-ref program 'sun-rpc-version 0))
(define interface-name
(string-append (mesa-type-id (car program))
"SunRPC"))
(define module-name
(string-append (mesa-type-id (car program))
"SunRPCClientImpl"))
(set! dlm-stack '())
(set! dlm? #f)
(display module-name)
(display ".mesa ... ")
(emit-to-file
(string-append module-name ".mesa")
(lambda ()
(emit "-- "module-name".mesa\n" )
(emit "  -- Generated by RPCGenerate.scheme\n\n")
(emit "DIRECTORY "interface-name", Arpa, ArpaExtras, Basics, ConvertExtras, IO, PBasics, Rope, SunAuthUnix, SunPMap, SunPMapClient, SunRPC, SunRPCAuth, SunRPCNumbers, UserCredentials;\n\n" )
(emit  module-name": CEDAR PROGRAM IMPORTS "interface-name", ArpaExtras, Basics, PBasics, SunAuthUnix, SunPMapClient, SunRPC, SunRPCAuth, SunRPCNumbers, UserCredentials EXPORTS "interface-name" = "
 )
(open <body>)
(emit-d "OPEN " interface-name)
(emit-d "ROPE: TYPE = Rope.ROPE")
(emit-builtin-marshal-procs <builtin-types>)
(emit "TIMEOUT: CARDINAL = 25") (dlm)
(emit "fastTimeout: CARDINAL = 500") (dlm)
(emit "mediumTimeout: CARDINAL = 2000") (dlm)
(emit "defaultRetries: CARDINAL = 5") (dlm)
(emit "noRetries: CARDINAL = 0") (dlm)
(emit "GetHandles: PUBLIC PROC [program, programVersion: CARD]")
(emit " RETURNS [h: SunRPC.Handle, c: SunRPCAuth.Conversation] = ")
(begin
(open <body>)
(emit-d "hostAddress: Arpa.Address = ArpaExtras.MyAddress[]")
(emit-d "myName, myPassword: ROPE")
(emit-d "port: CARDINAL")
(emit-d "h := SunRPC.Create[hostAddress, PBasics.HFromCard16[SunPMap.udpPort]]")
(emit-d "[myName, myPassword] := UserCredentials.Get[]")
(emit-d "c := SunRPCAuth.Initiate[SunRPCAuth.nullFlavor, SunAuthUnix.FixNameForUnix[myName], myPassword]")
(emit-d "port := SunPMapClient.GetPort[h, c, program, programVersion, SunPMap.ipProtocolUDP]")
(emit-d "IF port = 0 THEN ERROR SunRPC.Error[$failedSunPMapClientGetPort]")
(emit-d "h := SunRPC.SetRemote[h, hostAddress, PBasics.HFromCard16[PBasics.LowHalf[port]]]")
(close-d))
(for-each (lambda (x)
(apply emit-client-proc prog-num prog-vers x))
(cddr program))
(emit-d "NULL <<start code>>")
(close)
(emit ".\n"))))

(define (emit-server-arm prog vers d name proctype . numbers)
(define result-type (caddr proctype))
(define number (prop-ref numbers 'sun-rpc -1))
(emit number" => ")
(begin (open <body>)
(for-each
(lambda (x)
(cond ((not (void-type? x))
(emit "arg: ")
(emit-type x)
(dlm))))
(cadr proctype))
(for-each
(lambda (x)
(cond ((not (void-type? x))
(emit "res: ")
(emit-type x)
(dlm))))
(cddr proctype))
(for-each (lambda (x)
(emit-unmarshal-type #f x "arg"))
(cadr proctype))
(begin (open "[, ]")
(for-each
(lambda (x)
(cond ((not (void-type? x))
(emit "res")
(dlm))))
(cddr proctype))
(close))
(emit " := " (mesa-type-id name))
(begin (open "[, ]")
(emit-d "h")
(emit-d "c")
(emit-d "clientData")
(for-each
(lambda (x)
(cond ((not (void-type? x))
(emit "arg")
(dlm))))
(cadr proctype))
(close-d))
(emit-d "SunRPC.StartReply[h]")
(for-each (lambda (x)
(emit-marshal-type #f x "res")(dlm))
(cddr proctype))
(close)))

(define (generate-mesa-server program)
(define prog-num
(program-prop-ref program 'sun-rpc-program -1))
(define prog-vers
(program-prop-ref program 'sun-rpc-version 0))
(define interface-name
(string-append (mesa-type-id (car program))
"SunRPC"))
(define module-name
(string-append (mesa-type-id (car program))
"SunRPCServerImpl"))
(set! dlm-stack '())
(set! dlm? #f)
(display module-name)
(display ".mesa ... ")
(emit-to-file
(string-append module-name ".mesa")
(lambda ()
(emit "-- " module-name ".mesa\n")
(emit "  -- Generated by RPCGenerate.scheme\n\n")
(emit
"DIRECTORY " interface-name
", ArpaUDP, Basics, SunPMap, SunPMapLocal, SunRPC, SunRPCAuth, SunRPCNumbers, Rope;\n\n")
(emit module-name ": CEDAR PROGRAM IMPORTS " interface-name
", Basics, SunPMapLocal, SunRPC, SunRPCNumbers = ")
(open <body>)
(emit-d "OPEN " interface-name)
(emit-d "ROPE: TYPE = Rope.ROPE")
(emit-builtin-marshal-procs <builtin-types>)
(emit-d "defaultReplyTTL: CARDINAL := 2")
(emit-d "serverStarted: BOOL := FALSE")
(emit-d "server: SunRPC.Server := StartServer[]")
(emit "StartServer: PROC RETURNS [SunRPC.Server] = ")
(begin
(open <body>)
(emit-d "server: SunRPC.Server = SunRPC.CreateServer["prog-num", "
prog-vers", Dispatch, ArpaUDP.nullPort, 3, NIL]")
(emit-d "[] := SunPMapLocal.UnsetLocal[" prog-num ", " prog-vers "]")
(emit-d
"serverStarted := SunPMapLocal.SetLocal[" prog-num ", "
prog-vers
", SunPMap.ipProtocolUDP, Basics.Card16FromH[SunRPC.GetServerPort[server]]]")
(emit-d "RETURN [ server ]")
(close-d))
(emit "Dispatch: SunRPC.ServerProc = ")
(begin
(open <body>)

(emit-comment "[h: Handle, c: Conversation, proc: CARD, clientData: REF]")
(emit-comment "RETURNS [doReply: BOOLEAN, replyTimeToLive: CARDINAL]")
(emit-d "server: SunRPC.Server = SunRPC.CreateServer["prog-num ", "
prog-vers", Dispatch, ArpaUDP.nullPort, 3, NIL]")
(emit-d "doReply := TRUE")
(emit-d "replyTimeToLive := defaultReplyTTL")
(emit "SELECT proc FROM")
(begin (open <scases>)
(for-each (lambda (x)
(apply emit-server-arm prog-num prog-vers x)(dlm))
(cddr program))
(close-d))
(close-d))
(emit-d "NULL <<start code>>")
(close)
(emit ".\n"))))

(define (generate-mesas)
(tabl-for-each generate-mesa-interface *programs*)
(tabl-for-each generate-mesa-xdr *programs*)
(tabl-for-each generate-mesa-client *programs*)
(tabl-for-each generate-mesa-server *programs*))

(load-rpc filename)
(generate-mesas)
)

�;;; RPCGenerate.scheme
;;; 
;;; I don't have time to document this adequately before my vacation, but here is a stub generator that goes from a lispy interface description to cedar stubs.
��0R�
(cedarcode) style�NewlineDelimiter

�
code�
�c�Ischeme���cet
���+�KL�
�+�+L�L��
�L���
�k�
�n�!L�L�%��
��
�
�L��L���
�����L��L�L��
��
���%L���
�����L��L���
����%�:��
����#L�11 sp bigger leftIndent��11 sp bigger leftIndent����+�2L�4 sp bigger leftIndent�	L�4 sp bigger leftIndent���L���L���
�����+L��
��
���#��
��
���&L�13 sp bigger leftIndent�&����
���L�8 sp bigger leftIndent�L�8 sp bigger leftIndent����!�'��
���L�4 sp bigger leftIndent��3 sp bigger leftIndent��-2 sp bigger leftIndent�
L�3 sp bigger leftIndent����3 sp bigger leftIndent��
��L�-2 sp bigger leftIndent�0�-2 sp bigger leftIndent�
L�3 sp bigger leftIndent�L�3 sp bigger leftIndent�
�����L���
���
��L�/�L���
�����L�/�L�L��
��
��
�
��L�L��
��
�
�
�
��L�L��
��
��
�
��L���
���	��L���
��
��"�L���
���	��L��L���
���
��!L��L���
�����3��
���	L�L�(��L���
������1L�24 sp bigger leftIndent���L���
�����!��
���L�4 sp bigger leftIndent��3 sp bigger leftIndent�L�-2 sp bigger leftIndent���3 sp bigger leftIndent��
��L�-2 sp bigger leftIndent�"���L���
����
���
��
��
L���
��%���
��
��L���
�!�-���
��
�
�L���
��
���L�/�L���
��
���(�-2 sp bigger leftIndent�L�15 sp bigger leftIndent�
�?�?��-2 sp bigger leftIndent�L�15 sp bigger leftIndent�4��-2 sp bigger leftIndent�%L�20 sp bigger leftIndent�
�B�B��-2 sp bigger leftIndent�'L�16 sp bigger leftIndent�7��-2 sp bigger leftIndent�/�22 sp bigger leftIndent�
�(�(L�3 sp bigger leftIndent�
�����-2 sp bigger leftIndent�
�B�BL�33 sp bigger leftIndent�
����-2 sp bigger leftIndent�
�F�FL�35 sp bigger leftIndent�
�����L���
��
���*L�-2 sp bigger leftIndent�-��L���
�����L���
���L���
�����L�L�	L�	L���
�
��L���
�����L��
��
�
�
���
����4 sp bigger leftIndent�1L�3 sp bigger leftIndent���3 sp bigger leftIndent�L�3 sp bigger leftIndent�L�3 sp bigger leftIndent��-2 sp bigger leftIndent�����#L�22 sp bigger leftIndent�L�22 sp bigger leftIndent�L�22 sp bigger leftIndent�L�22 sp bigger leftIndent��
����L�-2 sp bigger leftIndent��L�3 sp bigger leftIndent��
�����L�L��
��
�
��L�L��
��
���L���
�����L���
�
�(�L���
�����!��
��
�L�4 sp bigger leftIndent���
�L�4 sp bigger leftIndent�B�3 sp bigger leftIndent�L�-2 sp bigger leftIndent���3 sp bigger leftIndent�
L�-2 sp bigger leftIndent��
��� �L�3 sp bigger leftIndent�L�3 sp bigger leftIndent�
��L�3 sp bigger leftIndent��
�����L���
�������
���L�3 sp bigger leftIndent��3 sp bigger leftIndent�
L�-2 sp bigger leftIndent��
�����3 sp bigger leftIndent�L�-2 sp bigger leftIndent���3 sp bigger leftIndent��
����L�-1 sp bigger leftIndent����L���
���
��L�
���L���
���	����
��
�
�	L����
����4 sp bigger leftIndent��
����L�-2 sp bigger leftIndent�+��
L�-2 sp bigger leftIndent��L��
����L�3 sp bigger leftIndent��
�����L�L��
��
�	�
�
��L�L��
��
���L�L��
��
���*L���
�����%�
����
�����
���L��
��
���L�L��
��
��
�����L���
���	����
���L�4 sp bigger leftIndent�L�4 sp bigger leftIndent���L���
�����L���
���L� ��L���
����
�
��L��L�L���
�������
�����
��'�-L�4 sp bigger leftIndent�&L�4 sp bigger leftIndent��
��
�����L��L�L��
��
��	�L�L��
��
��	�L��
��
���L��
��
���L���
�����L���
��
�	�L��L��L���
����
�
L��
��
����L���
����
�L��
��
���L�&����&�0L�7 sp bigger leftIndent�L�7 sp bigger leftIndent�?�L��
��
�	��!�L���
����
�
��L�L��L���
����
�L�L��L���
�����L�
L�	L�
L��L���
���
����
��"�%��
��&�,L�10 sp bigger leftIndent�L�10 sp bigger leftIndent�(L�10 sp bigger leftIndent�5���L���
���	����
���L�4 sp bigger leftIndent��3 sp bigger leftIndent�
�-2 sp bigger leftIndent��
����
L�-2 sp bigger leftIndent���	L�-2 sp bigger leftIndent�L�-2 sp bigger leftIndent��-2 sp bigger leftIndent�����L�10 sp bigger leftIndent�L�7 sp bigger leftIndent��L�-2 sp bigger leftIndent���	L�-2 sp bigger leftIndent�!��L�-2 sp bigger leftIndent�L�-2 sp bigger leftIndent��-2 sp bigger leftIndent�L�3 sp bigger leftIndent�L�3 sp bigger leftIndent�L�3 sp bigger leftIndent�"L�3 sp bigger leftIndent��L�-2 sp bigger leftIndent��-2 sp bigger leftIndent�����L�10 sp bigger leftIndent�L�7 sp bigger leftIndent��L�-2 sp bigger leftIndent�L�-2 sp bigger leftIndent���	L�-2 sp bigger leftIndent�L�-2 sp bigger leftIndent�L�-2 sp bigger leftIndent� L�-2 sp bigger leftIndent�L�-2 sp bigger leftIndent����-2 sp bigger leftIndent�L�3 sp bigger leftIndent�!L�3 sp bigger leftIndent��L�-2 sp bigger leftIndent���L�-2 sp bigger leftIndent�L�-2 sp bigger leftIndent�
�-2 sp bigger leftIndent�����L�10 sp bigger leftIndent�L�7 sp bigger leftIndent��L�-2 sp bigger leftIndent����
��L�-2 sp bigger leftIndent�(���L�3 sp bigger leftIndent��
�����L���
�����$L�@�L���
�����
��'��
�����
����4 sp bigger leftIndent��
���L�
�L�4 sp bigger leftIndent�'L�4 sp bigger leftIndent���L�L������L�10 sp bigger leftIndent�L�7 sp bigger leftIndent��L��L���
����
�$��
���
��L��L� L��L���
�������
��.�3�4 sp bigger leftIndent�$L�3 sp bigger leftIndent��L�4 sp bigger leftIndent�$��L���
�����
�	�<L�L��
���L�L�
L�H������10 sp bigger leftIndent�L�10 sp bigger leftIndent�0L�10 sp bigger leftIndent��L�10 sp bigger leftIndent�L�7 sp bigger leftIndent��L�L�L�
������10 sp bigger leftIndent�L�10 sp bigger leftIndent�2L�10 sp bigger leftIndent��L�7 sp bigger leftIndent��L��L���
�����/��
��.�3�4 sp bigger leftIndent�L�3 sp bigger leftIndent�L�3 sp bigger leftIndent��L�4 sp bigger leftIndent��
���L�4 sp bigger leftIndent�L�4 sp bigger leftIndent�
L�4 sp bigger leftIndent�L�4 sp bigger leftIndent�L�4 sp bigger leftIndent�L�4 sp bigger leftIndent�
L�4 sp bigger leftIndent�*L�4 sp bigger leftIndent�L�4 sp bigger leftIndent�L�3 sp bigger leftIndent��
�����L���
����� �'�2 sp bigger leftIndent��
���L�4 sp bigger leftIndent�
L�4 sp bigger leftIndent�AL�4 sp bigger leftIndent�L�4 sp bigger leftIndent����L���
�����.L�P�L���
�����/��
����4 sp bigger leftIndent�L�4 sp bigger leftIndent�
L�4 sp bigger leftIndent�
�-�-��3 sp bigger leftIndent�
�-2 sp bigger leftIndent��
����	�-2 sp bigger leftIndent�����L�10 sp bigger leftIndent�#L�7 sp bigger leftIndent����	L�-2 sp bigger leftIndent�
L�-2 sp bigger leftIndent�!���-2 sp bigger leftIndent��
���L�3 sp bigger leftIndent��6L�3 sp bigger leftIndent��L�L�;L����	�-2 sp bigger leftIndent��
���L�3 sp bigger leftIndent�L�
L�&L�
�*�*L�
�/�/L�L�(L�	L�L�����-2 sp bigger leftIndent��
���L�3 sp bigger leftIndent�L�3 sp bigger leftIndent�L��
��
���+��
�����
��(��
�����L��
��
���)L�L�
L�@�����L�10 sp bigger leftIndent�#L�7 sp bigger leftIndent��L�L�
�L� �L�
L�3L�L������L�10 sp bigger leftIndent�L�7 sp bigger leftIndent��L�	L����L�-2 sp bigger leftIndent�'���
��L�-2 sp bigger leftIndent�"���L�3 sp bigger leftIndent��
��
���L���
�����-��
��.�3�4 sp bigger leftIndent�L�3 sp bigger leftIndent�L�3 sp bigger leftIndent��L�4 sp bigger leftIndent��
���L�4 sp bigger leftIndent�L�4 sp bigger leftIndent�
L�4 sp bigger leftIndent�L�4 sp bigger leftIndent�*L�4 sp bigger leftIndent�L�4 sp bigger leftIndent�L�3 sp bigger leftIndent��
�����L���
������%�2 sp bigger leftIndent��
���L�4 sp bigger leftIndent�
L�4 sp bigger leftIndent�?L�4 sp bigger leftIndent�L�4 sp bigger leftIndent����L���
�����,L�N�L���
�����-��
����4 sp bigger leftIndent�L�4 sp bigger leftIndent�
�4�4��3 sp bigger leftIndent�
�-2 sp bigger leftIndent��
����	�-2 sp bigger leftIndent�����L�10 sp bigger leftIndent�!L�7 sp bigger leftIndent����	L�-2 sp bigger leftIndent�$���-2 sp bigger leftIndent��
���L�3 sp bigger leftIndent��6L�3 sp bigger leftIndent��L�L�9L�	���	�-2 sp bigger leftIndent��
���L�3 sp bigger leftIndent�L�
L� L�!L�3L�L�&L�	L�	����-2 sp bigger leftIndent��
���L�3 sp bigger leftIndent�L�3 sp bigger leftIndent�L��
��
���+��
�����
��(��
�����L��
��
���)L�+L�
L�#�����L�10 sp bigger leftIndent�!L�7 sp bigger leftIndent��L�
�L� �L�!L������L�10 sp bigger leftIndent�L�7 sp bigger leftIndent��L�	���L�-2 sp bigger leftIndent�&���
��L�-2 sp bigger leftIndent�"���L�3 sp bigger leftIndent��
��
���L���
�����)��
��� L��
�����L���
�����.L��
���&�L���
����	�)��
��
���+L�12 sp bigger leftIndent�
����
��
��L���
��/���
��
�	�L���
��.�L��
��
�	�
�
��L��
��
���L�L��
L�&��
���
L�%L�1L�0L�.L�
L�!�4L�3 sp bigger leftIndent�+�L�BL�)L�$�����L�10 sp bigger leftIndent�#L�7 sp bigger leftIndent�������L�15 sp bigger leftIndent��
��)�,L�12 sp bigger leftIndent�������L�15 sp bigger leftIndent��
��'�*L�12 sp bigger leftIndent��L�L����L���
�����(��
����4 sp bigger leftIndent��
���L�3 sp bigger leftIndent��	�
����
��"�'�4 sp bigger leftIndent�L�3 sp bigger leftIndent�%L�3 sp bigger leftIndent��L�4 sp bigger leftIndent�
L�4 sp bigger leftIndent�"L�4 sp bigger leftIndent�	�4 sp bigger leftIndent�L�3 sp bigger leftIndent�2L�3 sp bigger leftIndent��L�4 sp bigger leftIndent�
L�4 sp bigger leftIndent�L�4 sp bigger leftIndent���L�4 sp bigger leftIndent�)��L���
����	�#��
��
���+L�12 sp bigger leftIndent�
����
��
���+L�12 sp bigger leftIndent���L��
��
�	�
�
��L��
��
���L�L��
L�#��
���
L�
�!�!L�
�1�1L�
�F�F�
�]�]L�3 sp bigger leftIndent��L�
L�L�!L�,�����L�15 sp bigger leftIndent��
�� �#L�12 sp bigger leftIndent�������L�15 sp bigger leftIndent��
���!L�12 sp bigger leftIndent��L�L�L����L���
�����
�	�>L��
���%L��
��'�.L�
�%�%L����L��
L��
�;�;������L��$L���L��Q������L��&L���L��!L����L���
����	�&��
��
��L���
��/���
��
�	�L���
��.���
��
���+L�12 sp bigger leftIndent�
����
��
���+L�12 sp bigger leftIndent���L��
��
�	�
�
��L��
��
���L�L��
L�#��
���
L�
�!�!L�
�1�1L�
��
��
�
��
��
L�3 sp bigger leftIndent��L�
L�L�!L�,L�
�%�%L�
�*�*L�
�-�-L�
�+�+L�
�&�&L�@L�C�L�
L�=L�#L�L�PL�8L�jL�^L�KL�\L�
������L�10 sp bigger leftIndent�.L�7 sp bigger leftIndent��L�L�L����L���
�����
�	�=L��
���%L��
��'�.L��
������
�	�	���
�����L��L��
L����L�����
�	�	���
�����L��L��
L����L���������L��!L�������
�	�	���
�����L��L����L���L���L��
�!�!��L��L��L����
�	�	���
�����L��L����L���L��
�L��������L��$L���L��	��L���
����	�&��
��
��L���
��/���
��
�	�L���
��.���
��
���+L�12 sp bigger leftIndent�
����
��
���+L�12 sp bigger leftIndent���L��
��
�	�
�
��L��
��
���L�L��
L�#��
���
L�"L�1�L�L�
�Y�Y��;L�3 sp bigger leftIndent�
�3�3�L�
L�L�!L�,L�)L�'L�1L�5��
��L�
�BL�3 sp bigger leftIndent�1�L�E�L�7L�	L�M�L�L�
�L�'��
��L�
L�L�JL�F�CL�3 sp bigger leftIndent�1�L�L�-L���
����4 sp bigger leftIndent�����L�10 sp bigger leftIndent�2L�7 sp bigger leftIndent��L�4 sp bigger leftIndent�
�L�
�L�L�L����L���
����
�L�2L�,L�/L�0�L�L�
��L�
��L�
�L����S:�N