home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / apteryx / pasgen.lsp < prev    next >
Lisp/Scheme  |  1994-04-01  |  22KB  |  798 lines
  1. ;;; Start
  2. ; Lisp Program. Copyright 1993,1994 Apteryx Lisp Ltd.
  3.  
  4. ; Pascal code generator. Examples of individual code
  5. ; macro useage are given after their definitions. A file
  6. ; generation example is given at the bottom of this file.
  7.  
  8.  
  9. (load "gen.lsp" :print nil)
  10.  
  11. ;;; Layout
  12.  
  13. ; This means that you can generate individual expressions
  14. ; into standard output to see what result they produce.
  15. (setq *pout* *standard-output*)
  16.  
  17. (setq *ind* 0)
  18.  
  19. (if (not (fboundp 'print-indent))
  20.   (defun print-indent (n out)
  21.     (dotimes (i n)
  22.       (princ " " out) ) ) )
  23.  
  24. (defun indent ()
  25.   (print-indent *ind* *pout*) )
  26.  
  27. (defun semicolon ()
  28.   (princ ";" *pout*)
  29.   (terpri *pout*) )
  30.  
  31. (defun nl ()
  32.   (terpri *pout*) (indent) )
  33.  
  34. (defmacro with-indent (&rest stmts)
  35.   `(progn
  36.      (setq *ind* (+ *ind* 2))
  37.      ,@stmts
  38.      (setq *ind* (- *ind* 2)) ) )
  39.  
  40. (defun /* (line1 &rest lines)
  41.   (nl) (princ "{ " *pout*) (princ line1 *pout*)
  42.   (dolist (line lines)
  43.     (nl) (princ "  " *pout*) (princ line *pout*) )
  44.   (princ " }" *pout*) (terpri *pout*)
  45.   `(comment ,@lines) )
  46.  
  47. (defun comment-producer ()
  48.   (/* "Produced using Apteryx Lisp") )
  49.  
  50. ;;; Declarations
  51.  
  52. (defmacro program (name)
  53.   `(progn
  54.      (princ "program " *pout*)
  55.      (prin1 ',name *pout*)
  56.      (semicolon) (terpri *pout*)
  57.      '(program ,name) ) )
  58.  
  59. ; (program myprog)
  60.  
  61.  
  62. (defmacro unit (name)
  63.   `(progn
  64.      (princ "unit " *pout*)
  65.      (prin1 ',name *pout*)
  66.      (semicolon) (terpri *pout*) 
  67.      '(unit ,name) ) )
  68.  
  69. ; (unit myunit)
  70.  
  71.  
  72. ; Use to print an arbitrary string to Pascal file
  73. (defmacro p (string)
  74.   (princ string *pout*) (terpri *pout*) )
  75.  
  76. (defmacro interface ()
  77.   `(progn
  78.      (princ "interface" *pout*)
  79.      (terpri *pout*) (terpri *pout*)
  80.      'interface ) )
  81.  
  82. ; (interface)
  83.  
  84. (defmacro implementation ()
  85.   `(progn
  86.      (princ "implementation" *pout*)
  87.      (terpri *pout*) (terpri *pout*)
  88.      'implementation ) )
  89.  
  90. ; (implementation)
  91.  
  92. (defmacro uses (&rest modules)
  93.   `(progn
  94.      (princ "uses " *pout*)
  95.      (prin1 (car ',modules) *pout*)
  96.      (dolist (module (cdr ',modules))
  97.        (if (eq module :nl)
  98.          (progn (terpri *pout*) (indent) )
  99.          (progn
  100.            (princ ", " *pout*)
  101.            (prin1 module *pout*) ) ) )
  102.      (semicolon) (terpri *pout*)
  103.      '(uses ,@ modules) ) )
  104.  
  105. ; (uses unit1 unit2)
  106.  
  107. (defun print-proc-name (name)
  108.   (cond
  109.     ( (symbolp name)
  110.       (prin1 name *pout*) )
  111.     ( (and (listp name) (eql 3 (length name)) (eq (car name) '%) )
  112.       (format *pout* "~A.~A" (second name) (third name)) )
  113.     (t
  114.       (error "Invalid proc/func name" name) ) ) )
  115.  
  116. (defmacro proc (name args &rest decs)
  117.   `(progn
  118.      (princ "procedure " *pout*)
  119.      (print-proc-name ',name)
  120.      (print-args ',args)
  121.      (princ "; " *pout*)
  122.      (with-indent
  123.        (progn ,@decs) )
  124.      (terpri *pout*)
  125.      '(procedure ,name) ) )
  126.  
  127. ; (proc dosomething ( (var n integer) ) (begin (writeln "hello")))
  128.  
  129. (defmacro constructor (name args &rest decs)
  130.   `(progn
  131.      (princ "constructor " *pout*)
  132.      (print-proc-name ',name)
  133.      (print-args ',args)
  134.      (princ "; " *pout*)
  135.      (with-indent
  136.        (progn ,@decs) )
  137.      (terpri *pout*)
  138.      '(procedure ,name) ) )
  139.  
  140. ; (constructor (% TThing Doit) ( (n integer) (i word) ) (begin (writeln)))
  141.  
  142. (defmacro destructor (name args &rest decs)
  143.   `(progn
  144.      (princ "destructor " *pout*)
  145.      (print-proc-name ',name)
  146.      (print-args ',args)
  147.      (princ "; " *pout*)
  148.      (with-indent
  149.        (progn ,@decs) )
  150.      (terpri *pout*)
  151.      '(procedure ,name) ) )
  152.  
  153. ; (constructor (% TThing Done) () (begin (writeln "Gone")))
  154.  
  155. (defmacro func (name args type &rest decs)
  156.   `(progn
  157.      (princ "function " *pout*)
  158.      (print-proc-name ',name)
  159.      (print-args ',args)
  160.      (princ " : " *pout*)
  161.      (prin1 ',type *pout*)
  162.      (princ "; " *pout*)
  163.      (with-indent
  164.        (progn ,@decs) )
  165.      (terpri *pout*)
  166.      '(procedure ,name) ) )
  167.  
  168. ; (func myfunc ( (var n integer) ) integer (begin (= myfunc (+ n 2))))
  169.  
  170. (defun print-const-dec (dec)
  171.   (indent)
  172.   (case (length dec)
  173.     (2 (prin1 (first dec) *pout*)
  174.       (princ " = " *pout*)
  175.       (print-value (second dec))
  176.       (semicolon) )
  177.     (3 (prin1 (first dec) *pout*) (princ " :" *pout*)
  178.       (print-type (second dec))
  179.       (princ " = " *pout*)
  180.       (print-value (third dec))
  181.       (semicolon) )
  182.     (t (error "invalid const declaration" dec)) ) )
  183.  
  184. (defmacro const (&rest const-decs)
  185.   `(progn
  186.      (nl) (princ "const " *pout*) (terpri *pout*)
  187.      (with-indent
  188.        (dolist (dec ',const-decs)
  189.          (print-const-dec dec) ) )
  190.      '(const ,@const-decs) ) )
  191.  
  192. ; (const (i 2) (n "Fred"))
  193.  
  194. (defun print-type-dec (type-dec)
  195.   (let ( (name (car type-dec))
  196.          (type (second type-dec)) )
  197.     (indent)
  198.     (prin1 name *pout*)
  199.     (princ " = " *pout*)
  200.     (with-indent 
  201.       (print-type type)
  202.       (semicolon) ) ) )
  203.  
  204. (defmacro type (&rest type-decs)
  205.   `(progn
  206.      (nl) (princ "type " *pout*) (terpri *pout*)
  207.      (with-indent
  208.        (dolist (dec ',type-decs)
  209.          (print-type-dec dec) ) ) 
  210.      '(type ,@type-decs) ) )
  211.  
  212. ; (type (mytype integer) (myarray (array ( (.. 1 20) ) integer)))
  213.  
  214. (defmacro begin (&rest stmts)
  215.   `(progn
  216.      (print-stmt (cons 'begin ',stmts))
  217.      (semicolon) ) )
  218.  
  219. ; (begin (= i 1) (writeln "hello" goodbye_string))
  220.  
  221. (defmacro far ()
  222.   `(princ " far; " *pout*) )
  223.  
  224. ; (proc myproc ( (i integer) ) (far) (begin (writeln "hello")))
  225.  
  226. (defmacro module-begin (&rest stmts)
  227.   `(progn
  228.      (print-stmt (cons 'begin ',stmts))
  229.      (princ "." *pout*) (terpri *pout*)
  230.      'module-begin ) )
  231.  
  232. ; (module-begin (= i 1) (writeln "hello"))
  233.  
  234. (defun print-args (args)
  235.   (when args
  236.     (princ " (" *pout*)
  237.     (print-arg (car args))
  238.     (dolist (arg (cdr args))
  239.       (if (eq :nl arg)
  240.         (progn (terpri *pout*) (indent) )
  241.         (progn
  242.           (princ "; " *pout*)
  243.           (print-arg arg) ) ) )
  244.     (princ ")" *pout*) ) )
  245.  
  246. (defun print-arg (arg)
  247.   (let ( (rest arg) num-vars)
  248.     (case (car rest)
  249.       ((var invar outvar inoutvar)
  250.         (princ "var " *pout*)
  251.         (setq rest (cdr rest)) )
  252.       (in
  253.         (setq rest (cdr rest)) ) )
  254.     (setq num-vars (1- (length rest)))
  255.     (dotimes (i num-vars)
  256.       (if (> i 0) (princ ", " *pout*))
  257.       (prin1 (nth i rest) *pout*) )
  258.     (princ " :" *pout*)
  259.     (prin1 (nth num-vars rest) *pout*) ) )
  260.  
  261. (defmacro var (&rest decs)
  262.   `(progn
  263.      (nl) (princ "var" *pout*) (terpri *pout*)
  264.      (with-indent
  265.        (dolist (dec ',decs)
  266.          (print-var dec) ) )
  267.      '(vars ,@decs) ) )
  268.  
  269. ; (var (i integer) (n word))
  270.  
  271. (defun print-var (dec)
  272.   (indent)
  273.   (let* ( (rev-dec (reverse dec))
  274.           (type (car rev-dec))
  275.           (vars (reverse (cdr rev-dec))) )
  276.     (prin1 (car vars) *pout*)
  277.     (dolist (var (cdr vars))
  278.       (princ ", " *pout*)
  279.       (prin1 var *pout*) )
  280.     (princ " :" *pout*)
  281.     (print-type type)
  282.     (semicolon) ) )
  283.  
  284. (defun print-virtual (dec)
  285.   (princ ";" *pout*)
  286.   (cond
  287.     ( (eq dec 'virtual)
  288.       (princ " virtual" *pout*) )
  289.     ( (and (listp dec) (eq (car dec) 'virtual) (eql 2 (length dec)))
  290.       (princ " virtual " *pout*)
  291.       (print-value (second dec)) )
  292.     ( t
  293.       (error "Invalid virtual dec" dec) ) ) )
  294.  
  295. (defun print-method (dec)
  296.   (indent)
  297.   (let* ( (method-type (first dec))
  298.           (name (second dec))
  299.           (arglist (third dec))
  300.           (virtual-dec (nthcdr 3 dec)) )
  301.     (format *pout* "~A ~A " method-type name)
  302.     (print-args arglist)
  303.     (if (not (null virtual-dec))
  304.       (print-virtual (car virtual-dec)) )
  305.     (semicolon) ) )
  306.  
  307. ; (print-method '(procedure jim ( (var tom integer) (fred char)) (virtual (+ 5 6)) ))
  308.  
  309. (defun print-type (type)
  310.   (case (type-of type)
  311.     (symbol (prin1 type *pout*))
  312.     (cons
  313.       (let ( (fun (get (car type) 'type-fun)) )
  314.         (if fun
  315.           (apply fun (cdr type))
  316.           (error "Unknown type function" (car type)) ) ) )
  317.     (t (error "invalid print-type arg" type)) ) )
  318.  
  319. ;;; def-type-fun
  320.  
  321. (defmacro def-type-fun (name args &rest body)
  322.   `(progn
  323.      (setf (get ',name 'type-fun )
  324.        #'(lambda ,args ,@body) )
  325.      '(type-fun ,name) ) )
  326.  
  327. (defmacro def-type-macro (name args expr)
  328.   `(progn
  329.      (setf (get ',name 'type-fun )
  330.        #'(lambda ,args (print-type ,expr)) )
  331.      '(type-macro ,name) ) )
  332.  
  333. (def-type-fun record (&rest var-decs)
  334.   (terpri) (indent) (princ "record" *pout*) (terpri *pout*)
  335.   (with-indent
  336.     (dolist (var-dec var-decs)
  337.       (print-var var-dec) ) )
  338.   (indent) (princ "end" *pout*) )
  339.  
  340. ; (var (n (record (i integer) (w word))))
  341.  
  342. (def-type-fun object (parent &rest members)
  343.   (terpri) (indent) (princ "object" *pout*) 
  344.   (if (not (null parent))
  345.     (format *pout* " (~A) " parent) )
  346.   (terpri *pout*)
  347.   (with-indent
  348.     (let ( (member-type 'var) )
  349.       (dolist (member members)
  350.         (cond
  351.           ((eq member 'methods) (setq member-type 'method))      
  352.           ((eq member-type 'var) (print-var member))
  353.           ((eq member-type 'method) (print-method member)) ) ) ) )
  354.   (indent) (princ "end" *pout*) )
  355.  
  356. '(var (z (object nil
  357.                 (x integer) (y char)
  358.                 methods
  359.                 (procedure jim ( (x integer) ) 
  360.                   (virtual (+ wm_first wmMouseDown)) ) )) )
  361.  
  362. (def-type-fun .. (first last)
  363.   (print-value first) (princ ".." *pout*) (print-value last) )
  364.  
  365. ; (var (n (.. 1 10)))
  366.  
  367. (def-type-fun array (indexes type)
  368.   (princ "array [" *pout*)
  369.   (print-type (car indexes))
  370.   (dolist (index (cdr indexes))
  371.     (princ ", " *pout*)
  372.     (print-type index) )
  373.   (princ "] of " *pout*);
  374.   (print-type type) )
  375.  
  376. ; (var (n (array ( (.. 1 10) (.. 2 45) ) word)))
  377.  
  378. (def-type-fun ^ (type)
  379.   (princ "^" *pout*)
  380.   (print-type type) )
  381.  
  382. ; (var (p (^ TObject)))
  383.  
  384. (def-type-fun procedure (arglist)
  385.   (princ "procedure " *pout*)
  386.   (print-args arglist) )
  387.  
  388. ; (type (myproc (procedure ( (var i integer) (s PChar)))))
  389.  
  390. ;;; def-value-fun
  391.  
  392. (defun print-value (value)
  393.   (case (type-of value)
  394.     (nil (princ "nil" *pout*))
  395.     (symbol (prin1 value *pout*))
  396.     (fixnum (prin1 value *pout*))
  397.     (integer (prin1 value *pout*))
  398.     (string 
  399.       (princ "'" *pout*) (princ value *pout*)
  400.       (princ "'" *pout*) )
  401.     (flonum (prin1 value *pout*))
  402.     (float (prin1 value *pout*))
  403.     (cons
  404.       (let ( (fun (if (symbolp (car value)) (get (car value) 'value-fun) nil)) )
  405.         (if fun
  406.           (apply fun (cdr value))
  407.           (progn
  408.             (print-value (car value))
  409.             (let ( (args (cdr value)) )
  410.               (when args
  411.                 (princ " (" *pout*)
  412.                 (print-value (car args))
  413.                 (dolist (arg (cdr args))
  414.                   (if (eq arg :nl)
  415.                     (progn
  416.                       (terpri *pout*) (indent) )
  417.                     (progn
  418.                       (princ ", " *pout*)
  419.                       (print-value arg) ) ) )
  420.                 (princ ")" *pout*) ) ) ) ) ) )
  421.     (t (error "invalid print-value arg" value)) ) )
  422.  
  423. (defmacro def-value-fun (name args &rest body)
  424.   `(progn
  425.      (setf (get ',name  'value-fun)
  426.        #'(lambda ,args ,@body) )
  427.      '(value-fun ,name) ) )
  428.  
  429. (defmacro def-value-macro (name args expr)
  430.   `(progn
  431.      (setf (get ',name 'value-fun)
  432.        #'(lambda ,args (print-value ,expr)) )
  433.      '(value-macro ,name) ) )
  434.  
  435. (def-value-fun ch (number)
  436.   (princ "#" *pout*) (print-value number) )
  437.  
  438. ; (begin (= ch (ch 13)))
  439.  
  440. (def-value-fun @ (name)
  441.   (princ "@" *pout*) (print-value name) )
  442.  
  443. ; (begin (= ptr (@ variable)))
  444.  
  445. (def-value-fun ^ (name)
  446.   (print-value name) (princ "^" *pout*) )
  447.  
  448. ; (begin (= value (^ ptr)))
  449.  
  450. (def-value-fun concat (&rest vals)
  451.   (dolist (val vals)
  452.     (if (symbolp val)
  453.       (prin1 val *pout*)
  454.       (princ val *pout*) ) ) )
  455.  
  456. ; (begin (= string (concat #\' "jim " tom " and fred" #\')))
  457.  
  458. (def-value-fun not (name)
  459.   (princ "(not " *pout*)
  460.   (print-value name)
  461.   (princ ")" *pout*) )
  462.  
  463. ; (begin (= test (not (< 2 3))))
  464.  
  465. (def-value-fun [] (array &rest indexes)
  466.   (print-value array)
  467.   (princ "[" *pout*)
  468.   (print-value (car indexes))
  469.   (dolist (index (cdr indexes))
  470.     (princ "," *pout*)
  471.     (print-value index) )
  472.   (princ "]" *pout*) )
  473.  
  474. ; (begin (= i ([] arr n)))
  475.  
  476. (def-value-fun % (record field)
  477.   (print-value record)
  478.   (princ "." *pout*)
  479.   (print-value field) )
  480.  
  481. ; (begin (= val (% rec field)))
  482.  
  483. (def-value-macro []^ (array_ptr &rest indexes)
  484.   `([] (^ ,array_ptr) ,@indexes) )
  485.  
  486. ; (begin (= val ([]^ arr_ptr index)))
  487.  
  488. ;;; operators
  489.  
  490. (defmacro def-operator1 (name)
  491.   `(def-value-fun ,name (arg1 arg2)
  492.      (princ "(" *pout*)
  493.      (print-value arg1)
  494.      (princ " " *pout*)
  495.      (prin1 ',name *pout*)
  496.      (princ " " *pout*)
  497.      (print-value arg2)
  498.      (princ ")" *pout*) ) )
  499.  
  500. (defun def-operator (name)
  501.   (eval `(def-operator1 ,name)) )
  502.  
  503. (defmacro def-n-operator1 (name)
  504.   `(def-value-fun ,name (arg1 &rest args)
  505.      (princ "(" *pout*)
  506.      (print-value arg1)
  507.      (dolist (arg args)
  508.        (if (eq :nl arg)
  509.          (progn (terpri *pout*) (indent))
  510.          (progn
  511.            (princ " " *pout*)
  512.            (prin1 ',name *pout*)
  513.            (princ " " *pout*)
  514.            (print-value arg) ) ) )
  515.      (princ ")" *pout*) ) )
  516.  
  517. (defun def-n-operator (name)
  518.   (eval `(def-n-operator1 ,name)) )
  519.  
  520. (dolist (x '( - / div mod rem shl shr  in < > <= >= <> =))
  521.   (def-operator x) )
  522.  
  523. ; (begin (= i (+ (* n 20) 45)))
  524.  
  525. (dolist (x '(+ * and or xor))
  526.   (def-n-operator x) )
  527.  
  528. ; (begin (= i (+ 1 2 3 4 (* 5 6 7))))
  529.  
  530. ;;; def-stmt-fun
  531.  
  532. (defun print-stmt (stmt)
  533.   (case (type-of stmt)
  534.     (nil)
  535.     (cons
  536.       (let ( (fun (if (symbolp (car stmt)) (get (car stmt) 'stmt-fun) nil) ) )
  537.         (if fun
  538.           (apply fun (cdr stmt))
  539.           (progn
  540.             (print-value (car stmt))
  541.             (let ( (args (cdr stmt)) )
  542.               (when args
  543.                 (princ " (" *pout*)
  544.                 (print-value (car args))
  545.                 (dolist (arg (cdr args))
  546.                   (if (eq arg :nl)
  547.                     (progn (terpri *pout*) (indent))
  548.                     (progn
  549.                       (princ ", " *pout*)
  550.                       (print-value arg) ) ) )
  551.                 (princ ")" *pout*) ) ) ) ) ) )
  552.     (t (error "invalid print-stmt arg" stmt)) ) )
  553.  
  554. (defmacro def-stmt-fun (name args &rest body)
  555.   `(progn
  556.      (setf (get ',name 'stmt-fun)
  557.        #'(lambda ,args ,@body) )
  558.      '(stmt-fun ,name) ) )
  559.  
  560. (defmacro def-stmt-macro (name args expr)
  561.   `(progn
  562.      (setf (get ',name 'stmt-fun)
  563.        #'(lambda ,args (print-stmt ,expr)) )
  564.      '(stmt-macro ,name) ) )
  565.  
  566. (defun begin-block (stmts)
  567.   (nl) (princ "begin" *pout*) (terpri *pout*)
  568.   (with-indent
  569.     (dolist (stmt stmts)
  570.       (indent) (print-stmt stmt) (semicolon) ) )
  571.   (indent) (princ "end" *pout*) )
  572.  
  573. (def-stmt-fun = (var val)
  574.   (print-value var) (princ " := " *pout*)
  575.   (print-value val) )
  576.  
  577. ; (begin (= i (+ n 2)))
  578.  
  579. (def-stmt-fun begin (&rest stmts)
  580.   (begin-block stmts) )
  581.  
  582. ; (begin (= i n) (= y x) (writeln "hello"))
  583.  
  584. (def-stmt-fun for (header &rest stmts)
  585.   (let ( (var (first header))
  586.          (start (second header))
  587.          (end (third header)) )
  588.     (princ "for " *pout*) (print-value var)
  589.     (princ " := " *pout*) (print-value start)
  590.     (princ " to " *pout*) (print-value end)
  591.     (princ " do" *pout*)
  592.     (with-indent
  593.       (begin-block stmts) ) ) )
  594.  
  595. ; (begin (for (i 1 100) (writeln i) (= n (+ n i))))
  596.  
  597. (def-stmt-fun for-downto (header &rest stmts)
  598.   (let ( (var (first header))
  599.          (start (second header))
  600.          (end (third header)) )
  601.     (princ "for " *pout*) (print-value var)
  602.     (princ " := " *pout*) (print-value start)
  603.     (princ " downto " *pout*) (print-value end)
  604.     (princ " do" *pout*)
  605.     (with-indent
  606.       (begin-block stmts) ) ) )
  607.  
  608. ; (begin (for-downto (i 100 1) (writeln i) (= n (+ n i))))
  609.  
  610. (def-stmt-fun with (var &rest stmts)
  611.   (princ "with " *pout*)
  612.   (print-value var)
  613.   (princ " do " *pout*)
  614.   (with-indent
  615.     (begin-block stmts) ) )
  616.  
  617. ; (begin (with (^ ptr) (writeln field1) (writeln field2)))
  618.  
  619. (def-stmt-fun block (&rest stmts)
  620.   (print-stmt
  621.     (if (= (length stmts) 1)
  622.       (first stmts)
  623.       (cons 'begin stmts) ) ) )
  624.  
  625. ; (begin (block (writeln "hello")))
  626.  
  627. ; (begin (block (writeln "hello") (writeln "hello")))
  628.  
  629. ; call is not usually necessary, but it forces interpretation of
  630. ; first argument as a procedure or function
  631.  
  632. (def-stmt-fun call (proc-fun &rest args)
  633.   (print-value proc-fun)
  634.   (when args
  635.     (princ " (" *pout*)
  636.     (print-value (car args))
  637.     (dolist (arg (cdr args))
  638.       (princ ", " *pout*)
  639.       (print-value arg))
  640.     (princ ")" *pout*) ) )
  641.  
  642. ; (begin (call function n i))
  643.  
  644. (def-stmt-fun null-statement () )
  645.  
  646. ; (begin (for (i 1 10) (null-statement)))
  647.  
  648. (defun print-case-clause (values stmts)
  649.   (indent)
  650.   (if (eq values 'else)
  651.     (princ "else " *pout*)
  652.     (progn
  653.       (if (or (numberp values) (symbolp values) (stringp values))
  654.         (setq values (list values)) )
  655.       (print-value (car values))
  656.       (dolist (value (cdr values))
  657.         (princ ", " *pout*)
  658.         (print-value value) )
  659.       (princ ": " *pout*) ) )
  660.   (with-indent
  661.     (print-stmt (cons 'block stmts)) )
  662.   (semicolon) )
  663.  
  664. (def-stmt-fun case (val &rest clauses)
  665.   (princ "case " *pout*)
  666.   (print-value val)
  667.   (princ " of " *pout*) (terpri *pout*)
  668.   (with-indent
  669.     (dolist (clause clauses)
  670.       (print-case-clause (car clause) (cdr clause)) ) )
  671.   (indent) (princ "end" *pout*) )
  672.  
  673. ; (begin (case (+ i 2) (3 (writeln "three")) (21 (= i 3) (= y 4))))
  674.  
  675. ; (begin (case (+ i 2) (3 (writeln "three")) (else (= i 3) (= y 4))))
  676.  
  677. (def-stmt-fun while (var &rest stmts)
  678.   (princ "while " *pout*)
  679.   (print-value var)
  680.   (princ " do " *pout*)
  681.   (with-indent
  682.     (begin-block stmts) ) )
  683.  
  684. ; (begin (while (< i 5) (= i (+ i 1))))
  685.  
  686. (def-stmt-fun repeat-until (var &rest stmts)
  687.   (princ "repeat" *pout*) (terpri *pout*)
  688.   (with-indent
  689.     (dolist (stmt stmts)
  690.       (indent) (print-stmt stmt) (semicolon) ) )
  691.   (indent) (princ " until " *pout*) (print-value var) )
  692.  
  693. ; (begin (repeat-until (< i 5) (= i (+ i 1))))
  694.  
  695. (def-stmt-fun if (test then-stmt &optional else-stmt)
  696.   (princ "if " *pout*) (print-value test)
  697.   (nl) (princ " then " *pout*)
  698.   (with-indent
  699.     (print-stmt then-stmt) )
  700.   (when else-stmt
  701.     (progn (nl) (princ " else " *pout*))
  702.     (with-indent
  703.       (print-stmt else-stmt) ) ) )
  704.  
  705. ; (begin (if (< i 2) (writeln "less than 2") (writeln ">= 2")))
  706.  
  707. (def-stmt-macro addf (var value)
  708.   `(= ,var (+ ,var ,value)) )
  709.  
  710. ; (begin (addf i n))
  711.  
  712. (def-stmt-macro incf (var)
  713.   `(= ,var (+ ,var 1)) )
  714.  
  715. ; (begin (incf i))
  716.  
  717. ;;; string tables
  718.  
  719. ; The following code is for automatically generating string resource
  720. ; tables. It is desirable to use it for large programs because 
  721. ; constant strings use up precious data segment.
  722.  
  723. ; Call this function explicitly in the pascal file before any use of
  724. ; str. Choose start-no and limit-no to avoid clashes in different
  725. ; string tables.
  726.  
  727. (defun open-string-table (name start-no &optional limit-no)
  728.   (setq *string-index* start-no)
  729.   (setq *string-index-limit* 
  730.     (if limit-no limit-no (+ start-no 1000)) )
  731.   (setq *string-file-name* name)
  732.   (setq *string-file* (open (strcat name ".rc") :direction :output))
  733.   (format *pout* "{$R ~A.res}~%" name)
  734.   (princ "STRINGTABLE LOADONCALL MOVEABLE DISCARDABLE" *string-file*)
  735.   (terpri *string-file*)
  736.   (princ "BEGIN" *string-file*)
  737.   (terpri *string-file*) )
  738.  
  739. ; Calls rc.exe program provided with Borland Pascal to compile 
  740. ; generated .rc file into a .res file. (Automatically called by
  741. ; gen-pascal function.)
  742.  
  743. (defun finish-any-string-file ()
  744.   (when *string-file*
  745.     (princ "END" *string-file*)
  746.     (terpri *string-file*)
  747.     (close *string-file*)
  748.     (setq *string-file* nil)
  749.     (run-program (strcat "rc -r " *string-file-name* ".rc")) ) )
  750.  
  751. (setq *string-file* nil)
  752.  
  753. ; use (str "string") instead of "string" to generate a reference to a 
  754. ; resource string. Used with copy = nil, uses LString to retrieve 
  755. ; resource, used with copy = t uses LStringCopy to retrieve string.
  756. ; (You have to write LString and LStringCopy.)
  757.  
  758. (def-value-fun str (x &key copy)
  759.   (if *string-file*
  760.     (progn
  761.       (format *string-file* "  ~A, ~S~%" *string-index* x)
  762.       (if copy 
  763.         (format *pout* "LStringCopy (~A)" *string-index*)
  764.         (format *pout* "LString (~A)" *string-index*) )
  765.       (setq *string-index* (1+ *string-index*))
  766.       (if (>= *string-index* *string-index-limit*)
  767.         (error "String index limit exceeded" *string-index*) ) )
  768.     (print-value x) ) )
  769.  
  770. ; Example doesn't generate LString call because *string-file* = nil
  771. ; (begin (= a (str "Jim")))
  772.  
  773. ;;; gen-pascal
  774.  
  775. (defun gen-pascal (infile outfile)
  776.   (princ "Generating ") (prin1 outfile)
  777.   (princ " from ") (print infile)
  778.   (setq *string-file* nil)
  779.   (setq *ind* 1)
  780.   (let ( (pout-save *pout*)
  781.          (new-pout (open outfile :direction :output)) )
  782.     (unwind-protect
  783.       (progn
  784.         (setq *pout* new-pout)
  785.         (load infile :print t) )
  786.       (finish-any-string-file)
  787.       (close *pout*)
  788.       (setq *pout* pout-save) )
  789.     outfile) )
  790.  
  791. ; To see how this works, load this buffer and 
  792. ; evaluate the example below. Then compile 
  793. ; the newly generated example.pas in Turbo Pascal for Windows
  794. ; (registered Trademark of Borland)
  795.  
  796. ; (gen-pascal "example.ps" "example.pas")
  797.  
  798.