PASCAL 高级编程
TURBO PASCAL高级编程技术与实用程序集锦
作者：董占山
前言
TURBO PASCAL是目前微机上最流行的PASCAL语言,它提供了集编辑、编译、调试和联机帮助于一体的集成软件开发环境，语言本身对标准PASCAL进行了大量的扩展，具有高效的数值运算能力、操作系统的低级调用功能、内嵌式汇编语言等强有力的软件开发支持，可以用于任何类型、任何规模的系统软件和应用软件的开发。特别是1992年推出的TURBO PASCAL 6.0的升级产品BORLAND PASCAL 7.0,它提供了更方便、更广泛的编程环境，如同时提供了DOS实模式软件、DOS保护模式软件和WINDOWS软件的开发环境，应用BORLAND PASCAL不仅可以开发DOS程序，同时也可以开发WINDOWS的应用程序。BORLAND PASCAL是唯一可以和BORLAND C++相媲美的软件开发环境。
本书是共分三部分，第一部分介绍TURBO PASCAL高级编程技术，包括TURBO PASCAL与汇编语言和C语言的混合编程、用TURBO PASCAL编写中断例程、使用过程类型简化程序设计、动态数组的实现方法和怎样在程序中使用扩展内存(EMS)和扩充内存(XMS)等；第二部分包括11类非常有用的TURBO PASCAL单元：显示屏输入和输出单元ACRT、字符串处理单元ASTR、磁盘操作单元DISK、热键单元POPUP、数据库交互单元DBASE、扩展内存单元EMS、扩充内存单元XMS、数学函数单元MATH、矩阵运算单元MATRIX、概率分布函数单元PROB和复数运算单元COMPLEX；第三部分是实用程序，包括软锁驱动器程序、锁硬盘逻辑分区程序、稿纸打印程序、查找并替换程序(可以进行多文件操作)、备份硬盘主引导记录程序、数据库卡片打印程序、BATCH文件转换为COM文件程序及有效擦除机密文件的程序等。
随书提供了程序软盘，读者可以很方便地对书中的程序进行编译运行，或作为软件开发过程中的工具，也可以对程序进行扩充和改进。
本书适合于用TURBO PASCAL进行软件开发的编程人员、大学生、研究生和PASCAL学习者使用。
本书承蒙王路敬研究员的审阅，在成书过程中，得到了王路敬研究员的多方指导和帮助，在此特表示感谢。
由于作者水平有限，错误和不当之处在所难免，请读者多提宝贵意见。
董占山
1994年10月于北京
内容提要
本书是作者多年使用TURBO PASCAL编程的经验结晶。内容共分三部分，第一部分介绍TURBO PASCAL高级编程技术，包括TURBO PASCAL与汇编语言和C语言的混合编程、用TURBO PASCAL编写中断例程、使用过程类型简化程序设计、动态数组的实现方法和怎样在程序中使用扩展内存(EMS)和扩充内存(XMS)等；第二部分包括11类非常有用的TURBO PASCAL单元：显示屏输入和输出单元ACRT、字符串处理单元ASTR、磁盘操作单元DISK、热键单元POPUP、数据库交互单元DBASE、扩展内存单元EMS、扩充内存单元XMS、数学函数单元MATH、矩阵运算单元MATRIX、概率分布函数单元PROB和复数运算单元COMPLEX；第三部分是实用程序，包括软锁驱动器程序、锁硬盘逻辑分区程序、稿纸打印程序、查找并替换程序(可以进行多文件操作)、备份硬盘主引导记录程序、数据库卡片打印程序、BATCH文件转换为COM文件程序及有效擦除机密文件的程序等。本书适合于软件开发人员、大学生、研究生和PASCAL学习者使用。
该书于1994由学苑出版社出版. (ISBN 7-5028-124-4)
----------------------------------------------
本书是我编著的第一本书，它是我5年PASCAL编程的结晶。在1994年秋天，我已经积累了大量的TURBO PASCAL程序，一些已经在杂志上发表，但是仍然有大量的程序静静地存储在我的电脑中，没有介绍给广大的使用TURBO PASCAL编程的朋友。在中国农科院计算中心王路敬研究员的支持和鼓励下，我将自己多年积累的素材分类整理，撰写必要的说明文本，形成了此书。在此书的出版过程中得到了希望公司的秦人华老师的大力协助，最后由北京学苑出版社出版发行（1994, 共223页, 33万字，ISBN 7-80124-493-1）。本书的前言部分详细介绍了本书的内容和读者对象。
TURBO PASCAL虽然是DOS下的编程环境，当你转移到DELPHI环境下时，你会发现本书中的许多程序的算法和程序结构并不需要更改，仍然是可以直接使用的。鉴于此，我将此书完全再在网上出版一次，与广大DELPHI或KELIX程序员共享。使用下面的链接，可以浏览本书的全部内容。希望对你的学习和编程有一定的帮助。欢迎提出问题和建议。下载本书的所有源程序和可执行程序。
第1章 TURBO PASCAL高级编程技术
1.1 单元及其使用
1.2 与汇编语言混合编程
1.3 与C语言混合编程
1.4 过程类型及其使用
1.5 中断例程的编写方法
1.6 动态数组及其使用
1.7 扩充内存(EMS)及其使用
1.8 扩展内存(XMS)及其使用
1.9 程序的标准数据作代码处理的方法
第2章 实用工具单元
2.1 屏幕输入与输出单元ACRT
2.2 字符串处理单元ASTR
2.3 磁盘操作单元DISK
2.4 热键单元POPUP
2.5 数据库交互单元DBASE
2.6 扩充内存单元EMS
2.7 扩展内存单元XMS
2.8 数学函数单元MATH
2.9 矩阵运算单元MATRIX
2.10 概率分布函数单元PROB
2.11 复数运算单元COMPLEX
第3章 实用程序
3.1 软锁驱动器程序
3.2 锁硬盘逻辑盘程序
3.3 稿纸打印程序
3.4 源程序列表程序
3.5 查找并替换程序
3.6 备份硬盘主引导扇区程序
3.7 四通-PC文本文件转换程序
3.8 SPT文件与BMP文件的双向转换程序
3.9 数据库卡片打印程序
3.10 BATCH文件转换为COM文件程序
3.11 机密文件的有效销毁程序
3.12 释放内存程序
附录1 源程序文件索引表
附录2 各种显示卡及其显示模态表
参考文献
----------------------------------------------
第一章 TURBO PASCAL高级编程技术
TURBO PASCAL是美国BORLAND国际公司的产品，在微机PASCAL市场上占有绝对优势。它克服了往常PASCAL编译系统占用大量内存的缺陷，并对标准PASCAL作了许多有益的扩充，如它具有与低层软件和硬件打交道的能力、具有强大的图形图象功能、支持面向对象的程序设计方法、支持WINDOWS程序设计等等。它是一个名副其实的通用系统程序设计语言，十分适合开发一些高级应用软件、数据库管理系统、编译程序等。另外，TURBO PASCAL还配备有一个高性能的集成软件开发环境，包括编辑、编译、调试、文件管理等一系列功能。
本章就使用TURBO PASCAL开发高级软件的实用技术进行阐述，介绍如何使用一些工具和技术，为TURBO PASCAL程序员提供方便。本章将讲述在程序设计时使用单元的技术、TURBO PASCAL与汇编语言和C语言混合编程技术、实现和使用动态数组的技术、编写中断例程的方法、在程序中使用扩展内存(EMS)和扩充内存(XMS)的方法以及将程序的标准数据作代码处理的方法等。
§1.1 单元及其使用
单元是能与TURBO PASCAL程序分开编译的一组TURBO PASCAL过程和函数。因为单元是单独编译的，所以使用单元的程序编译速度快。而且，一个独立的单元可以为多个程序使用。充分利用单元的优点，不仅可以加快软件的开发速度，而且可以提高程序可维护性。
§1.1.1 单元的结构
一个单元有两部分组成──接口部分和实现部分。如:
unit <标识符>; {单元头}
interface {接口部分开始}
uses <单元列表> {可选项}
{公共说明部分}
implementation {实现部分开始}
{私有说明部分}
{过程或函数的定义}
begin {初始化部分开始}
{初始化代码}
end.
1.接口部分
单元的接口部分由保留字interface开始，在单元头和实现部分之间。在此部分，说明公用的常量、类型、变量与过程和函数的头部。一个程序如果使用了一个单元，那么它就能访问该单元的接口部分所定义的所有变量、数据类型、过程和函数。
接口部分仅包含过程和函数的头部。过程和函数的实现部分在单元的实现部分定义。在程序中使用一个单元只需要知道怎样调用单元中的过程，而不需要知道过程是怎样实现的。
2.实现部分
实现部分是由保留字implementation开始。实现部分定义所有在接口部分声明的过程和函数的程序体。另外实现部分可以有自己的说明，这些说明是局部的，外部程序是不知道它们的存在的，也不能调用它们。
因为在实现部分中声明的一切对象在作用域上是局部的，所以实现部分的改变对其它单元和程序来讲是不可见的。因此，修改一个单元的实现部分，并不需要重新编译使用该单元的单元，只需要编译这个修改单元和使用此单元的程序。然而，如果接口部分做了修改，所有使用该单元的单元和程序，均需要重新编译，甚至需要修改。
在实现部分，如果有uses子句，则必须紧跟在保留字implementation之后。
如果过程说明为external类型，则需用{$L 文件名.OBJ}编译指令将其连入程序。
在接口部分说明的函数或过程，除了inline类型之外，都必须在实现部分再现，它们的头部必须和接口部分一致或用简写格式。
3.初始化部分
单元的整个实现部分通常包括在保留字implementation和end之间。然而，如果把保留字begin放在end之前，在它们中间写一些语句，这些语句就是单元的初始化部分。
在初始化部分可以初始化任何变量，这些变量可由单元使用，也可通过接口部分由程序使用。可以在这部分打开文件供程序使用。例如，标准单元Printer用它的初始化部分使所有输出调用都指向文本文件Lst，这样在write语句中就可以使用它。
当使用单元的程序执行时，在程序的主体执行之前，它所使用的所有单元的初始化部分按uses子句中说明的先后依次被调用。
§1.1.2 单元的使用
当使用单元时，需在uses语句中将使用的所有单元的名字列出来，单元与单元之间用逗号(,)隔开。如:
uses dos,crt;
当编译器扫描到uses子句时，它把每个单元的接口信息加到符号表中，同时又把实现部分的机器码与程序代码连接起来。
1.单元的直接引用
一个模块(程序或单元)的uses子句只须列出该模块直接使用的单元名。例如:
program prog;
uses unit2;
const
a = b;
begin
writeln('a=',a);
end.
unit unit2;
interface
uses unit1;
const
b = c;
implementaion
end.
unit unit1;
interface
const
c = 1;
implementation
const
b = 2;
end.
unit2用了unit1，主程序用了unit2，间接地使用了unit1。
单元的接口部分如果有改动，则所有使用该单元的单元或程序必须重新编译。但如果改动了单元的实现部分，则用到它的单元不必重新编译。在上例中，如果unit1的接口部分改动了(如C=2)，unit2就必须重新编译;如果只改动实现部分(b=1)，则unit2不必重新编译。
编译一个单元时，TURBO PASCAL计算出该单元的版本数，这个数是单元的接口部分的校验和。上例中，在编译unit2时，unit1的当前版本数存入unit2的编译版本中，编译主程序时，unit1的版本数就和存在unit2中的版本数比较，若二者不同，说明unit2编译后，unit1的接口部分改动过，编译器给出错误信息并重新编译unit2。
2.单元的循环引用
由于在实现部分使用的单元对用户是不可见的，因此把uses子句放在单元的实现部分，进一步隐藏了单元的内部细节，而且有可能构造出相互依赖的单元。
下面的例子说明两个单元如何相互引用。主程序Circular使用Display单元，而Display单元在接口部分说明了Writexy过程，它有3个参数:坐标值x和y和要显示的文本信息，若(x，y)在屏幕内，Writexy移动光标到(x,y)并显示信息，否则，调用简单的错误处理过程ShowError，而ShowError过程反过来又调用Writexy来显示错误信息，这样就产生了单元的循环引用问题。
主程序:
program circular;
uses
crt,display;
begin
writexy(1,1,'Upper left corner of screen');
writexy(100,100,'Way of the screen');
writexy(81-length('Back to reality'),15,'Back to reality');
end.
display单元:
unit display;
interface
procedure Writexy(x,y:integer;Message:string);
implementation
uses CRT,Error;
procedure Writexy;
begin
if (x in [1..80]) and (y in [1..25]) then
begin
gotoxy(x,y);
writeln(message);
end
else
ShowError('Invalid Writexy coordinates');
end;
end.
Error单元:
unit Error;
interface
procedure ShowError(ErrMessage);
implementation
uses display;
procedure ShowError;
begin
Writexy(1,25,'Error: '+ErrMessage);
end;
end.
Display和Error单元的实现部分的uses子句互相引用，TURBO PASCAL能完整编译两个单元的接口部分，只要在接口部分不相互依赖，在实现部分可以相互调用。
§1.1.3 单元与大程序
单元是TURBO PASCAL模块化编程的基础，它用来创建能够为许多程序使用但不需要源程序的过程和函数库，它是把大程序划分为多个相关的模块基础。
通常，一个大程序可以划分为多个单元，这些单元按过程的功能将其分组。例如，一个编辑程序可以划分成初始化、打印、读写文件、格式化等若干个部分。另外，也可以有一个定义全局常量、数据类型、变量、过程及函数的“全局”单元，它能被所有单元和主程序使用。
一个大程序的框架如下:
program Editor;
uses
dos,crt,printer,
EditGlobal;
EditInit;
EditPrint;
EditFile;
EditFormat;
......
begin
...
end.
在大程序开发中使用单元的另一个原因是与代码段的限制有关。8086处理器要求代码段长度最大为64K。这意味着主程序及任何单元都不能超过64K。TURBO PASCAL将每个单元放在一个单独的段中来解决这个问题。
§1.2 与汇编语言混合编程
TURBO PASCAL以编译速度快、生成的目标代码高速和紧凑而著称。在大多数情况下，只使用TURBO PASCAL即可以完成各种各样的程序编制，但是，在硬件接口程序、实时控制程序及大规模浮点运算时，都需要用汇编语言来编程。虽然TURBO PASCAL提供了INLINE语句和命令，以及内嵌式汇编语言(TURBO PASCAL 6.00)，但这是远远不够的。本节详细讨论TURBO PASCAL与汇编语言混合编程的技术，并列举了大量的实例。
§1.2.1 TURBO PASCAL的调用协定
TURBO PASCAL程序与外部汇编子程序混合编程时，要涉及到子程序的调用方式、函数或过程的参数传递方法和函数如何返回值的问题，现分述如下。
§1.2.1.1 调用子程序的方式和子程序的返回方式
TURBO PASCAL程序在调用汇编子程序时，可以是近调用也可以是远调用，因此，TURBO PASCAL程序在对汇编子程序进行调用时，根据调用方式的不同，有两种不同的保存返回地址的方法：①近调用时，因是段内调用，仅将偏移地址IP入栈，占2字节；②远调用时，因是段间调用，要将代码段值CS和偏移地址IP入栈，占4字节。
在主程序中直接调用汇编子程序时，一般采用近调用，汇编子程序采用近返回方式，用RET指令；在TURBO PASCAL的单元中使用汇编子程序时分两种情况：①在单元接口部分说明的子程序，在汇编子程序中要用远返回，用RETF指令；②在单元解释部分说明的子程序，汇编子程序要用近返回方式，用RET指令。
汇编子程序在运行结束后，为了能正确地返回到调用程序，栈顶指针必须指向正确的返回地址，它通过在返回指令RETF(或RET)中给出参数入栈时所占的字节数的方法实现的。
§1.2.1.2 参数传递的方法
TURBO PASCAL是利用堆栈向过程和函数传递参数的，参数按从左到右的顺序(说明顺序)被压入堆栈中，例如调用过程PROC(A，B，C : INTEGER; VAR D)时，其堆栈情况见图1-1。
殌 ┌────────────┐
│+0E│ 参数A的值 │ ↑
│ ├────────────┤ │
参│+0C│ 参数B的值 │ │参
│ ├────────────┤ │
数│+0A│ 参数C的值 │ │数
│ ├────────────┤ │
压│ +8│ 参数D的段地址 │ │出
│ ├────────────┤ │
栈│ +6│ 参数D的偏移地址 │ │栈
│ ├────────────┤ │
顺│ +4│ 过程返回的段地址 │ │顺
│ ├────────────┤ │
序│ +2│ 过程返回的偏移地址 │ │序
↓ ├────────────┤ │
│ BP寄存器的值 │
└────────────┘
殣 图1-1.TURBO PASCAL远调用汇编程序PROC的堆栈情况
TURBO PASCAL在调用子程序时，有两种传递参数的方法，即传值和传地址的方法。下面分别说明这两种参数传递方法。各种类型参数入栈的方法见表1-1。
(1)传值方式
在TURBO PASCAL的过程或函数的形式参数表中，以值参形式定义的参数，且类型是记录、数组、字符串、指针等复合类型以外的各种类型，如字节型(BYTE)、短整型(SHORTINT)、整型(INTEGER)、字型(WORD)、长整型(LONGINT)、字符型(CHAR)、布尔型(BOOLEAN)、实数型(REAL)等，TURBO PASCAL在调用子程序时，直接将实参值依次从左到右顺序压入堆栈中，汇编子程序可以直接从堆栈中取得实参的值。
(2)传地址方式
在TURBO PASCAL的过程或函数的形式参数表中，以变量形式定义的参数，及以记录、字符串、数组、指针等复合类型定义的值参，TURBO PASCAL在调用子程序时，是将调用程序的实参地址依次按从左到右的顺序压入堆栈的。汇编子程序从堆栈中取得实参的地址，即可得到参数的值。同样汇编子程序可以把运算结果存放到对应的变量中，以便传回调用程序。
表1-1.各种类型参数入栈的方法
殌┌───────┬────┬─────┐
│形参类型 │传递方式│栈中字节数│
├───────┼────┼─────┤
│char,boolean │ │ │
│byte,shortint,│ 传值 │ 2 │
│integer,word │ │ │
├───────┼────┼─────┤
│longint,single│ 传值 │ 4 │
├───────┼────┼─────┤
│real │ 传值 │ 6 │
├───────┼────┼─────┤
│double │ 传值 │ 8 │
├───────┼────┼─────┤
│string,pointer│ 传地址 │ 4 │
│变量 │ │ │
└───────┴────┴─────┘殣
§1.2.1.3 函数返回值的传递
TURBO PASCAL函数返回值的传递方式根据函数返回值类型的不同而异，有采用传地址的方式进行，也有采用寄存器方式进行，如采用传地址的方式，其地址(4字节)首先入栈，然后才压入函数参数，最后压入函数的返回地址。各种函数返回类型的传递方式见表1-2。
表1-2.各种函数返回类型的传递方式
殌┌───────┬──────────┬──────┐
│ 函数返回类型 │ 返 回 方 式 │ 所占字节数 │
├───────┼──────────┼──────┤
│boolean,byte, │ 在寄存器AL中 │ 1 │
│char,shortint │ │ │
├───────┼──────────┼──────┤
│word,integer │ 在寄存器AX中 │ 2 │
├───────┼──────────┼──────┤
│longint │ 高位在DX,低位在AX │ 4 │
├───────┼──────────┼──────┤
│real │由高到低在DX,BX,AX中│ 6 │
├───────┼──────────┼──────┤
│pointer │段地址在DX,偏移在AX │ 4 │
├───────┼──────────┼──────┤
│string │ 在DS:SI指的地址中 │ 不限 │
└───────┴──────────┴──────┘
殣
§1.2.2 汇编子程序的编写格式
根据TURBO PASCAL的调用协定，外部汇编子程序的通用编写格式如下：
TITLE 程序名
DOSSEG
LOCALS @@
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
PUBLIC 过程或函数名
过程或函数名:
PUSH BP
MOV BP，SP
…
POP BP
RETF 参数占堆栈字节数
END
上述汇编子程序是TURBO ASSEMBLER的格式，本文汇编子程序均采用这种格式。对此汇编子程序格式说明如下：
. 汇编模块要采用TPASCAL模式；
. 在汇编模块中，必须把TURBO PASCAL调用的过程或函数说明为PUBLIC属性；
. 子程序返回指令视具体情况而定，近调用用RET，远调用用RETF；
. 返回指令后的参数是指该子程序形式参数表中所有参数入栈后所占堆栈的字节数；
. 汇编模块结束要写END。
§1.2.3 TURBO PASCAL程序的编写格式
在TURBO PASCAL中，声明外部子程序的格式如下:
procedure prc(a, b : integer; var c : real);external;
function func(a, b : integer) : real; external;
即在通常的TURBO PASCAL过程或函数的声明后加上external关键字。在声明了外部过程或函数的主程序或程序单元中，要用编译指令{$L}，把汇编好的目标模块加载进来。
在TURBO PASCAL程序中使用外部汇编过程或函数时，方法和一般的TURBO PASCAL过程和函数没有两样。
§1.2.4 主程序中使用外部汇编子程序的典型例子分析
在TURBO PASCAL主程序中直接使用外部汇编子程序时，一般采用近调用方式，所以汇编子程序返回指令为RET，在特别指明采用远调用方式时，要用RETF返回指令。
1.无参数传递的过程
program prog1;
{$L prog1.obj}
procedure DisplayOk;external;
begin
DisplayOk;
end.
Title PROG1
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
OkMsg db 'OK !',0dh,0ah,'$'
; Procedure DisplayOk
PUBLIC DisplayOk
DisplayOk:
push ds ;保存数据段
push cs ;代码段入栈
pop ds ;弹出数据段
mov ah,09 ;显示字符串
mov dx,offset OkMsg ;字符串地址
int 21h ;DOS功能调用
pop ds ;恢复数据段
ret ;近返回
end ;汇编子模块结束
2.传递字符型值参的过程
program prog2;
{$L prog2.obj}
procedure DisplayInt(ch : char);external;
begin
DisplayInt('a');
end.
Title PROG2
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; Procedure DisplayInt
PUBLIC DisplayInt
DisplayInt:
push bp
mov bp,sp
mov ah,02 ;显示字符
mov dl,[bp+4] ;从栈中取参数
int 21h ;DOS功能调用
pop bp
ret 2 ;形式参数在栈中占2字节
end
3.传递字符型值参和整型变参的过程
program prog3;
{$L prog3.obj}
procedure ProcArg(ch : char;var i : integer);external;
var i : integer;
begin
ProcArg('d',i);
writeln(i);
end.
Title PROG3
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; Procedure ProcArg
PUBLIC ProcArg
ProcArg:
push bp
mov bp,sp
xor ax,ax
mov al,byte ptr [bp+8] ;取字符参数
les si,[bp+4] ;取整数变量的地址
mov es:[si],al
pop bp
ret 6 ;形式参数在栈中占6字节
end
4.传递字符值参返回整型的函数
program prog4;
{$L prog4.obj}
function func(ch : char) : integer; external;
begin
writeln(func('a'));
end.
Title PROG4
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; Procedure func
PUBLIC func
func:
push bp
mov bp,sp
xor ax,ax
mov al,byte ptr [bp+4] ;取字符参数值
pop bp
ret 2 ;形式参数在栈中占2字节
end ;子程序返回值在寄存器AX中
5.传递字符串型值参和返回字符串型的函数
program prog5;
{$L prog5.obj}
function func(s : string) : string; external;
begin
writeln( func('abcd') );
end.
Title PROG5
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; Procedure func
PUBLIC func
func:
push bp
mov bp,sp
push ds
xor ch,ch
lds si,[bp+4] ;取字符串S的地址
les di,[bp+8] ;取返回值地址
mov cl,[si]
inc cl
cld
@@1:
lodsb
stosb
loop @@1
pop ds
pop bp
ret 4 ;字符串S的地址在栈中占4字节
end
6.传递长整型值参和返回长整型的函数
program prog6;
{$L prog6.obj}
function func(li : LongInt) : Longint; external;
var i : longint;
begin
i := func(111111110);
writeln(i);
end.
Title PROG6
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; Procedure func
PUBLIC func
func:
push bp
mov bp,sp
mov ax,[bp+4] ;取长整型数高位
mov dx,[bp+6] ;取长整型数低位
les si,[bp+8] ;取函数返回地址
mov es:[si],dx
mov es:[si+2],ax
pop bp
ret 4 ;长整型数LI在栈中占4字节
end
7.传递实型数值参和返回实型数的函数
program prog7;
{$L prog7.obj}
function func(r : real) : real; external;
var r : real;
begin
r := func(11111.1110);
writeln(r);
end.
Title PROG7
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; Procedure func
PUBLIC func
func:
push bp
mov bp,sp
mov ax,[bp+4] ;取实数R的值
mov bx,[bp+6] ;
mov dx,[bp+8] ;
les si,[bp+0ah] ;取函数的返回地址
mov es:[si],dx
mov es:[si+2],bx
mov es:[si+4],ax
pop bp
ret 6 ;实数R在栈中占6字节
end
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 15:53:23
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第4楼
§1.2.5 单元中使用汇编模块的情况
在下面的演示单元DEMOU中声明了两个外部汇编函数，P1是在单元接口部分定义的，在汇编模块中采用远返回方式，P2是在单元的解释部分声明的，在汇编模块中采用近返回方式。在单元DEMOU的过程P3中又调用了函数P1和P2，调用P2采用近调用，没有问题；当调用P1时，因其是在接口部分定义的，必须采用远调用方式，这可以用编译指令{$F}来完成，在调用 P1之前，加上 {$F+}，在调用之后，加上{$F-}即可。
program prog8;
uses demou;
begin
if p1(1) then Writeln('Far call complete !');
p3;
end.
unit demou;
interface
function p1(a : integer) : boolean;
procedure p3;
implementation
{$L demou.obj}
function p1( a : integer) : boolean; external;
function p2( a : char ) : boolean; external;
procedure p3;
begin
if p2('a') then writeln('Near call complete !');
{$F+} ;打开远调用编译指令
if p1(1) then Writeln('Far call again !');
{$F-} ;关闭远调用编译指令
end;
end.
Title DEMOU
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; function p1
PUBLIC p1
p1:
push bp
mov bp,sp
xor ax,ax
cmp ax,[bp+4]
jnz @@1
mov al,0
jmp @@2
@@1: mov al,1
@@2: pop bp
retf 2 ;此函数在单元接口部分定义
; function p2
PUBLIC p2
p2:
push bp
mov bp,sp
mov ax,'a'
cmp ax,[bp+4]
jnz @@3
mov al,0
jmp @@4
@@3: mov al,1
@@4: pop bp
ret 2 ;此函数在单元解释部分定义
end
§1.2.6 小结
本节详细地介绍了TURBO PASCAL与汇编语言混合编程的技术，并给出了许多典型实例，读者可以参照实例的格式进行混合语言编程，解决工作中的具体问题。高级语言和汇编语言混合编程是一个比较复杂的事情，只有在实践中不断细心体会，积累经验，才能有所提高。在对混合语言编写的程序进行调试时，不妨多使用TURBO DEBUGGER，它可以帮助你发现许多不易发现的汇编语言的错误，有利于加快程序的开发进程。
§1.3 与C语言混合编程
一般来说，高级语言间的相互调用比较困难。对TURBO系列软件来说，BORLAND公司提供了语言之间相互调用的接口机制，下面介绍TURBO PASCAL和TURBO C/C++混合编程的方法步骤。TURBO PASCAL的调用协议在上一节中已经叙述，这里不再赘述。
§1.3.1 TURBO C/C++程序的编写与编译
用TURBO C编写的供TURBO PASCAL调用的模块的一般形式如下:
/* C moduler for Turbo PAscal */
类型1 far 函数名1(形参表) /* 在单元接口部分定义 */
{
...
}
类型2 near 函数名2(形参表) /* 在程序或单元实现部分定义 */
{
...
}
其中，第一个函数的说明部分使用了调用模式说明far，它是在TURBO PASCAL单元的接口部分定义的，需要使用远调用。第二个函数用了near调用模式，它是在单元的实现部分或程序中定义的，采用近调用。
编写供TURBO PASCAL程序使用的TURBO C模块应当遵循如下的规则：
(1)在TURBO PASCAL单元的实现部分或主程序中直接定义的C函数，调用类型应当说明为near；在TURBO PASCAL单元的接口部分定义的C函数，调用类型应当说明为far；
(2)公用数据应当在TURBO PASCAL程序中定义，TURBO C模块中定义的数据不能被TURBO PASCAL程序引用；
(3)由于没有正确的段名，TURBO C/C++的运行库例程不能在TURBO C模块中使用。但是，当你拥有TURBO C/C++运行库例程的源码时，可以在你的C模块中包含进库例程的原型，重编译单个库例程模块，这样即可使用相关的库例程；
将编写好的TURBO C/C++程序模块编译成目标文件，需要遵循如下的规则：
(1)任何C模块均用小内存模式(SMALL)编译；
(2)把TURBO C/C++的代码生成编译开关设置为PASCAL；
(3)段名设置如下：
CODE names的Segment name设置为CODE，Group name和Class name设为空；
DATA names的Segment name设置为CONST，Group name和Class name设为空；
BSS names的Segment name设置为DATA，Group name和Class name设为空；
或者，用TURBO PASCAL系统盘上提供的TURBO C/C++的配置文件TURBOC.CFG来编译C模块的源程序。方法有二：
(1)在包含TURBOC.CFG和C模块子目录下，执行:
TCC C模块名.C
(2)执行:
TC /CCTOPAS.TC C模块名.C
把C模块编译为目标模块，即可在TURBO PASCAL程序中引用。其中CTOPAS.TC和TURBOC.CFG都可以在TURBO PASCAL或TURBO C的系统盘上找到。
§1.3.2 TURBO PASCAL程序的编写
TURBO PASCAL程序与普通的TURBO PASCAL程序没有两样，只是把有关的C函数定义为外部函数，并用编译开关{$L 文件名}将C模块的目标模块(.OBJ)连接到PASCAL程序中即可。
§1.3.3 程序中使用TURBO C函数的实例
在TURBO PASCAL的主程序中使用TURBO C模块定义的函数， 则C模块中的函数一般均定义为near调用类型。实例如下:
PASCAL主程序CPASDEMO.PAS：
program CPASDEMO;
uses Crt;
var
Factor : Word;
{$L CPASDEMO.OBJ}
function Sqr(I : Integer) : Word; external;
{ Change the text color and return the square of I }
function HiBits(W : Word) : Word; external;
{ Change the text color and return the high byte of W }
function Suc(B : Byte) : Byte; external;
{ Change the text color and return B + 1 }
function Upr(C : Char) : Char; external;
{ Change the text color and return the upper case of C }
function Prd(S : ShortInt) : ShortInt; external;
{ Change the text color and return S - 1 }
function LoBits(L : LongInt) : LongInt; external;
{ Change the text color and return the low word of L }
procedure StrUpr(var S : string); external;
{ Change the text color and return the upper case of S-Note that }
{the Turbo C routine must skip the length byte of the string. }
function BoolNot(B : Boolean) : Boolean; external;
{ Change the text color and return NOT B }
function MultByFactor(W : Word) : Word; external;
{ Change the text color and return W * Factor - note }
{ Turbo C's access of Turbo Pascal's global variable. }
procedure SetColor(NewColor : Byte);
{ A procedure that changes the current }
begin
{ display color by changing the CRT }
TextAttr := NewColor;
{ variable TextAttr }
end; { SetColor }
var
S : string;
begin
Writeln(Sqr(10));
{ Call each of the functions defined }
Writeln(HiBits(30000));
{ passing it the appropriate info. }
Writeln(Suc(200));
Writeln(Upr('x'));
Writeln(Prd(-100));
Writeln(LoBits(100000));
S := 'abcdefg';
StrUpr(S);
Writeln(S);
Writeln(BoolNot(False));
Factor := 100;
Writeln(MultbyFactor(10));
SetColor(LightGray);
end.
C模块CPASDEMO.C：
typedef unsigned int word;
typedef unsigned char byte;
typedef unsigned long longword;
extern void setcolor(byte newcolor); /* procedure defined in
Turbo Pascal program */
extern word factor; /* variable declared in Turbo Pascal program */
word sqr(int i)
{
setcolor(1);
return(i * i);
} /* sqr */
word hibits(word w)
{
setcolor(2);
return(w >> 8);
} /* hibits */
byte suc(byte b)
{
setcolor(3);
return(++b);
} /* suc */
byte upr(byte c)
{
setcolor(4);
return((c >= 'a') && (c <= 'z') ? c - 32 : c);
} /* upr */
char prd(char s)
{
setcolor(5);
return(--s);
} /* prd */
long lobits(long l)
{
setcolor(6);
return((longword)l & 65535);
} /* lobits */
void strupr(char far *s)
{
int counter;
for (counter = 1; counter <= s[0]; counter++) /* Note that the routine */
s[counter] = upr(s[counter]); /* skips Turbo Pascal's */
setcolor(7); /* length byte */
} /* strupr */
byte boolnot(byte b)
{
setcolor(8);
return(b == 0 ? 1 : 0);
} /* boolnot */
word multbyfactor(word w)
{
setcolor(9); /* note that this function accesses the Turbo Pascal */
return(w * factor); /* declared variable factor */
} /* multbyfactor */
§1.3.4 TURBO PASCAL单元中使用TURBO C函数的实例
在TURBO PASCAL单元中使用TURBO C模块定义的函数，则C模块中的函数的调用方式可以是near和far两种类型。下面给出一个简单的例子。
PASCAL主程序CPDEMO.PAS:
program CTOPASDEMO;
uses CPUNIT;
begin
writeln(add2(3));
DisplaySub2(3);
end.
PASCAL单元CPUNIT.PAS:
unit CPUNIT;
interface
function add2(x : integer) : integer;
procedure DisplaySub2(x: integer);
implementation
{$L CTOPAS.OBJ}
function add2; external;
function sub2(x : integer) : integer; external;
procedure DisplaySub2;
begin
WriteLn(Sub2(x));
end;
end.
C模块CTOPAS.C:
int far add2( int x)
{
return (x + 2);
}
int sub2(int x)
{
return(x - 2);
}
TURBO PASCAL和TURBO C均是目前比较流行的编程语言，广大编程人员如果能正确熟练地使用TURBO PASCAL和TURBO C进行混合编程，可以达到事半功倍的效果，使软件的开发得以加速。
§1.4 过程类型及其使用
TURBO PASCAL允许使用过程类型，把过程或函数当做能赋给变量或传给参数 的对象。在过程类型说明中，定义过程或函数的参数和函数的返回类型。
§1.4.1 过程类型的说明
过程类型的说明方法如下：
TYPE
Proc0 = Procedure;
Proc1 = Procedure(x : integer);
func0 = function : integer;
func1 = function(x : integer) : boolean;
过程类型说明中的参数名完全是装饰性的，并无实际意义。
§1.4.2 过程类型常量
过程类型常量必须指定过程或函数的标识符，而且过程或函数必须与常量的类型赋值兼容。例如:
Type
ErrorProc = Procedure(ErrorCode : integer);
Procedure DefaultError(ErrorCode : integer); far;
begin
Writeln('Error ',ErrorCode,'.');
end;
const
ErrorHandler : ErrorProc = DefaultError;
§1.4.3 过程类型变量
过程类型说明之后，就可以用来定义变量，这种变量叫做过程变量。如:
Var
f01,f02 : func0;
f11,f12 : func1;
p1 : proc1;
象整型变量一样，过程变量能赋以过程值。过程值可以是另一过程变量，一可以是过程或函数的标识符。比如有如下过程和函数说明:
function f1 : integer;far;
begin
f1 : = 1;
end;
则下面的语句是成立的:
f01 := @f1;
f02 := f01;
把函数或过程赋给过程变量，必须满足下列要求:
. 函数或过程必须是far调用类型
. 不能是标准过程或函数
. 不能是嵌入式过程或函数
. 不能是INLINE过程或函数
. 不能是INTERRUPT过程
过程类型的使用不限于简单变量，象其它类型一样，过程类型变量可以作为结构类型的分量。如:
type
GotoProc = procedure(x,y:integer);
procList = array[1..10] of GotoProc;
WindowPtr = ^WindowRec;
WindowRec = Record
Next : WindowPtr;
Header : string[31];
Top,Left,Bottom,Right : integer;
SetCursor : GotoProc;
end;
var
p : ProcList;
W : WindowPtr;
这样说明之后，下面语句是合法的过程调用:
p[3](1,1);
W^.SetCursor(10,10);
过程值赋给过程变量，实际上是把过程的地址存放到变量中。过程变量很象指针指针量，只是指针变量指向数据，过程变量指向过程或函数的入口。过程变量占4个字节，第一个字存放地址的偏移量，第二个字存放段地址。
§1.4.4 表达式中的过程类型
通常，在语句或表达式中使用过程变量表示对变量中储存的过程或函数的调用，但也有例外，当TURBO PASCAL在一个赋值语句的左边发现一个过程变量时，它就认为右边一定是一个过程值。例如:
type
IntFunc = function : integer;
var
F : IntFunc;
N : integer;
function ReadInt : integer; far;
var i : integer;
begin
readln(i);
ReadInt := i;
end;
begin
F := ReadInt;
N := ReadInt;
end.
主程序中的第一个语句将过程值ReadInt赋给过程变量F，第二个语句调用ReadInt，将返回值赋给N。
对语句:
if F = ReadInt then Writeln('Equal');
的解释是，调用F和ReadInt，然后比较它们的返回值，如果相等，则打印Equal。若要比较F和ReadInt的过程值，必须使用以下的结构:
if @F = @ReadInt then Writeln('Equal');
当给出过程变量或过程、函数标识符是时，地址操作符@可以阻止编译器调用该过程、函数，同时将参量转换为一个指针，@F将F转换为包含地址的无类型指针，@ReadInt返回ReadInt的地址。
当要取得过程变量的内存地址时，必须连用两个地址操作符(@@)。如，@F表示将F转换为一个无类型指针变量，@@F则表示返回变量F的物理地址。
§1.4.5 过程类型参数
由于过程类型可在任何场合使用，所以可把过程类型作为过程或函数的参数进行传递，这样在某些场合可以大大简化程序的编制工作。下面两例说明了过程参数的使用。
利用Simpson公式，求S=∫攩b攪攬a攭f(x)dx。采用逐步近似逼近方法:S=h/3*(f攬0攭+4*(f攬1攭+f攬3攭+...+f攬n-1攭)+2*(f攬2攭+f攬4攭+...+f攬n-2攭+f攬n攭)，其中f攬i攭=f(a+i*h)，h=(b-a)/n。
program Simpson_Method;
type
Func = function(x: real) : real;
{$F+}
function Simpson(f : Func; a,b : real; n : integer) : real;
var
h,s : real;
i : integer;
begin
h := (b-a) / n;
s := f(a) + f(b);
for i := 1 to n-1 do
if odd(i) then s := s + 4 * f(a + i*h)
else s := s + 2 * f(a + i*h);
Simpson := s * h / 3;
end;
function f1(x : real) : real;
begin
f1 := sqr(x) * sin(x);
end;
function f2(x : real) : real;
begin
f2 := 1 / (1 + x);
end;
begin
Writeln('∫1,2(x^2*sin(x) = ',SimpSon(f1,1,2,10):10:2);
Writeln('∫1,10(1/(1+x)) = ',SimpSon(f1,1,10,20):10:2);
end.
利用过程参数，设计一个通用的打印自然对数和常用对数表的程序。
program PrintLogTable;
type Func = function(x : integer) : real;
{$F+}
function log(x : integer) : real;
begin
log := ln(x) / ln(10);
end;
function lne(x : integer) : real;
begin
lne := ln(x);
end;
procedure PrintTable(i,w : integer; f : func);
var
m,n : integer;
begin
m := 0;
n := 0;
repeat
inc(m);
inc(n);
write(m:3,f(m):7:4,' ');
if n = w then
begin
writeln;
n := 0;
end;
until m = i;
writeln;
end;
begin
PrintTable(1000,7,log);
PrintTable(1000,7,lne);
end.
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 15:55:28
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第5楼
§1.5 中断例程的编写方法
TURBO PASCAL的运行库和由编译程序产生的代码是可中断的。大多数运行库是可重入的，这允许你用TURBO PASCAL编写中断例程。
§1.5.1 编写中断例程
中断过程可用INTERRUPT指令声明。每个中断程序必须用下列过程头来说明:
procedure IntHandle(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP : WORD);
INTERRUPT;
BEGIN
...
END;
所有寄存器都是作为参数传递的，所以在源代码中可以使用和修改，并且可以省略部分和全部参数。
在入口时，中断过程自动保存所有的寄存器，并初始化DS寄存器；出口代码恢复所有寄存器，并执行中断返回指令。
§1.5.1.1 常驻型中断例程(ISR)的框架
Program 程序名;
{$M 栈长度,0,0}
uses dos;
var
...
procedure 中断过程名(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP : WORD);
INTRRUPT;
begin
...
end;
begin
SetIntVec(中断号,@中断过程名);
keep(k);
end.
其中编译指令$M是Keep过程要求的，栈段的长度值为1024～65520，最大和最小堆长度经常都说明为0。
§1.5.1.2 暂驻型中断例程的框架
Program 程序名;
uses dos;
var
p : pointer;
...
procedure 中断过程名(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP : WORD);
INTRRUPT;
begin
...
end;
...
begin
GetIntVec(中断号,p);
SetIntVec(中断号,@中断过程名);
...
SetIntVec(中断号,p);
end.
在暂驻型程序中，在设置自己的中断向量之前，首先把系统原有的中断向量存放到有关的变量中，等到程序运行结束时，要把程序中所有重新定义过的中断向量恢复到系统原有的状态。否则程序返回操作系统后随时都会造成死机。
§1.5.2 设置中断向量、调用中断功能、程序驻留内存
在使用自己编写的中断例程的程序中，可用SetIntVec来设置自己的中断服务程序:
SetIntVec(IntNo,@IntHandle);
IntNo为中断号，@IntHandle为中断服务过程的地址。
在程序中可以使用Intr过程来调用自己的中断过程:
Intr(IntNo,Regs);
当用TURBO PASCAL编写的中断例程要驻留内存时，可以使用Keep过程来实现:
Keep(ExitCode);
§1.5.3 建立通讯数据区
由于中断例程的代码段地址可以从中断向量表中直接得到，用这个地址加上适当的地址偏移量，作为预定义内存数组Mem/MemW和MemL的下标，即可直接访问这些特定的内存单元，因此可以建立ISR的通讯数据区。
例如，为了防止同一个ISR在内存中重复驻留，应当设置一个"已驻留"的标志。如果在ISR最前面的过程的第一条语句中，把一条在驻留之前显示的屏幕提示，赋给一个动态串。通常这条提示串在显示完成后，其内容已不再需要，但可以通过引用内存数组元素MEMW[中断入口段地址:1]，对其中的内容加以比较，即可知道ISR是否驻留，新的ISR是否可以驻留。
§1.5.4 释放驻留内存
一个设计优秀的ISR，在撤离时，它所占用的内存也应该被释放。在用TURBO PASCAL 4.0或更高版本编译的程序中，有一个预定变量PrefixSeg，保存着该程序的程序段前缀PSP的起始段地址。把这个段地址作为调用参数送入ES寄存器之后，再调用INT 21H的49H号功能，即可把ISR自身占用的内存予以释放。
除了ISR自身占用的驻留内存空间外，DOS还为它另外分配了一块内存空间，作为它的环境块。其中存放着DOS环境参数的副本。虽然环境块不大，但它们同样也驻留着。在PSP的地址偏移量为2CH的位置上已经存放着上述环境块的段地址。将内存数组元素MEMW[Prefixseg:$2C]的值送入ES寄存器，再一次调用INT 21H的49H号功能，就能够把ISR的环境块也释放掉，从而回收ISR的全部驻留空间。
值得注意的是:如果在回收到的内存空间的高端地址处，还有其它未释放的驻留块，则已经回收的内存空间就会成为待用自由链中的“碎块”。这些碎块将会影响到以后的内存分配情况。在重新启动系统之前，其中的一部分有可能不能再次进行分配。因此在使用过程中应当先引导那些不需要撤换的ISR，需要反复撤换的ISR则放在最后引导。
此外，应当牢记:释放ISR的驻留内存之前，一定要恢复原来的中断向量，否则会造成系统混乱，导致死机或其它故障。
能够释放驻留内存，就可以在用户需要的时侯，任意调换不同的ISR，以满足各种不同的使用要求，并能随时保持较小的内存开销。
§1.5.5 程序实例
本程序(INTR.PAS)演示常驻型中断例程(ISR)的编写，并演示了怎样建立通讯数据区和程序的撤离方法，释放所有驻留内存。
{$M $1000,0,0}
program intrrupt_example;
uses dos;
const
MyMark:string[8] = 'MyInt500';
var
OldInt5,MyIntr5 : longint;
Mark : string[10];
reg : registers;
procedure First;
begin
Mark := 'MyInt500';
end;
procedure MyInt5(flags,cs,ip,ax,bx,cx,dx,si,di,ds,es,bp:word);
interrupt;
begin
inline($fa);
myintr5 := meml[0:5*4];
memw[0:5*4] := $a;
inline($fb);
if ax and $ff00 = $fe00 then
begin
inline($fa);
meml[0:4*5] := oldint5;
reg.es := prefixSeg;
reg.ah := $49;
msdos(reg);
reg.es := memw[PrefixSeg:$2c];
reg.ah := $49;
msdos(reg);
inline($fb);
end
else
begin
writeln('Call Interrupt 5');
inline($fa);
meml[0:5*4] := myintr5;
inline($fb);
end;
end;
procedure SetInt5;
begin
setIntvec($1b,saveint1b);
inline($fa);
OldInt5 := meml[0:4*5];
SetIntVec(5,@MyInt5);
mem[memw[0:4*5+2]:$a] := $cf;
inline($fb);
end;
function CheckInt5 : boolean;
var
i,j : word;
int5 : pointer;
begin
getIntVec(5,int5);
checkInt5 := true;
j := ofs(mark);
for i := 1 to 8 do
begin
if (chr(Mem[seg(int5^):i]) <> MyMark[i]) then
CheckInt5 := false;
end;
end;
procedure RemoveInt5;
begin
if CheckInt5 then
begin
reg.ah := $fe;
intr(5,reg);
writeln('Intrrupt 5 has been removed for memory');
end
else
writeln('Not find external Intrrrupt 5 routine');
end;
begin
first;
if paramcount = 0 then
begin
if CheckInt5 then
begin
writeln('Int 5 has kept');
halt(1);
end
else
begin
SetInt5;
keep(0);
end
end
else
if (paramstr(1) = 'R') or (paramstr(1) = 'r') then
RemoveInt5;
end.
§1.6 动态数组及其使用
§1.6.1 TURBO PASCAL的内存分配
TURBO PASCAL将计算机的可用内存划分为4个部分，如图1-2所示。代码段用于存放编译后程序指令；数据段用于存放程序和单元的常量和全程变量；栈段用于存放程序中过程和函数的局部变量；堆段用于存放程序的动态变量。
殌 ┌────┐← 最高可用内存
堆段 →│动态变量│↑向上分配
├────┤←
栈段 →│局部变量│
├────┤
数据段→│数据段 │
├────┤
代码段→│程序指令│
└────┘← 最低可用内存
殣
图1-2 TURBO PASCAL程序的内存分配图
堆空间是一个由用户控制的动态数据区域，它是利用指针变量在程序运行时动态分配的。也就是说，程序在编译时并不为指针变量在堆上分配空间，而在程序运行时，执行有关的语句时，才为其在堆上分配空间。堆的空间虽然能在0～640K之间变动，但在其中建立的每个动态变量的体积均不能大于65521字节。
§1.6.2 构造动态数组的方法
根据TURBO PASCAL对内存的管理方法，对总体积不大于64K的数组，可以直接在堆空间进行分配，在程序运行中构造动态数组。利用指针在堆中建立动态数组的步骤如下:
1.数组及其指针类型的说明
Type
IntArrPtr = ^IntArray;
IntArray = array[1..100] of integer;
2.指针变量的说明
Var IntArr : IntArrPtr;
3.申请内存
在使用动态数组之前，用New或GetMem过程在堆中分配内存空间，建立动态数组及它们的指针值。如:
GetMem(IntArr,Sizeof(IntArr^));
4.引用
在程序中按一般的TURBO PASCAL动态变量引用规则使用动态数组。如:
writeln(IntArr^[10]);
5.释放内存
动态数组使用完毕，立即用Dispose或FreeMem过程释放堆空间。如:
FreeMem(IntArrPtr,Sizeof(IntArr^));
下面的程序演示了上述方法，它在堆中建立了一个10000个元素的实型数组A。
program Dynamic_Array;
type
Arr1 = array[1..10000] of real;
var
A : ^arr1;
i : integer;
begin
GetMem(A,sizeof(a^));
for i := 1 to 10000 do a^[i] := i;
for i := 1 to 10000 do write(a^[i]:8:0);
FreeMem(A,sizeof(a^));
end.
§1.6.3 构造大于64K的数组
将整个大数组当做若干个小于64K的同类型、较低维数组的组合，在堆中建立这些子数组。然后，将这些子数组的指针以一个指针数组的形式组织起来。在形式上，该指针数组的数组名就是要定义的大数组的数组名，通过此名来统一引用该数组的各元素，从而达到能按通常的编程习惯在表达式中通过下标直接引用大数组的元素的目的。
下面的程序给出了如何具体应用上述方法的示例。它在堆中建立了一个8x100 x100的三维实数数组A，约占用480K内存。该数组被看成由8个100x100的二维子数组组成，因为每个子数组的体积为60000字节，故可用一动态数组表示。指向这8个子数组的8个指针组成了指针数组A。这样可通过A[i]^[j,k]引用上述三维数组的元素，不需要作任何下标变换，可直接参加表达式的运算，与静态数组的用法非常接近。从而保证了原来的程序设计风格，给程序的设计、编写、阅读、调试和修改都带来了方便。
program Huge_Array;
const
n = 100;
m = 8;
type
Arr2 = array[1..n,1..n] of real;
var
A : array[1..m] of ^Arr2;
i,j,k : integer;
begin
for i := 1 to m do GetMem(A[i],sizeof(a[i]^));
for i := 1 to m do
for j := 1 to n do
for k := 1 to n do
a[i]^[j,k] := 100*i + 10*j + k;
for i := 1 to m do
begin
for j := 1 to n do
begin
writeln('*****i=',i,',j=',j,'*****');
for k := 1 to n do write(a[i]^[j,k]:8:0);
writeln;
end;
writeln;
end;
for i := m downto 1 do FreeMem(A[i],sizeof(a[i]^));
end.
§1.6.4 动态可调数组的实现
当程序中要多次进行某种数组运算，如矩阵的转置、矩阵相乘或求解线性方程组时，程序员总希望把某种数组运算编写成一个通用过程，让过程中的数组是可调数组，即数组的维数和元素类型固定，每维的上下界可变。
动态可调数组的实现方法如下:
1.类型说明
按照所需的数组类型建立一个数组类型，为了达到数组规模可调，说明时不必给定数组各维的界限。如:
Type RealArray = array[1..1] of real;
2.变量说明
动态可调数组变量的说明和动态数组的说明一样，采用指针的形式。如:
var ra : ^RealArray;
3.动态可调数组的建立
当需要使用数组时，首先计算所有数组元素所占用的空间AraaySize的值，然后用New或GetMem分配ArraySize个字节的堆空间，用FillChar函数将此空间填入0，即完成数组的建立。
4.数组的引用
与动态数组的引用方法一样。
5.数组的撤消
为提高堆空间的利用率，数组用完后应及时将其撤消，其方法是利用Dispose或FreeMem函数释放分配给动态数组的堆空间。
下面的程序演示了上述方法，首先说明一个两维数组类型，数组的界限不定；然后说明一个具有此数组类型的指针变量；在程序开始，要求用户输入这个两维数组的各维的大小，接着计算数组的大小，申请堆空间，而后通过指针变量实用数组，最后撤消数组。
program Changable_Array;
Type
ArrayInt2 = array[1..1,1..1] of integer;
var
P : ^arrayInt2;
ArraySize : word;
I,j,n,m : integer;
begin
write('n = ');readln(n);
write('m = ');readln(m);
ArraySize := n * m * Sizeof(integer);
GetMem(p,ArraySize);
FillChar(p^,Arraysize,'0');
For i := 1 to n do
for j := 1 to m do
begin
randomize;
p^[i,j] := Random(j);
write(i:3,' ',p^[i,j]:5);
end;
FreeMem(p,ArraySize);
end.
§1.7 扩展内存
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 15:55:55
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第6楼
§1.7 扩展内存(EMS)及其使用
为了突破DOS管理640K自由内存空间的限制，1985年Lotus/Intel和Microsoft公司联合开发了一种扩展内存规范，简称LIM-EMS。它的主导思想是避开CPU模式切换的难题，采用了当时硬件上已相当成熟的“存储体切换”技术：将扩展内存卡插入机器的扩展槽，卡上的内存处于CPU的正常寻址空间之外；通过建立特定的映射关系由硬件将其以页面为单位重定位到CPU寻址空间中的某处，DOS程序中可以自由地改变这种映射关系，从而对整个扩展内存进行存取。这种用存储体开关技术扩展了的那部分内存空间称为扩展内存(Expanded Memory)。对扩展内存的管理由扩展内存管理程序EMM(Expanded Memory Manager)提供，具体是由INT 67H提供的。EMM 3.2支持最大为8MB的EMS内存，EMM 4.0则可支持16MB。
EMS技术在基于8088/80286的机器上得到了广泛的使用，绝大多数优秀的商业软件，如电子表格、CAD等等，都支持EMS规范。在用TURBO PASCAL编写的应用程序中如何使用EMS内存呢？可以设计一种通用的TURBO PASCAL使用EMS的程序单元(见§2.6)，应用程序使用此程序单元，即可使用扩展内存。下面阐述在程序中如何使用EMS。
§1.7.1 扩展内存的工作原理
使用扩展内存需要一块内存扩展卡。该卡由扩展内存管理器(EMM)软件来存取。计算机启动时，加载扩展内存管理软件，这需要在CONFIG.SYS文件中指定。
扩展内存管理软件把扩展内存卡上的存储器划分为16K的页。这样，2M的扩展内存相当于128个扩展内存页，但这些页不能同时使用。每次能够使用的扩展内存页数由页框的大小决定。
§1.7.2 扩展内存页框
PC机中8088/86微处理器能寻址1M字节，通常称为常规内存。然而在启动计算机时，DOS保留了很多内存(384K)自用，只为用户留下640K。扩展内存管理器在DOS保留的384K中划分出64K作为扩展内存页使用。
页框就好象是扩展内存的窗口。该窗口有4个16K的“窗口片”，每个片对应一页扩展内存。在使用一页扩展内存之前，先要把该页影射到或称移动到页框中。例如，如果想在扩展内存的0页中存储一些信息，就要把0页影射到页框中，然后把数据移动到页框中。
当程序要使用更多的扩展内存时，就需要将一些新的页移动到页框中。当将一页影射到页框中时，页框中原来的页就要被影射出去，也就是要保存在扩展内存中。当以后再把它移回页框时，其中的信息同移出去以前是一样的。
§1.7.3 逻辑页和物理页
同扩展内存相关的两个经常出现的术语是物理页和逻辑页。物理页是组成页框的4个页，其编号是0到3。而逻辑页是影射到页框中的扩展内存页。页框中的页是“物理”的，是因为可以直接往页框中存储数据，但不能直接向扩展内存的页传递数据。
§1.7.4 扩展内存句柄
在使用一个扩展内存页之前，要调用扩展内存管理器进行分配。可以申请最少1页，最多全部可用页。当扩展内存管理器满足申请分配页时，返回一个扩展内存句柄，即一个与所分配的页相关联的整数。
每个句柄有自己的一套扩展内存页。例如，句柄可以分配3页，编号为0到2。同时，另一个句柄可能有5页，编号为0到4。
§1.7.5 扩展内存功能
使用扩展内存功能与使用DOS和BIOS中断服务一样。扩展内存管理软件在装入内存时，占用中断67H。所有扩展内存服务均通过该中断完成。
扩展内存管理器几经修改，其最新版本是4.0版，它提供了30个扩展内存服务，其中只有15个在旧的版本中能工作。而在这15个中，又只有少数几个为大多数扩展内存程序所必需。表1-3列出了最常用的扩展内存服务。
表1-3.最常用的扩展内存服务
殔 ┌───┬──────┬───────────────────┐
│ 功能│描述 │ 说 明 │
├───┼──────┼───────────────────┤
│ 40H │取EMM状态 │ 确定是否加载了扩展内存管理程序和 │
│ │ │ 正常工作。结果返回在AH寄存器中， │
│ │ │ 0表示安装了EMM并且没有检测到硬件 │
│ │ │ 错误 │
│ 41H │取页框地址 │ 取页框段地址在BX中。如果AH不等于 │
│ │ │ 0，则BX中的值无效 │
│ 42H │取未分配页数│ 得到计算机中扩展内存总页数(在DX │
│ │ │ 中)和程序可用页数(在BX中) │
│ 43H │分配内存 │ 通知EMM程序分配扩展内存，供用户程 │
│ │ │ 序使用。BX中放需要的页数。EMM中 │
│ │ │ 断返回时将句柄放在DX中。 │
│ 44H │影射内存 │ 将一个扩展内存页(BX指定)影射到一 │
│ │ │ 个页框中的页(由AL指定)。EMM页句 │
│ │ │ 柄由DX指定 │
│ 45H │释放内存 │ 释放一个EMM句柄(DX指定)的所有页。 │
│ │ │ 一旦释放，这些页就可以再分配给一 │
│ │ │ 个新的句柄。 │
│ 46H │取EMM版本 │ 返回当前所用EMM版本。返回时，AL中 │
│ │ │ 高4位是主版本号，低4位是版本的小 │
│ │ │ 数部分。 │
└───┴──────┴───────────────────┘
殣
§1.7.6 判断扩展内存是否安装
扩展内存服务40H，报告是否加载了扩展内存管理器以及硬件功能是否正常。用户可能会用这一功能确定运行程序的计算机是否安装了扩展内存，然而这是错误的，因为只有在安装了扩展内存管理器后才能使用40H号服务。如果在没有扩展内存的情况下使用40H号服务程序，计算机可能会死锁。
那么40H号服务是干什么的?而且怎样知道计算机中是否安装了扩展内存?第一个问题的答案很简单，要时检测扩展内存是否在正常工作。40H服务能提供这种周期性的状态报告。
DOS的35H号功能用来取某一中断程序的入口地址，调用它可以确定是否安装了扩展内存。该服务程序返回指定中断的中断服务程序的段地址(ES)和偏移地址(BX)。因为EMM使用中断67H，因此，如果安装了EMM的话，这一DOS调用会返回EMM的入口地址。
如果在系统启动时装入了扩展内存管理程序(EMM)，在内存中的一个固定地址就会存放一个字符串──“EMMXXXXX0”。该地址为EMM所在段，偏移量为0AH处。
DOS服务35H返回EMM段地址在ES中，偏移量在BX中。看一下在内存ES:000AH处的内容，就可以判断是否安装了EMM。如果ES:000AH处是字符串“EMMXXXXX0”，那么就安装了EMM，否则就没有安装这一管理软件。检测EMM是否存在的程序段如下:
; 检测EMM是否存在
;
mov ax,3567h
int 21h
mov di,10
push cs
pop ds
mov si,offset DevName
mov cx,8
rep cmpsb
;
DevName DB 'EMMXXXX0'
;
§1.8 扩充内存(XMS)及其使用
EMS技术在基于8088/80286的机器上得到了广泛的使用，但是几乎没有一台386机上会装扩展内存卡，因为386芯片与286不同，它的内存管理功能更为强大，模式切换也非常方便，它的页式管理功能可以很容易把内存映射到任何地址；另外386数据总线为32位，32位的内存卡的存取速度要比16位的EMS卡快，而且价格便宜；因此在386机上由软件利用扩充内存(XMS)仿真扩展内存(EMS)就十分划得来。
扩充内存(Extended Memory)是指物理地址位于1MB(100000H)以上的那部分内存，它只适用于配备80286以上档次的CPU的机器上。如果应用程序使用扩充内存，不仅运行速度快，而且效率高。通常，在80386和80486系统中，MS-DOS还提供了EMM386.EXE程序，使扩充内存仿真扩展内存。
在MS-DOS 4.0及WINDOWS 3.0中，提供了一个名为HIMEM.SYS的扩充内存管理程序XMM(Extended Memory Manager)，它是按照Lotus/Intel/Microsoft/AST的扩充内存管理规范2.0版本编制的，使得应用程序对扩充内存的使用变得非常方便。HIMEM.SYS是一个设备驱动程序，可以在系统配置文件(CONFIG.SYS)中用DEVICE命令加以说明，在机器启动时便可装入。
XMS的使用通过INT 2FH的43H子功能提供管理。下面具体介绍XMS管理功能和使用方法。
§1.8.1 扩充内存管理规范(XMS)简介
扩充内存管理规范(XMS)是Lotus/Intel/Microsoft/AST公司的合作成果。它为286/386微机定义了一个软件接口，可以允许实模式程序以一种与硬件无关的方式使用扩充内存。如果不同厂商开发的程序按照这种协议来申请扩充内存，那么它们之间就能和平共处，不会发生冲突。
XMS规范定义了3种内存块的申请、修改和释放功能：
. 上位内存块(UMB)：地址位于640K和1024K之间
. 高内存区 (HMA)：地址位于1024K和1088K之间
. 扩充内存块(EMB)：地址位于1088K以上
这3部分的关系如图1-3所示。
殌 ────┬────────┐16MB/4GB
↑ │EMB(扩充内存块) │
扩充内存├────────┤1MB+64KB
↓ │HMA(高内存区) │
────┼────────┤1MB
↑ │ROM BIOS │
│ ├────────┤
│ │UMB(上位内存块) │
│ ├────────┤
│ │EMS页框地址 │
├────────┤
传统内存│外设口地址 │
├────────┤
│ │视频刷新缓冲区 │
│ ├────────┤640KB
│ │ 常规内存 │
│ │----------------│
↓ │ MS DOS内核 │
────┴────────┘0KB
殣
图1-3 286/386/486内存映象图
所以扩充内存是指80X86机器1MB寻址空间之外的内存。在扩充内存规范中，扩充内存也指高内存区(HMA)和上位内存块(UMB)。
UMB是指在DOS内存640KB和1MB之间的内存。在DOS5.0以前，程序员只有通过XMS驱动程序才能使用这一区域，从DOS 5.0开始，可以通过DOS内存服务来访问UMB。实际上DOS内存服务例程代为访问了XMS驱动程序。
HMA的存在比较特殊。当CPU运行在实模式并且第21条地址线(A20)处于激活状态时，CPU就可以访问一块65520B的内存(64K少16B)，这块内存就叫HMA。HMA的存在与CPU的寻址方式有关。CPU根据段地址：偏移地址来寻址，首先将段地址乘以16，再加上偏移地址，形成物理地址。如果此值超过20位，则截去其高位，使物理地址在000000H-0FFFFFH之间。如果A20线不激活，地址0FFFF:0010H就是物理地址000000H；若A20线激活，0FFFF:0010H就是物理地址010000:0000H，这样就有了额外的65520B的内存。也就是说地址0FFFF:0010H-0FFFF:0FFFFH通常映象到物理地址000000H-00FFFFH，当A20激活后，映象到的物理地址就为010000H-010FFEFH。
XMS驱动程序提供了五组功能：驱动程序信息、HMA管理、A20地址线管理、扩充内存管理和上位内存块管理。另外的两个功能是检查XMS驱动程序是否存在和XMS驱动程序控制功能的地址。表1-4给出了XMS功能调用。
§1.8.2 XMS的使用
使用扩充内存，需要判定扩充内存是否可用。首先执行如下代码，判定XMS程序是否存在。
MOV AX，4300H
INT 2FH
CMP AL，80H
JNE XMS_NOTPRESENT
; XMS IS PRESENT
如果存在，再取XMS驱动程序控制功能的地址，用如下的代码段即可完成此功能。
;
XMS_CONTROL DD (?)
;
MOV AX，4310H
INT 2FH
MOV WORD PTR [XMS_CONTROL]，BX
MOV WORD PTR [XMS_CONTROL]，ES
;
之后，就可以用远调用的方式来使用XMM提供的功能了。如执行取EMM版本号功能的程序如下:
;
mov ah,0
call XMS_control
;
表1-4.XMS的功能调用
殔┌──────┬───┬──────────┐
│ 功 能 │功能号│ 描 述 │
├──────┼───┼──────────┤
│驱动程序信息│ 0 │ 取XMS版本号 │
├──────┼───┼──────────┤
│管理高内存区│ 1 │ 请求高内存区HMA │
│ (HMA) │ 2 │ 释放高内存区HMA │
├──────┼───┼──────────┤
│ 操纵 │ 3 │ 全程启用A20 │
│ │ 4 │ 全程停用A20 │
│ A20 │ 5 │ 局部启用A20 │
│ │ 6 │ 局部停用A20 │
│ 地址线 │ 7 │ 查询A20的状态 │
├──────┼───┼──────────┤
│ │ 8 │ 查询自由扩充内存 │
│ 管理 │ 9 │ 分配扩充内存块 │
│ │ AH │ 释放扩充内存块 │
│ │ BH │ 移动扩充内存块 │
│ 扩充内存块 │ CH │ 锁住扩充内存块 │
│ │ DH │ 解锁扩充内存块 │
│ │ EH │ 取EMB句柄信息 │
│ (EMBs) │ FH │ 重新分配扩充内存块 │
├──────┼───┼──────────┤
│ 管理 │ 10H │ 请求上位内存块UMB │
│ 上位内存块 │ 11H │ 释放上位内存块UMB │
└──────┴───┴──────────┘
殣
§1.8.3 扩充内存管理功能
1.取版本号
入口参数：AH=00H
出口参数：AX=二进制版本号；BX=内部XMM版本；DX=1，存在HMA
2.请求高存区(HMA)
入口参数：AH=01H；DX=请求长度
出口参数：AX=1，HMA分配成功；否则BL返回错误码,错误码见表1-5
3.释放高存区(HMA)
入口参数：AH=02H
出口参数：AX=1，HMA释放成功；否则BL返回错误码
4.全程打开A20
入口参数：AH=03H
出口参数：AX=1，A20已激活；否则BL返回错误码
5.全程关闭A20
入口参数：AH=04H
出口参数：AX=1，A20已关闭；否则BL返回错误码
6.局部打开A20
入口参数：AH=05H
出口参数：AX=1，A20已激活；否则BL返回错误码
7.局部关闭A20
入口参数：AH=06H
出口参数：AX=1，A20已关闭；否则BL返回错误码
8.查询A20状态
入口参数：AH=07H
出口参数：AX=1，A20已激活
9.查询自由扩充内存大小
入口参数：AH=08H
出口参数：AX=最大扩充内存块的长度(KB)，DX=自由扩充内存总数(KB)，BL=错误码
这里查到的扩充内存总数是系统中实际安装的扩充内存数减去HMA的内存数。
10.分配扩充内存块
入口参数：AH=09H
出口参数：AX=1，分配成功；DX=扩充内存块句柄；BL=错误码
扩充内存的管理是通过扩充内存控制块来实现，扩充内存控制块的数据结构如下：
DB 标志(01：自由块；02：分配块；04空闲块) DW 内存块始址 (KB)
DB 加锁标志(0 ： 加锁；非0 ： 解锁) DW 内存块长度 (KB)
扩充内存控制块的地址称为扩充内存块句柄。从数据结构中可以看出，扩充内存最基本的管理单位是1KB，即最大可存取的物理地址为128MB。扩充内存控制块的数量即句柄的数量可在系统配置文件中说明，默认值为21，最大值为128，即最多可使用的内存块是128个。
11.释放扩充内存块
入口参数：AH=0AH，DX=扩充内存块句柄
出口参数：AX=1，扩充内存块已释放；否则BL=错误码
12.移动扩充内存块
入口参数：AH=0BH，DS：SI=参数表地址
出口参数：AX=1，移动成功；BL=错误码
本功能可以在常规内存和扩充内存之间双向传送数据。DS：SI所指参数表的格式：
DD 传送长度(必须是偶数) DW 目标块句柄
DW 源块句柄 DD 目标块内偏移
DD 源块内偏移
其中当句柄为0时，则相应的偏移量以SEGMENT：OFFSET的形式表示，数据由BL返回错误码。
13.扩充内存块加锁
入口参数：AH=0CH；DX=句柄
出口参数：AX=1，加锁成功；DX：BX=32位加锁的内存地址；否则BL=错误码
14.扩充内存块开锁
入口参数：AH=0DH；DX=句柄
出口参数：AX=1，开锁成功；否则BL=错误码
15.取扩充内存控制块句柄信息
入口参数：AH=0EH；DX=句柄
出口参数：AX=1，信息块已获得；BH=加锁信息；BL=自由句柄数；DX=内存块长度(KB)；否则BL=错误码
16.重新分配扩充内存
入口参数：AH=0FH；DX=句柄；BX=新的长度(KB)
出口参数：AX=1，重分配成功；否则BL=错误码
表1-5.XMM错误码一览表
殔┏━━━┯━━━━━━━━━━━━┳━━━┯━━━━━━━━━━━━━┓
┃错误码│ 含义 ┃错误码│ 含义 ┃
┠───┼────────────╂───┼─────────────┨
┃ 80H │ 功能未实现 ┃ 91H │ HMA已使用 ┃
┃ 81H │ 已安装虚拟盘 ┃ 92H │ 请求长度小于最小请求长度 ┃
┃ 82H │ A20地址线处理错 ┃ 93H │ HMA未使用 ┃
┃ 8EH │ 一般驱动程序错 ┃ A0H │ 无自由扩充内存 ┃
┃ 90H │ 不存在HMA ┃ A1H │ 无扩充内存句柄可用 ┃
┃ A2H │ 扩充内存控制块句柄无效 ┃ A8H │ 传送时有无效的地址重叠 ┃
┃ A3H │ 源句柄无效 ┃ A9H │ 奇偶校验错 ┃
┃ A4H │ 源偏移量无效 ┃ AAH │ 内存块已解锁 ┃
┃ A5H │ 目标句柄无效 ┃ ABH │ 内存块已加锁 ┃
┃ A6H │ 目标偏移量无效 ┃ ACH │ 加锁内存块数已溢出 ┃
┃ A7H │ 传递长度无效 ┃ ADH │ 不能加锁内存块 ┃
┗━━━┷━━━━━━━━━━━━┻━━━┷━━━━━━━━━━━━━┛
殣
§1.9 程序的标准数据作代码处理的方法
很多程序在开始运行时，要把一些标准的数据文件读到内存中。这些数据文件包含一些不变的信息，如字库和特殊的表。TURBO PASCAL使用程序BINOBJ能使用户直接把这些数据放在程序中，避免等到程序运行时再读取。
用BINOBJ把数据装入程序需要3步:
. 创建数据文件；
. 用BINOBJ将数据文件转换为.OBJ文件；
. 在程序中将数据文件作为外部过程引用。
把数据文件作为外部过程看待，成为程序的一部分，才能在程序启动时就自动装入内存。这样做有如下优点:首先，由于不需要打开和读取文件，加快了程序运行速度；其次，如果程序作为商品出卖，则可以减少磁盘文件数目；其三，增加了程序的保密性。
§1.9.1 创建数据文件
在用BINOBJ之前，要有一个准备好的二进制数据文件。下面的过程产生一个含有1到100的自然数及其自然对数的二进制数据文件。该文件的结构由数组类型LogArray定义。
Program MakeBinaryDataFile;
Type
LogArrayPtr = ^LogArray;
LogArray = Array[1..100] of Record
I : Integer;
LnI : Real;
End;
Var
I : Integer;
LogA : LogArrayPtr;
F : File of LogArray;
begin
GetMem(LogA,sizeof(LogA^));
for i := 1 to 100 do
begin
LogA^[i].I := I;
LogA^[i].LnI := ln(i);
end;
Assign(f,'LogData.bin');
Rewrite(f);
Write(f,Loga^);
close(f);
end.
该程序产生的LOGDATA.BIN二进制数据文件可作为BINOBJ的输入文件，因文件具有LogArray类型，所以在程序中存取这些作为外部过程的数据时，必须采用相同的数据类型。
§1.9.2 转换数据文件
用BINOBJ把二进制数据文件转换为目标文件(.OBJ)。
使用BINOBJ的一般格式是:
BINOBJ <源文件名.BIN> <目标文件名[.OBJ]> <公用数据名>
源文件是二进制数据文件，BINOBJ不能自动加.BIN，所以使用时要写上数据文件的扩展名。目标文件是BINOBJ产生的输出文件，如果不指定该文件的扩展名，BINOBJ会把标准的扩展名(.OBJ)加上。最后，公用数据名是在访问这些数据时所用的过程名。
用BINOBJ把上述程序产生的数据文件LOGDATA.BIN生成目标文件。
BINOBJ LOGDATA.BIN LOGDATA LOGDAT
§1.9.3 访问外部过程
将产生的数据文件转换为目标文件后，就可以连接到程序中。实现的一般形式是:
Procedure <公用数据名>; erternal;
{$L 目标文件名.OBJ}
过程名和运行BINOBJ的公用数据名相同。{$L}编译指令使用的名字与BINOBJ使用的目标文件名相同。所以，要使用上面生成的数据文件，必须在程序中作如下的声明:
Procedure LogDat; external;
{$L LOGDATA.OBJ}
在运行TURBO PASCAL编译程序时，LOGDATA.OBJ被连接到程序中，相应的数据放在LogDat指明的地址上。
访问存储在代码中的这些数据很简单，首先，声明一个与创建的数据文件相同数据类型的指针变量；其次，将指针变量指向存储这些数据的代码。
下面举例说明如何访问存储在LOGDATA.OBJ中的数据:
Program TestBin;
Type
LogArrayPtr = ^LogArray;
LogArray = Array[1..100] of Record
I : Integer;
LnI : Real;
End;
Var
I : Integer;
LogA : LogArrayPtr;
procedure LogDat; external;
{$L LOGDATA.OBJ}
begin
LogA := @LogDat;
for i := 1 to 100 do
begin
Write(LogA^[i].I);
writeln(LogA^[i].LnI:10:4);
end;
end.
LogA是与所创建的数据文件有相同的数据类型的指针变量。在运行时，LogA通过这个语句指向所连接的数据:
LogA := @LogDat;
这个语句取出LogDat的地址，赋给LogA。这样就可以访问LogA中的所有数据，就象在堆中动态分配来的一样。
注意，LogA没有申请任何内存，因为是在代码段中。不要试图释放LogA或其它任何指向代码段的指针。
虽然利用BINOBJ把数据存放在代码是个有效的方法，但是它也具有一些弊端。假设数据存放在程序的代码段，如果数据文件很大，则代码会超过64K限制，且数据在程序启动后永远保存在内存中，无法象在堆上申请空间一样释放。另外，如果修改数据文件，就必须重新运行BINOBJ，并编译程序。
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 15:56:22
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第7楼
第二章 实用工具单元
作者在长期使用TURBO PASCAL编程的过程中积累了许多实用的PASCAL过程和函数，并归并为几类TURBO PASCAL程序单元，这些单元大多是用TURBO PASCAL和TURBO汇编混合编程的，既具有很高的实用价值，又具有学习TURBO PASCAL编程技术的作用，现把它们奉献给广大读者。这些程序单元包括：屏幕输入输出单元ACRT，字符串处理单元ASRT，磁盘输入输出单元DISK，热键(Hotkey)单元POPUP，数据库交互单元DBASE、扩展内存使用单元EMS、扩充内存使用单元XMS、数学函数单元MATH，矩阵运算单元MATRIX、概率分布单元PROB和复数运算单元COMPLEX。这些单元适合于TURBO PASCAL 4.0及以上的各种TURBO PASCAL版本，对TURBO PASCAL 6.0及以上版本可以将汇编程序改写为内嵌式汇编，这里为方便TURBO PASCAL 6.0以下的读者，提供了独立的TURBO汇编源程序。读者可以将这些单元直接编译后使用，也可以根据需要扩充修改，同时可以从中学习TURBO PASCAL与汇编语言混合编程的方法、编写DOS中断例程的方法、过程或函数作为参数传递的方法等TURBO PASCAL的高级用法。
§2.1 屏幕输入输出单元ACRT
屏幕输入输出单元是与显示器有关的一些过程和函数的集合，包括有设置光标大小、设置和获取显示页、设置和获取显示模态、打开和关闭电子钟等12个过程和函数，它是对TURBO PASCAL的CRT单元的扩展和补充。
ACRT单元的一部分是用TURBO ASSEMBLER编写的，其代码在ACRT.ASM中，其余代码在ACRT.PAS中，汇编程序可以使用TASM的各种版本汇编为目标文件(.OBJ)，供TURBO PASCAL编译器使用。下面介绍ACRT单元的12个过程和函数的用法。
§2.1.1 ACRT的函数和过程
1.CrtType函数
功 能 返回计算机显示器的类型
用 法 CrtType
结果类型 字符型
返 回 值 'M'代表单色显示器，'C'代表彩色显示器
2.SetCursor过程
功 能 设置光标的大小
用 法 SetCursor(t:byte)
说 明 t是字节型值参，可取0，1，2三个值，t=0时光标消失，t=1时为小光标，t=2为大光标。
3.SetCrtMode过程
功 能 把显示器设置为不同的显示模态，如文本或图形
用 法 SetCrtMode(i:byte)
说 明 i可以取显示器可识别的各种模态，MDA为7，CGA为0-6，EGA为0-16， VGA为0-19，如附录2。用此过程可以在使用CRT的同时,在屏幕上显示汉字!
4.GetCrtMode函数
功 能 获取显示器模态值
用 法 GetCrtMode
结果类型 字节型
说 明 返回显示器的当前显示模态，见附录2。
返 回 值 返回显示模态值
5.SetVPage过程
功 能 设置一显示页为当前显示页
用 法 SetVPage(i:byte)
说 明 i可取显示卡可接受的值，对CGA为0-1，对EGA和VGA为0-3
6.GetVPage函数
功 能 获取当前显示页号
用 法 GetVPage
结果类型 字节型
返 回 值 返回显示页号值
7.OpenClock过程
功 能 在屏幕右上角显示一个电子钟
用 法 OpenClock(TA:byte)
说 明 TA代表文本显示属性，可取0-255之间的值
8.CloseClock过程
功 能 关闭屏幕右上角的电子钟
用 法 CloseClock
9.WriteXY过程
功 能 在屏幕上指定位置按给定的属性写字符串
用 法 WriteXY(x,y,TA : word; s: string)
说 明 x为行值，y为列值，TA为文本属性，s为待显示的字符串
10.YesNo函数
功 能 向用户提出一个是否(Yes、No)的问题
用 法 YesNo(s:string)
结果类型 布尔型
说 明 s代表提问内容字符串
返 回 值 True或False
11.LargeChar过程
功 能 显示一个放大了的字符
用 法 LargeChar(x,y,ch,bc,fc : integer)
说 明 x为屏幕行值，y屏幕列值，ch为待显示的字符的ASCII码值，bc为屏幕背景色，fc为屏幕前景色
12.ReBoot过程
功 能 重新启动计算机
用 法 Reboot
§2.1.2 ACRT的使用
ACRTDEMO.PAS演示了ACRT中部分过程和函数的用法。过程ClockDemo演示了两个电子钟过程的使用，VPageDemo演示了设置显示页过程的用法，DisplayLargeChar演示了在屏幕上显示大型ASCII字符过程LargeChar的用法。
§2.1.3 源程序清单
程序1:ACRT.PAS
{************************************}
{ UNIT : ACRT }
{ Advanced CRT Interface Unit }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{************************************}
unit ACRT;
{$D-,S-}
interface
uses Crt;
function CrtType:Char;
procedure OpenClock(TA:byte);{ Display a clock on screen }
procedure CloseClock; { Remove the clock }
procedure SetCursor(t:byte);{ Set current cursor routine }
procedure SetVPage(i:byte);
function GetVPage:byte;
procedure SetCrtMode(i:byte);
function GetCrtMode:byte;
procedure LargeChar(x,y,Ch,bc,fc:integer);
procedure WriteXY(x,y,TA:word;S:string);
function YesNo(s:string):boolean;
procedure reboot;
inline($EA/$00/$00/$FF/$FF); { jmp FFFF:0000 }
implementation
{$L ACRT}
function CrtType;
external {ACRT};
procedure OpenClock(TA:byte);
external {ACRT};
procedure CloseClock;
external {ACRT};
procedure SetCursor;
external {ACRT};
procedure SetVPage;
external {ACRT};
function GetVPage;
external {ACRT};
procedure SetCrtMode;
external {ACRT};
function GetCrtMode;
external {ACRT};
procedure LargeChar;
const UsedChar = 219;
type ROMChar = array[1..8] of byte;
var CharTable : array[0..255] of ROMChar absolute $f000:$Fa6e;
i,j,OldAttr : integer;
Pattern : ROMChar;
begin
OldAttr := TextAttr;
TextAttr := bc * 16 + fc;
Pattern := CharTable[Ch];
for i := 1 to 8 do
for j := 7 downto 0 do
begin
GotoXY(x-1+8-j,y-1+i);
if (odd(Pattern[i] shr j )) then write(chr(UsedChar));
end;
TextAttr := OldAttr;
end;
procedure WriteXY;
begin
GotoXY(x,y);
TextAttr := TA;
Write(S);
end;
function YesNo(s:string):boolean;
var ch : char;
str: string[1];
begin
str := '';
YesNo := false;
write(s,' (Y/N)?');
readln(str);
ch := str[1];
if ch in ['y','Y'] then YesNo := true;
end;
end.
程序2:ACRT.ASM
; ACRT.ASM
; Assembler include file for ACRT.PAS unit
TITLE ACRT
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; procedure SetVPage;
PUBLIC SetVPage
SetVPage:
PUSH BP
MOV BP,SP
MOV AX,[BP+6]
MOV AH,5
INT 10H
POP BP
RETF 2
; function GetVPage;
PUBLIC GetVPage
GetVPage:
MOV AX,40H
PUSH AX
POP ES
MOV AL,BYTE PTR ES:[62H]
MOV AH,00
RETF
; procedure SetCrtMode;
PUBLIC SetCrtMode
SetCrtMode:
PUSH BP
MOV BP,SP
MOV AL,[BP+6]
MOV AH,0
INT 10H
POP BP
RETF 2
; function GetCrtMode;
PUBLIC GetCrtMode
GetCrtMode:
MOV AX,40H
PUSH AX
POP ES
MOV AL,BYTE PTR ES:[49H]
MOV AH,00
RETF
; function CrtType:byte;
PUBLIC CrtType
CrtType:
MOV AX,40H
PUSH AX
POP ES
CMP BYTE PTR ES:[49H],7
JZ @@1
MOV AL,'C' ; Color
JMP @@2
@@1: MOV AL,'M' ; Monochrome
@@2: MOV AH,00
RETF
; procedure SetCursor(T:byte);
; T=0 No Cursor
; T=1 Small Cursor
; T=2 Big Cursor
PUBLIC SetCursor
SetCursor:
PUSH BP
MOV BP,SP
MOV AX,40H
PUSH AX
POP ES
MOV BX,[BP+6]
CMP BYTE PTR ES:[49H],7
JE @@1
CMP BL,02
JE @@2
CMP BL,01
JE @@3
JMP @@6
@@1: CMP BL,02
JE @@4
CMP BL,01
JE @@3
@@6: MOV CX,2000H
JMP @@7
@@3: MOV CX,0001H
JMP @@7
@@2: MOV CX,0007H
JMP @@7
@@4: MOV CX,000CH
@@7: MOV ES:[60H],CX
POP BP
RETF 2
; Int 1CH
Int1C:
PUSH ES
PUSH DS
PUSH DX
PUSH CX
PUSH AX
JMP @@3
OS DB 00H
TA DB 79H
@@3: MOV AH,02
INT 1AH
MOV AL,DH
CALL Bcd2DecAscii
CMP CS:OS,AL
JE @@2
PUSH AX
MOV AX,40H
PUSH AX
POP ES
MOV AX,0B000H
CMP BYTE PTR ES:[49H],7
JE @@1
MOV AX,0B800H
@@1: MOV DS,AX
POP AX
MOV DL,CS:TA
MOV CS:OS,AL
MOV BYTE PTR DS:[159],DL
MOV BYTE PTR DS:[158],AL
MOV BYTE PTR DS:[157],DL
MOV BYTE PTR DS:[156],AH
MOV AL,CL
CALL Bcd2DecAscii
MOV BYTE PTR DS:[155],DL
MOV BYTE PTR DS:[154],':'
MOV BYTE PTR DS:[153],DL
MOV BYTE PTR DS:[152],AL
MOV BYTE PTR DS:[151],DL
MOV BYTE PTR DS:[150],AH
MOV AL,CH
CALL Bcd2DecAscii
MOV BYTE PTR DS:[149],DL
MOV BYTE PTR DS:[148],':'
MOV BYTE PTR DS:[147],DL
MOV BYTE PTR DS:[146],AL
MOV BYTE PTR DS:[145],DL
MOV BYTE PTR DS:[144],AH
@@2:
POP AX
POP CX
POP DX
POP DS
POP ES
IRET
; Translate BCD Code to Decimal ASCII Code
; IN AL BCD Code
; OUT AX Decimal ASCII CODE
Bcd2DecAscii:
PUSH CX
MOV CH,AL
AND CH,0FH
MOV AH,CH
ADD AH,30H
MOV CL,4
SHR AL,CL
ADD AL,30H
XCHG AH,AL
POP CX
RET
; procedure OpenClock(TA:byte);
; procedure CloseClock;
PUBLIC OpenClock
PUBLIC CloseClock
Int1cSeg DW 0000h
InT1cOffset DW 0000h
OpenClock:
PUSH BP
MOV BP,SP
MOV CX,[BP+6]
MOV CS:TA,CL
SUB AX,AX
MOV ES,AX
MOV AX,ES:[70H]
MOV CS:Int1cOffset,AX
MOV AX,ES:[72H]
MOV CS:Int1cSeg,AX
MOV AX,OFFSET Int1C
MOV BX,SEG Int1C
CLI
MOV ES:[70H],AX
MOV ES:[72H],BX
STI
POP BP
RETF 2
CloseClock:
SUB AX,AX
MOV ES,AX
MOV AX,CS:Int1cOffset
CMP AX,0000H
JE @@1
CLI
MOV ES:[70H],AX
MOV AX,CS:Int1cSeg
MOV ES:[72H],AX
STI
@@1: RETF
END
程序3:ACRTDEMO.PAS
{-----------------------------------}
{ ACRTDEMO.PAS }
{ Demonstrates the usage of ACRT }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{-----------------------------------}
program ACrtDemo;
uses Crt,ACrt;
procedure ClockDemo(disp:boolean);
begin
if disp then OpenClock(12)
else CloseClock;
end;
procedure VPageDemo;
var i : integer;
begin
for i := 1 to 3 do
begin
setvpage(i);
delay(2000);
end;
setvpage(0);
end;
procedure DisplayLargeChar;
var i,j : integer;
begin
for i := 1 to 4 do
begin
clrscr;
writeln(i);
LargeChar(10,10,65,1,10+i*2);
LargeChar(20,10,66,1,14+i*2);
LargeChar(30,10,67,1,15+i*2);
for j := 1 to $1000 do
move(mem[$B800:j],mem[$B800 + i*$100:j],1);
end;
end;
begin
clrscr;
ClockDemo(true);
DisplayLargeChar;
VPageDemo;
ClockDemo(false);
clrscr;
end.
§2.2 字符串处理单元ASTR
字符串处理单元ASTR是专门处理与字符串有关的过程和函数的集合，包括十六进制数字串、以特定字符填充字符串、数字转字符串、日期和时间字符串、生成空格串、字符串的大小写转换等。它是TURBO PASCAL字符串功能的有益补充。
ASTR单元是用TURBO PASCAL和TURBO汇编混合编程的，代码分别存放在ASTR.PAS和ASTR.ASM中，ASTR.ASM可用TASM汇编为目标文件(.OBJ)，供TURBO PASCAL编译器使用。下面介绍10个函数的功能和调用方法。
§2.2.1 ASTR的函数和过程
1.HexStr函数
功 能 把给定变量的内容转换成十六进制字符串
用 法 HexStr(var Num; ByteCount: Byte)
结果类型 字符串类型
说 明 Num为待转换成十六进制串的变量，可以是字节整数、字型整数、有符号整数、长整数、字符、字符串等。ByteCount为待转换变量的字节数。
返 回 值 十六进制字符串
2.FillCharToStr函数
功 能 按指定字符填充指定长度的字符串
用 法 FillCharToStr(Len: Byte; Ch: Char)
结果类型 字符串类型
说 明 Len为字符串的长度;Ch为指定的字符
返 回 值 一定长度的指定字符的字符串
3.WordToStr函数
功 能 把给定的字型整数转换为指定长度的字符串
用 法 WordToStr(Num : Word; Len: Byte)
结果类型 字符串类型
说 明 Num为字型整数；Len为待生成的字符串的长度
返 回 值 指定长度的字型整数串
4.IntToStr函数
功 能 把给定的整型数转换为指定长度的字符串
用 法 IntToStr(Num: Integer; Len: Byte)
结果类型 字符串类型
说 明 Num为整型数；Len为待生成的字符串的长度
返 回 值 指定长度的整型数串
5.实型数字符串函数RealToStr
功 能 把给定的实型数转换为指定格式的字符串
用 法 RealToStr(Num: Real; Len, Places: Byte)
结果类型 字符串类型
说 明 Num为实型数；Len为待生成的字符串的长度；Places为小数位数
返 回 值 指定格式的实型数字符串
6.DateStr函数
功 能 生成当前日期的字符串
用 法 DateStr
结果类型 字符串类型
返 回 值 当前日期的字符串，格式为"Sunday July 17, 1994"
7.TimeStr函数
功 能 生成当前时间的字符串
用 法 TimeStr
结果类型 字符串类型
返 回 值 当前时间的字符串，格式为"2:20 PM"
8.Space函数
功 能 生成指定长度的空格字符串
用 法 Space(Len : Byte)
结果类型 字符串类型
说 明 Len为待生成字符串的长度
返 回 值 指定长度的空格字符串
9.UpperStr函数
功 能 把给定的字符串转换为大写字符串
用 法 UpperStr(var S : string)
结果类型 字符串类型
说 明 S为源字符串,变量
返 回 值 大写的字符串
10.LowerStr函数
功 能 把给定的字符串转换为小写字符串
用 法 LowerStr(var S : string)
结果类型 字符串类型
说 明 S为源字符串,变量
返 回 值 小写的字符串
§2.2.2 ASTR的使用
ASTRDEMO.PAS演示了ASTR中部分过程和函数的用法。UpLowDemo演示了UpperStr和LowerStr函数的用法，它把26个大写字母转换为相应的小写字母，HexStrDemo演示了HexStr函数的用法，它自动生成ASCII码全集的十进制和十六进制字符串，并显示到屏幕上，DateTimeDemo演示了DateStr和TimeSTr函数，把当前的日期和时间以直观的形式显示到屏幕上。
§2.2.3 源程序清单
程序1：ASTR.PAS
{*****************************************}
{ UNIT : ASTR }
{ Advanced String Interface Unit }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{*****************************************}
Unit ASTR;
{$D-,S-}
interface
uses dos;
Function HexStr(var Num; ByteCount: Byte) : String;
Function FillCharToStr(Len: Byte; Ch: Char) : String;
Function WordToStr(Num: Word; Len: Byte): String;
Function IntToStr(Num: Integer; Len: Byte): String;
Function RealToStr(Num: Real; Len, Places: Byte) : String;
Function DateStr : String;
Function TimeStr : String;
Function Space(Len : Byte) : String;
Function UpperStr(S : string) : String;
Function LowerStr(S : string) : String;
implementation
{$L ASTR.OBJ}
function HexStr;
external; { ASTR }
Function UpperStr(S : string) : String;
external;
Function LowerStr(S : string) : String;
external;
function FillCharToStr;
var
S: String;
begin
S[0] := Chr(Len);
FillChar(S[1],Len,Ch);
FillCharToStr := S;
end;
Function Space;
begin
Space := FillCharToStr(Len,' ');
end;
function WordToStr;
var
S : String[5];
begin
Str(Num:Len, S);
WordToStr := S;
end; { WordToStr }
function IntToStr;
var
S : String[5];
begin
Str(Num:Len, S);
IntToStr := S;
end; { IntToStr }
function RealToStr;
var
S : String[80];
begin
Str(Num:Len:Places, S);
RealToStr := S;
end; { RealToString }
Function DateStr;
type
WeekDays = array[0..6] of string[9];
Months = array[1..12] of string[9];
const
DayNames : WeekDays = ('Sunday','Monday','Tuesday','Wednesday',
'Thursday','Friday','Saturday');
MonthNames : Months = ('January','February','March','April','May',
'June','July','August','September',
'October','November','December');
BlankStr : string[1] = ' ';
CommaStr : string[1] = ',';
var
DayOfWeek : Word;
Year,Month,Day: Word;
YearStr : string[4];
DayStr : string[2];
begin
GetDate(Year,Month,Day,DayOfWeek);
Str(Year:4,YearStr);
Str(Day,DayStr);
DateStr := DayNames[DayOfWeek] + BlankStr + MonthNames[Month] +
BlankStr + DayStr + CommaStr + BlankStr + YearStr
end;
Function TimeStr;
type
AmPm = array[0..1] of string[3];
const
AmPmStr : AmPm = (' AM',' PM');
Colon : string[1] = ':';
var
TmpHours,TmpMins : Word;
HourStr,MinStr : string[2];
AmIndex : Word;
Hours,Minutes,Seconds,Tics: Word;
begin
GetTime(Hours,Minutes,Seconds,Tics);
TmpHours := Hours;
TmpMins := Minutes;
if (Seconds > 30) then
begin
TmpMins := Succ(TmpMins) mod 60;
if (TmpMins = 0) then
TmpHours := Succ(TmpHours) mod 24
end;
if (TmpHours < 12) then
begin
AmIndex := 0;
if (TmpHours = 0) then
TmpHours := 12
end
else
begin
AmIndex := 1;
if (TmpHours > 12) then
TmpHours := TmpHours - 12
end;
Str(TmpMins:2,MinStr);
if (TmpMins < 10) then MinStr[1] := '0';
Str(TmpHours,HourStr);
TimeStr := HourStr + Colon + MinStr + AmPmStr[AmIndex]
end;
end.
程序2：ASTR.ASM
; ASTR.ASM (Turbo Assembler Program)
; Assembler include file for ASTR.PAS unit
; Writen by Dong Zhanshanin 1994
Title ASTR
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; Parameters (+2 because of push bp)
byteCount equ byte ptr ss:[bp+6]
num equ dword ptr ss:[bp+8]
; Function result address (+2 because of push bp)
resultPtr equ dword ptr ss:[bp+12]
PUBLIC HexStr
HexStr:
push bp
mov bp,sp ;get pointer into stack
les di,resultPtr ;get address of function result
mov dx,ds ;save Turbo's DS in DX
lds si,num ;get number address
mov al,byteCount ;how many bytes?
xor ah,ah ;make a word
mov cx,ax ;keep track of bytes in CX
add si,ax ;start from MS byte of number
dec si
shl ax,1 ;how many digits? (2/byte)
cld ;store # digits (going forward)
stosb ;in destination string's length byte
HexLoop:
std ;scan number from MSB to LSB
lodsb ;get next byte
mov ah,al ;save it
shr al,1 ;extract high nibble
shr al,1
shr al,1
shr al,1
add al,90h ;special hex conversion sequence
daa ;using ADDs and DAA's
adc al,40h
daa ;nibble now converted to ASCII
cld ;store ASCII going up
stosb
mov al,ah ;repeat conversion for low nibble
and al,0Fh
add al,90h
daa
adc al,40h
daa
stosb
loop HexLoop ;keep going until done
mov ds,dx ;restore Turbo's DS
pop bp
retf 6 ;parameters take 6 bytes
; function UpperStr
Public UpperStr
ResStr EQU Dword ptr [bp+10]
S EQU Dword ptr [bp+6]
UpperStr:
push bp ; Save BP
mov bp,sp ; Save up stack frame
push ds ; Save DS
xor ch,ch
mov bx,offset S
mov cl,byte ptr [bx]
jcxz @@4
inc cl
lds si,S ; Load string address
les di,ResStr ; Load result address
cld ; Forward string-ups
@@3: lodsb ; Load a character
stosb ; Copy a character
loop @@3 ; Loop for all characters
push es
pop ds
mov bx,offset ResStr
mov cl,byte ptr [bx]
inc bx
@@1: mov al,[bx] ; Get a character
cmp al,'a'
jb @@2 ; < 'a', then jump
cmp al,'z'
ja @@2 ; > 'z', then jump
and al,5fh ; Converted to uppercase
mov [bx],al ; Store to string
@@2: inc bx ; Point to next character
loop @@1
@@4: pop ds ; Restore DS
pop bp ; Restore BP
retf 4 ; Remove parameter and return
; function LowerStr
Public LowerStr
ResStr EQU Dword ptr [bp+10]
S EQU Dword ptr [bp+6]
LowerStr:
push bp ; Save BP
mov bp,sp ; Save up stack frame
push ds ; Save DS
xor ch,ch
mov bx,offset S
mov cl,byte ptr [bx]
jcxz @@4
inc cl
lds si,S ; Load string address
les di,ResStr ; Load result address
cld ; Forward string-ups
@@3: lodsb ; Load a character
stosb ; Copy a character
loop @@3 ; Loop for all characters
push es
pop ds
mov bx,offset ResStr
mov cl,byte ptr [bx]
inc bx
@@1: mov al,[bx] ; Get a character
cmp al,'A'
jb @@2 ; < 'A', then jump
cmp al,'Z'
ja @@2 ; > 'Z', then jump
or al,20h ; Converted to lowercase
mov [bx],al ; Store to string
@@2: inc bx ; Point to next character
loop @@1
@@4: pop ds ; Restore DS
pop bp ; Restore BP
retf 4 ; Remove parameter and return
END
程序3：ASTRDEMO.PAS
{-----------------------------------}
{ ASTRDEMO.PAS }
{ Demonstrates the usage of ASTR }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{-----------------------------------}
program AStrDemo;
Uses AStr;
var
s1, s2: string;
n1 : integer;
procedure UpLowDemo;
var
i : integer;
begin
s1 := '';
for i := 1 to 26 do s1 := s1 + chr(96+i);
S2 := UpperStr(s1);
Writeln('Upper : ', s2);
Writeln('Lower : ', LowerStr(s2));
end;
procedure HexStrDemo;
var
i,j : integer;
begin
Writeln('Print ASCII code, DEX|HEX');
i := 0;
repeat
for j := 1 to 5 do
begin
inc(i);
Write(IntToStr(i,3),'|',HexStr(i,1),'|',chr(i),Space(2));
if i=255 then
begin
Writeln;
exit;
end;
end;
Writeln;
until i = 255;
end;
procedure DateTimeDemo;
begin
writeln('Today is ',DateStr,Space(2),TimeStr);
end;
var ch : char;
num : longint;
s : string;
begin
UpLowDemo;
HexStrDemo;
DateTimeDemo;
end.
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 15:56:56
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第8楼
§2.3 磁盘输入输出单元DISK
磁盘输入输出单元DISK是专门处理与磁盘有关的过程和函数的集合，包括读写磁盘物理扇区过程、读写硬盘主引导记录过程、读写磁盘启动扇区过程、测试磁盘状态函数、取当前盘的物理磁盘号函数、检测磁盘是否准备好的函数。另外，还定义了3个与磁盘结构有关的数据结构。
§2.3.1 DISK单元定义的数据结构
DISK单元定义了三类数据结构，即主引导记录类型、分区表类型、BOOT记录类型，下面具体介绍记录类型的字段及其含义。
1.分区表类型PartitionType
分区表类型PartitionType的定义参见程序1，利用它可直接读取和修改硬盘的分区信息。PartitionTyped的各字段的意义及取值如下:
BootIndicator为启动标志，可取0或128，1字节；128代表活动分区，否则为非活动分区；
StartHead为分区开始的头数，1字节；
StartSector为分区开始的扇区数，1字节；
StartCylinder为分区开始的柱体数，1字节；
SysIndicator为系统标志，可取0(无定义)，1(DOS-12)，4(DOS-16)，5(EXTENDED)，6(BIGDOS)等值，1字节；
EndHead为分区结束头数，1字节；
EndSector为分区结束扇区数，1字节；
EndCylinder为分区结束柱体数，1字节；
RelativeSector为相对扇区数，双字；
TotalSector为扇区总数，双字。
2.主引导记录类型MBRT
MBRT的定义见程序1，其中各字段的意义及取值如下:
MainBoot为主引导程序及出错信息，占446个字节，察看其内容可以发现计算机是否感染主引导型病毒；
PartitionTable为硬盘分区信息表，是分区记录类型PartitionType一维数组，占64个字节；
Token为系统启动的有效标志，及55AAH。
3.BOOT记录类型BRT
BRT的定义见程序1，其中各字段的意义及取值如下:
pro1为转跳指令，3个字节；
ID为厂商标志字段，8个字节；
SS为扇区长度，一般为512，1个字；
AU为分配单元，及每簇的扇区数，1个字节；
RS为保留扇区数，1个字；
NF为FAT个数，一般为2，1个字节；
DS为根目录包含文件数，1个字；
TS为总扇区数，1个字；
MD为磁盘介质描述符，1个字节；
FS为每个FAT所占扇区数，1个字；
ST为每道所含扇区数，1个字；
NH为磁头数，1个字；
HS为隐含扇区个数，一般用于硬盘分区，1个字；
XX未用，1个字;
BS为大DOS分区扇区，双字;
PD为物理磁盘号，1个字;
ES为扩展启动记录标志，1字节;
VS为卷系列数，双字;
VL为卷标，11个字节;
FI为系统标志字符串，与分区表类型的系统标志相对应，8个字节;
prog启动代码区，占452个字节。
§2.3.2 DISK的函数和过程
1.ProcessPhysicalSector过程
功 能 读写磁盘物理扇区
用 法 ProcessPhysicalSector(OperateType: byte; DriveType: byte;
HeadNo: byte; StartCyl: byte; StartSec: byte;
SectorNumber: byte; var p)
说 明 OperateType为磁盘操作方式，2为读盘，3为写盘，字节型
DriveType为磁盘号，A盘为0，B盘为1，C盘为128，字节型
HeadNo为开始头数，字节型
StartCyl为开始柱体数，字节型
StartSec为开始扇区数，字节型
SectorNumber为待读、写扇区数，字节型
p为磁盘操作缓冲区，无类型变参
2.ReadMainBootRec过程
功 能 读硬盘主引导记录
用 法 ReadMainBootRec(StartCyl,StartSec: byte;var p : MBRT)
说 明 StartCyl为开始柱体数，字节型
StartSec为开始扇区数，字节型
p为磁盘缓冲区，类型为MBRT的变参
3.WriteMainBootRec过程
功 能 写硬盘主引导记录
用 法 WriteMainBootRec(StartCyl,StartSec: byte;var p: MBRT)
说 明 StartCyl为开始柱体数，字节型
StartSec为开始扇区数，字节型
p为磁盘缓冲区，类型为MBRT的变参
4.ReadBootSector过程
功 能 读启动扇区
用 法 ReadBootSector(Drive,StartHead,StartCyl,StartSec:byte;
var p:BRT)
说 明 Drive为磁盘号，A盘为0，B盘为1，C盘为128，字节型
StartHead为开始头数，字节型
StartCyl为开始柱体数，字节型
StartSec为开始扇区数，字节型
p为磁盘操作缓冲区，类型为BRT的变参
5.WriteBootSector过程
功 能 写启动扇区
用 法 WriteBootSector(Drive,StartHead,StartCyl,StartSec:byte;
var p:BRT);
说 明 参数意义同ReadBootSector
6.GetMediaByte函数
功 能 取当前磁盘介质描述符
用 法 GetMediaByte
结果类型 字节型
返 回 值 磁盘介质描述符，有如下取值:
FFH为320K 5.25"软盘
FEH为160K 5.25"软盘
FDH为360K 5.25"软盘
FCH为180K 5.25"软盘
F9H为1.2M 5.25"软盘或720K 3.5"软盘
F8H为硬盘
F0H为1.44M 3.5"软盘
7.GetDriveNo函数
功 能 取当前物理磁盘号
用 法 GetDriveNo
结果类型 字节型
返 回 值 当前物理磁盘号，0为A盘，1为B盘，128为C盘
8.DriveCase函数
功 能 测试软磁盘状态
用 法 DriveCase(DriveNo : byte)
结果类型 字节型
说 明 DriveNo为物理磁盘号。
返 回 值 软磁盘状态，0为正常，2为未关磁盘机门，12为磁盘未格式化, 255为非法驱动器
9.AutoKnow过程
功 能 自动感知盘片准备好与否
用 法 AutoKnow(Drive,Mode : byte);
说 明 Drive为驱动器号，0指A驱，1指B驱；Mode指A或B驱和盘片的类型， 03代表1.2MB驱动器中放有1.2MB软盘
§2.3.3 DISK的使用
DISKDEMO演示了DISK单元部分过程的用法。
§2.3.4 源程序清单
程序1:DISK.PAS
{***********************************}
{ UNIT : DISK }
{ Disk In/Out unit }
{ Written by Dong Zhanshan }
{ Version : July 1994 }
{***********************************}
unit Disk;
{$D-,S-}
interface
type
PartitionType = record
BootIndicator : Byte;
StartHead : Byte;
StartSector : Byte;
StartCylinder : Byte;
SysIndicator : Byte;
EndHead : Byte;
EndSector : Byte;
EndCylinder : Byte;
RelativeSector : longint;
TotalSector : longint;
end;
MBRT = record
MainBoot : array[0..445] of byte;
PartitionTable : array[1..4] of PartitionType;
Token : array[1..2] of byte;
end;
BRT = record
pro1 : array[1..3] of byte;
ID : array[1..8] of char;
SS : word; { bytes per sector }
AU : byte; { sectors per cluster }
RS : word; { Reserved sectors at begining}
NF : byte; { FAT copies }
DS : word; { root directory entries }
TS : word; { total sectors on disk }
MD : byte; { media descriptor byte }
FS : word; { sectors per FAT }
ST : word; { sectors per track }
NH : word; { sides }
HS : word; { hiden sectors }
{ extended parts of boot record }
XX : word; { unused word }
BS : longint; { big total number of sectors }
PD : word; { physical drive number }
ES : byte; { extended boot record signature }
VS : longint; { volume serial number }
VL : array[1..11] of char; { volume label }
FI : array[1..8] of char; { file system ID }
prog : array[1..452] of byte;
end;
Procedure ProcessPhysicalSector(OperateType: byte; DriveType: byte;
HeadNo: byte; StartCyl: byte; StartSec: byte;
SectorNumber: byte; var p) ;
procedure ReadMainBootRec(StartCyl,StartSec : byte;var p : MBRT);
procedure WriteMainBootRec(StartCyl,StartSec : byte;var p : MBRT);
procedure ReadBootSector(Drive,StartHead,StartCyl,StartSec:byte;var p:BRT);
procedure WriteBootSector(Drive,StartHead,StartCyl,StartSec:byte;var p:BRT);
function GetMediaByte:byte;
function GetDriveNo:byte;
function DriveCase(DriveNo : byte) : byte;
implementation
{$L DISK.OBJ}
Procedure ProcessPhysicalSector;external {DISK};
{$F+}
procedure ReadMainBootRec;
begin
ProcessPhysicalSector(2,$80,1,StartCyl,StartSec,1,p);
end;
procedure WriteMainBootRec;
begin
ProcessPhysicalSector(3,$80,1,StartCyl,StartSec,1,p);
end;
procedure ReadBootSector;
begin
ProcessPhysicalSector(2,Drive,StartHead,StartCyl,StartSec,1,p);
end;
procedure WriteBootSector;
begin
ProcessPhysicalSector(3,Drive,StartHead,StartCyl,StartSec,1,p);
end;
{$F-}
function GetMediaByte;external {DISK};
function GetDriveNo;external {DISK};
function DriveCase;external {DISK};
end.
程序2:DISK.ASM
; DISK.ASM
; Assembler including file for DISK.PAS unit
TITLE DISK
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; function DriveCase
PUBLIC DriveCase
DriveCase:
PUSH BP
MOV BP,SP
PUSH DS
MOV AL,BYTE PTR [BP+6]
MOV AH,0
MOV CX,1
MOV DX,0
MOV BX,OFFSET CS:BUF
PUSH CS
POP DS
INT 25H
JC @@1
MOV AL,0
@@1: ADD SP,2
POP DS
POP BP
RETF 2
BUF DB 512 DUP(0)
; function GetMediaByte;
PUBLIC GetMediaByte
GetMediaByte:
PUSH DS
MOV AH,1BH
INT 21H
MOV AX,DS:BX
POP DS
RETF
; function GetDriveNo;
PUBLIC GetDriveNo
GetDriveNo:
MOV AH,19H
INT 21H
RETF
; Procedure ProcessPhysicalSector;
PUBLIC ProcessPhysicalSector
ProcessPhysicalSector:
push bp
mov bp,sp
push es
mov ax,[bp+08]
mov es,ax
mov bx,[bp+06]
mov ch,byte ptr [bp+0eh]
mov cl,byte ptr [bp+0ch]
mov dh,byte ptr [bp+10h]
mov dl,byte ptr [bp+12h]
mov ah,byte ptr [bp+14h]
mov al,byte ptr [bp+0ah]
int 13h
pop es
pop bp
retf 12h
END
程序3:DISKDEMO.PAS
{-----------------------------------}
{ DISKDEMO.PAS }
{ Demonstrates the usage of DISK }
{ Written by Dong Zhanshan }
{ Version : July 1994 }
{-----------------------------------}
program DiskDemo;
uses acrt,disk;
const
MBRF = 'MRECORD.SAV';
BRF = 'BOOT.SAV';
var
f1 : file;
procedure ReadBootDemo;
var B : BRT;
begin
ProcessPhysicalSector(2,$80,1,0,1,1,MR);
assign(f1,BRF);
rewrite(f1,1);
blockwrite(f1,b,512);
close(f1);
end;
procedure ReadMainRecordDemo;
var MR : MBRT;
begin
ProcessPhysicalSector(2,$80,0,0,1,1,MR);
assign(f1,MBRF);
rewrite(f1,1);
blockwrite(f1,MR,512);
close(f1);
end;
begin
if YesNo('Read the main boot record in hard disk') then
ReadMainRecordDemo;
if YesNo('Read the boot record in hard disk') then
ReadBootDemo;
end.
§2.4 热键(Hotkey)单元POPUP
POPUP单元中定义的3个过程，1个用来定义热键过程，其余2个用来允许或禁止在程序中使用热键。该单元的基本原理是：用键盘中断来捕获热键，用时钟中断来启动热键过程，在一个热键过程活动期间，不能启动另一个热键过程。使用本单元，在程序中可以定义100个热键过程。
§2.4.1 POPUP的函数和过程
1.PopUpProc过程
功 能 定义热键过程
用 法 PopUpProc(Pr: Pointer; SC,KM: Byte)
说 明 Pr为热键过程的入口地址，指针类型
SC为热键的扫描码
KM为键盘状态字节的值，可取以下值:
1为按下右SHIFT键
2为按下左SHIFT键
4为按下CTRL键
8为按下ALT键
16为ScrollLock键有效
32为NumLock键有效
64为CapsLock键有效
128为Ins键有效
2.EnablePop过程
功 能 允许使用热键
用 法 EnablePop
3.DisablePop过程
功 能 禁止使用热键
用 法 DisablePop
§2.4.2 POPUP的使用
POPDEMO.PAS演示了POPUP单元的使用方法。
§2.4.3 源程序清单
程序1:POPUP.PAS
{*********************************************}
{ UNIT : POPUP }
{ Popupa (HOTKEY) Procedure Interface Unit }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{*********************************************}
Unit PopUp;
{$D-,S-}
interface
uses DOS;
procedure PopUpProc(Pr: Pointer; SC,KM: Byte);
procedure EnablePop;
procedure DisablePop;
Implementation
const
TimerInt = $1C;
KbdInt = $9;
CritInt = $24;
PopFlag: Boolean = False; { True when press HOTKEY }
Running: Boolean = False; { True when program is actival }
ScanCode: Byte = 0; { Scan Code for HOTKEY }
KeyMask: Byte = 0; { KeyBoard State byte }
MaxHotKey: Byte = 0; { Maximum numbers of HotKey }
type
HotKeyRec = record
Proc: Pointer;
Scancode: Byte;
KeyMask: Byte;
end;
var
TimerVec,KbdVec,OldCritVec: Pointer; { Save old vector }
PopRtn: Pointer; { Popup procedure pointer}
SaveBreak,TsrByte,
DOSSEG, { Start segment of DOS system }
INDOS:Word; { Busy mark of the DOS }
HotKey: Array[1..100] of HotKeyRec;
ScanCodeSet: Set of Byte;
procedure CLI; Inline($FA);
procedure STI; Inline($FB);
procedure NewCrit(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP:Word);
Interrupt;
begin AX:=0; end;
procedure CallOldInt(Sub: Pointer); { Call the old INT }
begin
Inline( $9C/ { PUSHF }
$FF/$5E/$04); { CALL DWORD PTR [BP+4] }
end;
procedure CallPopProc(Sub: Pointer);
begin
Running := True;
Inline($FF/$5E/$04); { CALL Dword Ptr [BP+4] }
Running := False;
end;
procedure Clock(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP:Word);
Interrupt;
begin
CallOldInt(TimerVec);
if (PopFlag) and (mem[DOSSeg:INDOS] = 0) then
begin
CLI;
Port[$20] := $20;
STI;
PopFlag := False;
CallPopProc(PopRtn);
end;
end;
procedure KeyBoard(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP:Word);
Interrupt;
var
SC: Byte;
procedure CheckKey;
var I : word;
begin
if (Port[$60] in ScanCodeSet) then
begin
SC := Port[$60];
for I := 1 to MaxHotKey do
if SC = HotKey[I].ScanCode then
begin
ScanCode := HotKey[I].ScanCode;
KeyMask := HotKey[I].KeyMask;
PopRtn := HotKey[I].Proc;
end;
end;
end;
begin
CheckKey;
if ((Port[$60]=ScanCode ) and ((mem[$0040:$0017]
and KeyMask) = KeyMask)) then
begin
TSRByte := Port[$61];
Port[$61] := TSRByte or $80;
Port[$61] := TSRByte;
CLI;
Port[$20] := $20;
STI;
if not Running then PopFlag := true;
end
else
CallOldInt(KbdVec);
end;
procedure EnablePop;
begin
inline($b4/$34/
$cd/$21/
$8c/$06/DOSSeg/
$89/$1e/INDOS); { save INDOS address }
GetIntVec(TimerInt,TimerVec);
GetIntVec(KbdInt,KbdVec);
GetIntVec(CritInt,OldCritVec);
SetIntVec(CritInt,@NewCrit);
SetIntVec(TimerInt,@Clock);
SetIntVec(KbdInt,@KeyBoard);
SetIntVec($1B,SaveInt1B);
end;
Procedure PopUpProc(PR: Pointer; SC,KM: Byte);
begin
inc(MaxHotKey);
with HotKey[MaxHotKey] do
begin
ScanCode := SC;
KeyMask := KM;
Proc := PR;
end;
ScanCodeSet := ScanCodeSet + [SC];
end;
procedure DisablePop;
var
P: Pointer;
begin
SetIntVec(TimerInt,TimerVec);
SetIntVec(KbdInt,KbdVec);
SetIntVec(CritInt,OldCritVec);
end;
begin
fillChar(HotKey,SizeOf(HotKey),#0);
ScanCodeSet := [];
end.
程序2:POPDEMO.PAS
{-----------------------------------}
{ POPDEMO.PAS }
{ Demonstrates the usage of POPUP }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{-----------------------------------}
{$F+} { procedures must be called by far call }
program PopupDemo;
uses dos,crt,popup;
var ch : char;
procedure PopUpProc1;
begin
clrscr;
textattr := 2*16+15;
repeat
writeln('Popup procedure 1');
writeln('Please enter a key');
writeln('Enter ESC to quit this procedure');
ch := readkey;
writeln('Your entered key is ',ch);
until ch=#27;
textattr := 15;
end;
procedure PopUpProc2;
begin
clrscr;
textattr := 1*16+14;
repeat
writeln('Popup procedure 2');
writeln('Please enter a key');
writeln('Enter ESC to quit this procedure');
ch := readkey;
writeln('Your entered key is ',ch);
until ch=#27;
textattr := 15;
end;
begin
PopUpProc(@PopupProc1,$3b,$08);
PopUpProc(@PopupProc2,$3c,$08);
EnablePop;
repeat
writeln('Please enter a key, Enter ESC to quit');
ch := readkey;
writeln('Your entered key is :',ch);
until ch = #27;
DisablePop;
end.
§2.5 数据库交互单元DBASE
为了使TURBO PASCAL程序方便地与数据库软件DBASE Ⅲ、FOXBASE交互,编写了此单元。该单元共含有3个通用过程，一个用于打开并读取数据库文件的库结构信息,一个用于关闭数据库文件，另一个用于读取DBASE数据库文件的记录。该单元也定义了几个数据类型。
§2.5.1 DBASE单元的数据类型和常量
1.字段类型FieldType
FldName为字段名，10字节字符串型
FldType为字段类型，字符型
FldOffset为字段在记录中的位置，字型
FldWidth为字段宽度，字节型
PosDec为数字型字段的小数点位置，字节型
2.字段类型数组及其指针
每条记录最多有128个字段，所以FieldTypeArray为128个FieldType类型元素的一维数组；FieldTypePtr为FieldTypeArray类型的指针类型；
3.数据库结构信息类型StrucType
NumRec为记录个数，长整型
StartPosData为记录数据的开始位置，字型
LengthRec为每条记录的长度，字型
NumField为每条记录的字段数，字节型
Field为数据库字段指针，FieldTypePtr类型
4.记录类型数组及其指针
每条记录最多有4000个字符,所以RecTypeArray为4000个char类型元素的一维数组;RecTypePtr为RecTypeArray对应的指针类型;
§2.5.2 DBASE单元的过程和函数
1.OpenDBase过程
功 能 打开指定名字的DBASE数据库，并读取其结构信息
用 法 OpenDBase(DbfName : string; var dbf : file;
var RecInfo : StrucType)
说 明 DbfName为字符串类型, 代表数据库文件名, 必须包括扩展名
dbf为无类型文件变量
RecInfo为数据库结构信息变量，StrucType类型
2.ReadRecord过程
功 能 读数据库记录
用 法 ReadRecord(var dbf : file; RecNo : longint;
RecInfo : StrucType; var Rec : RecTypePtr)
说 明 dbf为无类型文件变量
RecNo为记录号，长整类型
RecInfo为数据库结构信息，StrucType类型
Rec为记录变量，RecTypePtr类型
3.CloseDBase过程
功 能 关闭数据库文件
用 法 CloseDBase(var dbf : file; RecInfo : StrucType)
说 明 dbf为无类型文件变量
RecInfo为数据库结构信息，StrucType类型
§2.5.3 DBASE数据库单元的使用
首先，用OpenDBase打开数据库文件，并读取数据库的结构, 然后用ReadRecord随机读取数据库的任何记录，数据库使用完后，用CloseDBase关闭数据库文件。关于DBASE单元的使用由DBDEMO.PAS来演示，另外还可以参考§3.9节的数据库打卡程序PDBC.PAS
§2.5.4 源程序清单
程序1:DBASE.PAS
{ DBASE.PAS 1.0 }
{ Copyright (c) 1994 Dong Zhanshan }
Unit DBase;
interface
type
FieldType = record
FldName : string[10];
FldType : char;
FldOffset : word;
FldWidth : byte;
PosDec : byte;
end;
{ 每条记录最多有128个字段 }
FieldTypeArray = array[1..128] of FieldType;
FieldTypePtr = ^FieldTypeArray;
StrucType = record
NumRec : longint;
StartPosData : word;
LengthRec : word;
NumField : byte;
Field : FieldTypePtr;
end;
{ 每条记录最多有4000个字符 }
RecTypeArray = Array[1..4000] of char;
RecTypePtr = ^RecTypeArray;
procedure OpenDBase(DbfName : string; var dbf : file;
var RecInfo : StrucType);
procedure ReadRecord(var dbf : file; RecNo : longint;
RecInfo : StrucType; var Rec : RecTypePtr);
procedure CloseDBase(var dbf : file; RecInfo : StrucType);
implementation
procedure CloseDBase;
begin
close(dbf);
with RecInfo do Freemem(Field,NumField*32);
end;
procedure OpenDBase;
var i,j,l : integer;
ab : array[1..32] of byte;
begin
assign(dbf,DbfName);
reset(dbf,1);
blockread(dbf,ab,12);
with RecInfo do
begin
NumRec := ab[5] + ab[6] * 256 + ab[7] * 256 *256
+ ab[8] * 256 * 256;
StartPosData := ab[9] + ab[10] * 256;
LengthRec := ab[11] + ab[12] * 256;
NumField := (StartPosData - 33) div 32;
getmem(Field,NumField*Sizeof(FieldType));
seek(dbf,32);
for i := 1 to NumField do
begin
blockread(dbf,ab,32);
l := 0;
for j := 1 to 10 do if ab[j] <> 0 then inc(l);
with Field^[i] do
begin
move(ab[1],FldName[1],l);
FldName[0] := char(l);
FldType := chr(ab[12]);
FldWidth := ab[17];
PosDec := ab[18];
if i = 1 then FldOffset := 0
else
begin
FldOffset := Field^[1].FldWidth;
for j := 2 to i - 1 do
FldOffset := FldOffset + Field^[j].FldWidth;
end;
end;
end;
end;
end;
procedure ReadRecord;
var ch : char;
begin
with RecInfo do
begin
seek(dbf,StartPosData + LengthRec * (RecNo-1) );
blockread(dbf,ch,1);
blockread(dbf,Rec^,LengthRec);
end;
end;
end.
程序2:DBDEMO.PAS
{-----------------------------------}
{ DBDEMO.PAS }
{ Written by Dong Zhanshan }
{ Version : Oct. 1994 }
{-----------------------------------}
program DbDemo;
uses Dbase;
var
RecInfo : StrucType;
Rec : RecTypePtr;
f1 : file;
procedure DisplayStruc(RecInfo : StrucType);
var i : word;
begin
with RecInfo do
begin
Writeln('Number of Records : ',NumRec);
Writeln('Length of a Record : ',LengthRec);
Writeln('Number of Field : ',NumField);
Writeln(' Name Type Width Dec');
for i := 1 to NumField do
with Field^[i] do
Writeln(FldName:10,FldType:4,FldWidth:8,PosDec:7);
end;
end;
begin
OpenDBase('tra.dbf', f1, RecInfo);
DisplayStruc(RecInfo);
CloseDBase(f1, RecInfo);
end.
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 15:58:15
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第9楼
§2.6 扩展内存使用单元EMS
扩展内存使用单元是专门处理与扩展内存的检测、分配、使用、释放等有关的过程和函数以及数据类型的集合。它包括了1个新的数据类型、8个函数和1个过程。
§2.6.1 扩展内存单元的数据类型
该单元定义了一个与数据在扩展内存与常规内存之间传送有关的类型EMBStruc,其字段及其含义如下：
count为待转送数据的字节数，长整型
SrcType源类型，字节型；0代表常规内存，1代表扩展内存
SrcHandle源句柄；字型；0代表常规内存，非零代表扩展内存
SrcOffset源地址偏移；字型
SrcSegment源段地址；字型
DesType目的类型，字节型；0代表常规内存，1代表扩展内存
DesHandle目的句柄；字型；0代表常规内存，非零代表扩展内存
DesOffset目的地址偏移；字型
DesSegment目的段地址；字型
§2.6.2 扩展内存单元的过程和函数
1.EMMtest函数
功 能 检测是否存在EMM驱动程序
用 法 EMMtest
结果类型 布尔型
返 回 值 EMM存在返回TRUE,不存在返回FALSE
2.EMSstat函数
功 能 当EMM存在时,检测EMM的状态
用 法 EMSstat
结果类型 布尔型
返 回 值 EMM无错误,返回TRUE,否则返回FALSE
3.EMSVer函数
功 能 取EMM版本号
用 法 EMSVer
结果类型 字节型
返 回 值 返回一字节的版本号,高4位是BCD码的主版本号,低4位是BCD码的次版本号
4.EMBFree函数
功 能 释放已分配的扩展内存块
用 法 EMBFree( Handle : word)
结果类型 布尔型
说 明 Handle为扩展内存句柄,字型
返 回 值 释放成功,返回TRUE,否则返回FALSE
5.EMBAlloc函数
功 能 分配扩展内存块
用 法 EMBAlloc( nbytes : longint)
结果类型 字型
说 明 nbytes为欲分配扩展内存块的字节数
返 回 值 分配成功,返回扩展内存句柄,否则返回0
6.EMSPage过程
功 能 获取EMS的页计数
用 法 EMSPage(Var TotalPage, LeftPage : word)
说 明 TotalPage和LeftPage均为字型变量,TotalPage代表EMS的总页数, LeftPage代表EMS的可用页数
7.EMSFrame函数
功 能 获取EMS的页框段地址
用 法 EMSFrame
结果类型 字型
返 回 值 EMS页框的段地址
8.EMBGet函数
功 能 从扩展内存取回数据
用 法 EMBGet(var arr; nbytes : longint; Handle : word)
结果类型 布尔型
说 明 arr为无类型变量,作数据缓冲区用; nbytes为常整型,传送数据的长度; Handle为字型,为扩展内存句柄
返 回 值 取数据成功返回TRUE,否则返回FALSE
9.EMBPut函数
功 能 向扩展内存传送数据
用 法 EMBPut(var arr; nbytes : longint; Handle : word)
结果类型 布尔型
说 明 arr为无类型变量,作数据缓冲区用; nbytes为常整型,传送数据的长度; Handle为字型,为扩展内存句柄
返 回 值 传送数据成功返回TRUE,否则返回FALSE
§2.6.3 扩展内存单元的使用
EMSDEMO.PAS演示了EMS单元的使用。程序首先用EMMTest检测是否存在EMM程序，存在则调用EMSPage和EMSVer显示EMS内存的多少和EMM的版本号，然后分配能容纳10000个实数的扩展内存，将数组ARR中的10000个实数传送到扩展内存，将ARR数组置零，从扩展内存取回10000个实数放入ARR中，显示ARR中的10000个数据，最后，释放申请的扩展内存。
§2.6.4 源程序清单
程序1:EMS.PAS
{************************************}
{ UNIT : EMS }
{ Written by Dong Zhanshan }
{ Version : Sept.1994 }
{************************************}
unit EMS;
interface
type
EMBStruc = record
count : longint;
SrcType : byte;
SrcHandle : word;
SrcOffset : word;
SrcSegment : word;
DesType : byte;
DesHandle : word;
DesOffset : word;
DesSegment : word;
end;
function EMMtest : boolean;
function EMSstat : boolean;
function EMSVer : byte;
function EMBFree( Handle : word) : boolean;
function EMBAlloc( nbytes : longint) : word;
procedure EMSPage(Var TotalPage, LeftPage : word);
function EMSFrame : word;
function EMBGet(var arr; nbytes : longint; Handle : word) : boolean;
function EMBPut(var arr; nbytes : longint; Handle : word) : boolean;
implementation
{$L ems.obj}
function EMMtest; external;
function EMSstat; external;
function EMSVer; external;
function EMBFree; external;
procedure EMSPage; external;
function EMSFrame; external;
function Alloc(n : word) : word; external;
function EMBMov(var EMB : EMBStruc) : boolean; external;
procedure DisplayEmsError(ErrorNo : byte);
const ErrorStr : array[1..14] of string[79] =
(('Size is invalid'),
('EMM driving routine is not installed'),
('EMM software failure'),
('EMS hardware failure'),
(''),
('Invalid handle'),
('Invalid function of EMM'),
('No available handle'),
(''),
('Applied pages are more than existing pages'),
('Applied pages are more than available pages'),
(''),
('No. of Pages is great than page of handle'),
('Invalid physical page'));
begin
if ErrorNo <> 0 then Writeln('Error : ',ErrorStr[ErrorNo - $7D]);
end;
function EMBAlloc;
var n : word;
begin
n := (nbytes + $3fff) div $4000;
EMBAlloc := Alloc(n);
end;
function EMBPut(var arr; nbytes : longint; Handle : word) : boolean;
var EMB : EMBStruc;
begin
with EMB do
begin
count := nbytes;
SrcType := 0;
SrcHandle := 0;
SrcOffset := ofs(arr);
SrcSegment := Seg(arr);
DesType := 1;
DesHandle := handle;
DesOffset := 0;
DesSegment := 0;
if EMBMov(EMB) then EMBPut := true else EMBPut := false;
end;
end;
function EMBGet(var arr; nbytes : longint; Handle : word) : boolean;
var EMB : EMBStruc;
begin
with EMB do
begin
count := nbytes;
SrcType := 1;
SrcHandle := handle;
SrcOffset := 0;
SrcSegment := 0;
DesType := 0;
DesHandle := 0;
DesOffset := Ofs(arr);
DesSegment := seg(arr);
if EMBMov(EMB) then EMBGet := true else EMBGet := false;
end;
end;
end.
程序2:EMS.ASM
TITLE EMS
DOSSEG
LOCALS @@
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
Extrn DisplayEmsError:near
DevName db 'EMMXXXX0'
; function EMMTest
public EMMTest
EMMTest:
push bp
mov bp,sp
push es
mov ax,3567h
int 21h
mov di,10
push ds
mov ax,cs
mov ds,ax
mov si,offset DevName
mov cx,8
rep cmpsb
pop ds
mov al,0
jne @@1
mov al,1
@@1: pop es
pop bp
retf
; function EMSStat
public EMSStat
EMSStat:
push bp
mov bp,sp
mov ah,40h
int 67h
mov al,ah
push ax
call DisplayEmsError
mov al,0
cmp ah,0
jne @@1
mov al,1
@@1: pop bp
retf
; Procedure EMSPage
public EMSPage
EMSPage:
push bp
mov bp,sp
push ds
mov ah,42h
int 67h
lds si,[bp+6] ; number of left pages
mov [si],bx ;
lds si,[bp+10] ; number of total pages
mov [si],dx ;
mov al,ah
push ax
call DisplayEmsError
pop ds
pop bp
retf 8
; function EMSFrame : word;
public EMSFrame
EMSFrame:
push bp
mov bp,sp
mov ah,41h
int 67h
mov al,ah
push ax
call DisplayEmsError
mov ax,bx
pop bp
retf
; function EMSVer
public EMSVer
EMSVer:
push bp
mov bp,sp
mov ah,46h
int 67h
push ax
mov al,ah
push ax
call DisplayEmsError
pop ax
pop bp
retf
; funtion Alloc
public Alloc
Alloc:
push bp
mov bp,sp
mov ah,43h
mov bx,[bp+6]
int 67h
push ax
mov al,ah
push ax
call DisplayEmsError
pop ax
mov ax,dx
pop bp
ret 2
; function EMBFree
public EMBFree
EMBFree:
push bp
mov bp,sp
mov dx,[bp+6]
mov ah,45h
int 67h
mov al,ah
push ax
call DisplayEmsError
mov al,0
cmp ah,0
jne @@1
mov al,1
@@1: pop bp
retf 2
; function EMBMov
public EMBMov
EMBMov:
push bp
mov bp,sp
push ds
push si
lds si,[bp+4]
mov ax,5700h
int 67h
mov al,ah
push ax
call DisplayEmsError
mov al,0
cmp ah,0
jne @@1
mov al,1
@@1: pop si
pop ds
pop bp
ret 4
end
程序3:EMSDEMO.PAS
{-----------------------------------}
{ EMSDEMO.PAS }
{ Demonstrates the usage of EMS }
{ Written by Dong Zhanshan }
{ Version : Sept.1994 }
{-----------------------------------}
program EMSDemo;
uses EMS;
const
size = 10000;
var ver,primever,secondver : byte;
ar : array[1..size] of real;
handle : word;
i,j : word;
begin
if EMMTest then
begin
EMSpage(i,j);
writeln('EMS Total pages := ',i,' Left Pages := ',j);
Ver := EMSVER;
Primever := (ver and 240) shr 4;
secondver := ver and 15;
writeln('EMS version : ',primever,'.',secondver);
handle := EmbAlloc(sizeof(ar));
writeln(handle);
for i := 1 to size do ar[i] := ln(i);
if EmbPut(ar,sizeof(ar),Handle) then writeln('Put EMS OK');
for i := 1 to size do ar[i] := 0;
if EmbGet(ar,sizeof(ar),Handle) then writeln('Get EMS OK');
for i := 1 to size do write(i:7,':',ar[i]:8:4);
if EMBFree(handle) then writeln('Free EMS OK!');
end
else
writeln('EMS does not exist');
end.
§2.7 扩充内存使用单元XMS
扩充内存使用单元包含了第一章所述扩充内存管理规范的各项功能，在TURBO PASCAL程序中只要使用此单元即可使用扩充内存。该单元定义了15个函数和1个过程，同时定义了3个记录类型，1个变量和4个常量。
§2.7.1 XMS单元所定义的数据结构
下面介绍XMS单元定义的3个记录数据类型、4个与A20地址线的状态有关的常量和1个存储XMS调用错误状态的变量ErrorStatus。
1.XMS状态记录类型XMS_status
version为版本号，字型
revision为内部版本号，字型
HMA_exist为高内存区是否存在的标志，布尔型
2.XMS内存状态记录类型XMS_mem_stat
LargestBlock为最大扩充内存分配块，以KB计，字型
TotalFreeMemory为总的自由扩充内存块，以KB计，字型
3.内存块传送参数结构类型EMBstruc
Count为传送的字节数，长整型
SourceHandle为源句柄，字型,0代表常规内存,非0代表扩充内存
SourceOfs为源偏移，长整型
DestinHandle为目的句柄，字型,0代表常规内存,非0代表扩充内存
DestinOfs为目的偏移，长整型
4.与A20地址线有关的4个常量
GlobalEnableA20为全程打开A20地址线功能
GlobalDisableA20为全程关闭A20地址线功能
LocalEnableA20为局部打开A20地址线功能
LocalDisableA20为局部关闭A20地址线功能
§2.7.2 XMS单元的过程和函数
1.XMS_test函数
功 能 检测XMM是否存在
用 法 XMS_test
结果类型 布尔型
返 回 值 如果XMM存在返回TRUE，否则返回FALSE
2.XMS_stat过程
功 能 检测XMM的状态
用 法 XMS_stat(var stat : XMS_status)
说 明 stat为XMS_status的变参
3.XMS_avail函数
功 能 取XMS的内存状态
用 法 XMS_avail(var MemStat : XMS_mem_stat)
结果类型 布尔型
说 明 MemStat为XMS_mem_stat类型的变参
返 回 值 如果XMS无错返回TRUE，否则返回FALSE
4.XMS_alloc函数
功 能 分配XMS内存
用 法 XMS_alloc(KSize : word; var Handle : word)
结果类型 布尔型
说 明 KSize为欲申请XMS内存的大小,以KB计,字型
Handle为XMS内存句柄,字型变量
返 回 值 分配成功返回TRUE,分配失败返回FALSE
5.XMS_realloc函数
功 能 重新分配XMS内存
用 法 XMS_realloc(KSize， Handle : word)
结果类型 布尔型
说 明 KSize为欲重新分配的XMS内存的大小,以KB计,字型值参
Handle为XMS内存句柄,字型值参
返 回 值 如果重新分配成功返回TRUE,否则返回FALSE
6.XMS_free函数
功 能 释放指定的XMS内存
用 法 XMS_free(Handle : word)
结果类型 布尔型
说 明 Handle为XMS内存句柄,字型值参
返 回 值 如果XMS内存释放成功返回TRUE,否则返回FALSE
7.XMS_lock函数
功 能 锁已分配的XMS内存
用 法 XMS_lock(Handle : word; var MyAddr : LongInt)
结果类型 布尔型
说 明 Handle为已分配XMS内存的句柄,字型值参
MyAddr为加锁的内存地址,长整型变参
返 回 值 如果加锁成功返回TRUE,否则返回FALSE
8.XMS_unlock函数
功 能 解锁锁定的XMS内存
用 法 XMS_unlock(Handle : word)
结果类型 布尔型
说 明 Handle为加锁的XMS内存的句柄,字型值参
返 回 值 如果解锁成功返回TRUE,否则返回FALSE
9.XMS_bstat函数
功 能 取扩充内存控制块句柄信息
用 法 XMS_bstat(Handle:word;var LockCount,NumFreeHandle:byte)
结果类型 布尔型
说 明 Handle为XMS内存句柄,字型值参
LockCount为加锁信息,字节型变参
NumFreeHandle为自由XMS内存句柄个数,字节型变参
返 回 值 如果已获得信息块返回TRUE,否则返回FALSE
10.XMS_move函数
功 能 移动扩充内存块
用 法 XMS_move(var EMB : EMBstruc)
结果类型 布尔型
说 明 EMB为EMBstruc类型的变量,为内存传送的参数块
返 回 值 如果内存之间的数据传送成功返回TRUE,否则返回FALSE
11.HMA_alloc函数
功 能 分配高内存区
用 法 HMA_alloc(Size : word)
结果类型 布尔型
说 明 Size为欲分配内存的大小,字型值参
返 回 值 如果分配成功返回TRUE,否则返回FALSE
12.HMA_free函数
功 能 释放高内存区
用 法 HMA_free
结果类型 布尔型
返 回 值 释放成功返回TRUE,否则返回FALSE
13.Alter_A20函数
功 能 操纵A20地址线
用 法 Alter_A20(Func : byte)
结果类型 布尔型
说 明 Func可取单元头上定义的4个常量中的一个,字节型值参
返 回 值 如果成功地执行了A20地址线的操作返回TRUE,否则返回FALSE
14.A20_stat函数
功 能 查询A20地址线的状态
用 法 A20_stat
结果类型 布尔型
返 回 值 查询成功返回TRUE,否则返回FALSE
15.UMB_alloc函数
功 能 分配上位存储块(UMB)
用 法 UMB_alloc(var PSize,SegAddr : word)
结果类型 布尔型
说 明 PSize为欲分配的UMB的大小,以KB计,字型变参
SegAddr为分配的UMB的段地址,字型变参
返 回 值 如果分配成功返回TRUE,否则返回FASLE
16.UMB_free函数
功 能 释放已分配的上位存储块(UMB)
用 法 UMB_free(SegAddr : word)
结果类型 布尔型
说 明 SegAddr为分配的UMB的段地址
返 回 值 如果释放成功返回TRUE,否则返回FLASE
§2.7.3 XMS单元的使用
XMSDEMO.PAS演示了XMS单元大多数函数的用法。首先用XMS_test检测XMM是否存在，如果存在调用XMS_stat取XMM的版本号，并显示之，而后取XMS的内存分配状态，最后演示了如何将数据传入与传出XMS内存。读者可以仿照此演示程序，编制自己的使用扩充内存的程序。
§2.7.4 源程序清单
程序1:XMS.PAS
{************************************}
{ UNIT : XMS }
{ Written by Dong Zhanshan }
{ Version : Aug. 1994 }
{************************************}
unit XMS;
interface
Type
XMS_status = record
version,revision : word;
HMA_exist : boolean;
end;
XMS_mem_stat = record
LargestBlock,TotalFreeMemory : Word;
end;
EMBstruc = record
Count : LongInt;
SourceHandle : word;
SourceOfs : LongInt;
DestinHandle : word;
DestinOfs : LongInt;
end;
var
ErrorStatus : Byte;
Const
GlobalEnableA20 = 00;
GlobalDisableA20 = 01;
LocalEnableA20 = 02;
LocalDisableA20 = 03;
function XMS_test : boolean;
procedure XMS_stat(var stat : XMS_status);
function XMS_avail(var MemStat : XMS_mem_stat) : boolean;
function XMS_alloc(KSize : word; var Handle : word) : boolean;
function XMS_realloc(KSize, Handle : word) : boolean;
function XMS_free(Handle : word) : boolean;
function XMS_lock(Handle : word; var MyAddr : LongInt) : boolean;
function XMS_unlock(Handle : word) : boolean;
function XMS_bstat(Handle : word; var LockCount, NumFreeHandle : byte) : boolean;
function XMS_move(var EMB : EMBstruc) : boolean;
function HMA_alloc(Size : word) : boolean;
function HMA_free : boolean;
function Alter_A20(Func : byte) : boolean;
function A20_stat : boolean;
function UMB_alloc(var PSize,SegAddr : word) : boolean;
function UMB_free(SegAddr : word) : boolean;
implementation
uses DOS;
var
XMS_control : Pointer;
{$L XMS.OBJ}
function XMS_test : boolean;
external;
procedure XMS_stat(var stat : XMS_status);
external;
function XMS_avail(var MemStat : XMS_mem_stat) : boolean;
external;
function XMS_alloc(KSize : word; var Handle : word) : boolean;
external;
function XMS_realloc(KSize, Handle : word) : boolean;
external;
function XMS_free(Handle : word) : boolean;
external;
function XMS_lock(Handle : word; var MyAddr : LongInt) : boolean;
external;
function XMS_unlock(Handle : word) : boolean;
external;
function XMS_bstat(Handle : word; var LockCount, NumFreeHandle : byte) : boolean;
external;
function XMS_move(var EMB : EMBstruc) : boolean;
external;
function HMA_alloc(Size : word) : boolean;
external;
function HMA_free : boolean;
external;
function Alter_A20(Func : byte) : boolean;
external;
function A20_stat : boolean;
external;
function UMB_alloc(var PSize,SegAddr : word) : boolean;
external;
function UMB_free(SegAddr : word) : boolean;
external;
end.
程序2:XMS.ASM
; XMS.ASM 1.0
; used by XMS.PAS
TITLE XMS
LOCALS @@
DOSSEG
.MODEL TPASCAL
extrn XMS_control:DWORD
extrn ErrorStatus:BYTE
.CODE
ASSUME CS:@CODE
; function XMS_test
PUBLIC XMS_test
XMS_test:
push bp
mov bp,sp
mov ax,4300h
int 2fh
cmp al,80h
jnz @@1
mov ax,4310h
int 2fh
mov word ptr XMS_control,bx
mov word ptr XMS_control+2,es
mov al,01
jmp @@2
@@1: mov al,0
@@2: mov sp,bp
pop bp
retf
; procedure XMS_stat
PUBLIC XMS_stat
XMS_stat:
push bp
mov bp,sp
mov ah,0
call XMS_control
les si,[bp+6]
mov es:[si],ax
mov es:[si+2],bx
mov es:[si+4],dl
pop bp
retf 04
; function XMS_avail
PUBLIC XMS_avail
XMS_avail:
push bp
mov bp,sp
mov ah,8
call XMS_control
les si,[bp+6]
mov es:[si],ax
mov es:[si+2],dx
mov ErrorStatus,bl
pop bp
retf 04
; function XMS_alloc
PUBLIC XMS_alloc
XMS_alloc:
push bp
mov bp,sp
mov ah,9
mov dx,[bp+0ah]
call XMS_control
les si,[bp+6]
mov es:[si],dx
mov ErrorStatus,bl
pop bp
retf 06
; function XMS_realloc
PUBLIC XMS_realloc
XMS_realloc:
push bp
mov bp,sp
mov ah,0fh
mov bx,[bp+8]
mov dx,[bp+6]
call XMS_control
mov ErrorStatus,bl
pop bp
retf 4
; function XMS_lock
PUBLIC XMS_lock
XMS_lock:
push bp
mov bp,sp
mov ah,0ch
mov dx,[bp+0ah]
call XMS_control
les si,[bp+6]
mov es:[si],bx
mov es:[si+2],dx
mov ErrorStatus,bl
pop bp
retf 06
; function XMS_unlock
PUBLIC XMS_unlock
XMS_unlock:
push bp
mov bp,sp
mov ah,0dh
mov dx,[bp+6]
call XMS_control
mov ErrorStatus,bl
pop bp
retf 02
; function XMS_bstat
PUBLIC XMS_bstat
XMS_bstat:
push bp
mov bp,sp
mov ah,0eh
mov dx,[bp+0eh]
call XMS_control
les si,[bp+0ah]
mov byte ptr es:[si],bh
les si,[bp+6]
mov byte ptr es:[si],bl
mov ErrorStatus,bl
pop bp
retf 0ah
; function XMS_move
PUBLIC XMS_move
XMS_move:
push bp
mov bp,sp
xor bx,bx
mov ah,0bh
push ds
pop es
push ds
lds si,[bp+6]
call es:XMS_control
pop ds
mov ErrorStatus,bl
pop bp
retf 04
; function XMS_free
PUBLIC XMS_free
XMS_free:
push bp
mov bp,sp
mov ah,0ah
mov dx,[bp+6]
call XMS_control
mov ErrorStatus,bl
pop bp
retf 02
; function HMA_alloc
PUBLIC HMA_alloc
HMA_alloc:
push bp
mov bp,sp
mov ah,1
mov dx,[bp+6]
call XMS_control
mov ErrorStatus,bl
pop bp
retf 02
; function HMA_free
PUBLIC HMA_free
HMA_free:
push bp
mov bp,sp
mov ah,2
call XMS_control
mov ErrorStatus,bl
pop bp
retf
; function Alter_A20
PUBLIC Alter_A20
Alter_A20:
push bp
mov bp,sp
mov ah,[bp+6]
add ah,3
call XMS_control
mov ErrorStatus,bl
pop bp
retf 2
; function A20_stat
PUBLIC A20_stat
A20_stat:
push bp
mov bp,sp
mov ah,7
call XMS_control
mov ErrorStatus,bl
pop bp
retf
; function UMB_alloc
PUBLIC UMB_alloc
UMB_alloc:
push bp
mov bp,sp
mov ah,10h
les si,[bp+0ah]
mov dx,es:[si]
call XMS_control
or ax,ax
jz @@5
les si,[bp+6]
mov es:[si],bx
@@5: les si,[bp+0ah]
mov es:[si],dx
mov ErrorStatus,bl
pop bp
retf 08
; function UMB_free
PUBLIC UMB_free
UMB_free:
push bp
mov bp,sp
mov ah,11h
mov dx,[bp+6]
call XMS_control
mov ErrorStatus,bl
pop bp
retf 2
end
程序3:XMSDEMO.PAS
{-----------------------------------}
{ XMSDEMO.PAS }
{ Demonstrates the usage of XMS }
{ Written by Dong Zhanshan }
{ Version : Aug. 1994 }
{-----------------------------------}
program XMSDemo;
uses XMS;
var stat : XMS_status;
memstat : XMS_mem_stat;
handle : word;
emb : EMBstruc;
i,ksize : integer;
Myaddr : LongInt;
ar,ar1 : array[1..10000] of integer;
begin
if XMS_test then
begin
writeln('XMS memory exists');
XMS_stat(stat);
writeln('XMS v',hi(stat.version),' XMM v',hi(stat.revision),'.0',lo(stat.revision));
if XMS_Avail(Memstat) then
writeln('lb= ',memStat.LargestBlock,' TFM = ',memstat.TotalFreeMEmory);
if XMS_alloc(16,handle) then
writeln('Handle = ',handle);
if XMS_Avail(Memstat) then
writeln('lb= ',memStat.LargestBlock,' TFM = ',memstat.TotalFreeMEmory);
if XMS_free(handle) then writeln('free ok');
if XMS_Avail(Memstat) then
writeln('lb= ',memStat.LargestBlock,' TFM = ',memstat.TotalFreeMEmory);
if A20_stat then writeln('A20 is busy');
end;
for i := 1 to 10000 do ar[i] := i;
{ for i := 1 to 10000 do write(ar[i]:5); }
ksize := sizeof(ar) div 1024;
if odd(Ksize) then inc(Ksize);
if XMS_alloc(Ksize,handle) then
begin
writeln(ErrorStatus);
emb.count := 1024;
emb.SourceHandle := 0;
emb.destinHandle := handle;
for i:= 1 to Ksize do
begin
emb.destinOfs := (i-1)*1024;
emb.SourceOfs := longint(addr(ar))+(i-1)*1024;
if XMS_move(emb) then ;
end;
for i := 1 to 10000 do ar[i] := 0;
WRITELN(ERRORSTATUS);
emb.count := 1024;
emb.SourceHandle := handle;
emb.destinHandle := 0;
for i:= 1 to Ksize do
begin
emb.SourceOfs := (i-1)*1024;
emb.destinOfs := longint(addr(ar))+(i-1)*1024;
if XMS_move(emb) then ;
end;
for i := 1 to 10000 do write(ar[i]:5);
WRITELN(ERRORSTATUS);
end;
if XMS_free(handle) then writeln('OK !');
end.
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 15:58:38
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第10楼
§2.8 数学函数单元MATH
MATH单元是一些数学函数的集合，是对TURBO PASCAL数学函数的一个有益的补充。它包括：取符号函数、指数函数、对数函数、三角和反三角函数、最大最小函数、排列与组合函数、阶乘函数等。
§2.8.1 MATH的函数和过程
1.Sign函数
功 能 取实数的符号
用 法 Sign(x : real)
结果类型 整型
说 明 x为实型数
返 回 值 +1或-1
2.Power函数
功 能 求x攩y攪的值
用 法 Power(x,y : real)
结果类型 实型
说 明 x为基数，实数；y为指数，实数
返 回 值 x攩y攪的值
3.Log函数
功 能 求log攬x攭y的值
用 法 Log(x,y : real)
结果类型 实型
说 明 x为对数的底数，实数；y为对数的真数，实数
返 回 值 log攬x攭y的值
4.Amax函数
功 能 求两个实数中较大的数
用 法 Amax(mxn1, mxn2 : real)
结果类型 实型
说 明 mxn1，mxn2为实数
返 回 值 两个实数中较大的数
5.Amin函数
功 能 求两个实数中较小的数
用 法 Amin(mxn1, mxn2 : real)
结果类型 实型
说 明 参数意义同Amax
返 回 值数中较小的数
6.Max函数
功 能 求两个整数中较大的数
用 法 Max(mxn1, mxn2 : longint)
结果类型 长整型
说 明 mxn1，mxn2为两个长整数
返 回 值 两个整数中较大的数
7.Min函数
功 能 求两个整数中较小的数
用 法 Min(mxn1, mxn2 : longint)
结果类型 长整型
说 明 参数意义同Max
返 回 值 两个整数中较小的数
8.Tan函数
功 能 求角x的正切函数值
用 法 Tan(x : real)
结果类型 实型
说 明 x为角度值，以弧度计
返 回 值 角x的正切函数值
9.CTan函数
功 能 求角x的余切函数值
用 法 CTan(x : real)
结果类型 实型
说 明 x为角度值，以弧度计
返 回 值 角x的余切函数值
10.ArcSin函数
功 能 求数x的反正弦函数值
用 法 ArcSin(x : real)
结果类型 实型
说 明 x为在[-1,1]区间内的实数
返 回 值 数x的反正弦函数值，以弧度计
11.ArcCos函数
功 能 求数x的反余弦函数值
用 法 ArcCos(x : real)
结果类型 实型
说 明 x为在[-1,1]区间内的实数
返 回 值 数x的余正弦函数值，以弧度计
12.Comb函数
功 能 求组合C攬n攭攩m攪的值
用 法 Comb(n,m : word)
结果类型 长整型
说 明 n，m为两个正整数，m小于n
返 回 值 组合C攬n攭攩m攪的值
13.Permut函数
功 能 求排列P攬n攭攩m攪的值
用 法 Permut(n,m : word)
结果类型 长整型
说 明 n，m为两个正整数，m小于n
返 回 值 排列P攬n攭攩m攪的值
14.Factor函数
功 能 求正整数n的阶乘值
用 法 Factor(n : word)
结果类型 长整型
说 明 n为正整数
返 回 值 正整数n的阶乘值
§2.8.2 MATH的使用
MATHDEMO.PAS演示了MATH单元的使用,它调用了反三角函数ArcSin和ArcCos及Log函数,打印了三个函数的函数表。
§2.8.3 源程序清单
程序1：MATH.PAS
{***************************************}
{ UNIT : MATH }
{ Mathematics functions unit }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{***************************************}
Unit Math;
(*
{$D-,S-}
*)
Interface
function Sign(x : real) : integer;
function Power(x,y : real) : real;
function Log(x,y : real) : real;
function Amax(mxn1, mxn2 : real) : real; { FORTRAN 77 function }
function Amin(mxn1, mxn2 : real) : real; { FORTRAN 77 function }
function Max(mxn1, mxn2 : longint) : longint; { FORTRAN 77 function }
function Min(mxn1, mxn2 : longint) : longint; { FORTRAN 77 function }
function Tan(x : real) : real;
function CTan(x : real) : real;
function ArcSin(x : real) : real;
function ArcCos(x : real) : real;
function Comb(n,m : word) : longint;
function Permut(n,m : word) : longint;
function Factor(n : word) : longint;
implementation
function Sign;
{ get the sign of a real }
begin
if x >= 0 then sign := 1 else sign := -1;
end;
function Tan(x : real) : real;
begin
Tan := Sin(x) / Cos(x);
end;
function CTan(x : real) : real;
begin
CTan := Cos(x) / Sin(x);
end;
function ArcSin(x:Real):Real;
{ ArcSin(x)= ArcTan(x/1-x) }
var o : real;
begin
o := abs(x);
if o > 1.0 then writeln('Illegal arguement');
if o = 1.0 then
if x < 0.0 then ArcSin := -0.5 * pi
else ArcSin := 0.5 * pi
else ArcSin := ArcTan(x/sqrt(1.0 - x*x));
end;
function ArcCos(x:Real):Real;
begin
ArcCos := (0.5 * pi) - ArcSin(x)
end;
function Amax(Mxn1,Mxn2:real):real;
begin
Amax := Mxn1;
if Mxn2>Mxn1 then Amax := Mxn2;
end;
function Amin(Mxn1,Mxn2:real):real;
begin
Amin := Mxn1;
if Mxn2end;
function Max;
begin
Max := Mxn1;
if Mxn2>Mxn1 then Max := Mxn2;
end;
function Min;
begin
Min := Mxn1;
if Mxn2end;
function Log(x,y:real):real;
begin
Log := ln(y)/ln(x);
end;
function poweri(x:real; n:integer):real;
function rlscan(x:real; n:integer):real;
var
y, z : real;
o : boolean;
bign : integer;
begin
bign := n;
y := 1.0;
z := x;
while bign > 0 do
begin
o := odd(bign);
bign := bign div 2;
if o then
begin
y := y * z;
rlscan := y;
end;
z := z * z;
end;
end; (* func rlscan *)
begin
if n > 0 then
poweri := rlscan(x,n)
else
if (x <> 0.0) and (n < 0) then
begin
n := -n;
poweri := 1.0 / rlscan(x,n);
end
else
if (n = 0) and (x <> 0) then
poweri := 1.0
else
if (n = 0) and (x = 0) then
begin
writeln('0 to the 0 power.');
poweri := 0.0;
end
else
if (n < 0) and (x = 0) then
begin
writeln('Division by zero.');
poweri := 0.0;
end;
end; (* function poweri *)
function power(x,y:real):real;
begin
if (y = int(y)) and (abs(y) <= 32767) then
power := poweri(x,trunc(y))
else
if x > 0 then
power := exp(y*ln(x))
else
if x < 0 then begin
writeln('X < 0.');
power := 0.0;
end
else
if (x=0) and (y=0) then begin
writeln('0 to the 0 power.');
power := 0.0;
end
else
if (x=0) and (y<0) then begin
writeln('0 to a negative power.');
power := 0.0;
end
else
power := 0.0;
end; { end of function power }
function factor;
{ This is a subroutine to calculte the factorial }
{ of a integer number. }
var i : integer;
x1 : longint;
begin
x1 := 1;
for i := 1 to n do x1 := x1 * i;
factor := x1;
end;
function permut;
{ This is a subroutine to calculte the permutation }
{ of two integer number. }
var x1 : longint;
i : integer;
begin
x1 := 1;
for i := 1 to m do x1 := x1*(n-i+1);
permut := x1;
end;
function comb;
{ This is a subroutine to calculte the combination }
{ of two integer number. }
var x1,x2,x3,i : longint;
begin
x3 := 1;
if (m > (n-m)) then
begin
x1 := m;
x2 := n-m;
end
else
begin
x1 := n-m;
x2 := m;
end;
for i := 1 to x2 do x3 := x3*(n-i+1);
x1 := factor(x2);
comb := x3 div x1;
end;
end.
程序2:MATHDEMO.PAS
{-----------------------------------}
{ MATHDEMO.PAS }
{ Demonstrates the usage of MATH }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{-----------------------------------}
{$F+}
program Mathdemo;
uses astr,math;
type
func = function(a:real):real; { decleare function type }
procedure PrintArcTriangleTable(proc1:func);
var
i,j : integer;
begin
i := 0;
repeat
for j := 1 to 5 do
begin
inc(i);
write(RealToStr(i/100,5,2),'|');
write(RealToStr(proc1(i/100)/pi*180,6,3),space(2));
end;
writeln;
until i = 100;
end;
procedure PrintLog;
var
i,j : integer;
begin
i := 0;
repeat
for j := 1 to 5 do
begin
inc(i);
write(WordToStr(i,4),'|');
write(RealToStr(log(10,i),6,4),space(2));
end;
writeln;
until i = 1000;
end;
begin
WriteLn('ArcSin Table x|degree');
PrintArcTriangleTable(ArcSin);
Writeln;
WriteLn('Arccos Table x|degree');
printArcTriangleTable(ArcCos);
Writeln;
Writeln('Log10(x) Table x|log10(x)');
PrintLog;
end.
§2.9 矩阵运算单元MATRIX
MATRIX单元含12个过程和函数，处理矩阵的加、减、乘、求逆、转置等运算，为TURBO PASCAL扩展了矩阵运算功能。
MATRIX中定义了矩阵最大元素个数常量MaxNumMatElement，同时定义了3个与矩阵有关的新类型，即矩阵元素类型MatElementType、最大矩阵类型MaxMatType和最大矩阵指针类型MaxMatPtr。
§2.9.1 MATRIX的函数和过程
1.MatMaxElement函数
功 能 求矩阵最大元素
用 法 MatMaxElement(mata:pointer;n,m:integer)
结果类型 实型
说 明 mata为指定的矩阵，无类型指针变量
n为矩阵mata的行数
m为矩阵mata的列数
返 回 值 矩阵的最大元素
2.MatZero过程
功 能 构造全零矩阵
用 法 MatZero(mata : pointer ; n,m : integer)
说 明 参数意义同MatMaxElement
3.MatCon过程
功 能 构造常数矩阵
用 法 MatCon(mata : pointer ; n,m : integer)
说 明 参数意义同MatMaxElement
4.MatIdn过程
功 能 构造单位矩阵
用 法 MatIdn(mata : pointer ; n : integer)
说 明 mata为指定的方阵，无类型指针变量
n为方阵mata的阶数
5.MatEqual过程
功 能 矩阵相等运算
用 法 MatEqual(mata,matb : pointer; n,m : integer)
说 明 mata，matb为指定的矩阵，无类型指针变量
n为矩阵的行数
m为矩阵的列数
6.MatAdd过程
功 能 矩阵相加运算
用 法 MatAdd(mata,matb,matc : pointer; n,m : integer)
说 明 mata，matb为指定的矩阵，无类型指针变量
matc为mata和matb相加的结果矩阵，无类型指针变量
n为矩阵的行数
m为矩阵的列数
7.MatSub过程
功 能 矩阵相减运算
用 法 MatSub(mata,matb,matc : pointer; n,m : integer)
说 明 mata，matb为指定的矩阵，无类型指针变量
matc为mata和matb相减的结果矩阵，无类型指针变量
n为矩阵的行数
m为矩阵的列数
8.MatMulConst过程
功 能 常数与矩阵相乘运算
用 法 MatMulConst(mata : pointer; c : real; n, m : integer)
说 明 mata为指定的矩阵，无类型指针变量
c为指定的常数
n为矩阵的行数
m为矩阵的列数
9.MatMul过程
功 能 矩阵相乘运算
用 法 MatMul(mata,matb,matc : pointer; n,m,o : integer)
说 明 mata，matb为指定的矩阵，无类型指针变量
matc为mata和matb相乘的结果矩阵，无类型指针变量
n为矩阵mata的行数
m为矩阵mata的列数，矩阵matb的行数
o为矩阵matb的列数
10.MatTran过程
功 能 矩阵转置运算
用 法 MatTran(mata,matb : pointer; n,m : integer)
说 明 mata为指定的矩阵,无类型指针变量
matb为转置矩阵，无类型指针变量
n为矩阵mata的行数
m为矩阵mata的列数
11.MatInv过程
功 能 求逆矩阵运算
用 法 MatInv(mata,matb : pointer; n : integer)
说 明 mata为指定的方阵，无类型指针变量
matb为逆矩阵，无类型指针变量
n为矩阵mata的阶数
12.DetEval函数
功 能 求指定方阵对应行列式的值
用 法 DetEval(mata : pointer; n : integer)
结果类型 实型
说 明 mata为指定的方阵，无类型指针变量
n为方阵mata的阶数
返 回 值 行列式的值
§2.9.2 MATRIX的使用
MATRDEMO.PAS演示了MATRIX单元部分过程的使用。该程序中用MATRIX单元提供的过程构造了一个通用的求解线性方程组的过程LinEquSol,读者可以仿此过程构造自己的程序。
§2.9.3 源程序清单
程序1:MATRIX.PAS
{***********************************}
{ UNIT : MATRIX }
{ Matrix procedure unit }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{***********************************}
unit matrix;
{ This unit includes 12 subroutines on Matrix. You }
{ can use it to do your work. }
interface
const
MaxNumMatElement = 10000;
type
MatElementType = real;
MaxMatType = array[1..MaxNumMatElement] of MatElementType;
MaxMatPtr = ^MaxMatType;
function MatMaxElement(mata:pointer;n,m:integer):real;
procedure MatZero(mata : pointer ; n,m : integer);
procedure MatCon(mata : pointer ; n,m : integer);
procedure MatIdn(mata : pointer ; n : integer);
procedure MatEqual(mata,matb : pointer; n,m : integer);
procedure MatAdd(mata,matb,matc : pointer; n,m : integer);
procedure MatSub(mata,matb,matc : pointer; n,m : integer);
procedure MatMulConst(mata : pointer; c : real; n, m : integer);
procedure MatMul(mata,matb,matc : pointer; n,m,o : integer);
procedure MatTran(mata,matb : pointer; n,m : integer);
procedure MatInv(mata,matb : pointer; n : integer);
function DetEval(mata : pointer; n : integer):real;
implementation
function MatMaxElement;
var p1 : MaxMatPtr;
i,j : integer;
max : real;
begin
p1 := mata;
max := 0;
for i := 1 to n do
for j := 1 to m do
if abs(p1^[(i-1) *m + j]) > max
then max := abs(p1^[(i-1) *m + j]);
MatMaxElement := max;
end;
procedure MatAdd;
var p1,p2,p3 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
p2 := matb;
p3 := matc;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p3^[l1] := p1^[l1] + p2^[l1];
end;
end;
procedure MatSub;
var p1,p2,p3 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
p2 := matb;
p3 := matc;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p3^[l1] := p1^[l1] - p2^[l1];
end;
end;
procedure MatMul;
var p1,p2,p3 : MaxMatPtr;
i,j,k,l1,l2,l3 : integer;
begin
p1 := mata;
p2 := matb;
p3 := matc;
for i := 1 to n*o do p3^[i] := 0;
for i := 1 to n do
for j := 1 to m do
for k := 1 to o do
begin
l1 := (i-1) * m + j;
l2 := (j-1) * o + k;
l3 := (i-1) * o + k;
p3^[l3] := p3^[l3] + p1^[l1] * p2^[l2];
end;
end;
procedure MatTran;
var p1,p2 : MaxMatPtr;
i,j,l1,l2 : integer;
begin
p1 := mata;
p2 := matb;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
l2 := (j-1) * n + i;
p2^[l2] := p1^[l1];
end;
end;
procedure MatEqual;
var p1,p2 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
p2 := matb;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p2^[l1] := p1^[l1];
end;
end;
procedure MatZero;
var p1 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p1^[l1] := 0;
end;
end;
procedure MatCon;
var p1 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p1^[l1] := 1;
end;
end;
procedure MatIdn;
var p1 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
for i := 1 to n do
for j := 1 to n do
begin
l1 := (i-1) * n + j;
if i = j then p1^[l1] := 1
else p1^[l1] := 0;
end;
end;
procedure MatMulConst;
var p1 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p1^[l1] := c * p1^[l1];
end;
end;
procedure MatInv;
var p1,p2 : MaxMatPtr;
i,j,k : integer;
w,s : real;
(****************************************************)
procedure trans(n1,n2:integer);
var i,j : integer;
begin
for i := n1 to n2 do
begin
s := p2^[i] / w;
for j := 1 to k -1 do
p1^[(i - 1) * n + j] := p1^[(i - 1) * n + j]
- s * p1^[(k - 1) * n + j];
if i = k then p1^[(i - 1) * n + k] := 1 - s
else p1^[(i - 1) * n + k] := - s;
end;
end; { **** end trans **** }
(****************** begin MatInv **********************)
begin
matequal(mata,matb,n,n);
p1 := matb;
getmem(p2 , n * n * SizeOf(MatElementType));
for i := 1 to n do
p1^[(i - 1) * n + i] := p1^[(i - 1) * n + i] - 1;
for k := 1 to n do
begin
for i := 1 to n do
begin
if i < k then w := 0
else w := p1^[(i - 1) * n + k];
for j := 1 to k - 1 do
w := w + p1^[(i - 1) * n + j]
* p1^[(j - 1) * n + k];
p2^[i] := w;
end;
w := p2^[k] + 1;
trans(k + 1 , n);
trans(1 , k);
end;
freemem(p2,n * n * SizeOf(MatElementType));
end; { ****** end MatInv ****** }
function DetEval;
var p1,p2 : MaxMatPtr;
i,j,k,l : integer;
p,t,u : real;
label out;
begin
p1 := mata;
getmem(p2,n * n * SizeOf(MatElementType));
for i := 1 to n do
begin
u := 0;
for j := 1 to n do
if abs(p1^[(i-1)*n+j]) > u
then u := abs(p1^[(i-1)*n+j]);
if u < 10e-20 then
begin
deteval := 0;
goto out;
end;
p2^[i] := u;
if u <> 1 then
for j := 1 to n do
p1^[(i-1)*n+j] := p1^[(i-1)*n+j] / u;
end;
p := 1;
for k := 1 to n -1 do
begin
l := k;
t := abs(p1^[(k-1)*n+k]);
for j := k + 1 to n do
if t< abs(p1^[(k-1)*n+j]) then
begin
t := abs(p1^[(k-1)*n+j]);
j := j;
end;
if t < 10e-20 then
begin
deteval := 0;
goto out;
end;
if l <> k then
begin
p := -p;
for i := k to n do
begin
t := p1^[(i-1)*n+k];
p1^[(i-1)*n+k] := p1^[(i-1)*n+l];
p1^[(i-1)*n+l] := t;
end;
end;
p := p * p1^[(k-1)*n+k];
for i := k+1 to n do
begin
t := p1^[(i-1)*n+k] / p1^[(k-1)*n+k];
for j := k + 1 to n do
p1^[(i-1)*n+j] := p1^[(i-1)*n+j]
- p1^[(k-1)*n+j] * t;
end;
end;
t := p * p1^[n*n];
for k := 1 to n do t := t * p2^[k];
deteval := t;
out:
freemem(p2,n * n * SizeOf(MatElementType));
end;
end.
程序2:MATRDEMO.PAS
{-----------------------------------}
{ MATRDEMO.PAS }
{ Demonstrates the usage of MATRIX }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{-----------------------------------}
Program MatrixDemo;
uses Astr,Matrix;
const
Mn = 3;
Mm = 1;
m1 : array[1..Mn,1..Mn] of MatElementType = ((1,1,1),(1,-1,1),(1,1,-1));
m2 : array[1..Mn,1..Mm] of MatElementType = ((5),(6),(4));
var
m3 : array[1..Mn,1..Mm] of MatElementType;
i,j : integer;
procedure LinEquSol(mata,matb,matc:pointer;n,m:integer);
var
p1,p2,p3,p4 : MaxMatPtr;
begin
p1 := mata;
p2 := matb;
p3 := matc;
getmem(p4,n*n*Sizeof(MatElementType));
MatInv(p1,p4,n);
MatMul(p4,p2,p3,n,n,m);
freemem(p4,n*n*Sizeof(MatElementType));
end;
begin
Writeln('This is a demonstration program for MATRIX unit');
Writeln('Linear Equation:');
for i := 1 to Mn do
begin
for j := 1 to Mn - 1 do
Write('(',RealToStr(m1[i,j],2,0),')',chr(119+j),'+');
inc(j);
Write('(',RealToStr(m1[i,j],2,0),')',chr(119+j),'=');
Writeln(RealToStr(m2[i,1],2,0));
end;
LinEquSol(@m1,@m2,@m3,Mn,Mm);
Writeln('Solution:');
for i := 1 to Mn do
Writeln(Space(5),chr(119+i),'=',RealToStr(m3[i,1],4,1));
writeln;
end.
§2.10 概率分布函数单元PROB
本单元给出了各种常用的概率分布,如F分布、t分布、X攩2攪分布的概率累积函数，使概率统计分析中的统计检验过程变得简单易行，且十分容易自动化。
§2.10.1 PROB单元定义的函数
1.Finv函数
功 能 根据给定的α值和自由度值求对应的F值
用 法 Finv( Alpha, Dfn, Dfe: real )
结果类型 实型
说 明 Alpha为显著性概率,Dfn,Dfe为F分布的自由度
返 回 值 F值
2.SigF函数
功 能 根据给定的自由度和F值计算出其概率值
用 法 SigF( F , Dfn , Dfd : real )
结果类型 实型
说 明 F为欲求其概率值的F值,Dfn和Dfd为F分布的自由度值
返 回 值 概率值
3.tinv函数
功 能 根据给定的α值和自由度值求对应的t值
用 法 tinv( Alpha, Df: real )
结果类型 实型
说 明 Alpha为显著性概率,Df为t分布的自由度
返 回 值 t值
4.Sigt函数
功 能 根据给定的自由度和t值计算出其概率值
用 法 Sigt( t , Df : real )
结果类型 实型
说 明 t为欲求其概率的值,Df为t分布的自由度
返 回 值 概率值
5.SigChi函数
功 能 根据给定的自由度和X攩2攪值计算出其概率值
用 法 SigChi( Chisq , Df : real )
结果类型 实型
说 明 Chisq为欲求其概率的数值,Df为X攩2攪分布的自由度
返 回 值 概率值
§2.10.2 PROB单元的使用
PROBDEMO.PAS演示了PROB单元的Finv函数的使用,它打印df1和df2的自由度均在100以内的F分布的F值表。
§2.10.3 源程序清单
程序1: PROB.PAS
{************************************}
{ UNIT : PROB }
{ Written by Dong Zhanshan }
{ Version : Oct. 1991 }
{************************************}
{$N+,E+}
unit Prob;
interface
uses math;
Function Finv( Alpha, Dfn, Dfe: real ) : real;
Function Sigt( t , Df : real ) : real;
Function tinv( Alpha, Df: real ) : real;
Function SigF( F , Dfn , Dfd : real ) : real;
Function SigChi( Chisq , Df : real ) : real;
implementation
CONST
PI = 3.141592653589793 { Math constant PI };
Xln2sp = 9.18938533204673E-01 { LogE( Sqrt( 2 * PI ) ) };
Rmax = 1.67E+37 { Maximum flt pt number };
Rsmall = 4.19E-37 { Smallest flt pt number };
Rinf = 1.67E+37 { Machine "infinity" };
Zeta = 1.0E-16 { Approx. machine prec. };
MaxPrec = 16 { Max. precision };
Sqrt2 = 1.4142135623730950 { Square root of 2 };
LnTenInv = 0.4342944819032520 { 1 / LN(10) };
LnTwo = 0.6931471805599450 { LN(2) };
Function Erf( Z : real ) : real;
CONST
A: ARRAY[1..14] OF real =
( 1.1283791670955,0.34197505591854,0.86290601455206E-1,
0.12382023274723E-1,0.11986242418302E-2,0.76537302607825E-4,
0.25365482058342E-5,-0.99999707603738,-1.4731794832805,
-1.0573449601594,-0.44078839213875,-0.100684197950781,
-0.12636031836273E-1,-0.1149393366616E-88 );
B: ARRAY[1..12] OF real =
( -0.36359916427762,0.52205830591727E-1,-0.30613035688519E-2,
-0.46856639020338E-4,0.15601995561434E-44,-0.62143556409287E-6,
2.6015349994799,2.9929556755308,1.9684584582884,
0.79250795276064,0.18937020051337,0.22396882835053E-1 );
VAR
U,X,S : real;
begin { Erf }
X := ABS( Z );
IF Z >= 0.0 THEN S := 1.0
ELSE S := -1.0;
IF ( Z = 0.0 ) THEN Erf := 0.0
ELSE IF( X >= 5.5 ) THEN Erf := S
ELSE
begin
U := X * X;
IF( X <= 1.5 ) THEN
Erf := ( X * EXP( -U ) * ( A[1] + U * ( A[2] + U *
( A[3] + U * ( A[4] + U * ( A[5] + U *
( A[6] + U * A[7] ) ) ) ) ) ) / ( 1.0 + U *
( B[1] + U * ( B[2] + U * ( B[3] + U *
( B[4] + U * ( B[5] + U * B[6] ) ) ) ) ) ) ) * S
ELSE
Erf := ( EXP( -U ) * ( A[8] + X * ( A[9] + X *
( A[10] + X * ( A[11] + X * ( A[12] + X *
( A[13] + X * A[14] ) ) ) ) ) ) / ( 1.0 + X *
( B[7] + X * ( B[8] + X * ( B[9] + X *
( B[10] + X * ( B[11] + X * B[12] ) ) ) ) ) ) + 1.0 ) * S;
end;
end { Erf };
Function ALGama( Arg : real ) : real;
CONST
P : ARRAY [ 1 .. 29 ] OF real =
( 4.12084318584770E+00 , 8.56898206283132E+01 , 2.43175243524421E+02 ,
-2.61721858385614E+02 , -9.222613728801552E+02 , -5.17638349802321E+02 ,
-7.74106407133295E+01 , -2.208843997216118E+00 , 5.15505761764082E+00 ,
3.77510679797217E+02 , 5.26898325591498E+03 , 1.95536055406304E+04 ,
1.20431738098716E+04 , -2.06482942053253E+04 , -1.50863022876672E+04 ,
-1.51383183411507E+03 , -1.037701651732998E+04 , -9.82710228142049E+05 ,
-1.97183011586092E+07 , -8.731675438238339E+07 , 1.11938535429986E+08 ,
4.81807710277363E+08 , -2.44832176903288E+08 , -2.40798698017337E+08 ,
8.06588089900001E-04 , -5.94997310888900E-04 , 7.93650067542790E-04 ,
-2.77777777688189E-03 , 8.333333333333300E-02 );
Q : ARRAY [ 1 .. 24 ] OF real =
( 1.00000000000000E+00 , 4.56467718758591E+01 , 3.77837248482394E+02 ,
9.51323597679706E+02 , 8.46075536202078E+02 , 2.62308347026946E+02 ,
2.44351966250631E+01 , 4.09779292109262E-01 , 1.00000000000000E+00 ,
1.28909318901296E+02 , 3.03990304143943E+03 , 2.20295621441566E+04 ,
5.71202553960250E+04 , 5.26228638384119E+04 , 1.44020903717009E+04 ,
6.98327414057351E+02 , 1.00000000000000E+00 , -2.01527519550048E+03 ,
-3.11406284734067E+05 , -1.048577583049994E+07 , -1.11925411626332E+08 ,
-4.04435928291436E+08 , -4.353707148043774E+08 , -7.90261111418763E+07);
VAR
Rarg,Alinc,Scale,Top,Bot,Frac,Algval : real;
I,Iapprox,Iof,Ilo,Ihi : integer;
Qminus,Qdoit : BOOLEAN;
begin { ALGama }
Algval := Rinf;
Scale := 1.0;
Alinc := 0.0;
Frac := 0.0;
Rarg := Arg;
Iof := 1;
Qminus := FALSE;
Qdoit := TRUE;
IF( Rarg < 0.0 ) THEN
begin
Qminus := TRUE;
Rarg := -Rarg;
Top := Int( Rarg );
Bot := 1.0;
IF( ( INT( Top / 2.0 ) * 2.0 ) = 0.0 ) THEN Bot := -1.0;
Top := Rarg - Top;
IF( Top = 0.0 ) THEN
Qdoit := FALSE
ELSE
begin
Frac := Bot * PI / SIN( Top * PI );
Rarg := Rarg + 1.0;
Frac := LN( ABS( Frac ) );
end;
end;
IF( Rarg = 0.0 ) THEN Qdoit := FALSE
ELSE IF( Rarg <= 0.5 ) THEN
begin
Alinc := -LN( Rarg );
Scale := Rarg;
Rarg := Rarg + 1.0;
IF( Scale < Zeta ) THEN
begin
Algval := Alinc;
Qdoit := FALSE;
end;
end
ELSE IF ( Rarg <= 1.5 ) THEN Scale := Rarg - 1.0
ELSE IF( Rarg <= 4.0 ) THEN
begin
Scale := Rarg - 2.0;
Iof := 9;
end
ELSE IF( Rarg <= 12.0 ) THEN Iof := 17
ELSE IF( Rarg <= RMAX ) THEN
begin
Alinc := ( Rarg - 0.5 ) * LN( Rarg ) - Rarg + Xln2sp;
Scale := 1.0 / Rarg;
Rarg := Scale * Scale;
Top := P[ 25 ];
FOR I := 26 TO 29 DO Top := Top * Rarg + P[ I ];
Algval := Scale * Top + Alinc;
Qdoit := FALSE;
end;
IF Qdoit THEN
begin
Ilo := Iof + 1;
Ihi := Iof + 7;
Top := P[ Iof ];
Bot := Q[ Iof ];
FOR I := Ilo TO Ihi DO
begin
Top := Top * Rarg + P[ I ];
Bot := Bot * Rarg + Q[ I ];
end;
Algval := Scale * ( Top / Bot ) + Alinc;
end;
IF( Qminus ) THEN Algval := Frac - Algval;
ALGama := Algval;
end { ALGama };
Function CDBeta( X, Alpha, Beta: real; Dprec, MaxIter : integer;
VAR Cprec : real; VAR Iter, Ifault : integer ) : real;
VAR
Epsz,A,B,C,F,Fx,Apb,Zm,Alo,Ahi,Blo,Bhi,Bod,Bev,Zm1,D1,Aev,Aod : real;
Ntries : integer;
Qswap,Qdoit,Qconv : BOOLEAN;
LABEL 20, 9000;
begin { CdBeta }
IF Dprec > MaxPrec THEN Dprec := MaxPrec
ELSE IF Dprec <= 0 THEN Dprec := 1;
Cprec := Dprec;
Epsz := Power(10, -Dprec );
X := X;
A := Alpha;
B := Beta;
QSwap := FALSE;
CDBeta := -1.0;
Qdoit := TRUE;
Ifault := 1;
IF( X <= 0.0 ) THEN GOTO 9000;
IF( ( A <= 0.0 ) OR ( B <= 0.0 ) ) THEN GOTO 9000;
CDBeta := 1.0;
Ifault := 0;
IF( X >= 1.0 ) THEN GOTO 9000;
IF( X > ( A / ( A + B ) ) ) THEN
begin
X := 1.0 - X;
A := Beta;
B := Alpha;
QSwap := TRUE;
end;
IF( ( X = A ) OR ( X = B ) ) THEN GOTO 20;
IF( A = ( ( B * X ) / ( 1.0 - X ) ) ) THEN GOTO 20;
IF( ABS( A - ( X * ( A + B ) ) ) <= Epsz ) THEN GOTO 20;
C := ALGama( A + B ) + A * LN( X ) +
B * LN( 1.0 - X ) - ALGama( A ) - ALGama( B ) -
LN( A - X * ( A + B ) );
IF( ( C < -36.0 ) AND QSwap ) THEN GOTO 9000;
CDBeta := 0.0;
IF( C < -180.0 ) THEN GOTO 9000;
20:
Apb := A + B;
Zm := 0.0;
Alo := 0.0;
Bod := 1.0;
Bev := 1.0;
Bhi := 1.0;
Blo := 1.0;
Ahi := EXP( ALGama( Apb ) + A * LN( X ) +
B * LN( 1.0 - X ) - ALGama( A + 1.0 ) -
ALGama( B ) );
F := Ahi;
Iter := 0;
Qconv := FALSE;
REPEAT
Fx := F;
Zm1 := Zm;
Zm := Zm + 1.0;
D1 := A + Zm + Zm1;
Aev := -( A + Zm1 ) * ( Apb + Zm1 ) * X / D1 / ( D1 - 1.0 );
Aod := Zm * ( B - Zm ) * X / D1 / ( D1 + 1.0 );
Alo := Bev * Ahi + Aev * Alo;
Blo := Bev * Bhi + Aev * Blo;
Ahi := Bod * Alo + Aod * Ahi;
Bhi := Bod * Blo + Aod * Bhi;
IF ABS( Bhi ) < Rsmall THEN Bhi := 0.0;
IF( Bhi <> 0.0 ) THEN
begin
F := Ahi / Bhi;
Qconv := ( ABS( ( F - Fx ) / F ) < Epsz );
end;
inc(Iter);
UNTIL ( ( Iter > MaxIter ) OR Qconv ) ;
IF ( Qswap ) THEN CDBeta := 1.0 - F
ELSE CDBeta := F;
IF ABS( F - Fx ) <> 0.0 THEN Cprec := -log(10, ABS( F - Fx ) )
ELSE Cprec := MaxPrec;
9000: { Error exit }
end; { CDBeta }
Function Ninv( P : real ) : real;
const
Lim = 1.0E-20;
PN : ARRAY[1..5] OF real =
( -0.322232431088 , -1.0 , -0.342242088547 ,
-0.0204231210245 , -0.453642210148E-4 );;
QN : ARRAY[1..5] OF real =
( 0.0993484626060 , 0.588581570495 , 0.531103462366 ,
0.103537752850 , 0.38560700634E-2 );
VAR
Y,Pr,Nv: real;
begin { Ninv }
Ninv := 0.0;
IF( P > 0.5 ) THEN Pr := 1.0 - P
ELSE Pr := P;
IF( ( Pr >= Lim ) AND ( Pr <> 0.5 ) ) THEN
begin
Y := SQRT ( LN( 1.0 / Pr / Pr ) );
Nv := Y + ((((Y * PN[ 5 ] + PN[ 4 ]) * Y + PN[ 3 ] ) * Y
+ PN[ 2 ]) * Y + PN[ 1 ] ) /
((((Y * QN[ 5 ] + QN[ 4 ]) * Y + QN[ 3 ] ) * Y
+ QN[ 2 ]) * Y + QN[ 1 ] );
IF( P < 0.5 ) THEN Ninv := -Nv
ELSE Ninv := Nv;
end;
end; { Ninv }
Function BetaInv( P, Alpha, Beta : real; MaxIter,Dprec :integer;
VAR Iter : integer; VAR Cprec : real;
VAR Ierr : integer ) : real;
VAR
Eps,Xim1,Xi,Xip1,Fim1,Fi,W,Cmplbt,Adj,Sq,R,
S,T,G,A,B,PP,H,A1,B1,Eprec : real;
Done : BOOLEAN;
Jter : integer;
LABEL 10, 30, 9000;
begin { BetaInv }
Ierr := 1;
BetaInv := P;
IF( ( Alpha <= 0.0 ) OR ( Beta <= 0.0 ) ) THEN GOTO 9000;
IF( ( P > 1.0 ) OR ( P < 0.0 ) ) THEN GOTO 9000;
IF( ( P = 0.0 ) OR ( P = 1.0 ) ) THEN
begin
Iter := 0;
Cprec := MaxPrec;
GOTO 9000;
end;
IF Dprec > MaxPrec THEN Dprec := MaxPrec
ELSE IF Dprec <= 0 THEN Dprec := 1;
Cprec := Dprec;
Eps := power(10, -2 * Dprec );
IF( P > 0.5 ) THEN
begin
A := Beta;
B := Alpha;
PP := 1.0 - P;
end
ELSE
begin
A := Alpha;
B := Beta;
PP := P;
end;
Ierr := 0;
Cmplbt := ALGama( A ) + ALGama( B ) - ALGama( A + B );
Fi := Ninv( 1.0 - PP );
IF( ( A > 1.0 ) AND ( B > 1.0 ) ) THEN
begin
R := ( Fi * Fi - 3.0 ) / 6.0;
S := 1.0 / ( A + A - 1.0 );
T := 1.0 / ( B + B - 1.0 );
H := 2.0 / ( S + T );
W := Fi * SQRT( H + R ) / H - ( T - S ) *
( R + 5.0 / 6.0 - 2.0 / ( 3.0 * H ) );
Xi := A / ( A + B * EXP( W + W ) );
end
ELSE
begin
R := B + B;
T := 1.0 / ( 9.0 * B );
T := R * Power( ( 1.0 - T + Fi * SQRT( T ) ) , 3 );
IF( T <= 0.0 ) THEN
Xi := 1.0 - EXP( ( LN( ( 1.0 - PP ) * B ) + Cmplbt ) / B )
ELSE
begin
T := ( 4.0 * A + R - 2.0 ) / T;
IF( T <= 1.0 ) THEN
Xi := EXP( (LN( PP * A ) + Cmplbt) / PP )
ELSE
Xi := 1.0 - 2.0 / ( T + 1.0 );
end;
end;
IF ( Xi < 0.0001 ) THEN Xi := 0.0001;
IF ( Xi > 0.9999 ) THEN Xi := 0.9999;
A1 := 1.0 - A;
B1 := 1.0 - B;
Fim1 := 0.0;
Sq := 1.0;
Xim1 := 1.0;
Iter := 0;
Done := FALSE;
REPEAT
Iter := Iter + 1;
Done := Done OR ( Iter > MaxIter );
Fi := CDBeta( Xi, A, B, Dprec+1, MaxIter, Eprec, Jter, Ierr );
IF( Ierr <> 0 ) THEN
begin
Ierr := 2;
Done := TRUE;
end
ELSE
begin
Fi := ( Fi - PP ) * EXP( Cmplbt + A1 * LN( Xi ) +
B1 * LN( 1.0 - Xi ) );
IF( ( Fi * Fim1 ) <= 0.0 ) THEN Xim1 := Sq;
G := 1.0;
10: REPEAT
Adj := G * Fi;
Sq := Adj * Adj;
IF( Sq >= Xim1 ) THEN G := G / 3.0;
UNTIL( Sq < Xim1 );
Xip1 := Xi - Adj;
IF( ( Xip1 < 0.0 ) OR ( Xip1 > 1.0 ) ) THEN
begin
G := G / 3.0;
GOTO 10;
end;
IF( Xim1 <= Eps ) THEN GOTO 30;
IF( Fi * Fi <= Eps ) THEN GOTO 30;
IF( ( Xip1 = 0.0 ) OR ( Xip1 = 1.0 ) ) THEN
begin
G := G / 3.0;
GOTO 10;
end;
IF( Xip1 <> Xi ) THEN
begin
Xi := Xip1;
Fim1 := Fi;
end
ELSE
Done := TRUE;
end;
UNTIL( Done );
30:
BetaInv := Xi;
IF( P > 0.5 ) THEN BetaInv := 1.0 - Xi;
IF ABS( Xi - Xim1 ) <> 0.0 THEN
Cprec := -Log(10,ABS( Xi - Xim1 ) )
ELSE
Cprec := MaxPrec;
9000:
IF Ierr <> 0 THEN BetaInv := -1.0;
end; { BetaInv }
Function Finv( Alpha, Dfn, Dfe: real ) : real;
CONST
MaxIter = 100;
Dprec = 10;
VAR
Fin,Cprec : real;
Iter,Ierr : integer;
begin { Finv }
Fin := -1.0;
IF( ( Dfn > 0.0 ) AND ( Dfe > 0.0 ) ) THEN
IF( ( Alpha >= 0.0 ) AND ( Alpha <= 1.0 ) ) THEN
begin
Fin := BetaInv( 1.0 - Alpha, Dfn/2.0, Dfe/2.0, MaxIter, Dprec,
Iter, Cprec, Ierr );
IF( ( Fin >= 0.0 ) AND ( Fin < 1.0 ) AND ( Ierr = 0 ) ) THEN
Fin := Fin * Dfe / ( Dfn * ( 1.0 - Fin ) );
end;
Finv := Fin;
end; { Finv }
Function Sigt( t , Df : real ) : real;
CONST
Dprec = 12;
MaxIter = 200;
VAR
Iter,Ifault : integer;
Pval, Cprec : real;
begin { Sigt }
Pval := -1.0;
IF( Df > 0.0 ) THEN
begin
Pval := CDBeta( Df / ( Df + t * t ), Df / 2.0, 0.5,
Dprec, MaxIter, Cprec, Iter, Ifault );
IF Ifault <> 0 THEN Pval := -1.0;
end;
Sigt := Pval;
end { Sigt };
Function tinv( Alpha, Df: real ) : real;
CONST
MaxIter = 100;
Dprec = 10;
VAR
tin,Cprec : real;
Iter,Ierr : integer;
begin { tinv }
Alpha := 1 - Alpha;
tin := -1.0;
IF( Df > 0.0 ) THEN
IF( ( Alpha >= 0.0 ) AND ( Alpha <= 1.0 ) ) THEN
begin
tin := BetaInv( Alpha, 0.5, Df / 2.0, MaxIter, Dprec,
Iter, Cprec, Ierr );
IF( ( tin >= 0.0 ) AND ( tin < 1.0 ) AND ( Ierr = 0 ) ) THEN
tin := SQRT( tin * Df / ( 1.0 - tin ) );
end;
tinv := tin;
end { tinv };
Function GammaIn( Y, P : real; Dprec, MaxIter : integer;
VAR Cprec : real; VAR Iter : integer;
VAR Ifault : integer ) : real;
CONST
Oflo = 1.0E+37;
MinExp = -87.0;
VAR
F,C,A,B,Term,Gin,An,Rn,Dif,Eps : real;
Pn : ARRAY[1..6] OF real;
Done : BOOLEAN;
LABEL 9000;
begin { GammaIn }
Ifault := 1;
GammaIn := 1.0;
IF( ( Y <= 0.0 ) OR ( P <= 0.0 ) ) THEN GOTO 9000;
Ifault := 0;
F := P * LN( Y ) - ALGama( P + 1.0 ) - Y;
IF ( F < MinExp ) THEN GOTO 9000;
F := EXP( F );
IF( F = 0.0 ) THEN GOTO 9000;
IF Dprec > MaxPrec THEN Dprec := MaxPrec
ELSE IF Dprec <= 0 THEN Dprec := 1;
Cprec := Dprec;
Eps := power(10, -Dprec );
IF( ( Y > 1.0 ) AND ( Y >= P ) ) THEN
begin { Continued Fraction }
A := 1.0 - P;
B := A + Y + 1.0;
Term := 0.0;
Pn[ 1 ] := 1.0;
Pn[ 2 ] := Y;
Pn[ 3 ] := Y + 1.0;
Pn[ 4 ] := Y * B;
Gin := Pn[ 3 ] / Pn[ 4 ];
Done := FALSE;
Iter := 0;
REPEAT
Iter := Iter + 1;
A := A + 1.0;
B := B + 2.0;
Term := Term + 1.0;
An := A * Term;
Pn[ 5 ] := B * Pn[ 3 ] - An * Pn[ 1 ];
Pn[ 6 ] := B * Pn[ 4 ] - An * Pn[ 2 ];
IF( Pn[ 6 ] <> 0.0 ) THEN
begin
Rn := Pn[ 5 ] / Pn[ 6 ];
Dif := ABS( Gin - Rn );
IF( Dif <= Eps ) THEN
IF( Dif <= ( Eps * Rn ) ) THEN Done := TRUE;
Gin := Rn;
end;
Pn[ 1 ] := Pn[ 3 ];
Pn[ 2 ] := Pn[ 4 ];
Pn[ 3 ] := Pn[ 5 ];
Pn[ 4 ] := Pn[ 6 ];
IF( ABS( Pn[ 5 ] ) >= Oflo ) THEN
begin
Pn[ 1 ] := Pn[ 1 ] / Oflo;
Pn[ 2 ] := Pn[ 2 ] / Oflo;
Pn[ 3 ] := Pn[ 3 ] / Oflo;
Pn[ 4 ] := Pn[ 4 ] / Oflo;
end;
UNTIL ( Iter > MaxIter ) OR Done;
Gin := 1.0 - ( F * Gin * P );
GammaIn := Gin;
IF Dif <> 0.0 THEN Cprec := -Log(10,Dif )
ELSE Cprec := MaxPrec;
end
ELSE
begin { Infinite series }
Iter := 0;
Term := 1.0;
C := 1.0;
A := P;
Done := FALSE;
REPEAT
A := A + 1.0;
Term := Term * Y / A;
C := C + Term;
Iter := Iter + 1;
UNTIL ( Iter > MaxIter ) OR ( ( Term / C ) <= Eps );
GammaIn := C * F;
Cprec := -Log(10,Term / C );
end;
9000: { Error exit }
end; { GammaIn }
Function SigChi( Chisq , Df : real ) : real;
CONST
MaxIter = 200;
Dprec = 12;
VAR
Ierr,Iter : integer;
Cprec: real;
begin { SigChi }
SigChi := 1.0 - GammaIn( Chisq / 2.0, Df / 2.0, Dprec, MaxIter,
Cprec, Iter, Ierr );
IF ( Ierr <> 0 ) THEN SigChi := -1.0;
end; { SigChi }
Function Cinv( P, V: real; VAR Ifault: integer ) : real;
CONST
E = 1.0E-8;
Dprec = 8;
MaxIter = 100;
VAR
XX,C,Ch,Q,P1,P2,T,X,B,A,G,S1,S2,S3,S4,S5,S6,Cprec : real;
Iter : integer;
LABEL 9000;
begin { Cinv }
Cinv := -1.0;
Ifault := 1;
IF ( P < E ) OR ( P > ( 1.0 - E ) ) THEN GOTO 9000;
Ifault := 2;
IF( V <= 0.0 ) THEN GOTO 9000;
P := 1.0 - P;
XX := V / 2.0;
G := ALGama( XX );
Ifault := 0;
C := XX - 1.0;
IF( V < ( -1.24 * LN( P ) ) ) THEN
begin
Ch := Power( P * XX * EXP( G + XX * LnTwo ) , ( 1.0 / XX ) );
IF Ch < E THEN
begin
Cinv := Ch;
GOTO 9000;
end;
end
ELSE
IF ( V <= 0.32 ) THEN
begin
Ch := 0.4;
A := LN( 1.0 - P );
REPEAT
Q := Ch;
P1 := 1.0 + Ch * ( 4.67 + Ch );
P2 := Ch * ( 6.73 + Ch * ( 6.66 + Ch ) );
T := -0.5 + ( 4.67 + 2.0 * Ch ) / P1 -
( 6.73 + Ch * ( 13.32 + 3.0 * Ch ) ) / P2;
Ch := Ch - ( 1.0 - EXP( A + G + 0.5 * Ch + C * LnTwo ) *
P2 / P1 ) / T;
UNTIL( ABS( Q / Ch - 1.0 ) <= 0.01 );
end
ELSE
begin
X := Ninv( P );
P1 := 2.0 / ( 9.0 * V );
Ch := V * power( ( X * SQRT( P1 ) + 1.0 - P1 ) , 3 );
IF ( Ch > ( 2.2 * V + 6.0 ) ) THEN
Ch := -2.0 * ( LN( 1.0 - P ) - C * LN( 0.5 * Ch ) + G );
end;
REPEAT
Q := Ch;
P1 := 0.5 * Ch;
P2 := P - GammaIn( P1, XX, Dprec, MaxIter, Cprec, Iter, Ifault );
IF( Ifault <> 0 ) OR ( Iter > MaxIter ) THEN
Ifault := 3
ELSE
begin
T := P2 * EXP( XX * LnTwo + G + P1 - C * LN( Ch ) );
B := T / Ch;
A := 0.5 * T - B * C;
S1 := ( 210.0 + A * ( 140.0 + A * ( 105.0 + A * ( 84.0 + A *
( 70.0 + 60.0 * A ) ) ) ) ) / 420.0;
S2 := ( 420.0 + A * ( 735.0 + A * ( 966.0 + A * ( 1141.0 +
1278.0 * A ) ) ) ) / 2520.0;
S3 := ( 210.0 + A * ( 462.0 + A * ( 707.0 + 932.0 * A ) ) )
/ 2520.0;
S4 := ( 252.0 + A * ( 672.0 + 1182.0 * A ) + C * ( 294.0 + A *
( 889.0 + 1740.0 * A ) ) ) / 5040.0;
S5 := ( 84.0 + 264.0 * A + C * ( 175.0 + 606.0 * A ) ) / 2520.0;
S6 := ( 120.0 + C * ( 346.0 + 127.0 * C ) ) / 5040.0;
Ch := Ch + T * ( 1.0 + 0.5 * T * S1 - B * C * ( S1 - B *
( S2 - B * ( S3 - B * ( S4 - B * ( S5 - B * S6 ) ) ) ) ) );
end;
UNTIL ( ABS( ( Q / Ch ) - 1.0 ) <= E ) OR ( Ifault <> 0 );
IF Ifault = 0 THEN Cinv := Ch
ELSE Cinv := -1.0;
9000: ;
end; { Cinv }
Function SigF( F , Dfn , Dfd : real ) : real;
CONST
Dprec = 12;
MaxIter = 200;
VAR
Iter,Ifault : integer;
Pval,Cprec : real;
begin { SigF }
Pval := -1.0;
IF ( Dfn > 0.0 ) AND ( Dfd > 0.0 ) THEN
begin
Pval := CDBeta( Dfd / ( Dfd + F * Dfn ), Dfd / 2.0, Dfn / 2.0,
Dprec, MaxIter, Cprec, Iter, Ifault );
IF Ifault <> 0 THEN Pval := -1.0;
end;
SigF := Pval;
end { SigF };
Function CDNorm( X : real ) : real;
begin { CDNorm }
IF X >= 0.0 THEN CDNorm := ( 1.0 + Erf( X / Sqrt2 ) ) / 2.0
ELSE CDNorm := ( 1.0 - Erf( -X / Sqrt2 ) ) / 2.0;
end; { CDNorm }
Function SigNorm( X : real ) : real;
begin { SigNorm }
IF X >= 0.0 THEN SigNorm := 1.0 - ( 1.0 + Erf( X / Sqrt2 ) ) / 2.0
ELSE SigNorm := 1.0 - ( 1.0 - Erf( -X / Sqrt2 ) ) / 2.0;
end; { SigNorm }
Function Ninv2( P : real ) : real;
VAR
Xp,P1,Z,X3,X2,X1,Phi : real;
begin { Ninv2 }
Xp := Ninv( P );
P1 := SigNorm( Xp );
Phi := SQRT( 1.0 / ( 2.0 * PI ) ) * EXP( -( Xp * Xp ) / 2.0 );
Z := ( P - P1 ) / Phi;
X3 := ( 2.0 * ( Xp * Xp ) + 1.0 ) * Z / 3.0;
X2 := ( X3 + Xp ) * Z / 2.0;
X1 := ( ( X2 + 1.0 ) * Z );
Ninv2 := Xp + X1;
end; { Ninv2 }
end.
程序2: PROBDEMO.PAS
{-----------------------------------}
{ PROBDEMO.PAS }
{ Demonstrates the usage of PROB }
{ Written by Dong Zhanshan }
{ Version : Aug. 1994 }
{-----------------------------------}
{$N+,E+}
program ProbDemo;
uses Prob;
var i,j,k : integer;
x,y,z : real;
begin
k := 0;
for i := 1 to 100 do
for j := 1 to 100 do
begin
inc(k);
write(Finv(0.05,i,j):9:3,'[',i:3,',',j:3,']');
if k = 4 then
begin
k := 0;
writeln;
end;
end;
end.
§2.11 复数运算单元COMPLEX
§2.11.1 概述
在一般的PASCAL教科书中，按如下方式定义复数类型和复数运算:
Type complex = record
real_part : real;
image_part : real;
end;
procedure CAdd(x,y:complex ; var result : complex);
procedure CSub(x,y:complex ; var result : complex);
procedure CMul(x,y:complex ; var result : complex);
procedure CDiv(x,y:complex ; var result : complex);
即把复数设计为具有实部和虚部的记录类型，其运算均采用过程来完成，而不是用函数来完成，这是由于PASCAL语言本身限制的。在PASCAL语言中，一个函数的返回类型只能是基本数据类型，而不能是复合数据类型。利用上述复数运算过程，一个缺点是运算表达不明确，二是中间的辅助变量较多。
下面介绍一种使用absolute和字符串类型编写的复数运算函数的方法。
TURBO PASCAL的absolute保留字，使一个变量与某个已定义的变量共享同一内存区域，这样对同一内存单元可以采用不同的方式进行存取。
为应用absolute子句，定义下列类型:
type
complexr = record
len : byte;
rp : real;
ip : real;
end;
complexs = string[sizeof(real)*2];
这样就可以用absolute将complexr和complexs对应起来，内部运算用complexr类型，外部传递参数和函数值的返回用complexs类型。复数的运算可定义为:
function CAdd(x,y:complexr):complexs;
function CSub(x,y:complexr):complexs;
function CMul(x,y:complexr):complexs;
function CDiv(x,y:complexr):complexs;
这种定义克服了第一种定义的缺点。
§2.11.2 COMPLEX的过程和函数
该单元定义了两种新的数据类型，即complexr和complexs，complexs是COMPLEX单元的公用数据类型,complexr是COMPLEX单元的私有数据类型,还定义了5个函数和1个过程。两种新的数据类型已在上面讲过,下面介绍其过程和函数。
1.CAdd函数
功 能 执行复数加法运算
用 法 CAdd(x,y:complexr)
结果类型 complexs
说 明 x,y为complexr类型的值参
返 回 值 complexs类型的值
2.CSub函数
功 能 执行复数减法运算
用 法 CSub(x,y:complexr)
结果类型 complexs
说 明 x,y为complexr类型的值参
返 回 值 complexs类型的值
3.CMul函数
功 能 执行复数乘法运算
用 法 CMul(x,y:complexr)
结果类型 complexs
说 明 x,y为complexr类型的值参
返 回 值 complexs类型的值
4.CDiv函数
功 能 执行复数除法运算
用 法 CDiv(x,y:complexr)
结果类型 complexs
说 明 x,y为complexr类型的参数
返 回 值 complexs类型的值
5.Cplx函数
功 能 构造一个新的复数
用 法 Cplx(x,y:real)
结果类型 complexs
说 明 x,y为实型值参
返 回 值: complexs类型的值
6.OCplx过程
功 能 输出一个复数
用 法 OCplx(s: string; x: complexs)
说 明 s为字符串型值参,x为complexs类型的值参
§2.11.3 COMPLEX单元的使用
COMPDEMO.PAS程序演示了COMPLEX单元的使用。首先用CPLX函数构造了4个复数类型，然后输出它们，最后调用COMPLEX单元定义的函数对它们进行加、减、乘、除运算，并输出结果。
§2.11.4 源程序清单
程序1: COMPLEX.PAS
{************************************}
{ UNIT : COMPLEX }
{ Written by Dong Zhanshan }
{ Version : Aug. 1994 }
{************************************}
unit Complex;
interface
const
ComplexSize = SizeOf(real) * 2;
Type
Complexs = String[ComplexSize];
function CAdd(x,y : Complexs) : Complexs;
function CSub(x,y : Complexs) : Complexs;
function CMul(x,y : Complexs) : Complexs;
function CDiv(x,y : Complexs) : Complexs;
function Cplx(x,y : real) : Complexs;
procedure OCplx(s : string; x : Complexs);
implementation
Type
Complexr = record
LN : byte; { length }
RP : real; { real part }
IP : real; { image part }
end;
function CAdd;
var
t1 : complexs;
c : complexr absolute x;
d : complexr absolute y;
t2 : complexr absolute t1;
begin
t2.ln := ComplexSize;
t2.RP := c.RP + d.RP;
t2.IP := c.IP + d.IP;
CAdd := t1;
end;
function CSub;
var
t1 : complexs;
c : complexr absolute x;
d : complexr absolute y;
t2 : complexr absolute t1;
begin
t2.ln := ComplexSize;
t2.RP := c.RP - d.RP;
t2.IP := c.IP - d.IP;
CSub := t1;
end;
function CMul;
var
t1 : complexs;
c : complexr absolute x;
d : complexr absolute y;
t2 : complexr absolute t1;
begin
t2.ln := ComplexSize;
t2.RP := c.RP * d.RP - c.IP * d.IP;
t2.IP := c.IP * d.RP + c.RP * d.IP;
CMul := t1;
end;
function CDiv;
var
t1 : complexs;
c : complexr absolute x;
d : complexr absolute y;
t2 : complexr absolute t1;
p : real;
begin
t2.ln := ComplexSize;
p := d.RP * d.RP + d.IP * d.IP;
t2.RP := (c.RP * d.RP + c.IP * d.IP) / p;
t2.IP := (c.IP * d.RP - c.RP * d.IP) / p;
CDiv := t1;
end;
function Cplx;
var
t1 : complexs;
t2 : complexr absolute t1;
begin
t2.ln := ComplexSize;
t2.RP := x;
t2.IP := y;
Cplx := t1;
end;
procedure OCplx;
var
t : complexr absolute x;
begin
Writeln(s:5,' = ',t.RP:10:4,' + ',t.IP:10:4,'i');
end;
end.
程序2: COMPDEMO.PAS
{------------------------------------}
{ COMPDEMO.PAS }
{ Demonstrates the usage of COMPLEX }
{ Written by Dong Zhanshan }
{ Version : Aug. 1994 }
{------------------------------------}
program ComplexDemo;
uses Complex;
var
a,b,c,d : complexs;
begin
a := Cplx(2,5);
b := Cplx(3,4);
c := Cplx(7,5);
d := Cplx(10,6);
OCplx('a',a);
OCplx('b',b);
OCplx('c',c);
OCplx('d',d);
OCplx('a+b',CAdd(a,b));
OCplx('a*c',CMul(a,c));
OCplx('a/b',CDiv(a,b));
OCplx('a-d',CSub(a,d));
end.
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 16:00:11
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第12楼
第三章 实用程序
本章提供了12个用TURBO PASCAL编写的实用程序,包括软锁驱动器的程序、锁硬盘逻辑分区的程序、稿纸排版打印程序、源程序列表程序、查找并替换程序、备份硬盘主引导记录程序、四通-PC文本文件双向转换程序、SPT文件和BMP文件的双向转换程序、数据库文件打卡程序、BATCH文件转换为COM文件的程序、机密文件的有效销毁程序、释放内存程序等12个。下面具体介绍每个程序的编写原理和使用方法。
§3.1 软锁驱动器程序
一般286或386微机都有一个容量极大的硬盘，为使用方便，在硬盘上要安装许多系统软件和专用软件，同时还有很多用户开发的应用程序，由于DOS系统的安全性比较差，软件、程序或数据往往容易被他人非法复制。怎样才能防止他人非法复制呢? 人们想出许多方法，其中有给硬盘加口令字，使子目录名变为隐含等多种方法，我向大家介绍一种使逻辑驱动器失效的防拷贝方法。巧妙地使用本节提供的程序，计算机从硬盘启动后，可以使软驱(包括A、B驱)均失效，当在C:/>提字符下打入A:并回车，则显示“Invalid drive specification”，键入B:时，同样显示此信息。这样在不得到许可时，非法用户是很难拷贝程序和软件的。
§3.1.1 获得驱动器路径表的方法
获得驱动器路径表需要用到未编入文档的DOS功能调用52H，该功能调用的用途是得到内部缓冲器的指针，该指针指向的表描述了与存储子系统有关的大多数DOS内部结构，返回指针存在ES:BX中。这个缓冲区的结构随DOS的主要版本而异，对DOS3.XX及以上版本，此表的偏移16H处为指向驱动器路径的远指针。
驱动器路径表由多个表项组成，每个表项均包含缺省值路径、磁头位置和各种标志和指针，表项的数目等于有效逻辑驱动器数加1，最后一表项的标志变量为零，没有任何有用数据。驱动器路径表项的结构如表3-1。
表3-1.驱动器路径表项的结构
殌┌────┬─────┬───────────────────────┐
│偏 移 │ 长 度 │ 说 明 │
├────┼─────┼───────────────────────┤
│ 0 │ 字 节 │ ASCIIZ格式的当前缺省值路径名,包含着逻辑驱动 │
│ │ (64) │ 器字母、冒号分隔符和起始符"/" │
│40H │ 双 字 │ 保留,置为0 │
│44H │ 字 节 │ 标志变量,所有有效项包含一个40H,最后一项包含0 │
│45H │ 双 字 │ 逻辑驱动器参数块的远指针 │
│49H │ 字 │ 此逻辑驱动器的当前块或磁道/扇区编号 │
│4BH │ 双 字 │ 远指针 │
│4FH │ 字 │ 未知存储 │
└────┴─────┴───────────────────────┘
殣 从表3-1可知，在驱动器路径表每个表项的偏移44H处的一个字节为该逻辑驱动器是否有效的标志，有效时为40H，为其它值则无效，所以要逻辑驱动器失效可以通过DOS功能调用52H，来修改这个标志为0即可。
作者用TURBO PASCAL和TASM编写一个程序SL.PAS，可以用来修改逻辑驱动器路径表，使逻辑驱动器失效和有效，源程序清单附后。
§3.1.2 使用方法
该程序采用命令行格式:
SL [d:] [/switch]
其中d代表驱动器,switch为开关,可取L和U,取时L执行锁驱动器过程,取U时解锁已锁的驱动器。典型用法：
SL -- 显示程序的帮助信息
SL C: -- 显示C逻辑盘的当前状态
SL C: /L -- 锁C逻辑盘
SL C: /U -- 解锁C逻辑盘
该程序只能在MS DOS 3.0以上的操作系统下工作。在对逻辑驱动器解锁时，程序提示输入口令，程序设定的口令是“ABCDEF”，在SOFTLOCK.ASM的源程序中可以找到。
§3.1.3 作用与效果
. 防止他人非法拷贝软件、程序或数据。
. 预防病毒的入侵：因为非机器管理人员在未得到许可时无法使用软驱，从而可以减少病毒入侵的机会。
该程序经过我的长期使用，非常有效，而且减少了病毒的入侵机会。每当交换数据前，我们均用防毒软件对软盘进行消毒，以致于病毒很难侵入系统，这对系统的安全和数据的保密都有很好的效果。
§3.1.5 源程序清单
程序1: SL.PAS
{ }
{ SL.PAS 1.0 }
{ Copyright (C) 1991 Dong Zhanshan }
program SoftLock;
var Drive,Switch: Char;
{$L SOFTLOCK}
procedure DriveState;
External;
procedure LockDrive;
External;
procedure UnLockDrive;
External;
function GetDriveNum: Byte;
External;
procedure Help;
begin
WriteLn('Syntax: SL [d:] [/Switch]');
WriteLn('Switch: /L = Lock the drive d:');
WriteLn(' /U = Unlock the drive d:');
WriteLn('Examples: SL -- Display help text');
WriteLn(' SL C: -- Display the state of drive C');
WriteLn(' SL C: /L -- Lock the drive C');
WriteLn(' SL C: /U -- Unlock the drive C');
WriteLn('Note: Only Using in MS DOS 3.0 and over');
end;
procedure Works;
begin
case Switch of
'L' : LockDrive;
'U' : UnLockDrive;
else WriteLn('The switch is invalid !');
end;
end;
procedure WriteError;
begin
WriteLn('The parameter is error !');
Writeln;
Help;
Halt;
end;
procedure GetParameter;
var TempStr: String[2];
TempChar: Char;
begin
if ParamCount > 0 then
begin
TempStr := ParamStr(1);
if TempStr[2] = ':' then
begin
TempChar := UpCase(tempstr[1]);
if TempChar in ['A'..'Z','a'..'z'] then
Drive := TempChar
else
WriteError;
end
else
WriteError;
end;
if ParamCount > 1 then
begin
TempStr := ParamStr(2);
if TempStr[1] = '/' then
begin
TempChar := UpCase(TempStr[2]);
if TempChar in ['L','U'] then
Switch := TempChar
else
WriteError;
end
else
WriteError;
end;
end;
begin
WriteLn('SL version 1.0 Copyright (c) 1991 Dong Zhanshan');
GetParameter;
if (Ord(Drive) >= 65) then
if (Ord(Drive) - 64 > GetDriveNum) then WriteError;
case ParamCount of
0 : Help;
1 : DriveState;
2 : Works;
else WriteError;
end;
end.
程序2: SOFTLOCK.ASM
; Turbo PASCAL 4.0-6.0
; Turbo Assembler include file for SL.PAS program
; Copyright (C) 1991 Dong Zhanshan
Title SoftLock
LOCALS @@
DOSSEG
.MODEL TPASCAL
.DATA
EXTRN Drive: Byte
.CODE
UnLockMsg1 DB 0dh,0ah,'Your password is correct, '
DB 'the drive is unlocked !',0dh,0ah,'$'
UnLockMsg2 DB 0dh,0ah,'Your password is not correct, '
DB 'the drive cannot be unlocked !',0dh,0ah
db 'Please ask system manager to get the password !'
db 0dh,0ah,'$'
LockState db 'The state of the drive is locked !',0dh,0ah,'$'
UnLockState db 'The state of the drive is unlocked !',0dh,0ah,'$'
LockMsg db 'This drive has been locked!',0dH,0ah,'$'
YourPsWd db 6 dup (0)
PsWdStr db 'ABCDEF'
PsWdMsg db 'Enter the PASSWORD : $'
;Function GetDriveNum:byte;
PUBLIC GetDriveNum
GetDriveNum:
push bp
sub ax,ax
mov ah,52h
int 21h
sub ah,ah
mov al,es:[bx+20h]
pop bp
ret
; Procedure DriveState;
PUBLIC DriveState
DriveState:
CALL GetAddress
MOV AX,ES:[BX]
CMP AX,40H
JNE @@1
mov dx,offset UnLockState
call DisplayMessenge
JMP @@2
@@1: mov dx,offset LockState
call DisplayMessenge
@@2: RET
; Procedure LockDrive
PUBLIC LockDrive
LockDrive:
CALL GetAddress
MOV AH,00
MOV ES:[BX],AH
MOV DX,OFFSET LockMsg
call DisplayMessenge
RET
; Procedure UnLockDrive
PUBLIC UnLockDrive
UnLockDrive:
CALL PassWord
CMP AL,01
JNE @@1
CALL GetAddress
MOV AH,40H
MOV ES:[BX],AH
mov dx,offset UnLockMsg1
call DisplayMessenge
JMP @@2
@@1:
mov dx,offset UnLockMsg2
call DisplayMessenge
@@2: RET
; Get Drive path address
; IN none
; OUT ES = Segment
; BX = Offset
GetAddress:
SUB AX,AX
MOV AH,52H
INT 21H
MOV AX,ES:[BX+18H]
PUSH AX
MOV AX,ES:[BX+16H]
MOV BX,AX
POP ES
sub ch,ch
mov cl,Drive
mov al,41h
sub cl,al
inc cl
@@1: ADD BX,51H
LOOP @@1
SUB BX,0dH
RET
; Get a password and check it
; IN none
; OUT none
; al = 0 --- invalid password
; al = 1 --- valid password
PassWord:
MOV DX,OFFSET PsWdMsg
call DisplayMessenge
MOV CX,06H
MOV BX,00H
@@1: MOV AH,00
INT 16H
MOV YourPsWd[BX],al
CALL WriteXChar
INC BX
LOOP @@1
MOV CX,06H
MOV BX,00H
@@2: MOV AL,YourPsWd[BX]
cmp PsWdStr[BX],AL
JNE @@3
INC BX
LOOP @@2
MOV AL,01H
JMP @@4
@@3: MOV AL,00
@@4: RET
; Write a char 'X' in current cursor on screen
; IN none
; OUT none
WriteXChar:
PUSH AX
PUSH BX
PUSH CX
MOV AH,0AH
MOV AL,'X'
MOV BH,00
MOV CX,1
INT 10H
MOV AH,03
MOV BX,00
INT 10H
INC DX
MOV AH,02
INT 10H
POP CX
POP BX
POP AX
RET
;Display messenge
;in DX = offset address
;out none
DisplayMessenge:
push ds
push cs
pop ds
mov ah,09h
int 21h
pop ds
ret
END
§3.2 锁硬盘逻辑盘程序
随着微处理器的更新换代，目前一般的中高档微机均配备有一个容量很大的硬盘机，小则几十MB，多则上百MB。在硬盘上要同时安装许多公用软件和用户文件，通常用户文件大多是个人的私有信息，不愿让他人随意查看和复制。报刊上介绍了多种硬盘的加密方法，多数是独占整个硬盘，禁止让不知道口令的用户使用。本人通过对硬盘逻辑盘结构的详细分析，提出了对硬盘的一个逻辑盘进行加密的有效方法，达到了独占一个硬盘逻辑盘的目的，从而圆满地解决了上述问题。
§3.2.1 逻辑盘的内部结构
FDISK把硬盘主引导记录存放在硬盘的第一个物理扇区，即0面0柱1扇区，在该扇区的1BEH-1FDH处(共64个字节)是硬盘的分区表，我们称这个分区表为主分区表，它由4个16字节的登记项组成，每个登记项描述一个特定的分区，其中各字节代表的意义见表3-2。
表3-2.分区表登记项各字节的意义
殌┌──┬──┬───────┬──┬───────┬───┬───┐
│ 意 │启动│ 分区开始 │系统│ 分区结束 │相对扇│扇 区 │
│ 义 │标志│头 扇区 柱体│标志│头 扇区 柱体│区数 │总 数 │
├──┼──┼───────┼──┼───────┼───┼───┤
│偏移│ 00 │01 02 03 │ 04 │05 06 07 │08-11 │12-15 │
└──┴──┴───────┴──┴───────┴───┴───┘
殣其中“系统标志”字节可以取以下不同的值：
01：DOS分区，该分区FAT表每项为12位；
02：XENIX分区；
04：DOS分区，该分区FAT表每项为16位；
05：扩展DOS分区；
06：大DOS分区，为MS DOS 4.00以上DOS版本在管理大于32MB盘或逻辑分区时所使用的标志，分区的FAT表每项为16位。
MS/PC DOS 3.30的FDISK程序把初始DOS分区信息放在主分区表的第一个登记项，而第二个登记项为扩展DOS分区信息，其余登记项为空。初始DOS分区代表C逻辑盘，扩展DOS分区的划分要根据它自己的分区表而定。扩展DOS分区的第一个扇区上记录有该扩展DOS分区的划分信息，这个分区被称为第一扩展DOS分区表，其中的第一个登记项记录着D逻辑盘的信息，第二个登记项记录了第二个扩展DOS分区的信息；第二个扩展DOS分区的第一个扇区记录了该扩展DOS分区的信息，其第一个登记项记录了E逻辑盘的信息，第二个登记项记录了第三个扩展DOS分区的信息；依此类推，可以找到所有扩展分区的信息。表3-3列出了一个62MB硬盘的所有分区信息。由表3-3可以知道，FDISK把硬盘的分区信息，以链表格式存放在硬盘的不同物理扇区上，每一个逻辑盘均有一个对应的分区信息表，且与一个物理扇区一一对应，如C盘与0面0柱1扇区对应，D盘与0面90柱1扇区对应。
表3-3.一个62MB硬盘分区信息表
殌┌────┬───┬──┬─────┬─────┬───┬───┬──┐
│ 定 位 │系 统│启动│ 分区开始 │ 分区结束 │相 对│总扇│逻辑│
│面 柱 扇│标 志│标志│面 柱 扇│面 柱 扇│扇 区│区 数│ 盘 │
├────┼───┼──┼─────┼─────┼───┼───┼──┤
│0 0 1│DOS-12│Yes │1 0 1 │7 89 26│ 26│ 18694│ C │
│ │EXTEND│No │0 90 1 │7 613 26│ 18720│108992│ │
├────┼───┼──┼─────┼─────┼───┼───┼──┤
│0 90 1│DOS-16│No │1 90 1 │7 289 26│ 26│ 41574│ D │
│ │EXTEND│No │0 290 1 │7 389 26│ 41600│ 20800│ │
├────┼───┼──┼─────┼─────┼───┼───┼──┤
│0 290 1│DOS-16│No │1 290 1 │7 389 26│ 26│ 20774│ E │
│ │EXTEND│No │0 390 1 │7 613 26│ 62400│ 46592│ │
├────┼───┼──┼─────┼─────┼───┼───┼──┤
│0 390 1│DOS-16│No │1 390 1 │7 613 26│ 26│ 46566│ F │
└────┴───┴──┴─────┴─────┴───┴───┴──┘
殣
§3.2.2 硬盘数据保密的原理
DOS对逻辑盘的管理是通过一个单链将若干个相互独立的连续盘区联系起来，每个连续的盘区均有一套完整的分区引导记录、FAT、文件目标和数据区。DOS在启动过程中，根据每个分区表中每个登记项的系统标志字节的内容来识别逻辑分区，如果该字节的值为DOS分区的有效值，则DOS将其视为有效分区，系统启动后，用户通过一逻辑盘使用这个分区；否则认为是无效分区，系统启动后，不为这个分区分配逻辑盘符，用户也就无法使用此分区，其数据也就暂时“隐含”起来了。
根据上述原理，我们可以使用BIOS提供的13H号中断完成硬盘分区表的读写和系统标志字节的更改，实现逻辑分区的锁闭与解锁，达到个人数据和机密数据的安全与保密。
§3.2.3 程序设计及其使用方法
程序设计的基本思路是：首先把分区表链读入内存，分析各分区的状态，根据用户的要求，若对某一分区加锁，则判断该分区的当前状态，如已锁，则返回，否则，对代表该分区的登记项的系统标志字节求反，提示用户输入口令，最后将修改了的分区表写回对应的物理扇区，重新启动机器后，该分区就“消失”了；解锁的过程基本同上，不过多了一道校验口令的过程。
本人应用TURBO PASCAL编写了一个程序HDL.PAS，经过编译生成执行文件后，在DOS系统下直接运行，能方便地完成硬盘逻辑分区的锁闭与解锁，并且可以加上用户自己的口令，某逻辑盘锁了以后，不知道口令的用户是无法打开的。
程序的使用方法很简单，其使用格式为:
HDL
其中d为逻辑分区对应的盘符，如C、D等，switch为选择开关，可以选：
L -- 为锁逻辑分区;
U -- 为解锁逻辑分区;
尖括号代表参数可以缺省。例如直接执行“HDL”显示程序的帮助信息；执行“HDL D:”显示D逻辑盘的当前状态；执行“HDL D: /L”锁D逻辑盘。
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 16:00:46
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第13楼
§3.2.4 源程序清单
{ HDL.PAS 1.1 }
{ Copyright (c) 1992,94 Dong Zhanshan }
program Hard_Disk_Lock;
{ This program may lock or unlock a logical partition }
{ of the hard disk. It was written by Dong Zhanshan in }
{ 1992.8 at CRI. }
uses disk;
var
{ store all partition information }
Buffer : array[1..24] of MBRT;
{ store states of all logical drive }
DriveState : array[1..24] of Boolean;
{ the number of logical drives }
DriveNum : byte;
Switch,Drive : char;
procedure reboot;
inline($EA/$00/$00/$FF/$FF); { jmp FFFF:0000 }
function readkey:char;
inline($b4/$07/ { mov ah,07 }
$cd/$21); { int 21h }
procedure Help; { the help information of this program }
begin
WriteLn('Syntax: HDL [d:] [/Switch]');
WriteLn('Switch: L = Lock the specifed drive');
WriteLn(' U = Unlock the specifed drive');
WriteLn('Examples: HDL -- Display help text');
WriteLn(' HDL D: -- Display the state of drive D:');
WriteLn(' HDL D: /L -- Lock the drive D:');
WriteLn(' HDL D: /U -- Unlock the drive D:');
end;
function FindExtendedPartition(p1:MBRT):byte;
{ find the position of extended dos partition }
var i : byte;
begin
FindExtendedPartition := 0;
for i := 1 to 4 do
begin
if (p1.PartitionTable[i].SysIndicator = 5)
or (not p1.PartitionTable[i].SysIndicator = 5)
then
begin
FindExtendedPartition := i;
exit;
end;
end;
end;
function FindDosPartition(p1:MBRT):byte;
{ find the position dos partition }
var i : byte;
begin
FindDosPartition := 0;
for i := 1 to 4 do
begin
if (p1.PartitionTable[i].SysIndicator in [1,4,6])
or (not p1.PartitionTable[i].SysIndicator in [1,4,6])
then
begin
FindDosPartition := i;
exit;
end;
end;
end;
procedure WriteError(S : string);
begin
WriteLn(S);
Halt;
end;
function ReadPassWord:string;
var ch : char;
tstr : string[6];
done : boolean;
i : byte;
begin
done := false;
i := 0;
tstr := '';
repeat
ch := readkey;
case ch of
#0 : ch := readkey;
#13 : done := true;
#27 : begin
done := true;
tstr := '';
end;
else begin
inc(i);
tstr := tstr + ch;
write('X');
if i = 6 then done := true;
end;
end;
until done;
ReadPassWord := Tstr;
end;
procedure SetPassword(var p1:MBRT);
var tstr1,tstr2 : string[6];
i : byte;
begin
for i := 0 to 6 do
begin
tstr1[i] := #0;
tstr2[i] := #0;
end;
repeat
write('Please enter password: ');
tstr1 := ReadPassWord;
writeln;
write('Please enter password again: ');
tstr2 := ReadPassWord;
writeln;
until tstr1 = tstr2;
move(tstr1[0],p1.MainBoot[439],7);
end;
function GetPassword(p1:MBRT) : boolean;
var tstr1,tstr2 : string[6];
i : byte;
begin
GetPassWord := false;
for i := 0 to 6 do
begin
tstr1[i] := #0;
tstr2[i] := #0;
end;
write('Please enter password: ');
tstr1 := ReadPassWord;
writeln;
move(p1.MainBoot[439],tstr2[0],7);
if tstr1 = tstr2 then GetPassWord := true;
end;
procedure LockDrive;
var StartCyl,StartSec : byte;
i,j : byte;
p : MBRT;
begin
i := ord(Drive) - ord('C') + 1;
if DriveState[i] then
begin
if i = 1 then
begin
StartCyl := 0;
StartSec := 1;
end
else
begin
j := FindExtendedPartition(Buffer[i-1]);
StartCyl := Buffer[i-1].PartitionTable[j].StartCylinder;
StartSec := Buffer[i-1].PartitionTable[j].StartSector;
end;
j := FindDosPartition(Buffer[i]);
Buffer[i].PartitionTable[j].SysIndicator :=
not Buffer[i].PartitionTable[j].SysIndicator;
SetPassWord(Buffer[i]);
p := Buffer[i];
ProcessPhysicalSector(3,$80,0,StartCyl,StartSec,1,p);
writeln('The drive ',Drive,': has been locked !');
reboot;
end
else
writeln('The drive ',Drive,': is locked !');
end;
procedure UnlockDrive;
var StartCyl,StartSec : byte;
i,j : byte;
p : MBRT;
begin
i:= ord(Drive) - ord('C') + 1;
if not DriveState[i] then
begin
if GetPassWord(Buffer[i]) then
begin
if i = 1 then
begin
StartCyl := 0;
StartSec := 1;
end
else
begin
j := FindExtendedPartition(Buffer[i-1]);
StartCyl := Buffer[i-1].PartitionTable[j].StartCylinder;
StartSec := Buffer[i-1].PartitionTable[j].StartSector;
end;
j := FindDosPartition(Buffer[i]);
Buffer[i].PartitionTable[j].SysIndicator :=
not Buffer[i].PartitionTable[j].SysIndicator;
p := buffer[i];
ProcessPhysicalSector(3,$80,0,StartCyl,StartSec,1,p);
writeln('The drive ',Drive,': has been unlocked !');
reboot;
end
else
WriteError('Your password is error, the drive '+
Drive + ': may not be unlocked !');
end
else
writeln('The drive ',Drive,': is unlocked !');
end;
procedure Works;
begin
case Switch of
'L' : LockDrive;
'U' : UnLockDrive;
end;
end;
procedure GetDriveState;
var i : byte;
begin
i := ord(Drive) - ord('C') + 1;
if DriveState[i] then
writeln('The drive ',Drive,': is unlocked !')
else
writeln('The drive ',Drive,': is locked !');
end;
procedure GetParameter;
var TempStr : String[2];
TempChar : Char;
begin
if ParamCount > 0 then
begin
TempStr := ParamStr(1);
if TempStr[2] = ':' then
begin
TempChar := UpCase(tempstr[1]);
if TempChar in ['A'..'Z'] then
Drive := TempChar
else
WriteError('Does not exist this drive !');
end
else
WriteError('The first parameter is error !');
end;
if ParamCount > 1 then
begin
TempStr := ParamStr(2);
if TempStr[1] = '/' then
begin
TempChar := UpCase(TempStr[2]);
if TempChar in ['L','U'] then
Switch := TempChar
else
WriteError('The switch is error !');
end
else
WriteError('The second parameter is error !');
end;
end;
procedure GetAllPartition;
var StartCyl,StartSec : word;
i,j,k : byte;
P : MBRT;
begin
StartCyl := 0;
StartSec := 1;
i := 0;
repeat
ProcessPhysicalSector(2,$80,0,StartCyl,StartSec,1,p);
j := FindExtendedPartition(p);
StartCyl := P.PartitionTable[j].StartCylinder;
StartSec := P.PartitionTable[j].StartSector;
inc(i);
Buffer[i] := p;
k := FindDosPartition(p);
if (P.PartitionTable[k].SysIndicator in [1,4,6])
then DriveState[i] := true;
until j = 0;
DriveNum := i;
end;
Procedure Init;
var i : byte;
begin
drive := #0;
for i := 1 to 24 do DriveState[i] := false;
end;
begin
WriteLn('HDL version 1.0, Copyright (C) 1992 Dong Zhanshan');
init;
GetParameter;
GetAllPartition;
if drive <> #0 then
if (Drive in ['A','B']) then
WriteError('Floppy diskette is not able to be locked !')
else if (Ord(Drive) >= 67) then
if (Ord(Drive) - 66 > DriveNum) then
WriteError('This logical drive does not exist !');
case ParamCount of
0 : Help;
1 : GetDriveState;
2 : Works;
else WriteError('Too many parameters !');
end;
end.
§3.3 稿纸排版打印程序
稿纸排版打印程序(SP)是一个通用的方格稿纸打印程序，用TURBO PASCAL编写，在中文、英文操作系统下均可运行。SP适用于中文文稿的方格稿纸格式输出，可打印中文、英文、图表混合的文稿，既清晰又美观，对科技文章的作者、文艺作品的作者以及其他写作爱好者，SP将是一个无与伦比的好帮手。SP可以省去你反复改稿誊稿的烦恼，使你从繁重的重复劳动中解脱出来，去干更有意义的工作。
杂志报纸的编辑部均要求文章的作者，把文稿用方格纸誊写清楚，以便送审与排版，避免不必要的差错，这就给文章的作者增加了负担。写文章的人皆把写文章比喻为“爬格子”，十分形象，象征着写文章的辛劳，我也是个“爬格子的”，苦则思变，怎样才能将“爬格子”变成一件赏心乐目的事呢?
我们已跨入了办公自动化的时代，很多以前由人做的事，现在都由计算机来完成。顺应时代潮流，跟上时代的步代，把“爬格子”的苦事交给计算机来完成。当文稿写成之后，录入计算机，然后用方格稿纸打印程序排版输出。
§3.3.1 程序设计的原则要求
科技文章一般均是中英文混合，且穿插一些图表，所以方格稿纸的排版的总原则是习惯化、规范化、简易化。
首先，要求图表与文字分别对待，图表做为一个整体直接输出，文字部分要求
中文、英文分别对待，中文字一格，英文连续排列；
其次，对文章的题标居中排版，对段落的开始要留两个空格；
其三，要正确分页并编码；
其四，要能够满足某些特殊要求；
别外还要考虑到，目前大多数人员是用WS或WPS编辑文本的，其文本中包含了许多排版符，这些字符均不是正常可见的ASCII字符，所以程序要对这些文本进行预处理后，再进行排版输出。
程序采用命令串格式，并提供了几个选择开关，由使用人员指定功能，使程序更加灵活方便。
§3.3.2 程序的主要功能
本程序采用采用了代码优代技术，代码紧凑，执行速度快。根据设计的原则要求，其难点主要是中英文分离及分类处理、图表的输出。
该程序的主要功能有三:
. 完成WS或WPS文本文件到纯ASCII文本文件的转换
. 完成纯ASCII文件的方格稿纸的排版
. 显示输出排版结果，打印输出排版结果
§3.3.3 使用方法
语法:
SP <输入文件> <输出文件> [<选择开关>]
其中“输入文件”为纯ASCII码格式的文件或WS与WPS的文本格式文件，“输出文件”为翻译成方格稿纸格式文本的输出文件，它可以在WPS系统下直接送打印机输出。
选择开关有:
/D = 显示翻译结果文本
/E = 删除翻译输出文件
/P = 打印翻译结果文本
/T = 当输入文件为WS或WPS文件时，转换此文件为纯ASCII码文件
当缺省选择开关时，SP只把输入文件翻译成方格稿纸格式的文件，而不送打印机输出。
§3.3.4 排版命令
(1) 命令格式:
①CTRL码
②CTRL码 数字 #
其中'CTRL码'有四种选择: ^C、^O、^S、^T，'数字'可为1-999之间的任意整数， '#'为命令结束符。
(2) 命令分类:
①行居中命令:
^C
②段排版命令:
^Sn#
其中n为0-20之间的任意整数，代表段落前所留空格数。
③行原样打印命令:
^On#
其中n为原样打印行数，在1-999之间。
④图表排版命令:
^Tn#
其中n为图表所占行数，在1-999之间。
5.板样
(1) WS文件(含排版命令)如下:
^C 方格稿纸打印软件SP V2.0
中国农科院棉花研究所 董占山
^S2# SP V2.0软件文件清单:
^O7# SP.DOC SP的使用手册，这个文件
SP.PAS SP的PASCAL源程序
SP.EXE SP的执行程序
DEMO1.TXT 一个演示文件
DEMO2.TXT 又一个演示文件
DEMO1.BAT DEMO1.TXT的批处理文件
DEMO2.BAT DEMO2.TXT的批处理文件
^S2# SP V2.0的主要功能及其选择开关简介如表1所示。
^T10# 表1.SP V2.0的主要功能及其选择开关
┌──────────┬──────────────┐
│ 主要功能 │ 选择开关 │
├──────────┼──────────────┤
│①转换WS文件 │ /D: 显示翻译结果文本 │
│②翻译文本为方格稿纸│ /E: 删除翻译输出文件 │
│ 格式的文件 │ /P: 打印翻译结果文本 │
│③打印输出稿纸文件 │ /T: 当输入文件为WS文件时， │
│ │ 转换WS文件为ASCII码文件│
└──────────┴──────────────┘
§3.3.5 源程序清单
{ SP.PAS 2.0 }
{ Copyright (c) 1991 Dong Zhanshan }
{$M 16000,$0,16000}
Program SP; { 方格稿纸排版打印程序 V2.0 }
uses crt,dos;
type
CtrlType = record { 定义排版命令类型 }
FMT : char;
Count : integer;
end;
const
WPS_1 = #$91#$81#$92#$94#$9b#$90#$99#$c1; { WPS的排版命令 }
WPS_2 = #$91#$80#$92#$85#$9b#$80#$99#$c0; { WPS的排版命令 }
CRCH = #$0D; { 定义回车符 }
ChiTabChar : array[1..5,1..2] of string[2] =( { 定义中文表格符 }
( '┌', { left upper corner }
'┐' ), { right upper corner }
( '└', { left down corner }
'┘' ), { right down corner }
( '─', { column }
'│' ), { row }
( '┬', { upper T }
'┴' ), { down T }
( '├', { left T }
'┤' ) { right T }
);
ConstCtrl : CtrlType = ( FMT : ^S; { 定义排版命令常量 }
Count : 2 );
display : boolean = false; { 显示控制常量 }
print : boolean = false; { 打印控制常量 }
erase : boolean = false; { 删除控制常量 }
trans : boolean = false; { 转换控制常量 }
CopyRight = 'MF SP Version 2.0 Copyright (c) 1990, 1991 MF Software Company';
var TempStr1,TempStr2,EStr,CStr, { 工作字符串变量 }
RegisterCH,ps1,ps2 : string; { 寄存剩余字符串 }
f1 : file; { 输入文件 }
f2 : text; { 输出文件 }
CR,Start,Chinese,English : boolean; { 布尔变量 }
CH : char; { 字符变量 }
FMTCom : CtrlType;{ 控制命令变量 }
PageNum,LineNum, { 页数, 行数 }
CurFileLen,len,Result : word; { 当前文件位置 }
TextLine,UpLine,DownLine : string; { 生成的文本行 }
procedure InitStr; { 初始化变量 }
begin
textline := ChiTabChar[3,2];
downline := ChiTabChar[5,1];
upline := ChiTabChar[5,1];
tempstr1 := '';
tempstr2 := '';
EStr := '';
CStr := '';
RegisterCh := '';
PageNum := 0;
LineNum := 0;
CurFileLen := 0;
Chinese := false;
English := false;
Start := true;
FMTCom := ConstCtrl;
end;
procedure AnStr1( s1 : string;
var S2 : string;
var len : word);
{ 在S1中找回车符, 并把回车以前的字符赋予S2 }
var i : integer;
begin
i := pos(CRCH,s1);
if i = 0 then i := pos(#$1A,S1);
if i <> 0 then
begin
CR := true;
move(s1,s2,i-1);
s2[0] := chr(i - 1);
len := i + 1;
end
else
begin
CR := false;
s2 := s1;
len := ord(s1[0]);
end;
end;
procedure DelSpace(var S : string);
{ 删除字符串S中的前导空格 }
begin
if start then
while (s[1] = ' ') and (ord(s[0]) > 1) do
begin
move(s[2] , s[1] , ord(s[0]) - 1);
s[0] := chr(ord(s[0]) - 1 );
end;
if (s[1] = ' ') and (ord(s[0]) = 1) then s[0] := chr(0);
end;
procedure GetChar( var S : string;
var Ch : char );
{ 从S中取一字符CH, 并把CH从S中删除 }
begin
ch := s[1];
move(s[2] , s[1] , ord(s[0]) - 1 );
s[0] := chr( ord(s[0]) - 1 );
end;
procedure ProcCtrlChar;
{ 取排版命令 }
Procedure SeekCount;
{ 给排版命令的COUNT赋值 }
var ts : string[3];
c,i : integer;
begin
i := 0;
ts := '';
repeat
GetChar(TempStr2,Ch);
if ch <> '#' then Ts := TS + ch;
inc(i);
until (ch = '#');
Val(Ts,FMTCom.Count,C);
end;
begin
case Ch of
^C : FMTCom.FMT := ^C;
^O,^S,^T :
begin
FMTCom.Fmt := ch;
SeekCount;
end;
else FMTCom := ConstCtrl;
end;
Start := true;
end;
procedure PrintPageTail;
{ 输出页尾 }
var i : integer;
begin
write(f2,ChiTabChar[2,1]);
for i:= 1 to 39 do write(f2,ChiTabChar[3,1]);
writeln(f2,ChiTabChar[2,2]);
writeln(f2,' 20x20=400 第 ',PageNum,' 页');
{ for i := 1 to 18 do writeln(f2); }
LineNum := 0;
end;
procedure PrintPageHead;
{ 输出页头 }
var i : integer;
begin
writeln(f2,WPS_1+' 稿 纸');
write(f2,WPS_2);
write(f2,ChiTabChar[1,1]);
for i:= 1 to 39 do write(f2,ChiTabChar[3,1]);
writeln(f2,ChiTabChar[1,2]);
end;
Procedure Writeline;
{ 输出文本行 }
begin
writeln(f2,Upline);
writeln(f2,Textline);
writeln(f2,Downline);
UpLine := ChiTabChar[5,1];
TextLine := ChiTabChar[3,2];
DownLine := ChiTabChar[5,1];
inc(LineNum);
if LineNum = 20 then
begin
inc(PageNum);
PrintPageTail;
PrintPageHead;
end;
end;
Procedure WriteSpaceLine( X : integer;
Done : boolean);
{ 输出X行空行, DONE为真时也输出页尾 }
var i : integer;
begin
for i := 1 to 19 do
begin
upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
downline := downline
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
textline := textline
+ ' '
+ ChiTabChar[3,2];
end;
upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
downline := downline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
textline := textline
+ ' '
+ ChiTabChar[3,2];
for i := 1 to X do
begin
writeln(f2,Upline);
writeln(f2,Textline);
writeln(f2,Downline);
inc(LineNum);
end;
if done then
begin
inc(PageNum);
PrintPageTail;
end
else
begin
UpLine := ChiTabChar[5,1];
TextLine := ChiTabChar[3,2];
DownLine := ChiTabChar[5,1];
end;
end;
procedure ProcCstr;
{ 处理中文字串 }
begin
case ord(textline[0]) of
0..76 : begin
textline := textline
+ CStr[1]
+ CStr[2]
+ ChiTabChar[3,2];
upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
if ord(CStr[0]) >= 4 then
begin
Move(CStr[3],CStr[1],ord(CStr[0])-2);
CStr[0] := chr(ord(CStr[0])-2);
ProcCStr;
end
else if ord(CStr[0]) = 3 then
RegisterCh := CStr[3];
end;
78..82 : begin
textline := textline
+ CStr[1]
+ CStr[2]
+ ChiTabChar[3,2];
upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
writeline;
if ord(CStr[0]) >= 4 then
begin
Move(CStr[3],CStr[1],ord(CStr[0])-2);
CStr[0] := chr(ord(CStr[0])-2);
ProcCStr;
end
else if ord(CStr[0]) = 3 then
RegisterCh := CStr[3];
end;
end;
chinese := false;
CStr := '';
end;
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 16:01:11
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第14楼
procedure ProcEstr;
{ 处理英文字串 }
Procedure AddUpLine(X1,X2:integer);
var i : integer;
begin
for i := 1 to x1*2 do
upline := upline + ChiTabChar[3,1];
case x2 of
1 : begin
case ord(upline[0]) of
0..76 : upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
78..82 : upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
end;
end;
2 : begin
case ord(upline[0]) of
0..76 : upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[3,1];
78..82 : upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
end;
end;
end;
end;
Procedure AddDownLine(X1,X2:integer);
var i : integer;
begin
for i := 1 to x1*2 do
Downline := Downline + ChiTabChar[3,1];
case x2 of
1 : begin
case ord(Downline[0]) of
0..76 : Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
78..82 : Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
end;
end;
2 : begin
case ord(Downline[0]) of
0..76 : Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[3,1];
78..82 : Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
end;
end;
end;
end;
Procedure ProcEstr1;
var i, x : integer;
begin
i := ord(EStr[0]);
if i mod 4 = 0 then x := 4 else x := i mod 4;
case X of
1 : begin
AddUpLine(i div 4,1);
AddDownLine(i div 4,1);
TextLine := TextLine + EStr + ' ' + ChiTabChar[3,2];
end;
2 : begin
AddUpLine(i div 4,1);
AddDownLine(i div 4,1);
TextLine := TextLine + EStr + ChiTabChar[3,2];
end;
3 : begin
AddUpLine(i div 4,2);
AddDownLine(i div 4,2);
TextLine := TextLine + EStr + ' ';
end;
4 : begin
AddUpLine(i div 4 - 1,2);
AddDownLine(i div 4 - 1,2);
TextLine := TextLine + EStr;
end;
end;
end;
begin
if ord(EStr[0]) > 80 - ord(textline[0]) then
begin
tempstr1 := copy( EStr,
80 - ord(textline[0]) + 1,
ord(EStr[0]) -(80 - ord(textline[0]))
);
delete( EStr,
80 - ord(textline[0]) + 1,
ord(EStr[0]) -(80 - ord(textline[0]))
);
ProcEstr1;
writeline;
EStr := Tempstr1;
ProcEstr1;
end
else
ProcEstr1;
if ord(TextLine[0]) = 82 then writeline;
english := false;
EStr := '';
end;
Procedure ProcStr2;
{ 处理字符串 }
begin
repeat
GetChar(Tempstr2,Ch);
case ch of
#$20..#$7F : begin
if Chinese then ProcCStr;
English := true;
EStr := EStr + ch;
if ord(EStr[0]) >= 40 then ProcEStr;
end;
#$80..#$FF : begin
if English then ProcEStr;
Chinese := true;
CStr := CStr + ch;
if ord(CStr[0]) >= 20 then ProcCStr;
end;
end;
until tempstr2 = '';
if Chinese then ProcCStr;
if English then
begin
if CR then ProcEStr
else begin
RegisterCH := EStr;
EStr := '';
end;
end;
end;
Procedure ReadStr;
{ 从文件中读字符到一个串中, 然后生成TEMPSTR2 }
begin
{$I-} blockread(f1,tempstr1,250,result); {$I+}
move(Tempstr1[0],Tempstr2[1],result);
tempstr2[0] := chr(result);
tempstr1 := tempstr2;
AnStr1(tempstr1,tempstr2,len);
inc(CurFileLen,Len);
seek(f1,CurFileLen);
end;
Procedure StrSegmentProc;
{ 段排版处理 }
var i,x,c : integer;
Procedure CompleteLine;
var i : integer;
begin
for i := 1 to (78 - ord(Textline[0])) div 4 do
begin
TextLine := TextLine
+ ' '
+ ChiTabChar[3,2];
Upline := UpLine
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
Downline := DownLine
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
end;
TextLine := TextLine
+ ' '
+ ChiTabChar[3,2];
Upline := UpLine
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
Downline := DownLine
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
writeline;
start := true;
cr := false;
RegisterCh := '';
end;
begin
TempStr2 := ch + Tempstr2;
DelSpace(Tempstr2);
if start then
begin
if FMTCom.Count = 0 then ProcStr2
else
begin
for i := 1 to FMTCom.Count do
begin
TextLine := TextLine
+ ' '
+ ChiTabChar[3,2];
Upline := Upline
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
Downline := DownLine
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
end;
ProcStr2;
end;
Start := false;
end
else
ProcStr2;
if CR then
if (Ord(TextLine[0]) <> 2) then CompleteLine
else
begin
start := true;
cr := false;
RegisterCh := '';
end;
end;
procedure StrCenterProc;
{ 居中排版处理 }
Procedure LeaveMagSpace;
var i,j,k : integer;
Tstr1,Tstr2,Tstr3 : string;
begin
i := 80 - ord(textLine[0]);
j := i div 4;
Tstr1 := ChiTabChar[5,1];
Tstr2 := ChiTabChar[3,2];
Tstr3 := ChiTabChar[5,1];
for k := 1 to j div 2 do
begin
Tstr1 := Tstr1 + ChiTabChar[3,1] + ChiTabChar[4,1];
Tstr2 := Tstr2 + ' ' + ChiTabChar[3,2];
Tstr3 := Tstr3 + ChiTabChar[3,1] + ChiTabChar[4,2];
end;
UpLine := Tstr1 + UpLine;
TextLine := Tstr2 + TextLine;
DownLine := Tstr3 + DownLine;
if i mod 4 <> 0 then j := j + 1;
if j mod 2 <> 0 then j := j div 2 + 1
else j := j div 2;
for k := 1 to j - 1 do
begin
UpLine := UpLine
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
TextLine := TextLine
+ ' '
+ ChiTabChar[3,2];
DownLine := DownLine
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
end;
UpLine := UpLine
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
TextLine := TextLine
+ ' '
+ ChiTabChar[3,2];
DownLine := DownLine
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
end;
begin
TextLine := '';
UpLine := '';
DownLine := '';
Tempstr2 := Ch + Tempstr2;
DelSpace(Tempstr2);
ProcStr2;
LeaveMagSpace;
Writeline;
end;
Procedure StrOrigProc;
{ 原样输出排版处理 }
type
OrigStrPtr = ^OrigStrType;
OrigStrType = array[1..60] of string;
var
OrigStr : OrigStrPtr;
x,y,z,oldLineNum : integer;
Procedure MakeProc(x1,x2 : integer);
var i,j : integer;
begin
GetMem(OrigStr,x2*246);
OrigStr^[1] := ChiTabChar[5,1] ;
for i := 1 to 39 do
OrigStr^[1] := OrigStr^[1] + ChiTabChar[3,1];
Origstr^[1] := OrigStr^[1] + ChiTabChar[5,2];
for i := 2 to x2*3 - 1 do
begin
OrigStr^[i] := ChiTabChar[3,2] ;
for j := 1 to 39 do
OrigStr^[i] := OrigStr^[i] + ' ';
Origstr^[i] := OrigStr^[i] + ChiTabChar[3,2];
end;
if odd(x2) then OrigStr^[x2*3] := OrigStr^[1]
else OrigStr^[x2*3] := OrigStr^[2];
move(Tempstr2[1],OrigStr^[2][3],ord(Tempstr2[0]));
if x1 > 1 then
begin
for i := 2 to x1 do
begin
ReadStr;
move(Tempstr2[1],OrigStr^[i*2][3],ord(Tempstr2[0]));
end;
end;
for i := 1 to x2 do
begin
UpLine := OrigStr^[(i-1)*3 + 1];
TextLine := OrigStr^[(i-1)*3 + 2];
DownLine := OrigStr^[(i-1)*3 + 3];
WriteLine;
end;
FreeMem(OrigStr,x2*246);
TempStr2 := '';
end;
Procedure ProcManyLine(XX : integer);
begin
ReadStr;
if xx > 30 then
begin
MakeProc(30 , 20);
ProcManyLine(xx - 30);
end
else
if xx * 2 mod 3 <> 0 then MakeProc(xx , xx * 2 div 3 + 1)
else MakeProc(xx , xx * 2 div 3);
end;
begin
Tempstr2 := ch + Tempstr2;
X := FMTCom.Count;
y := X * 2;
if y mod 3 <> 0 then z := y div 3 + 1
else z := y div 3;
if z <= 20 - LineNum then MakeProc(x,z)
else
begin
OldLineNum := LineNum;
MakeProc( ((20 - LineNum)*3) div 2 , 20 - LineNum);
ProcManyLine(X -(20 - OldLineNum)*3 div 2);
end;
end;
Procedure StrTableProc;
{ 图表输出排版处理 }
type
OrigStrPtr = ^OrigStrType;
OrigStrType = array[1..60] of string;
var
OrigStr : OrigStrPtr;
x,y,z,OldLineNum : integer;
Procedure MakeProc(x1,x2 : integer);
var i,j : integer;
begin
GetMem(OrigStr,x2*246);
OrigStr^[1] := ChiTabChar[5,1] ;
for i := 1 to 39 do
OrigStr^[1] := OrigStr^[1] + ChiTabChar[3,1];
Origstr^[1] := OrigStr^[1] + ChiTabChar[5,2];
for i := 2 to x2*3 do
begin
OrigStr^[i] := ChiTabChar[3,2] ;
for j := 1 to 39 do
OrigStr^[i] := OrigStr^[i] + ' ';
Origstr^[i] := OrigStr^[i] + ChiTabChar[3,2];
end;
move(Tempstr2[1],OrigStr^[2][3],ord(Tempstr2[0]));
if x1 > 1 then
begin
for i := 2 to x1 do
begin
ReadStr;
move(Tempstr2[1],OrigStr^[i+1][3],ord(Tempstr2[0]));
end;
end;
for i := 1 to x2 do
begin
UpLine := OrigStr^[(i-1)*3 + 1];
TextLine := OrigStr^[(i-1)*3 + 2];
DownLine := OrigStr^[(i-1)*3 + 3];
WriteLine;
end;
FreeMem(OrigStr,x2*246);
TempStr2 := '';
end;
Procedure ProcManyLine(XX : integer);
begin
ReadStr;
if XX > 59 then
begin
MakeProc(59, 20);
XX := XX - 59;
ProcManyLine(XX);
end
else
if (xx+1) mod 3 <> 0 then MakeProc(xx , (xx + 1) div 3 + 1)
else MakeProc(xx , (xx + 1) div 3);
end;
begin
Tempstr2 := ch + Tempstr2;
X := FMTCom.Count;
y := X + 1;
if y mod 3 <> 0 then z := y div 3 + 1
else z := y div 3;
if z <= 20 - LineNum then MakeProc(x,z)
else
begin
OldLineNum := LineNum;
MakeProc( (20 - LineNum)*3 - 1, 20 - LineNum);
ProcManyLine(X - (20 - OldLineNum)*3 + 1);
end;
end;
Procedure AnStr2;
{ 分析TEMPSTR2 }
begin
repeat
GetChar(TempStr2,Ch);
case ch of
^C,^O,^S,^T : ProcCtrlChar;
#$20..#$FF :
case FMTCom.FMT of
^C : StrCenterProc;
^O : StrOrigProc;
^S : StrSegmentProc;
^T : StrTableProc;
end;
end;
until tempstr2 = '';
end;
Procedure ws_ascii(fn1 : string);
{ 转换WS文件为ASCII文件 }
var f1 : file;
f2 : text;
begin
assign(f1,fn1);
assign(f2,'$$$.$$$');
reset(f1,1);
rewrite(f2);
repeat
blockread(f1,ch,1);
case ch of
#$8D : begin
blockread(f1,ch,1);
blockread(f1,ch,1);
end;
#$0D : begin
blockread(f1,ch,1);
case ch of
#$8A : begin
write(f2,#$0D#$0A);
blockread(f1,ch,1);
end;
#$0A : write(f2,#$0D);
end;
end;
end;
write(f2,ch);
until eof(f1);
close(f1);
close(f2);
end;
Procedure help;
{ 帮助过程 }
begin
writeln('Syntax: SP []');
writeln('Options: /d = display the output file');
writeln(' /e = erase the output file');
writeln(' /p = print the output file');
writeln(' /t = translate the input file with WS_ASCII');
halt;
end;
function YesNo(s : string) : boolean;
{ 回答YES或NO }
begin
YesNo := false;
write(s,' ?(Y/N)');
ch := readkey;
writeln(ch);
if ch in ['y','Y'] then YesNo := true;
end;
function exist(filename : string) : boolean;
{ 判断文件是否存在 }
var f1 : text;
i : integer;
begin
assign(f1,filename);
{$I-} reset(f1); {$I+}
i := ioresult;
if i = 0 then exist := true
else exist := false;
end;
procedure ParseComline;
{ 命令行分析器 }
var i : integer;
procedure ProcComlineStr(s:string);
var i : integer;
begin
for i := 1 to ord(s[0]) do
s[i] := upcase(s[i]);
if s = '/D' then display := true;
if s = '/E' then erase := true;
if s = '/P' then print := true;
if s = '/T' then trans := true;
end;
begin
i := paramcount;
if i < 2 then help;
if i = 2 then exit;
case i of
3 : ProcComlineStr(paramstr(3));
4 : begin
ProcComlineStr(paramstr(3));
ProcComlineStr(paramstr(4));
end;
5 : begin
ProcComlineStr(paramstr(3));
ProcComlineStr(paramstr(4));
ProcComlineStr(paramstr(5));
end;
6 : begin
ProcComlineStr(paramstr(3));
ProcComlineStr(paramstr(4));
ProcComlineStr(paramstr(5));
ProcComlineStr(paramstr(6));
end;
end;
end;
Procedure translatetext(fn1,fn2 : string);
{ 翻译ASCII文件为方格稿纸文本文件 }
begin
assign(f1,fn1);
reset(f1,1);
assign(f2,fn2);
rewrite(f2);
InitStr;
PrintPageHead;
repeat { 主循环体 }
ReadStr;
TempStr2 := RegisterCH + TempStr2;
RegisterCh := '';
DelSpace(Tempstr2);
if TempStr2 <> '' then AnStr2 ;
until eof(f1);
WriteSpaceLine(20-LineNum,True);
close(f1);
close(f2);
end;
procedure DisplayText(fn : string);
var f1,f2 : text;
ts : string[79];
ch : char;
i : integer;
begin
assign(f1,fn);
reset(f1);
assigncrt(f2);
rewrite(f2);
i := 0;
repeat
readln(f1,ts);
writeln(f2,ts);
inc(i);
if i = 20 then
begin
i := 0;
ch := readkey;
end;
until (ch=#$1B) or eof(f1);
close(f1);
close(f2);
end;
{ 主程序 }
begin
writeln('SP Version 2.1 Copyright (c) 1990,94 Dong Zhanshan');
directvideo := false;
writeln(CopyRight);
PS1 := paramstr(1);
PS2 := paramstr(2);
ParseComline;
if not exist(PS1) then
begin
writeln('File not found !');
exit;
end;
if exist(PS2) then
if not YesNo('File exist ! Overwrite') then exit;
if trans then ws_ascii(PS1);
if trans then TranslateText('$$$.$$$',PS2)
else TranslateText(PS1,PS2);
if display then DisplayText(PS2);
if print then exec(getenv('COMSPEC'),'/C copy '+PS2+ ' prn >nul');
if erase then exec(getenv('COMSPEC'),'/C del '+PS2+' >nul');
if trans then exec(getenv('COMSPEC'),'/C del $$$.$$$ >nul');
end.
§3.4 源程序分页打印程序
程序编写完成之后，如要打印输出，在BASICA中，可用LLIST命令完成，对其它高级语言，则缺少特定打印命令，不过还可以用DOS功能来实现，但对源程序的输出求较高时，则无通用的命令。为解决这个困难，用TURBO PASCAL编写了一个源程序打印程序ASL.PAS。
§3.4.1 程序使用方法
ASL /H --- 获得ASL帮助文本
ASL 文件名 --- 分页打印源程序
ASL 文件名 /D --- 分页显示源程序
说明: “文件名”为DOS的有效文件名，必须写全名。如果要批量打印一批扩展名为.PAS的文件，则可以执行：
For %%a in (*.PAS) do ASL %%a
§3.4.2 源程序清单
{ ASL.PAS 1.2 }
{ Copyright (c) 1990,94 Dong Zhanshan }
program AdvancedSourceLister;
uses printer,dos,crt,astr;
var d1,m1,y1,w1,pagenumber,counter,sp1,sp2 : word;
lin,flnm,sw : string;
f1,f2 : text;
function Exist(Flnm:string):boolean;
var i : byte;
f1 : text;
begin
Exist := False;
assign(f1,Flnm);
{$I-}
reset(f1);
{$I+}
i := IoResult;
if i = 0 then
begin
Exist := True;
close(f1);
end;
end;
procedure PrintPageHead(var f3:text);
var i,h1,m,s,s100 : word;
begin
gettime(h1 , m , s , s100);
writeln(f3 , 'Advanced Print Program'
, Space(sp1), flnm,Space(sp2)
, wordtostr(y1 , 4), '-'
, wordtostr(m1 , 2), '-'
, wordtostr(d1 , 2), Space(3)
, wordtostr(h1 , 2), ':'
, wordtostr(m , 2), ':'
, wordtostr(s , 2)
);
writeln( f3 , fillchartostr(80 , '_') );
end;
procedure PrintPageTail(var f3:text);
var i : word;
begin
inc ( pagenumber );
writeln( f3 , fillchartostr(80 , '_') );
write ( f3 , fillchartostr(36 , ' ') );
writeln( f3 , '----' , pagenumber , '----' );
for i := 1 to 12 do writeln(f3);
counter := 0;
end;
procedure Print(var f3:text);
begin
inc(counter);
writeln(f3, lin);
if counter = 50 then
begin
PrintPageTail(f3);
PrintPageHead(f3);
end;
end;
procedure LastPageProcess(var f3:text);
var i : integer;
begin
for i := counter + 1 to 48 do writeln(f3);
PrintPageTail(f3);
end;
procedure ProcessTab(var lin : string);
var temp,temp1 : string;
i : integer;
ch : char;
begin
temp := '';
for i := 1 to length(lin) do
begin
ch := lin[i];
if ch = #9 then temp1 := FillCharToStr(8,' ')
else temp1 := ch;
temp := temp + temp1;
end;
lin := temp;
end;
Procedure p(var lin : string);
var lin1 : string;
begin
if length(lin) > 80 then
begin
lin1 := lin;
lin[0] := chr(80);
if sw = '/D' then print(f2) else print(lst);
delete(lin1 , 1 , 80);
lin := FillCharToStr(4 , ' ')+lin1;
p(lin);
end
else
if sw = '/D' then print(f2) else print(lst);
end;
begin
writeln('ASL Version 1.2 Copyright (c) 1990,94 Dong Zhanshan');
if paramstr(1) = '/H' then
begin
writeln('Advanced Source Lister Usage:');
writeln(' ASL /H --- ASL help messenge');
writeln(' ASL filename --- Print the file to printer');
writeln(' ASL filename /D --- Display the file to screen');
exit;
end;
case paramcount of
0 : begin
write('Filename : ');
readln(flnm);
sw := '';
end;
1 : begin
flnm := paramstr(1);
sw := '';
end;
2 : begin
flnm := paramstr(1);
sw := paramstr(2);
end;
end;
if not exist(flnm) then
begin
writeln('File not found !');
exit;
end;
sp1 := 18 - length(flnm) div 2;
sp2 := 36 - (sp1 + length(flnm));
lin := flnm; flnm := '';
UpperLower(flnm,lin);
assign(f1,flnm);
reset(f1);
if sw = '/D' then
begin
assigncrt(f2);
rewrite(f2);
end;
pagenumber := 0;
counter := 0;
getdate(y1,m1,d1,w1);
if sw = '/D' then PrintPageHead(f2)
else PrintPageHead(lst);
repeat
readln(f1,lin);
ProcessTab(lin);
P(lin);
until eof(f1);
if sw = '/D' then LastPageProcess(f2)
else LastPageProcess(lst);
close(f1);
if sw = '/D' then close(f2);
end.
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 16:01:33
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第15楼
§3.5 查找并替换程序
TURBO PASCAL系统盘上提供了一个十分实用的字符串查找程序GREP.COM,该程序可以在指定的一批文件中,查找一个或具有一定特征的字符串,查到后在屏幕上显示出来。但是，它不能把指定的字符串同时替换成另外一个字符串，然而在实际工作中，我们往往要对一批文件中的指定字符串进行替换，如果使用编辑程序，则需要一个一个进行，实在是让人难以忍受。作者用TURBO PASCAL编写了一个简单的字符串查找并替换程序GREP.PAS，经过编译，形成执行文件后可以在操作系统下批量地对指定文件进行处理。
§3.5.1 程序使用方法
GREP <文件名> <查找的字符串> [替换的字符串]
其中“文件名”是某一特定的文件名,不能用通配符,且必须写上文件的扩展名；“查找的字符串”为任意合法的字符和数字的组合；“替换的字符串”是指把从文件中找到的查找字符串转换成的字符串，如果省略此项，GREP程序只在指定文件中查找字符串，而不进行替换工作。
§3.5.2 源程序清单
{ GREP.PAS 1.0 }
{ Copyright (c) 1994 Dong Zhanshan }
program Find_Replace;
uses dos;
var
f1,f2 : text;
FindStr,ReplaceStr : string;
FindB,ReplaceB : boolean;
Flnm : string;
procedure GetComLine;
begin
Flnm := '';
FindStr := '';
ReplaceStr := '';
FindB := False;
ReplaceB := False;
Case ParamCount of
2 : begin
Flnm := ParamStr(1);
FindStr := ParamStr(2);
FindB := True;
end;
3 : begin
Flnm := ParamStr(1);
FindStr := ParamStr(2);
ReplaceStr := ParamStr(3);
ReplaceB := True;
end;
end;
end;
Procedure Help;
begin
Writeln('Syntex : GREP [replace string]');
halt;
end;
procedure Find;
var
str1 : string;
i,l : word;
begin
if FSearch(flnm,'') = '' then help;
assign(f1,flnm);
reset(f1);
l := 0;
repeat
readln(f1,str1);
inc(l);
i := pos(FindStr,str1);
if i <> 0 then
Writeln('[',Flnm, '] Line : ',l,' ',str1);
until eof(f1);
close(f1);
end;
procedure Replace;
var
str1,str2,str3 : string;
P: PathStr;
D: DirStr;
N: NameStr;
E: ExtStr;
i : integer;
begin
assign(f1,flnm);
reset(f1);
assign(f2,'temp');
rewrite(f2);
repeat
readln(f1,str2);
repeat
i := pos(FindStr,str2);
if i <> 0 then
begin
str3 := copy(str2,1,i-1);
delete(str2,1,i+Length(FindStr)-1);
str2 := str3 + ReplaceStr + str2;
end;
until i = 0;
writeln(f2,str2);
until eof(f1);
close(f1);
close(f2);
assign(f1,Flnm);
assign(f2,'temp');
fsplit(p,d,n,e);
str1 := n + '.bak';
rename(f1,str1);
rename(f2,Flnm);
end;
begin
WriteLn('GREP Version 1.0, Copyright (C) 1994 Dong Zhanshan');
GetComLine;
if Flnm = '' then Help;
if FindB then Find;
if ReplaceB then Replace;
end.
§3.6 备份硬盘主引导扇区程序
§3.6.1 硬盘主引导记录
用FDISK对硬盘进行分区时，它在硬盘的0面0道1扇区生成一个包含分区信息表、主引导程序的主引导记录，其作用是当系统加电或复位时，若从硬盘自举，ROM BIOS就会把硬盘该扇区的内容读到内存的0000:7C00处，并执行主引导程序，把活动分区的操作系统引导到内存。
作者用TURBO PASCAL编写了备份硬盘主引导扇区程序，程序清单附后。该程序短小精悍，使用方便。
§3.6.2 使用方法
在DOS系统下执行:
HMR
根据程序的提示,即可把硬盘上的主引导记录写到MRECORD.SAV的文件中;也可以根据提示把文件MRECORD.SAV中存储的内容写到硬盘的0面0柱1扇区。
§3.6.3 源程序清单
{ HMR.PAS 1.2 }
{ Copyright (c) 1990,94 Dong Zhanshan }
program HarddiskMainbootRecord;
uses Acrt,Disk;
const
MBRF = 'MRECORD.SAV';
var
mp : MBRT;
i : integer;
f1 : file;
begin
writeln('HMR Version 1.2 Copyright (c) 1990,94 Dong Zhanshan',^M^J);
if YesNo('Read the hard disk main boot record') then
begin
ProcessPhysicalSector(2,$80,0,0,1,1,mp);
if YesNo('Save the hard disk main boot record') then
begin
assign(f1,MBRF);
rewrite(f1,1);
blockwrite(f1,mp,512);
close(f1);
end;
end;
if YesNo('Write the hard disk main boot record') then
begin
if YesNo('Are you sure') then
begin
assign(f1,MBRF);
{$I-}reset(f1,1);{$I+}
i := ioresult;
if i = 0 then
begin
blockread(f1,mp,512);
close(f1);
ProcessPhysicalSector(3,$80,0,0,1,1,mp);
end
else writeln('Read file error');
end;
end;
writeln(#7,'Done !',#7);
end.
§3.7 四通-PC文本文件转换程序
四通高级中英文打字机具有极强的文字处理能力，而IBM PC/XT、AT则有很大的灵活性，有许多优秀的中文排版软件可用，所以在四通打字机与PC机之间传递文件有一定的必要性。四通打字机的汉字机内码与PC机CCDOS的汉字机内码的差别主要是高位字节不同，前者高位的ASCII码比后者的小80H，另一方面的差别是在四通打字机WP系统下录入的文件，其每个软回车(其ASCII码为8DH)前有两个特殊的编辑字符，第一个字符的ASCII码为8EH。
通过以上的分析，作者用TURBO PASCAL编写了一个用于转换两个机器之中文文本文件的程序STPC.PAS，该程序经编译生成执行文件即可使用。使用方法:
STPC <输入文件> <输出文件>
其中，若输入文件为四通打字机的文本文件，则输出文件为PC机CCDOS的文本文件;若输入文件为PC机CCDOS的文本文件，则输出文件为四通打字机的文本文件。用该程序转换生成的CCDOS格式文件，可在WS下直接编辑、修改或打印，而生成的四通打字机格式的文件， 能在四通机的WP系统下直接处理。
源程序清单如下：
program stpc;
var
f1,f2 : file;
ch,ch1 : char;
fil1,fil2 : string;
begin
fil1 := paramstr(1);
fil2 := paramstr(2);
assign(f1,fil1);
assign(f2,fil2);
reset(f1,1);
rewrite(f2,1);
repeat
blockread(f1,ch,1);
case ch of
#$A1..#$FF:
begin
blockwrite(f2,ch,1);
blockread(f1,ch,1);
ch1 := chr(ord(ch) + $80);
ch := ch1;
end;
#$8E:
begin
blockread(f1,ch,1);
blockread(f1,ch,1);
end;
end;
blockwrite(f2,ch,1);
until eof(f1);
close(f1);
close(f2);
end.
§3.8 SPT和BMP文件的双向转换程序
SPT是Super-CCDOS提供的一个黑白两色的图文编辑程序，PaintBrush是WINDOWS提供的一个彩色图形编辑程序，它们各有优点，SPT提供的逐点编辑对图形的精细加工特别好用，而PaintBrush对图形的放大缩小是SPT所没有的。如果能够使两个程序直接交换数据，则是一件令人赏心的事情。
§3.8.1 SPT和BMP文件结构分析
通过对SPT和PaintBrush的图形文件的格式进行分析发现，SPT的未压缩Super Star图形文件(*.SPT)和PaintBrush的BMP格式文件(*.BMP)均是按点阵(位映象)存放图形的，只是存放次序和组织方法不同，所以完全可以利用这两种文件进行数据交换。PaintBrush中的BMP格式有单色位映象、16色位映象、256色位映象以及24b位映象4种，这里只考虑单色位映象一种格式，在此格式中，1bit(位)代表一个象素点，1B(字节)代表8个象素点。
SPT文件和BMP文件都有一个文件头，其中记录了图形的宽度、高度、文件长度和标志信息。SPT文件头有64B，如图3-1所示。前16B为SPT的文件头的标志，第34字节开始为两字节的图形宽度，紧接其后的是图形的高度，单位均是象素点。BMP的文件头如图3-2所示，前2B为标志，后面的4B是文件长度(LongInt)，第11，12两字节是指向点阵信息的指针，即从第3EH+1个字节开始存放点阵数据，第19，20字节表示图形宽度，23，24字节表示高度，单位也是象素点，第29字节(01)表示该BMP文件为单色位映象格式。BMP文件头共用了62字节。
殌櫪
SPT文件标志
3910:0100 敁53 75 70 65 72 2D 53 74-61 72 20 46 69 6C 65 1A敋 Super-Star File.
3910:0110 00 01 00 00 00 00 00 00-00 00 00 00 C0 EE C3 F7 ................
3910:0120 40 00 敁F0 03敋 敁F4 01敋 01 00-00 00 00 00 00 00 00 00 @...............
3910:0130 00 00 00 00 00 00 00 00-00 00 00 00 00 00 00 00 ................
图形宽度 图形高度
(1000点) (500点)
图3-1.SPT图形文件头
BMP文件标志 文件长度 指向点阵信息的指针
3910:0100 敁42 4D敋 敁76 28 00 00敋 00 00-00 00 敁3E 00敋 00 00 28 00 BMv(......v...(.
3910:0110 00 00 敁7B 00敋 00 00 敁A0 00敋-00 00 01 00 敁01敋 00 00 00 ..{.............
3910:0120 00 00 00 00 00 00 00 00-00 00 00 00 00 00 00 00 ................
3910:0130 00 00 00 00 00 00 00 00-00 00 00 00 80 00 ..............
图形宽度 图形高度 单色位映象格式标志
(123点) (160点)
图3-2.BMP图形文件头
殣
櫬 紧接文件头之后，SPT和BMP文件都是图形的点阵信息，SPT文件从图形的第一行开始，依次为第二、第三、...、第n行，BMP文件恰恰相反，为第n行、第n-1行、...、第一行，其中n为图形的高度。设图形的宽度为width个象素点，高度为height个象素点，因SPT只取width为8的倍数，故每行占的字节数LineByte为(width div 8);BMP文件中的width任意，但每行所占字节数必为4的倍数，所以实际每行所需字节数LineByte=(width+7) div 8。
据上述分析，用TURBO PASCAL编写了一个SPT_BMP.PAS程序，以实现SPT和BMP文件的双向转换。进行数据转换时应注意两点:(1)在SPT系统中存图形时，要选SuperStar文件类别，非压缩存储格式;(2)在PaintBrush存图时，在存文件对话框中打开Option文件格式选项，选Monochromoe bitmap项，然后存盘。
§3.8.2 程序使用方法
程序的使用方法是:
SPT_BMP
开关有两个选项:
/BS --- BMP文件转换为SPT文件
/SB --- SPT文件转换为BMP文件
§3.8.3 源程序清单
{ SPT_BMP.PAS 1.0 }
{ Copyright (c) 1994 Dong Zhanshan }
program Transfer_SPT_BMP;
const
SPT_Head : array[1..64] of byte = (
$53,$75,$70,$65,$72,$2D,$53,$74,$61,$72,$20,$46,$69,$6C,$65,$1A,
$00,$01,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$61,$62,$63,$64,
$40,$00,$00,$00,$00,$00,$01,$00,$00,$00,$00,$00,$00,$00,$00,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00);
BMP_Head : array[1..62] of byte = (
$42,$4D,$00,$00,$00,$00,$00,$00,$00,$00,$3E,$00,$00,$00,$28,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$01,$00,$01,$00,$00,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$FF,$FF,$FF,$00);
var
BMP_file,SPT_file : string;
ch : char;
BMP,SPT : file;
OneLine : array[1..1000] of char;
Width,Height,Bytes : word;
LineByte,Ofs,FileLength : longint;
Switch : string[3];
i : integer;
procedure DispError;
begin
if IOResult <>0 then
Begin
Writeln('File not found !');
halt;
end;
end;
procedure SPT_to_BMP;
var
i : integer;
begin
if pos('.',SPT_file) = 0 then SPT_file := SPT_file + '.SPT';
if pos('.',BMP_file) = 0 then BMP_file := BMP_file + '.BMP';
assign(SPT,SPT_file);
{$I-} reset(SPT,1); {$I+}
assign(BMP,BMP_file);
rewrite(BMP,1);
seek(SPT,34);
blockread(SPT,Width,2);
blockread(SPT,Height,2);
bytes := Width div 8;
LineByte := ((Bytes + 3) div 4) * 4;
FileLength := FileSize(SPT);
move(FileLength,BMP_Head[3],4);
move(Width,BMP_Head[19],2);
move(Height,BMP_Head[23],2);
blockwrite(BMP,BMP_Head,62);
for i := bytes to LineByte do OneLine[i] := #0;
for i := Height downto 1 do
begin
Ofs := bytes * (i-1) + 64;
seek(SPT,ofs);
blockread(SPT,OneLine,Bytes);
blockWrite(BMP,OneLine,LineByte);
end;
close(SPT);
close(BMP);
end;
procedure BMP_to_SPT;
var
i : integer;
begin
if pos('.',BMP_file) = 0 then BMP_file := BMP_file + '.BMP';
if pos('.',SPT_file) = 0 then SPT_file := SPT_file + '.SPT';
assign(BMP,BMP_file);
{$I-} reset(BMP,1); {$I+}
assign(SPT,SPT_file);
rewrite(SPT,1);
seek(BMP,18);
blockread(BMP,Width,2);
seek(BMP,22);
blockread(BMP,Height,2);
bytes := (Width + 7) div 8;
LineByte := ((Width + 31) div 32) * 4;
Width := bytes * 8;
move(Width,SPT_Head[35],2);
move(Height,SPT_Head[37],2);
blockwrite(SPT,SPT_Head,64);
for i := Height downto 1 do
begin
Ofs := LineByte * (i-1) + 62;
seek(BMP,ofs);
blockread(BMP,OneLine,linebyte);
blockwrite(SPT,OneLine,bytes);
end;
close(BMP);
close(SPT);
end;
procedure Help;
begin
Writeln('Syntex : SPT_BMP ');
halt;
end;
begin
Writeln('SPT_BMP Version 1.0 Copyright (c) 1994 Dong Zhanshan');
case ParamCount of
0,1,2 : help;
3 : begin
SPT_file := ParamStr(1);
BMP_file := ParamStr(2);
Switch := ParamStr(3);
end;
end;
for i := 2 to 3 do Switch[i] := UpCase(Switch[i]);
if Switch = '/SB' then SPT_to_BMP;
if Switch = '/BS' then BMP_to_SPT;
end.
3.9 数据库打卡程序PDBC.PAS
每个DBASE数据库文件均是许多数据的集合,是数据的仓库,是数据的电子银行。数据从纸张上进入计算机，是为了查询方便等。但当数据库建成并校正无误后，往往要打印一份或多份，以备案留底，用数据库管理软件的报表打印功能，可以打印出数据结果，但是其打印速度比较慢，当需要按表格格式一张一张输出每一个记录时，用DBASE软件就比较麻烦，作者用TURBO PASCAL编写了一个程序，它使用第二章的DBASE单元提供的功能，读取DBASE数据库文件的记录结构，然后构造一个空白的表格，接着读取每一个DBASE数据库记录,将其填入空白表格，最后输入到一个文本文件中。
该程序的使用方法是：
PDBC <数据库文件> <输出文件>
源程序清单:
{ PDBC.PAS 1.5 }
{ Copyright (c) 1991,94 Dong Zhanshan }
program PrintDBaseCard;
{ DBASE数据库卡片打印程序 }
uses crt,dos,DBase,AStr;
const
Frame : array[1..11] of string[2] =
('┌','┐','└','┘','├','┤','┬','┴','┼','─','│');
type
_line = array[1..50] of string;
var
RecInfo : StrucType; { 数据库结构 }
Rec : RecTypePtr; { 记录内容 }
line_ : _line; { 卡片内容 }
r : array[1..128,1..2] of integer; { 字段在卡片中的位置 }
NumLine : integer; { 卡片行数 }
fl1,fl2 : string[64]; { 文件名 }
f1 : file; { 数据库文件号 }
procedure tables;
{ 填空白表过程 }
var i,k,m,StartRecord,OTextAttr : integer;
FieldStr : string;
ch : char;
f2 : text;
begin
assign(f2,fl2);
rewrite(f2);
with RecInfo do
begin
write('Input start record(1..',NumRec:5,')---');
readln(StartRecord);
OTextAttr := TextAttr;
TextAttr := blink+0*16+15;
writeln('Working ...... ');
TextAttr := OTextAttr;
getmem(rec,LengthRec);
for m := StartRecord to NumRec do
begin
ReadRecord(f1,m,RecInfo,Rec);
for i := 1 to NumField do
begin
with Field^[i] do
begin
FieldStr := '';
for k := 1 to FldWidth do
FieldStr := FieldStr + rec^[k+FldOffset];
move(FieldStr[1],line_[r[i,2]+1][r[i,1]+2],length(FieldStr));
end;
end;
for i := 1 to NumLine do writeln(f2,line_[i]);
writeln(f2);
end;
end;
close(f2);
end;
procedure maketable;
{ 造空白表过程 }
var temp1,temp2 : string;
ii,ll : integer;
FldWidth1 : integer;
i,j,k,l,m,cw : integer;
_start,_end : boolean;
q,q1 : integer;
c,t : array [1..16] of integer;
function CalFldWidth(FieldNo : integer):integer;
{ 计算字段宽度函数 }
var
FldWidth1 : integer;
begin
with Recinfo.Field^[FieldNo] do
begin
if odd(length(FldName)) then FldName := FldName + #32;
if odd(FldWidth) then FldWidth1 := FldWidth + 1
else FldWidth1 := FldWidth;
CalFldWidth := FldWidth1 + length(FldName) + 4;
end;
end;
function inn(mm:integer):boolean;
var n : integer;
begin
for n := 1 to q do
if mm = c[n] then
begin
inn:= true;
exit;
end;
inn := false;
end;
procedure ChangeLine;
{ 换行过程 }
var ii : word;
begin
while k <= cw - 3 do
begin
temp2 := temp2 + #32#32;
if not inn(k) then temp1 := temp1 + Frame[10]
else temp1 := temp1 + Frame[8];
inc(k,2);
end;
if _start then temp1 := temp1 +Frame[2]
else temp1 := temp1 + Frame[6];
temp2 := temp2 +Frame[11];
line_[j] := temp1;
line_[j+1] := temp2;
inc(j,2);
temp1 := Frame[5];
temp2 := '';
k := 3;
if _start then _start := not _start;
q := q1;
for ii := 1 to 16 do c[ii] := t[ii];
for ii := 1 to 16 do t[ii] := 0;
q1 := 1;
end;
{ MakeTable过程开始 }
begin
i := 1; { 字段计数器 }
j := 1; { 行数计数器 }
k := 3; { 行内字符个数计数器 }
l := 1;
m := 1; { 循环计数器 }
q := 1; { 行内表格拐角计数器 }
q1 := 1; { 行内表格拐角计数器 }
FldWidth1 := 0;
_start := true;
_end := false;
temp2 := '';
temp1 := Frame[1];
for ii := 1 to 16 do c[ii] := 0;
for ii := 1 to 16 do t[ii] := 0;
write('Input line length(1..124)---');
readln(cw);
L := CalFldWidth(i);
while not _end do
begin
with RecInfo.Field^[i] do
begin
if odd(FldWidth) then FldWidth1 := FldWidth +1
else FldWidth1 := FldWidth ;
temp2 := temp2 +Frame[11] +Fldname + Frame[11] + space(FldWidth1);
for m := 1 to length(Fldname) do
begin
if not inn(k) then temp1 := temp1 + Frame[10]
else if ( m <> length(Fldname[i]) + 1 ) then temp1 := temp1 + Frame[8]
else temp1 := temp1 + Frame[9];
inc(m);
inc(k,2);
end;
r[i,1] := k;
r[i,2] := j;
t[q1] := k;
inc(q1);
if not inn(k) then temp1 := temp1 + Frame[7]
else temp1 := temp1 + Frame[9];
inc(k,2);
if odd(FldWidth ) then FldWidth1 := FldWidth +1
else FldWidth1 := FldWidth ;
for m := 1 to FldWidth1 do
begin
if not inn(k) then temp1 := temp1 + Frame[10]
else if m <> FldWidth1 + 1 then temp1 := temp1 + Frame[8]
else temp1 := temp1 + Frame[9];
inc(m);
inc(k,2);
end;
inc(i);
if i > RecInfo.NumField then _end := true;
ll := CalFldWidth(i);
if _end then ChangeLine
else if (ll + k) >= cw - 1 then ChangeLine
else
begin
t[q1] := k;
inc(q1);
if not inn(k) then temp1 := temp1 + Frame[7]
else temp1 := temp1 + Frame[9];
inc(k,2);
end;
end;
end;
temp1 := Frame[3];
i := 3;
while i <= cw-3 do
begin
if not inn(i) then temp1 := temp1 + Frame[10]
else temp1 := temp1 + Frame[8];
inc(i,2);
end;
temp1 := temp1 + Frame[4];
line_[j] := temp1;
NumLine := j;
end;
procedure help;
{ 显示帮助信息 }
begin
writeln('Syntex : PDBC DBASE_filename output_filename');
halt;
end;
{ 主程序开始 }
begin
writeln('PDBC Version 1.5 Copyright (c) 1991,94 Dong Zhanshan');
if paramcount<2 then help;
fl1 := paramstr(1);
if FSearch(fl1,'') = '' then exit;
fl2 := paramstr(2);
OpenDBase(fl1,f1,RecInfo);
MakeTable;
Tables;
CloseDBase(f1,RecInfo);
writeln(#7,#7,'End !!!');
end.
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 16:01:50
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第16楼
§3.10 BAT文件转换为COM的程序
众所周知，批处理文件具有编写和使用方便，占用内存少等独到的优点，特别是DOS 3.30以后的版本，又增加了许多新批命令，使批处理文件使用起来更得心应手。但批处理文件是用ASCII码存储的，这既是优点也是缺点。当你编写好一个软件后，其中要用到批处理文件，则会出现泄密的现象。怎样把批处理文件编译为命令文件，而得到一定程度的保密呢?
§3.10.1 批处理文件(.BAT)转换为命令文件(.COM)的技术原理
DOS的功能调用4BH是执行装入一个外部程序，并有选择地执行之，使用起来比较麻烦。DOS还提供了一个调用规则很简单的软中断2EH，可用之完成执行DOS内部和外部命令的要求。
中断2EH的调用规则:首先使用DOS功能调用4AH，开辟一个适当大小的缓冲区，然后，把DS:SI指向以命令串长度为先导的，以回车(0DH)为后缀的待执行命令串，然后执行中断。在执行2EH之后，除CS外的所有寄存器均被破坏，所以在执行中断调用之前，要把使用的寄存器保护起来，中断返回后再恢复之。
在批处理文件中，可以把命令等分成以下几类:①内部命令和外部命令，②标号，③注释，④条件语句，⑤转移语句，⑥循环语句。
对第一类命令，可以直接使用2EH实现;对第二类命令，只需在适当的地方构造一个标号即可;对第三类命令，在编译过程中，自动删除之;对第四类命令，要使用比较(CMP)与转移(JE，JNE等)来实现;对第五类命令，使用无条件转跳语句(JMP)来实现;而循环语句，即FOR语句，可以把它当作DOS命令来使用，只是要把"%%"符号改为"%"。
实现了以上的各类命令，再构造几各通用的子程序就可以完成BAT到COM文件的转换。需要构造的子程序有执行2EH的子程序，执行DOS返回的子程序和获得DOS命令行参数的子程序等。
§3.10.2 构造编译程序
要把BAT文件转换为COM文件，还需要有一个有效的编译程序，它主要把相应的BAT文件中相应的命令解译为汇编程序码或机器码，形成有效的ASM文件或COM文件，最后完成BAT到COM的编译工作。本文提供了一个将BATCH文件转换为COM文件的演示程序B2C.PAS。
§3.10.3 源程序清单
{ B2C.PAS 1.0 }
{ Copyright (c) 1993,94 Dong Zhanshan }
program Translate_Batch_to_COM;
uses dos;
const
Bat2ComHead : Array[1..81] of byte = (
$BB,$00,$10,$B4,$4A,$CD,$21,$0E,$1F,$2E,$8B,$0E,$51,$01,$BE,$51,
$01,$8B,$C6,$50,$5B,$51,$83,$C3,$02,$8B,$F3,$33,$DB,$8A,$1C,$53,
$56,$2E,$8C,$16,$4D,$01,$2E,$89,$26,$4F,$01,$CD,$2E,$0E,$1F,$2E,
$8B,$26,$4F,$01,$2E,$8E,$16,$4D,$01,$58,$5B,$59,$03,$C3,$50,$83,
$E9,$01,$83,$F9,$00,$75,$CD,$B8,$00,$4C,$CD,$21,$C3,$00,$00,$00,
$00);
var
str1 : string;
txtfl : text;
bfl : file of char;
buffer : array[1..10000] of char;
flnm : string;
TotalLength : word;
procedure RemoveSpace(Var str1:string);
var i : word;
begin
i := pos(' ',str1);
if i = 1 then
begin
delete(str1,1,1);
RemoveSpace(str1);
end;
end;
procedure RemoveDouble(Var str1:string);
var i : word;
begin
i := pos('%%',str1);
delete(str1,i,1);
if not (pos('%%',str1)=0) then RemoveDouble(str1);
end;
Procedure RemoveFlowerA( Var Str1:string);
var i : word;
begin
i := pos('@',str1);
if i = 1 then
delete(str1,1,1);
end;
procedure Transfer;
var strlen : word;
cmnum : word;
ch : char;
begin
assign(txtfl,flnm);
reset(txtfl);
cmnum := 0;
ch := char($0d);
TotalLength := 84;
repeat
readln(txtfl, str1);
removespace(str1);
removedouble(str1);
removeflowera(str1);
strlen := length(str1);
inc(cmnum);
move(str1, buffer[TotalLength], strlen + 1);
TotalLength := TotalLength + strlen + 1;
move(ch,buffer[TotalLength],1);
inc(TotalLength);
until eof(txtfl);
move(cmnum,buffer[82],2);
close(txtfl);
end;
procedure WriteBAT2COM;
var i : word;
begin
i := pos('.',flnm);
str1 := copy(flnm,1,i-1);
str1 := str1 + '.com';
move(BAT2COMHead,Buffer,81);
assign(bfl,str1);
rewrite(bfl);
for i := 1 to TotalLength do write(bfl,buffer[i]);
close(bfl);
end;
procedure Help;
begin
Writeln('Syntex : B2C Batch_filename');
halt;
end;
begin
writeln('B2C Version 1.0 Copyright (c) 1993,94 Dong Zhanshan');
case ParamCount of
0 : Help;
1 : Flnm := ParamStr(1);
else Help;
end;
if FSearch(flnm,'') = '' then help;
Transfer;
WriteBAT2COM;
end.
§3.11 机密文件的有效销毁程序
当删除一个DOS文件时，其实并未从磁盘上移走什么，这就给恢复文件提供了机会，某些人如果拥有合适的软件，就可以非法查看用户自以为已经销毁的数据。Norton Utilities和PC Tools都有实用程序能够从物理上真正删除文件，而避免文件被恢复，导致泄密。假如手头没有这类软件，可以使用下面的WIPE.PAS程序，可以实现同样的功能。
运行WIPE程序时，键入需要删除的文件名作为命令行参数。一旦用户确认确实希望删除该文件，程序即按美国国防部DOD5220.22M标准擦掉需要删除的机密数据。要删除的文件首先被写为'0'，再被写为'1'，如此重复3次，接着被写上一个随机值。再加上一个DOD标准中未说明的步骤，即在删除之前，先将文件名改为单字符文件名，如'X'，就能够使用恢复程序恢复机密文件的希望更加渺茫。
源程序清单:
{ WIPE.PAS 1.0 }
{ Copyright (c) 1994 Dong Zhanshan }
program Wipe_File;
{$I-,S-,R-}
uses Acrt;
var
f : file;
pass : integer;
ch : char;
procedure Stop;
begin
Writeln('Error Wiping file');
halt;
end;
procedure ErrorCheck;
begin
if IOResult <> 0 then Stop;
end;
procedure WipeWith(var f : file; c : char);
var i : longint;
r : word;
begin
Reset(f,1);
ErrorCheck;
for i := 1 to FileSize(f) do
begin
BlockWrite(f,c,1,r);
if r <> 1 then Stop;
end;
close(f);
ErrorCheck;
end;
Begin
Writeln('WIPE Version 1.0 Copyright (c) 1992 Vincent D. O''conner');
if ParamCount <> 1 then
begin
Writeln('Syntex : WIPE ');
exit;
end;
if not YesNo('Are you sure') then halt;
Randomize;
Assign(f,ParamStr(1));
ErrorCheck;
For pass := 1 to 3 do
begin
WipeWith(f,#0);
WipeWith(f,#1);
end;
WipeWith(f,chr(Random(256)));
Rename(f,'X');
ErrorCheck;
Erase(f);
ErrorCheck;
Writeln('Done!',#7);
end.
§3.12 释放内存程序
目前，一个好的TSR软件，应该在不需要时能够及时从内存中撤离，并且完全地把TSR占用的内存释放掉，供其它程序使用。例如CCDOS2.13H/SPDOS6.0F等；但是，也有一些软件在运行完后，不能及时从内存中撤离，浪费了内存空间，如SPDOS 5.0/UCDOS 1.0等。
由于DOS操作系统有640K常规内存的限制，如果不能有效地控制和释放内存中的各种TSR程序，在运行一些大型软件时就会发现内存不足的现象，往往就不得不重新启动系统，这样不仅浪费了宝贵的时间，而且也容易损坏机器。
要释放内存中TSR软件申请的内存资源，首先我们要恢复TSR软件运行前的中断向量表，其次是释放DOS分配给TSR的内存资源。我们知道当DOS装入一个程序时必须建立内存分配块，它是由一个16字节长的内存控制块(MCB)和以节为单位的内存块两部分组成。如果多个程序建立了多个内存分配块，这些分配块在内存中就形成一条内存控制链，用DOS服务52H，可以知道第一个内存控制块的地址，这对于释放内存资源是有用的。内存控制块的第一域为1字节标志位，4DH表示内存控制链没结束，05H表示结束。第二域为2字节长，为程序的PSP的地址。第三域为2字节长，为该内存分配块的长度，我们用当前内存控制块的地址与第三域值相加，结果就是下一个内存控制块的地址，这在释放内存时将用到。
当我们找到属于TSR的内存控制块后，通过DOS服务49H的调用就可以释放这块内存了，在调用该功能前需要将内存控制块所在段地址加1装入ES寄存器中。重复这个过程，从一个内存控制块移向另一个内存控制块并释放它，直到最后一块。
根据上述原理，用TURBO PASCAL编写一个内存资源释放程序RMEM.PAS，它修改了5H中断向量。此程序应该在要释放的TSR程序之前执行。当需要清除内存时，按下PRINT SCREEN键，即可释放其后装入的程序所占的内存了。该程序只需执行一次，即可多次使用。
源程序清单:
{ RMEM.PAS 1.0 }
{ Copyright (c) 1994 Dong Zhanshan }
{$M 1024,0,0}
Program Release_Memory;
uses dos;
type
intab = array[1..255] of longint;
var
inta : intab;
i : integer;
r : registers;
p : pointer;
mcb,mcb1end,mcb2end,tsrpsp : word;
str,flag : byte;
Procedure ramtsr;
interrupt;
label endl;
begin
r.ah := $52;
msdos(r);
mcb2end := memw[r.es:r.bx-2];
while (mem[mcb2end:0]) = $4d do
mcb2end := mcb2end + memw[mcb2end:3] + 1;
if mcb2end = mcb1end then goto endl;
mcb := mcb1end;
for i := 0 to 255 do
meml[0:4*i] := inta[i];
while (mem[mcb:0] = $4d) do
begin
tsrpsp := memw[mcb:1];
r.ah := $49;
r.es := mcb + 1;
msdos(r);
mcb := mcb + memw[mcb:3] + 1;
end;
endl:
r.ah := 0;
r.al := 3;
intr($10,r);
end;
begin
flag := 10;
getintvec($78,p);
move(p^,str,1);
if str = flag then
begin
writeln('Release Memory Has Installed !');
exit;
end
else
setintvec($78,@flag);
r.ah := $52;
msdos(r);
mcb1end := memw[r.es:r.bx-2];
while (mem[mcb1end:0] = $4d) do
mcb1end := mcb1end + memw[mcb1end:3] + 1;
writeln('Release Memory is already !');
setintvec($5,@ramtsr);
for i := 0 to 255 do
inta[i] := meml[0:4*i];
keep(0);
end.
----------------------------------------------
你是风儿我是沙，论坛就是我的家
PS：“风沙人”是我的老的ID，“水木风沙”：=“风沙人”
新注册了个ID——PASSBYWORD，还是我。
2003-4-2 16:02:05
风沙人
头衔：站长
等级：管理员
威望：2
文章：927
积分：1863
门派：反日大联盟
注册：2002-8-4
第17楼
本贴所有的源程序:
点击浏览该文件
和可执行程序:
点击浏览该文件
源程序文件索引表
文件名 所在章节
ACRT.PAS 2.1
ACRT.ASM 2.1
ACRTDEMO.PAS 2.1
AR1.PAS 1.6
AR2.PAS 1.6
AR3.PAS 1.6
ASL.PAS 3.4
ASTR.PAS 2.2
ASTR.ASM 2.2
ASTRDEMO.PAS 2.2
B2C.PAS 3.10
COMPDEMO.PAS 2.11
COMPLEX.PAS 2.11
CPASDEMO.PAS 1.3
CPASDEMO.C 1.3
CPDEMO.PAS 1.3
CPUNIT.PAS 1.3
CTOPAS.C 1.3
DBASE.PAS 2.5
DBDEMO.PAS 2.5
DISK.PAS 2.3
DISK.ASM 2.3
DISKDEMO.PAS 2.3
EMS.PAS 2.6
EMS.ASM 2.6
EMSDEMO.PAS 2.6
GREP.PAS 3.5
HDL.PAS 3.2
HMR.PAS 3.6
INTR.PAS 1.5
LOGTAB.PAS 1.4
MATH.PAS 2.8
MATHDEMO.PAS 2.8
MATRDEMO.PAS 2.9
MATRIX.PAS 2.9
MKBINDAT.PAS 1.9
PDBC.PAS 3.9
POPDEMO.PAS 2.4
POPUP.PAS 2.4
PROB.PAS 2.10
PROBDEMO.PAS 2.10
RMEM.PAS 3.12
SIMPSON.PAS 1.4
SL.PAS 3.1
SOFTLOCK.ASM 3.1
SP.PAS 3.3
SPT_BMP.PAS 3.8
STPC.PAS 3.7
TESTBIN.PAS 1.9
WIPE.PAS 3.11
XMS.PAS 2.7
XMS.ASM 2.7
XMSDEMO.PAS 2.7
附录2 各种显示卡及其显示模态
显示方式 显示卡 文本/图形
0 CGA,EGA,VGA,MCGA,3270 文本
1 同上 文本
2 同上 文本
3 同上 文本
4 同上 图形
5 同上 图形
6 同上 图形
7 MDA,EGA,VGA,3270 文本
d h EGA,VGA 图形
e h 同上 图形
f h 同上 图形
10h 同上 图形
11h MCGA,VGA 图形
12h VGA 图形
13h MCGA,VGA 图形
注：MDA单色卡,CGA彩色卡,EGA增强图形卡,
MCGA多色图形卡,VGA视屏图形卡,
3270IBM3270图形卡
PASCAL 高级编程相关推荐
- C++高级编程资料汇总（参考手册+电子书+编程思想+算法分析） ...
整理C++高级编程方面的资料,有参考手册,有高级教程电子书,有范例分析,有算法分析,欢迎大家下载~ C++沉思录 http://down.51cto.com/data/423064 C++ 高级参考手 ...
- 嵌入式Linux编程基础ppt,嵌入式LinuxC高级编程.ppt
<嵌入式LinuxC高级编程.ppt>由会员分享,可在线阅读,更多相关<嵌入式LinuxC高级编程.ppt(45页珍藏版)>请在装配图网上搜索. 1.嵌入式Linux C高级编 ...
- Go 学习推荐 —（Go by example 中文版、Go 构建 Web 应用、Go 学习笔记、Golang常见错误、Go 语言四十二章经、Go 语言高级编程）
Go by example 中文版 Go 构建 Web 应用 Go 学习笔记:无痕 Go 标准库中文文档 Golang开发新手常犯的50个错误 50 Shades of Go: Traps, Gotc ...
- linux web高级编程,寒假学习 第16.17天 （linux 高级编程）
寒假学习 第16.17天 (linux 高级编程) 笔记 总结 一.进程的基本控制(进程的同步) 1.进程的常见控制函数 pause sleep/usleep atexit on_exit i ...
- Oracle SQL高级编程——分析函数（窗口函数）全面讲解
Oracle SQL高级编程--分析函数(窗口函数)全面讲解 注:本文来源于:<Oracle SQL高级编程--分析函数(窗口函数)全面讲解> 概述 分析函数是以一定的方法在一个与当前行相 ...
- 如何学习android高级编程
学了android高级编程有前途吗?进入2010年之后,android的应用开发进入了一个爆炸式增长的状态,从去年的不到1万款应用程序增加到现在的9万,而且即将突破10万,这也从开发者这一方面展现了用 ...
- Linux环境高级编程函数,Linux环境高级编程--出错处理（CLStatus）
很多程序库对外提供若干类,每个方法出错时如何告知调用者是否出错,以及出错码(在Linux上在error.h中的全局errno就是保存我们Linux程序执行的出错码的)?方法很多,为了简化起见,函数将返 ...
- PL/SQL高级编程
PL/SQL高级编程 实验目的: 1.掌握PL/SQL的数据结构和编程结构,掌握应用PL/SQL编写简单程序的方法 2.理解存储过程的概念,掌握编写存储过程的方法 3.理解函数的概念,掌握编写存储过程 ...
- NDK 高级编程(笔记)
Android 开发中针对 NDK 的书籍很少,<Pro Android C++ with the NDK>也是出版的比较早的一本书,有些内容可能对现在的开发并不适用.但是书中介绍的内容比 ...
- PHP 高级编程之多线程
PHP 高级编程之多线程 http://netkiller.github.io/journal/thread.php.html Mr. Neo Chen (netkiller), 陈景峰(BG7NYT ...
最新文章
- java学习之匿名内部类与包装类
- 数据结构--Javascript--排序篇
- 洛谷 [P2590] 树的统计
- linux下collada-dom编译,COLLADA DOM Tutorial
- 万字长文了解免疫算法原理 及求解复杂约束问题（源码实现）
- 转：Some interesting facts about SharePoint 2007 Search
- 12c oracle 激活_Windows运维之Windows server 2016 安装及ORACLE 12C 安装
- php中$stu_by,PHP基础案例二：计算学生年龄
- 网页无法调用java9_JAVA 9 （内部类，异常，包）
- 企业即时通讯规模将达7亿
- MySQL 中 declare 声明的局部变量和 @var 会话变量的使用介绍
- Jmeter（五）bayboy录制时弹窗“当前页面的脚本发生错误”解决办法
- 永恩上线服务器维护,LOL10.16永恩BUG商城问题介绍-LOL10.16永恩BUG商城问题有哪些_牛游戏网...
- 基于树结构的机器学习模型
- 有没有免费刷IP的网站，PV也行
- 递归：由浅入深，深入了解递归
- Unity线程与协程
- C# 实现人员信息管理软件（增删查改操作）
- win10, net framework 3.5 安装报错0x800F081F
- 粉扑怎么用如何用粉扑上粉底