Category Archives:编译原理
56 行代码用 Python 实现一个 Flex/Lex
作为 Yacc/Bison 的好搭档 Lex/Flex 是一个很方便的工具，可以通过写几行规则就能生成一个新的词法分析器，大到给你的 parser 提供 token 流，小到解析一个配置文件，都很有帮助；而用 Python 实现一个支持自定义规则的类 Flex/Lex 词法分析器只需要短短 56 行代码，简单拷贝粘贴到你的代码里，让你的代码具备基于可定制规则的词法分析功能。
原理很简单，熟读 Python 文档的同学应该看过regex module 帮助页面最下面有段程序：
def tokenize(code): keywords = {'IF', 'THEN', 'ENDIF', 'FOR', 'NEXT', 'GOSUB', 'RETURN'} token_specification = [ ('NUMBER', r'\d+(\.\d*)?'), # Integer or decimal number ('ASSIGN', r':='), # Assignment operator ('END', r';'), # Statement terminator ('ID', r'[A-Za-z]+'), # Identifiers ('OP', r'[+\-*/]'), # Arithmetic operators ('NEWLINE', r'\n'), # Line endings ('SKIP', r'[ \t]+'), # Skip over spaces and tabs ('MISMATCH', r'.'), # Any other character ] tok_regex = '|'.join('(?P<%s>%s)' % pair for pair in token_specification) line_num = 1 line_start = 0 for mo in re.finditer(tok_regex, code): kind = mo.lastgroup value = mo.group() column = mo.start() - line_start if kind == 'NUMBER': value = float(value) if '.' in value else int(value) elif kind == 'ID' and value in keywords: kind = value elif kind == 'NEWLINE': line_start = mo.end() line_num += 1 continue elif kind == 'SKIP': continue elif kind == 'MISMATCH': raise RuntimeError(f'{value!r} unexpected on line {line_num}') yield Token(kind, value, line_num, column)上面这个官方文档里的程序，输入一段代码，返回 token 的：名称、原始文本、行号、列号 等。
它其实已经具备好三个重要功能了：1）规则自定义；2）由上往下匹配规则；3）使用生成器，逐步返回结果，而不是一次性处理好再返回，这个很重要，可以保证语法分析器边分析边指导词法分析器做一些精细化分析。
我们再它的基础上再修改一下，主要补充：
- 支持外部传入规则，而不是像上面那样写死的。
- 规则支持传入函数，这样可以根据结果进行二次判断。
- 更好的行和列信息统计，不依赖 NEWLINE 规则的存在。
- 支持 flex/lex 中的 “忽略”规则，比如忽略空格和换行，或者忽略注释。
- 支持在流末尾添加一个 EOF 符号，某些 parsing 技术需要输入流末尾插入一个名为 \$ 的结束符。
对文档中的简陋例子做完上面五项修改，我们即可得到一个通用的基于规则的词法分析器。
改写后代码很短，只有 56 行：
(点击 more 展开)
使用 LIBLR 解析带注释的 JSON
前文《基于 LR(1) 和 LALR 的 Parser Generator》里介绍了春节期间开发的小玩具LIBLR ，今天春节最后一天，用它跑一个小例子，解析带注释的 json 文件。由于 python 自带 json 库不支持带注释的 json 解析，而 vscode 里大量带注释的 json 没法解析，所以我们先写个文法，保存为json.txt：
# 定义两个终结符%token NUMBER%token STRINGstart: value {get1} ;value: object {get1} | array {get1} | STRING {get_string} | NUMBER {get_number} | 'true' {get_true} | 'false' {get_false} | 'null' {get_null} ;array: '[' array_items ']' {get_array} ;array_items: array_items ',' value {list_many} | value {list_one} | {list_empty} ;object: '{' object_items '}' {get_object} ;object_items: object_items ',' item_pair {list_many} | item_pair {list_one} | {list_empty} ;item_pair: STRING ':' value {item_pair} ;# 词法：忽略空白@ignore [ \r\n\t]*# 词法：忽略注释@ignore //.*# 词法：匹配 NUMBER 和 STRING@match NUMBER [+-]?\d+(\.\d*)?@match STRING "(?:\\.|[^"\\])*"有了文法，程序就很短了，50 多行足够：（点击 more 展开）
基于 LR(1) 和 LALR 的 Parser Generator
最近处理文本比较多，先前想增强下正则，看来不够用了，有同学推荐了我 Pyl 和 Lark，看了两眼，初看还行，但细看有一些不太喜欢的地方，于是刚好春节几天有空，从头写了一个 LR(1) / LALR 的 Generator，只有一个 LIBLR.py 的单文件，没有其它依赖：
用法很简单，给定文法，返回 Parser：
import LIBLR# 注意这里是 r 字符串，方便后面写正则# 所有词法规则用 @ 开头，从上到下依次匹配grammar = r'''start: WORD ',' WORD '!';@ignore [ \r\n\t]*@match WORD \w+'''parser = LIBLR.create_parser(grammar)print(parser('Hello, World !'))输出：
Node(Symbol('start'), ['Hello', ',', 'World', '!'])默认没有加 Semantic Action 的话，会返回一颗带注释的语法分析树（annotated parse-tree）。
支持语义动作（Semantic Action），可以在生成式中用{name} 定义，对应 name 的方法会在回调中被调用：
import LIBLR# 注意这里是 r 字符串，方便后面写正则grammar = r'''# 事先声明终结符%token numberE: E '+' T {add} | E '-' T {sub} | T {get1} ;T: T '*' F {mul} | T '/' F {div} | F {get1} ;F: number {getint} | '(' E ')' {get2} ;# 忽略空白@ignore [ \r\n\t]*# 词法规则@match number \d+'''# 定义语义动作：各个动作由类成员实现，每个方法的# 第一个参数 rule 是对应的生成式# 第二个参数 args 是各个部分的值，类似 yacc/bison 中的 $0-$N # args[1] 是生成式右边第一个符号的值，以此类推# args[0] 是继承属性class SemanticAction: def add (self, rule, args): return args[1] + args[3] def sub (self, rule, args): return args[1] - args[3] def mul (self, rule, args): return args[1] * args[3] def div (self, rule, args): return args[1] / args[3] def get1 (self, rule, args): return args[1] def get2 (self, rule, args): return args[2] def getint (self, rule, args): return int(args[1])parser = LIBLR.create_parser(grammar, SemanticAction())print(parser('1+2*3'))输出：
（点击 more 查看更多）
Python 中使用组合方式构建复杂正则
正则写复杂了很麻烦，难写难调试，只需要两个函数，就能用简单正则组合构建复杂正则：
比如输入一个字符串规则，可以使用{name} 引用前面定义的规则：
# rules definitionrules = r''' protocol = http|https login_name = [^:@\r\n\t ]+ login_pass = [^@\r\n\t ]+ login = {login_name}(:{login_pass})? host = [^:/@\r\n\t ]+ port = \d+ optional_port = (?:[:]{port})? path = /[^\r\n\t ]* url = {protocol}://({login}[@])?{host}{optional_port}{path}?'''然后调用regex_build 函数，将上面的规则转换成一个字典并输出：
# expand patterns in a dictionarym = regex_build(rules, capture = True)# list generated patternsfor k, v in m.items(): print(k, '=', v)结果：
protocol = (?P<protocol>http|https)login_name = (?P<login_name>[^:@\r\n\t ]+)login_pass = (?P<login_pass>[^@\r\n\t ]+)login = (?P<login>(?P<login_name>[^:@\r\n\t ]+)(:(?P<login_pass>[^@\r\n\t ]+))?)host = (?P<host>[^:/@\r\n\t ]+)port = (?P<port>\d+)optional_port = (?P<optional_port>(?:[:](?P<port>\d+))?)path = (?P<path>/[^\r\n\t ]*)url = (?P<url>(?P<protocol>http|https)://((?P<login>(?P<login_name>[^:@\r\n\t ]+)(:(?P<login_pass>[^@\r\n\t ]+))?)[@])?(?P<host>[^:/@\r\n\t ]+)(?P<optional_port>(?:[:](?P<port>\d+))?)(?P<path>/[^\r\n\t ]*)?)用手写直接写是很难写出这么复杂的正则的，写出来也很难调试，而组合方式构建正则的话，可以将小的简单正则提前测试好，要用的时候再组装起来，就不容易出错，上面就是组装替换后的结果。
下面用里面的 url 这个规则来匹配一下：
（点击 more 展开）
什么时候用C而不用C++？
知乎问题《什么时候用C而不用C++？》：
前两天不是有一个问题是“什么时候用C++而不用C”，我一直觉得问错了，难道不是“能用C++就不用C”么？那么当然就要讨论什么时候用C而不用C++啦。
一直以来都严格遵循OO的原则来进行开发（用的工具是C#和Qt），直到最近，开始接手某同事的代码，整个项目20多个小工程（代码量并不多），除了界面部分用了MFC这种不伦不类的OO以外，所有的代码都是C写的。但是模块化做的非常好。后来跟他讨论为何不用C++，他说其实没有什么特别的，就是习惯和爱好而已，后又补充：
如果不用多态的话，其实不管怎么写，不管用那种语言写，都算不上真正的OO
忽然觉得很有道理……
其实这是一个好问题，
题主开始欣赏到纯 C代码所带来的 “美感” 了，即简单性和可拆分性。代码是自底向上构造，一个模块只做好一个模块的事情，任意拆分组合。对于有参考的 OOP系统建模，自顶向下的构造代码抽象方法是有效率的，是方便的，对于新领域，没有任何参考时，刻意抽象会带来额外负担，并进一步增加系统耦合性，设计调整，往往需要大面积修改代码。
有兴趣你可以读读《Unix编程艺术》，OOP的思维模式，是大一统的；C的思维模式，是分离的。前者方便但容易造成高耦合，后者灵活但开发开发太累。用 C开发，应该刻意强调 “简单” 和 “可拆分”。一个个象搭积木一样的把基础系统搭建出来，哪个模块出问题，局部替换即可。
自底向上的开发模式，并不是从不站在大局考虑问题，而是从某个子系统具体实现开始，从局部迭代，逐步反思全局设计，刻意保持低偶合，一个模块一个模块的来，再逐步尝试组合。
自底向上强调先有实践，再总结理论，理论反过来指导实践，又从实践中迭代修正理论。这和人类认识世界的顺序是一样的，先捕猎筑巢，反思自然是怎么回事，又发现可以生火，又思考自然到底怎么回事情。
它的反面，是指大一统设计，你一开始用 UML画出整套系统的类结构，然后再开工设计。这种思维习惯，如果是参考已有系统做一个类似的设计，问题不大，全新设计的话，他总有一个前提，就是 “你能完整认识整个大自然”，就像人类一开始就要认识捕猎和筑巢还有取火一样。否则每次对世界有了新认识，OOP的自顶向下设计方法都能给你带来巨大的负担。
所以有些人才会说：OOP设计习惯会依赖一系列设计灵巧的 BaseObject，然而过段时间后再来看你的项目，当其中某个基础抽象类出现问题是，往往面临大范围的代码调整。这其实就是他们使用自顶向下思维方法，在逐步进入新世界时候，所带来的困惑。
当然也有人批判这种强调简单性和可拆分性的 Unix思维。认为世界不是总能保持简单和可拆分的，他们之间是有各种千丝万缕联系的，你一味的保持简单性和可拆分性，你会让别人很累。这里给你个药方，底层系统，基础组建，尽量用 C的方法，很好的设计成模块，随着你编程的积累，这些模块象积木一样越来越多，而彼此都无太大关系，甚至不少 .c文件都能独立运行，并没有一个一统天下的 common.h让大家去
include，接口其他语言也方便。
然后在你做到具体应用时根据不同的需求，用C++或者其他语言，将他们象胶水一样粘合起来。这时候，再把你的 common.h，写到你的 C++或者其他语言里面去。当然，作为胶水的语言不一定非要是 C++了，也可以是其他语言。
————-
PS: 这里主要在探讨 OOP存在的问题，并没有讨论嵌入式这种资源限制的情况，以及操作系统和底层等需要精确控制硬件和内存的情况，更没有讨论 C++在语言设计层面的事情。
————-
转部分答疑：（点击more展开）
转换 Intel 汇编格式到 AT&T 汇编风格
常用 MSVC 写内嵌汇编需要兼容 GCC 是一件头疼的事情，不是说你不会写 GCC 的 AT&T 风格汇编，而是说同一份代码写两遍，还要调试两遍，是一件头疼的事情，特别是汇编写了上百行的时候。于是五年前写过一个小工具，可以方便的进行转换，能把 MSVC/MASM 的汇编转成纯 AT&T 风格汇编，或者 GCC Inline 风格汇编，自动识别寄存器和变量，还有跳转地址，并且自动导出。今天把他放上来，或许有用到的人吧。
项目下载：https://github.com/skywind3000/Intel2GAS。
[业余土制] 实时汇编编译器
实时动态在内存中编译汇编代码，并返回函数调用指针，可用于JIT系统的后端：
项目地址：https://github.com/skywind3000/asmpure 例子：
const char *AlphaBlendAsm ="PROC C1:DWORD, C2:DWORD, A:DWORD\n"" movd mm0, A\n"" punpcklwd mm0, mm0\n"" punpckldq mm0, mm0\n"" pcmpeqb mm7, mm7\n"" psubw mm7, mm0\n"" \n"" punpcklbw mm1, C1\n"" psrlw mm1, 8\n"" punpcklbw mm2, C2\n"" psrlw mm2, 8\n"" \n"" pmullw mm1, mm7\n"" pmullw mm2, mm0\n"" paddw mm1, mm2\n"" \n"" psrlw mm1, 8\n"" packuswb mm1, mm1\n"" movd eax, mm1\n"" emms\n"" ret\n""ENDP\n";void testAlphaBlend(void){ CAssembler *casm; int c; int (*AlphaBlendPtr)(int, int, int); // create assembler casm = casm_create(); // append assembly source casm_source(casm, AlphaBlendAsm); AlphaBlendPtr = (int (*)(int, int, int))casm_callable(casm, NULL); if (AlphaBlendPtr == NULL) { printf("error: %s\n", casm->error); casm_release(casm); return; } printf("==================== Alpha Blend ====================\n"); casm_dumpinst(casm, stdout); printf("\nExecute code (y/n)?\n\n"); do { c = getch(); } while(c != 'y' && c != 'n'); if(c == 'y') { int x = AlphaBlendPtr(0x00FF00FF, 0xFF00FF00, 128); printf("output: %.8X\n\n", x); } free(AlphaBlendPtr); casm_release(casm);}output: 7f7f7f7f
虚拟机及VmBasic编译引擎说明
2001-2002 期间开发的虚拟机/编译器开源项目代码和资料：
- 关于虚拟机及其编译器的说明
- VmBasic 开发/调试环境的介绍及说明
- 关于其他
所有资料可以通过下面地址下载：
关于虚拟机及其编译器的说明
记得 3DS/MAX 里面实现了一个类似 BASIC 的脚本，Animator 里面实现了一个类 C 的脚本语言，Autodesk 公司的软件对于脚本支持的很出色，好的脚本引擎在乎平台无关性、高效性和扩充性，一个脚本引擎的需要对一个好程序来说非常迫切，于是半年前我写了一款虚拟机，最近又实现了一个类 Basic 的脚本编译器，特性说明：
1) 高效性和独立于平台：由于虚拟机运行是解释二进制的字节码因此速度明显快于每次运行及时解释的脚本语言，比如 Perl 和 PHP，而虚拟机的核心程序代码也经过数个 C++编译器和平台的测试，可以毫无修改的编译运行于多个操作系统。
2) 充分的开放：通过虚拟机的端口 I/O 技术，要对它进行扩充变得十分容易，VmBeta 指令通过输出/输入的方法向用户自己的程序进行通讯，用户通过处理输出输入消息来达到功能的扩充，使它符合你产品的需要，具体的虚拟机实现和设计说明参考文档 vmbeta.txt 。
3) 可设安全级别：通过可设置安全级别，对程序运行状态进行监控。
通过半年的修改我自己觉得虚拟机够高效开放，就是 vmbasic 编译器写的没有多高的水准：完全没有对生成代码做优化，弄出许多繁琐的中间代码，不过还是明显快于及时解释语言，通过测试速度大概是 DOS 自带的 QBASIC 程序的三倍左右（可以通过目录下的几个算法程序来实验）。
为了检验其效率和扩充性，我将虚拟机程序扩充了一些作图功能写成了 Windows 版本的，然后用 vmbasic 编写了一个空战小游戏，虽然由于一开始我太相信 GDI 而没有选择 DDraw，且编译器要生成 1/2 左右的重复性代码，但是仍可以从游戏中看出效率来（可以用 vmbide.exe 打开 fire.bas 运行），关于编译程序 VmBasic 的更详细说明见 basic.htm
程序说明：压缩档包括虚拟机运行程序 (vmbeta.exe)，VmBasic 调试开发平台 (vmbide.exe)，四个算法例子 (alex1-4.bas)，一个射击游戏例子 (fire.bas) 及其图片，说明帮助文档若干。。。
VmBasic开发/调试环境介绍及说明
右边的图是完整的开发环境左边是语句帮助，中间是代码编写区，下面是编译的错误和过程记录，系统热键说明：
1) F8 编译成 VMS 文件
2) F9 编译并运行程序
3) F1 对 VmBasic 的帮助
4) Shift+F1 帮助 IDE
另外点击运行图表左边的图表可以查看编译出来的虚拟机汇编代码。点击工具目录，可以做一系列设置：虚拟机程序设置，预连接库设置，开发环境设置等，都是简单的东西。
用 VmBasic 编写的射击小游戏：必须 Windows 版的虚拟机程序运行（扩充了 GDI 图形功能）
显示查看虚拟机汇编：
关于其他
半年前在论坛上面看见过一些师兄们关于编译的争论，忽然有所感悟，那时刚好写了虚拟机，于是就决定为它写款语言，本来考虑写类 C 或者类 Pascal 的，但是想着 Basic 用起来简单，而且分析起来似乎也简单，后来我才发现虽然没有 C 的编译难写但由于 Basic 经历了长时间的发展，语法变化很大，总的来说没有同意的规范，模块表示也不明确，就连 IF 语句都有好多种版本，所以一个支持函数/过程的 Basic 编译器我觉得比 Pascal 难写的多。目录 DOS 下有 DOS 环境的编译器和虚拟机，可以用来编译运行非扩展的 vmbasic 程序：alex1-4.bas，可以在 IDE 的工具->设置里面设定虚拟机的运行程序。
这是个引擎的演示版本，毕竟好的东西都不是一个人整出来的，我也会在学校不断的学习，非常欢迎来信讨论相关技术，和游戏/图形程式设计，如果你觉得这套引擎对你有价值，可以写信给我，如果你对相关的东西很感兴趣，也可以写信给我。
成都建设路电子科技大学20013080 林伟
邮编：610000
电话：028-83200790
信箱：skywind3000@163.com
PL0 编译程序Turbo Pascal代码
麻雀虽小，五脏具全，对编译原理的代码以 TPASCAL 格式重写，还原最原版的代码 编译版和例子下载：
http://www.skywind.me/maker/pl0-pas.rar
(********************* PL0 编译程序Turbo Pascal代码 *********************)program pl0(fa,fa1,fa2); (* PL0 compile with code generation *) label 99; (* Turbo Pascal do not support goto between different blocks so, the 'goto' command in getch are replaced by procedure exitp !! in another way, 'label 99' do not work !! Lin Wei 2001 *) const norw=13; (* of reserved words *) txmax=100; (* length of identifier table *) nmax=14; (* max number of digits in numbers *) al=10; (* length of identifiers *) amax=2047; (* maximum address *) levmax=3; (* max depth of block nesting *) cxmax=200; (* size of code array *) type symbol=(nul,ident,number,plus,minus,times,slash,oddsym, eql,neq,lss,leq,gtr,geq,lparen,rparen,comma, semicolon,period,becomes,beginsym,endsym,ifsym, thensym,whilesym,writesym,readsym,dosym,callsym, constsym,varsym,procsym); alfa=packed array[1..al] of char; objects=(constant,variable,procedur); (* wirth used the word "procedure"and"object" there, which won't work! *) symset=set of symbol; fct=(lit,opr,lod,sto,cal,int,jmp,jpc); instruction=packed record f:fct; (* function code *) l:0..levmax; (* level *) a:0..amax; (* displacement addr *) end; (* lit 0,a load constant a opr 0,a execute opr a lod 1,a load variable 1,a sto 1,a store variable 1,a cal 1,a call procedure at level 1 int 0,a increment t -register by a jmp 0,a jump to a jpc 0,a jump conditional to a *) var fa:text; fa1,fa2:text; listswitch:boolean; (* true set list object code *) ch:char; (* last char read *) sym:symbol; (* last symbol read *) id:alfa; (* last identifier read *) num:integer; (* last number read *) cc:integer; (* character count *) ll:integer; (* line length *) kk:integer; cx:integer; (* code allocation index *) line:array[1..81] of char; a:alfa; code:array[0..cxmax] of instruction; word:array[1..norw] of alfa; wsym:array[1..norw] of symbol; ssym:array[' '..'^'] of symbol; (* wirth uses "array[char]" here *) mnemonic:array[fct] of packed array[1..5] of char; declbegsys, statbegsys, facbegsys:symset; table:array[0..txmax] of record name:alfa; case kind:objects of constant:(val:integer); variable,procedur:(level,adr,size:integer) (* "size" lacking in original. I think it belongs here *) end; fin,fout:text; fname:string; err:integer; endf:boolean; procedure error(n:integer); begin writeln('****','':cc-1,'!',n:2); writeln(fa1,'****','':cc-1,'!',n:2); err:=err+1; end; (* error *) procedure exitp; begin endf:=true; close(fin); writeln; exit; end; procedure getsym; var i,j,k:integer; procedure getch; begin if cc=ll then begin if eof(fin) then begin write('program incomplete'); close(fin); writeln; exitp; (*goto 99;*) end; ll:=0; cc:=0; write(cx:4,' '); write(fa1,cx:4,' '); while not eoln(fin) do begin ll:=ll+1; read(fin,ch); write(ch); write(fa1,ch); line[ll]:=ch; end; writeln; ll:=ll+1; (* read(fin,line[ll]); repleaced by two lines below *) line[ll]:=' '; readln(fin); writeln(fa1); end; cc:=cc+1; ch:=line[cc]; end; (* getch *) begin (* getsym *) while ch=' ' do getch; if ch in ['a'..'z'] then begin k:=0; repeat if k<al then begin k:=k+1; a[k]:=ch; end; getch; until not(ch in ['a'..'z','0'..'9']); if k>=kk then kk:=k else repeat a[kk]:=' '; kk:=kk-1; until kk=k; id:=a; i:=1; j:=norw; repeat k:=(i+j) div 2; if id<=word[k] then j:=k-1; if id>=word[k] then i:=k+1; until i>j; if i-1>j then sym:=wsym[k] else sym:=ident; end else if ch in ['0'..'9'] then begin (* number *) k:=0; num:=0; sym:=number; repeat num:=10*num+(ord(ch)-ord('0')); k:=k+1; getch; until not(ch in['0'..'9']); if k>nmax then error(30); end else if ch=':' then begin getch; if ch='=' then begin sym:=becomes; getch; end else sym:=nul; end else if ch='<' then begin getch; if ch='=' then begin sym:=leq; getch; end else sym:=lss; end else if ch='>' then begin getch; if ch='=' then begin sym:=geq; getch; end else sym:=gtr; end else begin sym:=ssym[ch]; getch; end; end; (* getsym *) procedure gen(x:fct;y,z:integer); begin if cx>cxmax then begin write('program too long'); (*goto 99;*) end; with code[cx] do begin f:=x; l:=y; a:=z; end; cx:=cx+1; end; (* gen *) procedure test(s1,s2:symset;n:integer); begin if not(sym in s1) then begin error(n); s1:=s1+s2; while not(sym in s1) do getsym; end; end; (* test *) procedure block(lev,tx:integer;fsys:symset); var dx:integer; (* data allocation index *) tx0:integer; (* inital table index *) cx0:integer; (* inital code index *) procedure enter(k:objects); begin (* enter object into table *) tx:=tx+1; with table[tx] do begin name:=id; kind:=k; case k of constant: begin if num>amax then begin error(31); num:=0; end; val:=num; end; variable: begin level:=lev; adr:=dx; dx:=dx+1; end; procedur: level:=lev; end; end; end; (* enter *) function position(id:alfa):integer; var i:integer; begin (* find identifier in table *) table[0].name:=id; i:=tx; while table[i].name<>id do i:=i-1; position:=i; end; (* position *) procedure constdeclaration; begin if sym=ident then begin getsym; if sym in [eql,becomes] then begin if sym=becomes then error(1); getsym; if sym=number then begin enter(constant); getsym; end else error(2); end else error(3); end else error(4); end; (* constdeclaration *) procedure vardeclaration; begin if sym=ident then begin enter(variable); getsym; end else error(4); end; (* vardeclaration *) procedure listcode; var i:integer; begin if listswitch then begin for i:=cx0 to cx-1 do with code[i] do begin writeln(i,mnemonic[f]:5,l:3,a:5); writeln(fa,i:4,mnemonic[f]:5,l:3,a:5); end; end; end; (* listcode *) procedure statement(fsys:symset); var i,cx1,cx2:integer; procedure expression(fsys:symset); var addop:symbol; procedure term(fsys:symset); var mulop:symbol; procedure factor(fsys:symset); var i:integer; begin test(facbegsys,fsys,24); while sym in facbegsys do begin if sym=ident then begin i:=position(id); if i=0 then error(11) else with table[i] do case kind of constant:gen(lit,0,val); variable:gen(lod,lev-level,adr); procedur:error(21); end; getsym; end else if sym=number then begin if num>amax then begin error(31); num:=0; end; gen(lit,0,num); getsym; end else if sym=lparen then begin getsym; expression([rparen]+fsys); if sym=rparen then getsym else error(22); end; test(fsys,facbegsys,23); end; end; (* factor *) begin (* term *) factor([times,slash]+fsys); while sym in [times,slash] do begin mulop:=sym; getsym; factor(fsys+[times,slash]); if mulop=times then gen(opr,0,4) else gen(opr,0,5) end; end; (* term *) begin (* expression *) if sym in [plus,minus] then begin addop:=sym; getsym; term(fsys+[plus,minus]); if addop=minus then gen(opr,0,1); end else term(fsys+[plus,minus]); while sym in [plus,minus] do begin addop:=sym; getsym; term(fsys+[plus,minus]); if addop=plus then gen(opr,0,2) else gen(opr,0,3); end; end; (* expression *) procedure condition(fsys:symset); var relop:symbol; begin if sym=oddsym then begin getsym; expression(fsys); gen(opr,0,6); end else begin expression([eql,neq,lss,leq,gtr,geq]+fsys); if not(sym in [eql,neq,lss,leq,gtr,geq]) then error(20) else begin relop:=sym; getsym; expression(fsys); case relop of eql:gen(opr,0,8); neq:gen(opr,0,9); lss:gen(opr,0,10); geq:gen(opr,0,11); gtr:gen(opr,0,12); leq:gen(opr,0,13); end; end; end; end; (* condition *) begin (* statement *) if sym=ident then begin i:=position(id); if i=0 then error(11) else if table[i].kind<>variable then begin error(12); i:=0; end; getsym; if sym=becomes then getsym else error(13); expression(fsys); if i<>0 then with table[i] do gen(sto,lev-level,adr); end else if sym=readsym then begin getsym; if sym<>lparen then error(34) else repeat getsym; if sym=ident then i:=position(id) else i:=0; if i=0 then error(35) else with table[i] do begin gen(opr,0,16); gen(sto,lev-level,adr); end; getsym; until sym<>comma; if sym<>rparen then begin error(33); while not(sym in fsys) do getsym; end else getsym; end else if sym=writesym then begin getsym; if sym=lparen then begin repeat getsym; expression([rparen,comma]+fsys); gen(opr,0,14); until sym<>comma; if sym<>rparen then error(33) else getsym; end; gen(opr,0,15); end else if sym=callsym then begin getsym; if sym<>ident then error(14) else begin i:=position(id); if i=0 then error(11) else with table[i] do if kind=procedur then gen(cal,lev-level,adr) else error(15); getsym; end; end else if sym=ifsym then begin getsym; condition([thensym,dosym]+fsys); if sym=thensym then getsym else error(16); cx1:=cx; gen(jpc,0,0); statement(fsys); code[cx1].a:=cx; end else if sym=beginsym then begin getsym; statement([semicolon,endsym]+fsys); while sym in [semicolon]+statbegsys do begin if sym=semicolon then getsym else error(10); statement([semicolon,endsym]+fsys); end; if sym=endsym then getsym else error(17); end else if sym=whilesym then begin cx1:=cx; getsym; condition([dosym]+fsys); cx2:=cx; gen(jpc,0,0); if sym=dosym then getsym else error(18); statement(fsys); gen(jmp,0,cx1); code[cx2].a:=cx; end; test(fsys,[],19); end; (* statement *) begin (* block *) dx:=3; tx0:=tx; table[tx].adr:=cx; gen(jmp,0,0); if lev>levmax then error(32); repeat if sym=constsym then begin getsym; repeat constdeclaration; while sym=comma do begin getsym; constdeclaration; end; if sym=semicolon then getsym else error(5); until sym<>ident; end; if sym=varsym then begin getsym; repeat; vardeclaration; while sym=comma do begin getsym; vardeclaration; end; if sym=semicolon then getsym else error(5); until sym<>ident; end; while sym=procsym do begin getsym; if sym=ident then begin enter(procedur); getsym; end else error(4); if sym=semicolon then getsym else error(5); block(lev+1,tx,[semicolon]+fsys); if sym=semicolon then begin getsym; test(statbegsys+[ident,procsym],fsys,6); end else error(5); end; test(statbegsys+[ident],declbegsys,7); until not(sym in declbegsys); code[table[tx0].adr].a:=cx; with table[tx0] do begin adr:=cx; size:=dx; end; cx0:=cx; gen(int,0,dx); statement([semicolon,endsym]+fsys); gen(opr,0,0); test(fsys,[],8); listcode; end; (* block *) procedure interpret; const stacksize=500; var p,b,t:integer; (* program base topstack registers *) i:instruction; s:array[1..stacksize] of integer; (* datastore *) function base(l:integer):integer; var bl:integer; begin bl:=b; (* find base 1 level down *) while l>0 do begin bl:=s[bl]; l:=l-1; end; base:=bl; end; (* base *) begin writeln('start pl0'); t:=0; b:=1; p:=0; s[1]:=0; s[2]:=0; s[3]:=0; repeat i:=code[p]; p:=p+1; with i do case f of lit: begin t:=t+1; s[t]:=a; end; opr: case a of (* operator *) 0: begin (* return *) t:=b-1; p:=s[t+3]; b:=s[t+2]; end; 1: s[t]:=-s[t]; 2: begin t:=t-1; s[t]:=s[t]+s[t+1]; end; 3: begin t:=t-1; s[t]:=s[t]-s[t+1]; end; 4: begin t:=t-1; s[t]:=s[t]*s[t+1]; end; 5: begin t:=t-1; s[t]:=s[t] div s[t+1]; end; 6: s[t]:=ord(odd(s[t])); 8: begin t:=t-1; s[t]:=ord(s[t]=s[t+1]); end; 9: begin t:=t-1; s[t]:=ord(s[t]<>s[t+1]); end; 10:begin t:=t-1; s[t]:=ord(s[t]<s[t+1]); end; 11:begin t:=t-1; s[t]:=ord(s[t]>=s[t+1]); end; 12:begin t:=t-1; s[t]:=ord(s[t]>s[t+1]); end; 13:begin t:=t-1; s[t]:=ord(s[t]<=s[t+1]); end; 14:begin write(s[t]); write(fa2,s[t]); t:=t-1; end; 15:begin writeln; writeln(fa2); end; 16:begin t:=t+1; write('?'); write(fa2,'?'); readln(s[t]); writeln(fa2,s[t]); end; end; lod: begin t:=t+1; s[t]:=s[base(l)+a]; end; sto: begin s[base(l)+a]:=s[t]; (* writeln(s[t]) *) t:=t-1; end; cal: begin (* generat new block mark *) s[t+1]:=base(l); s[t+2]:=b; s[t+3]:=p; b:=t+1; p:=a; end; int: t:=t+a; jmp: p:=a; jpc: begin if s[t]=0 then p:=a; t:=t-1; end; end; (* with, case *) until p=0; close(fa2); end; (* interpret *) begin (* main *) for ch:=' ' to '!' do ssym[ch]:=nul; (* changed bacause of different character set note the typos below in the original where the alfas were not given the correct space *) word[1]:='begin '; word[2]:='call '; word[3]:='const '; word[4]:='do '; word[5]:='end '; word[6]:='if '; word[7]:='odd '; word[8]:='procedure '; word[9]:='read '; word[10]:='then '; word[11]:='var '; word[12]:='while '; word[13]:='write '; wsym[1]:=beginsym; wsym[2]:=callsym; wsym[3]:=constsym; wsym[4]:=dosym; wsym[5]:=endsym; wsym[6]:=ifsym; wsym[7]:=oddsym; wsym[8]:=procsym; wsym[9]:=readsym; wsym[10]:=thensym; wsym[11]:=varsym; wsym[12]:=whilesym; wsym[13]:=writesym; ssym['+']:=plus; ssym['-']:=minus; ssym['*']:=times; ssym['/']:=slash; ssym['(']:=lparen; ssym[')']:=rparen; ssym['=']:=eql; ssym[',']:=comma; ssym['.']:=period; ssym['#']:=neq; ssym[';']:=semicolon; mnemonic[lit]:='lit '; mnemonic[opr]:='opr '; mnemonic[lod]:='lod '; mnemonic[sto]:='sto '; mnemonic[cal]:='cal '; mnemonic[int]:='int '; mnemonic[jmp]:='jmp '; mnemonic[jpc]:='jpc '; declbegsys:=[constsym,varsym,procsym]; statbegsys:=[beginsym,callsym,ifsym,whilesym]; facbegsys:=[ident,number,lparen]; (* page(output) *) endf:=false; assign(fa1,'PL0.txt'); rewrite(fa1); write('input file? '); write(fa1,'input file?'); readln(fname); writeln(fa1,fname); (* openf(fin,fname,'r'); ==> *) assign(fin,fname); reset(fin); write('list object code ?'); readln(fname); write(fa1,'list object code ?'); listswitch:=(fname[1]='y'); err:=0; cc:=0; cx:=0; ll:=0; ch:=' '; kk:=al; getsym; assign(fa,'PL0-1.txt'); assign(fa2,'PL0-2.txt'); rewrite(fa); rewrite(fa2); block(0,0,[period]+declbegsys+statbegsys); close(fa); close(fa1); if sym<>period then error(9); if err=0 then interpret else write('error in pl/0 program'); 99: (* this line is not work in turbo pascal so replace by procedure exitp: see the memo at the top *) close(fin); writeln; end.