Author: coke
Date: Tue Jan 3 13:31:23 2006
New Revision: 10875
Modified:
trunk/languages/tcl/lib/commands/file.pir
trunk/languages/tcl/tcl.pir_template
Log:
#38138: [TODO] - Tcl - implement [file]
add first pass for [file]'s type, mtime, atime, and stat
Modified: trunk/languages/tcl/lib/commands/file.pir
==============================================================================
--- trunk/languages/tcl/lib/commands/file.pir (original)
+++ trunk/languages/tcl/lib/commands/file.pir Tue Jan 3 13:31:23 2006
@@ -32,6 +32,112 @@ few_args:
.namespace [ "_Tcl\0builtins\0file" ]
+
+.sub 'stat'
+ .param pmc argv
+
+ .local int argc
+ argc = argv
+
+ if argc != 2 goto bad_args
+
+ .local string file,varname
+ file = shift argv
+ varname = shift argv
+
+ $P1 = new .OS
+ push_eh no_file
+ $P2 = $P1.'stat'(file)
+ clear_eh
+
+ .local pmc __set
+ __set = find_global "_Tcl", "__set"
+
+ $P3 = new .TclArray
+ $P1 = $P2[8]
+ $P3['atime'] = $P1
+ $P1 = $P2[10]
+ $P3['ctime'] = $P1
+ $P1 = $P2[0]
+ $P3['dev'] = $P1
+ $P1 = $P2[5]
+ $P3['gid'] = $P1
+ $P1 = $P2[1]
+ $P3['ino'] = $P1
+ $P1 = $P2[2]
+ $P3['mode'] = $P1
+ $P1 = $P2[9]
+ $P3['mtime'] = $P1
+ $P1 = $P2[3]
+ $P3['nlink'] = $P1
+ $P1 = $P2[7]
+ $P3['size'] = $P1
+
+ $I1 = $P2[2]
+ $I2 = 0o170000 #S_IFMT
+ $I3 = $I1 & $I2
+
+ $P4 = find_global "_Tcl", "filetypes"
+ $S1 = $P4[$I3]
+ $P3['type'] = $S1
+
+
+ $P1 = $P2[4]
+ $P3['uid'] = $P1
+
+ __set(varname, $P3)
+
+ .return('')
+
+# XXX should be more discriminating about the error messages .OS generates
+no_file:
+ $S0 = 'could not read "'
+ $S0 .= file
+ $S0 .= '": no such file or directory'
+ .throw($S0)
+bad_args:
+ .throw('wrong # args: should be "file state name varName"')
+
+
+.end
+
+
+### The stat-based functions: listed in order by key into the stat struct
+
+.sub 'type'
+ .param pmc argv
+
+ .local int argc
+ argc = argv
+
+ if argc != 1 goto bad_args
+
+ .local string file
+ file = shift argv
+
+ $P1 = new .OS
+ push_eh no_file
+ $P2 = $P1.'stat'(file)
+ clear_eh
+
+ $I1 = $P2[2]
+ $I2 = 0o170000 #S_IFMT
+ $I3 = $I1 & $I2
+
+ $P4 = find_global "_Tcl", "filetypes"
+ $S1 = $P4[$I3]
+ .return ($S1)
+
+# XXX should be more discriminating about the error messages .OS generates
+no_file:
+ $S0 = 'could not read "'
+ $S0 .= file
+ $S0 .= '": no such file or directory'
+ .throw($S0)
+bad_args:
+ .throw('wrong # args: should be "file type name"')
+.end
+
.sub 'size'
.param pmc argv
@@ -60,3 +166,59 @@ bad_args:
.throw('wrong # args: should be "file size name"')
.end
+.sub 'atime'
+ .param pmc argv
+
+ .local int argc
+ argc = argv
+
+ if argc != 1 goto bad_args
+
+ .local string file
+ file = shift argv
+
+ $P1 = new .OS
+ push_eh no_file
+ $P2 = $P1.'stat'(file)
+ clear_eh
+ $I1 = $P2[8]
+ .return ($I1)
+
+# XXX should be more discriminating about the error messages .OS generates
+no_file:
+ $S0 = 'could not read "'
+ $S0 .= file
+ $S0 .= '": no such file or directory'
+ .throw($S0)
+bad_args:
+ .throw('wrong # args: should be "file atime name"')
+.end
+
+.sub 'mtime'
+ .param pmc argv
+
+ .local int argc
+ argc = argv
+
+ if argc != 1 goto bad_args
+
+ .local string file
+ file = shift argv
+
+ $P1 = new .OS
+ push_eh no_file
+ $P2 = $P1.'stat'(file)
+ clear_eh
+ $I1 = $P2[9]
+ .return ($I1)
+
+# XXX should be more discriminating about the error messages .OS generates
+no_file:
+ $S0 = 'could not read "'
+ $S0 .= file
+ $S0 .= '": no such file or directory'
+ .throw($S0)
+bad_args:
+ .throw('wrong # args: should be "file mtime name"')
+.end
+
Modified: trunk/languages/tcl/tcl.pir_template
==============================================================================
--- trunk/languages/tcl/tcl.pir_template (original)
+++ trunk/languages/tcl/tcl.pir_template Tue Jan 3 13:31:23 2006
@@ -91,7 +91,21 @@ providing a compreg-compatible method.
load_bytecode "Getopt/Long.pir"
#_load_grammar()
-
+
+
+ # keep track of names of file types.
+ .local pmc filetypes
+ filetypes = new .TclArray
+ filetypes[0o060000] = 'blockSpecial'
+ filetypes[0o020000] = 'characterSpecial'
+ filetypes[0o040000] = 'directory'
+ filetypes[0o010000] = 'file'
+ filetypes[0o100000] = 'fifo'
+ filetypes[0o120000] = 'link'
+ filetypes[0o140000] = 'socket'
+
+ store_global '_Tcl', 'filetypes', filetypes
+
.local pmc operators
.local pmc math_funcs
.local pmc precedence
