;;; -*- Mode: COMMON-LISP; Fonts:(MEDFNT HL12B HL12I MEDFNB); Package: PASCALX; Base: 10 -*- ;1; REVISION HISTORY:* ;1;* ;1; 5-24-88 Changed GEN-SIMPLE-EXPRESSION TYPEP expression because it* ;1; contained a function-spec that was no longer valid.* ;1; ;;; Construct a hash table to look up function names to translate expressions from PREFIX to LISP. ;;; Construct a hash table to do the code generation. See the file ;;; PASCALX: PASCALX; CODE-GEN.LISP for a description of what the code generator table looks like. 3(DEFCONSTANT EXP-FUN-ALIST** `((*and-op* . and) (*divide-op* . ,(make-print-identifier :name '*divide* :package 'pascalx)) (*eq-op* . equalp) (*ge-op* (:set . ,(make-print-identifier :name '*set-ge* :package 'pascalx)) (:number . >=) (:string . string-not-lessp) (:enumerated . ,(make-print-identifier :name '*enum-ge* :package 'pascalx))) (*gt-op* (:number . >) (:string . string-greaterp) (:enumerated . ,(make-print-identifier :name '*enum-gt* :package 'pascalx))) (*in-op* . member) (*int-divide-op* . truncate) (*le-op* (:set . ,(make-print-identifier :name '*set-le* :package 'pascalx)) (:number . <=) (:enumerated . ,(make-print-identifier :name '*enum-le* :package 'pascalx)) (:string . string-not-greaterp)) (*lt-op* (:number . <) (:enumerated . ,(make-print-identifier :name '*enum-lt* :package 'pascalx)) (:string . string-lessp)) (*minus-op* (:set . ,(make-print-identifier :name '*set-difference* :package 'pascalx)) (:number . -)) (*mod-op* . remainder) (*ne-op* . ,(make-print-identifier :name '*ne* :package 'pascalx)) (*nil-x* . nil) (*not-op* . not) (*or-op* . or) (*plus-op* (:set . ,(make-print-identifier :name '*union* :package 'pascalx)) (:number . +)) (*set-constructor* . ,(make-print-identifier :name '*set-constructor* :package 'pascalx)) (*times-op* (:set . ,(make-print-identifier :name '*intersection* :package 'pascalx)) (:number . *)) (*unary-minus* . -) (*unary-plus* . +)) 2"an alist to convert PREFIX to Common Lisp code"* );1exp-fun-alist 3(DEFVAR *EXP-FUN-TABLE*** (let* ((DEFAULT-CONS-AREA *PASCALX-STATIC-AREA*) (table (make-hash-table :test #'eq :size 150))) (dolist (key-value-pair EXP-FUN-ALIST table) (setf (gethash (first key-value-pair) table) (rest key-value-pair)))) 2"the hash table to look up PREFIX functions (in expressions) to get LISP expressions"*) (proclaim '(type hash-table *EXP-FUN-TABLE*)) 3(DEFCONSTANT EXP-TYPE-ALIST* `((*and-op* . boolean) (*divide-op* . real) (*eq-op* . boolean) (*ge-op* . boolean) (*gt-op* . boolean) (*in-op* . boolean) (*int-divide-op* . integer) (*le-op* . boolean) (*lt-op* . boolean) (*minus-op* . *type-of-arguments*) (*mod-op* . integer) (*ne-op* . boolean) (*nil-x* . nil) (*not-op* . boolean) (*or-op* . boolean) (*plus-op* . *type-of-arguments*) (*set-constructor* . *type-of-arguments*) (*times-op* . *type-of-arguments*) (*unary-minus* . *type-of-arguments*) (*unary-plus* . *type-of-arguments*)) 2"an alist to determine the type of expressions"* );1exp-type-alist 3(DEFVAR *EXP-TYPE-TABLE*** (let* ((DEFAULT-CONS-AREA *PASCALX-STATIC-AREA*) (table (make-hash-table :test #'eq :size 150))) (dolist (key-value-pair EXP-TYPE-ALIST table) (setf (gethash (first key-value-pair) table) (rest key-value-pair)))) 2"the hash table to look up PREFIX functions (in expressions) to get LISP expressions"*) (proclaim '(type hash-table *EXP-TYPE-TABLE*)) 3(DEFCONSTANT ALL-ORDINAL-TYPES* '(PRIMITIVE-TYPE SYMTAB-ENUMERATED-TYPE SYMTAB-SUBRANGE-TYPE) 2"all the ordinal TYPES"*) 3(DEFMACRO RECORD-ACCESSOR (symtab-record-type field-name) 1 2"Return the record accessor of a field. NOTE: there is no checking* 2done to see if indeed this is a field"*** `(make-print-identifier :name (intern (concatenate 'string (field-accessor-prefix ,symtab-record-type) (STRING ,field-name))) :package *output-package*)) 1;;; GEN-CATCH-IF-NECESSARY generates the appropriate code around CODE to do ;;; a catch if FUNCTION-LIST is non-null. It should be a list of functions or procedures ;;; that are called in the statement 3(DEFUN GEN-CATCH-IF-NECESSARY (function-list code &aux l-info label-list)** 2"generate a catch if there are some labels to catch"* (setf label-list (loop for fun in function-list nconc (mapcan #'(lambda (lab) (if (= (level (lookup-symtab lab)) *CURRENT-LEVEL*) (list lab) nil)) (external-labels-used (lookup-symtab fun))))) (cond ((not (null label-list)) `(case (catch ',(make-level-tag *CURRENT-LEVEL*) ,code) ,@(mapcar #'(lambda (lab) (setf l-info (lookup-symtab lab)) (list (make-label-into-throw-value (access-form l-info)) (list 'go (access-form l-info)))) label-list))) (t code)) );1gen-catch-if-necessary ;;; The parameter list of the function whose symbol table entry is INFO is an alist ;;; The car is the parameter name, the CDR is the type if it is a VALUE parameter, the ;;; procedure or function name if it is a procedural or functional parameter, and a list ;;; (VAR type) if it is a variable parameter, for VAR parameters, we have to pass a locative ;;; Generates an actual parameter list, INFO is the symbol table entry for this procedure. ;;; returns two values the actual parameter list, and whether there was a call to a ;;; non-pre-defned function. 3(DEFUN GEN-ACTUAL-PARAMETER-LIST (prefix info &aux exp sym-type sym-info** 3 type fun-call? functions-called)* 2"generates an actual parameter list"* (if (or (eq (parms info) :nlam) (not (= (length (parms info)) (length prefix)))) (error-handler 'gen-actual-parameter-list "different length parameter lists, in")) (if (not (eq (parms info) :nlam)) (values (mapcar #'(lambda (sym-par pre) (cond ((memq (setf sym-type (cadr sym-par)) '(function procedure)) 1 ;; This should just be a PROCEDURE or FUNCTION identifier* (setf sym-info (lookup-symtab (arg1 pre))) 1 ;; check here if PROCEDURE and FUNCTION parameter lists are compatible.* 1 ;; have to check whether the parameter list of SYM-INFO is compatible* 1 ;; with the functional parameter parameter list (which has to be found* 1 ;; in the symbol table) of SYM-TYPE.* (list 'function (access-form sym-info))) ((eq sym-type 'var) (multiple-value-setq (exp type fun-call?) (gen-variable-access pre)) (setf functions-called (append functions-called fun-call?)) (if (check-assignment-compatibility (caddr sym-par) type) (error-handler 'gen-actual-parameter-list "illegal type match of parameters, in")) 1;; here's a hack, if this is already a var parameter, then* 1;; the car of EXP should be the value of VAR-PARM-REF-OP* 1 ;; so we take it away and don't put a LOCF around the reference* (if (and (consp exp) (eq (first exp) var-parm-ref-op)) (second exp) (list 'locf exp))) ((eq sym-type 'value) (multiple-value-setq (exp type fun-call?) (gen-expression pre)) (setf functions-called (append functions-called fun-call?)) (if (check-assignment-compatibility (caddr sym-par) type) (error-handler 'gen-actual-parameter-list "illegal type match of parameters, in")) 1 ;; we only have to copy variable access, that reference arrays,* 1 ;; sets or records, see if this is one.* 1 * (if (and (member (op-name (oper pre)) '(*array-accessor* *record-accessor* *pointer-accessor* *identifier*)) (member (type-of (lookup-symtab type)) '(symtab-array-type symtab-set-type symtab-record-type))) (list copy-object-op exp) exp)) (t (error-handler 'gen-actual-parameter-list "illegal parameter type in")))) (parms info) prefix) functions-called) (values (mapcar #'(lambda (pre) 1; if this is :NLAM don't have to check parameter lists* (multiple-value-setq (exp nil fun-call?) (gen-expression pre)) (setf functions-called (append functions-called fun-call?)) exp) prefix) functions-called) );1if* );1gen-actual-parameter-list 3(DEFUN GEN-ARRAY-ACCESS (prefix &aux info)** 2"generate an array access"* (multiple-value-bind (arr arr-type functions-called) (gen-variable-access (arg1 prefix)) (setf info (lookup-symtab arr-type)) (if (or (null info) (not (typep info 'symtab-array-type))) (error-handler 'gen-array-access "undefined variable or illegal array reference in")) (multiple-value-bind (access type fun-call) (gen-expression (arg2 prefix)) (setf functions-called (append functions-called fun-call)) (if (check-assignment-compatibility type (array-index-type info)) (error-handler 'gen-array-access "illegal type of array index in")) (setf functions-called (append functions-called fun-call)) (values (append (list (make-lisp-struct-from-op (array-accessor info) (oper prefix)) arr) (if (not (packed info)) (gen-special-access-if-necessary (list access) (lookup-symtab (type-of-array info))) (list access))) (type-of-array info) functions-called))) );1gen-array-access ;;; if PACKED is non-NIL this is a packed type. ;;; Note: that multidimension arrays, are implemented as arrays of arrays 3(DEFUN GEN-ARRAY-TYPE (id prefix info &optional (packed nil))** 2"generates an array type"* (let ((arr-type (type-of-array info)) ;1; ++ took out* ;1; *(lookup-symtab 7/07/86 16:29:29 init-form lisp-arr-type upper-bounds lower-bounds index code) (if (not (eq (op-name (oper prefix)) '*array-type*)) (error-handler 'gen-array-type "expected *ARRAY-TYPE* in the beginning of an array definition in")) (multiple-value-setq (upper-bounds lower-bounds) (find-bounds-of-ordinal-type (array-index-type info))) (multiple-value-setq (lisp-arr-type init-form) (get-array-type arr-type packed)) ;1; ++ sjp hack for bug in MAKE-ARRAY *12/29/86 15:23:54 ;1; added the AND to catch-all because I wasn't sure of the problem *;1; 5-25-88 SJP* (IF (AND (consp lisp-arr-type) (TYPEP (cadr lisp-arr-type) 'pascalx::lisp-struct) (EQUAL (pascalx:lisp-form (CADR lisp-arr-type)) `'art-string)) ;1; then* (setf code (list 'list (list 'quote (make-lisp-struct-from-op 'make-array (oper prefix))) (list '1+ `(- (,ord-op ,upper-bounds) (,ord-op ,lower-bounds))) :type lisp-arr-type)) 1 *;1;else* (setf code (list 'list (list 'quote (make-lisp-struct-from-op 'make-array (oper prefix))) (list '1+ `(- (,ord-op ,upper-bounds) (,ord-op ,lower-bounds))) :element-type lisp-arr-type))) (setf code (if (member (type-of (lookup-symtab arr-type)) '(symtab-record-type symtab-array-type symtab-file-type)) (list 'list (list 'quote init-array-op) code (list 'quote (get-init-form arr-type))) (append code (list :initial-element init-form)))) (grind-to-lisp-stream (list (make-lisp-struct-from-op 'defmacro (oper prefix)) (make-lisp-struct-from-op (init-function info) (oper id)) () code)) (setf index (make-lisp-struct 'index nil 'minor)) (setf code `(list 'aref array (list '- (list ',ord-op ,index) (,ord-op ,lower-bounds)))) (grind-to-lisp-stream `(,(make-lisp-struct-from-op 'defmacro (oper prefix)) ,(make-lisp-struct-from-op (array-accessor info) (oper id)) (array ,index) ,code))) );1gen-array-type* ;; ;;Hacked the function to return a LISP string on unpacked arrays. This probably does not ;;conform to the PASCAL standard. ;; SJP 5/26/88 3(DEFUN GET-ARRAY-TYPE (info packed &aux size)* 2"returns the type to use in an array"* ;1; ++ Hack* (COND ((SYMBOLP info) (SETQ info (lookup-symtab info)))) (COND ((and (typep info 'primitive-type) (eq (required-type info) :char) packed) (VALUES (list 'quote (make-lisp-struct ''art-string (lisp-comment packed) (lisp-major-or-minor packed))) (list 'quote (list (make-print-identifier :name '*init-string* :package 'pascalx))))) ((and (typep info 'primitive-type) (eq (required-type info) :char)) (VALUES (list 'quote (make-lisp-struct ''art-string nil nil)) (list 'quote (list (make-print-identifier :name '*init-string* :package 'pascalx))))) ((and packed (typep info 'symtab-subrange-type) (typep (smallest info) :fixnum)) (setf size (get-bit-size-of-subrange info)) (values (make-lisp-struct (if (> size 16.) ''t `''(unsigned-byte ,size)) (lisp-comment packed) (lisp-major-or-minor packed)) (list 'quote (list (make-print-identifier :name '*init-packed-subrange* :package 'pascalx))))) (t (VALUES (if packed (list 'quote (make-lisp-struct 'true (lisp-comment packed) (lisp-major-or-minor packed))) ''t) (list 'quote (list (init-function info)))))) );1get-array-type 3(DEFUN GEN-ASSIGNMENT-STATEMENT (prefix)** 2"generates an assignment statement"* (let (info assign-fun access lhs-type funcall? exp rhs-type temp) (if (not (eq (op-name (oper prefix)) '*assignment-statement*)) (error-handler 'gen-assignment-statement "no *ASSIGNMENT-STATEMENT* in")) (multiple-value-setq (access lhs-type funcall?) (gen-variable-access (arg1 prefix))) (multiple-value-setq (exp rhs-type temp) (gen-expression (arg2 prefix))) (if (check-assignment-compatibility (if (eq lhs-type 'function) (lookup-symtab (arg1 (arg1 prefix))) lhs-type) rhs-type) (error-handler 'gen-assignment-statement "incompatible variable access and expression in")) (setf funcall? (append funcall? temp)) (setf assign-fun (if (eq lhs-type 'function) (assign-function (lookup-symtab (returns (lookup-symtab (arg1 (arg1 prefix)))))) (assign-function (setf info (lookup-symtab lhs-type))))) (gen-catch-if-necessary funcall? (list (make-lisp-struct-from-op assign-fun (oper prefix)) access exp)) );1let* );1gen-assignment-statement 3(DEFUN GEN-BOOLEAN-EXPRESSION (prefix)** 2"generates a boolean expression"* (multiple-value-bind (exp nil function-call?) (gen-expression prefix) (values exp function-call?))) 1;;; returns multiple values, the code for the select and T if this used otherwise. 3(DEFUN GEN-CASE-LIST-ELEMENT (prefix)** 2"Generate code for doing the case list elements of a case"* (let ((stmt (multiple-value-bind (lab stmt) (gen-statement (second prefix)) (if lab (list 'tagbody lab stmt) stmt))) const-list) (setf const-list (if (and (not (consp (first prefix))) (eq (op-name (oper prefix)) '*otherwise*)) (make-lisp-struct-from-op 'otherwise (first prefix)) (loop for const in (first prefix) collect (gen-constant const)))) (values (list const-list stmt) (and (not (consp (first prefix))) (eq (op-name (oper prefix)) '*otherwise*)))) );1gen-case-list-element 3(DEFUN GEN-COMPOUND-STATEMENT (prefix &optional (use-prog nil) &aux stmt-list (there-is-lab nil))** 2"Generate a compound statement from PREFIX"* (cond ((not (eq (op-name (oper prefix)) '*compound-statement*)) (error-handler 'gen-compound-statement "Expected a *COMPOUND-STATEMENT* as the operator in"))) (setf stmt-list (loop with lab and state-code for st in (arg1 prefix) do (multiple-value-setq (lab state-code) (gen-statement st)) (if lab (setf there-is-lab t)) when lab nconc (list lab) nconc (and state-code (list state-code)))) (if use-prog (if there-is-lab (list (make-lisp-struct-from-op 'let (oper prefix)) nil (list* (make-lisp-struct-from-op 'tagbody (oper prefix)) nil stmt-list)) (list (make-lisp-struct-from-op 'let (oper prefix)) nil ;1; ++ added (LIST so that progn wouldn't seem like a symbol* (cons (make-lisp-struct-from-op 'PROGN (oper prefix)) stmt-list))) (if there-is-lab (list* (make-lisp-struct-from-op 'tagbody (oper prefix)) nil stmt-list) (cons (make-lisp-struct-from-op 'progn (oper prefix)) stmt-list))) );1gen-compound-statement 3(DEFUN GEN-CONDITIONAL-STATEMENT (prefix &aux exp funcall? other clauses)** 2"Generate the conditional statements (IF and CASE)"* (case (op-name (oper prefix)) (*if-statement* (multiple-value-setq (exp funcall?) (gen-boolean-expression (arg1 prefix))) (gen-catch-if-necessary funcall? (append (list (make-lisp-struct-from-op 'cond (oper prefix)) (list exp (multiple-value-bind (lab stmt) (gen-statement (arg2 prefix)) (if lab (list 'tagbody lab stmt) stmt)))) (if (arg3 prefix) (list (multiple-value-bind (lab stmt) (gen-statement (arg3 prefix)) (list t (if lab (list 'tagbody lab stmt) stmt)))) nil)))) (*case-statement* (multiple-value-setq (exp nil funcall?) (gen-expression (arg1 prefix))) (setf clauses (mapcar #'(lambda (pre) (multiple-value-bind (code ot) (gen-case-list-element pre) (setf other (if (and other ot) (error-handler 'gen-conditional-statement "Can only have one OTHERS clause in") ot)) code)) (arg2 prefix))) (gen-catch-if-necessary funcall? (cons (make-lisp-struct-from-op 'select (oper prefix)) (cons exp (if other clauses (append clauses `((otherwise (cerror "Ignore it and proceed with no action" "Unexpected value to CASE statement")))) ))))) );1case* );1gen-conditional-statement ;;; GEN-CONSTANT returns the lisp structure to generate a constant, if NUMBER-ONLY is T then ;;; only a number can be found, useful for calling recursive if the constant has a + or - ;;; returns multiple-values, the constant code and the type, one of ;;; :INTEGER, :REAL, :STRING or the enumerated type that it is part of 3(DEFUN GEN-CONSTANT (prefix &optional (gen-new t) (number-only nil) &aux info)** (if (and number-only (or (eq (op-name (oper prefix)) '*string*) (and (eq (op-name (oper prefix)) '*identifier*) (typep (value (lookup-symtab (arg1 prefix))) :string) (not (null (part-of-type (lookup-symtab (arg1 prefix)))))))) (error-handler 'gen-constant "expected a numeric constant, but got a string or enumerated one in")) (case (op-name (oper prefix)) (*number* (values (make-lisp-struct-from-op (arg1 prefix) (oper prefix)) (cond ((floatp (arg1 prefix)) 'real) (t 'integer)))) (*string* (cond ((= (length (arg1 prefix)) 1) (values (make-lisp-struct-from-op (aref (arg1 prefix) 0) (oper prefix)) 'char)) (t (values (make-lisp-struct-from-op (arg1 prefix) (oper prefix)) :string)))) (*identifier* (setf info (lookup-symtab (arg1 prefix))) (values (make-lisp-struct-from-op (access-form info) (oper prefix)) (cond ((part-of-type info)) ((floatp (value info)) 'real) ((integerp (value info)) 'integer) ((stringp (value info)) :string)))) ((*unary-minus* *unary-plus*) (multiple-value-bind (code type) (gen-constant (arg1 prefix) gen-new t) (values (list (make-lisp-struct-from-op (gethash (op-name (oper prefix)) *EXP-FUN-TABLE*) (oper prefix)) code) type))) );1case* );1gen-constant* #| 3(DEFUN MAKE-CONSTANT-SYMBOL (prefix &aux str (number (arg1 prefix)))* (cond ((<= 256 number 99999) (setf str (format nil "~D" number)) (make-lisp-struct-from-op (cons '+ (append (cond ((and (= (length str) 5) (not (eql (char str 0) #\0))) (prog1 (list (make-print-identifier :name (nth (- (char str 0) #\1) *ten-thousands-list*) :package 'pascalx)) (setf number (- number (* 10000 (- (char str 0) #\0)))) (setf str (subseq str 1))))) (cond ((and (= (length str) 4) (not (eql (char str 0) #\0))) (prog1 (list (make-print-identifier :name (nth (- (char str 0) #\1) *thousands-list*) :package 'pascalx)) (setf number (- number (* 1000 (- (char str 0) #\0)))) (setf str (subseq str 1))))) (cond ((and (= (length str) 3) (not (eql (char str 0) #\0)) (>= number 256)) 1;; Subtract the #\1 since there is no *ONE-HUNDRED** (prog1 (list (make-print-identifier :name (nth (- (char str 0) #\2) *hundreds-list*) :package 'pascalx)) (setf number (- number (* 100 (- (char str 0) #\0)))) (setf str (subseq str 1))))) (if (/= number 0) (list number) nil))) (oper prefix))) (t (make-lisp-struct-from-op (arg1 prefix) (oper prefix)))) );1make-constant-symbol* |# 3(DEFUN GEN-CONSTANT-DEFINITIONS (prefix &aux info)* 2"Generate constant definitions if any"* (cond ((not (null prefix)) (if (not (eq (op-name (oper prefix)) '*constant-define*)) (error-handler 'gen-constant-definitions "expected *CONSTANT-DEFINE* in")) (mapcar #'(lambda (const-def) (setf info (lookup-symtab (arg1 (first const-def)))) (grind-to-lisp-stream (list 'defconstant (make-lisp-struct-from-op (access-form info) (oper (first const-def))) (gen-constant (second const-def) nil)))) (arg1 prefix))) (t nil)) )1;gen-constant-definitions 3(DEFUN DIRECTIVE? (prefix)** 2"returns T if this is a directive (currently FORWARD and EXTERNAL), NIL otherwise"* (and (typep (oper prefix) 'operator) (eq (op-name (oper prefix)) '*directive*))) 3(DEFUN GEN-ENUMERATED-TYPE (prefix info)* 2"generates a new enumerated type and returns a string to be printed"* (declare (values string-to-print)) (loop for const-id in (arg1 prefix) and symtab-ids on (poss-values info) and pred-info = nil then const-info for const-info = (lookup-symtab (car symtab-ids)) and succ-info = (and (cdr symtab-ids) (lookup-symtab (cadr symtab-ids))) do (grind-to-lisp-stream (list 'defconstant 1;; have to EVAL because enumerated symbols stored as 'symbol* (make-lisp-struct-from-op (eval (access-form const-info)) (oper const-id)) (value const-info) (format nil2 *"enumerated constant of type ~S" (access-form info)))) (grind-to-lisp-stream `(setf (global:get ',(eval (access-form const-info)) ',successor-op) ',(and succ-info (eval (access-form succ-info))))) (grind-to-lisp-stream `(setf (global:get ',(eval (access-form const-info)) ',predecessor-op) ',(and pred-info (eval (access-form pred-info)))))) (format nil "enumerated with the following identifiers in it: ~%~@14T~A" (format:print-list nil "~S" (poss-values info))) );1gen-enumerated-type ;;; Note: expressions are of the form ( ). is looked up ;;; in the table *EXP-FUN-TABLE*. If that returns a value GEN-EXPRESSION returns the list ;;; of the value followed by doing GEN-EXPRESSION on . If the value returned by ;;; *EXP-FUN-TABLE* is a list, then it does an assq of the list with the type of ;;; to determine which function to call. Note that if the function is *SET-CONSTRUCTOR*, ;;; the args are handled by GEN-MEMBER-DESIGNATORS. If *EXP-FUN-TABLE* does not return a value ;;; then it calls GEN-SIMPLE-EXPRESSION. ;;; GEN-EXPRESSION returns multiple values, the first is the expression code, the second is ;;; the type of the expression, which if this is a operator, this is the type ;;; that that operator returns, one of INTEGER, REAL or the name of an type identifier. [this ;;; would be a type of enumerated, symbol, or some kind of string]. ;;; the third is a list of function names if any (non predefined) ;;; functions are called in the expression. 3(DEFUN GEN-EXPRESSION (prefix &aux function-call? type arglist fun-type)** 2"generates the code for an expression"* (multiple-value-bind (pascal-function exists) (gethash (op-name (oper prefix)) *EXP-FUN-TABLE*) (cond ((not (null exists)) (cond ((eq (op-name (oper prefix)) '*set-constructor*) (multiple-value-setq (arglist function-call?) (gen-member-designators (arg1 prefix))) (setf type :set)) (t (setf arglist (loop with exp and past-type for pre in (rest1 prefix) do (multiple-value-setq (exp type function-call?) (gen-expression pre)) (setf type (if (or (and (eq type 'integer) (eq past-type 'real)) (and (eq type 'real) (eq past-type 'integer))) 'real type)) collect exp)))) (if (null pascal-function) 1 ; this is *NIL-X** (values nil :pointer nil) (values (cons (if (consp pascal-function) (cdr (assoc (find-primitive-type type) pascal-function)) pascal-function) arglist) (if (eq (setf fun-type (gethash (op-name (oper prefix)) *EXP-TYPE-TABLE*)) '*type-of-arguments*) type fun-type) function-call?))) (t (gen-simple-expression prefix)))) );1gen-expression 3(DEFUN FIND-PRIMITIVE-TYPE (ty-id &aux info)** 2"finds the primitive type of a type identifier"* (cond ((member ty-id '(:string :pointer :set :array)) ty-id) ((not (typep (setf info (lookup-symtab ty-id)) 'type)) (error-handler 'find-primitive-type "can only find the primitive type of a type identifier")) ((typep info 'symtab-array-type) (if (eq (find-primitive-type (type-of-array info)) :char) :string :array)) ((typep info 'symtab-subrange-type) (find-primitive-type (host-type info))) ((typep info 'symtab-enumerated-type) :enumerated) ((typep info 'symtab-set-type) :set) ((typep info 'symtab-pointer-type) :pointer) ((typep info 'primitive-type) (if (member (required-type info) '(:real :integer)) :number (required-type info))) (t (error-handler 'find-primitive-type "illegal type in"))) );1find-primitive-type ;;; if is ;;; *FUNCTION-CALL* then GEN-EXPRESSION, returns the list with the first of as the ;;; operator, otherwise should be one of *RECORD-ACCESSOR*, *ARRAY-ACCESSOR*, ;;; *POINTER-ACCESSOR* or *IDENTIFIER*, in which case GEN-VARIABLE-ACCESS is called ;;; if it is *IDENTIFIER* then a check is made to see if it is a function call with ;;; no args, if it is none of the above then GEN-CONSTANT is called.* ;1; Changed the TYPEP statement for *FUNCTION-CALL* because 'function is no* ;1; longer a legal argument for a type-spec. 5/24/88 SJP 3(DEFUN GEN-SIMPLE-EXPRESSION (prefix)** 2"generates a simple expression"* (let (access type function-call? info) (case (op-name (oper prefix)) (*function-call* (if (not (EQL (TYPEP (setf info (lookup-symtab (arg1 (arg1 prefix))))) 'function)) (error-handler 'gen-simple-expression "trying to use ~A as a function, when it is of type ~A, in" (arg1 (arg1 prefix)) (type-of info))) (cond ((pre-defined info) (gen-pre-def-fun-call prefix info)) (t (inherit-labels-used (external-labels-used info) (car *CURRENT-DEFINITION-STACK*)) (multiple-value-setq (access type) (gen-variable-access (arg1 prefix))) (multiple-value-bind (args funcall?) (gen-actual-parameter-list (arg2 prefix) info) (values (append (if (parameter info) (list 'funcall access) (list access)) args) (returns info) (cons (pascal-id info) funcall?)))))) (*identifier* 1; have to check if this is a function call with no args* (setf info (lookup-symtab (arg1 prefix))) (cond ((and (pre-defined info) (EQL (typep info) 'FUNCTION)) (gen-pre-def-fun-call prefix info)) (t (multiple-value-setq (access type) (gen-variable-access prefix)) (cond ((typep info 'function) (inherit-labels-used (external-labels-used info) (car *CURRENT-DEFINITION-STACK*)) (values (list access) type (list (pascal-id info)))) (t (values access type nil)))))) ((*array-accessor* *record-accessor* *pointer-accessor*) (multiple-value-setq (access type function-call?) (gen-variable-access prefix)) (values access type function-call?)) (otherwise (multiple-value-setq (access type) (gen-constant prefix)) (values access type nil)) );1case* );1let* );1gen-simple-expression 3(DEFUN GEN-PRE-DEF-FUN-CALL (prefix info &aux return-type fun-call? act-parm-list)** 2"generates a call to a predefined function"* (cond ((or (eq (pascal-id info) 'eof) (eq (pascal-id info) 'eoln)) (cond ((not (null (arg2 prefix))) (multiple-value-bind (access nil fun-call?) (gen-variable-access (first (arg2 prefix))) (if (and (consp access) (eq (first access) var-parm-ref-op)) (second access) (list 'locf access)) (values (list (access-form info) access) (returns info) fun-call?))) (t (values (list (access-form info) (access-form (lookup-symtab 'input))) 'boolean nil)))) (t (setf act-parm-list (mapcar #'(lambda (arg) (multiple-value-bind (exp type fun-c) (gen-expression arg) (setf fun-call? (append fun-call? fun-c)) (setf return-type type) exp)) (arg2 prefix))) (if (not (eq (returns info) '*type-of-arguments*)) (setf return-type (returns info))) (values (cons (access-form info) act-parm-list) return-type fun-call?))) );1gen-pre-def-fun-call 3(DEFUN GEN-FIELD-LIST (prefix field-list &optional (packed? nil))** 2"generate the field list of a record type"* (let ((fixed-part (gen-fixed-part (first prefix) field-list packed?))) (multiple-value-bind (variant-part tag-field) (gen-variant-part (second prefix) field-list packed?) (append fixed-part tag-field variant-part))) );1gen-field-list 3(DEFUN GEN-FIXED-PART (prefix field-list &optional (packed? nil))** 2"generates a fixed part of a field list [subrange types are packed if PACKED? is true]"* (cond ((not (null prefix)) (loop for rec-sect in prefix for field-type = (second rec-sect) and (nil . type-id) in (fixed-fields field-list) for type-info = (lookup-symtab type-id) nconc (loop for field-id in (first rec-sect) and num-of-bits = (if (and packed? (typep type-info 'symtab-subrange-type)) (get-bit-size-of-subrange type-info) 32) and init-function = (if (and packed? (typep type-info 'symtab-subrange-type)) (list (make-print-identifier :name '*init-packed-subrange* :package 'pascalx)) (list (init-function type-info))) collect (LIST (make-lisp-struct-from-op ;1; ++Added mk-pt-id* (make-print-identifier :name (arg1 field-id) :package *output-package*) (oper field-id)) (make-lisp-struct-from-op init-function (oper field-id)) num-of-bits))))) );1gen-fixed-part ;;; PACK-FIELDS takes a field-list for a defstruct, which is of the form (( ;;; )...) and packs it if it can. If is 32 then can't pack this field 3(DEFUN PACK-FIELDS (list)** 2"packs a list of numeric subranges if it can"* (loop with bits-left = 32 and current-list = nil and finished-list = nil for item in list when (consp item) do (cond ((>= (third item) 32) (if (not (null current-list)) (setf finished-list (append finished-list (list current-list)))) (setf finished-list (append finished-list (list (list (first item) (second item))))) (setf current-list nil bits-left 32)) ((= (third item) bits-left) (setf finished-list (append finished-list (list (append current-list (list (list (first item) `(byte ,(third item) ,(- 32 bits-left)) (second item))))))) (setf current-list nil bits-left 32)) ((< (third item) bits-left) (setf current-list (append current-list (list (list (first item) `(byte ,(third item) ,(- 32 bits-left)) (second item)))) bits-left (- bits-left (third item)))) ((> (third item) bits-left) (if (not (null current-list)) (setf finished-list (append finished-list (list current-list)))) (setf current-list (list (list (first item) `(byte ,(third item) 0) (second item))) bits-left 32))) else do (setf current-list (append current-list (list item))) finally (if (null current-list) (return finished-list) (return (append finished-list (list current-list)))) );1loop* );1packed-fields 3(DEFUN GEN-FOR-STATEMENT (prefix &aux (kind (op-name (oper prefix))))** (when (not (member kind '(*for-to-statement* *for-downto-statement*))) (error-handler 'gen-repetitive-statement "illegal type of repetitive statement ~A in" kind)) (let (control-var type1 funcall? type2 temp init-exp final-exp ass-fun) (multiple-value-setq (control-var type1 funcall?) (gen-variable-access (arg1 prefix))) (multiple-value-setq (init-exp type2 temp) (gen-expression (arg2 prefix))) (check-assignment-compatibility type1 type2) (setf funcall? (append funcall? temp)) (multiple-value-setq (final-exp type2 temp) (gen-expression (arg3 prefix))) (check-assignment-compatibility type1 type2) (setf funcall? (append funcall? temp)) (setf ass-fun (assign-function (lookup-symtab type1))) (gen-catch-if-necessary funcall? (list (make-print-identifier :name (if (eq kind '*for-to-statement*) '*for-to-loop* '*for-downto-loop*) :package 'pascalx) (list control-var ass-fun init-exp final-exp) (multiple-value-bind (lab stmt) (gen-statement (arg4 prefix)) (if lab (list 'tagbody lab stmt) stmt)))) );1let* );1gen-for-statement 3(DEFUN GEN-FORMAL-PARAMETERS (prefix &aux ty parms)** 2"returns a formal parameter list"* (cond ((not (null prefix)) (cond ((not (eq (op-name (oper prefix)) '*formal-parameters*)) (error-handler 'gen-formal-parameters "expected *FORMAL-PARAMETERS* at line number ~D in" (op-line-no (oper prefix))))) (mapcan #'(lambda (form-parm-sect) (cond ((consp (oper form-parm-sect)) (setf ty (pid-name (access-form (lookup-symtab (arg1 (second form-parm-sect))))) parms (oper form-parm-sect))) ((eq (op-name (oper form-parm-sect)) '*variable-parameter*) (setf ty (concat 'string (string (pid-name (access-form (lookup-symtab (arg1 (arg2 form-parm-sect)))))) 2 *"[VAR]: " (op-comment (oper prefix))) parms (arg1 form-parm-sect))) ((member (op-name (oper form-parm-sect)) '(*procedural-parameter* *functional-parameter*)) (setf ty (if (eq (op-name (oper form-parm-sect)) '*procedural-parameter*) 'procedure 'function) parms (list (arg1 form-parm-sect)))) (t (error-handler 'gen-formal-parameters "illegal parameter type at line number ~D, in" (op-line-no (oper prefix))))) (mapcar #'(lambda (x) (make-lisp-struct-from-op ;1; ++ took out *(pid-name1 *7/07/86 15:51:00 (access-form (lookup-symtab (arg1 x))) (oper x))) parms)) (arg1 prefix)))) );1gen-formal-parameters ;; ++ Changed the (append... ) to a backquote and moved the special-vars inside* ;1; the let so that nested functions will work correctly with special variables.* ;1; LET handles (declare...) 3(DEFUN GEN-FUNCTION-BLOCK (prefix parm-list)** 2"generate a function block from prefix PARM-LIST"* (let ((info (lookup-symtab (arg1 (arg1 prefix)))) head formals) (when (not (directive? (arg4 prefix))) (setf head `(,(make-lisp-struct-from-op 'defun (oper prefix)) ,(gen-variable-access (arg1 prefix)) ,(SETQ formals (gen-formal-parameters parm-list)))) (multiple-value-bind (blck special-vars) (gen-block (arg4 prefix) (pascal-id info)) (MULTIPLE-VALUE-BIND (formal-specials other-specials) (filter-special-formals special-vars formals) (terpri *LISP-STREAM*) (terpri *LISP-STREAM*) (grind-to-lisp-stream `(,@head ,@(if formal-specials `((DECLARE (SPECIAL . ,formal-specials))) nil) (,(CAR blck) ,(CADR blck) ,@(if other-specials `((DECLARE (SPECIAL . ,other-specials))) nil) ,@(CDDR blck))))))))) ; (append head ; (if (not (null special-vars)) ; (list special-vars) ; nil) ; (list blck)))) ; );1when* ; );1let* ; );1gen-function-block 3(DEFUN GEN-GOTO-STATEMENT (prefix &aux lab-info)** 2"generate a goto statement"* (if (not (eq (op-name (oper prefix)) '*goto-statement*)) (error-handler 'gen-goto-statement "expected a *GOTO-STATEMENT* in")) (setf lab-info (lookup-symtab (arg1 (arg1 prefix)))) (if (not (eq (type-of lab-info) 'label)) (error-handler 'gen-goto-statement "illegal label in")) (make-symbol-special lab-info) (if (eq *CURRENT-LEVEL* (level lab-info)) (list (make-lisp-struct-from-op 'go (oper prefix)) (make-lisp-struct-from-op (access-form lab-info) (oper (arg1 prefix)))) (list (make-lisp-struct-from-op 'throw (oper prefix)) (list 'quote (make-level-tag (level lab-info))) (list 'quote (make-lisp-struct-from-op (make-label-into-throw-value (access-form lab-info)) (oper (arg1 prefix))))) );1if* )1;gen-goto-statement 3(DEFUN GEN-LABEL-DECLARATIONS (prefix)** 2"generate the label declarations"* (when (not (null prefix)) (if (not (eq (op-name (oper prefix)) '*label-declare*)) (error-handler 'gen-label-declarations "expected a *LABEL-DECLARE* at the beginning of label declarations section in"))) );1gen-label-declarations 3(DEFUN GEN-MEMBER-DESIGNATORS (prefix &aux code code1 code2 fun-c functions-called)** 2"generates a list of member designators from a list of them."* (setf code (mapcar #'(lambda (des) (cond ((consp (car des)) (multiple-value-setq (code1 nil fun-c) (gen-expression (first des))) (setf functions-called (append functions-called fun-c)) (multiple-value-setq (code2 nil fun-c) (gen-expression (second des))) (setf functions-called (append functions-called fun-c)) (list 'list code1 code2)) (t (multiple-value-setq (code1 nil functions-called) (gen-expression des)) (setf functions-called (append functions-called fun-c)) code1))) prefix)) (values code functions-called) );1gen-member-designations 3(DEFUN GEN-ORDINAL-TYPE (prefix &aux id info (kind (op-name (oper prefix))))** 2"generate an ordinal type, entering a new type into symbol table."* (if (and (not (member kind '(*enumerated-type* *subrange-type*))) (or (not (eq kind '*identifier*)) (not (member (type-of (lookup-symtab (arg1 prefix))) all-ordinal-types)))) (error-handler 'gen-ordinal-type "illegal ordinal type at line number ~D in" (op-line-no (oper prefix)))) (case kind (*identifier* (pascal-id (lookup-symtab (arg1 prefix)))) (*enumerated-type* (setf info (enter-enumerated (setf id (get-new-anon-id)) prefix)) (gen-new-type id prefix info) (pascal-id info)) (*subrange-type* (setf info (enter-subranges (setf id (get-new-anon-id)) prefix)) (gen-new-type id prefix info) (pascal-id info))) );1gen-ordinal-type 3(DEFUN GEN-NEW-TYPE (id prefix info &optional (packed? nil))** 2"generate a new type"* (let ((kind (op-name (oper prefix))) packed) (cond ((eq kind '*packed*) (setf packed (make-lisp-struct-from-op 'packed (oper prefix))) (setf kind (op-name (oper (setf prefix (arg1 prefix)))))) (packed? (setf packed (make-lisp-struct 'packed nil nil)))) (case kind (*array-type* (gen-array-type id prefix info packed)) (*record-type* (gen-record-type id prefix info packed)) (*enumerated-type* (gen-enumerated-type prefix info)) ;1++ added enum type* 1 *;1added enumerated type* (otherwise (if (or (not (member kind '(*subrange-type* *pointer-type* *file-type* *set-type*))) (not (eq (op-name (oper id)) '*identifier*))) (error-handler 'gen-new-type "illegal format of identifier or type for generating new type"))) );1case* );1let* );1gen-new-type 3(DEFUN GEN-POINTER-ACCESS (prefix &aux info)** 2"generates a pointer access"* (multiple-value-bind (access type function-call?) (gen-variable-access (arg1 prefix)) (setf info (lookup-symtab type)) (if (typep info 'symtab-file-type) 1 ; then this is a reference to the buffer variable of a file type* (values (list (make-lisp-struct-from-op buf-variable-op (oper prefix)) access) (symtab-component-type info)) (values (list (make-lisp-struct-from-op pointer-op (oper prefix)) access) (symtab-domain-type info) function-call?))) );1gen-pointer-access* ;1; ++ Changed the (append... ) to a backquote and moved the special-vars inside* ;1; the let so that nested procedures will work correctly with special variables.* ;1; LET handles (declare...) 3(DEFUN GEN-PROCEDURE-BLOCK (prefix parm-list)** 2"generate a procedure block from the prefix PARM-LIST"* (cond ((not (directive? (arg3 prefix))) (multiple-value-bind (blck special-vars) (gen-block (arg3 prefix)) (LET ((formals (gen-formal-parameters parm-list))) (MULTIPLE-VALUE-BIND (formal-specials other-specials) (filter-special-formals special-vars formals) (terpri *LISP-STREAM*) (terpri *LISP-STREAM*) (grind-to-lisp-stream `(,(make-lisp-struct-from-op 'DEFUN (oper prefix)) ,(gen-variable-access (arg1 prefix)) ,formals ,@(if formal-specials `((DECLARE (SPECIAL . ,formal-specials))) nil) (,(CAR blck) ,(CADR blck) ,@(if other-specials `((DECLARE (SPECIAL . ,other-specials))) nil) ,@(CDDR blck)))))))))) ; (append (list (make-lisp-struct-from-op 'defun (oper prefix)) ; (gen-variable-access (arg1 prefix)) ; (gen-formal-parameters parm-list)) ; (if special-vars (list special-vars) nil) ; (list blck)))))) ; );1gen-procedure-block 3(DEFUN GEN-PROCEDURE-STATEMENT (prefix &aux info)** 2"generate a procedure call"* (if (not (eq (op-name (oper prefix)) '*procedure-call*)) (error-handler 'gen-procedure-statement "expected *PROCEDURE-CALL* in")) (setf info (lookup-symtab (arg1 (arg1 prefix)))) (cond ((pre-defined info) (gen-pre-defined-proc prefix info)) (t1 ;; We have to make this procedure inherit labels used on higher levels by the called procedure* (inherit-labels-used (external-labels-used info) (car *CURRENT-DEFINITION-STACK*)) (gen-catch-if-necessary (list (pascal-id info)) (cons (make-lisp-struct-from-op (access-form info) (oper (arg1 prefix))) (gen-actual-parameter-list (arg2 prefix) info))))) );1gen-procedure-statement 3(DEFUN GEN-PRE-DEFINED-PROC (prefix info &aux p-info code funcall?)** 2"generate the appropriate code for calling a predefined procedure where prefix is the PREFIX, INFO is the symbol table entry for this procedure"* (case (pascal-id info) ((write writeln page) (gen-write-call prefix info)) ((read readln) (gen-read-call prefix info)) ((BREAK) (gen-break-call prefix info)) ((breakin) (gen-breakin-call prefix info)) ((new dispose) (multiple-value-bind (access type funcall?) (gen-variable-access (first (arg2 prefix))) (if (or funcall? (not (typep (setf p-info (lookup-symtab type)) 'symtab-pointer-type))) (error-handler 'gen-pre-defined-proc "can only call NEW or DISPOSE on pointer variables")) (values (if (eq (pascal-id info) 'new) (list* (access-form info) access (list (init-function (lookup-symtab (symtab-domain-type p-info)))) (mapcar #'gen-constant (rest (arg2 prefix)))) (list* (access-form info) access (mapcar #'gen-constant (rest (arg2 prefix))))) nil))) (pack1 ;; should have three args* (multiple-value-bind (acc type fun-c1) (gen-variable-access (first (arg2 prefix))) (if (not (typep (setf p-info (lookup-symtab type)) 'symtab-array-type)) (error-handler 'gen-pre-defined-proc "illegal array for PACK")) (multiple-value-bind (exp nil fun-c2) (gen-expression (second (arg2 prefix))) (multiple-value-bind (nil lower-bound) (find-bounds-of-ordinal-type (array-index-type p-info)) (setf exp (list '- exp (list ord-op lower-bound)))) (multiple-value-bind (acc2 nil fun-c3) (gen-variable-access (third (arg2 prefix))) (values (list (make-lisp-struct-from-op (access-form info) (oper prefix)) acc exp acc2) (append fun-c1 fun-c2 fun-c3)))))) (unpack1 ;; should have three args* (multiple-value-bind (acc nil fun-c1) (gen-variable-access (first (arg2 prefix))) (multiple-value-bind (acc2 type fun-c2) (gen-variable-access (second (arg2 prefix))) (if (not (typep (setf p-info (lookup-symtab type)) 'symtab-array-type)) (error-handler 'gen-pre-defined-proc "illegal array for UNPACK")) (multiple-value-bind (exp nil fun-c3) (gen-expression (third (arg2 prefix))) (multiple-value-bind (nil lower-bound) (find-bounds-of-ordinal-type (array-index-type p-info)) (setf exp (list '- exp (list ord-op lower-bound)))) (values (list (make-lisp-struct-from-op (access-form info) (oper prefix)) acc acc2 exp) (append fun-c1 fun-c2 fun-c3)))))) ((rewrite reset) (setf code (cons (make-lisp-struct-from-op (access-form info) (oper prefix)) (cons *program-default-pathname* (mapcar #'(lambda (arg) (multiple-value-bind (exp nil fun-c) (gen-expression arg) (setf funcall? (append funcall? fun-c)) exp)) (arg2 prefix))))) (cond ((and (> (length code) 4) (or (eq (pascal-id info) 'reset) (eq (pascal-id info) 'rewrite))) (setf code (append (firstn 4 code) (interpret-switches (fifth code)))))) (values code funcall?)) ((get put close) (setf code (cons (make-lisp-struct-from-op (access-form info) (oper prefix)) (mapcar #'(lambda (arg) (multiple-value-bind (exp nil fun-c) (gen-expression arg) (setf funcall? (append funcall? fun-c)) exp)) (arg2 prefix)))) (cond ((and (> (length code) 4) (or (eq (pascal-id info) 'reset) (eq (pascal-id info) 'rewrite))) (setf code (append (firstn 4 code) (interpret-switches (fifth code)))))) (values code funcall?)) (otherwise (error-handler 'gen-pre-defined-proc "illegal pre-defined procedure name (~A) in" (pascal-id info)))) );1gen-pre-defined-proc ;;; Interprets switches (ala DEC-20) pascal that are given to reset and rewrite. ;;; Only switches that are recognixed are /O and /I. If the third arg is not ;;; a string this is an error. 3(DEFUN INTERPRET-SWITCHES (arg)** (let ((str (lisp-form arg))) (if (or (not (stringp str)) (< (length str) 2)) (error-handler 'interpret-switches "illegal switch type specified, ~S in" str)) (loop for sw = (subseq str 0 2) when (or (equal sw "/o") (equal sw "/O")) collect (make-lisp-struct :no-error (lisp-comment arg) (lisp-major-or-minor arg)) when (or (equal sw "/i") (equal sw "/I")) collect (make-lisp-struct :no-initial-get (lisp-comment arg) (lisp-major-or-minor arg)) do (setf str (subseq str 2)) until (< (length str) 1) );1loop* );1let* );1interpret-switches ;;; READ and READLN take the following parameters: (FILE &REST ARGS) ;;; FILE must be given, if it is left out of the PASCAL parameter list it defaults to ;;; INPUT. 3(DEFUN GEN-READ-CALL (prefix info** &aux file-info file-var type funcall? temp in-info code rest-args) 2"generate call to READ or READLN"* (cond ((not (null (arg2 prefix))) (setf code (cons (make-lisp-struct-from-op (access-form info) (oper prefix)) (cond ((not (consp (first (oper (arg2 prefix))))) (multiple-value-setq (file-var type funcall?) (gen-variable-access (first (arg2 prefix)))) (setf file-info (lookup-symtab type)) (cond ((not (typep file-info 'symtab-file-type)) (make-symbol-special (setf temp (lookup-symtab 'input))) (setf rest-args (rest (arg2 prefix))) (list (access-form temp) (find-read-or-write-type type) (if (and (consp file-var) (eq (first file-var) var-parm-ref-op)) (second file-var) (list 'locf file-var)))) (t (setf rest-args (rest (arg2 prefix))) (list file-var)))) (t (make-symbol-special (setf temp (lookup-symtab 'input))) (setf rest-args (arg2 prefix)) (list (access-form temp)))))) (setf code (append code (mapcan #'(lambda (parm) (multiple-value-bind (code fun) (gen-read-parm parm) (setf funcall? (append funcall? fun)) code)) rest-args))) (values code funcall?)) ((eq (pascal-id info) 'readln) (make-symbol-special (setf in-info (lookup-symtab 'input))) (values (list (make-lisp-struct-from-op (access-form info) (oper prefix)) (access-form in-info)) nil)) (t (error-handler 'gen-read-call "READ must have a parameter list, in"))) );1gen-read-call* ;1;; ++ generate a LISP break 3(DEFUN GEN-BREAK-CALL (prefix info** &aux code funcall?) 2"generate call to BREAK"* (if (not (null (arg2 prefix))) (setf code (LIST (make-lisp-struct-from-op (access-form info) (oper prefix)) (multiple-value-bind (exp nil fun-c) (gen-expression (CAR (arg2 prefix))) (setf funcall? (list fun-c)) exp))) (error-handler 'gen-read-call "3BREAK must have a format string.*")) (values code funcall?) ) ;gen-break-call ;1;; ++ generate a LISP break 3(DEFUN GEN-BREAK**IN3-CALL (prefix info* &aux code funcall?) 2"generate call to BREAKIN"* (setf code (cons (make-lisp-struct-from-op (access-form info) (oper prefix)) (mapcar #'(lambda (arg) (multiple-value-bind (exp nil fun-c) (gen-expression arg) (setf funcall? (append funcall? fun-c)) exp)) (arg2 prefix)))) #| (if (not (null (arg2 prefix))) (setf code (LIST (make-lisp-struct-from-op (access-form info) (oper prefix)) (CADR (oper (arg2 prefix))) (CADR (oper (arg3 prefix))))) (error-handler 'gen-read-call "3BREAK must 1 argument.*"))3 |*# (values code funcall?) ) 1;;; gen-read-parm returns a list of keyword, followed by a read parameter. A read parameter ;;; is either a locative (if keyword is :CHAR, :INTEGER or :REAL) it is or if keyword is ;;; :STRING then the parameter can be a list of 3 elements (it could also just be a locative) ;;; the first element is a locative for the string, the second is a locative for a howmany variable ;;; that tells how many characters were read by read, the third if supplied is a set of break characters. 3(DEFUN GEN-READ-PARM (prefix &aux funcall? type code temp)** (cond ((not (consp (oper prefix))) (multiple-value-bind (acc ty fun) (gen-variable-access prefix) (values `(,(find-read-or-write-type ty) (locf ,acc)) fun))) (t (multiple-value-bind (acc ty fun) (gen-variable-access (first prefix)) (setf type (find-read-or-write-type ty) funcall? (append funcall? fun)) (if (not (eq type :string)) (error-handler 'gen-read-parm "Trying to do a string read of a non string")) (setf code (list 'list (list 'locf acc)))) (multiple-value-bind (acc ty fun) (gen-variable-access (second prefix)) (setf funcall? (append funcall? fun)) (if (not (eq (setf temp (find-primitive-type ty)) :number)) (error-handler 'gen-read-parm "illegal type (~S) for a 'how-many' variable in a read" temp)) (setf code (append code (list (list 'locf acc))))) (if (not (null (third prefix))) (multiple-value-bind (exp nil fun) (gen-expression (third prefix)) (setf funcall? (append funcall? fun)) (setf code (append code (list exp))))) (values (list type code) funcall?))) );1gen-read-parm 3(DEFUN FIND-READ-OR-WRITE-TYPE (type &optional (write nil)** &aux info) 2"returns the type of TYPE which is :INTEGER, :REAL, :CHAR, or :STRING"* (cond ((MEMQ type '(:string :real :integer :char)) type) ((MEMQ type '(string real integer char)) (INTERN type 'keyword)) ((and (typep (setf info (lookup-symtab type)) 'primitive-type) (or (not (eq (required-type info) :boolean)) write)) (required-type info)) ((typep info 'symtab-array-type) (find-primitive-type type)) ((typep info 'symtab-subrange-type) (find-read-or-write-type (host-type info))) (t (error-handler 'find-read-or-write-call "illegal type for ~:[READ~;WRITE~] of a text file, in" write))) );1find-read-or-write-type ;;; WRITE take the following parameters: (FILE TEXT EXPRESSION &OPTIONAL (RETURN NIL), ;;; to do a WRITELN, RETURN is T, if WRITELN is called with no expression then EXPRESSION ;;; is NIL and RETURN is T. Note only one EXPRESSION, this ;;; is because the ANSI standard says that the expressions in a WRITE parameter ;;; list are evaluated one at a time. PAGE takes the parameters: (FILE). ;;; FILE must be given, if omitted in the PASCAL parameter list it defaults to OUTPUT. ;;; NOTE: WRITELN and PAGE can only be applied to TEXT files. 3(DEFUN GEN-WRITE-CALL (prefix info)** 2"generate a call to WRITE, WRITELN or PAGE"* (let ((write-args (arg2 prefix)) arg w-code f-access funcall? file-info out-info) (cond ((and (not (null (arg2 prefix))) (not (consp (oper (first (arg2 prefix))))) (member (op-name (oper (first (arg2 prefix)))) '(*record-accessor* *array-accessor* *identifier* *pointer-accessor*))) (multiple-value-bind (acc type f-call?) (gen-variable-access (first (arg2 prefix))) (setf funcall? f-call?) (setf f-access (cond ((and (not (null type)) (typep (setf file-info (lookup-symtab type)) 'symtab-file-type)) (setf write-args (rest write-args)) acc) (t (make-symbol-special (setf out-info (lookup-symtab 'output))) (access-form out-info)))))) (t (make-symbol-special (setf out-info (lookup-symtab 'output))) (setf f-access (access-form out-info)))) 1;; Do any checking to make sure WRITELN and PAGE are only called on text files,* 1;; that WRITE is only given formatting expressions with text files here.* (setf w-code (cond ((and (eq (pascal-id info) 'page) (not (null write-args))) (error-handler 'gen-write-call "Too many arguments to PAGE, in")) ((and (null write-args) (member (pascal-id info) '(page writeln))) (if (eq (pascal-id info) 'page) (list (access-form info) f-access) (list (access-form info) f-access :writeln nil t))) ((= (length write-args) 1) (multiple-value-bind (code type temp) (gen-write-parm (first write-args)) (setf funcall? (append funcall? temp)) (list (make-lisp-struct-from-op (access-form info) (oper prefix)) f-access type code (eq (pascal-id info) 'writeln)))) (t (setf arg (make-print-identifier :name '*arg* :package *OUTPUT-PACKAGE*));1 ++* (list 'mapc (list 'function (list 'lambda (list arg) (list 'apply (list 'function (make-lisp-struct-from-op (access-form info) (oper prefix))) f-access arg))) (cons 'list (loop for arg on write-args collect (multiple-value-bind (code type temp) (gen-write-parm (car arg)) (setf funcall? (append funcall? temp)) (list 'list type code (if (and (null (cdr arg)) (eq (pascal-id info) 'writeln)) t nil))))))))) (values w-code funcall?) );1let* );1gen-write-call ;;; Returns multiple values the code, the type and whether a function is called 3(DEFUN GEN-WRITE-PARM (prefix &aux result function-call? type)** 2"generate a write parameter, prefix should be an expression, or a list of three expressions"* (cond ((consp (oper prefix)) (if (not (= (length prefix) 3)) (error-handler 'gen-write-parm "illegal write parameter in")) (setf result (list 'list (multiple-value-bind (exp ty fun-call) (gen-expression (first prefix)) (setf function-call? (append function-call? fun-call)) (setf type ty) exp) (IF (SECOND prefix) ;1; ++* (multiple-value-bind (exp nil fun-call) (gen-expression (second prefix)) (setf function-call? (append function-call? fun-call)) exp)) (if (third prefix) (multiple-value-bind (exp nil fun-call) (gen-expression (third prefix)) (setf function-call? (append function-call? fun-call)) exp)))) (values result (find-read-or-write-type type t) function-call?)) (t (multiple-value-bind (exp ty fun-call?) (gen-expression prefix) (values exp (find-read-or-write-type ty t) fun-call?)))) );1gen-write-parm 3(DEFUN GEN-RECORD-ACCESS (prefix &aux info field-type)** 2"generate a record access"* (multiple-value-bind (rec rec-type function-call?) (gen-variable-access (arg1 prefix)) (setf info (lookup-symtab rec-type)) (if (or (null info) (not (typep info 'symtab-record-type))) (error-handler 'gen-record-access "undefined variable (~A) or attempting to find a record field (~A) ~ ~%in a non record variable on line number ~D." (arg1 (arg1 prefix)) (arg1 (arg2 prefix)) (op-line-no (oper prefix)))) (if (not (setf field-type (in-field-list (arg1 (arg2 prefix)) (record-fields info)))) (error-handler 'gen-record-access "illegal record field (~A) in record variable" (arg2 prefix))) (values (list (add-comment-to-lisp-struct (make-lisp-struct-from-op (record-accessor info (arg1 (arg2 prefix))) (oper prefix)) nil 'major ;1;++mega-hack (but, hey, if it works?)* ; (car (op-comment (oper (arg2 prefix)))) ; (cadr (op-comment (oper (arg2 prefix)))) ) rec) field-type function-call?) );1multiple-value-bind* );1gen-record-access 3(DEFUN IN-FIELD-LIST (field-id field-list)** 2"returns the type of FIELD-ID if it is in FIELD-LIST"* (cond ((cdr (assoc field-id (fixed-fields field-list) :test #'(lambda (item list) (member item list :test #'equal))))) ((eq field-id (car (symtab-tag-field field-list))) (cdr (symtab-tag-field field-list))) ((not (null (variant-fields field-list))) (loop for fie-l in (variant-fields field-list) for fie-ty = (and (cdr fie-l) (in-field-list field-id (cdr fie-l))) until fie-ty finally (return fie-ty))) (t nil)) );1in-field-list 3(DEFUN GEN-RECORD-TYPE (id prefix info &optional (packed nil))** 2"generate a record type[if PACKED is non-NIL this is a packed type]"* (cond ((not (eq (op-name (oper prefix)) '*record-type*)) (error-handler 'gen-record-type "expected a *RECORD-TYPE* at the beginning of"))) (cond ((not (do-not-need-array info)) (grind-to-lisp-stream (list* (make-lisp-struct-from-op 'defstruct (oper prefix)) (append (list (make-lisp-struct-from-op (access-form info) (oper id)) (list :constructor (init-function info)) (list :conc-name (field-accessor-prefix info))) (if (not packed) (list :named)) nil) (pack-fields (gen-field-list (arg1 prefix) (record-fields info) packed))))) (t (setf (assign-function info) set-op) (grind-to-lisp-stream (list (make-lisp-struct-from-op 'defmacro (oper prefix)) (init-function info) nil (list 'quote (list (make-print-identifier :name '*init-numeric* :package 'pascalx))))) (gen-word-record (make-lisp-struct-from-op (access-form info) (oper id)) (field-accessor-prefix info) (arg1 prefix) (record-fields info)))) 1 *);1gen-record-type 3(DEFUN GEN-WORD-RECORD (name acc-prefix prefix field-list &optional (total-bits 0))** (setf total-bits (gen-word-field (first prefix) name acc-prefix (fixed-fields field-list) total-bits)) (setf prefix (second prefix)) (cond ((and (not (null prefix)) (eq (op-name (oper prefix)) '*variant-part*)) 1 ;; generate the variant selector part.* (if (consp (first (arg1 prefix))) (setf total-bits (gen-word-field (first (arg1 prefix)) name acc-prefix (list (symtab-tag-field field-list)) total-bits))) (mapc #'(lambda (pre) (gen-word-record name acc-prefix (second pre) (cdr (assoc (arg1 (first (first pre))) (variant-fields field-list) :test #'(lambda (item list) (member item list :test #'equal)))) total-bits)) (arg2 prefix)))) );1gen-word-record 3(DEFUN GEN-WORD-FIELD (prefix name field-name-prefix list-of-fields start-bits)** (loop with total-bits = start-bits for rec-sect in prefix for field-type = (second rec-sect) and (nil . type-id) in list-of-fields for type-info = (lookup-symtab type-id) for num-of-bits = (cond ((typep type-info 'symtab-record-type) (do-not-need-array type-info)) ((typep type-info 'symtab-subrange-type) (get-bit-size-of-subrange type-info)) (t 32)) when (> (+ total-bits num-of-bits) 32) do (error-handler 'gen-word-field "To big a field for a word (shouldn't be hare)") do (mapc #'(lambda (field-id) (COND ((< num-of-bits 32) (grind-to-lisp-stream (list 'defmacro (make-lisp-struct-from-op (intern (concatenate 'string (string field-name-prefix) (STRING (arg1 field-id))) *output-package* ) (oper field-id)) (list name) `(list 'ldb '(byte ,num-of-bits ,total-bits) ,name)))) (t (grind-to-lisp-stream `(defmacro ,(make-lisp-struct-from-op (intern (concat 'string (string field-name-prefix) (STRING (arg1 field-id))) *output-package* ) (oper field-id)) (,name) ,(COND ((TYPEP type-info 'primitive-type) (CASe (required-type type-info) (:integer `(list 'FIX ,name)) (:real `(list 'FLOAT ,name)) (:CHAR `(list 'CHARACTER ,name)) ;1??* (otherwise ;1; ++ Should never* ;1; do this* name))) (t ;1;?* `(list 'FIX ,name))))))) (incf total-bits num-of-bits)) (first rec-sect)) finally (return total-bits) );1loop* );1gen-word-field 3(DEFUN GEN-REPETITIVE-STATEMENT (prefix)** 2"generate all the repeat statements"* (case (op-name (oper prefix)) (*repeat-statement* (gen-repeat-statement prefix)) (*while-statement* (gen-while-statement prefix)) ((*for-to-statement* *for-downto-statement*) (gen-for-statement prefix)) (otherwise (error-handler 'gen-repetitive-statement "illegal type of repetitive statement ~A in" (op-name (oper prefix)))) );1case* );1gen-repetitive-statement 3(DEFUN GEN-REPEAT-STATEMENT (prefix &aux stmt-list any-labs)** (if (not (eq (op-name (oper prefix)) '*repeat-statement*)) (error-handler 'gen-repetitive-statement "illegal type of repetitive statement ~A in" (op-name (oper prefix)))) (multiple-value-bind (bool-exp funcall?) (gen-boolean-expression (arg2 prefix)) (setf stmt-list (mapcan #'(lambda (pre) (multiple-value-bind (lab stmt) (gen-statement pre) (cond (lab (setf any-labs t) (list lab stmt)) (t (list stmt))))) (arg1 prefix))) (gen-catch-if-necessary funcall? (list loop-op do-op (cond (any-labs (cons 'tagbody stmt-list)) (t (cons 'progn stmt-list))) 'until bool-exp))) );1gen-repeat-statement 3(DEFUN GEN-STATEMENT (prefix &aux lab lab-info)** 2"generate the appropriate statement"* (cond ((not (null (first prefix))) (setf lab (make-lisp-struct-from-op (access-form (setf lab-info (lookup-symtab (arg1 (first prefix))))) (oper (first prefix)))))) (values lab (case (op-name (oper (second prefix))) (*compound-statement* (gen-compound-statement (second prefix))) ((*if-statement* *case-statement*) (gen-conditional-statement (second prefix))) ((*repeat-statement* *while-statement* *for-to-statement* *for-downto-statement*) (gen-repetitive-statement (second prefix))) (*with-statement* (gen-with-statement (second prefix))) (*procedure-call* (gen-procedure-statement (second prefix))) (*assignment-statement* (gen-assignment-statement (second prefix))) (*goto-statement* (gen-goto-statement (second prefix))) (*empty-statement* (make-lisp-struct-from-op '*comment* (oper (second prefix)))) (otherwise (error-handler 'gen-statement "illegal statement type (~A) in" (op-name (oper (second prefix))))) );1case* )1;values* );1gen-statement ;;; VAR-LIST is a list of varables and initializations of the ;;; variables, to be put as the variable list of the prog. if FUN is non NIL, then this ;;; is a the body of a function, and the first list in VAR-LIST is the function identifier ;;; and it's initalization form. The identifier is returned as the value of the prog. 3(DEFUN GEN-STATEMENT-PART (prefix &optional (var-list nil) (fun nil) &aux stmts)** 2"Generate the statement part"* (setf stmts (gen-compound-statement prefix t)) (setf (second stmts) var-list) (append stmts (if fun `(,(car (first var-list))) nil)) );1gen-statement-part 3(DEFUN GEN-TYPE-DEFINITIONS (prefix)** 2"Generate type definitions if any"* (cond ((not (null prefix)) (if (not (eq (op-name (oper prefix)) '*type-define*)) (error-handler 'gen-type-definitions "expected *TYPE-DEFINE* in")) (mapcar #'(lambda (ty) (gen-type-denoter (first ty) (second ty))) (arg1 prefix))) (t nil)) );1gen-type-definitions 3(DEFUN GEN-TYPE-DENOTER (id prefix &optional (packed? nil) &aux info)** 2"generate the type denoter [If ID is NIL this is an anonymous type.]"* (cond ((eq (op-name (oper prefix)) '*identifier*) 1;; if this is not an anonymous type we need to enter information* 1;; in the symbol table and print that this is the same as the type it is defined as* 1;; otherwise just return the identifier.* (cond ((not (null id)) (prog1 (pascal-id (setf info (enter-new-type id prefix))) (princ "(COMMENT the type " *LISP-STREAM*) (prin1 (make-lisp-struct-from-op (access-form info) (oper id)) *LISP-STREAM*) (princ " is the same as type " *LISP-STREAM*) (prin1 (make-lisp-struct-from-op (access-form (lookup-symtab (arg1 prefix))) (oper prefix)) *LISP-STREAM*) (tyo #\) *LISP-STREAM*) (terpri *LISP-STREAM*) (terpri *LISP-STREAM*))) (t (pascal-id (lookup-symtab (arg1 prefix)))))) (t (setf id (or id (get-new-anon-id))) (gen-new-type id prefix (setf info (enter-new-type id prefix)) packed?) (pascal-id info))) 1 *);1gen-type-denoter ;;; GEN-VARIABLE-ACCESS returns three values, the first is the code to generate ;;; the access, the second is the type of the variable access, the third value ;;; is T if there is an expression inside the access that calls a ;;; (non predefined) function. The type is one of INTEGER, REAL, CHAR, :STRING ;;; or another type identifier. For subrange types either CHAR or INTEGER ;;; or a enumerated type identifier is returned. 3(DEFUN GEN-VARIABLE-ACCESS (prefix &aux info type ty-info acc)** 2"generate variable accesses, or other access to identifiers"* (case (op-name (oper prefix)) (*array-accessor* (gen-array-access prefix)) (*record-accessor* (gen-record-access prefix)) (*pointer-accessor* (gen-pointer-access prefix)) (*identifier* (setf info (lookup-symtab (arg1 prefix))) (if (null info) (error-handler 'gen-variable-access "undefined variable (~A) in" (arg1 prefix))) 1;; make accessor a special accessor for different kinds of types, right* 1;; now only type CHAR has a special access functions* (if (typep info 'var) (make-symbol-special info)) 1; mark this variable as special if necessary* (setf type (cond ((typep info 'var) (if (typep (setf ty-info (lookup-symtab (var-type info))) 'symtab-subrange-type) (host-type ty-info) (pascal-id ty-info))) ((typep info 'const) (cond ((part-of-type info)) ((integerp (value info)) 'integer) ((floatp (value info)) 'real) ((stringp (value info)) 'string))) ((typep info 'function) (if (typep (setf ty-info (lookup-symtab (returns info))) 'symtab-subrange-type) (host-type ty-info) (pascal-id ty-info))))) (setf acc (make-lisp-struct-from-op (access-form info) (oper prefix))) (values (if (typep info 'var) (gen-special-access-if-necessary acc info) acc) type nil))) );1gen-varialbe-access ;;; Only does something for variable parameters. ;;; For variable parameters wraps a *VAR-PARM-REF* around ACC. 3(DEFUN GEN-SPECIAL-ACCESS-IF-NECESSARY (acc info &aux (new-acc acc))** (if (eq (parameter info) 'var) (setf new-acc (list var-parm-ref-op new-acc))) new-acc) 1;;; returns the list of variables with their initializations, if we are at ;;; level 0, and the variable is a record or array variable, then a ;;; DEFVAR is created and nothing returned. 3(DEFUN GEN-VARIABLE-DECLARATIONS (prefix)** 2"Generate variable declarations if any"* (cond ((not (null prefix)) (if (not (eq (op-name (oper prefix)) '*variable-declare*)) (error-handler 'gen-variable-declarations "expected *VARIABLE-DECLARE* in")) (mapcan #'(lambda (var-decl) (loop for var in (first var-decl) for info = (lookup-symtab (arg1 var)) for type-info = (lookup-symtab (var-type info)) when (/= *CURRENT-LEVEL* 0) collect (list (make-lisp-struct-from-op (access-form info) (oper var)) ; (get-init-form ; type-info)) (get-init-form (var-type info))) else do (cond ((or (not (typep type-info 'symtab-file-type)) (not (member (arg1 var) (prog-parms (lookup-symtab (car (last *CURRENT-DEFINITION-STACK*))))))) (WHEN *gen-closure-p* (PUSH var *closure-variables*)) (grind-to-lisp-stream (list 'defvar (make-lisp-struct-from-op (access-form info) (oper var)) ;1; ++* ;1;* ;1; type-info=>* (var-type info)1 *7/07/86 16:14:13 (get-init-form (var-type info)))))))) (arg1 prefix))) (t nil)) );1gen-variable-declarations 3(DEFUN GEN-VARIANT-PART (prefix field-list &optional (packed? nil))** 2"generate a variant part if there is one and return the list of fields and their init-forms."* (cond ((and (not (null prefix)) (eq (op-name (oper prefix)) '*variant-part*)) 1;; generate the variant selector part.* (cons (if (consp (first (arg1 prefix))) (list (make-lisp-struct-from-op (car (symtab-tag-field field-list)) (oper (first (arg1 prefix)))) (make-lisp-struct-from-op (list (init-function (lookup-symtab (cdr (symtab-tag-field field-list))))) (oper (first (arg1 prefix))))) (make-lisp-struct '*comment* "" nil)) 1;; generate the variant parts* (mapcan #'(lambda (pre) (gen-field-list (second pre) (cdr (assoc (arg1 (first (first pre))) (variant-fields field-list) :test #'(lambda (item list) (member item list :test #'equal)))) packed?)) (arg2 prefix)))) (t nil)) );1gen-variant-part 3(DEFUN GEN-WHILE-STATEMENT (prefix)** (if (not (eq (op-name (oper prefix)) '*while-statement*)) (error-handler 'gen-while-statement "illegal type of repetitive statement ~A in" (op-name (oper prefix)))) (multiple-value-bind (bool-exp funcall?) (gen-boolean-expression (arg1 prefix)) (gen-catch-if-necessary funcall? (list loop-op while-op bool-exp do-op (multiple-value-bind (lab stmt) (gen-statement (arg2 prefix)) (if lab (list 'tagbody lab stmt) stmt))))) );1gen-while-statement 3(DEFUN GEN-WITH-STATEMENT (prefix &aux info function-call?)** 2"generate a with statement, enter the record variables' field lists in the symbol table."* (cond ((not (eq (op-name (oper prefix)) '*with-statement*)) (error-handler 'with-statement "a *WITH-STATEMENT* is missing in"))) (mark-symtab nil nil) 1; create a new pseudo level* (MAPC #'(lambda (x) (setf info (lookup-symtab (find-type-of-var-access x))) (loop for (field-ids . field-type) in (get-field-name-list (record-fields info)) do (multiple-value-bind (var-acc var-type funcall?) (gen-variable-access x) (if (not (eq (typep (lookup-symtab var-type)) 'symtab-record-type)) (error-handler 'gen-with-statement "trying to use a3 *non-record variable in a with record variable list")) (MAPC #'(lambda (field-id) (insert-symtab field-id :var field-type :with-variable-form (list (record-accessor info field-id) var-acc))) field-ids) (setf function-call? (or function-call? funcall?))))) (arg1 prefix)) (prog1 (multiple-value-bind (lab stmt) (gen-statement (arg2 prefix)) (if lab (list 'tagbody lab stmt) stmt)) (free-symtab nil) 1; get rid of pseudo level* ) );1gen-with-statement