diff options
Diffstat (limited to 'rtl/sinclairql/system.pp')
| -rw-r--r-- | rtl/sinclairql/system.pp | 201 |
1 files changed, 171 insertions, 30 deletions
diff --git a/rtl/sinclairql/system.pp b/rtl/sinclairql/system.pp index 45d8d82548..e168c2e614 100644 --- a/rtl/sinclairql/system.pp +++ b/rtl/sinclairql/system.pp @@ -19,16 +19,13 @@ interface {$define FPC_IS_SYSTEM} {$define FPC_STDOUT_TRUE_ALIAS} {$define FPC_ANSI_TEXTFILEREC} -{$define FPC_QL_USE_TINYHEAP} +{$define FPC_QL_USE_OSHEAP} -{$ifdef FPC_QL_USE_TINYHEAP} +{$ifdef FPC_QL_USE_OSHEAP} {$define HAS_MEMORYMANAGER} -{$endif FPC_QL_USE_TINYHEAP} +{$endif FPC_QL_USE_OSHEAP} {$i systemh.inc} -{$ifdef FPC_QL_USE_TINYHEAP} -{$i tnyheaph.inc} -{$endif FPC_QL_USE_TINYHEAP} {Platform specific information} const @@ -57,13 +54,13 @@ const StdErrorHandle: longint = UnusedHandle; var - args: PChar; - argc: LongInt; - argv: PPChar; - envp: PPChar; - - heapStart: pointer; + QL_ChannelIDNum : word; + QL_ChannelIDs: pdword; + QL_CommandLineLen : word; + QL_CommandLine : pchar; + argv: PPChar; + argc: Longint; {$if defined(FPUSOFT)} @@ -73,9 +70,16 @@ var {$endif defined(FPUSOFT)} +function SetQLJobName(const s: string): longint; +function GetQLJobName: string; +function GetQLJobNamePtr: pointer; + implementation + {$define FPC_SYSTEM_HAS_STACKTOP} + {$define FPC_SYSTEM_HAS_BACKTRACESTR} + {$if defined(FPUSOFT)} {$define fpc_softfpu_implementation} @@ -99,9 +103,9 @@ implementation {$endif defined(FPUSOFT)} {$i system.inc} - {$ifdef FPC_QL_USE_TINYHEAP} - {$i tinyheap.inc} - {$endif FPC_QL_USE_TINYHEAP} + {$ifdef FPC_QL_USE_OSHEAP} + {$i osheap.inc} + {$endif FPC_QL_USE_OSHEAP} function GetProcessID:SizeUInt; @@ -109,16 +113,95 @@ begin GetProcessID := mt_inf(nil, nil); end; +{***************************************************************************** + ParamStr +*****************************************************************************} + +var + args: PChar; + +{ number of args } +function ParamCount: LongInt; +begin + ParamCount:=argc; +end; + +{ argument number l } +function ParamStr(l: LongInt): string; +begin + if (l >= 0) and (l <= argc) then + ParamStr:=argv[l] + else + ParamStr:=''; +end; + procedure SysInitParamsAndEnv; +var + i,j : longint; + c : char; + argv_size : longint; +const + word_separators=[' ',#0]; begin + argc:=0; + argv:=nil; + args:=GetMem(QL_CommandLineLen+1); + if not assigned(args) then + exit; + + Move(QL_CommandLine^,args^,QL_CommandLineLen); + args[QL_CommandLineLen]:=#0; + + i:=0; + c:=' '; + while args[i]<>#0 do + begin + if (c in word_separators) and not (args[i] in word_separators) then + inc(argc); + c:=args[i]; + inc(i); + end; + + { +2 is because argv[0] should be program name, + and argv[argc+1] is argv array terminator } + argv:=GetMem((argc+2)*sizeof(pointer)); + if not assigned(argv) then + begin + argc:=0; + exit; + end; + argv[argc+1]:=nil; + { FIX ME: for now the 0th argument (program name) is just always empty } + argv[0]:=#0; + + i:=0; + j:=1; + c:=' '; + while args[i]<>#0 do + begin + if (c in word_separators) and not (args[i] in word_separators) then + begin + argv[j]:=@args[i]; + inc(j); + end; + c:=args[i]; + if (c in word_separators) then + args[i]:=#0; + inc(i); + end; end; procedure randomize; begin - {$WARNING: randseed is uninitialized} - randseed:=0; + { Get the current date/time } + randseed:=mt_rclck; end; + +{***************************************************************************** + Platform specific custom calls +*****************************************************************************} + procedure PrintStr(ch: longint; const s: shortstring); begin io_sstrg(ch,-1,@s[1],ord(s[0])); @@ -132,24 +215,75 @@ begin for i:=0 to 10000 do begin end; end; -{$ifdef FPC_QL_USE_TINYHEAP} -procedure InitQLHeap; + +var + start_proc: byte; external name '_start'; + + { WARNING! if you change this value, make sure there's enough + buffer space for the job name in the startup code! } +const + JOB_NAME_MAX_LEN = 48; + +function SetQLJobName(const s: string): longint; +var + len: longint; +begin + SetQLJobName:=-1; + if pword(@start_proc)[3] = $4afb then + begin + len:=length(s); + if len > JOB_NAME_MAX_LEN then + len:=JOB_NAME_MAX_LEN; + Move(s[1],pword(@start_proc)[5],len); + pword(@start_proc)[4]:=len; + SetQLJobName:=len; + end; +end; + +function GetQLJobName: string; +var + len: longint; +begin + GetQLJobName:=''; + if pword(@start_proc)[3] = $4afb then + begin + len:=pword(@start_proc)[4]; + if len <= JOB_NAME_MAX_LEN then + begin + SetLength(GetQLJobName,len); + Move(pword(@start_proc)[5],GetQLJobName[1],len); + end; + end; +end; + +function GetQLJobNamePtr: pointer; begin - HeapOrg:=nil; - HeapEnd:=nil; - FreeList:=nil; - HeapPtr:=nil; + GetQLJobNamePtr:=nil; + if pword(@start_proc)[3] = $4afb then + begin + GetQLJobNamePtr:=@pword(@start_proc)[4]; + end; end; -{$endif} {***************************************************************************** System Dependent Entry code *****************************************************************************} +var + jobStackDataPtr: pointer; external name '__stackpointer_on_entry'; + program_name: shortstring; external name '__fpc_program_name'; + { QL/QDOS specific startup } procedure SysInitQDOS; var r: TQLRect; begin + QL_ChannelIDNum:=pword(jobStackDataPtr)[0]; + QL_ChannelIDs:=@pword(jobStackDataPtr)[1]; + QL_CommandLineLen:=pword(@QL_ChannelIDs[QL_ChannelIDNum])[0]; + QL_CommandLine:=@pword(@QL_ChannelIDs[QL_ChannelIDNum])[1]; + + SetQLJobName(program_name); + stdInputHandle:=io_open('con_',Q_OPEN); stdOutputHandle:=stdInputHandle; stdErrorHandle:=stdInputHandle; @@ -171,9 +305,14 @@ procedure haltproc(e:longint); external name '_haltproc'; procedure system_exit; const - anyKey: string = 'Press any key to exit'; + anyKey: pchar = 'Press any key to exit'; begin - io_sstrg(stdOutputHandle, -1, @anyKey[1], ord(anyKey[0])); + if assigned(args) then + FreeMem(args); + if assigned(argv) then + FreeMem(argv); + + io_sstrg(stdOutputHandle, -1, anyKey, length(anykey)); io_fbyte(stdInputHandle, -1); stdInputHandle:=UnusedHandle; @@ -205,15 +344,17 @@ end; begin StackLength := CheckInitialStkLen (InitialStkLen); + StackBottom := StackTop - StackLength; + StackMargin := min(align(StackLength div 20,2),STACK_MARGIN_MAX); { Initialize ExitProc } ExitProc:=Nil; SysInitQDOS; -{$ifndef FPC_QL_USE_TINYHEAP} +{$ifndef FPC_QL_USE_OSHEAP} { Setup heap } InitHeap; -{$else FPC_QL_USE_TINYHEAP} - InitQLHeap; -{$endif FPC_QL_USE_TINYHEAP} +{$else FPC_QL_USE_OSHEAP} +// InitOSHeap; +{$endif FPC_QL_USE_OSHEAP} SysInitExceptions; {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS} InitUnicodeStringManager; |