compiler.lisp 75 KB
Newer Older
1
;;;; -*- mode:lisp; coding:utf-8 -*-
2 3 4 5 6 7
;;;;****************************************************************************
;;;;FILE:               compiler.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
8
;;;;
9
;;;;    The LSE line compiler.
10
;;;;
11 12 13
;;;;AUTHORS
;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
14
;;;;    2012-02-19 <PJB> Implemented the expression unparser.
15 16 17
;;;;    2005-08-25 <PJB> Created.
;;;;BUGS
;;;;    LIRE must take into account the type of the variable.
18
;;;;    NON est une extension; voir comment le rendre optionel.
19
;;;;LEGAL
20
;;;;    AGPL3
21
;;;;
22
;;;;    Copyright Pascal Bourguignon 2005 - 2014
23
;;;;
24 25 26 27
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 of the License, or
;;;;    (at your option) any later version.
28
;;;;
29 30 31 32
;;;;    This program is distributed in the hope that it will be useful,
;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;    GNU Affero General Public License for more details.
33
;;;;
34
;;;;    You should have received a copy of the GNU Affero General Public License
35
;;;;    along with this program.  If not, see http://www.gnu.org/licenses/
36
;;;;****************************************************************************
37 38 39
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf *readtable* (copy-readtable nil)))
(in-package "COM.INFORMATIMAGO.LSE")
40
;;----------------------------------------------------------------------
41
(enable-byte-code-reader-macro)
42 43


44
;; The compiler module provides three features:
45
;;
46 47 48 49
;; 1- unparse the syntactic tree produced by the parser into a LSE source
;;    text.  This is used by the DECODE command.  We could as well use
;;    the original source text, but this allows us to produce a nicely
;;    formated (ie. without extraneous spaces or parentheses) code.
50
;;
51
;;    UNPARSE-SLIST
52
;;
53 54
;; 2- compiles the LSE source code to byte-code vectors.
;;    The scanner and parser are provided by lse-scanner.lisp
55 56
;;    and lse-parser.lisp.
;;
57
;;    GENERATE-EXPRESSION
58
;;    GENERATE-STATEMENT
59
;;
60 61 62 63
;;    COMPILE-LSE-LINE-PARSE-TREE
;;    COMPILE-LSE-LINE
;;    COMPILE-LSE-STREAM
;;    COMPILE-LSE-FILE
64
;;
65
;;    DECOMPILE-LSE-LINE
66
;;
67 68 69
;;    We don't decompile the byte-code, so that we may implement
;;    "optimizations".  Already,  the code generated for AFFICHER would
;;    produce sometimes a different source if decompiled.
70
;;
71 72
;; 3- disassemble the byte-code vectors.  This is used for debugging and
;;    pedagogical purposes.
73
;;
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
;;    DISASSEMBLE-LSE
;;
;;
;; Note: for now, the byte-code vectors also contain identifiers
;;       (symbols) and strings.  Since identifiers are limited to
;;       [A-Z][A-Z0-9]{0,4}, (with possibly a '&'  prefix for
;;       procedure identifiers),  they could be encoded as a 27-bit
;;       integer easily serialized as 4 bytes.  Strings could be
;;       serialized as a 2-byte length followed by UTF-8 codes.   But
;;       since the virtual machine is written in lisp, we really don't
;;       need to do that. (We could also use symbols instead of byte
;;       codes, see byte-code.lisp).
;;



;;;---------------------------------------------------------------------
;;; 1- Unparser
;;;---------------------------------------------------------------------

(defmacro dolist/separator ((var list separator) &body body)
  (let ((vsep (gensym))
        (esep (gensym)))
    `(loop
       :with ,esep = ,separator
       :for ,var :in ,list
       :for ,vsep = "" :then ,esep
       :do (princ ,vsep) (locally ,@body))))



;; (:plus (:fois (:vref a) (:vref a))
;;        (:fois (:vref b) (:vref b)))
;; a*a+b*b

;; (:fois (:plus (:vref a) (:vref a))
;;        (:plus (:vref b) (:vref b)))
;; (a+a)*(b+b)

;; Two signs cannot be adjacent: a*-b must be written a*(-b)

;; for (op1 (op2 … …) …)
;;
;; if (<= (operator-priority op1) (operator-priority op2))
;; then no need for parentheses  … op2 … op1 … == (… op2 …) op1 …
;;
;; if (> (operator-priority op1) (operator-priority op2))
;; then we need parentheses  (… op2 …) op1 …
;;                 otherwise  … op2 … op1 … == … op2 (… op1 …)


(defparameter *priority-levels*
  '((:ou)
    (:et)
    (:non)
    (:eg :ne :lt :le :gt :ge)
    (:moins :plus :concat)
    (:neg)
    (:divise :fois)
    (:puissance)
    (:xi :fonction :vval :vref :aval :aref)))

(defun operator-priority (operator)
  (position operator *priority-levels*
            :test (function member)))




;; a+b+c
;; (:plus a (:plus b c))

;; a-b-c
;; (:moins (:moins a b) c)

;; a-(b-c)
;; (:moins a (:moins b c))

;; a/b/c
;; (:divise (:divise a b) c)

;; a/(b/c)
;; (:divise a (:divise b c))


;; (disjonction (conjonction { :OU conjonction }))
;; (conjonction (condition   { :ET condition }))
;; (condition   (:NON condition)
;;              (expression (:EG :NE :LT :LE :GT :GE) expression))
;; (expression  (:neg expression)
;;              (terme   { (:moins :plus :concat) terme))
;; (terme       (facteur { (:fois :divise) facteur))
;; (facteur     (simple  { :puissance simple }))
;; (simple      (:xi disjonction expression expression)
;;              (:fonction procident (liste-arguments))
;;              (:VVAL procident)
;;              ( \( disjonction \) )
;;              (:vref identifier)
;;              (:vval identifier)
;;              (:aref identifier expression [expression])
;;              (:aval identifier expression [expression])
;;              chaine
;;              nombre
;;              numero)


(defun unparse-expression (expr)
  (macrolet ((with-parens ((op1 op2) item)
               (let ((vitem (gensym))
                     (vop1  (gensym))
                     (vop2  (gensym)))
                 `(let ((,vop1 ,op1)
                        (,vop2 ,op2)
                        (,vitem ,item))
                    (if (or (atom ,vitem)
                            (atom ,vop2)
                            (<= (operator-priority (first ,vop1))
                                (operator-priority (first ,vop2))))
                        (unparse-expression ,vitem)
                        (progn
                          (princ "(")
                          (unparse-expression ,vitem)
                          (princ ")")))))))
   (etypecase expr
     ((or integer nombre symbol)
      (princ expr))
     (token
      (ecase (token-kind expr)
        (tok-identificateur (princ (identificateur-nom expr)))
        (tok-procident      (princ (identificateur-nom expr)))
204
        (tok-litchaine      (princ (token-text expr)))
205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230
        (tok-nombre         (princ (nombre-valeur expr)))
        (tok-numero         (princ (numero-valeur expr)))))
     (cons
      (ecase (first expr)

        ((:neg) (princ "-")    (with-parens (expr (second expr))
                                 (second expr)))

        ((:non) (princ "NON ") (with-parens (expr (second expr))
                                 (second expr)))

        ((:moins :divise)
         (if (or (atom (second expr))
                 (eql (first expr) (first (second expr))))
             (unparse-expression (second expr))
             (with-parens (expr (second expr))
               (second expr)))
         (princ (case (first expr)
                  (:moins  "-")
                  (:divise "/")))
         (if (and (consp (third expr))
                  (eql (first expr) (first (third expr))))
             (progn
               (princ "(") (unparse-expression (third expr)) (princ ")"))
             (with-parens (expr (third expr))
               (third expr))))
231

232
        ((:plus :concat
233 234
                :fois
                :puissance
235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301
                :lt :le :gt :ge :eg :ne)
         (with-parens (expr (second expr))
           (second expr))
         (princ (case (first expr)
                  (:plus  "+")
                  (:fois  "*")
                  (:puissance "^")
                  (:concat "!")
                  (:lt "<")
                  (:le "<=")
                  (:gt ">")
                  (:ge ">=")
                  (:eg "=")
                  (:ne "#")))
         (with-parens (expr (third expr))
           (third expr)))

        (:xi
         (princ "SI ")
         (unparse-expression (second expr))
         (princ " ALORS ")
         (unparse-expression (third expr))
         (princ " SINON ")
         (unparse-expression (fourth expr)))

        ((:ou :et)
         (dolist/separator (item (rest expr) (case (first expr)
                                               (:ou " OU ")
                                               (:et " ET ")))
           (with-parens (expr item)
             item)))

        ((:adecl :aval :aref)
         (princ (identificateur-nom (second expr)))
         (princ "[")
         (unparse-expression (third expr))
         (when (cdddr expr)
           (princ ",")
           (unparse-expression (fourth expr)))
         (princ "]"))

        ((:vval :vref)
         (princ (identificateur-nom (second expr))))

        ((:fonction :appel)
         (princ (identificateur-nom (second expr)))
         (princ "(")
         (dolist/separator (item (cddr expr) ",")
           (unparse-expression item))
         (princ ")")))))))


(defun unparse-tree (expr)
  (macrolet ((with-parens (item)
               (let ((vitem (gensym)))
                 `(let ((,vitem ,item))
                    (if (atom ,vitem)
                        (unparse-tree ,vitem)
                        (progn
                          (princ "(")
                          (unparse-tree ,vitem)
                          (princ ")")))))))
    (etypecase expr
      ((or integer nombre symbol)
       (princ expr))
      (token
       (ecase (token-kind expr)
302
         (tok-litchaine      (princ (token-text expr)))
303 304 305 306 307 308 309 310 311 312 313 314 315 316
         (tok-identificateur (princ (identificateur-nom expr)))
         (tok-nombre         (princ (nombre-valeur expr)))
         (tok-numero         (princ (numero-valeur expr)))
         (tok-commentaire    (princ (token-text expr)))))
      (cons
       (ecase (first expr)
         ((:neg :non
                :moins :plus :fois :divise :puissance :concat
                :lt :le :gt :ge :eg :ne
                :xi :ou :et
                :adecl :aval :aref
                :vval :vref
                :fonction :appel)
          (unparse-expression expr))
317

318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336
         ((:commentaire :terminer :pause :aller-en :retour :retour-en :resultat
                        :liberer :chaine :tableau
                        :lire :garer :charger :supprimer :executer)
          (princ (case (first expr)
                   (:commentaire "")
                   (:terminer   "TERMINER")
                   (:pause      "PAUSE")
                   (:aller-en   "ALLER EN ")
                   (:resultat   "RESULTAT ")
                   (:retour-en  "RETOUR EN ")
                   (:retour     "RETOUR")
                   (:liberer    "LIBERER ")
                   (:chaine     "CHAINE ")
                   (:tableau    "TABLEAU ")
                   (:lire       "LIRE ")
                   (:garer      "GARER ")
                   (:charger    "CHARGER ")
                   (:supprimer  "SUPPRIMER ")
                   (:executer   "EXECUTER ")))
337 338 339 340 341
          (dolist/separator (item (if (and (eq  (first expr) :charger)
                                           (null (first (last expr))))
                                      (butlast (rest expr))
                                      (rest expr))
                                ",")
342
            (unparse-tree item)))
343

344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381
         (:decl-procedure
          (princ "PROCEDURE ")
          (princ (identificateur-nom (second expr)))
          (princ "(")
          (dolist/separator (item (third expr) ",")
            (unparse-tree item))
          (princ ")")
          (when (fourth expr)
            (princ " LOCAL ")
            (dolist/separator (item (fourth expr) ",")
              (unparse-tree item))))

         (:affectation
          (unparse-expression (second expr))
          (princ "_")
          (unparse-expression (third expr)))

         (:afficher
          (if (second expr)
              (progn (princ "AFFICHER[")
                     (dolist/separator (item (second expr) ",")
                       (ecase (first (second item))
                         (:rep-1     )
                         (:rep       (princ (numero-valeur (second (second item)))))
                         (:rep-var   (princ "*")))
                       (ecase (first item)
                         (:spec-chaine
                          (unparse-expression (third item)))
                         ((:spec-slash :spec-space :spec-cr :spec-nl)
                          (princ (case (first item)
                                   (:spec-slash "/")
                                   (:spec-space "X")
                                   (:spec-cr    "C")
                                   (:spec-nl    "L"))))
                         ((:spec-f :spec-e)
                          (princ (case (first item)
                                   (:spec-f "F")
                                   (:spec-e "E")))
382
                          (unparse-expression (third item))
383
                          (princ ".")
384
                          (unparse-expression  (fourth item)))
385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408
                         (:spec-u
                          (princ "U"))))
                     (princ "]"))
              (princ "AFFICHER "))
          (dolist/separator (item (cddr expr) ",")
            (unparse-expression item)))


         (:si
          (princ "SI ")
          (unparse-expression (second expr))
          (princ " ALORS ")
          (unparse-tree (third expr))
          (when (cdddr expr)
            (princ " SINON ")
            (unparse-tree (fourth expr))))

         ((:faire-jusqu-a :faire-tant-que) ;; lino ident init pas jusqua|tantque)
          (princ "FAIRE ")
          (unparse-expression (second expr))
          (princ " POUR ")
          (unparse-expression (third expr))
          (princ "_")
          (unparse-expression (fourth expr))
409 410 411 412 413 414 415
          (let ((pas (typecase (fifth expr)
                       (tok-numero (numero-valeur (fifth expr)))
                       (tok-nombre (nombre-valeur (fifth expr)))
                       (t          (fifth expr)))))
            (unless (and (numberp pas) (= 1 pas))
              (princ " PAS ")
              (unparse-expression (fifth expr))))
416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434
          (princ (case (first expr)
                   (:faire-jusqu-a  " JUSQUA ")
                   (:faire-tant-que " TANT QUE ")))
          (unparse-expression (sixth expr)))

         (:debut
          (loop
            :for item :in (cddr expr)
            :initially (princ "DEBUT ") (unparse-tree (second expr))
            :do (princ ";") (unparse-tree item)
            :finally (princ " FIN"))))))))


(defun unparse-slist (parse-tree)
  (with-output-to-string (*standard-output*)
    (with-standard-io-syntax
      (cond
        ((null parse-tree))              ; nothing to do
        ((atom parse-tree)
435
         (lse-error "INTERNE: UN ATOME ~S DANS L'ARBRE SYNTAXIQUE." parse-tree))
436 437 438 439 440 441 442 443 444 445 446
        ((eq (car parse-tree) :liste-instructions)
         (dolist/separator (item (cdr parse-tree) ";")
           (unparse-tree item)))
        ((eq (car parse-tree) :ligne-programme)
         (princ (numero-valeur (cadr parse-tree)))
         (unless (and (listp (caddr parse-tree))
                      (eql ':commentaire (caaddr parse-tree)))
           (princ " "))
         (dolist/separator (item (cddr parse-tree) ";")
           (unparse-tree item)))
        (t
447
         (lse-error "INTERNE: UNE LISTE INVALIDE ~S DANS L'ARBRE SYNTAXIQUE." parse-tree))))))
448 449 450 451 452 453 454 455



;;;---------------------------------------------------------------------
;;; 2- Compiler, byte-code generator.
;;;---------------------------------------------------------------------


456 457 458 459 460 461 462 463 464 465 466 467
(defun cons-position (cons list &key (start 0) (end nil))
  "
RETURN: The index in list of the cons cell CONS.
POST:   (and (cons-position c l) (eq c (nthcdr (cons-position c l) l)))
"
  (when (minusp start) (setf start 0))
  (when (and end (minusp end)) (setf end 0))
  (let ((current (nthcdr start list)))
    (loop (cond ((eq current cons)
                 (return-from cons-position start))
                ((or (and end (<= end start))
                     (null (cdr current)))
468
                 (return-from cons-position nil))
469 470 471
                (t
                 (incf start)
                 (setf current (cdr current)))))))
472 473 474



475 476 477 478 479 480 481 482 483 484 485 486
;; (defun gen (&rest items)
;;   (cond
;;     ((null (cdr items))
;;      (car items))
;;     ((or (numberp (car items))
;;          (stringp (car items))
;;          (and (symbolp (car items))
;;               (or (eq (symbol-package (car items)) (find-package "BC"))
;;                   (eq (symbol-package (car items)) (find-package "ID")))))
;;      (cons (car items) (apply (function gen) (cdr items))))
;;     (t
;;      (generate-statement (car items) (apply (function gen) (cdr items))))))
487 488 489
;;
;;
;;
490 491 492 493 494 495
;; (defun generate-statement (stat next)
;;   (etypecase stat
;;     ((or integer nombre symbol)
;;      (cons stat next))
;;     (token
;;      (ecase (token-kind stat)
496
;;        (tok-litchaine      (gen !pushi (chaine-valeur stat) next))
497 498 499 500 501 502
;;        (tok-nombre         (gen !pushi (nombre-valeur stat) next))
;;        (tok-numero         (gen !pushi (numero-valeur stat) next))
;;        (tok-identificateur (gen (identificateur-nom stat) next))
;;        (tok-commentaire    (gen !comment (token-text stat) next))))
;;     (cons
;;      (ecase (first stat)
503
;;
504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537
;;        ((:neg :non)
;;         (gen (second stat) (case (first stat)
;;                              (:neg !neg)
;;                              (:non !non)) next))
;;        ((:moins :plus :fois :divise :puissance :concat
;;                 :lt :le :gt :ge :eg :ne)
;;         (gen (second stat) (third stat)
;;              (case (first stat)
;;                (:moins !sub)
;;                (:plus  !add)
;;                (:fois  !mul)
;;                (:divise !div)
;;                (:puissance !pow)
;;                (:concat !concat)
;;                (:lt !lt)
;;                (:le !le)
;;                (:gt !gt)
;;                (:ge !ge)
;;                (:eg !eg)
;;                (:ne !ne)) next))
;;        (:xi
;;         (let* ((else (gen (fourth stat) next))
;;                (offset.e (cons-position next else))
;;                (then (gen (third stat) !balways  offset.e else))
;;                (offset.t (cons-position else then)))
;;           (gen (second stat) !bfalse offset.t then)))
;;        ((:ou :et)
;;         (loop
;;            :with suite = next
;;            :for item :in (reverse (cddr stat))
;;            :do (setf suite (gen item (case (first stat)
;;                                        (:ou !ou)
;;                                        (:et !et)) suite))
;;            :finally (return (gen (second stat) suite))))
538
;;
539 540
;;        (:commentaire
;;         (gen (second stat) next))
541
;;
542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561
;;        ((:liberer :chaine)
;;         (loop
;;            :with suite = next
;;            :for item :in (reverse (rest stat))
;;            :do (setf suite (gen (case (first stat)
;;                                   (:liberer !liberer)
;;                                   (:chaine  !chaine))
;;                                 (identificateur-nom item) suite))
;;            :finally (return suite)))
;;        (:tableau
;;         (loop
;;            :for item :in (reverse (rest stat))
;;            :do (setf next (generate-statement item next))
;;            :finally (return next)))
;;        (:adecl
;;         (if (null (cdddr stat))
;;             (gen (third stat) !tableau1
;;                  (identificateur-nom (second stat)) next)
;;             (gen (third stat) (fourth stat) !tableau2
;;                  (identificateur-nom (second stat)) next)))
562
;;
563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579
;;        ((:aval :aref)
;;         (if (null (cdddr stat))
;;             (gen (third stat)
;;                  (case (first stat)
;;                    (:aval !aref1&push-val)
;;                    (:aref !aref1&push-ref))
;;                  (identificateur-nom (second stat)) next)
;;             (gen (third stat) (fourth stat)
;;                  (case (first stat)
;;                    (:aval !aref2&push-val)
;;                    (:aref !aref2&push-ref))
;;                  (identificateur-nom (second stat)) next)))
;;        ((:vval :vref)
;;         (gen (case (first stat)
;;                (:vval !push-val)
;;                (:vref !push-ref))
;;              (identificateur-nom (second stat)) next))
580
;;
581 582 583 584 585 586 587
;;        ((:fonction :appel)
;;         (loop
;;            :with suite = (gen !call (identificateur-nom (second stat))
;;                               (length (cddr stat)) next)
;;            :for item :in (reverse (cddr stat))
;;            :do (setf suite (gen item suite))
;;            :finally (return suite)))
588 589
;;
;;
590 591 592 593 594 595 596 597
;;        ;; (:decl-procedure ident nil       nil)
;;        ;; (:decl-procedure ident (fpid...) nil)
;;        ;; (:decl-procedure ident nil       (locid...))
;;        ;; (:decl-procedure ident (fpid...) (locid...))
;;        ;; --> :trap-proc-reached *
;;        ;; ==> fpid inter locid == arguments par valeur  ==> copier
;;        ;; ==> fpid diff  locid == arguments par reference
;;        ;; ==> locid diff fpid  == variable locales --> table variable locale pour la proc.
598
;;
599 600 601 602
;;        ;; Parameters by reference
;;        ;; Parameters by value       = Local variables
;;        ;; Global Variables
;;        ;; Local Variables
603 604
;;
;;
605
;;     ;; - Appel de  PROCEDURE
606
;;     ;;
607 608 609 610
;;     ;;   We cannot generate vref or vval for parameters of PROCEDUREs
;;     ;;   before knowing what parameters are by reference and what are by
;;     ;;   value, therefore before having seen the PROCEDURE declaration in
;;     ;;   the source.
611
;;     ;;
612 613 614
;;     ;;   ⚠ Therefore we can generate the code only globally, just before we
;;     ;;     run the program.  Chaining or loading parts of the program while
;;     ;;     running means we need to recompile it.
615 616 617
;;
;;     ;;   OR we can generate vref all the time, and resolve the reference when it's used.
;;
618 619 620 621 622 623 624 625 626 627 628 629
;;        (:decl-procedure
;;         ;; Les procedures ne sont pas executable, !procedure generates an error.
;;         (destructuring-bind (decl name params locals) stat
;;           (make-procedure :name name
;;                           :parameters (mapcar (lambda (param)
;;                                                 (if (member param locals)
;;                                                     `(:par-valeur    ,param)
;;                                                     `(:par-reference ,param)))
;;                                               params)
;;                           :local-variables (local-variables (set-difference locals params))
;;                           :line line
;;                           :offset ))
630
;;
631
;;         (gen !procedure next))
632
;;
633 634 635
;;        (:resultat   (gen (second stat) !result next))
;;        (:retour-en  (gen (second stat) !retour-en next))
;;        (:retour     (gen !retour next))
636
;;
637 638 639
;;        ;; :result             OR  :retour-en      OR   :retour
;;        ;; -------------------     ---------------     ------------
;;        ;; result    <-- :pop  OR  goto <-- :pop   OR   nothing
640
;;        ;;
641 642 643 644 645 646
;;        ;; return-pc <-- sf.return-pc
;;        ;; next-sf   <-- sf.next-sf
;;        ;; argcnt    <-- sf.argcnt
;;        ;; sf        <-- next-sf
;;        ;; :pop-sf
;;        ;; :pop-n argcnt
647
;;        ;;
648 649
;;        ;; :push  result              --                 --
;;        ;; pc <-- return-pc       OR  pc <-- goto     or pc <-- return-pc
650
;;
651 652 653 654 655 656 657 658 659 660 661 662 663
;;        (:affectation
;;         ;; (:vref ident) expression) --> expression :pop&store ident
;;         ;; (:aref ident expr) expression) --> expression expr :pop&astore1 ident
;;         ;; (:aref ident expr.1 expr.2) expression) --> expression expr.1 expr.2 :pop&astore2 ident
;;         (setf next (cons (identificateur-nom (second (second stat))) next))
;;         (case (length (second stat))
;;           (2  (gen (third stat)
;;                    !pop&store    next))
;;           (3  (gen (third stat) (third (second stat))
;;                    !pop&astore1  next))
;;           (4  (gen (third stat) (third (second stat))
;;                    (fourth (second stat))
;;                    !pop&astore2  next))))
664
;;
665 666 667 668 669 670
;;        (:lire
;;         ;; (:vref ident) --> :lire&store ident
;;         ;; (:aref ident expr) -->  expr :lire&astore1 ident
;;         ;; (:aref ident expr.1 expr.2) -->  expr.1 expr.2 :lire&astore2 ident
;;         (loop
;;            :for item :in (reverse (rest stat))
671
;;            :do (setf next
672 673 674 675 676 677 678 679
;;                      (case (length item)
;;                        (2  (gen !lire&store
;;                                 (identificateur-nom (second item)) next))
;;                        (3  (gen (third item) !lire&astore1
;;                                 (identificateur-nom (second item)) next))
;;                        (4  (gen (third item) (fourth item) !lire&astore2
;;                                 (identificateur-nom (second item)) next))))
;;            :finally (return (gen !beep next))))
680
;;
681 682 683 684 685
;;        (:rep-1     (gen !pushi 1 next))
;;        (:rep       (gen !pushi (numero-valeur (second stat)) next))
;;        (:rep-var   (gen !push-val 'id::$index !dup !pushi 1 !add
;;                         !pop&store 'id::$index !aref1&push-val 'id::$vals
;;                         next))
686 687
;;
;;
688 689 690 691
;;        ;; AFFICHER expr…
;;        ;; --> (:afficher nil expr…)
;;        ;;
;;        ;; AFFICHER [spec…] expr…
692 693
;;        ;; --> (:afficher (spec…) expr…)
;;
694 695 696 697
;;        ;; First, the expr… are evaluated and stored in a TABLEAU $VALS[number of expr…]
;;        ;; Then $INDEX is set to 1,
;;        ;; and finally the :afficher-* codops are generated.
;;        ;; Each :afficher-* operation should use $VALS[$INDEX] and up, incrementing $INDEX.
698
;;
699 700 701 702 703 704
;;        ;; ['litchaine']
;;        ;; --> spec ::= (:spec-chaine (:rep-1) litchaine)    ==> (rep litchaine :afficher-u)
;;        ;; [42'litchaine']
;;        ;; --> spec ::= (:spec-chaine (:rep 42) litchaine)   ==> (rep litchaine :afficher-u)
;;        ;; [*'litchaine']
;;        ;; --> spec ::= (:spec-chaine (:rep-var) litchaine)  ==> (rep litchaine :afficher-u)
705
;;
706 707 708 709 710 711
;;        ;; [/]
;;        ;; --> spec ::= (:spec-slash (:rep-1))      ==> (rep :afficher-newline)
;;        ;; [42/]
;;        ;; --> spec ::= (:spec-slash (:rep 42))     ==> (rep :afficher-newline)
;;        ;; [*/]
;;        ;; --> spec ::= (:spec-slash (:rep-var))    ==> (rep :afficher-newline)
712
;;
713 714 715
;;        ;; X --> :spec-space    ==> (rep :afficher-space)
;;        ;; C --> :spec-cr       ==> (rep :afficher-cr)
;;        ;; L --> :spec-nl       ==> (rep :afficher-nl)
716
;;
717 718 719 720
;;        ;; For the following specifiers, only fixed repeatitions are allowed: :rep-1 and (:rep n)
;;        ;; U --> :spec-u        ==> (rep :afficher-u)
;;        ;; Fe.d --> (:spec-f rep e d) ==> (rep e d :afficher-f)
;;        ;; Ee.d --> (:spec-d rep e d) ==> (rep e d :afficher-e)
721
;;
722 723
;;        ;; This rules means that the number of expressions processed is
;;        ;; known at compilation time.
724
;;
725 726 727 728 729 730 731 732 733 734 735 736
;;        ;; The format specifiers and the expressions are processed in
;;        ;; parallel, threfore the following program:
;;        ;;
;;        ;; 10 AFFICHER['(',U,')']&P(42)
;;        ;; 11 TERMINER
;;        ;; 100 PROCEDURE &P(X)
;;        ;; 101 AFFICHER['[',U,']']X
;;        ;; 102 RESULTAT X
;;        ;;
;;        ;; should print:
;;        ;;
;;        ;; ([42]42)
737
;;
738 739 740 741
;;        (:afficher
;;         ;; (:afficher nil expr...)      --> :pushi n expr... :afficher-u
;;         ;; (:afficher (form...) expr...)
;;         ;; (:afficher (form...))
742
;;
743 744 745 746 747 748 749 750
;;         ;; TODO: the $INDEX and $VALS variables should be "local"
;;         ;; (gen  !LIBERER 'ID::$VALS next)
;;         (let ((result '())
;;               (exprs (cddr stat)))
;;           (labels ((collect (code)
;;                      (setf result (nconc result (copy-list code))))
;;                    (spec-simple (spec format)
;;                      (if (atom spec)
751
;;                          (lse-error "SPECIFICATEUR DE FORMAT INVALIDE ~S" format)
752 753 754 755
;;                          (case (first spec)
;;                            (:rep-1   (collect (gen !pushi 1 nil)))
;;                            (:rep     (collect (gen !pushi (numero-valeur (second spec)) nil)))
;;                            (:rep-var (when (null exprs)
756
;;                                        (lse-error "IL MANQUE AU MOINS UNE EXPRESSION POUR LE SPECIFICATEUR DE FORMAT ~S" format))
757 758
;;                                      (collect (generate-statement (pop exprs) nil)))
;;                            (otherwise
759
;;                             (lse-error "SPECIFICATEUR DE FORMAT INVALIDE ~S" format)))))
760 761
;;                    (spec-expr (spec op format)
;;                      (if (atom spec)
762
;;                          (lse-error "SPECIFICATEUR DE FORMAT INVALIDE ~S" format)
763 764
;;                          (case (first spec)
;;                            (:rep-1 (when (null exprs)
765
;;                                      (lse-error "IL MANQUE AU MOINS UNE EXPRESSION POUR LE SPECIFICATEUR DE FORMAT ~S" format))
766 767 768 769 770 771
;;                                    (collect (generate-statement (pop exprs) nil))
;;                                    (collect op))
;;                            (:rep   (loop
;;                                      :repeat (numero-valeur (second spec))
;;                                      :do (progn
;;                                            (when (null exprs)
772
;;                                              (lse-error "IL MANQUE AU MOINS UNE EXPRESSION POUR LE SPECIFICATEUR DE FORMAT ~S" format))
773 774 775
;;                                            (collect (generate-statement (pop exprs) nil))
;;                                            (collect op))))
;;                            (otherwise
776
;;                             (lse-error "SPECIFICATEUR DE FORMAT INVALIDE ~S" format))))))
777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814
;;             (if (second stat)
;;                 (loop
;;                   :for format :in (second stat)
;;                   :do (ecase (first format)
;;                         (:spec-chaine
;;                          ;; (print stat)
;;                           ;; (print format)
;;                          (spec-simple (second format) format)
;;                          (collect (gen (third format) !afficher-chaine nil)))
;;                         ((:spec-slash :spec-space :spec-cr :spec-nl)
;;                          (spec-simple (second format) format)
;;                          (collect (gen (case (first format)
;;                                          (:spec-slash !afficher-newline)
;;                                          (:spec-space !afficher-space)
;;                                          (:spec-cr    !afficher-cr)
;;                                          (:spec-nl    !afficher-nl))
;;                                        nil)))
;;                         ((:spec-f :spec-e)
;;                          (spec-expr (second format) (gen (third format)
;;                                                          (fourth format)
;;                                                          (case (first format)
;;                                                            (:spec-f !afficher-f)
;;                                                            (:spec-e !afficher-e))
;;                                                          nil) format))
;;                         (:spec-u
;;                          (spec-expr (second format) (gen !afficher-u nil) format)))
;;                   :finally (loop
;;                              :for expr :in exprs
;;                              :do (collect (gen (generate-statement expr nil) !afficher-u nil))))
;;                 ;; (5) afficher[{n}u]expr...
;;                 (progn
;;                   (collect (gen !pushi 1 !afficher-newline nil))
;;                   (loop
;;                     :for expr :in (cddr stat)
;;                     :do (progn
;;                           (collect (generate-statement expr nil))
;;                           (collect (gen !afficher-u nil)))))))
;;           (nconc result next)))
815 816
;;
;;
817 818 819 820 821 822
;;        ;; (setf next (gen !pushi (length (cddr stat)) !pop&store 'id::$valscnt next))
;;        ;; (setf next (gen !pushi 1 !pop&store 'id::$index next))
;;        ;; (4) set $index to 1
;;        ;; to avoid too much stack usage, we evalute each expression
;;        ;; and store it into $vals in turn.
;;        ;; (3) pop one expression and store them in $vals[$index]
823
;;        ;; (2) push one expression
824 825
;;        ;; (loop
;;        ;;    :for expr :in (reverse (cddr stat))
826
;;        ;;    :for i :from (length (cddr stat)) :downto 1
827 828 829 830
;;        ;;    :do (setf next (gen  !pushi i !pop&astore1 'id::$vals next))
;;        ;;    :do (setf next (generate-statement expr next)))
;;        ;; (1) declare the tableau $vals[n]
;;        ;; (gen  !pushi (length (cddr stat)) !tableau1 'id::$vals next)
831 832 833 834
;;
;;
;;        ;; rep :affiche-u --
;;        ;;
835 836 837 838
;;        ;; @loop: dup pushi 0 eg btrue @end
;;        ;; dup pushi 1 add swap pushi 1 swap
;;        ;; aref1&push $vals :afficher-u branch @loop
;;        ;; @end: pop
839 840 841
;;
;;
;;
842 843
;;        (:aller-en (gen (second stat) !goto next))
;;        (:si
844
;;         ;;(:si test then)       --> test :bfalse offset.t then
845 846 847 848 849 850 851 852 853 854 855
;;         ;;(:si test then else)  --> test :bfalse offset.t then  :balways offset.e else
;;         (if (cdddr stat)
;;             ;; same as :xi
;;             (let* ((else (gen (fourth stat) next))
;;                    (offset.e (cons-position next else))
;;                    (then (gen (third stat) !balways  offset.e else))
;;                    (offset.t (cons-position else then)))
;;               (gen (second stat) !bfalse offset.t then))
;;             (let* ((then (gen (third stat) next))
;;                    (offset.t (cons-position next then)))
;;               (gen (second stat) !bfalse offset.t then))))
856
;;
857 858
;;        (:terminer (gen !terminer next))
;;        (:pause    (gen !pause    next))
859
;;
860 861 862 863
;;        (:faire-jusqu-a ;; lino ident init pas jusqua)
;;         ;; --> lino init pas jusqua :faire-jusqu-a ident
;;         (gen (second stat) (fourth stat) (fifth stat) (sixth stat)
;;              !faire-jusqu-a (third stat) next))
864
;;
865 866
;;        (:faire-tant-que ;; lino ident init pas test)
;;         ;; --> lino init pas :faire-tant-que ident test
867
;;         (gen (second stat) (fourth stat) (fifth stat)
868 869
;;              !faire-tant-que (third stat)
;;              (sixth stat) !tant-que next))
870
;;
871 872
;;        ;; ==> create a faire bloc. When we reach the end of each line, we must
;;        ;;     check for loop blocks available for this line. (kind of come from...).
873 874
;;
;;
875 876
;;        (:garer ;; var enr fic) --> enr fic :garer var
;;         (gen (third stat) (fourth stat) !garer (identificateur-nom (second stat)) next))
877
;;
878 879 880 881 882 883 884 885 886 887 888 889
;;        (:charger
;;         ;;(:charger  var enr fic)         --> enr fic :charger var nil
;;         ;;(:charger  var enr fic varstat) --> enr fic :charger var varstat
;;         (if (cddddr stat)
;;             (gen (third stat) (fourth stat) !charger
;;                  (identificateur-nom (second stat))
;;                  (identificateur-nom (fifth stat))
;;                  next)
;;             (gen (third stat) (fourth stat) !charger
;;                  (identificateur-nom (second stat))
;;                  nil
;;                  next)))
890
;;
891 892 893 894
;;        (:supprimer
;;         (if (third stat)
;;             (gen (second stat) (third stat) !supprimer-enregistrement next)
;;             (gen (second stat) !supprimer-fichier next)))
895
;;
896 897 898 899
;;        (:executer
;;         (if (third stat)
;;             (gen (second stat) (third stat)  !executer next)
;;             (gen (second stat) !pushi 1      !executer next)))
900
;;
901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929
;;        (:debut
;;         (loop
;;            :for i :in (reverse (cdr stat))
;;            :do (setf next (generate-statement i next))
;;            :finally (return next)))))))



(defstruct procedure
  name
  (parameters      '())
  (local-variables '())
  line
  (offset 1))

(defstruct code
  (line      0)
  (vector    (make-array 8 :adjustable t :fill-pointer 0))
  (procedure nil)
  (source    nil))

(defun code-offset (code)
  (fill-pointer (code-vector code)))

(defun gen-code (code code1 &rest codes)
  (dolist (item (cons code1 codes))
    (if (or (numberp item)
            (stringp item)
            (and (symbolp item)
930 931
                 (or (null item)
                     (eq (symbol-package item) (find-package "BC"))
932 933 934 935 936 937 938 939 940 941 942
                     (eq (symbol-package item) (find-package "ID")))))
        (vector-push-extend item
                            (code-vector code)
                            (length (code-vector code)))
        (error "Invalid code ~S" item))))



(defun generate-expression (code expression)
  (etypecase expression
    (null)
943
    ((or integer nombre symbol)
944
     (gen-code code expression))
945
    (token
946
     (ecase (token-kind expression)
947
       (tok-litchaine      (gen-code code !pushi (chaine-valeur expression)))
948 949 950 951 952
       (tok-nombre         (gen-code code !pushi (nombre-valeur expression)))
       (tok-numero         (gen-code code !pushi (numero-valeur expression)))
       (tok-identificateur (gen-code code (identificateur-nom expression)))
       (tok-commentaire    (gen-code code !comment (token-text expression)))))
    (atom (error "Unknown expression ~S" expression))
953
    (cons
954
     (case (first expression)
955 956

       ((:neg :non)
957 958 959 960
        (generate-expression code (second expression))
        (gen-code code (case (first expression)
                                (:neg !neg)
                                (:non !non))))
961 962
       ((:moins :plus :fois :divise :puissance :concat
                :lt :le :gt :ge :eg :ne)
963 964 965 966 967 968 969 970 971 972 973 974 975 976 977
        (generate-expression code (second expression))
        (generate-expression code (third  expression))
        (gen-code code (case (first expression)
                                (:moins !sub)
                                (:plus  !add)
                                (:fois  !mul)
                                (:divise !div)
                                (:puissance !pow)
                                (:concat !concat)
                                (:lt !lt)
                                (:le !le)
                                (:gt !gt)
                                (:ge !ge)
                                (:eg !eg)
                                (:ne !ne))))
978
       (:xi
979 980 981 982 983 984 985 986 987 988 989 990
        (generate-expression code (second expression))
        (gen-code code !bfalse)
        (let ((index.t (code-offset code)))
          (gen-code code 0)
          (generate-expression code (third expression))
          (gen-code code !balways)
          (let ((index.e (code-offset code)))
            (gen-code code 0)
            (generate-expression code (fourth expression))
            (let ((index.f (code-offset code)))
              (setf (aref (code-vector code) index.t) (- index.e index.t)
                    (aref (code-vector code) index.e) (- index.f index.e 1))))))
991

992
       ((:ou :et)
993 994 995 996 997 998 999 1000 1001
        (generate-expression code (second expression))
        (loop
          :with operator = (case (first expression)
                             (:ou !ou)
                             (:et !et))
          :for item :in (cddr expression)
          :do (progn
                (generate-expression code item)
                (gen-code code operator))))
1002

1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014
       ((:aval :aref)
        (if (null (cdddr expression))
            (progn
              (generate-expression code (third expression))
              (gen-code code
                        (case (first expression)
                          (:aval !aref1&push-val)
                          (:aref !aref1&push-ref))
                        (identificateur-nom (second expression))))
            (progn
              (generate-expression code (third  expression))
              (generate-expression code (fourth expression))
1015
              (gen-code code
1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026
                        (case (first expression)
                          (:aval !aref2&push-val)
                          (:aref !aref2&push-ref))
                        (identificateur-nom (second expression))))))
       ((:vval :vref)
        (gen-code code (case (first expression)
                                (:vval !push-val)
                                (:vref !push-ref))
                  (identificateur-nom (second expression))))

       ((:fonction)
1027
        (loop
1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044
          :for item :in (cddr expression)
          :do (generate-expression code item)
          :finally (gen-code code !callf
                             (identificateur-nom (second expression))
                             (length (cddr expression)))))

       (t
        (error "Unknown expression ~S" expression)))))
  code)


(defun generate-statement (code statement)
  (etypecase statement
    (null)
    (atom (error "Unknown statement ~S" statement))
    (cons
     (case (first statement)
1045

1046
       (:commentaire
1047
        (generate-expression code (second statement)))
1048

1049
       ((:liberer :chaine)
1050
        (loop
1051 1052 1053 1054 1055 1056
          :with operator = (case (first statement)
                             (:liberer !liberer)
                             (:chaine  !chaine))
          :for item :in (rest statement)
          :do (gen-code code operator (identificateur-nom item))))

1057 1058
       (:tableau
        (loop
1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071
          :for item :in (rest statement)
          :do (destructuring-bind (adecl ident index.1 &optional index.2) item
                (unless (eql :adecl adecl)
                  (error "Unknown statement ~S" (list :tableau item)))
                (generate-expression code index.1)
                (if index.2
                    (progn
                      (generate-expression code index.2)
                      (gen-code code !tableau2))
                    (gen-code code !tableau1))
                (gen-code code (identificateur-nom ident)))))

       ((:appel)
1072
        (loop
1073 1074 1075 1076 1077
          :for item :in (cddr statement)
          :do (generate-expression code item)
          :finally (gen-code code !callp
                             (identificateur-nom (second statement))
                             (length (cddr statement)))))
1078

1079

1080 1081 1082 1083
       ;; (:decl-procedure ident nil       nil)
       ;; (:decl-procedure ident (fpid...) nil)
       ;; (:decl-procedure ident nil       (locid...))
       ;; (:decl-procedure ident (fpid...) (locid...))
1084 1085 1086 1087 1088 1089 1090 1091 1092 1093
       ;; --> :trap-proc-reached *
       ;; ==> fpid inter locid == arguments par valeur  ==> copier
       ;; ==> fpid diff  locid == arguments par reference
       ;; ==> locid diff fpid  == variable locales --> table variable locale pour la proc.

       ;; Parameters by reference
       ;; Parameters by value       = Local variables
       ;; Global Variables
       ;; Local Variables

1094

1095
       ;; - Appel de  PROCEDURE
1096
       ;;
1097 1098 1099 1100
       ;;   We cannot generate vref or vval for parameters of PROCEDUREs
       ;;   before knowing what parameters are by reference and what are by
       ;;   value, therefore before having seen the PROCEDURE declaration in
       ;;   the source.
1101
       ;;
1102 1103 1104
       ;;   ⚠ Therefore we can generate the code only globally, just before we
       ;;     run the program.  Chaining or loading parts of the program while
       ;;     running means we need to recompile it.
1105

1106

1107 1108 1109
       ;; :result             OR  :retour-en      OR   :retour
       ;; -------------------     ---------------     ------------
       ;; result    <-- :pop  OR  goto <-- :pop   OR   nothing
1110
       ;;
1111
       ;; return-pc <-- sf.return-pc
1112
       ;;-sf   <-- sf.next-sf
1113
       ;; argcnt    <-- sf.argcnt
1114
       ;; sf        <---sf
1115 1116
       ;; :pop-sf
       ;; :pop-n argcnt
1117
       ;;
1118 1119
       ;; :push  result              --                 --
       ;; pc <-- return-pc       OR  pc <-- goto     or pc <-- return-pc
1120

1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131

       (:decl-procedure
        ;; Les procedures ne sont pas executable, !procedure generates an error.
        (gen-code code !procedure)
        (destructuring-bind (decl name params locals) statement
          (declare (ignore decl))
          (let ((params (mapcar (function identificateur-nom)  params))
                (locals (mapcar (function identificateur-nom)  locals)))
           (setf (code-procedure code)
                 (make-procedure :name (identificateur-nom name)
                                 :parameters (nreverse
1132
                                              (mapcar (lambda (param)
1133 1134 1135 1136 1137 1138 1139
                                                        (if (member param locals)
                                                            `(:par-valeur    ,param)
                                                            `(:par-reference ,param)))
                                                      params))
                                 :local-variables (set-difference locals params)
                                 :line (code-line code)
                                 :offset (code-offset code))))))
1140

1141 1142 1143 1144 1145 1146
       (:resultat   (generate-expression code (second statement))
                    (gen-code code !result))
       (:retour-en  (generate-expression code (second statement))
                    (gen-code code !retour-en))
       (:retour     (gen-code code !retour))

1147 1148 1149 1150
       (:affectation
        ;; (:vref ident) expression) --> expression :pop&store ident
        ;; (:aref ident expr) expression) --> expression expr :pop&astore1 ident
        ;; (:aref ident expr.1 expr.2) expression) --> expression expr.1 expr.2 :pop&astore2 ident
1151 1152 1153 1154 1155 1156 1157 1158 1159
        (generate-expression code (third statement))
        (ecase (length (second statement))
          (2  (gen-code code !pop&store))
          (3  (generate-expression code (third (second statement)))
              (gen-code code !pop&astore1))
          (4  (generate-expression code (third  (second statement)))
              (generate-expression code (fourth (second statement)))
              (gen-code code !pop&astore2)))
        (gen-code code (identificateur-nom (second (second statement)))))
1160 1161

       (:lire
1162 1163 1164
        ;; (:vref ident) --> :lire&store ident
        ;; (:aref ident expr) -->  expr :lire&astore1 ident
        ;; (:aref ident expr.1 expr.2) -->  expr.1 expr.2 :lire&astore2 ident
1165
        (gen-code code !beep)
1166
        (loop
1167
          :for item :in (rest statement)
1168
          :do (progn
1169 1170
                (ecase (length item)
                  (2  (gen-code code !lire&store))
1171
                  (3  (generate-expression code (third  item))
1172
                      (gen-code code !lire&astore1))
1173 1174
                  (4  (generate-expression code (third  item))
                      (generate-expression code (fourth item))
1175 1176
                      (gen-code code !lire&astore2)))
                (gen-code code (identificateur-nom (second item))))))
1177 1178 1179 1180 1181 1182


       ;; AFFICHER expr…
       ;; --> (:afficher nil expr…)
       ;;
       ;; AFFICHER [spec…] expr…
1183
       ;; --> (:afficher (spec…) expr…)
1184 1185 1186 1187 1188

       ;; First, the expr… are evaluated and stored in a TABLEAU $VALS[number of expr…]
       ;; Then $INDEX is set to 1,
       ;; and finally the :afficher-* codops are generated.
       ;; Each :afficher-* operation should use $VALS[$INDEX] and up, incrementing $INDEX.
1189

1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211
       ;; ['litchaine']
       ;; --> spec ::= (:spec-chaine (:rep-1) litchaine)    ==> (rep litchaine :afficher-u)
       ;; [42'litchaine']
       ;; --> spec ::= (:spec-chaine (:rep 42) litchaine)   ==> (rep litchaine :afficher-u)
       ;; [*'litchaine']
       ;; --> spec ::= (:spec-chaine (:rep-var) litchaine)  ==> (rep litchaine :afficher-u)

       ;; [/]
       ;; --> spec ::= (:spec-slash (:rep-1))      ==> (rep :afficher-newline)
       ;; [42/]
       ;; --> spec ::= (:spec-slash (:rep 42))     ==> (rep :afficher-newline)
       ;; [*/]
       ;; --> spec ::= (:spec-slash (:rep-var))    ==> (rep :afficher-newline)

       ;; X --> :spec-space    ==> (rep :afficher-space)
       ;; C --> :spec-cr       ==> (rep :afficher-cr)
       ;; L --> :spec-nl       ==> (rep :afficher-nl)

       ;; For the following specifiers, only fixed repeatitions are allowed: :rep-1 and (:rep n)
       ;; U --> :spec-u        ==> (rep :afficher-u)
       ;; Fe.d --> (:spec-f rep e d) ==> (rep e d :afficher-f)
       ;; Ee.d --> (:spec-d rep e d) ==> (rep e d :afficher-e)
1212

1213 1214
       ;; This rules means that the number of expressions processed is
       ;; known at compilation time.
1215

1216
       ;; The format specifiers and the expressions are processed in
Pascal J. Bourguignon's avatar
Pascal J. Bourguignon committed
1217
       ;; parallel, therefore the following program:
1218
       ;;
Pascal J. Bourguignon's avatar
Pascal J. Bourguignon committed
1219
       ;; 10 AFFICHER['(',F0.0,')']&P(42)
1220 1221
       ;; 11 TERMINER
       ;; 100 PROCEDURE &P(X)
Pascal J. Bourguignon's avatar
Pascal J. Bourguignon committed
1222
       ;; 101 AFFICHER['[',F0.0,']']X
1223 1224 1225 1226 1227 1228
       ;; 102 RESULTAT X
       ;;
       ;; should print:
       ;;
       ;; ([42]42)

1229 1230 1231 1232
       (:afficher
        ;; (:afficher nil expr...)      --> :pushi n expr... :afficher-u
        ;; (:afficher (form...) expr...)
        ;; (:afficher (form...))
1233 1234
        (let ((exprs (cddr statement)))
          (labels ((spec-simple (spec format)
1235
                     (if (atom spec)
1236
                         (lse-error "SPECIFICATEUR DE FORMAT INVALIDE ~S" format)
1237
                         (case (first spec)
1238 1239
                           (:rep-1   (gen-code code !pushi 1))
                           (:rep     (gen-code code !pushi (numero-valeur (second spec))))
1240
                           (:rep-var (when (null exprs)
1241
                                       (lse-error "IL MANQUE AU MOINS UNE EXPRESSION POUR LE SPECIFICATEUR DE FORMAT ~S" format))
1242
                                     (generate-expression code (pop exprs)))
1243
                           (otherwise
1244
                            (lse-error "SPECIFICATEUR DE FORMAT INVALIDE ~S" format)))))
1245
                   (spec-expr (spec ops format)
1246
                     (if (atom spec)
1247
                         (lse-error "SPECIFICATEUR DE FORMAT INVALIDE ~S" format)
1248 1249
                         (case (first spec)
                           (:rep-1 (when (null exprs)
1250
                                     (lse-error "IL MANQUE AU MOINS UNE EXPRESSION POUR LE SPECIFICATEUR DE FORMAT ~S" format))
1251 1252
                                   (generate-expression code (pop exprs))
                                   (dolist (op ops) (gen-code code op)))
1253 1254 1255 1256
                           (:rep   (loop
                                     :repeat (numero-valeur (second spec))
                                     :do (progn
                                           (when (null exprs)
1257
                                             (lse-error "IL MANQUE AU MOINS UNE EXPRESSION POUR LE SPECIFICATEUR DE FORMAT ~S" format))
1258 1259
                                           (generate-expression code (pop exprs))
                                           (dolist (op ops) (gen-code code op)))))
1260
                           (otherwise
1261
                            (lse-error "SPECIFICATEUR DE FORMAT INVALIDE ~S" format))))))
1262
            (if (second statement)
1263
                (loop
1264
                  :for format :in (second statement)
1265 1266
                  :do (ecase (first format)
                        (:spec-chaine
1267 1268
                         ;; (print statement)
                         ;; (print format)
1269
                         (spec-simple (second format) format)
1270 1271
                         (generate-expression code (third format))
                         (gen-code code !afficher-chaine))
1272 1273
                        ((:spec-slash :spec-space :spec-cr :spec-nl)
                         (spec-simple (second format) format)
1274 1275 1276 1277 1278
                         (gen-code code (case (first format)
                                          (:spec-slash !afficher-newline)
                                          (:spec-space !afficher-space)
                                          (:spec-cr    !afficher-cr)
                                          (:spec-nl    !afficher-nl))))
1279
                        ((:spec-f :spec-e)
1280 1281 1282 1283 1284 1285 1286
                         (spec-expr (second format)
                                    (list !pushi (numero-valeur (third format))
                                          !pushi (numero-valeur (fourth format))
                                          (case (first format)
                                            (:spec-f !afficher-f)
                                            (:spec-e !afficher-e)))
                                    format))
1287
                        (:spec-u
1288
                         (spec-expr (second format) '(!afficher-u) format)))
1289 1290
                  :finally (loop
                             :for expr :in exprs
1291 1292 1293
                             :do (progn
                                   (generate-expression code expr)
                                   (gen-code code !afficher-u))))
1294
                ;; (5) afficher[{n}u]expr...
1295
                (progn
1296
                  (gen-code code !pushi 1 !afficher-newline)
1297
                  (loop
1298
                    :for expr :in (cddr statement)
1299
                    :do (progn
1300 1301
                          (generate-expression code expr)
                          (gen-code code !afficher-u))))))))
1302

1303

1304

1305 1306
       (:aller-en (generate-expression code (second statement))
                  (gen-code code !goto))
1307 1308

       (:si
1309
        ;;(:si test then)       --> test :bfalse offset.t then
1310
        ;;(:si test then else)  --> test :bfalse offset.t then  :balways offset.e else
1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323
        (generate-expression code (second statement))
        (gen-code code !bfalse)
        (let ((index.t (code-offset code)))
          (gen-code code 0)
          (generate-statement code (third statement))
          (if (fourth statement)
              (progn
                (gen-code code !balways)
                (let ((index.e (code-offset code)))
                  (gen-code code 0)
                  (generate-statement code (fourth statement))
                  (let ((index.f (code-offset code)))
                    (setf (aref (code-vector code) index.t) (- index.e index.t)
1324
                          (aref (code-vector code) index.e) (- index.f index.e 1)))))
1325 1326 1327 1328 1329
              (let ((index.e (code-offset code)))
                (setf (aref (code-vector code) index.t) (- index.e index.t 1))))))

       (:terminer (gen-code code !terminer))
       (:pause    (gen-code code !pause   ))
1330 1331 1332

       (:faire-jusqu-a ;; lino ident init pas jusqua)
        ;; --> lino init pas jusqua :faire-jusqu-a ident
1333 1334 1335 1336 1337
        (generate-expression code (second statement))
        (generate-expression code (fourth statement))
        (generate-expression code (fifth  statement))
        (generate-expression code (sixth  statement))
        (gen-code code !faire-jusqu-a (identificateur-nom (third statement))))
1338 1339 1340

       (:faire-tant-que ;; lino ident init pas test)
        ;; --> lino init pas :faire-tant-que ident test
1341 1342 1343 1344 1345 1346
        (generate-expression code (second statement))
        (generate-expression code (fourth statement))
        (generate-expression code (fifth  statement))
        (gen-code code !faire-tant-que (identificateur-nom (third statement)))
        (generate-expression code (sixth  statement))
        (gen-code code !tant-que))
1347 1348 1349 1350 1351 1352

       ;; ==> create a faire bloc. When we reach the end of each line, we must
       ;;     check for loop blocks available for this line. (kind of come from...).


       (:garer ;; var enr fic) --> enr fic :garer var
1353 1354 1355
        (generate-expression code (third statement))
        (generate-expression code (fourth statement))
        (gen-code code !garer (identificateur-nom (second statement))))
1356

1357
       (:charger
1358 1359
        ;;(:charger  var enr fic)         --> enr fic :charger var nil
        ;;(:charger  var enr fic varstat) --> enr fic :charger var varstat
1360 1361
        (generate-expression code (third statement))
        (generate-expression code (fourth statement))
1362
        (if (fifth statement)
1363 1364 1365 1366 1367 1368
            (gen-code code !charger
                      (identificateur-nom (second statement))
                      (identificateur-nom (fifth statement)))
            (gen-code code !charger
                      (identificateur-nom (second statement))
                      nil)))
1369

1370
       (:supprimer
1371 1372 1373 1374 1375 1376
        (generate-expression code (second statement))
        (if (third statement)
            (progn
              (generate-expression code (third statement))
              (gen-code code !supprimer-enregistrement))
            (gen-code code !supprimer-fichier)))
1377

1378
       (:executer
1379 1380 1381 1382 1383 1384
        (generate-expression code (second statement))
        (if (third statement)
            (progn
              (generate-expression code (third statement))
              (gen-code code !executer))
            (gen-code code !pushi 1 !executer)))
1385 1386

       (:debut
1387
        (compile-statement-list code (rest statement)))
1388

1389 1390 1391
       (t
         (error "Unknown statement ~S" statement)))))
  code)
1392

1393

1394 1395 1396
(defun compile-statement-list (code slist)
  (dolist (statement slist code)
    (generate-statement code statement)))
1397 1398


1399
(defun compile-lse-line-parse-tree (parse-tree)
1400
  ;; (let ((*print-pretty* nil)) (terpri) (princ "Parse tree: ") (prin1 parse-tree) (terpri))
1401
  (cond
1402 1403 1404 1405
    ((null parse-tree)
     (let ((code (make-code :line 0)))
       (gen-code code !stop)                    ; nothing to do
       code))
1406
    ((atom parse-tree)
1407
     (lse-error "INTERNE: UN ATOME ~S DANS L'ARBRE SYNTAXIQUE." parse-tree))
1408
    ((eq (car parse-tree) :liste-instructions)
1409 1410 1411 1412
     (let ((code (make-code :line 0)))
       (compile-statement-list code (cdr parse-tree))
       (gen-code code !stop)
       code))
1413
    ((eq (car parse-tree) :ligne-programme)
1414 1415 1416 1417
     (let ((linum (numero-valeur (cadr parse-tree))))
       (unless (line-number-valid-p linum)
         (lse-error "NUMERO DE LIGNE INVALIDE ~D; CE DEVRAIT ETRE UN ENTIER ENTRE 1 ET ~D INCLUS."
                    linum (line-number-maximum)))
1418 1419 1420 1421
       (let ((code (make-code :line linum)))
         (compile-statement-list code (cddr parse-tree))
         (gen-code code !next-line)
         code)))
1422
    (t
1423
     (lse-error "INTERNE: UNE LISTE INVALIDE ~S DANS L'ARBRE SYNTAXIQUE." parse-tree))))
1424 1425


1426 1427 1428 1429

(defmacro converting-parser-errors (&body body)
  ;; We convert parser and scanner errors into lse-parser and
  ;; lse-scanner errors, rewriting the error messages.
1430
  `(handler-bind (((or scanner-error-invalid-character lse-scanner-error-invalid-character)
1431 1432
                   (lambda (err)
                     (error 'lse-scanner-error-invalid-character
1433
                            :backtrace         (or (lse-error-backtrace err) #+ccl (ccl::backtrace-as-list))
1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447
                            :line              (scanner-error-line          err)
                            :column            (scanner-error-column        err)
                            :state             (scanner-error-state         err)
                            :current-token     (scanner-error-current-token err)
                            :scanner           (scanner-error-scanner       err)
                            :invalid-character (scanner-error-invalid-character err)
                            :format-control    "CARACTÈRE INVALIDE ~A~:[~*~; (~D)~]"
                            :format-arguments   (let ((ch (scanner-error-invalid-character err)))
                                                  (list
                                                   (if (<= 32 (char-code ch))
                                                       (format nil "'~A'" ch)
                                                       (format nil ".~A." (char-code ch)))
                                                   (<= 32 (char-code ch))
                                                   (char-code ch))))))
1448
                  (lse-parser-error-end-of-source-not-reached
1449 1450
                   (lambda (err)
                     (error 'lse-parser-error-end-of-source-not-reached
1451 1452 1453 1454 1455
                            :backtrace          (or (lse-error-backtrace err) #+ccl (ccl::backtrace-as-list))
                            :line               (parser-error-line err)
                            :column             (parser-error-column err)
                            :grammar            (parser-error-grammar err)
                            :scanner            (parser-error-scanner err)
1456 1457 1458
                            :non-terminal-stack (parser-error-non-terminal-stack err)
                            :format-control "SYMBOLE SURNUMÉRAIRE ~:[~A ~S~;~S~*~]; ATTENDU: FIN DE LA LIGNE."
                            :format-arguments
1459
                            (let ((token (scanner-current-token (parser-error-scanner err))))
1460 1461 1462 1463
                              (list (string= (token-kind-label (token-kind token))
                                             (token-text token))
                                    (token-kind-label (token-kind token))
                                    (token-text token))))))
1464
                  (lse-parser-error-unexpected-token
1465 1466
                   (lambda (err)
                     (error 'lse-parser-error-unexpected-token
1467 1468 1469 1470 1471
                            :backtrace          (or (lse-error-backtrace err) #+ccl (ccl::backtrace-as-list))
                            :line               (parser-error-line err)
                            :column             (parser-error-column err)
                            :grammar            (parser-error-grammar err)
                            :scanner            (parser-error-scanner err)
1472
                            :non-terminal-stack (parser-error-non-terminal-stack err)
1473 1474
                            :expected-tokens (parser-error-expected-tokens err)
                            :format-control "~:[FIN DE LIGNE INATTENDUE~3*~;SYMBOLE INATTENDU ~:[~A ~S~;~*~S~]~]~@[; ATTENDU: ~{~A~^ ~}~]."
1475
                            :format-arguments
1476 1477 1478 1479 1480 1481
                            (let ((token (scanner-current-token (parser-error-scanner err))))
                              (list (not (or (eolp token) (eofp token)))
                                    (string= (token-kind-label (token-kind token))
                                             (token-text token))
                                    (token-kind-label (token-kind token))
                                    (token-text token)
1482 1483
                                    (mapcar (function token-kind-label)
                                            (parser-error-expected-tokens err)))))))
1484
                  (parser-error
1485
                   (lambda (err)
1486
                     (error 'lse-parser-error
1487 1488 1489 1490 1491
                            :backtrace          (or #+ccl (ccl::backtrace-as-list))
                            :line               (parser-error-line err)
                            :column             (parser-error-column err)
                            :grammar            (parser-error-grammar err)
                            :scanner            (parser-error-scanner err)
1492
                            :non-terminal-stack (parser-error-non-terminal-stack err)
1493 1494
                            :format-control     (parser-error-format-control   err)
                            :format-arguments   (parser-error-format-arguments err))))
1495

1496 1497 1498
                  (unexpected-token-error
                   (lambda (err)
                     (error 'lse-parser-error-unexpected-token
1499 1500 1501
                            :backtrace          (or #+ccl (ccl::backtrace-as-list))
                            :line               (scanner-error-line err)
                            :column             (scanner-error-column err)
1502
                            ;; :grammar (scanner-error-grammar err)
1503
                            :scanner            (scanner-error-scanner err)
1504
                            ;; :non-terminal-stack (scanner-error-non-terminal-stack err)
1505 1506
                            :expected-tokens    (com.informatimago.rdp::unexpected-token-error-expected-tokens err)
                            :format-control    "~:[FIN DE LIGNE INATTENDUE~3*~;SYMBOLE INATTENDU ~:[~A ~S~;~*~S~]~]~@[; ATTENDU: ~{~A~^, ~}~]."
1507 1508 1509 1510 1511 1512
                            :format-arguments  (let ((token (scanner-current-token (scanner-error-scanner err))))
                                                 (list (not (or (eolp token) (eofp token)))
                                                       (string= (token-kind-label (token-kind token))
                                                                (token-text token))
                                                       (token-kind-label (token-kind token))
                                                       (token-text token)
1513 1514 1515 1516 1517 1518 1519 1520
                                                       (mapcar (lambda (token)
                                                                 (case token
                                                                   ((nil) "RIEN")
                                                                   ((eof eol) "FIN DE LIGNE")
                                                                   (t     (token-kind-label token))))
                                                               (com.informatimago.rdp::unexpected-token-error-expected-tokens err))))))))
     ,@body)
  `(progn ,@body))
1521 1522


1523
(defun lse-parse-one-line (*scanner*)
1524
  (converting-parser-errors
1525 1526
    (prog1 (parse-lse *scanner*)
      (accept *scanner* 'eol))))
1527 1528


1529
(defun compile-lse-line (source-line)
1530
  (let* ((*scanner*  (make-instance 'lse-scanner :source source-line))
1531
         (parse-tree (lse-parse-one-line *scanner*))
1532 1533 1534
         (code       (compile-lse-line-parse-tree parse-tree)))
    (setf (code-source code)  (unparse-slist parse-tree))
    code))
1535 1536


1537 1538
(defun compile-lse-stream (stream)
  (let ((*scanner* (make-instance 'lse-scanner :source stream)))
1539
    (converting-parser-errors
1540 1541 1542 1543 1544 1545 1546 1547
      (loop
        :until (eofp (scanner-current-token *scanner*))
        :for parse-tree = (prog1 (parse-lse *scanner*)
                            (expect *scanner* 'eol))
        :when parse-tree
          :collect (let ((code (compile-lse-line-parse-tree parse-tree)))
                     (setf (code-source code) (unparse-slist parse-tree))
                     code)))))
1548 1549 1550 1551 1552 1553 1554 1555 1556


(defun compile-lse-file (source &optional name)
  (with-open-file (stream source
                          :direction :input
                          :if-does-not-exist nil)
    (if stream
        (compile-lse-stream stream)
        (error 'lse-file-error
1557
               :backtrace (or #+ccl (ccl::backtrace-as-list))
1558 1559 1560
               :pathname source
               :format-control "PAS DE PROGRAMME NOMME '~A' ACCESSIBLE"
               :format-arguments (list name)))))
1561

1562

1563

1564 1565 1566 1567
(defun decompile-lse-line (lino code)
  (declare (ignore lino))
  ;; For now, we cheat, we don't decompile anything, we just return
  ;; the unparsed source kept along with the code vector.
1568
  (code-source code))
1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613


(defun decompile-lse-line-2 (lino byte-code)
  (with-output-to-string (source)
    (princ lino source) (princ " " source)
    (flet ((nbop (cop) (cdr (gethash cop *cop-info* '(0 . 0))))
           (disa (cop) (car (gethash cop *cop-info* (cons cop 0)))))
      (let ((pc 0)
            (listing '())
            (labels '()))
        (loop :while (< pc (length byte-code)) :do
          (let ((cop (list (disa (aref byte-code pc))))
                (noa       (nbop (aref byte-code pc))))
            (incf pc)
            (dotimes (n noa)
              (setf cop (nconc cop (list (aref byte-code pc))))
              (incf pc))
            (push cop listing)
            (when (member (first cop) bc::*branches*)
              (push (+ pc (second cop)) labels))))
        (setf listing (nreverse listing))
        (princ listing source)
        #-(and)
        (loop
          :initially (format t "~&")
          :with pc = 0
          :for line :in listing
          :do (progn (if (member pc labels)
                         (format t "@~6:A " pc)
                         (format t "        "))
                     (format t "~32:A"
                             (with-output-to-string (out)
                               (princ "(" out)
                               (let ((first t))
                                 (dolist (item line)
                                   (if first
                                       (setf first nil)
                                       (princ " " out))
                                   (if (symbolp item)
                                       (princ item out)
                                       (prin1 item out))))
                               (princ ")" out)))
                     (if (member (first line) bc::*branches*)
                         (format t " ; @~A~%"  (+ pc (length line) (second line)))
                         (format t "~%"))
1614
                     (incf pc (length line))))))))