oberon-07-compiler/source/Compiler.ob07

(*
	BSD 2-Clause License

	Copyright (c) 2018, Anton Krotov
	All rights reserved.
	*)

MODULE Compiler;

IMPORT mSt := STATEMENTS,
	mTarg := TARGETS,
	mPars := PARS,
	mUtil := UTILS,
	mPath := PATHS,
	mCons := CONSOLE,
	mErr  := ERRORS,
	mStr  := STRINGS,
	mVer  := VER,
	mWrit := WRITER;

CONST
	EXT = ".ob07";

PROCEDURE Target_Get (s: ARRAY OF CHAR): INTEGER;
	VAR
		res: INTEGER;
	BEGIN
		IF s = "con" THEN
			res := mTarg.CONSOLE
		ELSIF s = "gui" THEN
			res := mTarg.GUI
		ELSIF s = "dll" THEN
			res := mTarg.DLL
		ELSIF s = "kos" THEN
			res := mTarg.KOS
		ELSIF s = "obj" THEN
			res := mTarg.OBJ
		ELSIF s = "win64" THEN
			res := mTarg.WIN64
		ELSE
			res := 0
		END

		RETURN res
	END Target_Get;

PROCEDURE keys (VAR StackSize, BaseAddress, Version: INTEGER; VAR pic, reloc: BOOLEAN; VAR checking: SET);
	VAR
		param: mPars.PATH;
		i, j:  INTEGER;
		end:   BOOLEAN;
		value: INTEGER;
		minor,
		major: INTEGER;

	BEGIN
		end := FALSE;
		i := 4;
		REPEAT
			mUtil.GetArg(i, param);

			IF param = "-stk" THEN
				INC(i);
				mUtil.GetArg(i, param);
				IF mStr.StrToInt(param, value) & (1 <= value) & (value <= 32) THEN
					StackSize := value
				END;
				IF param[0] = "-" THEN
					DEC(i)
				END

			ELSIF param = "-base" THEN
				INC(i);
				mUtil.GetArg(i, param);
				IF mStr.StrToInt(param, value) THEN
					BaseAddress := ((value DIV 64) * 64) * 1024
				END;
				IF param[0] = "-" THEN
					DEC(i)
				END

			ELSIF param = "-nochk" THEN
				INC(i);
				mUtil.GetArg(i, param);

				IF param[0] = "-" THEN
					DEC(i)
				ELSE
					j := 0;
					WHILE param[j] # 0X DO

						IF    param[j] = "p" THEN
							EXCL(checking, mSt.chkPTR)
						ELSIF param[j] = "t" THEN
							EXCL(checking, mSt.chkGUARD)
						ELSIF param[j] = "i" THEN
							EXCL(checking, mSt.chkIDX)
						ELSIF param[j] = "b" THEN
							EXCL(checking, mSt.chkBYTE)
						ELSIF param[j] = "c" THEN
							EXCL(checking, mSt.chkCHR)
						ELSIF param[j] = "w" THEN
							EXCL(checking, mSt.chkWCHR)
						ELSIF param[j] = "r" THEN
							EXCL(checking, mSt.chkCHR);
							EXCL(checking, mSt.chkWCHR);
							EXCL(checking, mSt.chkBYTE)
						ELSIF param[j] = "a" THEN
							checking := {}
						END;

						INC(j)
					END
				END

			ELSIF param = "-ver" THEN
				INC(i);
				mUtil.GetArg(i, param);
				IF mStr.StrToVer(param, major, minor) THEN
					Version := major * 65536 + minor
				END;
				IF param[0] = "-" THEN
					DEC(i)
				END

			ELSIF param = "-pic" THEN
				pic := TRUE

			ELSIF param = "-reloc" THEN
				reloc := TRUE

			ELSIF param = "" THEN
				end := TRUE

			ELSE
				mErr.error3("bad parameter: ", param, "")
			END;

			INC(i)
		UNTIL end

	END keys;

PROCEDURE Main;
	VAR
		path:       mPars.PATH;
		inname:     mPars.PATH;
		ext:        mPars.PATH;
		app_path:   mPars.PATH;
		lib_path:   mPars.PATH;
		modname:    mPars.PATH;
		outname:    mPars.PATH;
		param:      mPars.PATH;
		temp:       mPars.PATH;

		target:     INTEGER;

		time:       INTEGER;

		StackSize,
		Version,
		BaseAdr:    INTEGER;
		pic, reloc: BOOLEAN;
		checking:   SET;

	BEGIN
		StackSize := 1;
		Version := 65536;
		pic := FALSE;
		reloc := FALSE;
		checking := mSt.chkALL;

		mPath.GetCurrentDirectory(app_path);
		lib_path := app_path;

		mUtil.GetArg(1, inname);

		IF inname = "" THEN
			mCons.String("Akron Oberon-07/16 Compiler v"); mCons.Int(mVer.Major); mCons.String("."); mCons.Int2(mVer.Minor); mCons.Ln; mCons.Ln;
			mCons.String("Usage: Compiler <main module> <output> <target> [optional settings]"); mCons.Ln; mCons.Ln;
			mCons.String('target = "con" | "gui" | "dll" | "kos" | "obj"'); mCons.Ln; mCons.Ln;
			mCons.String("optional settings:"); mCons.Ln; mCons.Ln;
			mCons.String("  -stk <size>            set size of stack in megabytes"); mCons.Ln; mCons.Ln;
			mCons.String("  -base <address>        set base address of image in kilobytes"); mCons.Ln; mCons.Ln;
			mCons.String("  -pic                   generate position-independent code"); mCons.Ln; mCons.Ln;
			mCons.String("  -reloc                 make relocation table"); mCons.Ln; mCons.Ln;
			mCons.String('  -ver <major.minor>     set version of program ("obj" only)'); mCons.Ln; mCons.Ln;
			mCons.String('  -nochk <"ptibcwra">    disable runtime checking (pointers, types, indexes,'); mCons.Ln;
			mCons.String('                         BYTE, CHR, WCHR)'); mCons.Ln; mCons.Ln;
			mUtil.Exit(0)
		END;

		mPath.split(inname, path, modname, ext);
		IF ext # EXT THEN
			mErr.error3('inputfile name extension must be "', EXT, '"')
		END;
		IF mPath.isRelative(path) THEN
			mPath.RelPath(app_path, path, temp);
			path := temp
		END;

		mUtil.GetArg(2, outname);
		IF outname = "" THEN
			mErr.error1("not enough parameters")
		END;
		IF mPath.isRelative(outname) THEN
			mPath.RelPath(app_path, outname, temp);
			outname := temp
		END;

		mUtil.GetArg(3, param);
		IF param = "" THEN
			mErr.error1("not enough parameters")
		END;

		target := Target_Get(param);
		
		IF target = 0 THEN
			mErr.error1("bad parameter <target>")
		END;

		IF target = mTarg.WIN64 THEN
			IF mUtil.bit_depth = 32 THEN           
				mErr.error1("bad parameter <target>")
			END;
			mPars.init(64)
		ELSE
			mPars.init(32)
		END;

		mPars.program.dll := target IN {mTarg.DLL, mTarg.OBJ};
		mPars.program.obj := target = mTarg.OBJ;

		mStr.append(lib_path, "lib");
		mStr.append(lib_path, mUtil.slash);

		IF target IN {mTarg.CONSOLE, mTarg.GUI, mTarg.DLL} THEN
			IF target = mTarg.DLL THEN
				BaseAdr := 10000000H
			ELSE
				BaseAdr := 400000H
			END;
			mStr.append(lib_path, "Windows32")

		ELSIF target IN {mTarg.KOS, mTarg.OBJ} THEN
			mStr.append(lib_path, "KolibriOS")

		ELSIF target = mTarg.WIN64 THEN
			mStr.append(lib_path, "Windows64")

		END;

		mStr.append(lib_path, mUtil.slash);

		keys(StackSize, BaseAdr, Version, pic, reloc, checking);

		mSt.compile(path, lib_path, modname, outname, EXT, target, Version, StackSize, BaseAdr, pic, reloc, checking);

		time := mUtil.GetTickCount() - mUtil.time;

		mCons.Int(time DIV 100); mCons.String("."); mCons.Int2(time MOD 100); mCons.String(" sec, ");
		mCons.Int(mWrit.counter); mCons.String(" bytes"); mCons.Ln;

		mUtil.Exit(0)
	END Main;

BEGIN
	Main
END Compiler.