sinclairql: more work on the QL port. very basic stdio (console writeln) works.

git-svn-id: trunk@47455 -

rtl/sinclairql/qdos.inc

@@ -17,6 +17,7 @@
 
 const
   _MT_INF   = $00;
+  _MT_DMODE = $10;
   _MT_ALCHP = $18;
   _MT_RECHP = $19;
 
@@ -35,6 +36,18 @@ asm
   move.l  d1,d0     { jobid }
 end;
 
+procedure mt_dmode(s_mode: pword; d_type: pword); assembler; nostackframe; public name '_mt_dmode';
+asm
+  movem.l d2/a3-a4,-(sp)
+  move.w (a0),d1
+  move.w (a1),d2
+  moveq.l #_MT_DMODE,d0
+  trap #1
+  move.w d1,(a0)
+  move.w d2,(a1) 
+  movem.l (sp)+,d2/a3-a4
+end;
+
 function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; assembler; nostackframe; public name '_mt_alchp';
 asm
   movem.l d2-d3/a2-a3,-(sp)
@@ -109,6 +122,8 @@ end;
 const
   _IO_SBYTE = $05;
   _IO_SSTRG = $07;
+  _SD_WDEF = $0D;
+  _SD_CLEAR = $20;
 
 function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; assembler; public name '_io_sbyte';
 asm
@@ -147,12 +162,35 @@ asm
   movem.l (sp)+,d2-d3
 end;
 
+function sd_wdef(chan: Tchanid; timeout: Ttimeout; border_colour: byte; border_width: word; window: PQLRect): longint; assembler; public name '_sd_wdef'; 
+asm
+  movem.l d2-d3,-(sp)
+  move.l window,a1
+  move.w timeout,d3
+  move.w border_width,d2
+  move.b border_colour,d1
+  move.l chan,a0
+  moveq.l #_SD_WDEF,d0
+  trap #3 
+  movem.l (sp)+,d2-d3
+end;
+
+function sd_clear(chan: Tchanid; timeout: Ttimeout): longint; assembler; public name '_sd_clear';
+asm
+  move.l d3,-(sp)
+  move.w timeout,d3
+  move.l chan,a0
+  moveq.l #_SD_CLEAR,d0
+  trap #3 
+  move.l (sp)+,d3
+end;
+
 
 const
   _UT_CON = $c6;
   _UT_SCR = $c8;
 
-function ut_con(params: PConScrParams): Tchanid; assembler; nostackframe; public name '_ut_con';
+function ut_con(params: PWindowDef): Tchanid; assembler; nostackframe; public name '_ut_con';
 asm
   movem.l d2-d3/a2-a3,-(sp)
   move.l params,a1
@@ -164,7 +202,7 @@ asm
   movem.l (sp)+,d2-d3/a2-a3
 end;
 
-function ut_scr(params: PConScrParams): Tchanid; assembler; nostackframe; public name '_ut_scr';
+function ut_scr(params: PWindowDef): Tchanid; assembler; nostackframe; public name '_ut_scr';
 asm
   movem.l d2-d3/a2-a3,-(sp)
   move.l params,a1

rtl/sinclairql/qdosfuncs.inc

@@ -17,6 +17,8 @@
 
 function mt_inf(sys_vars: ppchar; ver_ascii: plongint): Tjobid; external name '_mt_inf';
 
+procedure mt_dmode(s_mode: pword; d_type: pword); external name '_mt_dmode';
+
 function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; external name '_mt_alchp';
 procedure mt_rechp(area: pointer); external name '_mt_rechp';
 
@@ -27,5 +29,8 @@ function io_close(chan: Tchanid): longint; external name '_io_close';
 function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; external name '_io_sbyte';
 function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; external name '_io_sstrg';
 
-function ut_con(params: PConScrParams): Tchanid; external name '_ut_con';
+function sd_wdef(chan: Tchanid; timeout: Ttimeout; border_colour: byte; border_width: word; window: PQLRect): longint; external name '_sd_wdef'; 
-function ut_scr(params: PConScrParams): Tchanid; external name '_ut_scr';
+function sd_clear(chan: Tchanid; timeout: Ttimeout): longint; external name '_sd_clear';
+
+function ut_con(params: PWindowDef): Tchanid; external name '_ut_con';
+function ut_scr(params: PWindowDef): Tchanid; external name '_ut_scr';

rtl/sinclairql/qdosh.inc

@@ -49,14 +49,29 @@ const
   Q_OPEN_OVER = 3;  { Not available on microdrives. }
   Q_OPEN_DIR = 4;
 
+type
+  Tqlfloat = array[0..5] of byte;
+  Pqlfloat = ^Tqlfloat;
 
 type
-  TConScrParams = record
+  TQLRect = record
-    bordercolor:  byte;
+    q_width : word;
-    bordersize:   byte;
+    q_height : word;
-    papercolor:   byte;
+    q_x : word;
-    inkcolor:     byte;
+    q_y : word;
-    width,height: word;
-    x,y:          word;
   end;
-  PConScrParams = ^TConScrParams;
+  PQLRect = ^TQLRect;
+
+type
+  TWindowDef = record
+    border_colour : byte;
+    border_width : byte;
+    paper : byte;
+    ink : byte;
+    width : word;
+    height : word;
+    x_origin: word;
+    y_origin: word;
+  end;
+  PWindowDef = ^TWindowDef;
+

rtl/sinclairql/sysfile.inc

@@ -22,6 +22,7 @@
 { close a file from the handle value }
 procedure do_close(handle : longint);
 begin
+  Error2InOutRes(io_close(handle));
 end;
 
 
@@ -36,8 +37,15 @@ end;
 
 
 function do_write(h: longint; addr: pointer; len: longint) : longint;
+var
+  res: longint;
 begin
-  do_write:=-1;
+  do_write:=0;
+  res:=io_sstrg(h, -1, addr, len);
+  if res < 0 then
+    Error2InOutRes(res)
+  else
+    do_write:=res;
 end;
 
 
@@ -84,7 +92,73 @@ procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
   when (flags and $1000)  the file will be truncate/rewritten
   when (flags and $10000) there is no check for close (needed for textfiles)
 }
+var
+  res: longint;
+  openMode: longint;
 begin
+  openMode:=Q_OPEN;
+
+  { close first if opened }
+  if ((flags and $10000)=0) then
+   begin
+     case filerec(f).mode of
+       fmInput, fmOutput, fmInout:
+         do_close(filerec(f).handle);
+       fmClosed: ;
+     else
+       begin
+         InOutRes:=102; {not assigned}
+         exit;
+       end;
+     end;
+   end;
+
+  { reset file handle }
+  filerec(f).handle:=UnusedHandle;
+
+  { convert filemode to filerec modes }
+  case (flags and 3) of
+    0 : filerec(f).mode:=fmInput;
+    1 : filerec(f).mode:=fmOutput;
+    2 : filerec(f).mode:=fmInout;
+  end;
+
+  { empty name is special }
+  if p[0]=#0 then begin
+    case filerec(f).mode of
+      fminput :
+        filerec(f).handle:=StdInputHandle;
+      fmappend,
+      fmoutput : begin
+        filerec(f).handle:=StdOutputHandle;
+        filerec(f).mode:=fmOutput; {fool fmappend}
+      end;
+    end;
+    exit;
+  end;
+
+  { rewrite (create a new file) }
+  { FIX ME: this will just create a new file, actual overwriting
+    seems to be a more complex endeavor... }
+  if (flags and $1000)<>0 then openMode:=Q_OPEN_NEW;
+
+  res:=io_open(p,openMode);
+
+  if res < 0 then
+    begin
+      Error2InOutRes(res);
+      filerec(f).mode:=fmClosed;
+      exit;
+    end
+  else
+    filerec(f).handle:=res;
+
+  { append mode }
+  if ((Flags and $100)<>0) and
+      (FileRec(F).Handle<>UnusedHandle) then begin
+    do_seekend(filerec(f).handle);
+    filerec(f).mode:=fmOutput; {fool fmappend}
+  end;
 end;
 
 

rtl/sinclairql/system.pp

@@ -32,7 +32,7 @@ interface
 
 {Platform specific information}
 const
-    LineEnding = #13#10;
+    LineEnding = #10;
     LFNSupport = false;
     CtrlZMarksEOF: boolean = false; (* #26 not considered as end of file *)
     DirectorySeparator = '\';
@@ -48,13 +48,13 @@ const
     AllFilesMask = '*.*';
 
     sLineBreak = LineEnding;
-    DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
+    DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
 
 const
     UnusedHandle    = $ffff;
-    StdInputHandle  = 0;
+    StdInputHandle: longint = UnusedHandle;
-    StdOutputHandle = 1;
+    StdOutputHandle: longint = UnusedHandle;
-    StdErrorHandle  = $ffff;
+    StdErrorHandle: longint = UnusedHandle;
 
 var
     args: PChar;
@@ -62,6 +62,10 @@ var
     argv: PPChar;
     envp: PPChar;
 
+    QCON: longint; // QDOS console
+    QSCR: longint; // QDOS screen
+    heapStart: pointer;
+
 
     {$if defined(FPUSOFT)}
 
@@ -119,6 +123,61 @@ var
     randseed:=0;
   end;
 
+procedure PrintStr(ch: longint; const s: shortstring);
+begin
+  io_sstrg(ch,-1,@s[1],ord(s[0]));
+end;
+
+procedure PrintStr2(ch: longint; const s: shortstring);
+var
+  i: smallint;
+begin
+  for i:=1 to ord(s[0]) do
+    io_sbyte(ch,-1,s[i]);
+end;
+
+procedure DebugStr(const s: shortstring); public name '_dbgstr';
+var
+  i: longint;
+begin
+  PrintStr($00010001,s);
+  for i:=0 to 10000 do begin end;
+end;
+
+{$ifdef FPC_QL_USE_TINYHEAP}
+procedure InitQLHeap;
+begin
+  HeapOrg:=nil;
+  HeapEnd:=nil;
+  FreeList:=nil;
+  HeapPtr:=nil;
+end;
+{$endif}
+
+{*****************************************************************************
+                        System Dependent Entry code
+*****************************************************************************}
+{ QL/QDOS specific startup }
+procedure SysInitQDOS;
+var
+  r: TQLRect;
+begin
+  stdInputHandle:=io_open('con_',Q_OPEN);
+  stdOutputHandle:=stdInputHandle;
+  stdErrorHandle:=stdInputHandle;
+  QCON:=stdInputHandle;
+
+  r.q_width:=512;
+  r.q_height:=256;
+  r.q_x:=0;
+  r.q_y:=0;
+
+  sd_wdef(stdInputHandle,-1,0,16,@r);
+  sd_clear(stdInputHandle,-1);
+
+//  QSCR:=io_open('scr_',Q_OPEN);
+end;
+
 {*****************************************************************************
                          System Dependent Exit code
 *****************************************************************************}
@@ -127,6 +186,12 @@ procedure haltproc(e:longint); external name '_haltproc';
 
 procedure system_exit;
 begin
+//  io_close(QCON);
+//  io_close(QSCR);
+  stdInputHandle:=UnusedHandle;
+  stdOutputHandle:=UnusedHandle;
+  stdErrorHandle:=UnusedHandle;
+
   haltproc(exitcode);
 end;
 
@@ -150,34 +215,24 @@ begin
   CheckInitialStkLen := StkLen;
 end;
 
-procedure PrintStr(const s: shortstring);
-begin
-  io_sstrg($00010001,-1,@s[1],ord(s[0]));
-end;
-
-procedure PrintStr2(const s: shortstring);
-var
-  i: smallint;
-begin
-  for i:=1 to ord(s[0]) do
-    io_sbyte($00010001,-1,s[i]);
-end;
-
 
 begin
   StackLength := CheckInitialStkLen (InitialStkLen);
 { Initialize ExitProc }
   ExitProc:=Nil;
+  SysInitQDOS;
 {$ifndef FPC_QL_USE_TINYHEAP}
 { Setup heap }
   InitHeap;
+{$else FPC_QL_USE_TINYHEAP}
+  InitQLHeap;
 {$endif FPC_QL_USE_TINYHEAP}
   SysInitExceptions;
 {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
   InitUnicodeStringManager;
 {$endif FPC_HAS_FEATURE_UNICODESTRINGS}
 { Setup stdin, stdout and stderr }
-(*  SysInitStdIO;*)
+  SysInitStdIO;
 { Reset IO Error }
   InOutRes:=0;
 { Setup command line arguments }