Artifact
4356cb4b0ecf19f8929d073bd3e13d61a5e4b2fb:
0000: 3b 20 2a 2a 2a 20 54 68 69 73 20 66 69 6c 65 20 ; *** This file
0010: 73 74 61 72 74 73 20 77 69 74 68 20 61 20 63 6f starts with a co
0020: 70 79 20 6f 66 20 74 68 65 20 66 69 6c 65 20 6d py of the file m
0030: 75 6c 74 69 6c 65 78 2e 73 63 6d 20 2a 2a 2a 0a ultilex.scm ***.
0040: 3b 20 43 6f 70 79 72 69 67 68 74 20 28 43 29 20 ; Copyright (C)
0050: 31 39 39 37 20 44 61 6e 6e 79 20 44 75 62 65 27 1997 Danny Dube'
0060: 2c 20 55 6e 69 76 65 72 73 69 74 65 27 20 64 65 , Universite' de
0070: 20 4d 6f 6e 74 72 65 27 61 6c 2e 0a 3b 20 41 6c Montre'al..; Al
0080: 6c 20 72 69 67 68 74 73 20 72 65 73 65 72 76 65 l rights reserve
0090: 64 2e 0a 3b 20 53 49 4c 65 78 20 31 2e 30 2e 0a d..; SILex 1.0..
00a0: 0a 3b 0a 3b 20 47 65 73 74 69 6f 6e 20 64 65 73 .;.; Gestion des
00b0: 20 49 6e 70 75 74 20 53 79 73 74 65 6d 73 0a 3b Input Systems.;
00c0: 20 46 6f 6e 63 74 69 6f 6e 73 20 61 20 75 74 69 Fonctions a uti
00d0: 6c 69 73 65 72 20 70 61 72 20 6c 27 75 73 61 67 liser par l'usag
00e0: 65 72 3a 0a 3b 20 20 20 6c 65 78 65 72 2d 6d 61 er:.; lexer-ma
00f0: 6b 65 2d 49 53 2c 20 6c 65 78 65 72 2d 67 65 74 ke-IS, lexer-get
0100: 2d 66 75 6e 63 2d 67 65 74 63 2c 20 6c 65 78 65 -func-getc, lexe
0110: 72 2d 67 65 74 2d 66 75 6e 63 2d 75 6e 67 65 74 r-get-func-unget
0120: 63 2c 0a 3b 20 20 20 6c 65 78 65 72 2d 67 65 74 c,.; lexer-get
0130: 2d 66 75 6e 63 2d 6c 69 6e 65 2c 20 6c 65 78 65 -func-line, lexe
0140: 72 2d 67 65 74 2d 66 75 6e 63 2d 63 6f 6c 75 6d r-get-func-colum
0150: 6e 20 65 74 20 6c 65 78 65 72 2d 67 65 74 2d 66 n et lexer-get-f
0160: 75 6e 63 2d 6f 66 66 73 65 74 0a 3b 0a 0a 3b 20 unc-offset.;..;
0170: 54 61 69 6c 6c 65 20 69 6e 69 74 69 61 6c 65 20 Taille initiale
0180: 70 61 72 20 64 65 66 61 75 74 20 64 75 20 62 75 par defaut du bu
0190: 66 66 65 72 20 64 27 65 6e 74 72 65 65 0a 28 64 ffer d'entree.(d
01a0: 65 66 69 6e 65 20 6c 65 78 65 72 2d 69 6e 69 74 efine lexer-init
01b0: 2d 62 75 66 66 65 72 2d 6c 65 6e 20 31 30 32 34 -buffer-len 1024
01c0: 29 0a 0a 3b 20 4e 75 6d 65 72 6f 20 64 75 20 63 )..; Numero du c
01d0: 61 72 61 63 74 65 72 65 20 6e 65 77 6c 69 6e 65 aractere newline
01e0: 0a 28 64 65 66 69 6e 65 20 6c 65 78 65 72 2d 69 .(define lexer-i
01f0: 6e 74 65 67 65 72 2d 6e 65 77 6c 69 6e 65 20 28 nteger-newline (
0200: 63 68 61 72 2d 3e 69 6e 74 65 67 65 72 20 23 5c char->integer #\
0210: 6e 65 77 6c 69 6e 65 29 29 0a 0a 3b 20 43 6f 6e newline))..; Con
0220: 73 74 72 75 63 74 65 75 72 20 64 27 49 53 20 62 structeur d'IS b
0230: 72 75 74 0a 28 64 65 66 69 6e 65 20 6c 65 78 65 rut.(define lexe
0240: 72 2d 72 61 77 2d 49 53 2d 6d 61 6b 65 72 0a 20 r-raw-IS-maker.
0250: 20 28 6c 61 6d 62 64 61 20 28 62 75 66 66 65 72 (lambda (buffer
0260: 20 72 65 61 64 2d 70 74 72 20 69 6e 70 75 74 2d read-ptr input-
0270: 66 20 63 6f 75 6e 74 65 72 73 29 0a 20 20 20 20 f counters).
0280: 28 6c 65 74 20 28 28 69 6e 70 75 74 2d 66 20 20 (let ((input-f
0290: 20 20 20 20 20 20 20 20 69 6e 70 75 74 2d 66 29 input-f)
02a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
02b0: 3b 20 45 6e 74 72 65 65 20 72 65 65 6c 6c 65 0a ; Entree reelle.
02c0: 09 20 20 28 62 75 66 66 65 72 20 20 20 20 20 20 . (buffer
02d0: 20 20 20 20 20 62 75 66 66 65 72 29 20 20 20 20 buffer)
02e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 20 42 ; B
02f0: 75 66 66 65 72 0a 09 20 20 28 62 75 66 6c 65 6e uffer.. (buflen
0300: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 (stri
0310: 6e 67 2d 6c 65 6e 67 74 68 20 62 75 66 66 65 72 ng-length buffer
0320: 29 29 0a 09 20 20 28 72 65 61 64 2d 70 74 72 20 )).. (read-ptr
0330: 20 20 20 20 20 20 20 20 72 65 61 64 2d 70 74 72 read-ptr
0340: 29 0a 09 20 20 28 73 74 61 72 74 2d 70 74 72 20 ).. (start-ptr
0350: 20 20 20 20 20 20 20 31 29 20 20 20 20 20 20 20 1)
0360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
0370: 20 4d 61 72 71 75 65 20 64 65 20 64 65 62 75 74 Marque de debut
0380: 20 64 65 20 6c 65 78 65 6d 65 0a 09 20 20 28 73 de lexeme.. (s
0390: 74 61 72 74 2d 6c 69 6e 65 20 20 20 20 20 20 20 tart-line
03a0: 31 29 0a 09 20 20 28 73 74 61 72 74 2d 63 6f 6c 1).. (start-col
03b0: 75 6d 6e 20 20 20 20 20 31 29 0a 09 20 20 28 73 umn 1).. (s
03c0: 74 61 72 74 2d 6f 66 66 73 65 74 20 20 20 20 20 tart-offset
03d0: 30 29 0a 09 20 20 28 65 6e 64 2d 70 74 72 20 20 0).. (end-ptr
03e0: 20 20 20 20 20 20 20 20 31 29 20 20 20 20 20 20 1)
03f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0400: 3b 20 4d 61 72 71 75 65 20 64 65 20 66 69 6e 20 ; Marque de fin
0410: 64 65 20 6c 65 78 65 6d 65 0a 09 20 20 28 70 6f de lexeme.. (po
0420: 69 6e 74 2d 70 74 72 20 20 20 20 20 20 20 20 31 int-ptr 1
0430: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
0440: 20 20 20 20 20 20 20 3b 20 4c 65 20 70 6f 69 6e ; Le poin
0450: 74 0a 09 20 20 28 75 73 65 72 2d 70 74 72 20 20 t.. (user-ptr
0460: 20 20 20 20 20 20 20 31 29 20 20 20 20 20 20 20 1)
0470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
0480: 20 4d 61 72 71 75 65 20 64 65 20 6c 27 75 73 61 Marque de l'usa
0490: 67 65 72 0a 09 20 20 28 75 73 65 72 2d 6c 69 6e ger.. (user-lin
04a0: 65 20 20 20 20 20 20 20 20 31 29 0a 09 20 20 28 e 1).. (
04b0: 75 73 65 72 2d 63 6f 6c 75 6d 6e 20 20 20 20 20 user-column
04c0: 20 31 29 0a 09 20 20 28 75 73 65 72 2d 6f 66 66 1).. (user-off
04d0: 73 65 74 20 20 20 20 20 20 30 29 0a 09 20 20 28 set 0).. (
04e0: 75 73 65 72 2d 75 70 2d 74 6f 2d 64 61 74 65 3f user-up-to-date?
04f0: 20 23 74 29 29 20 20 20 20 20 20 20 20 20 20 20 #t))
0500: 20 20 20 20 20 20 20 20 20 3b 20 43 6f 6e 63 65 ; Conce
0510: 72 6e 65 20 6c 61 20 63 6f 6c 6f 6e 6e 65 20 73 rne la colonne s
0520: 65 75 6c 2e 0a 20 20 20 20 20 20 28 6c 65 74 72 eul.. (letr
0530: 65 63 0a 09 20 20 28 28 73 74 61 72 74 2d 67 6f ec.. ((start-go
0540: 2d 74 6f 2d 65 6e 64 2d 6e 6f 6e 65 20 20 20 20 -to-end-none
0550: 20 20 20 20 20 3b 20 46 6f 6e 63 74 69 6f 6e 73 ; Fonctions
0560: 20 64 65 20 64 65 70 6c 2e 20 64 65 73 20 6d 61 de depl. des ma
0570: 72 71 75 65 73 0a 09 20 20 20 20 28 6c 61 6d 62 rques.. (lamb
0580: 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 73 65 da ().. (se
0590: 74 21 20 73 74 61 72 74 2d 70 74 72 20 65 6e 64 t! start-ptr end
05a0: 2d 70 74 72 29 29 29 0a 09 20 20 20 28 73 74 61 -ptr))).. (sta
05b0: 72 74 2d 67 6f 2d 74 6f 2d 65 6e 64 2d 6c 69 6e rt-go-to-end-lin
05c0: 65 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 e.. (lambda (
05d0: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f ).. (let lo
05e0: 6f 70 20 28 28 70 74 72 20 73 74 61 72 74 2d 70 op ((ptr start-p
05f0: 74 72 29 20 28 6c 69 6e 65 20 73 74 61 72 74 2d tr) (line start-
0600: 6c 69 6e 65 29 29 0a 09 09 28 69 66 20 28 3d 20 line))...(if (=
0610: 70 74 72 20 65 6e 64 2d 70 74 72 29 0a 09 09 20 ptr end-ptr)...
0620: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
0630: 20 20 28 73 65 74 21 20 73 74 61 72 74 2d 70 74 (set! start-pt
0640: 72 20 70 74 72 29 0a 09 09 20 20 20 20 20 20 28 r ptr)... (
0650: 73 65 74 21 20 73 74 61 72 74 2d 6c 69 6e 65 20 set! start-line
0660: 6c 69 6e 65 29 29 0a 09 09 20 20 20 20 28 69 66 line))... (if
0670: 20 28 63 68 61 72 3d 3f 20 28 73 74 72 69 6e 67 (char=? (string
0680: 2d 72 65 66 20 62 75 66 66 65 72 20 70 74 72 29 -ref buffer ptr)
0690: 20 23 5c 6e 65 77 6c 69 6e 65 29 0a 09 09 09 28 #\newline)....(
06a0: 6c 6f 6f 70 20 28 2b 20 70 74 72 20 31 29 20 28 loop (+ ptr 1) (
06b0: 2b 20 6c 69 6e 65 20 31 29 29 0a 09 09 09 28 6c + line 1))....(l
06c0: 6f 6f 70 20 28 2b 20 70 74 72 20 31 29 20 6c 69 oop (+ ptr 1) li
06d0: 6e 65 29 29 29 29 29 29 0a 09 20 20 20 28 73 74 ne)))))).. (st
06e0: 61 72 74 2d 67 6f 2d 74 6f 2d 65 6e 64 2d 61 6c art-go-to-end-al
06f0: 6c 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 l.. (lambda (
0700: 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 20 73 ).. (set! s
0710: 74 61 72 74 2d 6f 66 66 73 65 74 20 28 2b 20 73 tart-offset (+ s
0720: 74 61 72 74 2d 6f 66 66 73 65 74 20 28 2d 20 65 tart-offset (- e
0730: 6e 64 2d 70 74 72 20 73 74 61 72 74 2d 70 74 72 nd-ptr start-ptr
0740: 29 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 ))).. (let
0750: 6c 6f 6f 70 20 28 28 70 74 72 20 73 74 61 72 74 loop ((ptr start
0760: 2d 70 74 72 29 0a 09 09 09 20 28 6c 69 6e 65 20 -ptr).... (line
0770: 73 74 61 72 74 2d 6c 69 6e 65 29 0a 09 09 09 20 start-line)....
0780: 28 63 6f 6c 75 6d 6e 20 73 74 61 72 74 2d 63 6f (column start-co
0790: 6c 75 6d 6e 29 29 0a 09 09 28 69 66 20 28 3d 20 lumn))...(if (=
07a0: 70 74 72 20 65 6e 64 2d 70 74 72 29 0a 09 09 20 ptr end-ptr)...
07b0: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
07c0: 20 20 28 73 65 74 21 20 73 74 61 72 74 2d 70 74 (set! start-pt
07d0: 72 20 70 74 72 29 0a 09 09 20 20 20 20 20 20 28 r ptr)... (
07e0: 73 65 74 21 20 73 74 61 72 74 2d 6c 69 6e 65 20 set! start-line
07f0: 6c 69 6e 65 29 0a 09 09 20 20 20 20 20 20 28 73 line)... (s
0800: 65 74 21 20 73 74 61 72 74 2d 63 6f 6c 75 6d 6e et! start-column
0810: 20 63 6f 6c 75 6d 6e 29 29 0a 09 09 20 20 20 20 column))...
0820: 28 69 66 20 28 63 68 61 72 3d 3f 20 28 73 74 72 (if (char=? (str
0830: 69 6e 67 2d 72 65 66 20 62 75 66 66 65 72 20 70 ing-ref buffer p
0840: 74 72 29 20 23 5c 6e 65 77 6c 69 6e 65 29 0a 09 tr) #\newline)..
0850: 09 09 28 6c 6f 6f 70 20 28 2b 20 70 74 72 20 31 ..(loop (+ ptr 1
0860: 29 20 28 2b 20 6c 69 6e 65 20 31 29 20 31 29 0a ) (+ line 1) 1).
0870: 09 09 09 28 6c 6f 6f 70 20 28 2b 20 70 74 72 20 ...(loop (+ ptr
0880: 31 29 20 6c 69 6e 65 20 28 2b 20 63 6f 6c 75 6d 1) line (+ colum
0890: 6e 20 31 29 29 29 29 29 29 29 0a 09 20 20 20 28 n 1))))))).. (
08a0: 73 74 61 72 74 2d 67 6f 2d 74 6f 2d 75 73 65 72 start-go-to-user
08b0: 2d 6e 6f 6e 65 0a 09 20 20 20 20 28 6c 61 6d 62 -none.. (lamb
08c0: 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 73 65 da ().. (se
08d0: 74 21 20 73 74 61 72 74 2d 70 74 72 20 75 73 65 t! start-ptr use
08e0: 72 2d 70 74 72 29 29 29 0a 09 20 20 20 28 73 74 r-ptr))).. (st
08f0: 61 72 74 2d 67 6f 2d 74 6f 2d 75 73 65 72 2d 6c art-go-to-user-l
0900: 69 6e 65 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 ine.. (lambda
0910: 20 28 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 ().. (set!
0920: 20 73 74 61 72 74 2d 70 74 72 20 75 73 65 72 2d start-ptr user-
0930: 70 74 72 29 0a 09 20 20 20 20 20 20 28 73 65 74 ptr).. (set
0940: 21 20 73 74 61 72 74 2d 6c 69 6e 65 20 75 73 65 ! start-line use
0950: 72 2d 6c 69 6e 65 29 29 29 0a 09 20 20 20 28 73 r-line))).. (s
0960: 74 61 72 74 2d 67 6f 2d 74 6f 2d 75 73 65 72 2d tart-go-to-user-
0970: 61 6c 6c 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 all.. (lambda
0980: 20 28 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 ().. (set!
0990: 20 73 74 61 72 74 2d 6c 69 6e 65 20 75 73 65 72 start-line user
09a0: 2d 6c 69 6e 65 29 0a 09 20 20 20 20 20 20 28 73 -line).. (s
09b0: 65 74 21 20 73 74 61 72 74 2d 6f 66 66 73 65 74 et! start-offset
09c0: 20 75 73 65 72 2d 6f 66 66 73 65 74 29 0a 09 20 user-offset)..
09d0: 20 20 20 20 20 28 69 66 20 75 73 65 72 2d 75 70 (if user-up
09e0: 2d 74 6f 2d 64 61 74 65 3f 0a 09 09 20 20 28 62 -to-date?... (b
09f0: 65 67 69 6e 0a 09 09 20 20 20 20 28 73 65 74 21 egin... (set!
0a00: 20 73 74 61 72 74 2d 70 74 72 20 75 73 65 72 2d start-ptr user-
0a10: 70 74 72 29 0a 09 09 20 20 20 20 28 73 65 74 21 ptr)... (set!
0a20: 20 73 74 61 72 74 2d 63 6f 6c 75 6d 6e 20 75 73 start-column us
0a30: 65 72 2d 63 6f 6c 75 6d 6e 29 29 0a 09 09 20 20 er-column))...
0a40: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 70 74 72 20 (let loop ((ptr
0a50: 73 74 61 72 74 2d 70 74 72 29 20 28 63 6f 6c 75 start-ptr) (colu
0a60: 6d 6e 20 73 74 61 72 74 2d 63 6f 6c 75 6d 6e 29 mn start-column)
0a70: 29 0a 09 09 20 20 20 20 28 69 66 20 28 3d 20 70 )... (if (= p
0a80: 74 72 20 75 73 65 72 2d 70 74 72 29 0a 09 09 09 tr user-ptr)....
0a90: 28 62 65 67 69 6e 0a 09 09 09 20 20 28 73 65 74 (begin.... (set
0aa0: 21 20 73 74 61 72 74 2d 70 74 72 20 70 74 72 29 ! start-ptr ptr)
0ab0: 0a 09 09 09 20 20 28 73 65 74 21 20 73 74 61 72 .... (set! star
0ac0: 74 2d 63 6f 6c 75 6d 6e 20 63 6f 6c 75 6d 6e 29 t-column column)
0ad0: 29 0a 09 09 09 28 69 66 20 28 63 68 61 72 3d 3f )....(if (char=?
0ae0: 20 28 73 74 72 69 6e 67 2d 72 65 66 20 62 75 66 (string-ref buf
0af0: 66 65 72 20 70 74 72 29 20 23 5c 6e 65 77 6c 69 fer ptr) #\newli
0b00: 6e 65 29 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 ne).... (loop
0b10: 20 28 2b 20 70 74 72 20 31 29 20 31 29 0a 09 09 (+ ptr 1) 1)...
0b20: 09 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 70 74 . (loop (+ pt
0b30: 72 20 31 29 20 28 2b 20 63 6f 6c 75 6d 6e 20 31 r 1) (+ column 1
0b40: 29 29 29 29 29 29 29 29 0a 09 20 20 20 28 65 6e )))))))).. (en
0b50: 64 2d 67 6f 2d 74 6f 2d 70 6f 69 6e 74 0a 09 20 d-go-to-point..
0b60: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 (lambda ()..
0b70: 20 20 20 20 20 28 73 65 74 21 20 65 6e 64 2d 70 (set! end-p
0b80: 74 72 20 70 6f 69 6e 74 2d 70 74 72 29 29 29 0a tr point-ptr))).
0b90: 09 20 20 20 28 70 6f 69 6e 74 2d 67 6f 2d 74 6f . (point-go-to
0ba0: 2d 73 74 61 72 74 0a 09 20 20 20 20 28 6c 61 6d -start.. (lam
0bb0: 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 73 bda ().. (s
0bc0: 65 74 21 20 70 6f 69 6e 74 2d 70 74 72 20 73 74 et! point-ptr st
0bd0: 61 72 74 2d 70 74 72 29 29 29 0a 09 20 20 20 28 art-ptr))).. (
0be0: 75 73 65 72 2d 67 6f 2d 74 6f 2d 73 74 61 72 74 user-go-to-start
0bf0: 2d 6e 6f 6e 65 0a 09 20 20 20 20 28 6c 61 6d 62 -none.. (lamb
0c00: 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 73 65 da ().. (se
0c10: 74 21 20 75 73 65 72 2d 70 74 72 20 73 74 61 72 t! user-ptr star
0c20: 74 2d 70 74 72 29 29 29 0a 09 20 20 20 28 75 73 t-ptr))).. (us
0c30: 65 72 2d 67 6f 2d 74 6f 2d 73 74 61 72 74 2d 6c er-go-to-start-l
0c40: 69 6e 65 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 ine.. (lambda
0c50: 20 28 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 ().. (set!
0c60: 20 75 73 65 72 2d 70 74 72 20 73 74 61 72 74 2d user-ptr start-
0c70: 70 74 72 29 0a 09 20 20 20 20 20 20 28 73 65 74 ptr).. (set
0c80: 21 20 75 73 65 72 2d 6c 69 6e 65 20 73 74 61 72 ! user-line star
0c90: 74 2d 6c 69 6e 65 29 29 29 0a 09 20 20 20 28 75 t-line))).. (u
0ca0: 73 65 72 2d 67 6f 2d 74 6f 2d 73 74 61 72 74 2d ser-go-to-start-
0cb0: 61 6c 6c 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 all.. (lambda
0cc0: 20 28 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 ().. (set!
0cd0: 20 75 73 65 72 2d 70 74 72 20 73 74 61 72 74 2d user-ptr start-
0ce0: 70 74 72 29 0a 09 20 20 20 20 20 20 28 73 65 74 ptr).. (set
0cf0: 21 20 75 73 65 72 2d 6c 69 6e 65 20 73 74 61 72 ! user-line star
0d00: 74 2d 6c 69 6e 65 29 0a 09 20 20 20 20 20 20 28 t-line).. (
0d10: 73 65 74 21 20 75 73 65 72 2d 63 6f 6c 75 6d 6e set! user-column
0d20: 20 73 74 61 72 74 2d 63 6f 6c 75 6d 6e 29 0a 09 start-column)..
0d30: 20 20 20 20 20 20 28 73 65 74 21 20 75 73 65 72 (set! user
0d40: 2d 6f 66 66 73 65 74 20 73 74 61 72 74 2d 6f 66 -offset start-of
0d50: 66 73 65 74 29 0a 09 20 20 20 20 20 20 28 73 65 fset).. (se
0d60: 74 21 20 75 73 65 72 2d 75 70 2d 74 6f 2d 64 61 t! user-up-to-da
0d70: 74 65 3f 20 23 74 29 29 29 0a 09 20 20 20 28 69 te? #t))).. (i
0d80: 6e 69 74 2d 6c 65 78 65 6d 65 2d 6e 6f 6e 65 20 nit-lexeme-none
0d90: 20 20 20 20 20 20 20 20 20 20 20 20 3b 20 44 65 ; De
0da0: 62 75 74 65 20 75 6e 20 6e 6f 75 76 65 61 75 20 bute un nouveau
0db0: 6c 65 78 65 6d 65 0a 09 20 20 20 20 28 6c 61 6d lexeme.. (lam
0dc0: 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 69 bda ().. (i
0dd0: 66 20 28 3c 20 73 74 61 72 74 2d 70 74 72 20 75 f (< start-ptr u
0de0: 73 65 72 2d 70 74 72 29 0a 09 09 20 20 28 73 74 ser-ptr)... (st
0df0: 61 72 74 2d 67 6f 2d 74 6f 2d 75 73 65 72 2d 6e art-go-to-user-n
0e00: 6f 6e 65 29 29 0a 09 20 20 20 20 20 20 28 70 6f one)).. (po
0e10: 69 6e 74 2d 67 6f 2d 74 6f 2d 73 74 61 72 74 29 int-go-to-start)
0e20: 29 29 0a 09 20 20 20 28 69 6e 69 74 2d 6c 65 78 )).. (init-lex
0e30: 65 6d 65 2d 6c 69 6e 65 0a 09 20 20 20 20 28 6c eme-line.. (l
0e40: 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 ambda ()..
0e50: 28 69 66 20 28 3c 20 73 74 61 72 74 2d 70 74 72 (if (< start-ptr
0e60: 20 75 73 65 72 2d 70 74 72 29 0a 09 09 20 20 28 user-ptr)... (
0e70: 73 74 61 72 74 2d 67 6f 2d 74 6f 2d 75 73 65 72 start-go-to-user
0e80: 2d 6c 69 6e 65 29 29 0a 09 20 20 20 20 20 20 28 -line)).. (
0e90: 70 6f 69 6e 74 2d 67 6f 2d 74 6f 2d 73 74 61 72 point-go-to-star
0ea0: 74 29 29 29 0a 09 20 20 20 28 69 6e 69 74 2d 6c t))).. (init-l
0eb0: 65 78 65 6d 65 2d 61 6c 6c 0a 09 20 20 20 20 28 exeme-all.. (
0ec0: 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 lambda ()..
0ed0: 20 28 69 66 20 28 3c 20 73 74 61 72 74 2d 70 74 (if (< start-pt
0ee0: 72 20 75 73 65 72 2d 70 74 72 29 0a 09 09 20 20 r user-ptr)...
0ef0: 28 73 74 61 72 74 2d 67 6f 2d 74 6f 2d 75 73 65 (start-go-to-use
0f00: 72 2d 61 6c 6c 29 29 0a 09 20 20 20 20 20 20 28 r-all)).. (
0f10: 70 6f 69 6e 74 2d 67 6f 2d 74 6f 2d 73 74 61 72 point-go-to-star
0f20: 74 29 29 29 0a 09 20 20 20 28 67 65 74 2d 73 74 t))).. (get-st
0f30: 61 72 74 2d 6c 69 6e 65 20 20 20 20 20 20 20 20 art-line
0f40: 20 20 20 20 20 20 20 3b 20 4f 62 74 65 6e 74 69 ; Obtenti
0f50: 6f 6e 20 64 65 73 20 73 74 61 74 73 20 64 75 20 on des stats du
0f60: 64 65 62 75 74 20 64 75 20 6c 78 6d 0a 09 20 20 debut du lxm..
0f70: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 (lambda ()..
0f80: 20 20 20 20 73 74 61 72 74 2d 6c 69 6e 65 29 29 start-line))
0f90: 0a 09 20 20 20 28 67 65 74 2d 73 74 61 72 74 2d .. (get-start-
0fa0: 63 6f 6c 75 6d 6e 0a 09 20 20 20 20 28 6c 61 6d column.. (lam
0fb0: 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 73 74 bda ().. st
0fc0: 61 72 74 2d 63 6f 6c 75 6d 6e 29 29 0a 09 20 20 art-column))..
0fd0: 20 28 67 65 74 2d 73 74 61 72 74 2d 6f 66 66 73 (get-start-offs
0fe0: 65 74 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 et.. (lambda
0ff0: 28 29 0a 09 20 20 20 20 20 20 73 74 61 72 74 2d ().. start-
1000: 6f 66 66 73 65 74 29 29 0a 09 20 20 20 28 70 65 offset)).. (pe
1010: 65 6b 2d 6c 65 66 74 2d 63 6f 6e 74 65 78 74 20 ek-left-context
1020: 20 20 20 20 20 20 20 20 20 20 20 3b 20 4f 62 74 ; Obt
1030: 65 6e 74 69 6f 6e 20 64 65 20 63 61 72 61 63 74 ention de caract
1040: 65 72 65 73 20 28 23 66 20 73 69 20 45 4f 46 29 eres (#f si EOF)
1050: 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 .. (lambda ()
1060: 0a 09 20 20 20 20 20 20 28 63 68 61 72 2d 3e 69 .. (char->i
1070: 6e 74 65 67 65 72 20 28 73 74 72 69 6e 67 2d 72 nteger (string-r
1080: 65 66 20 62 75 66 66 65 72 20 28 2d 20 73 74 61 ef buffer (- sta
1090: 72 74 2d 70 74 72 20 31 29 29 29 29 29 0a 09 20 rt-ptr 1)))))..
10a0: 20 20 28 70 65 65 6b 2d 63 68 61 72 0a 09 20 20 (peek-char..
10b0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 (lambda ()..
10c0: 20 20 20 20 28 69 66 20 28 3c 20 70 6f 69 6e 74 (if (< point
10d0: 2d 70 74 72 20 72 65 61 64 2d 70 74 72 29 0a 09 -ptr read-ptr)..
10e0: 09 20 20 28 63 68 61 72 2d 3e 69 6e 74 65 67 65 . (char->intege
10f0: 72 20 28 73 74 72 69 6e 67 2d 72 65 66 20 62 75 r (string-ref bu
1100: 66 66 65 72 20 70 6f 69 6e 74 2d 70 74 72 29 29 ffer point-ptr))
1110: 0a 09 09 20 20 28 6c 65 74 20 28 28 63 20 28 69 ... (let ((c (i
1120: 6e 70 75 74 2d 66 29 29 29 0a 09 09 20 20 20 20 nput-f)))...
1130: 28 69 66 20 28 63 68 61 72 3f 20 63 29 0a 09 09 (if (char? c)...
1140: 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 69 66 .(begin.... (if
1150: 20 28 3d 20 72 65 61 64 2d 70 74 72 20 62 75 66 (= read-ptr buf
1160: 6c 65 6e 29 0a 09 09 09 20 20 20 20 20 20 28 72 len).... (r
1170: 65 6f 72 67 61 6e 69 7a 65 2d 62 75 66 66 65 72 eorganize-buffer
1180: 29 29 0a 09 09 09 20 20 28 73 74 72 69 6e 67 2d )).... (string-
1190: 73 65 74 21 20 62 75 66 66 65 72 20 70 6f 69 6e set! buffer poin
11a0: 74 2d 70 74 72 20 63 29 0a 09 09 09 20 20 28 73 t-ptr c).... (s
11b0: 65 74 21 20 72 65 61 64 2d 70 74 72 20 28 2b 20 et! read-ptr (+
11c0: 70 6f 69 6e 74 2d 70 74 72 20 31 29 29 0a 09 09 point-ptr 1))...
11d0: 09 20 20 28 63 68 61 72 2d 3e 69 6e 74 65 67 65 . (char->intege
11e0: 72 20 63 29 29 0a 09 09 09 28 62 65 67 69 6e 0a r c))....(begin.
11f0: 09 09 09 20 20 28 73 65 74 21 20 69 6e 70 75 74 ... (set! input
1200: 2d 66 20 28 6c 61 6d 62 64 61 20 28 29 20 27 65 -f (lambda () 'e
1210: 6f 66 29 29 0a 09 09 09 20 20 23 66 29 29 29 29 of)).... #f))))
1220: 29 29 0a 09 20 20 20 28 72 65 61 64 2d 63 68 61 )).. (read-cha
1230: 72 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 r.. (lambda (
1240: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3c 20 ).. (if (<
1250: 70 6f 69 6e 74 2d 70 74 72 20 72 65 61 64 2d 70 point-ptr read-p
1260: 74 72 29 0a 09 09 20 20 28 6c 65 74 20 28 28 63 tr)... (let ((c
1270: 20 28 73 74 72 69 6e 67 2d 72 65 66 20 62 75 66 (string-ref buf
1280: 66 65 72 20 70 6f 69 6e 74 2d 70 74 72 29 29 29 fer point-ptr)))
1290: 0a 09 09 20 20 20 20 28 73 65 74 21 20 70 6f 69 ... (set! poi
12a0: 6e 74 2d 70 74 72 20 28 2b 20 70 6f 69 6e 74 2d nt-ptr (+ point-
12b0: 70 74 72 20 31 29 29 0a 09 09 20 20 20 20 28 63 ptr 1))... (c
12c0: 68 61 72 2d 3e 69 6e 74 65 67 65 72 20 63 29 29 har->integer c))
12d0: 0a 09 09 20 20 28 6c 65 74 20 28 28 63 20 28 69 ... (let ((c (i
12e0: 6e 70 75 74 2d 66 29 29 29 0a 09 09 20 20 20 20 nput-f)))...
12f0: 28 69 66 20 28 63 68 61 72 3f 20 63 29 0a 09 09 (if (char? c)...
1300: 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 69 66 .(begin.... (if
1310: 20 28 3d 20 72 65 61 64 2d 70 74 72 20 62 75 66 (= read-ptr buf
1320: 6c 65 6e 29 0a 09 09 09 20 20 20 20 20 20 28 72 len).... (r
1330: 65 6f 72 67 61 6e 69 7a 65 2d 62 75 66 66 65 72 eorganize-buffer
1340: 29 29 0a 09 09 09 20 20 28 73 74 72 69 6e 67 2d )).... (string-
1350: 73 65 74 21 20 62 75 66 66 65 72 20 70 6f 69 6e set! buffer poin
1360: 74 2d 70 74 72 20 63 29 0a 09 09 09 20 20 28 73 t-ptr c).... (s
1370: 65 74 21 20 72 65 61 64 2d 70 74 72 20 28 2b 20 et! read-ptr (+
1380: 70 6f 69 6e 74 2d 70 74 72 20 31 29 29 0a 09 09 point-ptr 1))...
1390: 09 20 20 28 73 65 74 21 20 70 6f 69 6e 74 2d 70 . (set! point-p
13a0: 74 72 20 72 65 61 64 2d 70 74 72 29 0a 09 09 09 tr read-ptr)....
13b0: 20 20 28 63 68 61 72 2d 3e 69 6e 74 65 67 65 72 (char->integer
13c0: 20 63 29 29 0a 09 09 09 28 62 65 67 69 6e 0a 09 c))....(begin..
13d0: 09 09 20 20 28 73 65 74 21 20 69 6e 70 75 74 2d .. (set! input-
13e0: 66 20 28 6c 61 6d 62 64 61 20 28 29 20 27 65 6f f (lambda () 'eo
13f0: 66 29 29 0a 09 09 09 20 20 23 66 29 29 29 29 29 f)).... #f)))))
1400: 29 0a 09 20 20 20 28 67 65 74 2d 73 74 61 72 74 ).. (get-start
1410: 2d 65 6e 64 2d 74 65 78 74 20 20 20 20 20 20 20 -end-text
1420: 20 20 20 20 3b 20 4f 62 74 65 6e 74 69 6f 6e 20 ; Obtention
1430: 64 75 20 6c 65 78 65 6d 65 0a 09 20 20 20 20 28 du lexeme.. (
1440: 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 lambda ()..
1450: 20 28 73 75 62 73 74 72 69 6e 67 20 62 75 66 66 (substring buff
1460: 65 72 20 73 74 61 72 74 2d 70 74 72 20 65 6e 64 er start-ptr end
1470: 2d 70 74 72 29 29 29 0a 09 20 20 20 28 67 65 74 -ptr))).. (get
1480: 2d 75 73 65 72 2d 6c 69 6e 65 2d 6c 69 6e 65 20 -user-line-line
1490: 20 20 20 20 20 20 20 20 20 20 3b 20 46 6f 6e 63 ; Fonc
14a0: 74 69 6f 6e 73 20 70 6f 75 72 20 6c 27 75 73 61 tions pour l'usa
14b0: 67 65 72 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 ger.. (lambda
14c0: 20 28 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 ().. (if (
14d0: 3c 20 75 73 65 72 2d 70 74 72 20 73 74 61 72 74 < user-ptr start
14e0: 2d 70 74 72 29 0a 09 09 20 20 28 75 73 65 72 2d -ptr)... (user-
14f0: 67 6f 2d 74 6f 2d 73 74 61 72 74 2d 6c 69 6e 65 go-to-start-line
1500: 29 29 0a 09 20 20 20 20 20 20 75 73 65 72 2d 6c )).. user-l
1510: 69 6e 65 29 29 0a 09 20 20 20 28 67 65 74 2d 75 ine)).. (get-u
1520: 73 65 72 2d 6c 69 6e 65 2d 61 6c 6c 0a 09 20 20 ser-line-all..
1530: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 (lambda ()..
1540: 20 20 20 20 28 69 66 20 28 3c 20 75 73 65 72 2d (if (< user-
1550: 70 74 72 20 73 74 61 72 74 2d 70 74 72 29 0a 09 ptr start-ptr)..
1560: 09 20 20 28 75 73 65 72 2d 67 6f 2d 74 6f 2d 73 . (user-go-to-s
1570: 74 61 72 74 2d 61 6c 6c 29 29 0a 09 20 20 20 20 tart-all))..
1580: 20 20 75 73 65 72 2d 6c 69 6e 65 29 29 0a 09 20 user-line))..
1590: 20 20 28 67 65 74 2d 75 73 65 72 2d 63 6f 6c 75 (get-user-colu
15a0: 6d 6e 2d 61 6c 6c 0a 09 20 20 20 20 28 6c 61 6d mn-all.. (lam
15b0: 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 63 bda ().. (c
15c0: 6f 6e 64 20 28 28 3c 20 75 73 65 72 2d 70 74 72 ond ((< user-ptr
15d0: 20 73 74 61 72 74 2d 70 74 72 29 0a 09 09 20 20 start-ptr)...
15e0: 20 20 20 28 75 73 65 72 2d 67 6f 2d 74 6f 2d 73 (user-go-to-s
15f0: 74 61 72 74 2d 61 6c 6c 29 0a 09 09 20 20 20 20 tart-all)...
1600: 20 75 73 65 72 2d 63 6f 6c 75 6d 6e 29 0a 09 09 user-column)...
1610: 20 20 20 20 28 75 73 65 72 2d 75 70 2d 74 6f 2d (user-up-to-
1620: 64 61 74 65 3f 0a 09 09 20 20 20 20 20 75 73 65 date?... use
1630: 72 2d 63 6f 6c 75 6d 6e 29 0a 09 09 20 20 20 20 r-column)...
1640: 28 65 6c 73 65 0a 09 09 20 20 20 20 20 28 6c 65 (else... (le
1650: 74 20 6c 6f 6f 70 20 28 28 70 74 72 20 73 74 61 t loop ((ptr sta
1660: 72 74 2d 70 74 72 29 20 28 63 6f 6c 75 6d 6e 20 rt-ptr) (column
1670: 73 74 61 72 74 2d 63 6f 6c 75 6d 6e 29 29 0a 09 start-column))..
1680: 09 20 20 20 20 20 20 20 28 69 66 20 28 3d 20 70 . (if (= p
1690: 74 72 20 75 73 65 72 2d 70 74 72 29 0a 09 09 09 tr user-ptr)....
16a0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 (begin....
16b0: 20 20 28 73 65 74 21 20 75 73 65 72 2d 63 6f 6c (set! user-col
16c0: 75 6d 6e 20 63 6f 6c 75 6d 6e 29 0a 09 09 09 20 umn column)....
16d0: 20 20 20 20 28 73 65 74 21 20 75 73 65 72 2d 75 (set! user-u
16e0: 70 2d 74 6f 2d 64 61 74 65 3f 20 23 74 29 0a 09 p-to-date? #t)..
16f0: 09 09 20 20 20 20 20 63 6f 6c 75 6d 6e 29 0a 09 .. column)..
1700: 09 09 20 20 20 28 69 66 20 28 63 68 61 72 3d 3f .. (if (char=?
1710: 20 28 73 74 72 69 6e 67 2d 72 65 66 20 62 75 66 (string-ref buf
1720: 66 65 72 20 70 74 72 29 20 23 5c 6e 65 77 6c 69 fer ptr) #\newli
1730: 6e 65 29 0a 09 09 09 20 20 20 20 20 20 20 28 6c ne).... (l
1740: 6f 6f 70 20 28 2b 20 70 74 72 20 31 29 20 31 29 oop (+ ptr 1) 1)
1750: 0a 09 09 09 20 20 20 20 20 20 20 28 6c 6f 6f 70 .... (loop
1760: 20 28 2b 20 70 74 72 20 31 29 20 28 2b 20 63 6f (+ ptr 1) (+ co
1770: 6c 75 6d 6e 20 31 29 29 29 29 29 29 29 29 29 0a lumn 1))))))))).
1780: 09 20 20 20 28 67 65 74 2d 75 73 65 72 2d 6f 66 . (get-user-of
1790: 66 73 65 74 2d 61 6c 6c 0a 09 20 20 20 20 28 6c fset-all.. (l
17a0: 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 ambda ()..
17b0: 28 69 66 20 28 3c 20 75 73 65 72 2d 70 74 72 20 (if (< user-ptr
17c0: 73 74 61 72 74 2d 70 74 72 29 0a 09 09 20 20 28 start-ptr)... (
17d0: 75 73 65 72 2d 67 6f 2d 74 6f 2d 73 74 61 72 74 user-go-to-start
17e0: 2d 61 6c 6c 29 29 0a 09 20 20 20 20 20 20 75 73 -all)).. us
17f0: 65 72 2d 6f 66 66 73 65 74 29 29 0a 09 20 20 20 er-offset))..
1800: 28 75 73 65 72 2d 67 65 74 63 2d 6e 6f 6e 65 0a (user-getc-none.
1810: 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a . (lambda ().
1820: 09 20 20 20 20 20 20 28 69 66 20 28 3c 20 75 73 . (if (< us
1830: 65 72 2d 70 74 72 20 73 74 61 72 74 2d 70 74 72 er-ptr start-ptr
1840: 29 0a 09 09 20 20 28 75 73 65 72 2d 67 6f 2d 74 )... (user-go-t
1850: 6f 2d 73 74 61 72 74 2d 6e 6f 6e 65 29 29 0a 09 o-start-none))..
1860: 20 20 20 20 20 20 28 69 66 20 28 3c 20 75 73 65 (if (< use
1870: 72 2d 70 74 72 20 72 65 61 64 2d 70 74 72 29 0a r-ptr read-ptr).
1880: 09 09 20 20 28 6c 65 74 20 28 28 63 20 28 73 74 .. (let ((c (st
1890: 72 69 6e 67 2d 72 65 66 20 62 75 66 66 65 72 20 ring-ref buffer
18a0: 75 73 65 72 2d 70 74 72 29 29 29 0a 09 09 20 20 user-ptr)))...
18b0: 20 20 28 73 65 74 21 20 75 73 65 72 2d 70 74 72 (set! user-ptr
18c0: 20 28 2b 20 75 73 65 72 2d 70 74 72 20 31 29 29 (+ user-ptr 1))
18d0: 0a 09 09 20 20 20 20 63 29 0a 09 09 20 20 28 6c ... c)... (l
18e0: 65 74 20 28 28 63 20 28 69 6e 70 75 74 2d 66 29 et ((c (input-f)
18f0: 29 29 0a 09 09 20 20 20 20 28 69 66 20 28 63 68 ))... (if (ch
1900: 61 72 3f 20 63 29 0a 09 09 09 28 62 65 67 69 6e ar? c)....(begin
1910: 0a 09 09 09 20 20 28 69 66 20 28 3d 20 72 65 61 .... (if (= rea
1920: 64 2d 70 74 72 20 62 75 66 6c 65 6e 29 0a 09 09 d-ptr buflen)...
1930: 09 20 20 20 20 20 20 28 72 65 6f 72 67 61 6e 69 . (reorgani
1940: 7a 65 2d 62 75 66 66 65 72 29 29 0a 09 09 09 20 ze-buffer))....
1950: 20 28 73 74 72 69 6e 67 2d 73 65 74 21 20 62 75 (string-set! bu
1960: 66 66 65 72 20 75 73 65 72 2d 70 74 72 20 63 29 ffer user-ptr c)
1970: 0a 09 09 09 20 20 28 73 65 74 21 20 72 65 61 64 .... (set! read
1980: 2d 70 74 72 20 28 2b 20 72 65 61 64 2d 70 74 72 -ptr (+ read-ptr
1990: 20 31 29 29 0a 09 09 09 20 20 28 73 65 74 21 20 1)).... (set!
19a0: 75 73 65 72 2d 70 74 72 20 72 65 61 64 2d 70 74 user-ptr read-pt
19b0: 72 29 0a 09 09 09 20 20 63 29 0a 09 09 09 28 62 r).... c)....(b
19c0: 65 67 69 6e 0a 09 09 09 20 20 28 73 65 74 21 20 egin.... (set!
19d0: 69 6e 70 75 74 2d 66 20 28 6c 61 6d 62 64 61 20 input-f (lambda
19e0: 28 29 20 27 65 6f 66 29 29 0a 09 09 09 20 20 27 () 'eof)).... '
19f0: 65 6f 66 29 29 29 29 29 29 0a 09 20 20 20 28 75 eof)))))).. (u
1a00: 73 65 72 2d 67 65 74 63 2d 6c 69 6e 65 0a 09 20 ser-getc-line..
1a10: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 (lambda ()..
1a20: 20 20 20 20 20 28 69 66 20 28 3c 20 75 73 65 72 (if (< user
1a30: 2d 70 74 72 20 73 74 61 72 74 2d 70 74 72 29 0a -ptr start-ptr).
1a40: 09 09 20 20 28 75 73 65 72 2d 67 6f 2d 74 6f 2d .. (user-go-to-
1a50: 73 74 61 72 74 2d 6c 69 6e 65 29 29 0a 09 20 20 start-line))..
1a60: 20 20 20 20 28 69 66 20 28 3c 20 75 73 65 72 2d (if (< user-
1a70: 70 74 72 20 72 65 61 64 2d 70 74 72 29 0a 09 09 ptr read-ptr)...
1a80: 20 20 28 6c 65 74 20 28 28 63 20 28 73 74 72 69 (let ((c (stri
1a90: 6e 67 2d 72 65 66 20 62 75 66 66 65 72 20 75 73 ng-ref buffer us
1aa0: 65 72 2d 70 74 72 29 29 29 0a 09 09 20 20 20 20 er-ptr)))...
1ab0: 28 73 65 74 21 20 75 73 65 72 2d 70 74 72 20 28 (set! user-ptr (
1ac0: 2b 20 75 73 65 72 2d 70 74 72 20 31 29 29 0a 09 + user-ptr 1))..
1ad0: 09 20 20 20 20 28 69 66 20 28 63 68 61 72 3d 3f . (if (char=?
1ae0: 20 63 20 23 5c 6e 65 77 6c 69 6e 65 29 0a 09 09 c #\newline)...
1af0: 09 28 73 65 74 21 20 75 73 65 72 2d 6c 69 6e 65 .(set! user-line
1b00: 20 28 2b 20 75 73 65 72 2d 6c 69 6e 65 20 31 29 (+ user-line 1)
1b10: 29 29 0a 09 09 20 20 20 20 63 29 0a 09 09 20 20 ))... c)...
1b20: 28 6c 65 74 20 28 28 63 20 28 69 6e 70 75 74 2d (let ((c (input-
1b30: 66 29 29 29 0a 09 09 20 20 20 20 28 69 66 20 28 f)))... (if (
1b40: 63 68 61 72 3f 20 63 29 0a 09 09 09 28 62 65 67 char? c)....(beg
1b50: 69 6e 0a 09 09 09 20 20 28 69 66 20 28 3d 20 72 in.... (if (= r
1b60: 65 61 64 2d 70 74 72 20 62 75 66 6c 65 6e 29 0a ead-ptr buflen).
1b70: 09 09 09 20 20 20 20 20 20 28 72 65 6f 72 67 61 ... (reorga
1b80: 6e 69 7a 65 2d 62 75 66 66 65 72 29 29 0a 09 09 nize-buffer))...
1b90: 09 20 20 28 73 74 72 69 6e 67 2d 73 65 74 21 20 . (string-set!
1ba0: 62 75 66 66 65 72 20 75 73 65 72 2d 70 74 72 20 buffer user-ptr
1bb0: 63 29 0a 09 09 09 20 20 28 73 65 74 21 20 72 65 c).... (set! re
1bc0: 61 64 2d 70 74 72 20 28 2b 20 72 65 61 64 2d 70 ad-ptr (+ read-p
1bd0: 74 72 20 31 29 29 0a 09 09 09 20 20 28 73 65 74 tr 1)).... (set
1be0: 21 20 75 73 65 72 2d 70 74 72 20 72 65 61 64 2d ! user-ptr read-
1bf0: 70 74 72 29 0a 09 09 09 20 20 28 69 66 20 28 63 ptr).... (if (c
1c00: 68 61 72 3d 3f 20 63 20 23 5c 6e 65 77 6c 69 6e har=? c #\newlin
1c10: 65 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 e).... (set
1c20: 21 20 75 73 65 72 2d 6c 69 6e 65 20 28 2b 20 75 ! user-line (+ u
1c30: 73 65 72 2d 6c 69 6e 65 20 31 29 29 29 0a 09 09 ser-line 1)))...
1c40: 09 20 20 63 29 0a 09 09 09 28 62 65 67 69 6e 0a . c)....(begin.
1c50: 09 09 09 20 20 28 73 65 74 21 20 69 6e 70 75 74 ... (set! input
1c60: 2d 66 20 28 6c 61 6d 62 64 61 20 28 29 20 27 65 -f (lambda () 'e
1c70: 6f 66 29 29 0a 09 09 09 20 20 27 65 6f 66 29 29 of)).... 'eof))
1c80: 29 29 29 29 0a 09 20 20 20 28 75 73 65 72 2d 67 )))).. (user-g
1c90: 65 74 63 2d 61 6c 6c 0a 09 20 20 20 20 28 6c 61 etc-all.. (la
1ca0: 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 mbda ().. (
1cb0: 69 66 20 28 3c 20 75 73 65 72 2d 70 74 72 20 73 if (< user-ptr s
1cc0: 74 61 72 74 2d 70 74 72 29 0a 09 09 20 20 28 75 tart-ptr)... (u
1cd0: 73 65 72 2d 67 6f 2d 74 6f 2d 73 74 61 72 74 2d ser-go-to-start-
1ce0: 61 6c 6c 29 29 0a 09 20 20 20 20 20 20 28 69 66 all)).. (if
1cf0: 20 28 3c 20 75 73 65 72 2d 70 74 72 20 72 65 61 (< user-ptr rea
1d00: 64 2d 70 74 72 29 0a 09 09 20 20 28 6c 65 74 20 d-ptr)... (let
1d10: 28 28 63 20 28 73 74 72 69 6e 67 2d 72 65 66 20 ((c (string-ref
1d20: 62 75 66 66 65 72 20 75 73 65 72 2d 70 74 72 29 buffer user-ptr)
1d30: 29 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 75 ))... (set! u
1d40: 73 65 72 2d 70 74 72 20 28 2b 20 75 73 65 72 2d ser-ptr (+ user-
1d50: 70 74 72 20 31 29 29 0a 09 09 20 20 20 20 28 69 ptr 1))... (i
1d60: 66 20 28 63 68 61 72 3d 3f 20 63 20 23 5c 6e 65 f (char=? c #\ne
1d70: 77 6c 69 6e 65 29 0a 09 09 09 28 62 65 67 69 6e wline)....(begin
1d80: 0a 09 09 09 20 20 28 73 65 74 21 20 75 73 65 72 .... (set! user
1d90: 2d 6c 69 6e 65 20 28 2b 20 75 73 65 72 2d 6c 69 -line (+ user-li
1da0: 6e 65 20 31 29 29 0a 09 09 09 20 20 28 73 65 74 ne 1)).... (set
1db0: 21 20 75 73 65 72 2d 63 6f 6c 75 6d 6e 20 31 29 ! user-column 1)
1dc0: 29 0a 09 09 09 28 73 65 74 21 20 75 73 65 72 2d )....(set! user-
1dd0: 63 6f 6c 75 6d 6e 20 28 2b 20 75 73 65 72 2d 63 column (+ user-c
1de0: 6f 6c 75 6d 6e 20 31 29 29 29 0a 09 09 20 20 20 olumn 1)))...
1df0: 20 28 73 65 74 21 20 75 73 65 72 2d 6f 66 66 73 (set! user-offs
1e00: 65 74 20 28 2b 20 75 73 65 72 2d 6f 66 66 73 65 et (+ user-offse
1e10: 74 20 31 29 29 0a 09 09 20 20 20 20 63 29 0a 09 t 1))... c)..
1e20: 09 20 20 28 6c 65 74 20 28 28 63 20 28 69 6e 70 . (let ((c (inp
1e30: 75 74 2d 66 29 29 29 0a 09 09 20 20 20 20 28 69 ut-f)))... (i
1e40: 66 20 28 63 68 61 72 3f 20 63 29 0a 09 09 09 28 f (char? c)....(
1e50: 62 65 67 69 6e 0a 09 09 09 20 20 28 69 66 20 28 begin.... (if (
1e60: 3d 20 72 65 61 64 2d 70 74 72 20 62 75 66 6c 65 = read-ptr bufle
1e70: 6e 29 0a 09 09 09 20 20 20 20 20 20 28 72 65 6f n).... (reo
1e80: 72 67 61 6e 69 7a 65 2d 62 75 66 66 65 72 29 29 rganize-buffer))
1e90: 0a 09 09 09 20 20 28 73 74 72 69 6e 67 2d 73 65 .... (string-se
1ea0: 74 21 20 62 75 66 66 65 72 20 75 73 65 72 2d 70 t! buffer user-p
1eb0: 74 72 20 63 29 0a 09 09 09 20 20 28 73 65 74 21 tr c).... (set!
1ec0: 20 72 65 61 64 2d 70 74 72 20 28 2b 20 72 65 61 read-ptr (+ rea
1ed0: 64 2d 70 74 72 20 31 29 29 0a 09 09 09 20 20 28 d-ptr 1)).... (
1ee0: 73 65 74 21 20 75 73 65 72 2d 70 74 72 20 72 65 set! user-ptr re
1ef0: 61 64 2d 70 74 72 29 0a 09 09 09 20 20 28 69 66 ad-ptr).... (if
1f00: 20 28 63 68 61 72 3d 3f 20 63 20 23 5c 6e 65 77 (char=? c #\new
1f10: 6c 69 6e 65 29 0a 09 09 09 20 20 20 20 20 20 28 line).... (
1f20: 62 65 67 69 6e 0a 09 09 09 09 28 73 65 74 21 20 begin.....(set!
1f30: 75 73 65 72 2d 6c 69 6e 65 20 28 2b 20 75 73 65 user-line (+ use
1f40: 72 2d 6c 69 6e 65 20 31 29 29 0a 09 09 09 09 28 r-line 1)).....(
1f50: 73 65 74 21 20 75 73 65 72 2d 63 6f 6c 75 6d 6e set! user-column
1f60: 20 31 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 1)).... (s
1f70: 65 74 21 20 75 73 65 72 2d 63 6f 6c 75 6d 6e 20 et! user-column
1f80: 28 2b 20 75 73 65 72 2d 63 6f 6c 75 6d 6e 20 31 (+ user-column 1
1f90: 29 29 29 0a 09 09 09 20 20 28 73 65 74 21 20 75 ))).... (set! u
1fa0: 73 65 72 2d 6f 66 66 73 65 74 20 28 2b 20 75 73 ser-offset (+ us
1fb0: 65 72 2d 6f 66 66 73 65 74 20 31 29 29 0a 09 09 er-offset 1))...
1fc0: 09 20 20 63 29 0a 09 09 09 28 62 65 67 69 6e 0a . c)....(begin.
1fd0: 09 09 09 20 20 28 73 65 74 21 20 69 6e 70 75 74 ... (set! input
1fe0: 2d 66 20 28 6c 61 6d 62 64 61 20 28 29 20 27 65 -f (lambda () 'e
1ff0: 6f 66 29 29 0a 09 09 09 20 20 27 65 6f 66 29 29 of)).... 'eof))
2000: 29 29 29 29 0a 09 20 20 20 28 75 73 65 72 2d 75 )))).. (user-u
2010: 6e 67 65 74 63 2d 6e 6f 6e 65 0a 09 20 20 20 20 ngetc-none..
2020: 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 (lambda ()..
2030: 20 20 28 69 66 20 28 3e 20 75 73 65 72 2d 70 74 (if (> user-pt
2040: 72 20 73 74 61 72 74 2d 70 74 72 29 0a 09 09 20 r start-ptr)...
2050: 20 28 73 65 74 21 20 75 73 65 72 2d 70 74 72 20 (set! user-ptr
2060: 28 2d 20 75 73 65 72 2d 70 74 72 20 31 29 29 29 (- user-ptr 1)))
2070: 29 29 0a 09 20 20 20 28 75 73 65 72 2d 75 6e 67 )).. (user-ung
2080: 65 74 63 2d 6c 69 6e 65 0a 09 20 20 20 20 28 6c etc-line.. (l
2090: 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 ambda ()..
20a0: 28 69 66 20 28 3e 20 75 73 65 72 2d 70 74 72 20 (if (> user-ptr
20b0: 73 74 61 72 74 2d 70 74 72 29 0a 09 09 20 20 28 start-ptr)... (
20c0: 62 65 67 69 6e 0a 09 09 20 20 20 20 28 73 65 74 begin... (set
20d0: 21 20 75 73 65 72 2d 70 74 72 20 28 2d 20 75 73 ! user-ptr (- us
20e0: 65 72 2d 70 74 72 20 31 29 29 0a 09 09 20 20 20 er-ptr 1))...
20f0: 20 28 6c 65 74 20 28 28 63 20 28 73 74 72 69 6e (let ((c (strin
2100: 67 2d 72 65 66 20 62 75 66 66 65 72 20 75 73 65 g-ref buffer use
2110: 72 2d 70 74 72 29 29 29 0a 09 09 20 20 20 20 20 r-ptr)))...
2120: 20 28 69 66 20 28 63 68 61 72 3d 3f 20 63 20 23 (if (char=? c #
2130: 5c 6e 65 77 6c 69 6e 65 29 0a 09 09 09 20 20 28 \newline).... (
2140: 73 65 74 21 20 75 73 65 72 2d 6c 69 6e 65 20 28 set! user-line (
2150: 2d 20 75 73 65 72 2d 6c 69 6e 65 20 31 29 29 29 - user-line 1)))
2160: 29 29 29 29 29 0a 09 20 20 20 28 75 73 65 72 2d ))))).. (user-
2170: 75 6e 67 65 74 63 2d 61 6c 6c 0a 09 20 20 20 20 ungetc-all..
2180: 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 (lambda ()..
2190: 20 20 28 69 66 20 28 3e 20 75 73 65 72 2d 70 74 (if (> user-pt
21a0: 72 20 73 74 61 72 74 2d 70 74 72 29 0a 09 09 20 r start-ptr)...
21b0: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 73 (begin... (s
21c0: 65 74 21 20 75 73 65 72 2d 70 74 72 20 28 2d 20 et! user-ptr (-
21d0: 75 73 65 72 2d 70 74 72 20 31 29 29 0a 09 09 20 user-ptr 1))...
21e0: 20 20 20 28 6c 65 74 20 28 28 63 20 28 73 74 72 (let ((c (str
21f0: 69 6e 67 2d 72 65 66 20 62 75 66 66 65 72 20 75 ing-ref buffer u
2200: 73 65 72 2d 70 74 72 29 29 29 0a 09 09 20 20 20 ser-ptr)))...
2210: 20 20 20 28 69 66 20 28 63 68 61 72 3d 3f 20 63 (if (char=? c
2220: 20 23 5c 6e 65 77 6c 69 6e 65 29 0a 09 09 09 20 #\newline)....
2230: 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 28 (begin.... (
2240: 73 65 74 21 20 75 73 65 72 2d 6c 69 6e 65 20 28 set! user-line (
2250: 2d 20 75 73 65 72 2d 6c 69 6e 65 20 31 29 29 0a - user-line 1)).
2260: 09 09 09 20 20 20 20 28 73 65 74 21 20 75 73 65 ... (set! use
2270: 72 2d 75 70 2d 74 6f 2d 64 61 74 65 3f 20 23 66 r-up-to-date? #f
2280: 29 29 0a 09 09 09 20 20 28 73 65 74 21 20 75 73 )).... (set! us
2290: 65 72 2d 63 6f 6c 75 6d 6e 20 28 2d 20 75 73 65 er-column (- use
22a0: 72 2d 63 6f 6c 75 6d 6e 20 31 29 29 29 0a 09 09 r-column 1)))...
22b0: 20 20 20 20 20 20 28 73 65 74 21 20 75 73 65 72 (set! user
22c0: 2d 6f 66 66 73 65 74 20 28 2d 20 75 73 65 72 2d -offset (- user-
22d0: 6f 66 66 73 65 74 20 31 29 29 29 29 29 29 29 0a offset 1))))))).
22e0: 09 20 20 20 28 72 65 6f 72 67 61 6e 69 7a 65 2d . (reorganize-
22f0: 62 75 66 66 65 72 20 20 20 20 20 20 20 20 20 20 buffer
2300: 20 20 3b 20 44 65 63 61 6c 65 72 20 6f 75 20 61 ; Decaler ou a
2310: 67 72 61 6e 64 69 72 20 6c 65 20 62 75 66 66 65 grandir le buffe
2320: 72 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 r.. (lambda (
2330: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3c 20 ).. (if (<
2340: 28 2a 20 32 20 73 74 61 72 74 2d 70 74 72 29 20 (* 2 start-ptr)
2350: 62 75 66 6c 65 6e 29 0a 09 09 20 20 28 6c 65 74 buflen)... (let
2360: 2a 20 28 28 6e 65 77 6c 65 6e 20 28 2a 20 32 20 * ((newlen (* 2
2370: 62 75 66 6c 65 6e 29 29 0a 09 09 09 20 28 6e 65 buflen)).... (ne
2380: 77 62 75 66 20 28 6d 61 6b 65 2d 73 74 72 69 6e wbuf (make-strin
2390: 67 20 6e 65 77 6c 65 6e 29 29 0a 09 09 09 20 28 g newlen)).... (
23a0: 64 65 6c 74 61 20 28 2d 20 73 74 61 72 74 2d 70 delta (- start-p
23b0: 74 72 20 31 29 29 29 0a 09 09 20 20 20 20 28 6c tr 1)))... (l
23c0: 65 74 20 6c 6f 6f 70 20 28 28 66 72 6f 6d 20 28 et loop ((from (
23d0: 2d 20 73 74 61 72 74 2d 70 74 72 20 31 29 29 29 - start-ptr 1)))
23e0: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 3c 20 ... (if (<
23f0: 66 72 6f 6d 20 62 75 66 6c 65 6e 29 0a 09 09 09 from buflen)....
2400: 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 (begin....
2410: 28 73 74 72 69 6e 67 2d 73 65 74 21 20 6e 65 77 (string-set! new
2420: 62 75 66 0a 09 09 09 09 09 20 28 2d 20 66 72 6f buf...... (- fro
2430: 6d 20 64 65 6c 74 61 29 0a 09 09 09 09 09 20 28 m delta)...... (
2440: 73 74 72 69 6e 67 2d 72 65 66 20 62 75 66 66 65 string-ref buffe
2450: 72 20 66 72 6f 6d 29 29 0a 09 09 09 20 20 20 20 r from))....
2460: 28 6c 6f 6f 70 20 28 2b 20 66 72 6f 6d 20 31 29 (loop (+ from 1)
2470: 29 29 29 29 0a 09 09 20 20 20 20 28 73 65 74 21 ))))... (set!
2480: 20 62 75 66 66 65 72 20 20 20 20 6e 65 77 62 75 buffer newbu
2490: 66 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 62 f)... (set! b
24a0: 75 66 6c 65 6e 20 20 20 20 6e 65 77 6c 65 6e 29 uflen newlen)
24b0: 0a 09 09 20 20 20 20 28 73 65 74 21 20 72 65 61 ... (set! rea
24c0: 64 2d 70 74 72 20 20 28 2d 20 72 65 61 64 2d 70 d-ptr (- read-p
24d0: 74 72 20 64 65 6c 74 61 29 29 0a 09 09 20 20 20 tr delta))...
24e0: 20 28 73 65 74 21 20 73 74 61 72 74 2d 70 74 72 (set! start-ptr
24f0: 20 28 2d 20 73 74 61 72 74 2d 70 74 72 20 64 65 (- start-ptr de
2500: 6c 74 61 29 29 0a 09 09 20 20 20 20 28 73 65 74 lta))... (set
2510: 21 20 65 6e 64 2d 70 74 72 20 20 20 28 2d 20 65 ! end-ptr (- e
2520: 6e 64 2d 70 74 72 20 64 65 6c 74 61 29 29 0a 09 nd-ptr delta))..
2530: 09 20 20 20 20 28 73 65 74 21 20 70 6f 69 6e 74 . (set! point
2540: 2d 70 74 72 20 28 2d 20 70 6f 69 6e 74 2d 70 74 -ptr (- point-pt
2550: 72 20 64 65 6c 74 61 29 29 0a 09 09 20 20 20 20 r delta))...
2560: 28 73 65 74 21 20 75 73 65 72 2d 70 74 72 20 20 (set! user-ptr
2570: 28 2d 20 75 73 65 72 2d 70 74 72 20 64 65 6c 74 (- user-ptr delt
2580: 61 29 29 29 0a 09 09 20 20 28 6c 65 74 20 28 28 a)))... (let ((
2590: 64 65 6c 74 61 20 28 2d 20 73 74 61 72 74 2d 70 delta (- start-p
25a0: 74 72 20 31 29 29 29 0a 09 09 20 20 20 20 28 6c tr 1)))... (l
25b0: 65 74 20 6c 6f 6f 70 20 28 28 66 72 6f 6d 20 28 et loop ((from (
25c0: 2d 20 73 74 61 72 74 2d 70 74 72 20 31 29 29 29 - start-ptr 1)))
25d0: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 3c 20 ... (if (<
25e0: 66 72 6f 6d 20 62 75 66 6c 65 6e 29 0a 09 09 09 from buflen)....
25f0: 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 (begin....
2600: 28 73 74 72 69 6e 67 2d 73 65 74 21 20 62 75 66 (string-set! buf
2610: 66 65 72 0a 09 09 09 09 09 20 28 2d 20 66 72 6f fer...... (- fro
2620: 6d 20 64 65 6c 74 61 29 0a 09 09 09 09 09 20 28 m delta)...... (
2630: 73 74 72 69 6e 67 2d 72 65 66 20 62 75 66 66 65 string-ref buffe
2640: 72 20 66 72 6f 6d 29 29 0a 09 09 09 20 20 20 20 r from))....
2650: 28 6c 6f 6f 70 20 28 2b 20 66 72 6f 6d 20 31 29 (loop (+ from 1)
2660: 29 29 29 29 0a 09 09 20 20 20 20 28 73 65 74 21 ))))... (set!
2670: 20 72 65 61 64 2d 70 74 72 20 20 28 2d 20 72 65 read-ptr (- re
2680: 61 64 2d 70 74 72 20 64 65 6c 74 61 29 29 0a 09 ad-ptr delta))..
2690: 09 20 20 20 20 28 73 65 74 21 20 73 74 61 72 74 . (set! start
26a0: 2d 70 74 72 20 28 2d 20 73 74 61 72 74 2d 70 74 -ptr (- start-pt
26b0: 72 20 64 65 6c 74 61 29 29 0a 09 09 20 20 20 20 r delta))...
26c0: 28 73 65 74 21 20 65 6e 64 2d 70 74 72 20 20 20 (set! end-ptr
26d0: 28 2d 20 65 6e 64 2d 70 74 72 20 64 65 6c 74 61 (- end-ptr delta
26e0: 29 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 70 ))... (set! p
26f0: 6f 69 6e 74 2d 70 74 72 20 28 2d 20 70 6f 69 6e oint-ptr (- poin
2700: 74 2d 70 74 72 20 64 65 6c 74 61 29 29 0a 09 09 t-ptr delta))...
2710: 20 20 20 20 28 73 65 74 21 20 75 73 65 72 2d 70 (set! user-p
2720: 74 72 20 20 28 2d 20 75 73 65 72 2d 70 74 72 20 tr (- user-ptr
2730: 64 65 6c 74 61 29 29 29 29 29 29 29 0a 09 28 6c delta)))))))..(l
2740: 69 73 74 20 28 63 6f 6e 73 20 27 73 74 61 72 74 ist (cons 'start
2750: 2d 67 6f 2d 74 6f 2d 65 6e 64 0a 09 09 20 20 20 -go-to-end...
2760: 20 28 63 6f 6e 64 20 28 28 65 71 3f 20 63 6f 75 (cond ((eq? cou
2770: 6e 74 65 72 73 20 27 6e 6f 6e 65 29 20 73 74 61 nters 'none) sta
2780: 72 74 2d 67 6f 2d 74 6f 2d 65 6e 64 2d 6e 6f 6e rt-go-to-end-non
2790: 65 29 0a 09 09 09 20 20 28 28 65 71 3f 20 63 6f e).... ((eq? co
27a0: 75 6e 74 65 72 73 20 27 6c 69 6e 65 29 20 73 74 unters 'line) st
27b0: 61 72 74 2d 67 6f 2d 74 6f 2d 65 6e 64 2d 6c 69 art-go-to-end-li
27c0: 6e 65 29 0a 09 09 09 20 20 28 28 65 71 3f 20 63 ne).... ((eq? c
27d0: 6f 75 6e 74 65 72 73 20 27 61 6c 6c 20 29 20 73 ounters 'all ) s
27e0: 74 61 72 74 2d 67 6f 2d 74 6f 2d 65 6e 64 2d 61 tart-go-to-end-a
27f0: 6c 6c 29 29 29 0a 09 20 20 20 20 20 20 28 63 6f ll))).. (co
2800: 6e 73 20 27 65 6e 64 2d 67 6f 2d 74 6f 2d 70 6f ns 'end-go-to-po
2810: 69 6e 74 0a 09 09 20 20 20 20 65 6e 64 2d 67 6f int... end-go
2820: 2d 74 6f 2d 70 6f 69 6e 74 29 0a 09 20 20 20 20 -to-point)..
2830: 20 20 28 63 6f 6e 73 20 27 69 6e 69 74 2d 6c 65 (cons 'init-le
2840: 78 65 6d 65 0a 09 09 20 20 20 20 28 63 6f 6e 64 xeme... (cond
2850: 20 28 28 65 71 3f 20 63 6f 75 6e 74 65 72 73 20 ((eq? counters
2860: 27 6e 6f 6e 65 29 20 69 6e 69 74 2d 6c 65 78 65 'none) init-lexe
2870: 6d 65 2d 6e 6f 6e 65 29 0a 09 09 09 20 20 28 28 me-none).... ((
2880: 65 71 3f 20 63 6f 75 6e 74 65 72 73 20 27 6c 69 eq? counters 'li
2890: 6e 65 29 20 69 6e 69 74 2d 6c 65 78 65 6d 65 2d ne) init-lexeme-
28a0: 6c 69 6e 65 29 0a 09 09 09 20 20 28 28 65 71 3f line).... ((eq?
28b0: 20 63 6f 75 6e 74 65 72 73 20 27 61 6c 6c 20 29 counters 'all )
28c0: 20 69 6e 69 74 2d 6c 65 78 65 6d 65 2d 61 6c 6c init-lexeme-all
28d0: 29 29 29 0a 09 20 20 20 20 20 20 28 63 6f 6e 73 ))).. (cons
28e0: 20 27 67 65 74 2d 73 74 61 72 74 2d 6c 69 6e 65 'get-start-line
28f0: 0a 09 09 20 20 20 20 67 65 74 2d 73 74 61 72 74 ... get-start
2900: 2d 6c 69 6e 65 29 0a 09 20 20 20 20 20 20 28 63 -line).. (c
2910: 6f 6e 73 20 27 67 65 74 2d 73 74 61 72 74 2d 63 ons 'get-start-c
2920: 6f 6c 75 6d 6e 0a 09 09 20 20 20 20 67 65 74 2d olumn... get-
2930: 73 74 61 72 74 2d 63 6f 6c 75 6d 6e 29 0a 09 20 start-column)..
2940: 20 20 20 20 20 28 63 6f 6e 73 20 27 67 65 74 2d (cons 'get-
2950: 73 74 61 72 74 2d 6f 66 66 73 65 74 0a 09 09 20 start-offset...
2960: 20 20 20 67 65 74 2d 73 74 61 72 74 2d 6f 66 66 get-start-off
2970: 73 65 74 29 0a 09 20 20 20 20 20 20 28 63 6f 6e set).. (con
2980: 73 20 27 70 65 65 6b 2d 6c 65 66 74 2d 63 6f 6e s 'peek-left-con
2990: 74 65 78 74 0a 09 09 20 20 20 20 70 65 65 6b 2d text... peek-
29a0: 6c 65 66 74 2d 63 6f 6e 74 65 78 74 29 0a 09 20 left-context)..
29b0: 20 20 20 20 20 28 63 6f 6e 73 20 27 70 65 65 6b (cons 'peek
29c0: 2d 63 68 61 72 0a 09 09 20 20 20 20 70 65 65 6b -char... peek
29d0: 2d 63 68 61 72 29 0a 09 20 20 20 20 20 20 28 63 -char).. (c
29e0: 6f 6e 73 20 27 72 65 61 64 2d 63 68 61 72 0a 09 ons 'read-char..
29f0: 09 20 20 20 20 72 65 61 64 2d 63 68 61 72 29 0a . read-char).
2a00: 09 20 20 20 20 20 20 28 63 6f 6e 73 20 27 67 65 . (cons 'ge
2a10: 74 2d 73 74 61 72 74 2d 65 6e 64 2d 74 65 78 74 t-start-end-text
2a20: 0a 09 09 20 20 20 20 67 65 74 2d 73 74 61 72 74 ... get-start
2a30: 2d 65 6e 64 2d 74 65 78 74 29 0a 09 20 20 20 20 -end-text)..
2a40: 20 20 28 63 6f 6e 73 20 27 67 65 74 2d 75 73 65 (cons 'get-use
2a50: 72 2d 6c 69 6e 65 0a 09 09 20 20 20 20 28 63 6f r-line... (co
2a60: 6e 64 20 28 28 65 71 3f 20 63 6f 75 6e 74 65 72 nd ((eq? counter
2a70: 73 20 27 6e 6f 6e 65 29 20 23 66 29 0a 09 09 09 s 'none) #f)....
2a80: 20 20 28 28 65 71 3f 20 63 6f 75 6e 74 65 72 73 ((eq? counters
2a90: 20 27 6c 69 6e 65 29 20 67 65 74 2d 75 73 65 72 'line) get-user
2aa0: 2d 6c 69 6e 65 2d 6c 69 6e 65 29 0a 09 09 09 20 -line-line)....
2ab0: 20 28 28 65 71 3f 20 63 6f 75 6e 74 65 72 73 20 ((eq? counters
2ac0: 27 61 6c 6c 20 29 20 67 65 74 2d 75 73 65 72 2d 'all ) get-user-
2ad0: 6c 69 6e 65 2d 61 6c 6c 29 29 29 0a 09 20 20 20 line-all)))..
2ae0: 20 20 20 28 63 6f 6e 73 20 27 67 65 74 2d 75 73 (cons 'get-us
2af0: 65 72 2d 63 6f 6c 75 6d 6e 0a 09 09 20 20 20 20 er-column...
2b00: 28 63 6f 6e 64 20 28 28 65 71 3f 20 63 6f 75 6e (cond ((eq? coun
2b10: 74 65 72 73 20 27 6e 6f 6e 65 29 20 23 66 29 0a ters 'none) #f).
2b20: 09 09 09 20 20 28 28 65 71 3f 20 63 6f 75 6e 74 ... ((eq? count
2b30: 65 72 73 20 27 6c 69 6e 65 29 20 23 66 29 0a 09 ers 'line) #f)..
2b40: 09 09 20 20 28 28 65 71 3f 20 63 6f 75 6e 74 65 .. ((eq? counte
2b50: 72 73 20 27 61 6c 6c 20 29 20 67 65 74 2d 75 73 rs 'all ) get-us
2b60: 65 72 2d 63 6f 6c 75 6d 6e 2d 61 6c 6c 29 29 29 er-column-all)))
2b70: 0a 09 20 20 20 20 20 20 28 63 6f 6e 73 20 27 67 .. (cons 'g
2b80: 65 74 2d 75 73 65 72 2d 6f 66 66 73 65 74 0a 09 et-user-offset..
2b90: 09 20 20 20 20 28 63 6f 6e 64 20 28 28 65 71 3f . (cond ((eq?
2ba0: 20 63 6f 75 6e 74 65 72 73 20 27 6e 6f 6e 65 29 counters 'none)
2bb0: 20 23 66 29 0a 09 09 09 20 20 28 28 65 71 3f 20 #f).... ((eq?
2bc0: 63 6f 75 6e 74 65 72 73 20 27 6c 69 6e 65 29 20 counters 'line)
2bd0: 23 66 29 0a 09 09 09 20 20 28 28 65 71 3f 20 63 #f).... ((eq? c
2be0: 6f 75 6e 74 65 72 73 20 27 61 6c 6c 20 29 20 67 ounters 'all ) g
2bf0: 65 74 2d 75 73 65 72 2d 6f 66 66 73 65 74 2d 61 et-user-offset-a
2c00: 6c 6c 29 29 29 0a 09 20 20 20 20 20 20 28 63 6f ll))).. (co
2c10: 6e 73 20 27 75 73 65 72 2d 67 65 74 63 0a 09 09 ns 'user-getc...
2c20: 20 20 20 20 28 63 6f 6e 64 20 28 28 65 71 3f 20 (cond ((eq?
2c30: 63 6f 75 6e 74 65 72 73 20 27 6e 6f 6e 65 29 20 counters 'none)
2c40: 75 73 65 72 2d 67 65 74 63 2d 6e 6f 6e 65 29 0a user-getc-none).
2c50: 09 09 09 20 20 28 28 65 71 3f 20 63 6f 75 6e 74 ... ((eq? count
2c60: 65 72 73 20 27 6c 69 6e 65 29 20 75 73 65 72 2d ers 'line) user-
2c70: 67 65 74 63 2d 6c 69 6e 65 29 0a 09 09 09 20 20 getc-line)....
2c80: 28 28 65 71 3f 20 63 6f 75 6e 74 65 72 73 20 27 ((eq? counters '
2c90: 61 6c 6c 20 29 20 75 73 65 72 2d 67 65 74 63 2d all ) user-getc-
2ca0: 61 6c 6c 29 29 29 0a 09 20 20 20 20 20 20 28 63 all))).. (c
2cb0: 6f 6e 73 20 27 75 73 65 72 2d 75 6e 67 65 74 63 ons 'user-ungetc
2cc0: 0a 09 09 20 20 20 20 28 63 6f 6e 64 20 28 28 65 ... (cond ((e
2cd0: 71 3f 20 63 6f 75 6e 74 65 72 73 20 27 6e 6f 6e q? counters 'non
2ce0: 65 29 20 75 73 65 72 2d 75 6e 67 65 74 63 2d 6e e) user-ungetc-n
2cf0: 6f 6e 65 29 0a 09 09 09 20 20 28 28 65 71 3f 20 one).... ((eq?
2d00: 63 6f 75 6e 74 65 72 73 20 27 6c 69 6e 65 29 20 counters 'line)
2d10: 75 73 65 72 2d 75 6e 67 65 74 63 2d 6c 69 6e 65 user-ungetc-line
2d20: 29 0a 09 09 09 20 20 28 28 65 71 3f 20 63 6f 75 ).... ((eq? cou
2d30: 6e 74 65 72 73 20 27 61 6c 6c 20 29 20 75 73 65 nters 'all ) use
2d40: 72 2d 75 6e 67 65 74 63 2d 61 6c 6c 29 29 29 29 r-ungetc-all))))
2d50: 29 29 29 29 0a 0a 3b 20 43 6f 6e 73 74 72 75 69 ))))..; Construi
2d60: 74 20 75 6e 20 49 6e 70 75 74 20 53 79 73 74 65 t un Input Syste
2d70: 6d 0a 3b 20 4c 65 20 70 72 65 6d 69 65 72 20 70 m.; Le premier p
2d80: 61 72 61 6d 65 74 72 65 20 64 6f 69 74 20 65 74 arametre doit et
2d90: 72 65 20 70 61 72 6d 69 20 22 70 6f 72 74 22 2c re parmi "port",
2da0: 20 22 70 72 6f 63 65 64 75 72 65 22 20 6f 75 20 "procedure" ou
2db0: 22 73 74 72 69 6e 67 22 0a 3b 20 50 72 65 6e 64 "string".; Prend
2dc0: 20 75 6e 20 70 61 72 61 6d 65 74 72 65 20 66 61 un parametre fa
2dd0: 63 75 6c 74 61 74 69 66 20 71 75 69 20 64 6f 69 cultatif qui doi
2de0: 74 20 65 74 72 65 20 70 61 72 6d 69 0a 3b 20 22 t etre parmi.; "
2df0: 6e 6f 6e 65 22 2c 20 22 6c 69 6e 65 22 20 6f 75 none", "line" ou
2e00: 20 22 61 6c 6c 22 0a 28 64 65 66 69 6e 65 20 6c "all".(define l
2e10: 65 78 65 72 2d 6d 61 6b 65 2d 49 53 0a 20 20 28 exer-make-IS. (
2e20: 6c 61 6d 62 64 61 20 28 69 6e 70 75 74 2d 74 79 lambda (input-ty
2e30: 70 65 20 69 6e 70 75 74 20 2e 20 6c 61 72 67 73 pe input . largs
2e40: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 63 6f 75 ). (let ((cou
2e50: 6e 74 65 72 73 2d 74 79 70 65 20 28 63 6f 6e 64 nters-type (cond
2e60: 20 28 28 6e 75 6c 6c 3f 20 6c 61 72 67 73 29 0a ((null? largs).
2e70: 09 09 09 09 27 6c 69 6e 65 29 0a 09 09 09 20 20 ....'line)....
2e80: 20 20 20 20 20 28 28 6d 65 6d 71 20 28 63 61 72 ((memq (car
2e90: 20 6c 61 72 67 73 29 20 27 28 6e 6f 6e 65 20 6c largs) '(none l
2ea0: 69 6e 65 20 61 6c 6c 29 29 0a 09 09 09 09 28 63 ine all)).....(c
2eb0: 61 72 20 6c 61 72 67 73 29 29 0a 09 09 09 20 20 ar largs))....
2ec0: 20 20 20 20 20 28 65 6c 73 65 0a 09 09 09 09 27 (else.....'
2ed0: 6c 69 6e 65 29 29 29 29 0a 20 20 20 20 20 20 28 line)))). (
2ee0: 63 6f 6e 64 20 28 28 61 6e 64 20 28 65 71 3f 20 cond ((and (eq?
2ef0: 69 6e 70 75 74 2d 74 79 70 65 20 27 70 6f 72 74 input-type 'port
2f00: 29 20 28 69 6e 70 75 74 2d 70 6f 72 74 3f 20 69 ) (input-port? i
2f10: 6e 70 75 74 29 29 0a 09 20 20 20 20 20 28 6c 65 nput)).. (le
2f20: 74 2a 20 28 28 62 75 66 66 65 72 20 20 20 28 6d t* ((buffer (m
2f30: 61 6b 65 2d 73 74 72 69 6e 67 20 6c 65 78 65 72 ake-string lexer
2f40: 2d 69 6e 69 74 2d 62 75 66 66 65 72 2d 6c 65 6e -init-buffer-len
2f50: 20 23 5c 6e 65 77 6c 69 6e 65 29 29 0a 09 09 20 #\newline))...
2f60: 20 20 20 28 72 65 61 64 2d 70 74 72 20 31 29 0a (read-ptr 1).
2f70: 09 09 20 20 20 20 28 69 6e 70 75 74 2d 66 20 20 .. (input-f
2f80: 28 6c 61 6d 62 64 61 20 28 29 20 28 72 65 61 64 (lambda () (read
2f90: 2d 63 68 61 72 20 69 6e 70 75 74 29 29 29 29 0a -char input)))).
2fa0: 09 20 20 20 20 20 20 20 28 6c 65 78 65 72 2d 72 . (lexer-r
2fb0: 61 77 2d 49 53 2d 6d 61 6b 65 72 20 62 75 66 66 aw-IS-maker buff
2fc0: 65 72 20 72 65 61 64 2d 70 74 72 20 69 6e 70 75 er read-ptr inpu
2fd0: 74 2d 66 20 63 6f 75 6e 74 65 72 73 2d 74 79 70 t-f counters-typ
2fe0: 65 29 29 29 0a 09 20 20 20 20 28 28 61 6e 64 20 e))).. ((and
2ff0: 28 65 71 3f 20 69 6e 70 75 74 2d 74 79 70 65 20 (eq? input-type
3000: 27 70 72 6f 63 65 64 75 72 65 29 20 28 70 72 6f 'procedure) (pro
3010: 63 65 64 75 72 65 3f 20 69 6e 70 75 74 29 29 0a cedure? input)).
3020: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 62 75 . (let* ((bu
3030: 66 66 65 72 20 20 20 28 6d 61 6b 65 2d 73 74 72 ffer (make-str
3040: 69 6e 67 20 6c 65 78 65 72 2d 69 6e 69 74 2d 62 ing lexer-init-b
3050: 75 66 66 65 72 2d 6c 65 6e 20 23 5c 6e 65 77 6c uffer-len #\newl
3060: 69 6e 65 29 29 0a 09 09 20 20 20 20 28 72 65 61 ine))... (rea
3070: 64 2d 70 74 72 20 31 29 0a 09 09 20 20 20 20 28 d-ptr 1)... (
3080: 69 6e 70 75 74 2d 66 20 20 69 6e 70 75 74 29 29 input-f input))
3090: 0a 09 20 20 20 20 20 20 20 28 6c 65 78 65 72 2d .. (lexer-
30a0: 72 61 77 2d 49 53 2d 6d 61 6b 65 72 20 62 75 66 raw-IS-maker buf
30b0: 66 65 72 20 72 65 61 64 2d 70 74 72 20 69 6e 70 fer read-ptr inp
30c0: 75 74 2d 66 20 63 6f 75 6e 74 65 72 73 2d 74 79 ut-f counters-ty
30d0: 70 65 29 29 29 0a 09 20 20 20 20 28 28 61 6e 64 pe))).. ((and
30e0: 20 28 65 71 3f 20 69 6e 70 75 74 2d 74 79 70 65 (eq? input-type
30f0: 20 27 73 74 72 69 6e 67 29 20 28 73 74 72 69 6e 'string) (strin
3100: 67 3f 20 69 6e 70 75 74 29 29 0a 09 20 20 20 20 g? input))..
3110: 20 28 6c 65 74 2a 20 28 28 62 75 66 66 65 72 20 (let* ((buffer
3120: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
3130: 20 28 73 74 72 69 6e 67 20 23 5c 6e 65 77 6c 69 (string #\newli
3140: 6e 65 29 20 69 6e 70 75 74 29 29 0a 09 09 20 20 ne) input))...
3150: 20 20 28 72 65 61 64 2d 70 74 72 20 28 73 74 72 (read-ptr (str
3160: 69 6e 67 2d 6c 65 6e 67 74 68 20 62 75 66 66 65 ing-length buffe
3170: 72 29 29 0a 09 09 20 20 20 20 28 69 6e 70 75 74 r))... (input
3180: 2d 66 20 20 28 6c 61 6d 62 64 61 20 28 29 20 27 -f (lambda () '
3190: 65 6f 66 29 29 29 0a 09 20 20 20 20 20 20 20 28 eof))).. (
31a0: 6c 65 78 65 72 2d 72 61 77 2d 49 53 2d 6d 61 6b lexer-raw-IS-mak
31b0: 65 72 20 62 75 66 66 65 72 20 72 65 61 64 2d 70 er buffer read-p
31c0: 74 72 20 69 6e 70 75 74 2d 66 20 63 6f 75 6e 74 tr input-f count
31d0: 65 72 73 2d 74 79 70 65 29 29 29 0a 09 20 20 20 ers-type)))..
31e0: 20 28 65 6c 73 65 0a 09 20 20 20 20 20 28 6c 65 (else.. (le
31f0: 74 2a 20 28 28 62 75 66 66 65 72 20 20 20 28 73 t* ((buffer (s
3200: 74 72 69 6e 67 20 23 5c 6e 65 77 6c 69 6e 65 29 tring #\newline)
3210: 29 0a 09 09 20 20 20 20 28 72 65 61 64 2d 70 74 )... (read-pt
3220: 72 20 31 29 0a 09 09 20 20 20 20 28 69 6e 70 75 r 1)... (inpu
3230: 74 2d 66 20 20 28 6c 61 6d 62 64 61 20 28 29 20 t-f (lambda ()
3240: 27 65 6f 66 29 29 29 0a 09 20 20 20 20 20 20 20 'eof)))..
3250: 28 6c 65 78 65 72 2d 72 61 77 2d 49 53 2d 6d 61 (lexer-raw-IS-ma
3260: 6b 65 72 20 62 75 66 66 65 72 20 72 65 61 64 2d ker buffer read-
3270: 70 74 72 20 69 6e 70 75 74 2d 66 20 63 6f 75 6e ptr input-f coun
3280: 74 65 72 73 2d 74 79 70 65 29 29 29 29 29 29 29 ters-type)))))))
3290: 0a 0a 3b 20 4c 65 73 20 66 6f 6e 63 74 69 6f 6e ..; Les fonction
32a0: 73 3a 0a 3b 20 20 20 6c 65 78 65 72 2d 67 65 74 s:.; lexer-get
32b0: 2d 66 75 6e 63 2d 67 65 74 63 2c 20 6c 65 78 65 -func-getc, lexe
32c0: 72 2d 67 65 74 2d 66 75 6e 63 2d 75 6e 67 65 74 r-get-func-unget
32d0: 63 2c 0a 3b 20 20 20 6c 65 78 65 72 2d 67 65 74 c,.; lexer-get
32e0: 2d 66 75 6e 63 2d 6c 69 6e 65 2c 20 6c 65 78 65 -func-line, lexe
32f0: 72 2d 67 65 74 2d 66 75 6e 63 2d 63 6f 6c 75 6d r-get-func-colum
3300: 6e 20 65 74 20 6c 65 78 65 72 2d 67 65 74 2d 66 n et lexer-get-f
3310: 75 6e 63 2d 6f 66 66 73 65 74 0a 28 64 65 66 69 unc-offset.(defi
3320: 6e 65 20 6c 65 78 65 72 2d 67 65 74 2d 66 75 6e ne lexer-get-fun
3330: 63 2d 67 65 74 63 0a 20 20 28 6c 61 6d 62 64 61 c-getc. (lambda
3340: 20 28 49 53 29 20 28 63 64 72 20 28 61 73 73 71 (IS) (cdr (assq
3350: 20 27 75 73 65 72 2d 67 65 74 63 20 49 53 29 29 'user-getc IS))
3360: 29 29 0a 28 64 65 66 69 6e 65 20 6c 65 78 65 72 )).(define lexer
3370: 2d 67 65 74 2d 66 75 6e 63 2d 75 6e 67 65 74 63 -get-func-ungetc
3380: 0a 20 20 28 6c 61 6d 62 64 61 20 28 49 53 29 20 . (lambda (IS)
3390: 28 63 64 72 20 28 61 73 73 71 20 27 75 73 65 72 (cdr (assq 'user
33a0: 2d 75 6e 67 65 74 63 20 49 53 29 29 29 29 0a 28 -ungetc IS)))).(
33b0: 64 65 66 69 6e 65 20 6c 65 78 65 72 2d 67 65 74 define lexer-get
33c0: 2d 66 75 6e 63 2d 6c 69 6e 65 0a 20 20 28 6c 61 -func-line. (la
33d0: 6d 62 64 61 20 28 49 53 29 20 28 63 64 72 20 28 mbda (IS) (cdr (
33e0: 61 73 73 71 20 27 67 65 74 2d 75 73 65 72 2d 6c assq 'get-user-l
33f0: 69 6e 65 20 49 53 29 29 29 29 0a 28 64 65 66 69 ine IS)))).(defi
3400: 6e 65 20 6c 65 78 65 72 2d 67 65 74 2d 66 75 6e ne lexer-get-fun
3410: 63 2d 63 6f 6c 75 6d 6e 0a 20 20 28 6c 61 6d 62 c-column. (lamb
3420: 64 61 20 28 49 53 29 20 28 63 64 72 20 28 61 73 da (IS) (cdr (as
3430: 73 71 20 27 67 65 74 2d 75 73 65 72 2d 63 6f 6c sq 'get-user-col
3440: 75 6d 6e 20 49 53 29 29 29 29 0a 28 64 65 66 69 umn IS)))).(defi
3450: 6e 65 20 6c 65 78 65 72 2d 67 65 74 2d 66 75 6e ne lexer-get-fun
3460: 63 2d 6f 66 66 73 65 74 0a 20 20 28 6c 61 6d 62 c-offset. (lamb
3470: 64 61 20 28 49 53 29 20 28 63 64 72 20 28 61 73 da (IS) (cdr (as
3480: 73 71 20 27 67 65 74 2d 75 73 65 72 2d 6f 66 66 sq 'get-user-off
3490: 73 65 74 20 49 53 29 29 29 29 0a 0a 3b 0a 3b 20 set IS))))..;.;
34a0: 47 65 73 74 69 6f 6e 20 64 65 73 20 6c 65 78 65 Gestion des lexe
34b0: 72 73 0a 3b 0a 0a 3b 20 46 61 62 72 69 63 61 74 rs.;..; Fabricat
34c0: 69 6f 6e 20 64 65 20 6c 65 78 65 72 20 61 20 70 ion de lexer a p
34d0: 61 72 74 69 72 20 64 27 61 72 62 72 65 73 20 64 artir d'arbres d
34e0: 65 20 64 65 63 69 73 69 6f 6e 0a 28 64 65 66 69 e decision.(defi
34f0: 6e 65 20 6c 65 78 65 72 2d 6d 61 6b 65 2d 74 72 ne lexer-make-tr
3500: 65 65 2d 6c 65 78 65 72 0a 20 20 28 6c 61 6d 62 ee-lexer. (lamb
3510: 64 61 20 28 74 61 62 6c 65 73 20 49 53 29 0a 20 da (tables IS).
3520: 20 20 20 28 6c 65 74 72 65 63 0a 09 28 3b 20 43 (letrec..(; C
3530: 6f 6e 74 65 6e 75 20 64 65 20 6c 61 20 74 61 62 ontenu de la tab
3540: 6c 65 0a 09 20 28 63 6f 75 6e 74 65 72 73 2d 74 le.. (counters-t
3550: 79 70 65 20 20 20 20 20 20 20 20 28 76 65 63 74 ype (vect
3560: 6f 72 2d 72 65 66 20 74 61 62 6c 65 73 20 30 29 or-ref tables 0)
3570: 29 0a 09 20 28 3c 3c 45 4f 46 3e 3e 2d 70 72 65 ).. (<<EOF>>-pre
3580: 2d 61 63 74 69 6f 6e 20 20 20 28 76 65 63 74 6f -action (vecto
3590: 72 2d 72 65 66 20 74 61 62 6c 65 73 20 31 29 29 r-ref tables 1))
35a0: 0a 09 20 28 3c 3c 45 52 52 4f 52 3e 3e 2d 70 72 .. (<<ERROR>>-pr
35b0: 65 2d 61 63 74 69 6f 6e 20 28 76 65 63 74 6f 72 e-action (vector
35c0: 2d 72 65 66 20 74 61 62 6c 65 73 20 32 29 29 0a -ref tables 2)).
35d0: 09 20 28 72 75 6c 65 73 2d 70 72 65 2d 61 63 74 . (rules-pre-act
35e0: 69 6f 6e 73 20 20 20 20 28 76 65 63 74 6f 72 2d ions (vector-
35f0: 72 65 66 20 74 61 62 6c 65 73 20 33 29 29 0a 09 ref tables 3))..
3600: 20 28 74 61 62 6c 65 2d 6e 6c 2d 73 74 61 72 74 (table-nl-start
3610: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
3620: 65 66 20 74 61 62 6c 65 73 20 35 29 29 0a 09 20 ef tables 5))..
3630: 28 74 61 62 6c 65 2d 6e 6f 2d 6e 6c 2d 73 74 61 (table-no-nl-sta
3640: 72 74 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 rt (vector-re
3650: 66 20 74 61 62 6c 65 73 20 36 29 29 0a 09 20 28 f tables 6)).. (
3660: 74 72 65 65 73 2d 76 20 20 20 20 20 20 20 20 20 trees-v
3670: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
3680: 20 74 61 62 6c 65 73 20 37 29 29 0a 09 20 28 61 tables 7)).. (a
3690: 63 63 2d 76 20 20 20 20 20 20 20 20 20 20 20 20 cc-v
36a0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
36b0: 74 61 62 6c 65 73 20 38 29 29 0a 0a 09 20 3b 20 tables 8))... ;
36c0: 43 6f 6e 74 65 6e 75 20 64 75 20 49 53 0a 09 20 Contenu du IS..
36d0: 28 49 53 2d 73 74 61 72 74 2d 67 6f 2d 74 6f 2d (IS-start-go-to-
36e0: 65 6e 64 20 20 20 20 28 63 64 72 20 28 61 73 73 end (cdr (ass
36f0: 71 20 27 73 74 61 72 74 2d 67 6f 2d 74 6f 2d 65 q 'start-go-to-e
3700: 6e 64 20 49 53 29 29 29 0a 09 20 28 49 53 2d 65 nd IS))).. (IS-e
3710: 6e 64 2d 67 6f 2d 74 6f 2d 70 6f 69 6e 74 20 20 nd-go-to-point
3720: 20 20 28 63 64 72 20 28 61 73 73 71 20 27 65 6e (cdr (assq 'en
3730: 64 2d 67 6f 2d 74 6f 2d 70 6f 69 6e 74 20 49 53 d-go-to-point IS
3740: 29 29 29 0a 09 20 28 49 53 2d 69 6e 69 74 2d 6c ))).. (IS-init-l
3750: 65 78 65 6d 65 20 20 20 20 20 20 20 20 28 63 64 exeme (cd
3760: 72 20 28 61 73 73 71 20 27 69 6e 69 74 2d 6c 65 r (assq 'init-le
3770: 78 65 6d 65 20 49 53 29 29 29 0a 09 20 28 49 53 xeme IS))).. (IS
3780: 2d 67 65 74 2d 73 74 61 72 74 2d 6c 69 6e 65 20 -get-start-line
3790: 20 20 20 20 28 63 64 72 20 28 61 73 73 71 20 27 (cdr (assq '
37a0: 67 65 74 2d 73 74 61 72 74 2d 6c 69 6e 65 20 49 get-start-line I
37b0: 53 29 29 29 0a 09 20 28 49 53 2d 67 65 74 2d 73 S))).. (IS-get-s
37c0: 74 61 72 74 2d 63 6f 6c 75 6d 6e 20 20 20 28 63 tart-column (c
37d0: 64 72 20 28 61 73 73 71 20 27 67 65 74 2d 73 74 dr (assq 'get-st
37e0: 61 72 74 2d 63 6f 6c 75 6d 6e 20 49 53 29 29 29 art-column IS)))
37f0: 0a 09 20 28 49 53 2d 67 65 74 2d 73 74 61 72 74 .. (IS-get-start
3800: 2d 6f 66 66 73 65 74 20 20 20 28 63 64 72 20 28 -offset (cdr (
3810: 61 73 73 71 20 27 67 65 74 2d 73 74 61 72 74 2d assq 'get-start-
3820: 6f 66 66 73 65 74 20 49 53 29 29 29 0a 09 20 28 offset IS))).. (
3830: 49 53 2d 70 65 65 6b 2d 6c 65 66 74 2d 63 6f 6e IS-peek-left-con
3840: 74 65 78 74 20 20 28 63 64 72 20 28 61 73 73 71 text (cdr (assq
3850: 20 27 70 65 65 6b 2d 6c 65 66 74 2d 63 6f 6e 74 'peek-left-cont
3860: 65 78 74 20 49 53 29 29 29 0a 09 20 28 49 53 2d ext IS))).. (IS-
3870: 70 65 65 6b 2d 63 68 61 72 20 20 20 20 20 20 20 peek-char
3880: 20 20 20 28 63 64 72 20 28 61 73 73 71 20 27 70 (cdr (assq 'p
3890: 65 65 6b 2d 63 68 61 72 20 49 53 29 29 29 0a 09 eek-char IS)))..
38a0: 20 28 49 53 2d 72 65 61 64 2d 63 68 61 72 20 20 (IS-read-char
38b0: 20 20 20 20 20 20 20 20 28 63 64 72 20 28 61 73 (cdr (as
38c0: 73 71 20 27 72 65 61 64 2d 63 68 61 72 20 49 53 sq 'read-char IS
38d0: 29 29 29 0a 09 20 28 49 53 2d 67 65 74 2d 73 74 ))).. (IS-get-st
38e0: 61 72 74 2d 65 6e 64 2d 74 65 78 74 20 28 63 64 art-end-text (cd
38f0: 72 20 28 61 73 73 71 20 27 67 65 74 2d 73 74 61 r (assq 'get-sta
3900: 72 74 2d 65 6e 64 2d 74 65 78 74 20 49 53 29 29 rt-end-text IS))
3910: 29 0a 09 20 28 49 53 2d 67 65 74 2d 75 73 65 72 ).. (IS-get-user
3920: 2d 6c 69 6e 65 20 20 20 20 20 20 28 63 64 72 20 -line (cdr
3930: 28 61 73 73 71 20 27 67 65 74 2d 75 73 65 72 2d (assq 'get-user-
3940: 6c 69 6e 65 20 49 53 29 29 29 0a 09 20 28 49 53 line IS))).. (IS
3950: 2d 67 65 74 2d 75 73 65 72 2d 63 6f 6c 75 6d 6e -get-user-column
3960: 20 20 20 20 28 63 64 72 20 28 61 73 73 71 20 27 (cdr (assq '
3970: 67 65 74 2d 75 73 65 72 2d 63 6f 6c 75 6d 6e 20 get-user-column
3980: 49 53 29 29 29 0a 09 20 28 49 53 2d 67 65 74 2d IS))).. (IS-get-
3990: 75 73 65 72 2d 6f 66 66 73 65 74 20 20 20 20 28 user-offset (
39a0: 63 64 72 20 28 61 73 73 71 20 27 67 65 74 2d 75 cdr (assq 'get-u
39b0: 73 65 72 2d 6f 66 66 73 65 74 20 49 53 29 29 29 ser-offset IS)))
39c0: 0a 09 20 28 49 53 2d 75 73 65 72 2d 67 65 74 63 .. (IS-user-getc
39d0: 20 20 20 20 20 20 20 20 20 20 28 63 64 72 20 28 (cdr (
39e0: 61 73 73 71 20 27 75 73 65 72 2d 67 65 74 63 20 assq 'user-getc
39f0: 49 53 29 29 29 0a 09 20 28 49 53 2d 75 73 65 72 IS))).. (IS-user
3a00: 2d 75 6e 67 65 74 63 20 20 20 20 20 20 20 20 28 -ungetc (
3a10: 63 64 72 20 28 61 73 73 71 20 27 75 73 65 72 2d cdr (assq 'user-
3a20: 75 6e 67 65 74 63 20 49 53 29 29 29 0a 0a 09 20 ungetc IS)))...
3a30: 3b 20 52 65 73 75 6c 74 61 74 73 0a 09 20 28 3c ; Resultats.. (<
3a40: 3c 45 4f 46 3e 3e 2d 61 63 74 69 6f 6e 20 20 20 <EOF>>-action
3a50: 23 66 29 0a 09 20 28 3c 3c 45 52 52 4f 52 3e 3e #f).. (<<ERROR>>
3a60: 2d 61 63 74 69 6f 6e 20 23 66 29 0a 09 20 28 72 -action #f).. (r
3a70: 75 6c 65 73 2d 61 63 74 69 6f 6e 73 20 20 20 20 ules-actions
3a80: 23 66 29 0a 09 20 28 73 74 61 74 65 73 20 20 20 #f).. (states
3a90: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 66 #f).. (f
3aa0: 69 6e 61 6c 2d 6c 65 78 65 72 20 20 20 20 20 20 inal-lexer
3ab0: 23 66 29 0a 0a 09 20 3b 20 47 65 73 74 69 6f 6e #f)... ; Gestion
3ac0: 20 64 65 73 20 68 6f 6f 6b 73 0a 09 20 28 68 6f des hooks.. (ho
3ad0: 6f 6b 2d 6c 69 73 74 20 27 28 29 29 0a 09 20 28 ok-list '()).. (
3ae0: 61 64 64 2d 68 6f 6f 6b 0a 09 20 20 28 6c 61 6d add-hook.. (lam
3af0: 62 64 61 20 28 74 68 75 6e 6b 29 0a 09 20 20 20 bda (thunk)..
3b00: 20 28 73 65 74 21 20 68 6f 6f 6b 2d 6c 69 73 74 (set! hook-list
3b10: 20 28 63 6f 6e 73 20 74 68 75 6e 6b 20 68 6f 6f (cons thunk hoo
3b20: 6b 2d 6c 69 73 74 29 29 29 29 0a 09 20 28 61 70 k-list)))).. (ap
3b30: 70 6c 79 2d 68 6f 6f 6b 73 0a 09 20 20 28 6c 61 ply-hooks.. (la
3b40: 6d 62 64 61 20 28 29 0a 09 20 20 20 20 28 6c 65 mbda ().. (le
3b50: 74 20 6c 6f 6f 70 20 28 28 6c 20 68 6f 6f 6b 2d t loop ((l hook-
3b60: 6c 69 73 74 29 29 0a 09 20 20 20 20 20 20 28 69 list)).. (i
3b70: 66 20 28 70 61 69 72 3f 20 6c 29 0a 09 09 20 20 f (pair? l)...
3b80: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 28 63 (begin... ((c
3b90: 61 72 20 6c 29 29 0a 09 09 20 20 20 20 28 6c 6f ar l))... (lo
3ba0: 6f 70 20 28 63 64 72 20 6c 29 29 29 29 29 29 29 op (cdr l)))))))
3bb0: 0a 0a 09 20 3b 20 50 72 65 70 61 72 61 74 69 6f ... ; Preparatio
3bc0: 6e 20 64 65 73 20 61 63 74 69 6f 6e 73 0a 09 20 n des actions..
3bd0: 28 73 65 74 2d 61 63 74 69 6f 6e 2d 73 74 61 74 (set-action-stat
3be0: 69 63 73 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 ics.. (lambda (
3bf0: 70 72 65 2d 61 63 74 69 6f 6e 29 0a 09 20 20 20 pre-action)..
3c00: 20 28 70 72 65 2d 61 63 74 69 6f 6e 20 66 69 6e (pre-action fin
3c10: 61 6c 2d 6c 65 78 65 72 20 49 53 2d 75 73 65 72 al-lexer IS-user
3c20: 2d 67 65 74 63 20 49 53 2d 75 73 65 72 2d 75 6e -getc IS-user-un
3c30: 67 65 74 63 29 29 29 0a 09 20 28 70 72 65 70 61 getc))).. (prepa
3c40: 72 65 2d 73 70 65 63 69 61 6c 2d 61 63 74 69 6f re-special-actio
3c50: 6e 2d 6e 6f 6e 65 0a 09 20 20 28 6c 61 6d 62 64 n-none.. (lambd
3c60: 61 20 28 70 72 65 2d 61 63 74 69 6f 6e 29 0a 09 a (pre-action)..
3c70: 20 20 20 20 28 6c 65 74 20 28 28 61 63 74 69 6f (let ((actio
3c80: 6e 20 23 66 29 29 0a 09 20 20 20 20 20 20 28 6c n #f)).. (l
3c90: 65 74 20 28 28 72 65 73 75 6c 74 0a 09 09 20 20 et ((result...
3ca0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
3cb0: 20 20 20 20 20 20 20 28 61 63 74 69 6f 6e 20 22 (action "
3cc0: 22 29 29 29 0a 09 09 20 20 20 20 28 68 6f 6f 6b ")))... (hook
3cd0: 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ... (lambda
3ce0: 28 29 0a 09 09 20 20 20 20 20 20 20 28 73 65 74 ()... (set
3cf0: 21 20 61 63 74 69 6f 6e 20 28 73 65 74 2d 61 63 ! action (set-ac
3d00: 74 69 6f 6e 2d 73 74 61 74 69 63 73 20 70 72 65 tion-statics pre
3d10: 2d 61 63 74 69 6f 6e 29 29 29 29 29 0a 09 09 28 -action)))))...(
3d20: 61 64 64 2d 68 6f 6f 6b 20 68 6f 6f 6b 29 0a 09 add-hook hook)..
3d30: 09 72 65 73 75 6c 74 29 29 29 29 0a 09 20 28 70 .result)))).. (p
3d40: 72 65 70 61 72 65 2d 73 70 65 63 69 61 6c 2d 61 repare-special-a
3d50: 63 74 69 6f 6e 2d 6c 69 6e 65 0a 09 20 20 28 6c ction-line.. (l
3d60: 61 6d 62 64 61 20 28 70 72 65 2d 61 63 74 69 6f ambda (pre-actio
3d70: 6e 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 61 n).. (let ((a
3d80: 63 74 69 6f 6e 20 23 66 29 29 0a 09 20 20 20 20 ction #f))..
3d90: 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 0a (let ((result.
3da0: 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
3db0: 79 79 6c 69 6e 65 29 0a 09 09 20 20 20 20 20 20 yyline)...
3dc0: 20 28 61 63 74 69 6f 6e 20 22 22 20 79 79 6c 69 (action "" yyli
3dd0: 6e 65 29 29 29 0a 09 09 20 20 20 20 28 68 6f 6f ne)))... (hoo
3de0: 6b 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 k... (lambda
3df0: 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 73 65 ()... (se
3e00: 74 21 20 61 63 74 69 6f 6e 20 28 73 65 74 2d 61 t! action (set-a
3e10: 63 74 69 6f 6e 2d 73 74 61 74 69 63 73 20 70 72 ction-statics pr
3e20: 65 2d 61 63 74 69 6f 6e 29 29 29 29 29 0a 09 09 e-action)))))...
3e30: 28 61 64 64 2d 68 6f 6f 6b 20 68 6f 6f 6b 29 0a (add-hook hook).
3e40: 09 09 72 65 73 75 6c 74 29 29 29 29 0a 09 20 28 ..result)))).. (
3e50: 70 72 65 70 61 72 65 2d 73 70 65 63 69 61 6c 2d prepare-special-
3e60: 61 63 74 69 6f 6e 2d 61 6c 6c 0a 09 20 20 28 6c action-all.. (l
3e70: 61 6d 62 64 61 20 28 70 72 65 2d 61 63 74 69 6f ambda (pre-actio
3e80: 6e 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 61 n).. (let ((a
3e90: 63 74 69 6f 6e 20 23 66 29 29 0a 09 20 20 20 20 ction #f))..
3ea0: 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 0a (let ((result.
3eb0: 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
3ec0: 79 79 6c 69 6e 65 20 79 79 63 6f 6c 75 6d 6e 20 yyline yycolumn
3ed0: 79 79 6f 66 66 73 65 74 29 0a 09 09 20 20 20 20 yyoffset)...
3ee0: 20 20 20 28 61 63 74 69 6f 6e 20 22 22 20 79 79 (action "" yy
3ef0: 6c 69 6e 65 20 79 79 63 6f 6c 75 6d 6e 20 79 79 line yycolumn yy
3f00: 6f 66 66 73 65 74 29 29 29 0a 09 09 20 20 20 20 offset)))...
3f10: 28 68 6f 6f 6b 0a 09 09 20 20 20 20 20 28 6c 61 (hook... (la
3f20: 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 mbda ()...
3f30: 20 28 73 65 74 21 20 61 63 74 69 6f 6e 20 28 73 (set! action (s
3f40: 65 74 2d 61 63 74 69 6f 6e 2d 73 74 61 74 69 63 et-action-static
3f50: 73 20 70 72 65 2d 61 63 74 69 6f 6e 29 29 29 29 s pre-action))))
3f60: 29 0a 09 09 28 61 64 64 2d 68 6f 6f 6b 20 68 6f )...(add-hook ho
3f70: 6f 6b 29 0a 09 09 72 65 73 75 6c 74 29 29 29 29 ok)...result))))
3f80: 0a 09 20 28 70 72 65 70 61 72 65 2d 73 70 65 63 .. (prepare-spec
3f90: 69 61 6c 2d 61 63 74 69 6f 6e 0a 09 20 20 28 6c ial-action.. (l
3fa0: 61 6d 62 64 61 20 28 70 72 65 2d 61 63 74 69 6f ambda (pre-actio
3fb0: 6e 29 0a 09 20 20 20 20 28 63 6f 6e 64 20 28 28 n).. (cond ((
3fc0: 65 71 3f 20 63 6f 75 6e 74 65 72 73 2d 74 79 70 eq? counters-typ
3fd0: 65 20 27 6e 6f 6e 65 29 0a 09 09 20 20 20 28 70 e 'none)... (p
3fe0: 72 65 70 61 72 65 2d 73 70 65 63 69 61 6c 2d 61 repare-special-a
3ff0: 63 74 69 6f 6e 2d 6e 6f 6e 65 20 70 72 65 2d 61 ction-none pre-a
4000: 63 74 69 6f 6e 29 29 0a 09 09 20 20 28 28 65 71 ction))... ((eq
4010: 3f 20 63 6f 75 6e 74 65 72 73 2d 74 79 70 65 20 ? counters-type
4020: 27 6c 69 6e 65 29 0a 09 09 20 20 20 28 70 72 65 'line)... (pre
4030: 70 61 72 65 2d 73 70 65 63 69 61 6c 2d 61 63 74 pare-special-act
4040: 69 6f 6e 2d 6c 69 6e 65 20 70 72 65 2d 61 63 74 ion-line pre-act
4050: 69 6f 6e 29 29 0a 09 09 20 20 28 28 65 71 3f 20 ion))... ((eq?
4060: 63 6f 75 6e 74 65 72 73 2d 74 79 70 65 20 27 61 counters-type 'a
4070: 6c 6c 29 0a 09 09 20 20 20 28 70 72 65 70 61 72 ll)... (prepar
4080: 65 2d 73 70 65 63 69 61 6c 2d 61 63 74 69 6f 6e e-special-action
4090: 2d 61 6c 6c 20 20 70 72 65 2d 61 63 74 69 6f 6e -all pre-action
40a0: 29 29 29 29 29 0a 09 20 28 70 72 65 70 61 72 65 ))))).. (prepare
40b0: 2d 61 63 74 69 6f 6e 2d 79 79 74 65 78 74 2d 6e -action-yytext-n
40c0: 6f 6e 65 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 one.. (lambda (
40d0: 70 72 65 2d 61 63 74 69 6f 6e 29 0a 09 20 20 20 pre-action)..
40e0: 20 28 6c 65 74 20 28 28 67 65 74 2d 73 74 61 72 (let ((get-star
40f0: 74 2d 65 6e 64 2d 74 65 78 74 20 49 53 2d 67 65 t-end-text IS-ge
4100: 74 2d 73 74 61 72 74 2d 65 6e 64 2d 74 65 78 74 t-start-end-text
4110: 29 0a 09 09 20 20 28 73 74 61 72 74 2d 67 6f 2d )... (start-go-
4120: 74 6f 2d 65 6e 64 20 20 20 20 49 53 2d 73 74 61 to-end IS-sta
4130: 72 74 2d 67 6f 2d 74 6f 2d 65 6e 64 29 0a 09 09 rt-go-to-end)...
4140: 20 20 28 61 63 74 69 6f 6e 20 20 20 20 20 20 20 (action
4150: 20 20 20 20 20 20 23 66 29 29 0a 09 20 20 20 20 #f))..
4160: 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 0a (let ((result.
4170: 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
4180: 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 )... (let
4190: 28 28 79 79 74 65 78 74 20 28 67 65 74 2d 73 74 ((yytext (get-st
41a0: 61 72 74 2d 65 6e 64 2d 74 65 78 74 29 29 29 0a art-end-text))).
41b0: 09 09 09 20 28 73 74 61 72 74 2d 67 6f 2d 74 6f ... (start-go-to
41c0: 2d 65 6e 64 29 0a 09 09 09 20 28 61 63 74 69 6f -end).... (actio
41d0: 6e 20 79 79 74 65 78 74 29 29 29 29 0a 09 09 20 n yytext))))...
41e0: 20 20 20 28 68 6f 6f 6b 0a 09 09 20 20 20 20 20 (hook...
41f0: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 (lambda ()...
4200: 20 20 20 20 28 73 65 74 21 20 61 63 74 69 6f 6e (set! action
4210: 20 28 73 65 74 2d 61 63 74 69 6f 6e 2d 73 74 61 (set-action-sta
4220: 74 69 63 73 20 70 72 65 2d 61 63 74 69 6f 6e 29 tics pre-action)
4230: 29 29 29 29 0a 09 09 28 61 64 64 2d 68 6f 6f 6b ))))...(add-hook
4240: 20 68 6f 6f 6b 29 0a 09 09 72 65 73 75 6c 74 29 hook)...result)
4250: 29 29 29 0a 09 20 28 70 72 65 70 61 72 65 2d 61 ))).. (prepare-a
4260: 63 74 69 6f 6e 2d 79 79 74 65 78 74 2d 6c 69 6e ction-yytext-lin
4270: 65 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 70 72 e.. (lambda (pr
4280: 65 2d 61 63 74 69 6f 6e 29 0a 09 20 20 20 20 28 e-action).. (
4290: 6c 65 74 20 28 28 67 65 74 2d 73 74 61 72 74 2d let ((get-start-
42a0: 65 6e 64 2d 74 65 78 74 20 49 53 2d 67 65 74 2d end-text IS-get-
42b0: 73 74 61 72 74 2d 65 6e 64 2d 74 65 78 74 29 0a start-end-text).
42c0: 09 09 20 20 28 73 74 61 72 74 2d 67 6f 2d 74 6f .. (start-go-to
42d0: 2d 65 6e 64 20 20 20 20 49 53 2d 73 74 61 72 74 -end IS-start
42e0: 2d 67 6f 2d 74 6f 2d 65 6e 64 29 0a 09 09 20 20 -go-to-end)...
42f0: 28 61 63 74 69 6f 6e 20 20 20 20 20 20 20 20 20 (action
4300: 20 20 20 20 23 66 29 29 0a 09 20 20 20 20 20 20 #f))..
4310: 28 6c 65 74 20 28 28 72 65 73 75 6c 74 0a 09 09 (let ((result...
4320: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 79 79 (lambda (yy
4330: 6c 69 6e 65 29 0a 09 09 20 20 20 20 20 20 20 28 line)... (
4340: 6c 65 74 20 28 28 79 79 74 65 78 74 20 28 67 65 let ((yytext (ge
4350: 74 2d 73 74 61 72 74 2d 65 6e 64 2d 74 65 78 74 t-start-end-text
4360: 29 29 29 0a 09 09 09 20 28 73 74 61 72 74 2d 67 ))).... (start-g
4370: 6f 2d 74 6f 2d 65 6e 64 29 0a 09 09 09 20 28 61 o-to-end).... (a
4380: 63 74 69 6f 6e 20 79 79 74 65 78 74 20 79 79 6c ction yytext yyl
4390: 69 6e 65 29 29 29 29 0a 09 09 20 20 20 20 28 68 ine))))... (h
43a0: 6f 6f 6b 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 ook... (lamb
43b0: 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 da ()... (
43c0: 73 65 74 21 20 61 63 74 69 6f 6e 20 28 73 65 74 set! action (set
43d0: 2d 61 63 74 69 6f 6e 2d 73 74 61 74 69 63 73 20 -action-statics
43e0: 70 72 65 2d 61 63 74 69 6f 6e 29 29 29 29 29 0a pre-action))))).
43f0: 09 09 28 61 64 64 2d 68 6f 6f 6b 20 68 6f 6f 6b ..(add-hook hook
4400: 29 0a 09 09 72 65 73 75 6c 74 29 29 29 29 0a 09 )...result))))..
4410: 20 28 70 72 65 70 61 72 65 2d 61 63 74 69 6f 6e (prepare-action
4420: 2d 79 79 74 65 78 74 2d 61 6c 6c 0a 09 20 20 28 -yytext-all.. (
4430: 6c 61 6d 62 64 61 20 28 70 72 65 2d 61 63 74 69 lambda (pre-acti
4440: 6f 6e 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 on).. (let ((
4450: 67 65 74 2d 73 74 61 72 74 2d 65 6e 64 2d 74 65 get-start-end-te
4460: 78 74 20 49 53 2d 67 65 74 2d 73 74 61 72 74 2d xt IS-get-start-
4470: 65 6e 64 2d 74 65 78 74 29 0a 09 09 20 20 28 73 end-text)... (s
4480: 74 61 72 74 2d 67 6f 2d 74 6f 2d 65 6e 64 20 20 tart-go-to-end
4490: 20 20 49 53 2d 73 74 61 72 74 2d 67 6f 2d 74 6f IS-start-go-to
44a0: 2d 65 6e 64 29 0a 09 09 20 20 28 61 63 74 69 6f -end)... (actio
44b0: 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 n #f
44c0: 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 )).. (let (
44d0: 28 72 65 73 75 6c 74 0a 09 09 20 20 20 20 20 28 (result... (
44e0: 6c 61 6d 62 64 61 20 28 79 79 6c 69 6e 65 20 79 lambda (yyline y
44f0: 79 63 6f 6c 75 6d 6e 20 79 79 6f 66 66 73 65 74 ycolumn yyoffset
4500: 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 )... (let
4510: 28 28 79 79 74 65 78 74 20 28 67 65 74 2d 73 74 ((yytext (get-st
4520: 61 72 74 2d 65 6e 64 2d 74 65 78 74 29 29 29 0a art-end-text))).
4530: 09 09 09 20 28 73 74 61 72 74 2d 67 6f 2d 74 6f ... (start-go-to
4540: 2d 65 6e 64 29 0a 09 09 09 20 28 61 63 74 69 6f -end).... (actio
4550: 6e 20 79 79 74 65 78 74 20 79 79 6c 69 6e 65 20 n yytext yyline
4560: 79 79 63 6f 6c 75 6d 6e 20 79 79 6f 66 66 73 65 yycolumn yyoffse
4570: 74 29 29 29 29 0a 09 09 20 20 20 20 28 68 6f 6f t))))... (hoo
4580: 6b 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 k... (lambda
4590: 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 73 65 ()... (se
45a0: 74 21 20 61 63 74 69 6f 6e 20 28 73 65 74 2d 61 t! action (set-a
45b0: 63 74 69 6f 6e 2d 73 74 61 74 69 63 73 20 70 72 ction-statics pr
45c0: 65 2d 61 63 74 69 6f 6e 29 29 29 29 29 0a 09 09 e-action)))))...
45d0: 28 61 64 64 2d 68 6f 6f 6b 20 68 6f 6f 6b 29 0a (add-hook hook).
45e0: 09 09 72 65 73 75 6c 74 29 29 29 29 0a 09 20 28 ..result)))).. (
45f0: 70 72 65 70 61 72 65 2d 61 63 74 69 6f 6e 2d 79 prepare-action-y
4600: 79 74 65 78 74 0a 09 20 20 28 6c 61 6d 62 64 61 ytext.. (lambda
4610: 20 28 70 72 65 2d 61 63 74 69 6f 6e 29 0a 09 20 (pre-action)..
4620: 20 20 20 28 63 6f 6e 64 20 28 28 65 71 3f 20 63 (cond ((eq? c
4630: 6f 75 6e 74 65 72 73 2d 74 79 70 65 20 27 6e 6f ounters-type 'no
4640: 6e 65 29 0a 09 09 20 20 20 28 70 72 65 70 61 72 ne)... (prepar
4650: 65 2d 61 63 74 69 6f 6e 2d 79 79 74 65 78 74 2d e-action-yytext-
4660: 6e 6f 6e 65 20 70 72 65 2d 61 63 74 69 6f 6e 29 none pre-action)
4670: 29 0a 09 09 20 20 28 28 65 71 3f 20 63 6f 75 6e )... ((eq? coun
4680: 74 65 72 73 2d 74 79 70 65 20 27 6c 69 6e 65 29 ters-type 'line)
4690: 0a 09 09 20 20 20 28 70 72 65 70 61 72 65 2d 61 ... (prepare-a
46a0: 63 74 69 6f 6e 2d 79 79 74 65 78 74 2d 6c 69 6e ction-yytext-lin
46b0: 65 20 70 72 65 2d 61 63 74 69 6f 6e 29 29 0a 09 e pre-action))..
46c0: 09 20 20 28 28 65 71 3f 20 63 6f 75 6e 74 65 72 . ((eq? counter
46d0: 73 2d 74 79 70 65 20 27 61 6c 6c 29 0a 09 09 20 s-type 'all)...
46e0: 20 20 28 70 72 65 70 61 72 65 2d 61 63 74 69 6f (prepare-actio
46f0: 6e 2d 79 79 74 65 78 74 2d 61 6c 6c 20 20 70 72 n-yytext-all pr
4700: 65 2d 61 63 74 69 6f 6e 29 29 29 29 29 0a 09 20 e-action)))))..
4710: 28 70 72 65 70 61 72 65 2d 61 63 74 69 6f 6e 2d (prepare-action-
4720: 6e 6f 2d 79 79 74 65 78 74 2d 6e 6f 6e 65 0a 09 no-yytext-none..
4730: 20 20 28 6c 61 6d 62 64 61 20 28 70 72 65 2d 61 (lambda (pre-a
4740: 63 74 69 6f 6e 29 0a 09 20 20 20 20 28 6c 65 74 ction).. (let
4750: 20 28 28 73 74 61 72 74 2d 67 6f 2d 74 6f 2d 65 ((start-go-to-e
4760: 6e 64 20 20 20 20 49 53 2d 73 74 61 72 74 2d 67 nd IS-start-g
4770: 6f 2d 74 6f 2d 65 6e 64 29 0a 09 09 20 20 28 61 o-to-end)... (a
4780: 63 74 69 6f 6e 20 20 20 20 20 20 20 20 20 20 20 ction
4790: 20 20 23 66 29 29 0a 09 20 20 20 20 20 20 28 6c #f)).. (l
47a0: 65 74 20 28 28 72 65 73 75 6c 74 0a 09 09 20 20 et ((result...
47b0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
47c0: 20 20 20 20 20 20 20 28 73 74 61 72 74 2d 67 6f (start-go
47d0: 2d 74 6f 2d 65 6e 64 29 0a 09 09 20 20 20 20 20 -to-end)...
47e0: 20 20 28 61 63 74 69 6f 6e 29 29 29 0a 09 09 20 (action)))...
47f0: 20 20 20 28 68 6f 6f 6b 0a 09 09 20 20 20 20 20 (hook...
4800: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 (lambda ()...
4810: 20 20 20 20 28 73 65 74 21 20 61 63 74 69 6f 6e (set! action
4820: 20 28 73 65 74 2d 61 63 74 69 6f 6e 2d 73 74 61 (set-action-sta
4830: 74 69 63 73 20 70 72 65 2d 61 63 74 69 6f 6e 29 tics pre-action)
4840: 29 29 29 29 0a 09 09 28 61 64 64 2d 68 6f 6f 6b ))))...(add-hook
4850: 20 68 6f 6f 6b 29 0a 09 09 72 65 73 75 6c 74 29 hook)...result)
4860: 29 29 29 0a 09 20 28 70 72 65 70 61 72 65 2d 61 ))).. (prepare-a
4870: 63 74 69 6f 6e 2d 6e 6f 2d 79 79 74 65 78 74 2d ction-no-yytext-
4880: 6c 69 6e 65 0a 09 20 20 28 6c 61 6d 62 64 61 20 line.. (lambda
4890: 28 70 72 65 2d 61 63 74 69 6f 6e 29 0a 09 20 20 (pre-action)..
48a0: 20 20 28 6c 65 74 20 28 28 73 74 61 72 74 2d 67 (let ((start-g
48b0: 6f 2d 74 6f 2d 65 6e 64 20 20 20 20 49 53 2d 73 o-to-end IS-s
48c0: 74 61 72 74 2d 67 6f 2d 74 6f 2d 65 6e 64 29 0a tart-go-to-end).
48d0: 09 09 20 20 28 61 63 74 69 6f 6e 20 20 20 20 20 .. (action
48e0: 20 20 20 20 20 20 20 20 23 66 29 29 0a 09 20 20 #f))..
48f0: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c (let ((resul
4900: 74 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 t... (lambda
4910: 20 28 79 79 6c 69 6e 65 29 0a 09 09 20 20 20 20 (yyline)...
4920: 20 20 20 28 73 74 61 72 74 2d 67 6f 2d 74 6f 2d (start-go-to-
4930: 65 6e 64 29 0a 09 09 20 20 20 20 20 20 20 28 61 end)... (a
4940: 63 74 69 6f 6e 20 79 79 6c 69 6e 65 29 29 29 0a ction yyline))).
4950: 09 09 20 20 20 20 28 68 6f 6f 6b 0a 09 09 20 20 .. (hook...
4960: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
4970: 20 20 20 20 20 20 20 28 73 65 74 21 20 61 63 74 (set! act
4980: 69 6f 6e 20 28 73 65 74 2d 61 63 74 69 6f 6e 2d ion (set-action-
4990: 73 74 61 74 69 63 73 20 70 72 65 2d 61 63 74 69 statics pre-acti
49a0: 6f 6e 29 29 29 29 29 0a 09 09 28 61 64 64 2d 68 on)))))...(add-h
49b0: 6f 6f 6b 20 68 6f 6f 6b 29 0a 09 09 72 65 73 75 ook hook)...resu
49c0: 6c 74 29 29 29 29 0a 09 20 28 70 72 65 70 61 72 lt)))).. (prepar
49d0: 65 2d 61 63 74 69 6f 6e 2d 6e 6f 2d 79 79 74 65 e-action-no-yyte
49e0: 78 74 2d 61 6c 6c 0a 09 20 20 28 6c 61 6d 62 64 xt-all.. (lambd
49f0: 61 20 28 70 72 65 2d 61 63 74 69 6f 6e 29 0a 09 a (pre-action)..
4a00: 20 20 20 20 28 6c 65 74 20 28 28 73 74 61 72 74 (let ((start
4a10: 2d 67 6f 2d 74 6f 2d 65 6e 64 20 20 20 20 49 53 -go-to-end IS
4a20: 2d 73 74 61 72 74 2d 67 6f 2d 74 6f 2d 65 6e 64 -start-go-to-end
4a30: 29 0a 09 09 20 20 28 61 63 74 69 6f 6e 20 20 20 )... (action
4a40: 20 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 09 #f))..
4a50: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
4a60: 75 6c 74 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 ult... (lamb
4a70: 64 61 20 28 79 79 6c 69 6e 65 20 79 79 63 6f 6c da (yyline yycol
4a80: 75 6d 6e 20 79 79 6f 66 66 73 65 74 29 0a 09 09 umn yyoffset)...
4a90: 20 20 20 20 20 20 20 28 73 74 61 72 74 2d 67 6f (start-go
4aa0: 2d 74 6f 2d 65 6e 64 29 0a 09 09 20 20 20 20 20 -to-end)...
4ab0: 20 20 28 61 63 74 69 6f 6e 20 79 79 6c 69 6e 65 (action yyline
4ac0: 20 79 79 63 6f 6c 75 6d 6e 20 79 79 6f 66 66 73 yycolumn yyoffs
4ad0: 65 74 29 29 29 0a 09 09 20 20 20 20 28 68 6f 6f et)))... (hoo
4ae0: 6b 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 k... (lambda
4af0: 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 73 65 ()... (se
4b00: 74 21 20 61 63 74 69 6f 6e 20 28 73 65 74 2d 61 t! action (set-a
4b10: 63 74 69 6f 6e 2d 73 74 61 74 69 63 73 20 70 72 ction-statics pr
4b20: 65 2d 61 63 74 69 6f 6e 29 29 29 29 29 0a 09 09 e-action)))))...
4b30: 28 61 64 64 2d 68 6f 6f 6b 20 68 6f 6f 6b 29 0a (add-hook hook).
4b40: 09 09 72 65 73 75 6c 74 29 29 29 29 0a 09 20 28 ..result)))).. (
4b50: 70 72 65 70 61 72 65 2d 61 63 74 69 6f 6e 2d 6e prepare-action-n
4b60: 6f 2d 79 79 74 65 78 74 0a 09 20 20 28 6c 61 6d o-yytext.. (lam
4b70: 62 64 61 20 28 70 72 65 2d 61 63 74 69 6f 6e 29 bda (pre-action)
4b80: 0a 09 20 20 20 20 28 63 6f 6e 64 20 28 28 65 71 .. (cond ((eq
4b90: 3f 20 63 6f 75 6e 74 65 72 73 2d 74 79 70 65 20 ? counters-type
4ba0: 27 6e 6f 6e 65 29 0a 09 09 20 20 20 28 70 72 65 'none)... (pre
4bb0: 70 61 72 65 2d 61 63 74 69 6f 6e 2d 6e 6f 2d 79 pare-action-no-y
4bc0: 79 74 65 78 74 2d 6e 6f 6e 65 20 70 72 65 2d 61 ytext-none pre-a
4bd0: 63 74 69 6f 6e 29 29 0a 09 09 20 20 28 28 65 71 ction))... ((eq
4be0: 3f 20 63 6f 75 6e 74 65 72 73 2d 74 79 70 65 20 ? counters-type
4bf0: 27 6c 69 6e 65 29 0a 09 09 20 20 20 28 70 72 65 'line)... (pre
4c00: 70 61 72 65 2d 61 63 74 69 6f 6e 2d 6e 6f 2d 79 pare-action-no-y
4c10: 79 74 65 78 74 2d 6c 69 6e 65 20 70 72 65 2d 61 ytext-line pre-a
4c20: 63 74 69 6f 6e 29 29 0a 09 09 20 20 28 28 65 71 ction))... ((eq
4c30: 3f 20 63 6f 75 6e 74 65 72 73 2d 74 79 70 65 20 ? counters-type
4c40: 27 61 6c 6c 29 0a 09 09 20 20 20 28 70 72 65 70 'all)... (prep
4c50: 61 72 65 2d 61 63 74 69 6f 6e 2d 6e 6f 2d 79 79 are-action-no-yy
4c60: 74 65 78 74 2d 61 6c 6c 20 20 70 72 65 2d 61 63 text-all pre-ac
4c70: 74 69 6f 6e 29 29 29 29 29 0a 0a 09 20 3b 20 46 tion)))))... ; F
4c80: 61 62 72 69 71 75 65 20 6c 65 73 20 66 6f 6e 63 abrique les fonc
4c90: 74 69 6f 6e 73 20 64 65 20 64 69 73 70 61 74 63 tions de dispatc
4ca0: 68 0a 09 20 28 70 72 65 70 61 72 65 2d 64 69 73 h.. (prepare-dis
4cb0: 70 61 74 63 68 2d 65 72 72 0a 09 20 20 28 6c 61 patch-err.. (la
4cc0: 6d 62 64 61 20 28 6c 65 61 66 29 0a 09 20 20 20 mbda (leaf)..
4cd0: 20 28 6c 61 6d 62 64 61 20 28 63 29 0a 09 20 20 (lambda (c)..
4ce0: 20 20 20 20 23 66 29 29 29 0a 09 20 28 70 72 65 #f))).. (pre
4cf0: 70 61 72 65 2d 64 69 73 70 61 74 63 68 2d 6e 75 pare-dispatch-nu
4d00: 6d 62 65 72 0a 09 20 20 28 6c 61 6d 62 64 61 20 mber.. (lambda
4d10: 28 6c 65 61 66 29 0a 09 20 20 20 20 28 6c 65 74 (leaf).. (let
4d20: 20 28 28 73 74 61 74 65 2d 66 75 6e 63 74 69 6f ((state-functio
4d30: 6e 20 23 66 29 29 0a 09 20 20 20 20 20 20 28 6c n #f)).. (l
4d40: 65 74 20 28 28 72 65 73 75 6c 74 0a 09 09 20 20 et ((result...
4d50: 20 20 20 28 6c 61 6d 62 64 61 20 28 63 29 0a 09 (lambda (c)..
4d60: 09 20 20 20 20 20 20 20 73 74 61 74 65 2d 66 75 . state-fu
4d70: 6e 63 74 69 6f 6e 29 29 0a 09 09 20 20 20 20 28 nction))... (
4d80: 68 6f 6f 6b 0a 09 09 20 20 20 20 20 28 6c 61 6d hook... (lam
4d90: 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 20 bda ()...
4da0: 28 73 65 74 21 20 73 74 61 74 65 2d 66 75 6e 63 (set! state-func
4db0: 74 69 6f 6e 20 28 76 65 63 74 6f 72 2d 72 65 66 tion (vector-ref
4dc0: 20 73 74 61 74 65 73 20 6c 65 61 66 29 29 29 29 states leaf))))
4dd0: 29 0a 09 09 28 61 64 64 2d 68 6f 6f 6b 20 68 6f )...(add-hook ho
4de0: 6f 6b 29 0a 09 09 72 65 73 75 6c 74 29 29 29 29 ok)...result))))
4df0: 0a 09 20 28 70 72 65 70 61 72 65 2d 64 69 73 70 .. (prepare-disp
4e00: 61 74 63 68 2d 6c 65 61 66 0a 09 20 20 28 6c 61 atch-leaf.. (la
4e10: 6d 62 64 61 20 28 6c 65 61 66 29 0a 09 20 20 20 mbda (leaf)..
4e20: 20 28 69 66 20 28 65 71 3f 20 6c 65 61 66 20 27 (if (eq? leaf '
4e30: 65 72 72 29 0a 09 09 28 70 72 65 70 61 72 65 2d err)...(prepare-
4e40: 64 69 73 70 61 74 63 68 2d 65 72 72 20 6c 65 61 dispatch-err lea
4e50: 66 29 0a 09 09 28 70 72 65 70 61 72 65 2d 64 69 f)...(prepare-di
4e60: 73 70 61 74 63 68 2d 6e 75 6d 62 65 72 20 6c 65 spatch-number le
4e70: 61 66 29 29 29 29 0a 09 20 28 70 72 65 70 61 72 af)))).. (prepar
4e80: 65 2d 64 69 73 70 61 74 63 68 2d 3c 0a 09 20 20 e-dispatch-<..
4e90: 28 6c 61 6d 62 64 61 20 28 74 72 65 65 29 0a 09 (lambda (tree)..
4ea0: 20 20 20 20 28 6c 65 74 20 28 28 6c 65 66 74 2d (let ((left-
4eb0: 74 72 65 65 20 20 28 6c 69 73 74 2d 72 65 66 20 tree (list-ref
4ec0: 74 72 65 65 20 31 29 29 0a 09 09 20 20 28 72 69 tree 1))... (ri
4ed0: 67 68 74 2d 74 72 65 65 20 28 6c 69 73 74 2d 72 ght-tree (list-r
4ee0: 65 66 20 74 72 65 65 20 32 29 29 29 0a 09 20 20 ef tree 2)))..
4ef0: 20 20 20 20 28 6c 65 74 20 28 28 62 6f 75 6e 64 (let ((bound
4f00: 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 (list-ref
4f10: 74 72 65 65 20 30 29 29 0a 09 09 20 20 20 20 28 tree 0))... (
4f20: 6c 65 66 74 2d 66 75 6e 63 20 20 28 70 72 65 70 left-func (prep
4f30: 61 72 65 2d 64 69 73 70 61 74 63 68 2d 74 72 65 are-dispatch-tre
4f40: 65 20 6c 65 66 74 2d 74 72 65 65 29 29 0a 09 09 e left-tree))...
4f50: 20 20 20 20 28 72 69 67 68 74 2d 66 75 6e 63 20 (right-func
4f60: 28 70 72 65 70 61 72 65 2d 64 69 73 70 61 74 63 (prepare-dispatc
4f70: 68 2d 74 72 65 65 20 72 69 67 68 74 2d 74 72 65 h-tree right-tre
4f80: 65 29 29 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 e)))...(lambda (
4f90: 63 29 0a 09 09 20 20 28 69 66 20 28 3c 20 63 20 c)... (if (< c
4fa0: 62 6f 75 6e 64 29 0a 09 09 20 20 20 20 20 20 28 bound)... (
4fb0: 6c 65 66 74 2d 66 75 6e 63 20 63 29 0a 09 09 20 left-func c)...
4fc0: 20 20 20 20 20 28 72 69 67 68 74 2d 66 75 6e 63 (right-func
4fd0: 20 63 29 29 29 29 29 29 29 0a 09 20 28 70 72 65 c))))))).. (pre
4fe0: 70 61 72 65 2d 64 69 73 70 61 74 63 68 2d 3d 0a pare-dispatch-=.
4ff0: 09 20 20 28 6c 61 6d 62 64 61 20 28 74 72 65 65 . (lambda (tree
5000: 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 6c 65 ).. (let ((le
5010: 66 74 2d 74 72 65 65 20 20 28 6c 69 73 74 2d 72 ft-tree (list-r
5020: 65 66 20 74 72 65 65 20 32 29 29 0a 09 09 20 20 ef tree 2))...
5030: 28 72 69 67 68 74 2d 74 72 65 65 20 28 6c 69 73 (right-tree (lis
5040: 74 2d 72 65 66 20 74 72 65 65 20 33 29 29 29 0a t-ref tree 3))).
5050: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 62 6f . (let ((bo
5060: 75 6e 64 20 20 20 20 20 20 28 6c 69 73 74 2d 72 und (list-r
5070: 65 66 20 74 72 65 65 20 31 29 29 0a 09 09 20 20 ef tree 1))...
5080: 20 20 28 6c 65 66 74 2d 66 75 6e 63 20 20 28 70 (left-func (p
5090: 72 65 70 61 72 65 2d 64 69 73 70 61 74 63 68 2d repare-dispatch-
50a0: 74 72 65 65 20 6c 65 66 74 2d 74 72 65 65 29 29 tree left-tree))
50b0: 0a 09 09 20 20 20 20 28 72 69 67 68 74 2d 66 75 ... (right-fu
50c0: 6e 63 20 28 70 72 65 70 61 72 65 2d 64 69 73 70 nc (prepare-disp
50d0: 61 74 63 68 2d 74 72 65 65 20 72 69 67 68 74 2d atch-tree right-
50e0: 74 72 65 65 29 29 29 0a 09 09 28 6c 61 6d 62 64 tree)))...(lambd
50f0: 61 20 28 63 29 0a 09 09 20 20 28 69 66 20 28 3d a (c)... (if (=
5100: 20 63 20 62 6f 75 6e 64 29 0a 09 09 20 20 20 20 c bound)...
5110: 20 20 28 6c 65 66 74 2d 66 75 6e 63 20 63 29 0a (left-func c).
5120: 09 09 20 20 20 20 20 20 28 72 69 67 68 74 2d 66 .. (right-f
5130: 75 6e 63 20 63 29 29 29 29 29 29 29 0a 09 20 28 unc c))))))).. (
5140: 70 72 65 70 61 72 65 2d 64 69 73 70 61 74 63 68 prepare-dispatch
5150: 2d 74 72 65 65 0a 09 20 20 28 6c 61 6d 62 64 61 -tree.. (lambda
5160: 20 28 74 72 65 65 29 0a 09 20 20 20 20 28 63 6f (tree).. (co
5170: 6e 64 20 28 28 6e 6f 74 20 28 70 61 69 72 3f 20 nd ((not (pair?
5180: 74 72 65 65 29 29 0a 09 09 20 20 20 28 70 72 65 tree))... (pre
5190: 70 61 72 65 2d 64 69 73 70 61 74 63 68 2d 6c 65 pare-dispatch-le
51a0: 61 66 20 74 72 65 65 29 29 0a 09 09 20 20 28 28 af tree))... ((
51b0: 65 71 3f 20 28 63 61 72 20 74 72 65 65 29 20 27 eq? (car tree) '
51c0: 3d 29 0a 09 09 20 20 20 28 70 72 65 70 61 72 65 =)... (prepare
51d0: 2d 64 69 73 70 61 74 63 68 2d 3d 20 74 72 65 65 -dispatch-= tree
51e0: 29 29 0a 09 09 20 20 28 65 6c 73 65 0a 09 09 20 ))... (else...
51f0: 20 20 28 70 72 65 70 61 72 65 2d 64 69 73 70 61 (prepare-dispa
5200: 74 63 68 2d 3c 20 74 72 65 65 29 29 29 29 29 0a tch-< tree))))).
5210: 09 20 28 70 72 65 70 61 72 65 2d 64 69 73 70 61 . (prepare-dispa
5220: 74 63 68 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 tch.. (lambda (
5230: 74 72 65 65 29 0a 09 20 20 20 20 28 6c 65 74 20 tree).. (let
5240: 28 28 64 69 63 68 6f 2d 66 75 6e 63 20 28 70 72 ((dicho-func (pr
5250: 65 70 61 72 65 2d 64 69 73 70 61 74 63 68 2d 74 epare-dispatch-t
5260: 72 65 65 20 74 72 65 65 29 29 29 0a 09 20 20 20 ree tree)))..
5270: 20 20 20 28 6c 61 6d 62 64 61 20 28 63 29 0a 09 (lambda (c)..
5280: 09 28 61 6e 64 20 63 20 28 64 69 63 68 6f 2d 66 .(and c (dicho-f
5290: 75 6e 63 20 63 29 29 29 29 29 29 0a 0a 09 20 3b unc c))))))... ;
52a0: 20 46 61 62 72 69 71 75 65 20 6c 65 73 20 66 6f Fabrique les fo
52b0: 6e 63 74 69 6f 6e 73 20 64 65 20 74 72 61 6e 73 nctions de trans
52c0: 69 74 69 6f 6e 20 28 72 65 61 64 20 26 20 67 6f ition (read & go
52d0: 29 20 65 74 20 28 61 62 6f 72 74 29 0a 09 20 28 ) et (abort).. (
52e0: 70 72 65 70 61 72 65 2d 72 65 61 64 2d 6e 2d 67 prepare-read-n-g
52f0: 6f 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 74 72 o.. (lambda (tr
5300: 65 65 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 ee).. (let ((
5310: 64 69 73 70 61 74 63 68 2d 66 75 6e 63 20 28 70 dispatch-func (p
5320: 72 65 70 61 72 65 2d 64 69 73 70 61 74 63 68 20 repare-dispatch
5330: 74 72 65 65 29 29 0a 09 09 20 20 28 72 65 61 64 tree))... (read
5340: 2d 63 68 61 72 20 20 20 20 20 49 53 2d 72 65 61 -char IS-rea
5350: 64 2d 63 68 61 72 29 29 0a 09 20 20 20 20 20 20 d-char))..
5360: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 28 64 69 (lambda ()...(di
5370: 73 70 61 74 63 68 2d 66 75 6e 63 20 28 72 65 61 spatch-func (rea
5380: 64 2d 63 68 61 72 29 29 29 29 29 29 0a 09 20 28 d-char)))))).. (
5390: 70 72 65 70 61 72 65 2d 61 62 6f 72 74 0a 09 20 prepare-abort..
53a0: 20 28 6c 61 6d 62 64 61 20 28 74 72 65 65 29 0a (lambda (tree).
53b0: 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a . (lambda ().
53c0: 09 20 20 20 20 20 20 23 66 29 29 29 0a 09 20 28 . #f))).. (
53d0: 70 72 65 70 61 72 65 2d 74 72 61 6e 73 69 74 69 prepare-transiti
53e0: 6f 6e 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 74 on.. (lambda (t
53f0: 72 65 65 29 0a 09 20 20 20 20 28 69 66 20 28 65 ree).. (if (e
5400: 71 3f 20 74 72 65 65 20 27 65 72 72 29 0a 09 09 q? tree 'err)...
5410: 28 70 72 65 70 61 72 65 2d 61 62 6f 72 74 20 20 (prepare-abort
5420: 20 20 20 74 72 65 65 29 0a 09 09 28 70 72 65 70 tree)...(prep
5430: 61 72 65 2d 72 65 61 64 2d 6e 2d 67 6f 20 74 72 are-read-n-go tr
5440: 65 65 29 29 29 29 0a 0a 09 20 3b 20 46 61 62 72 ee))))... ; Fabr
5450: 69 71 75 65 20 6c 65 73 20 66 6f 6e 63 74 69 6f ique les fonctio
5460: 6e 73 20 64 27 65 74 61 74 73 20 28 5b 73 65 74 ns d'etats ([set
5470: 2d 65 6e 64 5d 20 26 20 74 72 61 6e 73 29 0a 09 -end] & trans)..
5480: 20 28 70 72 65 70 61 72 65 2d 73 74 61 74 65 2d (prepare-state-
5490: 6e 6f 2d 61 63 63 0a 09 20 20 20 28 6c 61 6d 62 no-acc.. (lamb
54a0: 64 61 20 28 73 20 72 31 20 72 32 29 0a 09 20 20 da (s r1 r2)..
54b0: 20 20 20 28 6c 65 74 20 28 28 74 72 61 6e 73 2d (let ((trans-
54c0: 66 75 6e 63 20 28 70 72 65 70 61 72 65 2d 74 72 func (prepare-tr
54d0: 61 6e 73 69 74 69 6f 6e 20 28 76 65 63 74 6f 72 ansition (vector
54e0: 2d 72 65 66 20 74 72 65 65 73 2d 76 20 73 29 29 -ref trees-v s))
54f0: 29 29 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 )).. (lamb
5500: 64 61 20 28 61 63 74 69 6f 6e 29 0a 09 09 20 28 da (action)... (
5510: 6c 65 74 20 28 28 6e 65 78 74 2d 73 74 61 74 65 let ((next-state
5520: 20 28 74 72 61 6e 73 2d 66 75 6e 63 29 29 29 0a (trans-func))).
5530: 09 09 20 20 20 28 69 66 20 6e 65 78 74 2d 73 74 .. (if next-st
5540: 61 74 65 0a 09 09 20 20 20 20 20 20 20 28 6e 65 ate... (ne
5550: 78 74 2d 73 74 61 74 65 20 61 63 74 69 6f 6e 29 xt-state action)
5560: 0a 09 09 20 20 20 20 20 20 20 61 63 74 69 6f 6e ... action
5570: 29 29 29 29 29 29 0a 09 20 28 70 72 65 70 61 72 )))))).. (prepar
5580: 65 2d 73 74 61 74 65 2d 79 65 73 2d 6e 6f 0a 09 e-state-yes-no..
5590: 20 20 28 6c 61 6d 62 64 61 20 28 73 20 72 31 20 (lambda (s r1
55a0: 72 32 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 r2).. (let ((
55b0: 70 65 65 6b 2d 63 68 61 72 20 20 20 20 20 20 20 peek-char
55c0: 49 53 2d 70 65 65 6b 2d 63 68 61 72 29 0a 09 09 IS-peek-char)...
55d0: 20 20 28 65 6e 64 2d 67 6f 2d 74 6f 2d 70 6f 69 (end-go-to-poi
55e0: 6e 74 20 49 53 2d 65 6e 64 2d 67 6f 2d 74 6f 2d nt IS-end-go-to-
55f0: 70 6f 69 6e 74 29 0a 09 09 20 20 28 6e 65 77 2d point)... (new-
5600: 61 63 74 69 6f 6e 31 20 20 20 20 20 23 66 29 0a action1 #f).
5610: 09 09 20 20 28 74 72 61 6e 73 2d 66 75 6e 63 20 .. (trans-func
5620: 28 70 72 65 70 61 72 65 2d 74 72 61 6e 73 69 74 (prepare-transit
5630: 69 6f 6e 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ion (vector-ref
5640: 74 72 65 65 73 2d 76 20 73 29 29 29 29 0a 09 20 trees-v s))))..
5650: 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 75 (let ((resu
5660: 6c 74 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 64 lt... (lambd
5670: 61 20 28 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 a (action)...
5680: 20 20 20 20 28 6c 65 74 2a 20 28 28 63 20 28 70 (let* ((c (p
5690: 65 65 6b 2d 63 68 61 72 29 29 0a 09 09 09 20 20 eek-char))....
56a0: 20 20 20 20 28 6e 65 77 2d 61 63 74 69 6f 6e 0a (new-action.
56b0: 09 09 09 20 20 20 20 20 20 20 28 69 66 20 28 6f ... (if (o
56c0: 72 20 28 6e 6f 74 20 63 29 20 28 3d 20 63 20 6c r (not c) (= c l
56d0: 65 78 65 72 2d 69 6e 74 65 67 65 72 2d 6e 65 77 exer-integer-new
56e0: 6c 69 6e 65 29 29 0a 09 09 09 09 20 20 20 28 62 line))..... (b
56f0: 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 28 65 egin..... (e
5700: 6e 64 2d 67 6f 2d 74 6f 2d 70 6f 69 6e 74 29 0a nd-go-to-point).
5710: 09 09 09 09 20 20 20 20 20 6e 65 77 2d 61 63 74 .... new-act
5720: 69 6f 6e 31 29 0a 09 09 09 09 20 20 20 61 63 74 ion1)..... act
5730: 69 6f 6e 29 29 0a 09 09 09 20 20 20 20 20 20 28 ion)).... (
5740: 6e 65 78 74 2d 73 74 61 74 65 20 28 74 72 61 6e next-state (tran
5750: 73 2d 66 75 6e 63 29 29 29 0a 09 09 09 20 28 69 s-func))).... (i
5760: 66 20 6e 65 78 74 2d 73 74 61 74 65 0a 09 09 09 f next-state....
5770: 20 20 20 20 20 28 6e 65 78 74 2d 73 74 61 74 65 (next-state
5780: 20 6e 65 77 2d 61 63 74 69 6f 6e 29 0a 09 09 09 new-action)....
5790: 20 20 20 20 20 6e 65 77 2d 61 63 74 69 6f 6e 29 new-action)
57a0: 29 29 29 0a 09 09 20 20 20 20 28 68 6f 6f 6b 0a )))... (hook.
57b0: 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
57c0: 29 0a 09 09 20 20 20 20 20 20 20 28 73 65 74 21 )... (set!
57d0: 20 6e 65 77 2d 61 63 74 69 6f 6e 31 20 28 76 65 new-action1 (ve
57e0: 63 74 6f 72 2d 72 65 66 20 72 75 6c 65 73 2d 61 ctor-ref rules-a
57f0: 63 74 69 6f 6e 73 20 72 31 29 29 29 29 29 0a 09 ctions r1)))))..
5800: 09 28 61 64 64 2d 68 6f 6f 6b 20 68 6f 6f 6b 29 .(add-hook hook)
5810: 0a 09 09 72 65 73 75 6c 74 29 29 29 29 0a 09 20 ...result))))..
5820: 28 70 72 65 70 61 72 65 2d 73 74 61 74 65 2d 64 (prepare-state-d
5830: 69 66 66 2d 61 63 63 0a 09 20 20 28 6c 61 6d 62 iff-acc.. (lamb
5840: 64 61 20 28 73 20 72 31 20 72 32 29 0a 09 20 20 da (s r1 r2)..
5850: 20 20 28 6c 65 74 20 28 28 65 6e 64 2d 67 6f 2d (let ((end-go-
5860: 74 6f 2d 70 6f 69 6e 74 20 49 53 2d 65 6e 64 2d to-point IS-end-
5870: 67 6f 2d 74 6f 2d 70 6f 69 6e 74 29 0a 09 09 20 go-to-point)...
5880: 20 28 70 65 65 6b 2d 63 68 61 72 20 20 20 20 20 (peek-char
5890: 20 20 49 53 2d 70 65 65 6b 2d 63 68 61 72 29 0a IS-peek-char).
58a0: 09 09 20 20 28 6e 65 77 2d 61 63 74 69 6f 6e 31 .. (new-action1
58b0: 20 20 20 20 20 23 66 29 0a 09 09 20 20 28 6e 65 #f)... (ne
58c0: 77 2d 61 63 74 69 6f 6e 32 20 20 20 20 20 23 66 w-action2 #f
58d0: 29 0a 09 09 20 20 28 74 72 61 6e 73 2d 66 75 6e )... (trans-fun
58e0: 63 20 28 70 72 65 70 61 72 65 2d 74 72 61 6e 73 c (prepare-trans
58f0: 69 74 69 6f 6e 20 28 76 65 63 74 6f 72 2d 72 65 ition (vector-re
5900: 66 20 74 72 65 65 73 2d 76 20 73 29 29 29 29 0a f trees-v s)))).
5910: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
5920: 73 75 6c 74 0a 09 09 20 20 20 20 20 28 6c 61 6d sult... (lam
5930: 62 64 61 20 28 61 63 74 69 6f 6e 29 0a 09 09 20 bda (action)...
5940: 20 20 20 20 20 20 28 65 6e 64 2d 67 6f 2d 74 6f (end-go-to
5950: 2d 70 6f 69 6e 74 29 0a 09 09 20 20 20 20 20 20 -point)...
5960: 20 28 6c 65 74 2a 20 28 28 63 20 28 70 65 65 6b (let* ((c (peek
5970: 2d 63 68 61 72 29 29 0a 09 09 09 20 20 20 20 20 -char))....
5980: 20 28 6e 65 77 2d 61 63 74 69 6f 6e 0a 09 09 09 (new-action....
5990: 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 (if (or (
59a0: 6e 6f 74 20 63 29 20 28 3d 20 63 20 6c 65 78 65 not c) (= c lexe
59b0: 72 2d 69 6e 74 65 67 65 72 2d 6e 65 77 6c 69 6e r-integer-newlin
59c0: 65 29 29 0a 09 09 09 09 20 20 20 6e 65 77 2d 61 e))..... new-a
59d0: 63 74 69 6f 6e 31 0a 09 09 09 09 20 20 20 6e 65 ction1..... ne
59e0: 77 2d 61 63 74 69 6f 6e 32 29 29 0a 09 09 09 20 w-action2))....
59f0: 20 20 20 20 20 28 6e 65 78 74 2d 73 74 61 74 65 (next-state
5a00: 20 28 74 72 61 6e 73 2d 66 75 6e 63 29 29 29 0a (trans-func))).
5a10: 09 09 09 20 28 69 66 20 6e 65 78 74 2d 73 74 61 ... (if next-sta
5a20: 74 65 0a 09 09 09 20 20 20 20 20 28 6e 65 78 74 te.... (next
5a30: 2d 73 74 61 74 65 20 6e 65 77 2d 61 63 74 69 6f -state new-actio
5a40: 6e 29 0a 09 09 09 20 20 20 20 20 6e 65 77 2d 61 n).... new-a
5a50: 63 74 69 6f 6e 29 29 29 29 0a 09 09 20 20 20 20 ction))))...
5a60: 28 68 6f 6f 6b 0a 09 09 20 20 20 20 20 28 6c 61 (hook... (la
5a70: 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 20 mbda ()...
5a80: 20 28 73 65 74 21 20 6e 65 77 2d 61 63 74 69 6f (set! new-actio
5a90: 6e 31 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 n1 (vector-ref r
5aa0: 75 6c 65 73 2d 61 63 74 69 6f 6e 73 20 72 31 29 ules-actions r1)
5ab0: 29 0a 09 09 20 20 20 20 20 20 20 28 73 65 74 21 )... (set!
5ac0: 20 6e 65 77 2d 61 63 74 69 6f 6e 32 20 28 76 65 new-action2 (ve
5ad0: 63 74 6f 72 2d 72 65 66 20 72 75 6c 65 73 2d 61 ctor-ref rules-a
5ae0: 63 74 69 6f 6e 73 20 72 32 29 29 29 29 29 0a 09 ctions r2)))))..
5af0: 09 28 61 64 64 2d 68 6f 6f 6b 20 68 6f 6f 6b 29 .(add-hook hook)
5b00: 0a 09 09 72 65 73 75 6c 74 29 29 29 29 0a 09 20 ...result))))..
5b10: 28 70 72 65 70 61 72 65 2d 73 74 61 74 65 2d 73 (prepare-state-s
5b20: 61 6d 65 2d 61 63 63 0a 09 20 20 28 6c 61 6d 62 ame-acc.. (lamb
5b30: 64 61 20 28 73 20 72 31 20 72 32 29 0a 09 20 20 da (s r1 r2)..
5b40: 20 20 28 6c 65 74 20 28 28 65 6e 64 2d 67 6f 2d (let ((end-go-
5b50: 74 6f 2d 70 6f 69 6e 74 20 49 53 2d 65 6e 64 2d to-point IS-end-
5b60: 67 6f 2d 74 6f 2d 70 6f 69 6e 74 29 0a 09 09 20 go-to-point)...
5b70: 20 28 74 72 61 6e 73 2d 66 75 6e 63 20 28 70 72 (trans-func (pr
5b80: 65 70 61 72 65 2d 74 72 61 6e 73 69 74 69 6f 6e epare-transition
5b90: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 72 65 (vector-ref tre
5ba0: 65 73 2d 76 20 73 29 29 29 0a 09 09 20 20 28 6e es-v s)))... (n
5bb0: 65 77 2d 61 63 74 69 6f 6e 20 23 66 29 29 0a 09 ew-action #f))..
5bc0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
5bd0: 75 6c 74 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 ult... (lamb
5be0: 64 61 20 28 61 63 74 69 6f 6e 29 0a 09 09 20 20 da (action)...
5bf0: 20 20 20 20 20 28 65 6e 64 2d 67 6f 2d 74 6f 2d (end-go-to-
5c00: 70 6f 69 6e 74 29 0a 09 09 20 20 20 20 20 20 20 point)...
5c10: 28 6c 65 74 20 28 28 6e 65 78 74 2d 73 74 61 74 (let ((next-stat
5c20: 65 20 28 74 72 61 6e 73 2d 66 75 6e 63 29 29 29 e (trans-func)))
5c30: 0a 09 09 09 20 28 69 66 20 6e 65 78 74 2d 73 74 .... (if next-st
5c40: 61 74 65 0a 09 09 09 20 20 20 20 20 28 6e 65 78 ate.... (nex
5c50: 74 2d 73 74 61 74 65 20 6e 65 77 2d 61 63 74 69 t-state new-acti
5c60: 6f 6e 29 0a 09 09 09 20 20 20 20 20 6e 65 77 2d on).... new-
5c70: 61 63 74 69 6f 6e 29 29 29 29 0a 09 09 20 20 20 action))))...
5c80: 20 28 68 6f 6f 6b 0a 09 09 20 20 20 20 20 28 6c (hook... (l
5c90: 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 ambda ()...
5ca0: 20 20 28 73 65 74 21 20 6e 65 77 2d 61 63 74 69 (set! new-acti
5cb0: 6f 6e 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 on (vector-ref r
5cc0: 75 6c 65 73 2d 61 63 74 69 6f 6e 73 20 72 31 29 ules-actions r1)
5cd0: 29 29 29 29 0a 09 09 28 61 64 64 2d 68 6f 6f 6b ))))...(add-hook
5ce0: 20 68 6f 6f 6b 29 0a 09 09 72 65 73 75 6c 74 29 hook)...result)
5cf0: 29 29 29 0a 09 20 28 70 72 65 70 61 72 65 2d 73 ))).. (prepare-s
5d00: 74 61 74 65 0a 09 20 20 28 6c 61 6d 62 64 61 20 tate.. (lambda
5d10: 28 73 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 (s).. (let* (
5d20: 28 61 63 63 20 28 76 65 63 74 6f 72 2d 72 65 66 (acc (vector-ref
5d30: 20 61 63 63 2d 76 20 73 29 29 0a 09 09 20 20 20 acc-v s))...
5d40: 28 72 31 20 28 63 61 72 20 61 63 63 29 29 0a 09 (r1 (car acc))..
5d50: 09 20 20 20 28 72 32 20 28 63 64 72 20 61 63 63 . (r2 (cdr acc
5d60: 29 29 29 0a 09 20 20 20 20 20 20 28 63 6f 6e 64 ))).. (cond
5d70: 20 28 28 6e 6f 74 20 72 31 29 20 20 28 70 72 65 ((not r1) (pre
5d80: 70 61 72 65 2d 73 74 61 74 65 2d 6e 6f 2d 61 63 pare-state-no-ac
5d90: 63 20 20 20 73 20 72 31 20 72 32 29 29 0a 09 09 c s r1 r2))...
5da0: 20 20 20 20 28 28 6e 6f 74 20 72 32 29 20 20 28 ((not r2) (
5db0: 70 72 65 70 61 72 65 2d 73 74 61 74 65 2d 79 65 prepare-state-ye
5dc0: 73 2d 6e 6f 20 20 20 73 20 72 31 20 72 32 29 29 s-no s r1 r2))
5dd0: 0a 09 09 20 20 20 20 28 28 3c 20 72 31 20 72 32 ... ((< r1 r2
5de0: 29 20 28 70 72 65 70 61 72 65 2d 73 74 61 74 65 ) (prepare-state
5df0: 2d 64 69 66 66 2d 61 63 63 20 73 20 72 31 20 72 -diff-acc s r1 r
5e00: 32 29 29 0a 09 09 20 20 20 20 28 65 6c 73 65 20 2))... (else
5e10: 20 20 20 20 20 28 70 72 65 70 61 72 65 2d 73 74 (prepare-st
5e20: 61 74 65 2d 73 61 6d 65 2d 61 63 63 20 73 20 72 ate-same-acc s r
5e30: 31 20 72 32 29 29 29 29 29 29 0a 0a 09 20 3b 20 1 r2))))))... ;
5e40: 46 61 62 72 69 71 75 65 20 6c 61 20 66 6f 6e 63 Fabrique la fonc
5e50: 74 69 6f 6e 20 64 65 20 6c 61 6e 63 65 6d 65 6e tion de lancemen
5e60: 74 20 64 75 20 6c 65 78 61 67 65 20 61 20 6c 27 t du lexage a l'
5e70: 65 74 61 74 20 64 65 20 64 65 70 61 72 74 0a 09 etat de depart..
5e80: 20 28 70 72 65 70 61 72 65 2d 73 74 61 72 74 2d (prepare-start-
5e90: 73 61 6d 65 0a 09 20 20 28 6c 61 6d 62 64 61 20 same.. (lambda
5ea0: 28 73 31 20 73 32 29 0a 09 20 20 20 20 28 6c 65 (s1 s2).. (le
5eb0: 74 20 28 28 70 65 65 6b 2d 63 68 61 72 20 20 20 t ((peek-char
5ec0: 20 49 53 2d 70 65 65 6b 2d 63 68 61 72 29 0a 09 IS-peek-char)..
5ed0: 09 20 20 28 65 6f 66 2d 61 63 74 69 6f 6e 20 20 . (eof-action
5ee0: 20 23 66 29 0a 09 09 20 20 28 73 74 61 72 74 2d #f)... (start-
5ef0: 73 74 61 74 65 20 20 23 66 29 0a 09 09 20 20 28 state #f)... (
5f00: 65 72 72 6f 72 2d 61 63 74 69 6f 6e 20 23 66 29 error-action #f)
5f10: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ).. (let ((
5f20: 72 65 73 75 6c 74 0a 09 09 20 20 20 20 20 28 6c result... (l
5f30: 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 20 ambda ()...
5f40: 20 20 28 69 66 20 28 6e 6f 74 20 28 70 65 65 6b (if (not (peek
5f50: 2d 63 68 61 72 29 29 0a 09 09 09 20 20 20 65 6f -char)).... eo
5f60: 66 2d 61 63 74 69 6f 6e 0a 09 09 09 20 20 20 28 f-action.... (
5f70: 73 74 61 72 74 2d 73 74 61 74 65 20 65 72 72 6f start-state erro
5f80: 72 2d 61 63 74 69 6f 6e 29 29 29 29 0a 09 09 20 r-action))))...
5f90: 20 20 20 28 68 6f 6f 6b 0a 09 09 20 20 20 20 20 (hook...
5fa0: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 (lambda ()...
5fb0: 20 20 20 20 28 73 65 74 21 20 65 6f 66 2d 61 63 (set! eof-ac
5fc0: 74 69 6f 6e 20 20 20 3c 3c 45 4f 46 3e 3e 2d 61 tion <<EOF>>-a
5fd0: 63 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 20 20 ction)...
5fe0: 28 73 65 74 21 20 73 74 61 72 74 2d 73 74 61 74 (set! start-stat
5ff0: 65 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 73 e (vector-ref s
6000: 74 61 74 65 73 20 73 31 29 29 0a 09 09 20 20 20 tates s1))...
6010: 20 20 20 20 28 73 65 74 21 20 65 72 72 6f 72 2d (set! error-
6020: 61 63 74 69 6f 6e 20 3c 3c 45 52 52 4f 52 3e 3e action <<ERROR>>
6030: 2d 61 63 74 69 6f 6e 29 29 29 29 0a 09 09 28 61 -action))))...(a
6040: 64 64 2d 68 6f 6f 6b 20 68 6f 6f 6b 29 0a 09 09 dd-hook hook)...
6050: 72 65 73 75 6c 74 29 29 29 29 0a 09 20 28 70 72 result)))).. (pr
6060: 65 70 61 72 65 2d 73 74 61 72 74 2d 64 69 66 66 epare-start-diff
6070: 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 73 31 20 .. (lambda (s1
6080: 73 32 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 s2).. (let ((
6090: 70 65 65 6b 2d 63 68 61 72 20 20 20 20 20 20 20 peek-char
60a0: 20 20 49 53 2d 70 65 65 6b 2d 63 68 61 72 29 0a IS-peek-char).
60b0: 09 09 20 20 28 65 6f 66 2d 61 63 74 69 6f 6e 20 .. (eof-action
60c0: 20 20 20 20 20 20 20 23 66 29 0a 09 09 20 20 28 #f)... (
60d0: 70 65 65 6b 2d 6c 65 66 74 2d 63 6f 6e 74 65 78 peek-left-contex
60e0: 74 20 49 53 2d 70 65 65 6b 2d 6c 65 66 74 2d 63 t IS-peek-left-c
60f0: 6f 6e 74 65 78 74 29 0a 09 09 20 20 28 73 74 61 ontext)... (sta
6100: 72 74 2d 73 74 61 74 65 31 20 20 20 20 20 20 23 rt-state1 #
6110: 66 29 0a 09 09 20 20 28 73 74 61 72 74 2d 73 74 f)... (start-st
6120: 61 74 65 32 20 20 20 20 20 20 23 66 29 0a 09 09 ate2 #f)...
6130: 20 20 28 65 72 72 6f 72 2d 61 63 74 69 6f 6e 20 (error-action
6140: 20 20 20 20 20 23 66 29 29 0a 09 20 20 20 20 20 #f))..
6150: 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 0a 09 (let ((result..
6160: 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 . (lambda ()
6170: 0a 09 09 20 20 20 20 20 20 20 28 63 6f 6e 64 20 ... (cond
6180: 28 28 6e 6f 74 20 28 70 65 65 6b 2d 63 68 61 72 ((not (peek-char
6190: 29 29 0a 09 09 09 20 20 20 20 20 20 65 6f 66 2d )).... eof-
61a0: 61 63 74 69 6f 6e 29 0a 09 09 09 20 20 20 20 20 action)....
61b0: 28 28 3d 20 28 70 65 65 6b 2d 6c 65 66 74 2d 63 ((= (peek-left-c
61c0: 6f 6e 74 65 78 74 29 20 6c 65 78 65 72 2d 69 6e ontext) lexer-in
61d0: 74 65 67 65 72 2d 6e 65 77 6c 69 6e 65 29 0a 09 teger-newline)..
61e0: 09 09 20 20 20 20 20 20 28 73 74 61 72 74 2d 73 .. (start-s
61f0: 74 61 74 65 31 20 65 72 72 6f 72 2d 61 63 74 69 tate1 error-acti
6200: 6f 6e 29 29 0a 09 09 09 20 20 20 20 20 28 65 6c on)).... (el
6210: 73 65 0a 09 09 09 20 20 20 20 20 20 28 73 74 61 se.... (sta
6220: 72 74 2d 73 74 61 74 65 32 20 65 72 72 6f 72 2d rt-state2 error-
6230: 61 63 74 69 6f 6e 29 29 29 29 29 0a 09 09 20 20 action)))))...
6240: 20 20 28 68 6f 6f 6b 0a 09 09 20 20 20 20 20 28 (hook... (
6250: 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 20 lambda ()...
6260: 20 20 20 28 73 65 74 21 20 65 6f 66 2d 61 63 74 (set! eof-act
6270: 69 6f 6e 20 3c 3c 45 4f 46 3e 3e 2d 61 63 74 69 ion <<EOF>>-acti
6280: 6f 6e 29 0a 09 09 20 20 20 20 20 20 20 28 73 65 on)... (se
6290: 74 21 20 73 74 61 72 74 2d 73 74 61 74 65 31 20 t! start-state1
62a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 73 74 61 74 (vector-ref stat
62b0: 65 73 20 73 31 29 29 0a 09 09 20 20 20 20 20 20 es s1))...
62c0: 20 28 73 65 74 21 20 73 74 61 72 74 2d 73 74 61 (set! start-sta
62d0: 74 65 32 20 28 76 65 63 74 6f 72 2d 72 65 66 20 te2 (vector-ref
62e0: 73 74 61 74 65 73 20 73 32 29 29 0a 09 09 20 20 states s2))...
62f0: 20 20 20 20 20 28 73 65 74 21 20 65 72 72 6f 72 (set! error
6300: 2d 61 63 74 69 6f 6e 20 3c 3c 45 52 52 4f 52 3e -action <<ERROR>
6310: 3e 2d 61 63 74 69 6f 6e 29 29 29 29 0a 09 09 28 >-action))))...(
6320: 61 64 64 2d 68 6f 6f 6b 20 68 6f 6f 6b 29 0a 09 add-hook hook)..
6330: 09 72 65 73 75 6c 74 29 29 29 29 0a 09 20 28 70 .result)))).. (p
6340: 72 65 70 61 72 65 2d 73 74 61 72 74 0a 09 20 20 repare-start..
6350: 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 (lambda ()..
6360: 28 6c 65 74 20 28 28 73 31 20 74 61 62 6c 65 2d (let ((s1 table-
6370: 6e 6c 2d 73 74 61 72 74 29 0a 09 09 20 20 28 73 nl-start)... (s
6380: 32 20 74 61 62 6c 65 2d 6e 6f 2d 6e 6c 2d 73 74 2 table-no-nl-st
6390: 61 72 74 29 29 0a 09 20 20 20 20 20 20 28 69 66 art)).. (if
63a0: 20 28 3d 20 73 31 20 73 32 29 0a 09 09 20 20 28 (= s1 s2)... (
63b0: 70 72 65 70 61 72 65 2d 73 74 61 72 74 2d 73 61 prepare-start-sa
63c0: 6d 65 20 73 31 20 73 32 29 0a 09 09 20 20 28 70 me s1 s2)... (p
63d0: 72 65 70 61 72 65 2d 73 74 61 72 74 2d 64 69 66 repare-start-dif
63e0: 66 20 73 31 20 73 32 29 29 29 29 29 0a 0a 09 20 f s1 s2)))))...
63f0: 3b 20 46 61 62 72 69 71 75 65 20 6c 61 20 66 6f ; Fabrique la fo
6400: 6e 63 74 69 6f 6e 20 70 72 69 6e 63 69 70 61 6c nction principal
6410: 65 0a 09 20 28 70 72 65 70 61 72 65 2d 6c 65 78 e.. (prepare-lex
6420: 65 72 2d 6e 6f 6e 65 0a 09 20 20 28 6c 61 6d 62 er-none.. (lamb
6430: 64 61 20 28 29 0a 09 20 20 20 20 28 6c 65 74 20 da ().. (let
6440: 28 28 69 6e 69 74 2d 6c 65 78 65 6d 65 20 49 53 ((init-lexeme IS
6450: 2d 69 6e 69 74 2d 6c 65 78 65 6d 65 29 0a 09 09 -init-lexeme)...
6460: 20 20 28 73 74 61 72 74 2d 66 75 6e 63 20 20 28 (start-func (
6470: 70 72 65 70 61 72 65 2d 73 74 61 72 74 29 29 29 prepare-start)))
6480: 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .. (lambda
6490: 28 29 0a 09 09 28 69 6e 69 74 2d 6c 65 78 65 6d ()...(init-lexem
64a0: 65 29 0a 09 09 28 28 73 74 61 72 74 2d 66 75 6e e)...((start-fun
64b0: 63 29 29 29 29 29 29 0a 09 20 28 70 72 65 70 61 c)))))).. (prepa
64c0: 72 65 2d 6c 65 78 65 72 2d 6c 69 6e 65 0a 09 20 re-lexer-line..
64d0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 (lambda ()..
64e0: 20 28 6c 65 74 20 28 28 69 6e 69 74 2d 6c 65 78 (let ((init-lex
64f0: 65 6d 65 20 20 20 20 49 53 2d 69 6e 69 74 2d 6c eme IS-init-l
6500: 65 78 65 6d 65 29 0a 09 09 20 20 28 67 65 74 2d exeme)... (get-
6510: 73 74 61 72 74 2d 6c 69 6e 65 20 49 53 2d 67 65 start-line IS-ge
6520: 74 2d 73 74 61 72 74 2d 6c 69 6e 65 29 0a 09 09 t-start-line)...
6530: 20 20 28 73 74 61 72 74 2d 66 75 6e 63 20 20 20 (start-func
6540: 20 20 28 70 72 65 70 61 72 65 2d 73 74 61 72 74 (prepare-start
6550: 29 29 29 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 ))).. (lamb
6560: 64 61 20 28 29 0a 09 09 28 69 6e 69 74 2d 6c 65 da ()...(init-le
6570: 78 65 6d 65 29 0a 09 09 28 6c 65 74 20 28 28 79 xeme)...(let ((y
6580: 79 6c 69 6e 65 20 28 67 65 74 2d 73 74 61 72 74 yline (get-start
6590: 2d 6c 69 6e 65 29 29 29 0a 09 09 20 20 28 28 73 -line)))... ((s
65a0: 74 61 72 74 2d 66 75 6e 63 29 20 79 79 6c 69 6e tart-func) yylin
65b0: 65 29 29 29 29 29 29 0a 09 20 28 70 72 65 70 61 e)))))).. (prepa
65c0: 72 65 2d 6c 65 78 65 72 2d 61 6c 6c 0a 09 20 20 re-lexer-all..
65d0: 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 (lambda ()..
65e0: 28 6c 65 74 20 28 28 69 6e 69 74 2d 6c 65 78 65 (let ((init-lexe
65f0: 6d 65 20 20 20 20 20 20 49 53 2d 69 6e 69 74 2d me IS-init-
6600: 6c 65 78 65 6d 65 29 0a 09 09 20 20 28 67 65 74 lexeme)... (get
6610: 2d 73 74 61 72 74 2d 6c 69 6e 65 20 20 20 49 53 -start-line IS
6620: 2d 67 65 74 2d 73 74 61 72 74 2d 6c 69 6e 65 29 -get-start-line)
6630: 0a 09 09 20 20 28 67 65 74 2d 73 74 61 72 74 2d ... (get-start-
6640: 63 6f 6c 75 6d 6e 20 49 53 2d 67 65 74 2d 73 74 column IS-get-st
6650: 61 72 74 2d 63 6f 6c 75 6d 6e 29 0a 09 09 20 20 art-column)...
6660: 28 67 65 74 2d 73 74 61 72 74 2d 6f 66 66 73 65 (get-start-offse
6670: 74 20 49 53 2d 67 65 74 2d 73 74 61 72 74 2d 6f t IS-get-start-o
6680: 66 66 73 65 74 29 0a 09 09 20 20 28 73 74 61 72 ffset)... (star
6690: 74 2d 66 75 6e 63 20 20 20 20 20 20 20 28 70 72 t-func (pr
66a0: 65 70 61 72 65 2d 73 74 61 72 74 29 29 29 0a 09 epare-start)))..
66b0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
66c0: 0a 09 09 28 69 6e 69 74 2d 6c 65 78 65 6d 65 29 ...(init-lexeme)
66d0: 0a 09 09 28 6c 65 74 20 28 28 79 79 6c 69 6e 65 ...(let ((yyline
66e0: 20 20 20 28 67 65 74 2d 73 74 61 72 74 2d 6c 69 (get-start-li
66f0: 6e 65 29 29 0a 09 09 20 20 20 20 20 20 28 79 79 ne))... (yy
6700: 63 6f 6c 75 6d 6e 20 28 67 65 74 2d 73 74 61 72 column (get-star
6710: 74 2d 63 6f 6c 75 6d 6e 29 29 0a 09 09 20 20 20 t-column))...
6720: 20 20 20 28 79 79 6f 66 66 73 65 74 20 28 67 65 (yyoffset (ge
6730: 74 2d 73 74 61 72 74 2d 6f 66 66 73 65 74 29 29 t-start-offset))
6740: 29 0a 09 09 20 20 28 28 73 74 61 72 74 2d 66 75 )... ((start-fu
6750: 6e 63 29 20 79 79 6c 69 6e 65 20 79 79 63 6f 6c nc) yyline yycol
6760: 75 6d 6e 20 79 79 6f 66 66 73 65 74 29 29 29 29 umn yyoffset))))
6770: 29 29 0a 09 20 28 70 72 65 70 61 72 65 2d 6c 65 )).. (prepare-le
6780: 78 65 72 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 xer.. (lambda (
6790: 29 0a 09 20 20 20 20 28 63 6f 6e 64 20 28 28 65 ).. (cond ((e
67a0: 71 3f 20 63 6f 75 6e 74 65 72 73 2d 74 79 70 65 q? counters-type
67b0: 20 27 6e 6f 6e 65 29 20 28 70 72 65 70 61 72 65 'none) (prepare
67c0: 2d 6c 65 78 65 72 2d 6e 6f 6e 65 29 29 0a 09 09 -lexer-none))...
67d0: 20 20 28 28 65 71 3f 20 63 6f 75 6e 74 65 72 73 ((eq? counters
67e0: 2d 74 79 70 65 20 27 6c 69 6e 65 29 20 28 70 72 -type 'line) (pr
67f0: 65 70 61 72 65 2d 6c 65 78 65 72 2d 6c 69 6e 65 epare-lexer-line
6800: 29 29 0a 09 09 20 20 28 28 65 71 3f 20 63 6f 75 ))... ((eq? cou
6810: 6e 74 65 72 73 2d 74 79 70 65 20 27 61 6c 6c 29 nters-type 'all)
6820: 20 20 28 70 72 65 70 61 72 65 2d 6c 65 78 65 72 (prepare-lexer
6830: 2d 61 6c 6c 29 29 29 29 29 29 0a 0a 20 20 20 20 -all))))))..
6840: 20 20 3b 20 43 61 6c 63 75 6c 65 72 20 6c 61 20 ; Calculer la
6850: 76 61 6c 65 75 72 20 64 65 20 3c 3c 45 4f 46 3e valeur de <<EOF>
6860: 3e 2d 61 63 74 69 6f 6e 20 65 74 20 64 65 20 3c >-action et de <
6870: 3c 45 52 52 4f 52 3e 3e 2d 61 63 74 69 6f 6e 0a <ERROR>>-action.
6880: 20 20 20 20 20 20 28 73 65 74 21 20 3c 3c 45 4f (set! <<EO
6890: 46 3e 3e 2d 61 63 74 69 6f 6e 20 20 20 28 70 72 F>>-action (pr
68a0: 65 70 61 72 65 2d 73 70 65 63 69 61 6c 2d 61 63 epare-special-ac
68b0: 74 69 6f 6e 20 3c 3c 45 4f 46 3e 3e 2d 70 72 65 tion <<EOF>>-pre
68c0: 2d 61 63 74 69 6f 6e 29 29 0a 20 20 20 20 20 20 -action)).
68d0: 28 73 65 74 21 20 3c 3c 45 52 52 4f 52 3e 3e 2d (set! <<ERROR>>-
68e0: 61 63 74 69 6f 6e 20 28 70 72 65 70 61 72 65 2d action (prepare-
68f0: 73 70 65 63 69 61 6c 2d 61 63 74 69 6f 6e 20 3c special-action <
6900: 3c 45 52 52 4f 52 3e 3e 2d 70 72 65 2d 61 63 74 <ERROR>>-pre-act
6910: 69 6f 6e 29 29 0a 0a 20 20 20 20 20 20 3b 20 43 ion)).. ; C
6920: 61 6c 63 75 6c 65 72 20 6c 61 20 76 61 6c 65 75 alculer la valeu
6930: 72 20 64 65 20 72 75 6c 65 73 2d 61 63 74 69 6f r de rules-actio
6940: 6e 73 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ns. (let* (
6950: 28 6c 65 6e 20 28 71 75 6f 74 69 65 6e 74 20 28 (len (quotient (
6960: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 72 75 vector-length ru
6970: 6c 65 73 2d 70 72 65 2d 61 63 74 69 6f 6e 73 29 les-pre-actions)
6980: 20 32 29 29 0a 09 20 20 20 20 20 28 76 20 28 6d 2)).. (v (m
6990: 61 6b 65 2d 76 65 63 74 6f 72 20 6c 65 6e 29 29 ake-vector len))
69a0: 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 72 )..(let loop ((r
69b0: 20 28 2d 20 6c 65 6e 20 31 29 29 29 0a 09 20 20 (- len 1)))..
69c0: 28 69 66 20 28 3c 20 72 20 30 29 0a 09 20 20 20 (if (< r 0)..
69d0: 20 20 20 28 73 65 74 21 20 72 75 6c 65 73 2d 61 (set! rules-a
69e0: 63 74 69 6f 6e 73 20 76 29 0a 09 20 20 20 20 20 ctions v)..
69f0: 20 28 6c 65 74 2a 20 28 28 79 79 74 65 78 74 3f (let* ((yytext?
6a00: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6c (vector-ref rul
6a10: 65 73 2d 70 72 65 2d 61 63 74 69 6f 6e 73 20 28 es-pre-actions (
6a20: 2a 20 32 20 72 29 29 29 0a 09 09 20 20 20 20 20 * 2 r)))...
6a30: 28 70 72 65 2d 61 63 74 69 6f 6e 20 28 76 65 63 (pre-action (vec
6a40: 74 6f 72 2d 72 65 66 20 72 75 6c 65 73 2d 70 72 tor-ref rules-pr
6a50: 65 2d 61 63 74 69 6f 6e 73 20 28 2b 20 28 2a 20 e-actions (+ (*
6a60: 32 20 72 29 20 31 29 29 29 0a 09 09 20 20 20 20 2 r) 1)))...
6a70: 20 28 61 63 74 69 6f 6e 20 28 69 66 20 79 79 74 (action (if yyt
6a80: 65 78 74 3f 0a 09 09 09 09 20 28 70 72 65 70 61 ext?..... (prepa
6a90: 72 65 2d 61 63 74 69 6f 6e 2d 79 79 74 65 78 74 re-action-yytext
6aa0: 20 20 20 20 70 72 65 2d 61 63 74 69 6f 6e 29 0a pre-action).
6ab0: 09 09 09 09 20 28 70 72 65 70 61 72 65 2d 61 63 .... (prepare-ac
6ac0: 74 69 6f 6e 2d 6e 6f 2d 79 79 74 65 78 74 20 70 tion-no-yytext p
6ad0: 72 65 2d 61 63 74 69 6f 6e 29 29 29 29 0a 09 09 re-action))))...
6ae0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 20 72 (vector-set! v r
6af0: 20 61 63 74 69 6f 6e 29 0a 09 09 28 6c 6f 6f 70 action)...(loop
6b00: 20 28 2d 20 72 20 31 29 29 29 29 29 29 0a 0a 20 (- r 1))))))..
6b10: 20 20 20 20 20 3b 20 43 61 6c 63 75 6c 65 72 20 ; Calculer
6b20: 6c 61 20 76 61 6c 65 75 72 20 64 65 20 73 74 61 la valeur de sta
6b30: 74 65 73 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 tes. (let*
6b40: 28 28 6c 65 6e 20 28 76 65 63 74 6f 72 2d 6c 65 ((len (vector-le
6b50: 6e 67 74 68 20 74 72 65 65 73 2d 76 29 29 0a 09 ngth trees-v))..
6b60: 20 20 20 20 20 28 76 20 28 6d 61 6b 65 2d 76 65 (v (make-ve
6b70: 63 74 6f 72 20 6c 65 6e 29 29 29 0a 09 28 6c 65 ctor len)))..(le
6b80: 74 20 6c 6f 6f 70 20 28 28 73 20 28 2d 20 6c 65 t loop ((s (- le
6b90: 6e 20 31 29 29 29 0a 09 20 20 28 69 66 20 28 3c n 1))).. (if (<
6ba0: 20 73 20 30 29 0a 09 20 20 20 20 20 20 28 73 65 s 0).. (se
6bb0: 74 21 20 73 74 61 74 65 73 20 76 29 0a 09 20 20 t! states v)..
6bc0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 76 65 (begin...(ve
6bd0: 63 74 6f 72 2d 73 65 74 21 20 76 20 73 20 28 70 ctor-set! v s (p
6be0: 72 65 70 61 72 65 2d 73 74 61 74 65 20 73 29 29 repare-state s))
6bf0: 0a 09 09 28 6c 6f 6f 70 20 28 2d 20 73 20 31 29 ...(loop (- s 1)
6c00: 29 29 29 29 29 0a 0a 20 20 20 20 20 20 3b 20 43 ))))).. ; C
6c10: 61 6c 63 75 6c 65 72 20 6c 61 20 76 61 6c 65 75 alculer la valeu
6c20: 72 20 64 65 20 66 69 6e 61 6c 2d 6c 65 78 65 72 r de final-lexer
6c30: 0a 20 20 20 20 20 20 28 73 65 74 21 20 66 69 6e . (set! fin
6c40: 61 6c 2d 6c 65 78 65 72 20 28 70 72 65 70 61 72 al-lexer (prepar
6c50: 65 2d 6c 65 78 65 72 29 29 0a 0a 20 20 20 20 20 e-lexer))..
6c60: 20 3b 20 45 78 65 63 75 74 65 72 20 6c 65 73 20 ; Executer les
6c70: 68 6f 6f 6b 73 0a 20 20 20 20 20 20 28 61 70 70 hooks. (app
6c80: 6c 79 2d 68 6f 6f 6b 73 29 0a 0a 20 20 20 20 20 ly-hooks)..
6c90: 20 3b 20 52 65 73 75 6c 74 61 74 0a 20 20 20 20 ; Resultat.
6ca0: 20 20 66 69 6e 61 6c 2d 6c 65 78 65 72 29 29 29 final-lexer)))
6cb0: 0a 0a 3b 20 46 61 62 72 69 63 61 74 69 6f 6e 20 ..; Fabrication
6cc0: 64 65 20 6c 65 78 65 72 20 61 20 70 61 72 74 69 de lexer a parti
6cd0: 72 20 64 65 20 6c 69 73 74 65 73 20 64 65 20 63 r de listes de c
6ce0: 61 72 61 63 74 65 72 65 73 20 74 61 67 67 65 65 aracteres taggee
6cf0: 73 0a 28 64 65 66 69 6e 65 20 6c 65 78 65 72 2d s.(define lexer-
6d00: 6d 61 6b 65 2d 63 68 61 72 2d 6c 65 78 65 72 0a make-char-lexer.
6d10: 20 20 28 6c 65 74 2a 20 28 28 63 68 61 72 2d 3e (let* ((char->
6d20: 63 6c 61 73 73 0a 09 20 20 28 6c 61 6d 62 64 61 class.. (lambda
6d30: 20 28 63 29 0a 09 20 20 20 20 28 6c 65 74 20 28 (c).. (let (
6d40: 28 6e 20 28 63 68 61 72 2d 3e 69 6e 74 65 67 65 (n (char->intege
6d50: 72 20 63 29 29 29 0a 09 20 20 20 20 20 20 28 6c r c))).. (l
6d60: 69 73 74 20 28 63 6f 6e 73 20 6e 20 6e 29 29 29 ist (cons n n)))
6d70: 29 29 0a 09 20 28 6d 65 72 67 65 2d 73 6f 72 74 )).. (merge-sort
6d80: 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 6c 20 63 .. (lambda (l c
6d90: 6f 6d 62 69 6e 65 20 7a 65 72 6f 2d 65 6c 74 29 ombine zero-elt)
6da0: 0a 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f .. (if (null?
6db0: 20 6c 29 0a 09 09 7a 65 72 6f 2d 65 6c 74 0a 09 l)...zero-elt..
6dc0: 09 28 6c 65 74 20 6c 6f 6f 70 31 20 28 28 6c 20 .(let loop1 ((l
6dd0: 6c 29 29 0a 09 09 20 20 28 69 66 20 28 6e 75 6c l))... (if (nul
6de0: 6c 3f 20 28 63 64 72 20 6c 29 29 0a 09 09 20 20 l? (cdr l))...
6df0: 20 20 20 20 28 63 61 72 20 6c 29 0a 09 09 20 20 (car l)...
6e00: 20 20 20 20 28 6c 6f 6f 70 31 0a 09 09 20 20 20 (loop1...
6e10: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 32 20 28 (let loop2 (
6e20: 28 6c 20 6c 29 29 0a 09 09 09 20 28 63 6f 6e 64 (l l)).... (cond
6e30: 20 28 28 6e 75 6c 6c 3f 20 6c 29 0a 09 09 09 09 ((null? l).....
6e40: 6c 29 0a 09 09 09 20 20 20 20 20 20 20 28 28 6e l).... ((n
6e50: 75 6c 6c 3f 20 28 63 64 72 20 6c 29 29 0a 09 09 ull? (cdr l))...
6e60: 09 09 6c 29 0a 09 09 09 20 20 20 20 20 20 20 28 ..l).... (
6e70: 65 6c 73 65 0a 09 09 09 09 28 63 6f 6e 73 20 28 else.....(cons (
6e80: 63 6f 6d 62 69 6e 65 20 28 63 61 72 20 6c 29 20 combine (car l)
6e90: 28 63 61 64 72 20 6c 29 29 0a 09 09 09 09 20 20 (cadr l)).....
6ea0: 20 20 20 20 28 6c 6f 6f 70 32 20 28 63 64 64 72 (loop2 (cddr
6eb0: 20 6c 29 29 29 29 29 29 29 29 29 29 29 29 0a 09 l))))))))))))..
6ec0: 20 28 66 69 6e 69 74 65 2d 63 6c 61 73 73 2d 75 (finite-class-u
6ed0: 6e 69 6f 6e 0a 09 20 20 28 6c 61 6d 62 64 61 20 nion.. (lambda
6ee0: 28 63 31 20 63 32 29 0a 09 20 20 20 20 28 6c 65 (c1 c2).. (le
6ef0: 74 20 6c 6f 6f 70 20 28 28 63 31 20 63 31 29 20 t loop ((c1 c1)
6f00: 28 63 32 20 63 32 29 20 28 75 20 27 28 29 29 29 (c2 c2) (u '()))
6f10: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c .. (if (nul
6f20: 6c 3f 20 63 31 29 0a 09 09 20 20 28 69 66 20 28 l? c1)... (if (
6f30: 6e 75 6c 6c 3f 20 63 32 29 0a 09 09 20 20 20 20 null? c2)...
6f40: 20 20 28 72 65 76 65 72 73 65 20 75 29 0a 09 09 (reverse u)...
6f50: 20 20 20 20 20 20 28 6c 6f 6f 70 20 63 31 20 28 (loop c1 (
6f60: 63 64 72 20 63 32 29 20 28 63 6f 6e 73 20 28 63 cdr c2) (cons (c
6f70: 61 72 20 63 32 29 20 75 29 29 29 0a 09 09 20 20 ar c2) u)))...
6f80: 28 69 66 20 28 6e 75 6c 6c 3f 20 63 32 29 0a 09 (if (null? c2)..
6f90: 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 64 . (loop (cd
6fa0: 72 20 63 31 29 20 63 32 20 28 63 6f 6e 73 20 28 r c1) c2 (cons (
6fb0: 63 61 72 20 63 31 29 20 75 29 29 0a 09 09 20 20 car c1) u))...
6fc0: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 31 20 28 (let* ((r1 (
6fd0: 63 61 72 20 63 31 29 29 0a 09 09 09 20 20 20 20 car c1))....
6fe0: 20 28 72 32 20 28 63 61 72 20 63 32 29 29 0a 09 (r2 (car c2))..
6ff0: 09 09 20 20 20 20 20 28 72 31 73 74 61 72 74 20 .. (r1start
7000: 28 63 61 72 20 72 31 29 29 0a 09 09 09 20 20 20 (car r1))....
7010: 20 20 28 72 31 65 6e 64 20 28 63 64 72 20 72 31 (r1end (cdr r1
7020: 29 29 0a 09 09 09 20 20 20 20 20 28 72 32 73 74 )).... (r2st
7030: 61 72 74 20 28 63 61 72 20 72 32 29 29 0a 09 09 art (car r2))...
7040: 09 20 20 20 20 20 28 72 32 65 6e 64 20 28 63 64 . (r2end (cd
7050: 72 20 72 32 29 29 29 0a 09 09 09 28 69 66 20 28 r r2)))....(if (
7060: 3c 3d 20 72 31 73 74 61 72 74 20 72 32 73 74 61 <= r1start r2sta
7070: 72 74 29 0a 09 09 09 20 20 20 20 28 63 6f 6e 64 rt).... (cond
7080: 20 28 28 3c 20 28 2b 20 72 31 65 6e 64 20 31 29 ((< (+ r1end 1)
7090: 20 72 32 73 74 61 72 74 29 0a 09 09 09 09 20 20 r2start).....
70a0: 20 28 6c 6f 6f 70 20 28 63 64 72 20 63 31 29 20 (loop (cdr c1)
70b0: 63 32 20 28 63 6f 6e 73 20 72 31 20 75 29 29 29 c2 (cons r1 u)))
70c0: 0a 09 09 09 09 20 20 28 28 3c 3d 20 72 31 65 6e ..... ((<= r1en
70d0: 64 20 72 32 65 6e 64 29 0a 09 09 09 09 20 20 20 d r2end).....
70e0: 28 6c 6f 6f 70 20 28 63 64 72 20 63 31 29 0a 09 (loop (cdr c1)..
70f0: 09 09 09 09 20 28 63 6f 6e 73 20 28 63 6f 6e 73 .... (cons (cons
7100: 20 72 31 73 74 61 72 74 20 72 32 65 6e 64 29 20 r1start r2end)
7110: 28 63 64 72 20 63 32 29 29 0a 09 09 09 09 09 20 (cdr c2))......
7120: 75 29 29 0a 09 09 09 09 20 20 28 65 6c 73 65 0a u))..... (else.
7130: 09 09 09 09 20 20 20 28 6c 6f 6f 70 20 63 31 20 .... (loop c1
7140: 28 63 64 72 20 63 32 29 20 75 29 29 29 0a 09 09 (cdr c2) u)))...
7150: 09 20 20 20 20 28 63 6f 6e 64 20 28 28 3e 20 72 . (cond ((> r
7160: 31 73 74 61 72 74 20 28 2b 20 72 32 65 6e 64 20 1start (+ r2end
7170: 31 29 29 0a 09 09 09 09 20 20 20 28 6c 6f 6f 70 1))..... (loop
7180: 20 63 31 20 28 63 64 72 20 63 32 29 20 28 63 6f c1 (cdr c2) (co
7190: 6e 73 20 72 32 20 75 29 29 29 0a 09 09 09 09 20 ns r2 u))).....
71a0: 20 28 28 3e 3d 20 72 31 65 6e 64 20 72 32 65 6e ((>= r1end r2en
71b0: 64 29 0a 09 09 09 09 20 20 20 28 6c 6f 6f 70 20 d)..... (loop
71c0: 28 63 6f 6e 73 20 28 63 6f 6e 73 20 72 32 73 74 (cons (cons r2st
71d0: 61 72 74 20 72 31 65 6e 64 29 20 28 63 64 72 20 art r1end) (cdr
71e0: 63 31 29 29 0a 09 09 09 09 09 20 28 63 64 72 20 c1))...... (cdr
71f0: 63 32 29 0a 09 09 09 09 09 20 75 29 29 0a 09 09 c2)...... u))...
7200: 09 09 20 20 28 65 6c 73 65 0a 09 09 09 09 20 20 .. (else.....
7210: 20 28 6c 6f 6f 70 20 28 63 64 72 20 63 31 29 20 (loop (cdr c1)
7220: 63 32 20 75 29 29 29 29 29 29 29 29 29 29 0a 09 c2 u))))))))))..
7230: 20 28 63 68 61 72 2d 6c 69 73 74 2d 3e 63 6c 61 (char-list->cla
7240: 73 73 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 63 ss.. (lambda (c
7250: 6c 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 63 l).. (let ((c
7260: 6c 61 73 73 65 73 20 28 6d 61 70 20 63 68 61 72 lasses (map char
7270: 2d 3e 63 6c 61 73 73 20 63 6c 29 29 29 0a 09 20 ->class cl)))..
7280: 20 20 20 20 20 28 6d 65 72 67 65 2d 73 6f 72 74 (merge-sort
7290: 20 63 6c 61 73 73 65 73 20 66 69 6e 69 74 65 2d classes finite-
72a0: 63 6c 61 73 73 2d 75 6e 69 6f 6e 20 27 28 29 29 class-union '())
72b0: 29 29 29 0a 09 20 28 63 6c 61 73 73 2d 3c 0a 09 ))).. (class-<..
72c0: 20 20 28 6c 61 6d 62 64 61 20 28 62 31 20 62 32 (lambda (b1 b2
72d0: 29 0a 09 20 20 20 20 28 63 6f 6e 64 20 28 28 65 ).. (cond ((e
72e0: 71 3f 20 62 31 20 27 69 6e 66 2b 29 20 23 66 29 q? b1 'inf+) #f)
72f0: 0a 09 09 20 20 28 28 65 71 3f 20 62 32 20 27 69 ... ((eq? b2 'i
7300: 6e 66 2d 29 20 23 66 29 0a 09 09 20 20 28 28 65 nf-) #f)... ((e
7310: 71 3f 20 62 31 20 27 69 6e 66 2d 29 20 23 74 29 q? b1 'inf-) #t)
7320: 0a 09 09 20 20 28 28 65 71 3f 20 62 32 20 27 69 ... ((eq? b2 'i
7330: 6e 66 2b 29 20 23 74 29 0a 09 09 20 20 28 65 6c nf+) #t)... (el
7340: 73 65 20 28 3c 20 62 31 20 62 32 29 29 29 29 29 se (< b1 b2)))))
7350: 0a 09 20 28 66 69 6e 69 74 65 2d 63 6c 61 73 73 .. (finite-class
7360: 2d 63 6f 6d 70 6c 0a 09 20 20 28 6c 61 6d 62 64 -compl.. (lambd
7370: 61 20 28 63 29 0a 09 20 20 20 20 28 6c 65 74 20 a (c).. (let
7380: 6c 6f 6f 70 20 28 28 63 20 63 29 20 28 73 74 61 loop ((c c) (sta
7390: 72 74 20 27 69 6e 66 2d 29 29 0a 09 20 20 20 20 rt 'inf-))..
73a0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 29 0a (if (null? c).
73b0: 09 09 20 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 .. (list (cons
73c0: 73 74 61 72 74 20 27 69 6e 66 2b 29 29 0a 09 09 start 'inf+))...
73d0: 20 20 28 6c 65 74 2a 20 28 28 72 20 28 63 61 72 (let* ((r (car
73e0: 20 63 29 29 0a 09 09 09 20 28 72 73 74 61 72 74 c)).... (rstart
73f0: 20 28 63 61 72 20 72 29 29 0a 09 09 09 20 28 72 (car r)).... (r
7400: 65 6e 64 20 28 63 64 72 20 72 29 29 29 0a 09 09 end (cdr r)))...
7410: 20 20 20 20 28 69 66 20 28 63 6c 61 73 73 2d 3c (if (class-<
7420: 20 73 74 61 72 74 20 72 73 74 61 72 74 29 0a 09 start rstart)..
7430: 09 09 28 63 6f 6e 73 20 28 63 6f 6e 73 20 73 74 ..(cons (cons st
7440: 61 72 74 20 28 2d 20 72 73 74 61 72 74 20 31 29 art (- rstart 1)
7450: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 ).... (loop
7460: 20 63 20 72 73 74 61 72 74 29 29 0a 09 09 09 28 c rstart))....(
7470: 6c 6f 6f 70 20 28 63 64 72 20 63 29 20 28 2b 20 loop (cdr c) (+
7480: 72 65 6e 64 20 31 29 29 29 29 29 29 29 29 0a 09 rend 1))))))))..
7490: 20 28 74 61 67 67 65 64 2d 63 68 61 72 73 2d 3e (tagged-chars->
74a0: 63 6c 61 73 73 0a 09 20 20 28 6c 61 6d 62 64 61 class.. (lambda
74b0: 20 28 74 63 6c 29 0a 09 20 20 20 20 28 6c 65 74 (tcl).. (let
74c0: 2a 20 28 28 69 6e 76 65 72 73 65 3f 20 28 63 61 * ((inverse? (ca
74d0: 72 20 74 63 6c 29 29 0a 09 09 20 20 20 28 63 6c r tcl))... (cl
74e0: 20 28 63 64 72 20 74 63 6c 29 29 0a 09 09 20 20 (cdr tcl))...
74f0: 20 28 63 6c 61 73 73 2d 74 6d 70 20 28 63 68 61 (class-tmp (cha
7500: 72 2d 6c 69 73 74 2d 3e 63 6c 61 73 73 20 63 6c r-list->class cl
7510: 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 69 ))).. (if i
7520: 6e 76 65 72 73 65 3f 20 28 66 69 6e 69 74 65 2d nverse? (finite-
7530: 63 6c 61 73 73 2d 63 6f 6d 70 6c 20 63 6c 61 73 class-compl clas
7540: 73 2d 74 6d 70 29 20 63 6c 61 73 73 2d 74 6d 70 s-tmp) class-tmp
7550: 29 29 29 29 0a 09 20 28 63 68 61 72 63 2d 3e 61 )))).. (charc->a
7560: 72 63 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 63 rc.. (lambda (c
7570: 68 61 72 63 29 0a 09 20 20 20 20 28 6c 65 74 2a harc).. (let*
7580: 20 28 28 74 63 6c 20 28 63 61 72 20 63 68 61 72 ((tcl (car char
7590: 63 29 29 0a 09 09 20 20 20 28 64 65 73 74 20 28 c))... (dest (
75a0: 63 64 72 20 63 68 61 72 63 29 29 0a 09 09 20 20 cdr charc))...
75b0: 20 28 63 6c 61 73 73 20 28 74 61 67 67 65 64 2d (class (tagged-
75c0: 63 68 61 72 73 2d 3e 63 6c 61 73 73 20 74 63 6c chars->class tcl
75d0: 29 29 29 0a 09 20 20 20 20 20 20 28 63 6f 6e 73 ))).. (cons
75e0: 20 63 6c 61 73 73 20 64 65 73 74 29 29 29 29 0a class dest)))).
75f0: 09 20 28 61 72 63 2d 3e 73 68 61 72 63 73 0a 09 . (arc->sharcs..
7600: 20 20 28 6c 61 6d 62 64 61 20 28 61 72 63 29 0a (lambda (arc).
7610: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 72 61 6e . (let* ((ran
7620: 67 65 2d 6c 20 28 63 61 72 20 61 72 63 29 29 0a ge-l (car arc)).
7630: 09 09 20 20 20 28 64 65 73 74 20 28 63 64 72 20 .. (dest (cdr
7640: 61 72 63 29 29 0a 09 09 20 20 20 28 6f 70 20 28 arc))... (op (
7650: 6c 61 6d 62 64 61 20 28 72 61 6e 67 65 29 20 28 lambda (range) (
7660: 63 6f 6e 73 20 72 61 6e 67 65 20 64 65 73 74 29 cons range dest)
7670: 29 29 29 0a 09 20 20 20 20 20 20 28 6d 61 70 20 ))).. (map
7680: 6f 70 20 72 61 6e 67 65 2d 6c 29 29 29 29 0a 09 op range-l))))..
7690: 20 28 63 6c 61 73 73 2d 3c 3d 0a 09 20 20 28 6c (class-<=.. (l
76a0: 61 6d 62 64 61 20 28 62 31 20 62 32 29 0a 09 20 ambda (b1 b2)..
76b0: 20 20 20 28 63 6f 6e 64 20 28 28 65 71 3f 20 62 (cond ((eq? b
76c0: 31 20 27 69 6e 66 2d 29 20 23 74 29 0a 09 09 20 1 'inf-) #t)...
76d0: 20 28 28 65 71 3f 20 62 32 20 27 69 6e 66 2b 29 ((eq? b2 'inf+)
76e0: 20 23 74 29 0a 09 09 20 20 28 28 65 71 3f 20 62 #t)... ((eq? b
76f0: 31 20 27 69 6e 66 2b 29 20 23 66 29 0a 09 09 20 1 'inf+) #f)...
7700: 20 28 28 65 71 3f 20 62 32 20 27 69 6e 66 2d 29 ((eq? b2 'inf-)
7710: 20 23 66 29 0a 09 09 20 20 28 65 6c 73 65 20 28 #f)... (else (
7720: 3c 3d 20 62 31 20 62 32 29 29 29 29 29 0a 09 20 <= b1 b2)))))..
7730: 28 73 68 61 72 63 2d 3c 3d 0a 09 20 20 28 6c 61 (sharc-<=.. (la
7740: 6d 62 64 61 20 28 73 68 61 72 63 31 20 73 68 61 mbda (sharc1 sha
7750: 72 63 32 29 0a 09 20 20 20 20 28 63 6c 61 73 73 rc2).. (class
7760: 2d 3c 3d 20 28 63 61 61 72 20 73 68 61 72 63 31 -<= (caar sharc1
7770: 29 20 28 63 61 61 72 20 73 68 61 72 63 32 29 29 ) (caar sharc2))
7780: 29 29 0a 09 20 28 6d 65 72 67 65 2d 73 68 61 72 )).. (merge-shar
7790: 63 73 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 6c cs.. (lambda (l
77a0: 31 20 6c 32 29 0a 09 20 20 20 20 28 6c 65 74 20 1 l2).. (let
77b0: 6c 6f 6f 70 20 28 28 6c 31 20 6c 31 29 20 28 6c loop ((l1 l1) (l
77c0: 32 20 6c 32 29 29 0a 09 20 20 20 20 20 20 28 63 2 l2)).. (c
77d0: 6f 6e 64 20 28 28 6e 75 6c 6c 3f 20 6c 31 29 0a ond ((null? l1).
77e0: 09 09 20 20 20 20 20 6c 32 29 0a 09 09 20 20 20 .. l2)...
77f0: 20 28 28 6e 75 6c 6c 3f 20 6c 32 29 0a 09 09 20 ((null? l2)...
7800: 20 20 20 20 6c 31 29 0a 09 09 20 20 20 20 28 65 l1)... (e
7810: 6c 73 65 0a 09 09 20 20 20 20 20 28 6c 65 74 20 lse... (let
7820: 28 28 73 68 61 72 63 31 20 28 63 61 72 20 6c 31 ((sharc1 (car l1
7830: 29 29 0a 09 09 09 20 20 20 28 73 68 61 72 63 32 )).... (sharc2
7840: 20 28 63 61 72 20 6c 32 29 29 29 0a 09 09 20 20 (car l2)))...
7850: 20 20 20 20 20 28 69 66 20 28 73 68 61 72 63 2d (if (sharc-
7860: 3c 3d 20 73 68 61 72 63 31 20 73 68 61 72 63 32 <= sharc1 sharc2
7870: 29 0a 09 09 09 20 20 20 28 63 6f 6e 73 20 73 68 ).... (cons sh
7880: 61 72 63 31 20 28 6c 6f 6f 70 20 28 63 64 72 20 arc1 (loop (cdr
7890: 6c 31 29 20 6c 32 29 29 0a 09 09 09 20 20 20 28 l1) l2)).... (
78a0: 63 6f 6e 73 20 73 68 61 72 63 32 20 28 6c 6f 6f cons sharc2 (loo
78b0: 70 20 6c 31 20 28 63 64 72 20 6c 32 29 29 29 29 p l1 (cdr l2))))
78c0: 29 29 29 29 29 29 0a 09 20 28 63 6c 61 73 73 2d )))))).. (class-
78d0: 3d 20 65 71 76 3f 29 0a 09 20 28 66 69 6c 6c 2d = eqv?).. (fill-
78e0: 65 72 72 6f 72 0a 09 20 20 28 6c 61 6d 62 64 61 error.. (lambda
78f0: 20 28 73 68 61 72 63 73 29 0a 09 20 20 20 20 28 (sharcs).. (
7900: 6c 65 74 20 6c 6f 6f 70 20 28 28 73 68 61 72 63 let loop ((sharc
7910: 73 20 73 68 61 72 63 73 29 20 28 73 74 61 72 74 s sharcs) (start
7920: 20 27 69 6e 66 2d 29 29 0a 09 20 20 20 20 20 20 'inf-))..
7930: 28 63 6f 6e 64 20 28 28 63 6c 61 73 73 2d 3d 20 (cond ((class-=
7940: 73 74 61 72 74 20 27 69 6e 66 2b 29 0a 09 09 20 start 'inf+)...
7950: 20 20 20 20 27 28 29 29 0a 09 09 20 20 20 20 28 '())... (
7960: 28 6e 75 6c 6c 3f 20 73 68 61 72 63 73 29 0a 09 (null? sharcs)..
7970: 09 20 20 20 20 20 28 63 6f 6e 73 20 28 63 6f 6e . (cons (con
7980: 73 20 28 63 6f 6e 73 20 73 74 61 72 74 20 27 69 s (cons start 'i
7990: 6e 66 2b 29 20 27 65 72 72 29 0a 09 09 09 20 20 nf+) 'err)....
79a0: 20 28 6c 6f 6f 70 20 73 68 61 72 63 73 20 27 69 (loop sharcs 'i
79b0: 6e 66 2b 29 29 29 0a 09 09 20 20 20 20 28 65 6c nf+)))... (el
79c0: 73 65 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 se... (let*
79d0: 28 28 73 68 61 72 63 20 28 63 61 72 20 73 68 61 ((sharc (car sha
79e0: 72 63 73 29 29 0a 09 09 09 20 20 20 20 28 68 20 rcs)).... (h
79f0: 28 63 61 61 72 20 73 68 61 72 63 29 29 0a 09 09 (caar sharc))...
7a00: 09 20 20 20 20 28 74 20 28 63 64 61 72 20 73 68 . (t (cdar sh
7a10: 61 72 63 29 29 29 0a 09 09 20 20 20 20 20 20 20 arc)))...
7a20: 28 69 66 20 28 63 6c 61 73 73 2d 3c 20 73 74 61 (if (class-< sta
7a30: 72 74 20 68 29 0a 09 09 09 20 20 20 28 63 6f 6e rt h).... (con
7a40: 73 20 28 63 6f 6e 73 20 28 63 6f 6e 73 20 73 74 s (cons (cons st
7a50: 61 72 74 20 28 2d 20 68 20 31 29 29 20 27 65 72 art (- h 1)) 'er
7a60: 72 29 0a 09 09 09 09 20 28 6c 6f 6f 70 20 73 68 r)..... (loop sh
7a70: 61 72 63 73 20 68 29 29 0a 09 09 09 20 20 20 28 arcs h)).... (
7a80: 63 6f 6e 73 20 73 68 61 72 63 20 28 6c 6f 6f 70 cons sharc (loop
7a90: 20 28 63 64 72 20 73 68 61 72 63 73 29 0a 09 09 (cdr sharcs)...
7aa0: 09 09 09 20 20 20 20 20 28 69 66 20 28 63 6c 61 ... (if (cla
7ab0: 73 73 2d 3d 20 74 20 27 69 6e 66 2b 29 0a 09 09 ss-= t 'inf+)...
7ac0: 09 09 09 09 20 27 69 6e 66 2b 0a 09 09 09 09 09 .... 'inf+......
7ad0: 09 20 28 2b 20 74 20 31 29 29 29 29 29 29 29 29 . (+ t 1))))))))
7ae0: 29 29 29 0a 09 20 28 63 68 61 72 63 73 2d 3e 74 ))).. (charcs->t
7af0: 72 65 65 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 ree.. (lambda (
7b00: 63 68 61 72 63 73 29 0a 09 20 20 20 20 28 6c 65 charcs).. (le
7b10: 74 2a 20 28 28 6f 70 20 28 6c 61 6d 62 64 61 20 t* ((op (lambda
7b20: 28 63 68 61 72 63 29 20 28 61 72 63 2d 3e 73 68 (charc) (arc->sh
7b30: 61 72 63 73 20 28 63 68 61 72 63 2d 3e 61 72 63 arcs (charc->arc
7b40: 20 63 68 61 72 63 29 29 29 29 0a 09 09 20 20 20 charc))))...
7b50: 28 73 68 61 72 63 73 2d 6c 20 28 6d 61 70 20 6f (sharcs-l (map o
7b60: 70 20 63 68 61 72 63 73 29 29 0a 09 09 20 20 20 p charcs))...
7b70: 28 73 6f 72 74 65 64 2d 73 68 61 72 63 73 20 28 (sorted-sharcs (
7b80: 6d 65 72 67 65 2d 73 6f 72 74 20 73 68 61 72 63 merge-sort sharc
7b90: 73 2d 6c 20 6d 65 72 67 65 2d 73 68 61 72 63 73 s-l merge-sharcs
7ba0: 20 27 28 29 29 29 0a 09 09 20 20 20 28 66 75 6c '()))... (ful
7bb0: 6c 2d 73 68 61 72 63 73 20 28 66 69 6c 6c 2d 65 l-sharcs (fill-e
7bc0: 72 72 6f 72 20 73 6f 72 74 65 64 2d 73 68 61 72 rror sorted-shar
7bd0: 63 73 29 29 0a 09 09 20 20 20 28 6f 70 20 28 6c cs))... (op (l
7be0: 61 6d 62 64 61 20 28 73 68 61 72 63 29 20 28 63 ambda (sharc) (c
7bf0: 6f 6e 73 20 28 63 61 61 72 20 73 68 61 72 63 29 ons (caar sharc)
7c00: 20 28 63 64 72 20 73 68 61 72 63 29 29 29 29 0a (cdr sharc)))).
7c10: 09 09 20 20 20 28 74 61 62 6c 65 20 28 6c 69 73 .. (table (lis
7c20: 74 2d 3e 76 65 63 74 6f 72 20 28 6d 61 70 20 6f t->vector (map o
7c30: 70 20 66 75 6c 6c 2d 73 68 61 72 63 73 29 29 29 p full-sharcs)))
7c40: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f ).. (let lo
7c50: 6f 70 20 28 28 6c 65 66 74 20 30 29 20 28 72 69 op ((left 0) (ri
7c60: 67 68 74 20 28 2d 20 28 76 65 63 74 6f 72 2d 6c ght (- (vector-l
7c70: 65 6e 67 74 68 20 74 61 62 6c 65 29 20 31 29 29 ength table) 1))
7c80: 29 0a 09 09 28 69 66 20 28 3d 20 6c 65 66 74 20 )...(if (= left
7c90: 72 69 67 68 74 29 0a 09 09 20 20 20 20 28 63 64 right)... (cd
7ca0: 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 61 r (vector-ref ta
7cb0: 62 6c 65 20 6c 65 66 74 29 29 0a 09 09 20 20 20 ble left))...
7cc0: 20 28 6c 65 74 20 28 28 6d 69 64 20 28 71 75 6f (let ((mid (quo
7cd0: 74 69 65 6e 74 20 28 2b 20 6c 65 66 74 20 72 69 tient (+ left ri
7ce0: 67 68 74 20 31 29 20 32 29 29 29 0a 09 09 20 20 ght 1) 2)))...
7cf0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 3d 20 (if (and (=
7d00: 28 2b 20 6c 65 66 74 20 32 29 20 72 69 67 68 74 (+ left 2) right
7d10: 29 0a 09 09 09 20 20 20 20 20 20 20 28 3d 20 28 ).... (= (
7d20: 2b 20 28 63 61 72 20 28 76 65 63 74 6f 72 2d 72 + (car (vector-r
7d30: 65 66 20 74 61 62 6c 65 20 6d 69 64 29 29 20 31 ef table mid)) 1
7d40: 29 0a 09 09 09 09 20 20 28 63 61 72 20 28 76 65 )..... (car (ve
7d50: 63 74 6f 72 2d 72 65 66 20 74 61 62 6c 65 20 72 ctor-ref table r
7d60: 69 67 68 74 29 29 29 0a 09 09 09 20 20 20 20 20 ight)))....
7d70: 20 20 28 65 71 76 3f 20 28 63 64 72 20 28 76 65 (eqv? (cdr (ve
7d80: 63 74 6f 72 2d 72 65 66 20 74 61 62 6c 65 20 6c ctor-ref table l
7d90: 65 66 74 29 29 0a 09 09 09 09 20 20 20 20 20 28 eft))..... (
7da0: 63 64 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 cdr (vector-ref
7db0: 74 61 62 6c 65 20 72 69 67 68 74 29 29 29 29 0a table right)))).
7dc0: 09 09 09 20 20 28 6c 69 73 74 20 27 3d 0a 09 09 ... (list '=...
7dd0: 09 09 28 63 61 72 20 28 76 65 63 74 6f 72 2d 72 ..(car (vector-r
7de0: 65 66 20 74 61 62 6c 65 20 6d 69 64 29 29 0a 09 ef table mid))..
7df0: 09 09 09 28 63 64 72 20 28 76 65 63 74 6f 72 2d ...(cdr (vector-
7e00: 72 65 66 20 74 61 62 6c 65 20 6d 69 64 29 29 0a ref table mid)).
7e10: 09 09 09 09 28 63 64 72 20 28 76 65 63 74 6f 72 ....(cdr (vector
7e20: 2d 72 65 66 20 74 61 62 6c 65 20 6c 65 66 74 29 -ref table left)
7e30: 29 29 0a 09 09 09 20 20 28 6c 69 73 74 20 28 63 )).... (list (c
7e40: 61 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 ar (vector-ref t
7e50: 61 62 6c 65 20 6d 69 64 29 29 0a 09 09 09 09 28 able mid)).....(
7e60: 6c 6f 6f 70 20 6c 65 66 74 20 28 2d 20 6d 69 64 loop left (- mid
7e70: 20 31 29 29 0a 09 09 09 09 28 6c 6f 6f 70 20 6d 1)).....(loop m
7e80: 69 64 20 72 69 67 68 74 29 29 29 29 29 29 29 29 id right))))))))
7e90: 29 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 )). (lambda (
7ea0: 74 61 62 6c 65 73 20 49 53 29 0a 20 20 20 20 20 tables IS).
7eb0: 20 28 6c 65 74 20 28 28 63 6f 75 6e 74 65 72 73 (let ((counters
7ec0: 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 (vector
7ed0: 2d 72 65 66 20 74 61 62 6c 65 73 20 30 29 29 0a -ref tables 0)).
7ee0: 09 20 20 20 20 28 3c 3c 45 4f 46 3e 3e 2d 61 63 . (<<EOF>>-ac
7ef0: 74 69 6f 6e 20 20 20 28 76 65 63 74 6f 72 2d 72 tion (vector-r
7f00: 65 66 20 74 61 62 6c 65 73 20 31 29 29 0a 09 20 ef tables 1))..
7f10: 20 20 20 28 3c 3c 45 52 52 4f 52 3e 3e 2d 61 63 (<<ERROR>>-ac
7f20: 74 69 6f 6e 20 28 76 65 63 74 6f 72 2d 72 65 66 tion (vector-ref
7f30: 20 74 61 62 6c 65 73 20 32 29 29 0a 09 20 20 20 tables 2))..
7f40: 20 28 72 75 6c 65 73 2d 61 63 74 69 6f 6e 73 20 (rules-actions
7f50: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (vector-ref t
7f60: 61 62 6c 65 73 20 33 29 29 0a 09 20 20 20 20 28 ables 3)).. (
7f70: 6e 6c 2d 73 74 61 72 74 20 20 20 20 20 20 20 20 nl-start
7f80: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 61 62 (vector-ref tab
7f90: 6c 65 73 20 35 29 29 0a 09 20 20 20 20 28 6e 6f les 5)).. (no
7fa0: 2d 6e 6c 2d 73 74 61 72 74 20 20 20 20 20 20 28 -nl-start (
7fb0: 76 65 63 74 6f 72 2d 72 65 66 20 74 61 62 6c 65 vector-ref table
7fc0: 73 20 36 29 29 0a 09 20 20 20 20 28 63 68 61 72 s 6)).. (char
7fd0: 63 73 2d 76 20 20 20 20 20 20 20 20 20 28 76 65 cs-v (ve
7fe0: 63 74 6f 72 2d 72 65 66 20 74 61 62 6c 65 73 20 ctor-ref tables
7ff0: 37 29 29 0a 09 20 20 20 20 28 61 63 63 2d 76 20 7)).. (acc-v
8000: 20 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 (vect
8010: 6f 72 2d 72 65 66 20 74 61 62 6c 65 73 20 38 29 or-ref tables 8)
8020: 29 29 0a 09 28 6c 65 74 2a 20 28 28 6c 65 6e 20 ))..(let* ((len
8030: 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 63 (vector-length c
8040: 68 61 72 63 73 2d 76 29 29 0a 09 20 20 20 20 20 harcs-v))..
8050: 20 20 28 76 20 28 6d 61 6b 65 2d 76 65 63 74 6f (v (make-vecto
8060: 72 20 6c 65 6e 29 29 29 0a 09 20 20 28 6c 65 74 r len))).. (let
8070: 20 6c 6f 6f 70 20 28 28 69 20 28 2d 20 6c 65 6e loop ((i (- len
8080: 20 31 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 1))).. (if (
8090: 3e 3d 20 69 20 30 29 0a 09 09 28 62 65 67 69 6e >= i 0)...(begin
80a0: 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 74 ... (vector-set
80b0: 21 20 76 20 69 20 28 63 68 61 72 63 73 2d 3e 74 ! v i (charcs->t
80c0: 72 65 65 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ree (vector-ref
80d0: 63 68 61 72 63 73 2d 76 20 69 29 29 29 0a 09 09 charcs-v i)))...
80e0: 20 20 28 6c 6f 6f 70 20 28 2d 20 69 20 31 29 29 (loop (- i 1))
80f0: 29 0a 09 09 28 6c 65 78 65 72 2d 6d 61 6b 65 2d )...(lexer-make-
8100: 74 72 65 65 2d 6c 65 78 65 72 0a 09 09 20 28 76 tree-lexer... (v
8110: 65 63 74 6f 72 20 63 6f 75 6e 74 65 72 73 0a 09 ector counters..
8120: 09 09 20 3c 3c 45 4f 46 3e 3e 2d 61 63 74 69 6f .. <<EOF>>-actio
8130: 6e 0a 09 09 09 20 3c 3c 45 52 52 4f 52 3e 3e 2d n.... <<ERROR>>-
8140: 61 63 74 69 6f 6e 0a 09 09 09 20 72 75 6c 65 73 action.... rules
8150: 2d 61 63 74 69 6f 6e 73 0a 09 09 09 20 27 64 65 -actions.... 'de
8160: 63 69 73 69 6f 6e 2d 74 72 65 65 73 0a 09 09 09 cision-trees....
8170: 20 6e 6c 2d 73 74 61 72 74 0a 09 09 09 20 6e 6f nl-start.... no
8180: 2d 6e 6c 2d 73 74 61 72 74 0a 09 09 09 20 76 0a -nl-start.... v.
8190: 09 09 09 20 61 63 63 2d 76 29 0a 09 09 20 49 53 ... acc-v)... IS
81a0: 29 29 29 29 29 29 29 29 0a 0a 3b 20 46 61 62 72 ))))))))..; Fabr
81b0: 69 63 61 74 69 6f 6e 20 64 27 75 6e 20 6c 65 78 ication d'un lex
81c0: 65 72 20 61 20 70 61 72 74 69 72 20 64 65 20 63 er a partir de c
81d0: 6f 64 65 20 70 72 65 2d 67 65 6e 65 72 65 0a 28 ode pre-genere.(
81e0: 64 65 66 69 6e 65 20 6c 65 78 65 72 2d 6d 61 6b define lexer-mak
81f0: 65 2d 63 6f 64 65 2d 6c 65 78 65 72 0a 20 20 28 e-code-lexer. (
8200: 6c 61 6d 62 64 61 20 28 74 61 62 6c 65 73 20 49 lambda (tables I
8210: 53 29 0a 20 20 20 20 28 6c 65 74 20 28 28 3c 3c S). (let ((<<
8220: 45 4f 46 3e 3e 2d 70 72 65 2d 61 63 74 69 6f 6e EOF>>-pre-action
8230: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (vector-ref t
8240: 61 62 6c 65 73 20 31 29 29 0a 09 20 20 28 3c 3c ables 1)).. (<<
8250: 45 52 52 4f 52 3e 3e 2d 70 72 65 2d 61 63 74 69 ERROR>>-pre-acti
8260: 6f 6e 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 on (vector-ref t
8270: 61 62 6c 65 73 20 32 29 29 0a 09 20 20 28 72 75 ables 2)).. (ru
8280: 6c 65 73 2d 70 72 65 2d 61 63 74 69 6f 6e 20 20 les-pre-action
8290: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (vector-ref t
82a0: 61 62 6c 65 73 20 33 29 29 0a 09 20 20 28 63 6f ables 3)).. (co
82b0: 64 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 de
82c0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (vector-ref t
82d0: 61 62 6c 65 73 20 35 29 29 29 0a 20 20 20 20 20 ables 5))).
82e0: 20 28 63 6f 64 65 20 3c 3c 45 4f 46 3e 3e 2d 70 (code <<EOF>>-p
82f0: 72 65 2d 61 63 74 69 6f 6e 20 3c 3c 45 52 52 4f re-action <<ERRO
8300: 52 3e 3e 2d 70 72 65 2d 61 63 74 69 6f 6e 20 72 R>>-pre-action r
8310: 75 6c 65 73 2d 70 72 65 2d 61 63 74 69 6f 6e 20 ules-pre-action
8320: 49 53 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 IS))))..(define
8330: 6c 65 78 65 72 2d 6d 61 6b 65 2d 6c 65 78 65 72 lexer-make-lexer
8340: 0a 20 20 28 6c 61 6d 62 64 61 20 28 74 61 62 6c . (lambda (tabl
8350: 65 73 20 49 53 29 0a 20 20 20 20 28 6c 65 74 20 es IS). (let
8360: 28 28 61 75 74 6f 6d 61 74 6f 6e 2d 74 79 70 65 ((automaton-type
8370: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 61 62 (vector-ref tab
8380: 6c 65 73 20 34 29 29 29 0a 20 20 20 20 20 20 28 les 4))). (
8390: 63 6f 6e 64 20 28 28 65 71 3f 20 61 75 74 6f 6d cond ((eq? autom
83a0: 61 74 6f 6e 2d 74 79 70 65 20 27 64 65 63 69 73 aton-type 'decis
83b0: 69 6f 6e 2d 74 72 65 65 73 29 0a 09 20 20 20 20 ion-trees)..
83c0: 20 28 6c 65 78 65 72 2d 6d 61 6b 65 2d 74 72 65 (lexer-make-tre
83d0: 65 2d 6c 65 78 65 72 20 74 61 62 6c 65 73 20 49 e-lexer tables I
83e0: 53 29 29 0a 09 20 20 20 20 28 28 65 71 3f 20 61 S)).. ((eq? a
83f0: 75 74 6f 6d 61 74 6f 6e 2d 74 79 70 65 20 27 74 utomaton-type 't
8400: 61 67 67 65 64 2d 63 68 61 72 73 2d 6c 69 73 74 agged-chars-list
8410: 73 29 0a 09 20 20 20 20 20 28 6c 65 78 65 72 2d s).. (lexer-
8420: 6d 61 6b 65 2d 63 68 61 72 2d 6c 65 78 65 72 20 make-char-lexer
8430: 74 61 62 6c 65 73 20 49 53 29 29 0a 09 20 20 20 tables IS))..
8440: 20 28 28 65 71 3f 20 61 75 74 6f 6d 61 74 6f 6e ((eq? automaton
8450: 2d 74 79 70 65 20 27 63 6f 64 65 29 0a 09 20 20 -type 'code)..
8460: 20 20 20 28 6c 65 78 65 72 2d 6d 61 6b 65 2d 63 (lexer-make-c
8470: 6f 64 65 2d 6c 65 78 65 72 20 74 61 62 6c 65 73 ode-lexer tables
8480: 20 49 53 29 29 29 29 29 29 0a 0a 3b 0a 3b 20 54 IS))))))..;.; T
8490: 61 62 6c 65 20 67 65 6e 65 72 61 74 65 64 20 66 able generated f
84a0: 72 6f 6d 20 74 68 65 20 66 69 6c 65 20 74 77 69 rom the file twi
84b0: 6b 69 2e 6c 20 62 79 20 53 49 4c 65 78 20 31 2e ki.l by SILex 1.
84c0: 30 0a 3b 0a 0a 28 64 65 66 69 6e 65 20 6c 65 78 0.;..(define lex
84d0: 65 72 2d 64 65 66 61 75 6c 74 2d 74 61 62 6c 65 er-default-table
84e0: 0a 20 20 28 76 65 63 74 6f 72 0a 20 20 20 27 6c . (vector. 'l
84f0: 69 6e 65 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 ine. (lambda (
8500: 79 79 63 6f 6e 74 69 6e 75 65 20 79 79 67 65 74 yycontinue yyget
8510: 63 20 79 79 75 6e 67 65 74 63 29 0a 20 20 20 20 c yyungetc).
8520: 20 28 6c 61 6d 62 64 61 20 28 79 79 74 65 78 74 (lambda (yytext
8530: 20 79 79 6c 69 6e 65 29 0a 20 20 20 20 20 20 20 yyline).
8540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8550: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 27 (list '
8560: 65 6e 64 2d 6f 66 2d 69 6e 70 75 74 20 23 66 20 end-of-input #f
8570: 29 20 3b 3b 20 79 79 6c 69 6e 65 29 0a 20 20 20 ) ;; yyline).
8580: 20 20 20 20 29 29 0a 20 20 20 28 6c 61 6d 62 64 )). (lambd
8590: 61 20 28 79 79 63 6f 6e 74 69 6e 75 65 20 79 79 a (yycontinue yy
85a0: 67 65 74 63 20 79 79 75 6e 67 65 74 63 29 0a 20 getc yyungetc).
85b0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 79 79 74 (lambda (yyt
85c0: 65 78 74 20 79 79 6c 69 6e 65 29 0a 20 20 20 20 ext yyline).
85d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
85e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 78 (lex
85f0: 2d 65 72 72 6f 72 20 28 63 6f 6e 63 20 79 79 6c -error (conc yyl
8600: 69 6e 65 20 22 20 3a 20 69 6c 6c 65 67 61 6c 20 ine " : illegal
8610: 63 68 61 72 61 63 74 65 72 20 22 29 20 28 79 79 character ") (yy
8620: 67 65 74 63 29 29 0a 20 20 20 20 20 20 20 29 29 getc)). ))
8630: 0a 20 20 20 28 76 65 63 74 6f 72 0a 20 20 20 20 . (vector.
8640: 23 74 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 #t. (lambda (
8650: 79 79 63 6f 6e 74 69 6e 75 65 20 79 79 67 65 74 yycontinue yyget
8660: 63 20 79 79 75 6e 67 65 74 63 29 0a 20 20 20 20 c yyungetc).
8670: 20 20 28 6c 61 6d 62 64 61 20 28 79 79 74 65 78 (lambda (yytex
8680: 74 20 79 79 6c 69 6e 65 29 0a 20 20 20 20 20 20 t yyline).
8690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86a0: 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 (list
86b0: 27 6f 70 65 6e 73 71 20 20 20 20 20 79 79 74 65 'opensq yyte
86c0: 78 74 29 0a 20 20 20 20 20 20 20 20 29 29 0a 20 xt). )).
86d0: 20 20 20 23 74 0a 20 20 20 20 28 6c 61 6d 62 64 #t. (lambd
86e0: 61 20 28 79 79 63 6f 6e 74 69 6e 75 65 20 79 79 a (yycontinue yy
86f0: 67 65 74 63 20 79 79 75 6e 67 65 74 63 29 0a 20 getc yyungetc).
8700: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 79 79 (lambda (yy
8710: 74 65 78 74 20 79 79 6c 69 6e 65 29 0a 20 20 20 text yyline).
8720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8730: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 (li
8740: 73 74 20 27 63 6c 6f 73 65 73 71 20 20 20 20 79 st 'closesq y
8750: 79 74 65 78 74 29 0a 20 20 20 20 20 20 20 20 29 ytext). )
8760: 29 0a 20 20 20 20 23 74 0a 20 20 20 20 28 6c 61 ). #t. (la
8770: 6d 62 64 61 20 28 79 79 63 6f 6e 74 69 6e 75 65 mbda (yycontinue
8780: 20 79 79 67 65 74 63 20 79 79 75 6e 67 65 74 63 yygetc yyungetc
8790: 29 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ). (lambda
87a0: 28 79 79 74 65 78 74 20 79 79 6c 69 6e 65 29 0a (yytext yyline).
87b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87d0: 28 6c 69 73 74 20 27 6f 70 65 6e 73 71 75 69 67 (list 'opensquig
87e0: 20 20 79 79 74 65 78 74 29 0a 20 20 20 20 20 20 yytext).
87f0: 20 20 29 29 0a 20 20 20 20 23 74 0a 20 20 20 20 )). #t.
8800: 28 6c 61 6d 62 64 61 20 28 79 79 63 6f 6e 74 69 (lambda (yyconti
8810: 6e 75 65 20 79 79 67 65 74 63 20 79 79 75 6e 67 nue yygetc yyung
8820: 65 74 63 29 0a 20 20 20 20 20 20 28 6c 61 6d 62 etc). (lamb
8830: 64 61 20 28 79 79 74 65 78 74 20 79 79 6c 69 6e da (yytext yylin
8840: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
8850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8860: 20 20 20 28 6c 69 73 74 20 27 63 6c 6f 73 65 73 (list 'closes
8870: 71 75 69 67 20 79 79 74 65 78 74 29 0a 20 20 20 quig yytext).
8880: 20 20 20 20 20 29 29 0a 20 20 20 20 23 74 0a 20 )). #t.
8890: 20 20 20 28 6c 61 6d 62 64 61 20 28 79 79 63 6f (lambda (yyco
88a0: 6e 74 69 6e 75 65 20 79 79 67 65 74 63 20 79 79 ntinue yygetc yy
88b0: 75 6e 67 65 74 63 29 0a 20 20 20 20 20 20 28 6c ungetc). (l
88c0: 61 6d 62 64 61 20 28 79 79 74 65 78 74 20 79 79 ambda (yytext yy
88d0: 6c 69 6e 65 29 0a 20 20 20 20 20 20 20 20 20 20 line).
88e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88f0: 20 20 20 20 20 20 28 6c 69 73 74 20 27 62 61 6e (list 'ban
8900: 67 20 20 20 20 20 20 20 79 79 74 65 78 74 29 0a g yytext).
8910: 20 20 20 20 20 20 20 20 29 29 0a 20 20 20 20 23 )). #
8920: 74 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 79 t. (lambda (y
8930: 79 63 6f 6e 74 69 6e 75 65 20 79 79 67 65 74 63 ycontinue yygetc
8940: 20 79 79 75 6e 67 65 74 63 29 0a 20 20 20 20 20 yyungetc).
8950: 20 28 6c 61 6d 62 64 61 20 28 79 79 74 65 78 74 (lambda (yytext
8960: 20 79 79 6c 69 6e 65 29 0a 20 20 20 20 20 20 20 yyline).
8970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8980: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 27 (list '
8990: 70 6c 61 69 6e 74 65 78 74 20 20 79 79 74 65 78 plaintext yytex
89a0: 74 29 0a 20 20 20 20 20 20 20 20 29 29 29 0a 20 t). ))).
89b0: 20 20 27 64 65 63 69 73 69 6f 6e 2d 74 72 65 65 'decision-tree
89c0: 73 0a 20 20 20 30 0a 20 20 20 30 0a 20 20 20 27 s. 0. 0. '
89d0: 23 28 28 35 39 20 28 33 35 20 28 33 32 20 28 39 #((59 (35 (32 (9
89e0: 20 65 72 72 20 28 31 31 20 31 20 65 72 72 29 29 err (11 1 err))
89f0: 20 28 33 33 20 31 20 28 33 34 20 32 20 65 72 72 (33 1 (34 2 err
8a00: 29 29 29 20 28 33 38 20 28 3d 20 33 36 20 65 72 ))) (38 (= 36 er
8a10: 72 20 31 29 0a 20 20 20 20 28 34 34 20 28 33 39 r 1). (44 (39
8a20: 20 65 72 72 20 31 29 20 28 34 35 20 65 72 72 20 err 1) (45 err
8a30: 31 29 29 29 29 20 28 39 35 20 28 39 32 20 28 36 1)))) (95 (92 (6
8a40: 35 20 65 72 72 20 28 39 31 20 31 20 36 29 29 20 5 err (91 1 6))
8a50: 28 39 33 20 31 20 28 39 34 20 35 0a 20 20 20 20 (93 1 (94 5.
8a60: 65 72 72 29 29 29 20 28 31 32 33 20 28 3d 20 39 err))) (123 (= 9
8a70: 36 20 65 72 72 20 31 29 20 28 31 32 35 20 28 31 6 err 1) (125 (1
8a80: 32 34 20 34 20 65 72 72 29 20 28 31 32 36 20 33 24 4 err) (126 3
8a90: 20 65 72 72 29 29 29 29 29 20 28 34 34 20 28 33 err))))) (44 (3
8aa0: 35 20 28 31 31 0a 20 20 20 20 28 39 20 65 72 72 5 (11. (9 err
8ab0: 20 31 29 20 28 3d 20 33 32 20 31 20 65 72 72 29 1) (= 32 1 err)
8ac0: 29 20 28 33 37 20 28 33 36 20 31 20 65 72 72 29 ) (37 (36 1 err)
8ad0: 20 28 3d 20 33 38 20 65 72 72 20 31 29 29 29 20 (= 38 err 1)))
8ae0: 28 39 32 20 28 35 39 20 28 34 35 20 65 72 72 0a (92 (59 (45 err.
8af0: 20 20 20 20 31 29 20 28 36 35 20 65 72 72 20 28 1) (65 err (
8b00: 39 31 20 31 20 65 72 72 29 29 29 20 28 39 36 20 91 1 err))) (96
8b10: 28 39 33 20 31 20 28 39 35 20 65 72 72 20 31 29 (93 1 (95 err 1)
8b20: 29 20 28 39 37 20 65 72 72 20 28 31 32 33 20 31 ) (97 err (123 1
8b30: 20 65 72 72 29 29 29 29 29 0a 20 20 20 20 65 72 err))))). er
8b40: 72 20 65 72 72 20 65 72 72 20 65 72 72 20 65 72 r err err err er
8b50: 72 29 0a 20 20 20 27 23 28 28 23 66 20 2e 20 23 r). '#((#f . #
8b60: 66 29 20 28 35 20 2e 20 35 29 20 28 34 20 2e 20 f) (5 . 5) (4 .
8b70: 34 29 20 28 33 20 2e 20 33 29 20 28 32 20 2e 20 4) (3 . 3) (2 .
8b80: 32 29 20 28 31 20 2e 20 31 29 20 28 30 20 2e 20 2) (1 . 1) (0 .
8b90: 30 29 29 29 29 0a 0a 3b 0a 3b 20 55 73 65 72 20 0))))..;.; User
8ba0: 66 75 6e 63 74 69 6f 6e 73 0a 3b 0a 0a 28 64 65 functions.;..(de
8bb0: 66 69 6e 65 20 6c 65 78 65 72 20 23 66 29 0a 0a fine lexer #f)..
8bc0: 28 64 65 66 69 6e 65 20 6c 65 78 65 72 2d 67 65 (define lexer-ge
8bd0: 74 2d 6c 69 6e 65 20 20 20 23 66 29 0a 28 64 65 t-line #f).(de
8be0: 66 69 6e 65 20 6c 65 78 65 72 2d 67 65 74 63 20 fine lexer-getc
8bf0: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
8c00: 65 20 6c 65 78 65 72 2d 75 6e 67 65 74 63 20 20 e lexer-ungetc
8c10: 20 20 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 #f)..(define
8c20: 6c 65 78 65 72 2d 69 6e 69 74 0a 20 20 28 6c 61 lexer-init. (la
8c30: 6d 62 64 61 20 28 69 6e 70 75 74 2d 74 79 70 65 mbda (input-type
8c40: 20 69 6e 70 75 74 29 0a 20 20 20 20 28 6c 65 74 input). (let
8c50: 20 28 28 49 53 20 28 6c 65 78 65 72 2d 6d 61 6b ((IS (lexer-mak
8c60: 65 2d 49 53 20 69 6e 70 75 74 2d 74 79 70 65 20 e-IS input-type
8c70: 69 6e 70 75 74 20 27 6c 69 6e 65 29 29 29 0a 20 input 'line))).
8c80: 20 20 20 20 20 28 73 65 74 21 20 6c 65 78 65 72 (set! lexer
8c90: 20 28 6c 65 78 65 72 2d 6d 61 6b 65 2d 6c 65 78 (lexer-make-lex
8ca0: 65 72 20 6c 65 78 65 72 2d 64 65 66 61 75 6c 74 er lexer-default
8cb0: 2d 74 61 62 6c 65 20 49 53 29 29 0a 20 20 20 20 -table IS)).
8cc0: 20 20 28 73 65 74 21 20 6c 65 78 65 72 2d 67 65 (set! lexer-ge
8cd0: 74 2d 6c 69 6e 65 20 20 20 28 6c 65 78 65 72 2d t-line (lexer-
8ce0: 67 65 74 2d 66 75 6e 63 2d 6c 69 6e 65 20 49 53 get-func-line IS
8cf0: 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 6c )). (set! l
8d00: 65 78 65 72 2d 67 65 74 63 20 20 20 20 20 20 20 exer-getc
8d10: 28 6c 65 78 65 72 2d 67 65 74 2d 66 75 6e 63 2d (lexer-get-func-
8d20: 67 65 74 63 20 49 53 29 29 0a 20 20 20 20 20 20 getc IS)).
8d30: 28 73 65 74 21 20 6c 65 78 65 72 2d 75 6e 67 65 (set! lexer-unge
8d40: 74 63 20 20 20 20 20 28 6c 65 78 65 72 2d 67 65 tc (lexer-ge
8d50: 74 2d 66 75 6e 63 2d 75 6e 67 65 74 63 20 49 53 t-func-ungetc IS
8d60: 29 29 29 29 29 0a ))))).