[_CDCSL_93-16_]<1>Cedar>release>SunRPCRuntime>RPCGenerate.scheme

;;; RPCGenerate.scheme

;;; Michael Plass, May 11, 1990 2:35 pm PDT

;;;

;;; 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.

(define (cedarsunrpcgen filename)

;;

;; Body of cedarsunrpcgen starts here

(define closeparen

(string-ref "()" 1))

(define (identity 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))

(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))))

(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))

(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)

)