progress on creating archives

tar.tal

@@ -227,8 +227,109 @@
 
 @create-archive ( -> )
     ;arg/count LDA #03 LTH ?error-noinput
+    validate-inputs ?{ print-usage #01 !exit }
+    ( ; we know that all input files exist )
+    #01 arg/read DUP2 path-exists ?&dest-exists
+
+    .File1/name DEO2
+    #00 .File1/append DEO
+    ;arg/count LDA #02
+    &loop DUP arg/read archive-path INC GTHk ?&loop
+    POP2 JMP2r
+
+    &dest-exists ;destination-exists print
+    print #0a18 DEO print-usage #01 !exit
+
+@validate-inputs ( -> ok^ )
+    ;arg/count LDA #02 LITr 01  ( count^ 2^ [1^] )
+    &loop DUP validate-input    ( count^ i^ ok1^ [ok0^] )
+    STH ANDr INC GTHk ?&loop    ( count^ i+1^ [ok2^] )
+    POP2 STHr JMP2r             ( ok^ )
+
+@validate-input ( i^ -> ok^ )
+    arg/read DUP2 path-exists ?&ok1
+    ;missing-input print print #0a18 DEO #00 JMP2r
+    &ok1 ;long-size LDA LIT "? NEQ ?&ok2
+    ;input-toobig print print #0a18 DEO #00 JMP2r
+    &ok2 POP2 #01 JMP2r
+
+@path-exists ( path* -> )
+    path-read-size ;long-size LDA LIT "! NEQ JMP2r
+
+@path-read-size ( path* -> )
+    .File2/name DEO2
+    #0008 .File2/len DEO2
+    ;long-size .File2/stat DEO2
     JMP2r
 
+@archive-dir ( path* -> )
+    POP2 JMP2r
+
+@archive-path ( path* -> )
+    zero-header DUP2 path-read-size        ( path* )
+    ;long-size LDA LIT "- EQU ?archive-dir ( path* )
+    LIT2r =header                          ( path* [h*] )
+    STH2kr LDA LIT "/ NEQ ?&rel-path       ( path* [h*] )
+    LIT ". STH2kr STA INC2r                ( path* [h+1*] )
+    &rel-path STH2r copy-str               ( ; write file name )
+    ;default-mode ;header/mode copy-str    ( ; write file permissions )
+    ;default-id ;header/owner copy-str     ( ; write file owner )
+    ;default-id ;header/group copy-str     ( ; write file group )
+    size-to-octal                          ( ; write file size )
+    ;default-mtime ;header/mtime copy-str  ( ; write mtime )
+    LIT "0 ;header/type STA                ( ; write '0' for normal file )
+    ;u-sum compute-sum                     ( checksum* )
+
+@byte-to-octal ( n^ addr* -> n>>6^ addr+2* )
+    STH2 DUP #07 AND LIT "0 ADD ( n^ digit1^ [addr*] )
+    STH2kr STA #03 SFT INC2r    ( n>>3^ [addr+1*] )
+    DUP #07 AND LIT "0 ADD      ( n>>3^ digit2^ [addr+1*] )
+    STH2kr STA #03 SFT INC2r    ( n>>6^ [addr+2*] )
+    STH2r JMP2r                 ( n>>6^ addr+2* )
+
+@short-to-octal ( n* addr* -> n>>15^ addr+5* )
+    byte-to-octal STH2 SWP      ( lo>>6^ hi^ [addr+2*] )
+    DUP #01 AND #20 SFT ROT ORA ( hi^ [[hi&1]<<2]|lo>>6 [addr+2*] )
+    LIT "0 ADD STH2kr STA       ( hi^ [addr+2*] )
+    #01 SFT INC2r               ( hi>>1^ [addr+3*] )
+    STH2r !byte-to-octal        ( hi>>7^ addr+5* )
+
+@size-to-octal ( -> )
+    ;long-size LDA2                ( hi* )
+    ;long-size/mid LDA2            ( hi* lo* )
+    ;scratch render-octal32        ( )
+    #000b ;header/size !save-octal ( )
+
+@render-octal32 ( hi* lo* addr* -> )
+    short-to-octal STH2 STH     ( aaaaaaaa bbbbbbbb [addr+5* 0000000x] )
+    #0000 ROT                   ( aaaaaaaa 00000000 00000000 bbbbbbbb [addr+5* 0000000x] )
+    #10 SFT2                    ( aaaaaaaa 00000000 0000000b bbbbbbb0 [addr+5* 0000000x] )
+    SWP2 #07 SFT2               ( 0000000b bbbbbbb0 0000000a aaaaaaa0 [addr+5* 0000000x] )
+    SWP2 STH                    ( 0000000a aaaaaaa0 0000000b [addr+5* 0000000x bbbbbbb0] )
+    ORA ORAr STHr               ( 0000000a aaaaaaab bbbbbbbx [addr+5*] )
+    STH2r short-to-octal        ( 0000000a 0000000z addr+10* )
+    STH2 SWP #10 SFT ORA        ( 000000az [addr+10*] )
+    LIT "0 ADD STH2kr STA       ( [addr+10*] )
+    STH2r INC2 JMP2r            ( addr+11* )
+
+@save-octal ( count* addr* -> )
+    LIT2r ffff                    ( [ffff*] )
+    OVR2 ADD2 STH2 OVR2r ADD2r    ( count* [ffff* addr+count-1*] )
+    ;scratch SWP2 OVR2 ADD2 SWP2  ( limit* s* [ffff* h*] )
+    &loop LDAk STH2kr STA         ( limit* s* [ffff* h*] )
+    INC2 OVR2r ADD2r GTH2k ?&loop ( limit* s+1* [ffff* h-1*] )
+
+@copy-str ( s* addr* -> addr+n* )
+    STH2
+    &loop LDAk DUP ?&next POP STH2r INC2 JMP2r
+    &next STH2kr STA INC2 INC2r !&loop
+
+( we know header is exactly 512 bytes, an even number )
+@zero-header ( -> )
+    ;uheader/end ;header LIT2r 0000
+    &loop STH2kr OVR2 STA2 INC2 INC2 GTH2k ?&loop
+    POP2r POP2 POP2 JMP2r
+
 ( writes `n` bytes from File1 to File2 )
 ( uses a 32k internal buffer )
 @write ( carry^ hi* lo* -> )
@@ -429,6 +530,12 @@
 @invalid-checksum "error: 20 "invalid 20 "checksum 0a 00
 @expected "expected: 20 00
 @found "found: 20 20 20 20 00
+@missing-input "error: 20 "missing 20 "input 20 "file: 20 00
+@input-toobig "error: 20 "input 20 "file 20 "too 20 "large: 20 00
+@destination-exists "error: 20 "destination 20 "already 20 "exists: 20 00
+@default-mode "0000755 00
+@default-id "0000000 00
+@default-mtime "07033241577 00
 
 ( load argument parser )
 ~arg.tal
@@ -499,8 +606,11 @@
     &pad $c                     ( 0x1f4: padding, 12 bytes )
     &end                        ( 0x200: end of header )
 
+( small scratch buffer )
+|77e8 @scratch $10
+
 ( up to 8 bytes for long size )
-|77f8 @long-size $8
+|77f8 @long-size $4 &mid $4
 
 ( buffer for up to 2048 characters of long names/paths )
 |7800 @long-buf $800