/*
 *      DIO.LIB
 *          SLANG Ö³ I/O ØÀÞ²Ú¸¼®Ý ײÌÞ×Ø
 *
 */

const   SOSDC=0;    /*  S-OS É #PRINT ²¶Þ² É ¶ÞÒÝ Ë®³¼Þ Ù°ÁÝ ¦ ¶³ Å×ÊÞ 1 */
const   MEMDISK=1;  /*  S-OS É Ä¸¼­ Ü°¸´Ø± ¦ ÃÞ¨½¸ ļà ¶³ Å× 1 */
                    /*  ±¸¾½ ½Ù ¶Ý½³ ÉÐ ¦ ËÂÖ³ Ä½Ù Ä·Ê 2 */

/*  USAGE
const   argcmax=??,arglmax=??;
¥¥¥
#include DIO.LIB
¥¥¥
array byte argv[argcmax][arglmax];
var argc;
¥¥¥
main()
    [
    dioinit(&argc,argv);
    ¥¥¥
    ¥¥¥
    dioflush();
    ]
¥¥¥
*/

machine @file(1),@svsec(1),@abort(1),
        @getl(),@flget(),@print();
#IF (SOSDC==1)
machine @prints(),@ltnl(),@msg(),@msx(),@mprint(),@prthx(),@prthl();
#ENDIF

const   @getnum=1;
#IF (SOSDC==1)
const   @putnum=7;
#ELSE
const   @putnum=0;
#ENDIF

const   stdin=0,stdout=1,stderr=2,stdprn=3,
        @con=0,@disk=1,@diskcon=2,@prn=3,@prncon=4,@mem=5,@memcon=6,
        EOF=0;

var @charc=0,@inch=0,@outch=0;

#IF (MEMDISK>0)
const @WKSIZE=constw[$1F68];
var @mropf=0,@mwopf=0,@mrp,@mwp,@mwcnt=0;
#ENDIF

array byte @fname0[19],byte @fname1[19],
      byte @job[3]= [
                    @con,   (*  stdin   *)
                    @con,   (*  stdout  *)
                    @con,   (*  stderr  *)
                    @prn    (*  stdprn  *)
                    ];
array
    @getex[@getnum] =
        [
        %$1FD4,     (*  #GETL   *)
        %$2022      (*  #FLGET  *)
        ],
    @getsv[@getnum],
    @putex[@putnum] =
        [
        %$1FF5      (*  #PRINT  *)
#IF (SOSDC==1)
              ,
        %$1FF2,     (*  #PRINTS *)
        %$1FEF,     (*  #LTNL   *)
        %$1FE9,     (*  #MSG    *)
        %$1FE6,     (*  #MSX    *)
        %$1FE3,     (*  #MPRINT *)
        %$1FC2,     (*  #PRTHX  *)
        %$1FBF      (*  #PRTHL  *)
#ENDIF
        ],
    @putsv[@putnum];

dioinit(word argc[],byte argv[][arglmax])
    var byte p[],s0,s1;
    [
    getreg();
    @charc=argc[0]=0;
    p=^DE;
    p=@spcut(p);
    while ((s0=p[0])!=0)
        [
        s1=p[1];
        if (s0=='<' and @inch==0 and s1!=0 and s1!=' ')
            [
            p=@getarg(p+1,@fname0,19);
#IF (MEMDISK==1)
            case(memw[@fname0]-':'*256)
                [
                'M','m':
                    [
                    mopen(0);
                    @job[stdin]=@mem;
                    ]
                others:
                    [
#ENDIF
                    @fopen(0,@fname0,0);
                    @job[stdin]=@disk;
#IF (MEMDISK==1)
                    ]
                ]
#ENDIF
            @getpatch();
            ]
        else if ((s0=='>' or s0=='+')
                    and @outch==0 and s1!=0 and s1!=' ')
            [
            p=@getarg(p+1,@fname1,19);
            case(memw[@fname1]-':'*256)
                [
                'L','l':
                    @job[stdout]=@prn+(s0=='+');
#IF (MEMDISK==1)
                'M','m':
                    [
                    mopen(1);
                    @job[stdout]=@mem+(s0=='+');
                    ]
#ENDIF
                others:
                    [
                    @fopen(1,@fname1,3);
                    @job[stdout]=@disk+(s0=='+');
                    ]
               ]
            @putpatch();
            ]
        else if(argc[0]<=argcmax)
            p=@getarg(p,argv[argc[0]++],arglmax);
        else
            p=@skiparg(p);
        p=@spcut(p);
        ]
    ]

@spcut(byte p[])
    [
    while(p[0]==' ')
        p++;
    return(p);
    ]

@getarg(byte p[],byte str[],max)
    var os;
    [
    os=0;
    if (p[0]=='\'')
        [
        p++;
        while(p[0]!=0)
            [
            if (p[0]=='\'')
                [
                p++;
                if (p[0]!='\'')
                    exit;
                ]
            if (os<max)
                str[os++]=p[0];
            p++;
            ]
        ]
    else
        while(p[0]!=0 and p[0]!=' ')
            [
            if (os<max)
                str[os++]=p[0];
            p++;
            ]
    str[os]=0;
    return(p);
    ]

@skiparg(byte p[])
    [
    if (p[0]=='\'')
        [
        p++;
        while(p[0]!=0)
            [
            if (p[0]=='\'')
                [
                p++;
                if (p[0]!='\'')
                    exit;
                ]
            p++;
            ]
        ]
    else
        while(p[0]!=0 and p[0]!=' ')
            p++;
    return(p);
    ]

@fopen(fno,fname,mode)
    [
    fopen(fno,fname,mode);
    getreg();
    if (^CY)
        abort(^A);
    ]

@fgetc(fno)
    var c;
    [
    c=fgetc(fno);
    getreg();
    if (^CY)
        abort(^A);
    return(c);
    ]

@fputc(fno,data)
    [
    fputc(fno,data);
    getreg();
    if (^CY)
        abort(^A);
    ]

@fclose(fno)    /*  IY Ú¼Þ½À ¦ οÞÝ ½Ù ÀÒ É ÆÄÞ ÃÞÏ  */
    [
    fclose(fno);
    ]

@lpout(c)
    [
    code(
        [c],            (*  LD      HL,c    *)
        $7D,            (*  LD      A,L     *)
        $CD,$DC,$1F     (*  CALL    #LPRNT  *)
        );
    getreg();
    if (^CY)
        abort(^A);
    ]

#IF (MEMDISK>0)
mopen(mode)
    var s;
    [
    if (mode)
        [       (*  wopen   *)
        if (@mropf)
            if ((s=sosw[0])>@WKSIZE-4)
                abort(9);       (*  Device Full  *)
            else
                @mwp=s+2;
        else
            @mwp=2;
        @mwopf=1;
        @mwcnt=0;
        ]
    else
        [       (*  ropen   *)
        if not(@mfexist())
            abort(8);           (*  File not Found  *)
        @mrp=2;
        @mropf=1;
        if (@mwopf)
            if ((s=sosw[0])>@WKSIZE-4)
                abort(9);       (*  Device Full  *)
            else
                @mwp=s+2;
        ]
    ]

@mfexist()          /*  ĸ¼­ Ü°¸´Ø± É Å²Ö³ ¶Þ ̧²Ù É Ã²»² ¦  */
    var i,size;     /*  ÄÄÉ´Ã ²ÚÊÞ true¤ ¿³ÃÞ Å¹ÚÊÞ false  */
    [
    if ((size=sosw[0])==0 or size>@WKSIZE-2 or sos[size+1]!=0)
        return(false);
    for(i=2; i<size+1; i++)
        if (sos[i]==0)
            return(false);
    return(true);
    ]

mgetc()
    [
    if (@mropf==0)
        abort(12);          (* File not Open    *)
    if (@mrp>@WKSIZE-1)
        abort(1);           (* Device I/O Error *)
    return(sos[@mrp++]);
    ]

mputc(c)
    [
    if (@mwopf==0)
        abort(12);          (* File not Open    *)
    if (@mwp>@WKSIZE-1)
        abort(9);           (* Device Full      *)
    @mwcnt++;
    sos[@mwp++]=c;
    ]

mclose()
    var i,j;
    [
    if (@mwopf)
        [
        j=sosw[0]+2;
        sosw[0]=@mwcnt;
        if (@mropf)
            for (i=2; i<2+@mwcnt; i++,j++)
                sos[i]=sos[j];
        ]
    @mropf=@mwopf=0;
    ]
#ENDIF

abort(errno)
    [
    @recover();
    @abort(errno);
    ]

@abort(1)   /*  Thanks to N.Onuki   */
    [
    code($7D);  (*  LD  A,L *)
    stop();
    ]

@getpatch()
    [
    @getsv[0]=memw[@getex[0]];  memw[@getex[0]]=&@getl();
    @getsv[1]=memw[@getex[1]];  memw[@getex[1]]=&@flget();
    @inch=1;
    ]

@putpatch()
    [
    @putsv[0]=memw[@putex[0]];  memw[@putex[0]]=&@print();
#IF (SOSDC==1)
    @putsv[1]=memw[@putex[1]];  memw[@putex[1]]=&@prints();
    @putsv[2]=memw[@putex[2]];  memw[@putex[2]]=&@ltnl();
    @putsv[3]=memw[@putex[3]];  memw[@putex[3]]=&@msg();
    @putsv[4]=memw[@putex[4]];  memw[@putex[4]]=&@msx();
    @putsv[5]=memw[@putex[5]];  memw[@putex[5]]=&@mprint();
    @putsv[6]=memw[@putex[6]];  memw[@putex[6]]=&@prthx();
    @putsv[7]=memw[@putex[7]];  memw[@putex[7]]=&@prthl();
#ENDIF
    @outch=1;
    ]

getc(io)
    [
    if (@inch==1)
        case(@job[io])
            [
            @disk:
                return(@fgetc(0));
#IF (MEMDISK==1)
            @mem:
                return(mgetc());
#ENDIF
            others:
                [
                code(
                    [@getsv[1]],    (*  LD      HL,#FLGET   *)
                    $CD,$81,$1F,    (*  CALL    [HL]        *)
                    $6F,            (*  LD      L,A         *)
                    $26,$00         (*  LD      H,0         *)
                    );
                return;
                ]
            ]
    else
        return(inkey(1));       (*  #FLGET  *)
    ]

getchar()
    [
    return(getc(stdin));
    ]

putc(c,io)
    var j;
    [
    if (@outch)
        [
        case(j=@job[io])
            [
#IF (MEMDISK==1)
            @con,@diskcon,@prncon,@memcon:
#ELSE
            @con,@diskcon,@prncon:
#ENDIF
                if (c!=0)
                    code(
                    [c],            (*  LD      HL,c        *)
                    $7D,            (*  LD      A,L         *)
                    $F5,            (*  PUSH    AF          *)
                    [@putsv[0]],    (*  LD      HL,#PRINT   *)
                    $F1,            (*  POP     AF          *)
                    $CD,$81,$1F     (*  CALL    [HL]        *)
                    );
            ]
        case(j)
            [
            @disk,@diskcon:
                @fputc(1,c);
            @prn,@prncon:
                if (c!=0)
                    @lpout(c);
#IF (MEMDISK==1)
            @mem,@memcon:
                mputc(c);
#ENDIF
            ]
        ]
    else
        case(@job[io])
            [
            @con:
                print(str$(c,1));
            @prn:
                [
                prmode(2);
                print(str$(c,1));
                prmode(0);
                ]
            ]
    if (io==stdout)
        @charc++;
    ]

putchar(c)
    [
    putc(c,stdout);
    ]

@recover()
    var i;
    [
    if (@inch)
        [
        for(i=0; i<@getnum+1; i++)
            memw[@getex[i]]=@getsv[i];
        if (@job[stdin]==@disk)
            @fclose(0);
        ]
    if (@outch)
        [
        for(i=0; i<@putnum+1; i++)
            memw[@putex[i]]=@putsv[i];
        case(@job[stdout])
            [
            @disk,@diskcon:
                [
                @fclose(1);
                @chsize(@fname1);
                ]
            ]
        ]
#IF (MEMDISK==1)
    mclose();
#ENDIF
    ]

dioflush()
    [
    if (@outch)
        case(@job[stdout])
            [
#IF (MEMDISK==1)
            @disk,@diskcon,@mem,@memcon:
#ELSE
            @disk,@diskcon:
#ENDIF
                putchar(0);
            ]
    @recover();
    ]

@chsize(byte fname[])
    var err,sectno;
    var word dirp[];
    [
    @file(fname);   (*  file-name ¦ ¾¯Ä  *)
    dirp=@schfcb(&sectno)+18;   (*  dirp = FCB É (#SIZE)  *)
    dirp[0]=@charc;
    @svsec(sectno);         (*  ¶·¶´À ÌÞÌÞÝ ¦ ¾¸À ÏÙºÞÄ ¾°ÌÞ  *)
    ]

@file(1)                    (*  ̧²ÙÒ² ¦ (#IBGAD) Æ ¾¯Ä  *)
    [
    code(                   (*  HL=fname Í É pointer *)
        $EB,                (*  EX      DE,HL       *)
        $3E,$04,            (*  LD      A,'ASCFILE' *)
        $CD,$A3,$1F         (*  CALL    #FILE       *)
        );
    ]

@schfcb(word sectno[])
    [
    code(
        $CD,$6B,$27,        (*  CALL    FCBSCH      *)
        $E5,                (*  PUSH    HL          *)
        [sectno],           (*  LD      HL,sectno   *)
        $73,                (*  LD      (HL),E      *)
        $23,                (*  INC     HL          *)
        $72,                (*  LD      (HL),D      *)
        $E1                 (*  POP     HL          *)
        );
    ]

@svsec(1)
    [
    code(                   (*  HL=sectno           *)
        $EB,                (*  EX      DE,HL       *)
        $2A,$64,$1F,        (*  LD      HL,(#DTBUF) *)
        $3E,$01,            (*  LD      A,1         *)
        $CD,$03,$20         (*  CALL    #DWTSB      *)
        );
    getreg();
    if(^CY)
        @abort(^A);
    ]

/*  Extended S-OS Sub-Routines  */

@getl()
    var c,os,byte buf[];
    [
    code(
        $C5,$D5,$E5     (*  PUSH    BC,DE,HL    *)
        );
    getreg();
    buf=^DE;
    for(os=0; os<255 and (c=getchar())!='\n'; os++)
        [
        case(c)
            [
            EOF,$1B:
                [
                buf[0]=$1B;
                goto brkout;
                ]
            others:
                buf[os]=c;
            ]
        ]
    buf[os]=0;
brkout:
    code(
        $E1,$D1,$C1     (*  POP     HL,DE,BC    *)
        );
    ]

@flget()
    [
    code(
        $C5,$D5,$E5     (*  PUSH    BC,DE,HL    *)
        );
    getchar();          (*  HL = getchar()      *)
    code(
        $7D,            (*  LD      A,L         *)
        $E1,$D1,$C1     (*  POP     HL,DE,BC    *)
        );
    ]

@print()
    [
    code(
        $F5,$C5,$D5,$E5 (*  PUSH    AF,BC,DE,HL *)
        );
    getreg();
    putchar(^A);
    code(
        $E1,$D1,$C1,$F1 (*  POP     HL,DE,BC,AF *)
        );
    ]

#IF (SOSDC==1)
@prints()
    [
    code(
        $F5,$C5,$D5,$E5 (*  PUSH    AF,BC,DE,HL *)
        );
    putchar(' ');
    code(
        $E1,$D1,$C1,$F1 (*  POP     HL,DE,BC,AF *)
        );
    ]

@ltnl()
    [
    code(
        $F5,$C5,$D5,$E5 (*  PUSH    AF,BC,DE,HL *)
        );
    putchar('\n');
    code(
        $E1,$D1,$C1,$F1 (*  POP     HL,DE,BC,AF *)
        );
    ]

@msg()
    [
    code(
        $F5,$C5,$D5,$E5 (*  PUSH    AF,BC,DE,HL *)
        );
    getreg();
    print(msg$(^DE));
    code(
        $E1,$D1,$C1,$F1 (*  POP     HL,DE,BC,AF *)
        );
    ]

@msx()
    [
    code(
        $F5,$C5,$D5,$E5 (*  PUSH    AF,BC,DE,HL *)
        );
    getreg();
    print(msx$(^DE));
    code(
        $E1,$D1,$C1,$F1 (*  POP     HL,DE,BC,AF *)
        );
    ]

@mprint()
    var os,byte buf[];
    [
    code(
        $E3,            (*  EX      (SP),HL     *)
        $C5             (*  PUSH    BC          *)
        );
    getreg();
    print(msx$(buf=^HL));
    while(buf[os++]!=0)
        ;
    code(
        [buf+os],       (*  LD      HL,buf+os   *)
        $C1,            (*  POP     BC          *)
        $E3             (*  EX      (SP),HL     *)
        );
    ]

@prthx()
    [
    code(
        $C5,$D5,$E5     (*  PUSH    BC,DE,HL    *)
        );
    getreg();
    print(hex2$(^A));
    code(
        $E1,$D1,$C1     (*  POP     HL,DE,BC    *)
        );
    ]

@prthl()
    [
    code(
        $C5,$D5,$E5     (*  PUSH    BC,DE,HL    *)
        );
    getreg();
    print(hex4$(^HL));
    code(
        $E1,$D1,$C1     (*  POP     HL,DE,BC    *)
        );
    ]
#ENDIF

/*  End of DIO.LIB  */