From 60b899ee4d4f72157bd2714adbc6cce390c6f54d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Mon, 22 Dec 2008 12:02:22 +0000 Subject: [PATCH] q# --- LGPL/PLStream/ATOMS | 807 ++++++ LGPL/PLStream/Makefile.in | 119 + LGPL/PLStream/atoms.h | 793 ++++++ LGPL/PLStream/buildatoms | 35 + LGPL/PLStream/pl-buffer.c | 114 + LGPL/PLStream/pl-buffer.h | 112 + LGPL/PLStream/pl-ctype.c | 911 +++++++ LGPL/PLStream/pl-ctype.h | 82 + LGPL/PLStream/pl-error.c | 180 ++ LGPL/PLStream/pl-error.h | 66 + LGPL/PLStream/pl-feature.c | 10 + LGPL/PLStream/pl-file.c | 4768 ++++++++++++++++++++++++++++++++++++ LGPL/PLStream/pl-incl.h | 549 +++++ LGPL/PLStream/pl-opts.h | 24 + LGPL/PLStream/pl-os.c | 3157 ++++++++++++++++++++++++ LGPL/PLStream/pl-os.h | 254 ++ LGPL/PLStream/pl-stream.c | 3413 ++++++++++++++++++++++++++ LGPL/PLStream/pl-stream.h | 413 ++++ LGPL/PLStream/pl-string.c | 67 + LGPL/PLStream/pl-table.c | 427 ++++ LGPL/PLStream/pl-table.h | 58 + LGPL/PLStream/pl-text.c | 1158 +++++++++ LGPL/PLStream/pl-text.h | 80 + LGPL/PLStream/pl-utf8.c | 117 + LGPL/PLStream/pl-utf8.h | 61 + LGPL/PLStream/pl-yap.c | 539 ++++ LGPL/PLStream/pl-yap.h | 154 ++ 27 files changed, 18468 insertions(+) create mode 100644 LGPL/PLStream/ATOMS create mode 100644 LGPL/PLStream/Makefile.in create mode 100644 LGPL/PLStream/atoms.h create mode 100644 LGPL/PLStream/buildatoms create mode 100644 LGPL/PLStream/pl-buffer.c create mode 100644 LGPL/PLStream/pl-buffer.h create mode 100644 LGPL/PLStream/pl-ctype.c create mode 100644 LGPL/PLStream/pl-ctype.h create mode 100644 LGPL/PLStream/pl-error.c create mode 100644 LGPL/PLStream/pl-error.h create mode 100644 LGPL/PLStream/pl-feature.c create mode 100644 LGPL/PLStream/pl-file.c create mode 100644 LGPL/PLStream/pl-incl.h create mode 100644 LGPL/PLStream/pl-opts.h create mode 100644 LGPL/PLStream/pl-os.c create mode 100644 LGPL/PLStream/pl-os.h create mode 100644 LGPL/PLStream/pl-stream.c create mode 100644 LGPL/PLStream/pl-stream.h create mode 100644 LGPL/PLStream/pl-string.c create mode 100644 LGPL/PLStream/pl-table.c create mode 100644 LGPL/PLStream/pl-table.h create mode 100644 LGPL/PLStream/pl-text.c create mode 100644 LGPL/PLStream/pl-text.h create mode 100644 LGPL/PLStream/pl-utf8.c create mode 100644 LGPL/PLStream/pl-utf8.h create mode 100644 LGPL/PLStream/pl-yap.c create mode 100644 LGPL/PLStream/pl-yap.h diff --git a/LGPL/PLStream/ATOMS b/LGPL/PLStream/ATOMS new file mode 100644 index 000000000..e9a681ca8 --- /dev/null +++ b/LGPL/PLStream/ATOMS @@ -0,0 +1,807 @@ +# Definition table of atoms functors used somewhere in the C-code. +# format: +# +# A : --> #define ATOM_ into +# F --> #define FUNCTOR_ +# (A name should exist as well) +# +# This file is processed using the Unix awk program defineatoms to produce +# pl-atom.ic, pl-atom.ih, pl-funct.ic and pl-funct.ih. If you do not have +# awk you can propagate the changes by hand, but be careful! + + + +A abort "abort" +A aborted "$aborted" +A abs "abs" +A access "access" +A acos "acos" +A agc "agc" +A agc_gained "agc_gained" +A agc_margin "agc_margin" +A agc_time "agc_time" +A alias "alias" +A allow_variable_name_as_functor "allow_variable_name_as_functor" +A alnum "alnum" +A alpha "alpha" +A alternative "alternative" +A and "/\\" +A anonvar "_" +A append "append" +A ar_equals "=:=" +A ar_not_equal "=\\=" +A argument "argument" +A argumentlimit "argumentlimit" +A ascii "ascii" +A asin "asin" +A assert "assert" +A asserta "asserta" +A at "at" +A at_equals "=@=" +A at_exit "at_exit" +A at_larger "@>" +A at_larger_eq "@>=" +A at_not_equals "\\=@=" +A at_smaller "@<" +A at_smaller_eq "@=<" +A atan "atan" +A atom "atom" +A atom_garbage_collection "atom_garbage_collection" +A atomic "atomic" +A atoms "atoms" +A att "att" +A attributes "attributes" +A attvar "attvar" +A autoload "autoload" +A backquoted_string "backquoted_string" +A backslash "\\" +A backtrace "backtrace" +A bar "|" +A begin "begin" +A binary "binary" +A bind "bind" +A block "block" +A bof "bof" +A bom "bom" +A bool "bool" +A brace_term_position "brace_term_position" +A break "break" +A btree "btree" +A buffer "buffer" +A buffer_size "buffer_size" +A built_in_procedure "built_in_procedure" +A busy "busy" +A byte "byte" +A call "call" +A callable "callable" +A callpred "$callpred" +A canceled "canceled" +A case_sensitive_file_names "case_sensitive_file_names" +A catch "catch" +A ceil "ceil" +A ceiling "ceiling" +A char_type "char_type" +A character "character" +A character_code "character_code" +A character_escapes "character_escapes" +A chars "chars" +A chdir "chdir" +A chmod "chmod" +A choice "choice" +A clause "clause" +A clause_reference "clause_reference" +A close "close" +A close_on_abort "close_on_abort" +A close_option "close_option" +A cm "cm" +A cntrl "cntrl" +A co "co" +A codes "codes" +A collected "collected" +A collections "collections" +A colon ":" +A comma "," +A comments "comments" +A compound "compound" +A context "context" +A context_module "context_module" +A continue "continue" +A core "core" +A core_left "core_left" +A cos "cos" +A cputime "cputime" +A create "create" +A csym "csym" +A csymf "csymf" +A cumulative "cumulative" +A curl "{}" +A current "current" +A current_input "current_input" +A current_output "current_output" +A cut "!" +A cut_call "cut_call" +A cut_exit "cut_exit" +A cut_parent "cut_parent" +A cutted "cut" +A date "date" +A dc_call_prolog "$c_call_prolog" +A db_reference "db_reference" +A dcall "" +A dcall_cleanup "$call_cleanup" +A dcatch "$catch" +A dcut "$cut" +A dde_error "dde_error" +A dde_handle "dde_handle" +A debug "debug" +A debug_on_error "debug_on_error" +A debugger_print_options "debugger_print_options" +A debugger_show_context "debugger_show_context" +A debugging "debugging" +A dec10 "dec10" +A default "default" +A defined "defined" +A delete "delete" +A depth_limit_exceeded "depth_limit_exceeded" +A destroy "destroy" +A detached "detached" +A detect "detect" +A development "development" +A dexit "$exit" +A dforeign_registered "$foreign_registered" +A dgarbage_collect "$garbage_collect" +A digit "digit" +A directory "directory" +A discontiguous "discontiguous" +A div "//" +A divide "/" +A dload "$load" +A dmessage_queue "$message_queue" +A dmutex "$mutex" +A domain_error "domain_error" +A dos "dos" +A dot "." +A dots "dots" +A double_quotes "double_quotes" +A doublestar "**" +A dprof_node "$profile_node" +A dstream "$stream" +A dthread_init "$thread_init" +A dthrow "$throw" +A dtime "$time" +A dwakeup "$wakeup" +A dynamic "dynamic" +A e "e" +A encoding "encoding" +A end "end" +A end_of_file "end_of_file" +A end_of_line "end_of_line" +A end_of_stream "end_of_stream" +A environment "environment" +A eof "eof" +A eof_action "eof_action" +A eof_code "eof_code" +A equal "equal" +A equals "=" +A erase "erase" +A erased "erased" +A error "error" +A eval "eval" +A evaluable "evaluable" +A evaluation_error "evaluation_error" +A exception "exception" +A exclusive "exclusive" +A execute "execute" +A exist "exist" +A existence_error "existence_error" +A exit "exit" +A exited "exited" +A exp "exp" +A export "export" +A exported "exported" +A expression "expression" +A externals "externals" +A fact "fact" +A factor "factor" +A fail "fail" +A failure_error "failure_error" +A false "false" +A feature "feature" +A file "file" +A file_name "file_name" +A file_name_variables "file_name_variables" +A file_no "file_no" +A flag "flag" +A flag_value "flag_value" +A float "float" +A float_format "float_format" +A float_fractional_part "float_fractional_part" +A float_integer_part "float_integer_part" +A float_overflow "float_overflow" +A float_underflow "float_underflow" +A floor "floor" +A force "force" +A foreign "foreign" +A foreign_function "$foreign_function" +A foreign_return_value "foreign_return_value" +A fork "fork" +A frame "frame" +A frame_attribute "frame_attribute" +A frame_finished "frame_finished" +A frame_reference "frame_reference" +A free_of_attvar "free_of_attvar" +A freeze "freeze" +A full "full" +A functor_name "functor_name" +A functors "functors" +A fx "fx" +A fy "fy" +A garbage_collected "" +A garbage_collection "garbage_collection" +A gc "gc" +A gctime "gctime" +A getcwd "getcwd" +A global "global" +A global_shifts "global_shifts" +A global_stack "global_stack" +A globallimit "globallimit" +A globalused "globalused" +A goal "goal" +A goal_expansion "goal_expansion" +A grammar "-->" +A graph "graph" +A gvar "gvar" +A halt "halt" +A has_alternatives "has_alternatives" +A hash "hash" +A hashed "hashed" +A hat "^" +A heap "heap" +A heaplimit "heaplimit" +A heapused "heapused" +A help "help" +A hidden "hidden" +A hide_childs "hide_childs" +A history_depth "history_depth" +A ifthen "->" +A ignore "ignore" +A ignore_ops "ignore_ops" +A imported "imported" +A imported_procedure "imported_procedure" +A index "index" +A indexed "indexed" +A inf "inf" +A inferences "inferences" +A infinite "infinite" +A informational "informational" +A init_file "init_file" +A initialization "initialization" +A input "input" +A inserted_char "inserted_char" +A instantiation_error "instantiation_error" +A int "int" +A int64_t "int64_t" +A int_overflow "int_overflow" +A integer "integer" +A interrupt "interrupt" +A io_error "io_error" +A io_mode "io_mode" +A ioctl "ioctl" +A is "is" +A iso "iso" +A iso_latin_1 "iso_latin_1" +A isovar "$VAR" +A join "join" +A jump "jump" +A kernel "kernel" +A key "key" +A larger ">" +A larger_equal ">=" +A level "level" +A li "li" +A limit "limit" +A line "line" +A line_count "line_count" +A list "list" +A list_position "list_position" +A listing "listing" +A local "local" +A local_shifts "local_shifts" +A local_stack "local_stack" +A locale "locale" +A locallimit "locallimit" +A localused "localused" +A lock "lock" +A locked "locked" +A log "log" +A log10 "log10" +A long "long" +A low "low" +A lower "lower" +A lsb "lsb" +A lshift "<<" +A main "main" +A mark "mark" +A matches "matches" +A max "max" +A max_arity "max_arity" +A max_dde_handles "max_dde_handles" +A max_depth "max_depth" +A max_files "max_files" +A max_path_length "max_path_length" +A max_size "max_size" +A max_variable_length "max_variable_length" +A memory "memory" +A message "message" +A message_lines "message_lines" +A message_queue "message_queue" +A message_queue_property "message_queue_property" +A meta_predicate "meta_predicate" +A min "min" +A min_free "min_free" +A minus "-" +A mismatched_char "mismatched_char" +A mod "mod" +A mode "mode" +A modify "modify" +A module "module" +A module_property "module_property" +A module_transparent "module_transparent" +A modules "modules" +A msb "msb" +A multifile "multifile" +A mutex "mutex" +A mutex_option "mutex_option" +A mutex_property "mutex_property" +A natural "natural" +A newline "newline" +A nil "[]" +A no_memory "no_memory" +A nodebug "nodebug" +A non_empty_list "non_empty_list" +A none "none" +A noprofile "noprofile" +A not "not" +A not_equals "\\=" +A not_implemented "not_implemented" +A not_less_than_one "not_less_than_one" +A not_less_than_zero "not_less_than_zero" +A not_provable "\\+" +A not_strickt_equals "\\==" +A not_unique "not_unique" +A number "number" +A number_of_clauses "number_of_clauses" +A numbervar_option "numbervar_option" +A numbervars "numbervars" +A occurs_check "occurs_check" +A octet "octet" +A off "off" +A on "on" +A open "open" +A operator "operator" +A operator_priority "operator_priority" +A operator_specifier "operator_specifier" +A optimise "optimise" +A or "\\/" +A order "order" +A output "output" +A pair "pair" +A paren "paren" +A parent "parent" +A parent_goal "parent_goal" +A past "past" +A past_end_of_stream "past_end_of_stream" +A pattern "pattern" +A pc "pc" +A period "period" +A permission_error "permission_error" +A pi "pi" +A pipe "pipe" +A plain "plain" +A plus "+" +A popcount "popcount" +A portray "portray" +A position "position" +A posix "posix" +A powm "powm" +A predicate_indicator "predicate_indicator" +A predicates "predicates" +A print "print" +A print_message "print_message" +A priority "priority" +A private_procedure "private_procedure" +A procedure "procedure" +A profile_mode "profile_mode" +A profile_no_cpu_time "profile_no_cpu_time" +A profile_node "profile_node" +A program "program" +A program_counter "program_counter" +A prolog "prolog" +A prompt "|:" +A property "property" +A protocol "protocol" +A prove ":-" +A punct "punct" +A query "?-" +A queue_option "queue_option" +A quiet "quiet" +A quote "quote" +A quoted "quoted" +A radix "radix" +A random "random" +A rational "rational" +A rationalize "rationalize" +A rdiv "rdiv" +A read "read" +A read_option "read_option" +A readline "readline" +A real_time "real_time" +A receiver "receiver" +A record "record" +A record_position "record_position" +A redefine "redefine" +A redo "redo" +A references "references" +A rem "rem" +A rename "rename" +A report_error "report_error" +A reposition "reposition" +A representation_error "representation_error" +A representation_errors "representation_errors" +A reset "reset" +A resource_error "resource_error" +A resource_handle "resource_handle" +A retry "retry" +A round "round" +A rshift ">>" +A running "running" +A runtime "runtime" +A save_class "save_class" +A save_option "save_option" +A seek_method "seek_method" +A select "select" +A semicolon ";" +A separated "separated" +A setup_and_call_cleanup "setup_and_call_cleanup" +A shared "shared" +A shared_object "shared_object" +A shared_object_handle "shared_object_handle" +A shell "shell" +A sign "sign" +A signal "signal" +A signal_handler "signal_handler" +A silent "silent" +A sin "sin" +A singletons "singletons" +A size "size" +A skip "skip" +A smaller "<" +A smaller_equal "=<" +A softcut "*->" +A source_sink "source_sink" +A space "space" +A spy "spy" +A sqrt "sqrt" +A stack "stack" +A stack_parameter "stack_parameter" +A stack_shifts "stack_shifts" +A stacks "stacks" +A stand_alone "stand_alone" +A star "*" +A start "start" +A stat "stat" +A static_procedure "static_procedure" +A statistics "statistics" +A status "status" +A stderr "stderr" +A stream "stream" +A stream_option "stream_option" +A stream_or_alias "stream_or_alias" +A stream_position "$stream_position" +A stream_property "stream_property" +A strict_equal "==" +A string "string" +A string_position "string_position" +A subterm_positions "subterm_positions" +A suffix "suffix" +A syntax_error "syntax_error" +A syntax_errors "syntax_errors" +A system "system" +A system_error "system_error" +A system_init_file "system_init_file" +A system_thread_id "system_thread_id" +A system_time "system_time" +A tan "tan" +A term "term" +A term_expansion "term_expansion" +A term_position "term_position" +A terminal "terminal" +A terminal_capability "terminal_capability" +A text "text" +A thread "thread" +A thread_cputime "thread_cputime" +A thread_initialization "thread_initialization" +A thread_local "thread_local" +A thread_local_procedure "thread_local_procedure" +A thread_option "thread_option" +A thread_property "thread_property" +A threads "threads" +A threads_created "threads_created" +A throw "throw" +A tilde "~" +A time "time" +A time_stamp "time_stamp" +A timeout "timeout" +A timeout_error "timeout_error" +A timezone "timezone" +A to_lower "to_lower" +A to_upper "to_upper" +A top "top" +A top_level "top_level" +A toplevel "toplevel" +A trace "trace" +A trace_any "trace_any" +A trace_call "trace_call" +A trace_exit "trace_exit" +A trace_fail "trace_fail" +A trace_gc "trace_gc" +A trace_redo "trace_redo" +A traceinterc "prolog_trace_interception" +A tracing "tracing" +A trail "trail" +A trail_shifts "trail_shifts" +A traillimit "traillimit" +A trailused "trailused" +A transparent "transparent" +A transposed_char "transposed_char" +A transposed_word "transposed_word" +A true "true" +A truncate "truncate" +A tty "tty" +A tty_control "tty_control" +A type "type" +A type_error "type_error" +A undefined "undefined" +A undefined_global_variable "undefined_global_variable" +A undefinterc "$undefined_procedure" +A unicode_be "unicode_be" +A unicode_le "unicode_le" +A unify "unify" +A unique "unique" +A univ "=.." +A unknown "unknown" +A unlimited "unlimited" +A unlock "unlock" +A unlocked "unlocked" +A update "update" +A upper "upper" +A user "user" +A user_error "user_error" +A user_input "user_input" +A user_output "user_output" +A utc "UTC" +A utf8 "utf8" +A v "v" +A var "$VAR$" +A variable "variable" +A variable_names "variable_names" +A variables "variables" +A very_deep "very_deep" +A vmi "vmi" +A volatile "volatile" +A wakeup "wakeup" +A warning "warning" +A wchar_t "wchar_t" +A white "white" +A write "write" +A write_attributes "write_attributes" +A write_option "write_option" +A xdigit "xdigit" +A xf "xf" +A xfx "xfx" +A xfy "xfy" +A xml "xml" +A xor "xor" +A xpceref "@" +A yf "yf" +A yfx "yfx" +A yfy "yfy" +A zero_divisor "zero_divisor" + +F abs 1 +F access 1 +F acos 1 +F alias 1 +F and 2 +F ar_equals 2 +F ar_not_equal 2 +F asin 1 +F assert 1 +F asserta 1 +F atan 1 +F atan 2 +F atom 1 +F att 3 +F backslash 1 +F bar 2 +F block 3 +F bom 1 +F brace_term_position 3 +F break 1 +F break 3 +F buffer 1 +F buffer_size 1 +F busy 2 +F call 1 +F callpred 2 +F catch 3 +F ceil 1 +F ceiling 1 +F chars 1 +F chars 2 +F clause 1 +F close_on_abort 1 +F codes 1 +F codes 2 +F colon 2 +F comma 2 +F context 2 +F cos 1 +F cputime 0 +F curl 1 +F cut_call 1 +F cut_exit 1 +F date 9 +F dcall 1 +F dcut 1 +F dde_error 2 +F debugging 1 +F detached 1 +F dexit 2 +F dforeign_registered 2 +F dgarbage_collect 1 +F div 2 +F divide 2 +F dmessage_queue 1 +F dmutex 1 +F domain_error 2 +F dot 2 +F doublestar 2 +F dprof_node 1 +F dstream 1 +F dthread_init 0 +F dthrow 1 +F dtime 2 +F dwakeup 1 +F e 0 +F encoding 1 +F end_of_stream 1 +F eof_action 1 +F equals 2 +F erased 1 +F error 2 +F eval 1 +F evaluation_error 1 +F exception 1 +F exception 3 +F existence_error 2 +F exited 1 +F exp 1 +F fail 0 +F failure_error 1 +F file 1 +F file 4 +F file_name 1 +F file_no 1 +F float 1 +F float_fractional_part 1 +F float_integer_part 1 +F floor 1 +F foreign_function 1 +F frame 3 +F frame_finished 1 +F goal_expansion 2 +F hat 2 +F ifthen 2 +F input 0 +F integer 1 +F interrupt 1 +F io_error 2 +F is 2 +F isovar 1 +F larger 2 +F larger_equal 2 +F line_count 1 +F list_position 4 +F listing 1 +F locked 2 +F log 1 +F log10 1 +F lsb 1 +F lshift 2 +F max 2 +F max_size 1 +F message_lines 1 +F min 2 +F minus 1 +F minus 2 +F mod 2 +F mode 1 +F msb 1 +F newline 1 +F not_implemented 2 +F not_provable 1 +F occurs_check 2 +F or 2 +F output 0 +F permission_error 3 +F pi 0 +F pipe 1 +F plus 1 +F plus 2 +F popcount 1 +F portray 1 +F position 1 +F powm 3 +F print 1 +F print_message 2 +F procedure 2 +F prove 1 +F prove 2 +F punct 2 +F random 1 +F rational 1 +F rationalize 1 +F rdiv 2 +F rem 2 +F reposition 1 +F representation_error 1 +F representation_errors 1 +F resource_error 1 +F retry 1 +F round 1 +F rshift 2 +F semicolon 2 +F setup_and_call_cleanup 4 +F shared_object 2 +F shell 2 +F sign 1 +F signal 1 +F signal 2 +F sin 1 +F singletons 1 +F size 1 +F smaller 2 +F smaller_equal 2 +F softcut 2 +F spy 1 +F sqrt 1 +F star 2 +F status 1 +F stream 4 +F stream_position 4 +F string 1 +F string 2 +F string_position 2 +F syntax_error 1 +F syntax_error 3 +F tan 1 +F term_expansion 2 +F term_position 5 +F timeout 1 +F timeout_error 2 +F trace 1 +F traceinterc 3 +F tracing 1 +F true 0 +F truncate 1 +F tty 1 +F type 1 +F type_error 2 +F undefinterc 4 +F var 1 +F wakeup 3 +F warning 3 +F xor 2 +F xpceref 1 +F dc_call_prolog 0 +F strict_equal 2 diff --git a/LGPL/PLStream/Makefile.in b/LGPL/PLStream/Makefile.in new file mode 100644 index 000000000..372024e95 --- /dev/null +++ b/LGPL/PLStream/Makefile.in @@ -0,0 +1,119 @@ +# +# default base directory for YAP installation +# (EROOT for architecture-dependent files) +# +GCC=@GCC@ +prefix = @prefix@ +ROOTDIR = $(prefix) +EROOTDIR = @exec_prefix@ +# +# where the binary should be +# +BINDIR = $(EROOTDIR)/bin +# +# where YAP should look for libraries +# +LIBDIR=$(EROOTDIR)/lib/Yap +# +# +CC=@CC@ +CFLAGS= @CFLAGS@ $(YAP_EXTRAS) $(DEFS) -I$(srcdir) -I../.. -I$(srcdir)/../../include +# +# +# You shouldn't need to change what follows. +# +INSTALL=@INSTALL@ +INSTALL_DATA=@INSTALL_DATA@ +INSTALL_PROGRAM=@INSTALL_PROGRAM@ +SHELL=/bin/sh +RANLIB=@RANLIB@ +srcdir=@srcdir@ +SHLIB_CFLAGS=@SHLIB_CFLAGS@ +SHLIB_SUFFIX=@SHLIB_SUFFIX@ +#4.1VPATH=@srcdir@:@srcdir@/OPTYap +CWD=$(PWD) +# + +HEADERS=$(srcdir)/atoms.h $(srcdir)/pl-buffer.h $(srcdir)/pl-ctype.h \ + $(srcdir)/pl-incl.h $(srcdir)/pl-opts.h \ + $(srcdir)/pl-os.h \ + $(srcdir)/pl-stream.h \ + $(srcdir)/pl-table.h \ + $(srcdir)/pl-text.h $(srcdir)/pl-utf8.h \ + $(srcdir)/pl-yap.h +C_SOURCES=$(srcdir)/pl-buffer.c $(srcdir)/pl-ctype.c \ + $(srcdir)/pl-error.c $(srcdir)/pl-feature.c \ + $(srcdir)/pl-file.c $(srcdir)/pl-os.c \ + $(srcdir)/pl-stream.c $(srcdir)/pl-string.c \ + $(srcdir)/pl-table.c \ + $(srcdir)/pl-text.c $(srcdir)/pl-utf8.c \ + $(srcdir)/pl-yap.c +OBJS=pl-buffer.o pl-ctype.o pl-error.o pl-feature.o \ + pl-file.o pl-os.o \ + pl-stream.o pl-string.o pl-table.o pl-text.o pl-utf8.o \ + pl-yap.o +SOBJS=plstream@SHLIB_SUFFIX@ + +#in some systems we just create a single object, in others we need to +# create a libray + +all: $(SOBJS) + +pl-buffer.o: $(srcdir)/pl-buffer.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-buffer.c -o pl-buffer.o + +pl-ctype.o: $(srcdir)/pl-ctype.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-ctype.c -o pl-ctype.o + +pl-error.o: $(srcdir)/pl-error.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-error.c -o pl-error.o + +pl-feature.o: $(srcdir)/pl-feature.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-feature.c -o pl-feature.o + +pl-file.o: $(srcdir)/pl-file.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-file.c -o pl-file.o + +pl-os.o: $(srcdir)/pl-os.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-os.c -o pl-os.o + +pl-stream.o: $(srcdir)/pl-stream.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-stream.c -o pl-stream.o + +pl-string.o: $(srcdir)/pl-string.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-string.c -o pl-string.o + +pl-table.o: $(srcdir)/pl-table.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-table.c -o pl-table.o + +pl-text.o: $(srcdir)/pl-text.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-text.c -o pl-text.o + +pl-utf8.o: $(srcdir)/pl-utf8.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-utf8.c -o pl-utf8.o + +pl-yap.o: $(srcdir)/pl-yap.c + $(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/pl-yap.c -o pl-yap.o + +@DO_SECOND_LD@%@SHLIB_SUFFIX@: %.o +@DO_SECOND_LD@ @SHLIB_LD@ -o $@ $< + +@DO_SECOND_LD@plstream@SHLIB_SUFFIX@: $(OBJS) +@DO_SECOND_LD@ @SHLIB_LD@ -o plstream@SHLIB_SUFFIX@ $(OBJS) + +install: all + $(INSTALL_PROGRAM) $(SOBJS) $(DESTDIR)$(LIBDIR) + +clean: + rm -f *.o *~ $(OBJS) $(SOBJS) *.BAK + + +depend: $(HEADERS) $(C_SOURCES) + -@if test "$(GCC)" = yes; then\ + $(CC) -MM -MG $(CFLAGS) -I$(srcdir) -I$(srcdir)/../../include -I$(srcdir)/../../H $(C_SOURCES) > depend;\ + else\ + makedepend -f - -- $(CFLAGS) -I$(srcdir)/../../H -I$(srcdir)/../../include -- $(C_SOURCES) |\ + sed 's|.*/\([^:]*\):|\1:|' > .depend ;\ + fi + +include depend diff --git a/LGPL/PLStream/atoms.h b/LGPL/PLStream/atoms.h new file mode 100644 index 000000000..0de6c8396 --- /dev/null +++ b/LGPL/PLStream/atoms.h @@ -0,0 +1,793 @@ +#define ATOM_abort MK_ATOM("abort") +#define ATOM_aborted MK_ATOM("$aborted") +#define ATOM_abs MK_ATOM("abs") +#define ATOM_access MK_ATOM("access") +#define ATOM_acos MK_ATOM("acos") +#define ATOM_agc MK_ATOM("agc") +#define ATOM_agc_gained MK_ATOM("agc_gained") +#define ATOM_agc_margin MK_ATOM("agc_margin") +#define ATOM_agc_time MK_ATOM("agc_time") +#define ATOM_alias MK_ATOM("alias") +#define ATOM_allow_variable_name_as_functor MK_ATOM("allow_variable_name_as_functor") +#define ATOM_alnum MK_ATOM("alnum") +#define ATOM_alpha MK_ATOM("alpha") +#define ATOM_alternative MK_ATOM("alternative") +#define ATOM_and MK_ATOM("/\\") +#define ATOM_anonvar MK_ATOM("_") +#define ATOM_append MK_ATOM("append") +#define ATOM_ar_equals MK_ATOM("=:=") +#define ATOM_ar_not_equal MK_ATOM("=\\=") +#define ATOM_argument MK_ATOM("argument") +#define ATOM_argumentlimit MK_ATOM("argumentlimit") +#define ATOM_ascii MK_ATOM("ascii") +#define ATOM_asin MK_ATOM("asin") +#define ATOM_assert MK_ATOM("assert") +#define ATOM_asserta MK_ATOM("asserta") +#define ATOM_at MK_ATOM("at") +#define ATOM_at_equals MK_ATOM("=@=") +#define ATOM_at_exit MK_ATOM("at_exit") +#define ATOM_at_larger MK_ATOM("@>") +#define ATOM_at_larger_eq MK_ATOM("@>=") +#define ATOM_at_not_equals MK_ATOM("\\=@=") +#define ATOM_at_smaller MK_ATOM("@<") +#define ATOM_at_smaller_eq MK_ATOM("@=<") +#define ATOM_atan MK_ATOM("atan") +#define ATOM_atom MK_ATOM("atom") +#define ATOM_atom_garbage_collection MK_ATOM("atom_garbage_collection") +#define ATOM_atomic MK_ATOM("atomic") +#define ATOM_atoms MK_ATOM("atoms") +#define ATOM_att MK_ATOM("att") +#define ATOM_attributes MK_ATOM("attributes") +#define ATOM_attvar MK_ATOM("attvar") +#define ATOM_autoload MK_ATOM("autoload") +#define ATOM_backquoted_string MK_ATOM("backquoted_string") +#define ATOM_backslash MK_ATOM("\\") +#define ATOM_backtrace MK_ATOM("backtrace") +#define ATOM_bar MK_ATOM("|") +#define ATOM_begin MK_ATOM("begin") +#define ATOM_binary MK_ATOM("binary") +#define ATOM_bind MK_ATOM("bind") +#define ATOM_block MK_ATOM("block") +#define ATOM_bof MK_ATOM("bof") +#define ATOM_bom MK_ATOM("bom") +#define ATOM_bool MK_ATOM("bool") +#define ATOM_brace_term_position MK_ATOM("brace_term_position") +#define ATOM_break MK_ATOM("break") +#define ATOM_btree MK_ATOM("btree") +#define ATOM_buffer MK_ATOM("buffer") +#define ATOM_buffer_size MK_ATOM("buffer_size") +#define ATOM_built_in_procedure MK_ATOM("built_in_procedure") +#define ATOM_busy MK_ATOM("busy") +#define ATOM_byte MK_ATOM("byte") +#define ATOM_call MK_ATOM("call") +#define ATOM_callable MK_ATOM("callable") +#define ATOM_callpred MK_ATOM("$callpred") +#define ATOM_canceled MK_ATOM("canceled") +#define ATOM_case_sensitive_file_names MK_ATOM("case_sensitive_file_names") +#define ATOM_catch MK_ATOM("catch") +#define ATOM_ceil MK_ATOM("ceil") +#define ATOM_ceiling MK_ATOM("ceiling") +#define ATOM_char_type MK_ATOM("char_type") +#define ATOM_character MK_ATOM("character") +#define ATOM_character_code MK_ATOM("character_code") +#define ATOM_character_escapes MK_ATOM("character_escapes") +#define ATOM_chars MK_ATOM("chars") +#define ATOM_chdir MK_ATOM("chdir") +#define ATOM_chmod MK_ATOM("chmod") +#define ATOM_choice MK_ATOM("choice") +#define ATOM_clause MK_ATOM("clause") +#define ATOM_clause_reference MK_ATOM("clause_reference") +#define ATOM_close MK_ATOM("close") +#define ATOM_close_on_abort MK_ATOM("close_on_abort") +#define ATOM_close_option MK_ATOM("close_option") +#define ATOM_cm MK_ATOM("cm") +#define ATOM_cntrl MK_ATOM("cntrl") +#define ATOM_co MK_ATOM("co") +#define ATOM_codes MK_ATOM("codes") +#define ATOM_collected MK_ATOM("collected") +#define ATOM_collections MK_ATOM("collections") +#define ATOM_colon MK_ATOM(":") +#define ATOM_comma MK_ATOM(",") +#define ATOM_comments MK_ATOM("comments") +#define ATOM_compound MK_ATOM("compound") +#define ATOM_context MK_ATOM("context") +#define ATOM_context_module MK_ATOM("context_module") +#define ATOM_continue MK_ATOM("continue") +#define ATOM_core MK_ATOM("core") +#define ATOM_core_left MK_ATOM("core_left") +#define ATOM_cos MK_ATOM("cos") +#define ATOM_cputime MK_ATOM("cputime") +#define ATOM_create MK_ATOM("create") +#define ATOM_csym MK_ATOM("csym") +#define ATOM_csymf MK_ATOM("csymf") +#define ATOM_cumulative MK_ATOM("cumulative") +#define ATOM_curl MK_ATOM("{}") +#define ATOM_current MK_ATOM("current") +#define ATOM_current_input MK_ATOM("current_input") +#define ATOM_current_output MK_ATOM("current_output") +#define ATOM_cut MK_ATOM("!") +#define ATOM_cut_call MK_ATOM("cut_call") +#define ATOM_cut_exit MK_ATOM("cut_exit") +#define ATOM_cut_parent MK_ATOM("cut_parent") +#define ATOM_cutted MK_ATOM("cut") +#define ATOM_date MK_ATOM("date") +#define ATOM_dc_call_prolog MK_ATOM("$c_call_prolog") +#define ATOM_db_reference MK_ATOM("db_reference") +#define ATOM_dcall MK_ATOM("") +#define ATOM_dcall_cleanup MK_ATOM("$call_cleanup") +#define ATOM_dcatch MK_ATOM("$catch") +#define ATOM_dcut MK_ATOM("$cut") +#define ATOM_dde_error MK_ATOM("dde_error") +#define ATOM_dde_handle MK_ATOM("dde_handle") +#define ATOM_debug MK_ATOM("debug") +#define ATOM_debug_on_error MK_ATOM("debug_on_error") +#define ATOM_debugger_print_options MK_ATOM("debugger_print_options") +#define ATOM_debugger_show_context MK_ATOM("debugger_show_context") +#define ATOM_debugging MK_ATOM("debugging") +#define ATOM_dec10 MK_ATOM("dec10") +#define ATOM_default MK_ATOM("default") +#define ATOM_defined MK_ATOM("defined") +#define ATOM_delete MK_ATOM("delete") +#define ATOM_depth_limit_exceeded MK_ATOM("depth_limit_exceeded") +#define ATOM_destroy MK_ATOM("destroy") +#define ATOM_detached MK_ATOM("detached") +#define ATOM_detect MK_ATOM("detect") +#define ATOM_development MK_ATOM("development") +#define ATOM_dexit MK_ATOM("$exit") +#define ATOM_dforeign_registered MK_ATOM("$foreign_registered") +#define ATOM_dgarbage_collect MK_ATOM("$garbage_collect") +#define ATOM_digit MK_ATOM("digit") +#define ATOM_directory MK_ATOM("directory") +#define ATOM_discontiguous MK_ATOM("discontiguous") +#define ATOM_div MK_ATOM("//") +#define ATOM_divide MK_ATOM("/") +#define ATOM_dload MK_ATOM("$load") +#define ATOM_dmessage_queue MK_ATOM("$message_queue") +#define ATOM_dmutex MK_ATOM("$mutex") +#define ATOM_domain_error MK_ATOM("domain_error") +#define ATOM_dos MK_ATOM("dos") +#define ATOM_dot MK_ATOM(".") +#define ATOM_dots MK_ATOM("dots") +#define ATOM_double_quotes MK_ATOM("double_quotes") +#define ATOM_doublestar MK_ATOM("**") +#define ATOM_dprof_node MK_ATOM("$profile_node") +#define ATOM_dstream MK_ATOM("$stream") +#define ATOM_dthread_init MK_ATOM("$thread_init") +#define ATOM_dthrow MK_ATOM("$throw") +#define ATOM_dtime MK_ATOM("$time") +#define ATOM_dwakeup MK_ATOM("$wakeup") +#define ATOM_dynamic MK_ATOM("dynamic") +#define ATOM_e MK_ATOM("e") +#define ATOM_encoding MK_ATOM("encoding") +#define ATOM_end MK_ATOM("end") +#define ATOM_end_of_file MK_ATOM("end_of_file") +#define ATOM_end_of_line MK_ATOM("end_of_line") +#define ATOM_end_of_stream MK_ATOM("end_of_stream") +#define ATOM_environment MK_ATOM("environment") +#define ATOM_eof MK_ATOM("eof") +#define ATOM_eof_action MK_ATOM("eof_action") +#define ATOM_eof_code MK_ATOM("eof_code") +#define ATOM_equal MK_ATOM("equal") +#define ATOM_equals MK_ATOM("=") +#define ATOM_erase MK_ATOM("erase") +#define ATOM_erased MK_ATOM("erased") +#define ATOM_error MK_ATOM("error") +#define ATOM_eval MK_ATOM("eval") +#define ATOM_evaluable MK_ATOM("evaluable") +#define ATOM_evaluation_error MK_ATOM("evaluation_error") +#define ATOM_exception MK_ATOM("exception") +#define ATOM_exclusive MK_ATOM("exclusive") +#define ATOM_execute MK_ATOM("execute") +#define ATOM_exist MK_ATOM("exist") +#define ATOM_existence_error MK_ATOM("existence_error") +#define ATOM_exit MK_ATOM("exit") +#define ATOM_exited MK_ATOM("exited") +#define ATOM_exp MK_ATOM("exp") +#define ATOM_export MK_ATOM("export") +#define ATOM_exported MK_ATOM("exported") +#define ATOM_expression MK_ATOM("expression") +#define ATOM_externals MK_ATOM("externals") +#define ATOM_fact MK_ATOM("fact") +#define ATOM_factor MK_ATOM("factor") +#define ATOM_fail MK_ATOM("fail") +#define ATOM_failure_error MK_ATOM("failure_error") +#define ATOM_false MK_ATOM("false") +#define ATOM_feature MK_ATOM("feature") +#define ATOM_file MK_ATOM("file") +#define ATOM_file_name MK_ATOM("file_name") +#define ATOM_file_name_variables MK_ATOM("file_name_variables") +#define ATOM_file_no MK_ATOM("file_no") +#define ATOM_flag MK_ATOM("flag") +#define ATOM_flag_value MK_ATOM("flag_value") +#define ATOM_float MK_ATOM("float") +#define ATOM_float_format MK_ATOM("float_format") +#define ATOM_float_fractional_part MK_ATOM("float_fractional_part") +#define ATOM_float_integer_part MK_ATOM("float_integer_part") +#define ATOM_float_overflow MK_ATOM("float_overflow") +#define ATOM_float_underflow MK_ATOM("float_underflow") +#define ATOM_floor MK_ATOM("floor") +#define ATOM_force MK_ATOM("force") +#define ATOM_foreign MK_ATOM("foreign") +#define ATOM_foreign_function MK_ATOM("$foreign_function") +#define ATOM_foreign_return_value MK_ATOM("foreign_return_value") +#define ATOM_fork MK_ATOM("fork") +#define ATOM_frame MK_ATOM("frame") +#define ATOM_frame_attribute MK_ATOM("frame_attribute") +#define ATOM_frame_finished MK_ATOM("frame_finished") +#define ATOM_frame_reference MK_ATOM("frame_reference") +#define ATOM_free_of_attvar MK_ATOM("free_of_attvar") +#define ATOM_freeze MK_ATOM("freeze") +#define ATOM_full MK_ATOM("full") +#define ATOM_functor_name MK_ATOM("functor_name") +#define ATOM_functors MK_ATOM("functors") +#define ATOM_fx MK_ATOM("fx") +#define ATOM_fy MK_ATOM("fy") +#define ATOM_garbage_collected MK_ATOM("") +#define ATOM_garbage_collection MK_ATOM("garbage_collection") +#define ATOM_gc MK_ATOM("gc") +#define ATOM_gctime MK_ATOM("gctime") +#define ATOM_getcwd MK_ATOM("getcwd") +#define ATOM_global MK_ATOM("global") +#define ATOM_global_shifts MK_ATOM("global_shifts") +#define ATOM_global_stack MK_ATOM("global_stack") +#define ATOM_globallimit MK_ATOM("globallimit") +#define ATOM_globalused MK_ATOM("globalused") +#define ATOM_goal MK_ATOM("goal") +#define ATOM_goal_expansion MK_ATOM("goal_expansion") +#define ATOM_grammar MK_ATOM("-->") +#define ATOM_graph MK_ATOM("graph") +#define ATOM_gvar MK_ATOM("gvar") +#define ATOM_halt MK_ATOM("halt") +#define ATOM_has_alternatives MK_ATOM("has_alternatives") +#define ATOM_hash MK_ATOM("hash") +#define ATOM_hashed MK_ATOM("hashed") +#define ATOM_hat MK_ATOM("^") +#define ATOM_heap MK_ATOM("heap") +#define ATOM_heaplimit MK_ATOM("heaplimit") +#define ATOM_heapused MK_ATOM("heapused") +#define ATOM_help MK_ATOM("help") +#define ATOM_hidden MK_ATOM("hidden") +#define ATOM_hide_childs MK_ATOM("hide_childs") +#define ATOM_history_depth MK_ATOM("history_depth") +#define ATOM_ifthen MK_ATOM("->") +#define ATOM_ignore MK_ATOM("ignore") +#define ATOM_ignore_ops MK_ATOM("ignore_ops") +#define ATOM_imported MK_ATOM("imported") +#define ATOM_imported_procedure MK_ATOM("imported_procedure") +#define ATOM_index MK_ATOM("index") +#define ATOM_indexed MK_ATOM("indexed") +#define ATOM_inf MK_ATOM("inf") +#define ATOM_inferences MK_ATOM("inferences") +#define ATOM_infinite MK_ATOM("infinite") +#define ATOM_informational MK_ATOM("informational") +#define ATOM_init_file MK_ATOM("init_file") +#define ATOM_initialization MK_ATOM("initialization") +#define ATOM_input MK_ATOM("input") +#define ATOM_inserted_char MK_ATOM("inserted_char") +#define ATOM_instantiation_error MK_ATOM("instantiation_error") +#define ATOM_int MK_ATOM("int") +#define ATOM_int64_t MK_ATOM("int64_t") +#define ATOM_int_overflow MK_ATOM("int_overflow") +#define ATOM_integer MK_ATOM("integer") +#define ATOM_interrupt MK_ATOM("interrupt") +#define ATOM_io_error MK_ATOM("io_error") +#define ATOM_io_mode MK_ATOM("io_mode") +#define ATOM_ioctl MK_ATOM("ioctl") +#define ATOM_is MK_ATOM("is") +#define ATOM_iso MK_ATOM("iso") +#define ATOM_iso_latin_1 MK_ATOM("iso_latin_1") +#define ATOM_isovar MK_ATOM("$VAR") +#define ATOM_join MK_ATOM("join") +#define ATOM_jump MK_ATOM("jump") +#define ATOM_kernel MK_ATOM("kernel") +#define ATOM_key MK_ATOM("key") +#define ATOM_larger MK_ATOM(">") +#define ATOM_larger_equal MK_ATOM(">=") +#define ATOM_level MK_ATOM("level") +#define ATOM_li MK_ATOM("li") +#define ATOM_limit MK_ATOM("limit") +#define ATOM_line MK_ATOM("line") +#define ATOM_line_count MK_ATOM("line_count") +#define ATOM_list MK_ATOM("list") +#define ATOM_list_position MK_ATOM("list_position") +#define ATOM_listing MK_ATOM("listing") +#define ATOM_local MK_ATOM("local") +#define ATOM_local_shifts MK_ATOM("local_shifts") +#define ATOM_local_stack MK_ATOM("local_stack") +#define ATOM_locale MK_ATOM("locale") +#define ATOM_locallimit MK_ATOM("locallimit") +#define ATOM_localused MK_ATOM("localused") +#define ATOM_lock MK_ATOM("lock") +#define ATOM_locked MK_ATOM("locked") +#define ATOM_log MK_ATOM("log") +#define ATOM_log10 MK_ATOM("log10") +#define ATOM_long MK_ATOM("long") +#define ATOM_low MK_ATOM("low") +#define ATOM_lower MK_ATOM("lower") +#define ATOM_lsb MK_ATOM("lsb") +#define ATOM_lshift MK_ATOM("<<") +#define ATOM_main MK_ATOM("main") +#define ATOM_mark MK_ATOM("mark") +#define ATOM_matches MK_ATOM("matches") +#define ATOM_max MK_ATOM("max") +#define ATOM_max_arity MK_ATOM("max_arity") +#define ATOM_max_dde_handles MK_ATOM("max_dde_handles") +#define ATOM_max_depth MK_ATOM("max_depth") +#define ATOM_max_files MK_ATOM("max_files") +#define ATOM_max_path_length MK_ATOM("max_path_length") +#define ATOM_max_size MK_ATOM("max_size") +#define ATOM_max_variable_length MK_ATOM("max_variable_length") +#define ATOM_memory MK_ATOM("memory") +#define ATOM_message MK_ATOM("message") +#define ATOM_message_lines MK_ATOM("message_lines") +#define ATOM_message_queue MK_ATOM("message_queue") +#define ATOM_message_queue_property MK_ATOM("message_queue_property") +#define ATOM_meta_predicate MK_ATOM("meta_predicate") +#define ATOM_min MK_ATOM("min") +#define ATOM_min_free MK_ATOM("min_free") +#define ATOM_minus MK_ATOM("-") +#define ATOM_mismatched_char MK_ATOM("mismatched_char") +#define ATOM_mod MK_ATOM("mod") +#define ATOM_mode MK_ATOM("mode") +#define ATOM_modify MK_ATOM("modify") +#define ATOM_module MK_ATOM("module") +#define ATOM_module_property MK_ATOM("module_property") +#define ATOM_module_transparent MK_ATOM("module_transparent") +#define ATOM_modules MK_ATOM("modules") +#define ATOM_msb MK_ATOM("msb") +#define ATOM_multifile MK_ATOM("multifile") +#define ATOM_mutex MK_ATOM("mutex") +#define ATOM_mutex_option MK_ATOM("mutex_option") +#define ATOM_mutex_property MK_ATOM("mutex_property") +#define ATOM_natural MK_ATOM("natural") +#define ATOM_newline MK_ATOM("newline") +#define ATOM_nil MK_ATOM("[]") +#define ATOM_no_memory MK_ATOM("no_memory") +#define ATOM_nodebug MK_ATOM("nodebug") +#define ATOM_non_empty_list MK_ATOM("non_empty_list") +#define ATOM_none MK_ATOM("none") +#define ATOM_noprofile MK_ATOM("noprofile") +#define ATOM_not MK_ATOM("not") +#define ATOM_not_equals MK_ATOM("\\=") +#define ATOM_not_implemented MK_ATOM("not_implemented") +#define ATOM_not_less_than_one MK_ATOM("not_less_than_one") +#define ATOM_not_less_than_zero MK_ATOM("not_less_than_zero") +#define ATOM_not_provable MK_ATOM("\\+") +#define ATOM_not_strickt_equals MK_ATOM("\\==") +#define ATOM_not_unique MK_ATOM("not_unique") +#define ATOM_number MK_ATOM("number") +#define ATOM_number_of_clauses MK_ATOM("number_of_clauses") +#define ATOM_numbervar_option MK_ATOM("numbervar_option") +#define ATOM_numbervars MK_ATOM("numbervars") +#define ATOM_occurs_check MK_ATOM("occurs_check") +#define ATOM_octet MK_ATOM("octet") +#define ATOM_off MK_ATOM("off") +#define ATOM_on MK_ATOM("on") +#define ATOM_open MK_ATOM("open") +#define ATOM_operator MK_ATOM("operator") +#define ATOM_operator_priority MK_ATOM("operator_priority") +#define ATOM_operator_specifier MK_ATOM("operator_specifier") +#define ATOM_optimise MK_ATOM("optimise") +#define ATOM_or MK_ATOM("\\/") +#define ATOM_order MK_ATOM("order") +#define ATOM_output MK_ATOM("output") +#define ATOM_pair MK_ATOM("pair") +#define ATOM_paren MK_ATOM("paren") +#define ATOM_parent MK_ATOM("parent") +#define ATOM_parent_goal MK_ATOM("parent_goal") +#define ATOM_past MK_ATOM("past") +#define ATOM_past_end_of_stream MK_ATOM("past_end_of_stream") +#define ATOM_pattern MK_ATOM("pattern") +#define ATOM_pc MK_ATOM("pc") +#define ATOM_period MK_ATOM("period") +#define ATOM_permission_error MK_ATOM("permission_error") +#define ATOM_pi MK_ATOM("pi") +#define ATOM_pipe MK_ATOM("pipe") +#define ATOM_plain MK_ATOM("plain") +#define ATOM_plus MK_ATOM("+") +#define ATOM_popcount MK_ATOM("popcount") +#define ATOM_portray MK_ATOM("portray") +#define ATOM_position MK_ATOM("position") +#define ATOM_posix MK_ATOM("posix") +#define ATOM_powm MK_ATOM("powm") +#define ATOM_predicate_indicator MK_ATOM("predicate_indicator") +#define ATOM_predicates MK_ATOM("predicates") +#define ATOM_print MK_ATOM("print") +#define ATOM_print_message MK_ATOM("print_message") +#define ATOM_priority MK_ATOM("priority") +#define ATOM_private_procedure MK_ATOM("private_procedure") +#define ATOM_procedure MK_ATOM("procedure") +#define ATOM_profile_mode MK_ATOM("profile_mode") +#define ATOM_profile_no_cpu_time MK_ATOM("profile_no_cpu_time") +#define ATOM_profile_node MK_ATOM("profile_node") +#define ATOM_program MK_ATOM("program") +#define ATOM_program_counter MK_ATOM("program_counter") +#define ATOM_prolog MK_ATOM("prolog") +#define ATOM_prompt MK_ATOM("|:") +#define ATOM_property MK_ATOM("property") +#define ATOM_protocol MK_ATOM("protocol") +#define ATOM_prove MK_ATOM(":-") +#define ATOM_punct MK_ATOM("punct") +#define ATOM_query MK_ATOM("?-") +#define ATOM_queue_option MK_ATOM("queue_option") +#define ATOM_quiet MK_ATOM("quiet") +#define ATOM_quote MK_ATOM("quote") +#define ATOM_quoted MK_ATOM("quoted") +#define ATOM_radix MK_ATOM("radix") +#define ATOM_random MK_ATOM("random") +#define ATOM_rational MK_ATOM("rational") +#define ATOM_rationalize MK_ATOM("rationalize") +#define ATOM_rdiv MK_ATOM("rdiv") +#define ATOM_read MK_ATOM("read") +#define ATOM_read_option MK_ATOM("read_option") +#define ATOM_readline MK_ATOM("readline") +#define ATOM_real_time MK_ATOM("real_time") +#define ATOM_receiver MK_ATOM("receiver") +#define ATOM_record MK_ATOM("record") +#define ATOM_record_position MK_ATOM("record_position") +#define ATOM_redefine MK_ATOM("redefine") +#define ATOM_redo MK_ATOM("redo") +#define ATOM_references MK_ATOM("references") +#define ATOM_rem MK_ATOM("rem") +#define ATOM_rename MK_ATOM("rename") +#define ATOM_report_error MK_ATOM("report_error") +#define ATOM_reposition MK_ATOM("reposition") +#define ATOM_representation_error MK_ATOM("representation_error") +#define ATOM_representation_errors MK_ATOM("representation_errors") +#define ATOM_reset MK_ATOM("reset") +#define ATOM_resource_error MK_ATOM("resource_error") +#define ATOM_resource_handle MK_ATOM("resource_handle") +#define ATOM_retry MK_ATOM("retry") +#define ATOM_round MK_ATOM("round") +#define ATOM_rshift MK_ATOM(">>") +#define ATOM_running MK_ATOM("running") +#define ATOM_runtime MK_ATOM("runtime") +#define ATOM_save_class MK_ATOM("save_class") +#define ATOM_save_option MK_ATOM("save_option") +#define ATOM_seek_method MK_ATOM("seek_method") +#define ATOM_select MK_ATOM("select") +#define ATOM_semicolon MK_ATOM(";") +#define ATOM_separated MK_ATOM("separated") +#define ATOM_setup_and_call_cleanup MK_ATOM("setup_and_call_cleanup") +#define ATOM_shared MK_ATOM("shared") +#define ATOM_shared_object MK_ATOM("shared_object") +#define ATOM_shared_object_handle MK_ATOM("shared_object_handle") +#define ATOM_shell MK_ATOM("shell") +#define ATOM_sign MK_ATOM("sign") +#define ATOM_signal MK_ATOM("signal") +#define ATOM_signal_handler MK_ATOM("signal_handler") +#define ATOM_silent MK_ATOM("silent") +#define ATOM_sin MK_ATOM("sin") +#define ATOM_singletons MK_ATOM("singletons") +#define ATOM_size MK_ATOM("size") +#define ATOM_skip MK_ATOM("skip") +#define ATOM_smaller MK_ATOM("<") +#define ATOM_smaller_equal MK_ATOM("=<") +#define ATOM_softcut MK_ATOM("*->") +#define ATOM_source_sink MK_ATOM("source_sink") +#define ATOM_space MK_ATOM("space") +#define ATOM_spy MK_ATOM("spy") +#define ATOM_sqrt MK_ATOM("sqrt") +#define ATOM_stack MK_ATOM("stack") +#define ATOM_stack_parameter MK_ATOM("stack_parameter") +#define ATOM_stack_shifts MK_ATOM("stack_shifts") +#define ATOM_stacks MK_ATOM("stacks") +#define ATOM_stand_alone MK_ATOM("stand_alone") +#define ATOM_star MK_ATOM("*") +#define ATOM_start MK_ATOM("start") +#define ATOM_stat MK_ATOM("stat") +#define ATOM_static_procedure MK_ATOM("static_procedure") +#define ATOM_statistics MK_ATOM("statistics") +#define ATOM_status MK_ATOM("status") +#define ATOM_stderr MK_ATOM("stderr") +#define ATOM_stream MK_ATOM("stream") +#define ATOM_stream_option MK_ATOM("stream_option") +#define ATOM_stream_or_alias MK_ATOM("stream_or_alias") +#define ATOM_stream_position MK_ATOM("$stream_position") +#define ATOM_stream_property MK_ATOM("stream_property") +#define ATOM_strict_equal MK_ATOM("==") +#define ATOM_string MK_ATOM("string") +#define ATOM_string_position MK_ATOM("string_position") +#define ATOM_subterm_positions MK_ATOM("subterm_positions") +#define ATOM_suffix MK_ATOM("suffix") +#define ATOM_syntax_error MK_ATOM("syntax_error") +#define ATOM_syntax_errors MK_ATOM("syntax_errors") +#define ATOM_system MK_ATOM("system") +#define ATOM_system_error MK_ATOM("system_error") +#define ATOM_system_init_file MK_ATOM("system_init_file") +#define ATOM_system_thread_id MK_ATOM("system_thread_id") +#define ATOM_system_time MK_ATOM("system_time") +#define ATOM_tan MK_ATOM("tan") +#define ATOM_term MK_ATOM("term") +#define ATOM_term_expansion MK_ATOM("term_expansion") +#define ATOM_term_position MK_ATOM("term_position") +#define ATOM_terminal MK_ATOM("terminal") +#define ATOM_terminal_capability MK_ATOM("terminal_capability") +#define ATOM_text MK_ATOM("text") +#define ATOM_thread MK_ATOM("thread") +#define ATOM_thread_cputime MK_ATOM("thread_cputime") +#define ATOM_thread_initialization MK_ATOM("thread_initialization") +#define ATOM_thread_local MK_ATOM("thread_local") +#define ATOM_thread_local_procedure MK_ATOM("thread_local_procedure") +#define ATOM_thread_option MK_ATOM("thread_option") +#define ATOM_thread_property MK_ATOM("thread_property") +#define ATOM_threads MK_ATOM("threads") +#define ATOM_threads_created MK_ATOM("threads_created") +#define ATOM_throw MK_ATOM("throw") +#define ATOM_tilde MK_ATOM("~") +#define ATOM_time MK_ATOM("time") +#define ATOM_time_stamp MK_ATOM("time_stamp") +#define ATOM_timeout MK_ATOM("timeout") +#define ATOM_timeout_error MK_ATOM("timeout_error") +#define ATOM_timezone MK_ATOM("timezone") +#define ATOM_to_lower MK_ATOM("to_lower") +#define ATOM_to_upper MK_ATOM("to_upper") +#define ATOM_top MK_ATOM("top") +#define ATOM_top_level MK_ATOM("top_level") +#define ATOM_toplevel MK_ATOM("toplevel") +#define ATOM_trace MK_ATOM("trace") +#define ATOM_trace_any MK_ATOM("trace_any") +#define ATOM_trace_call MK_ATOM("trace_call") +#define ATOM_trace_exit MK_ATOM("trace_exit") +#define ATOM_trace_fail MK_ATOM("trace_fail") +#define ATOM_trace_gc MK_ATOM("trace_gc") +#define ATOM_trace_redo MK_ATOM("trace_redo") +#define ATOM_traceinterc MK_ATOM("prolog_trace_interception") +#define ATOM_tracing MK_ATOM("tracing") +#define ATOM_trail MK_ATOM("trail") +#define ATOM_trail_shifts MK_ATOM("trail_shifts") +#define ATOM_traillimit MK_ATOM("traillimit") +#define ATOM_trailused MK_ATOM("trailused") +#define ATOM_transparent MK_ATOM("transparent") +#define ATOM_transposed_char MK_ATOM("transposed_char") +#define ATOM_transposed_word MK_ATOM("transposed_word") +#define ATOM_true MK_ATOM("true") +#define ATOM_truncate MK_ATOM("truncate") +#define ATOM_tty MK_ATOM("tty") +#define ATOM_tty_control MK_ATOM("tty_control") +#define ATOM_type MK_ATOM("type") +#define ATOM_type_error MK_ATOM("type_error") +#define ATOM_undefined MK_ATOM("undefined") +#define ATOM_undefined_global_variable MK_ATOM("undefined_global_variable") +#define ATOM_undefinterc MK_ATOM("$undefined_procedure") +#define ATOM_unicode_be MK_ATOM("unicode_be") +#define ATOM_unicode_le MK_ATOM("unicode_le") +#define ATOM_unify MK_ATOM("unify") +#define ATOM_unique MK_ATOM("unique") +#define ATOM_univ MK_ATOM("=..") +#define ATOM_unknown MK_ATOM("unknown") +#define ATOM_unlimited MK_ATOM("unlimited") +#define ATOM_unlock MK_ATOM("unlock") +#define ATOM_unlocked MK_ATOM("unlocked") +#define ATOM_update MK_ATOM("update") +#define ATOM_upper MK_ATOM("upper") +#define ATOM_user MK_ATOM("user") +#define ATOM_user_error MK_ATOM("user_error") +#define ATOM_user_input MK_ATOM("user_input") +#define ATOM_user_output MK_ATOM("user_output") +#define ATOM_utc MK_ATOM("UTC") +#define ATOM_utf8 MK_ATOM("utf8") +#define ATOM_v MK_ATOM("v") +#define ATOM_var MK_ATOM("$VAR$") +#define ATOM_variable MK_ATOM("variable") +#define ATOM_variable_names MK_ATOM("variable_names") +#define ATOM_variables MK_ATOM("variables") +#define ATOM_very_deep MK_ATOM("very_deep") +#define ATOM_vmi MK_ATOM("vmi") +#define ATOM_volatile MK_ATOM("volatile") +#define ATOM_wakeup MK_ATOM("wakeup") +#define ATOM_warning MK_ATOM("warning") +#define ATOM_wchar_t MK_ATOM("wchar_t") +#define ATOM_white MK_ATOM("white") +#define ATOM_write MK_ATOM("write") +#define ATOM_write_attributes MK_ATOM("write_attributes") +#define ATOM_write_option MK_ATOM("write_option") +#define ATOM_xdigit MK_ATOM("xdigit") +#define ATOM_xf MK_ATOM("xf") +#define ATOM_xfx MK_ATOM("xfx") +#define ATOM_xfy MK_ATOM("xfy") +#define ATOM_xml MK_ATOM("xml") +#define ATOM_xor MK_ATOM("xor") +#define ATOM_xpceref MK_ATOM("@") +#define ATOM_yf MK_ATOM("yf") +#define ATOM_yfx MK_ATOM("yfx") +#define ATOM_yfy MK_ATOM("yfy") +#define ATOM_zero_divisor MK_ATOM("zero_divisor") +#define FUNCTOR_abs1 MKFUNCTOR(ATOM_abs,1) +#define FUNCTOR_access1 MKFUNCTOR(ATOM_access,1) +#define FUNCTOR_acos1 MKFUNCTOR(ATOM_acos,1) +#define FUNCTOR_alias1 MKFUNCTOR(ATOM_alias,1) +#define FUNCTOR_and2 MKFUNCTOR(ATOM_and,2) +#define FUNCTOR_ar_equals2 MKFUNCTOR(ATOM_ar_equals,2) +#define FUNCTOR_ar_not_equal2 MKFUNCTOR(ATOM_ar_not_equal,2) +#define FUNCTOR_asin1 MKFUNCTOR(ATOM_asin,1) +#define FUNCTOR_assert1 MKFUNCTOR(ATOM_assert,1) +#define FUNCTOR_asserta1 MKFUNCTOR(ATOM_asserta,1) +#define FUNCTOR_atan1 MKFUNCTOR(ATOM_atan,1) +#define FUNCTOR_atan2 MKFUNCTOR(ATOM_atan,2) +#define FUNCTOR_atom1 MKFUNCTOR(ATOM_atom,1) +#define FUNCTOR_att3 MKFUNCTOR(ATOM_att,3) +#define FUNCTOR_backslash1 MKFUNCTOR(ATOM_backslash,1) +#define FUNCTOR_bar2 MKFUNCTOR(ATOM_bar,2) +#define FUNCTOR_block3 MKFUNCTOR(ATOM_block,3) +#define FUNCTOR_bom1 MKFUNCTOR(ATOM_bom,1) +#define FUNCTOR_brace_term_position3 MKFUNCTOR(ATOM_brace_term_position,3) +#define FUNCTOR_break1 MKFUNCTOR(ATOM_break,1) +#define FUNCTOR_break3 MKFUNCTOR(ATOM_break,3) +#define FUNCTOR_buffer1 MKFUNCTOR(ATOM_buffer,1) +#define FUNCTOR_buffer_size1 MKFUNCTOR(ATOM_buffer_size,1) +#define FUNCTOR_busy2 MKFUNCTOR(ATOM_busy,2) +#define FUNCTOR_call1 MKFUNCTOR(ATOM_call,1) +#define FUNCTOR_callpred2 MKFUNCTOR(ATOM_callpred,2) +#define FUNCTOR_catch3 MKFUNCTOR(ATOM_catch,3) +#define FUNCTOR_ceil1 MKFUNCTOR(ATOM_ceil,1) +#define FUNCTOR_ceiling1 MKFUNCTOR(ATOM_ceiling,1) +#define FUNCTOR_chars1 MKFUNCTOR(ATOM_chars,1) +#define FUNCTOR_chars2 MKFUNCTOR(ATOM_chars,2) +#define FUNCTOR_clause1 MKFUNCTOR(ATOM_clause,1) +#define FUNCTOR_close_on_abort1 MKFUNCTOR(ATOM_close_on_abort,1) +#define FUNCTOR_codes1 MKFUNCTOR(ATOM_codes,1) +#define FUNCTOR_codes2 MKFUNCTOR(ATOM_codes,2) +#define FUNCTOR_colon2 MKFUNCTOR(ATOM_colon,2) +#define FUNCTOR_comma2 MKFUNCTOR(ATOM_comma,2) +#define FUNCTOR_context2 MKFUNCTOR(ATOM_context,2) +#define FUNCTOR_cos1 MKFUNCTOR(ATOM_cos,1) +#define FUNCTOR_cputime0 MKFUNCTOR(ATOM_cputime,0) +#define FUNCTOR_curl1 MKFUNCTOR(ATOM_curl,1) +#define FUNCTOR_cut_call1 MKFUNCTOR(ATOM_cut_call,1) +#define FUNCTOR_cut_exit1 MKFUNCTOR(ATOM_cut_exit,1) +#define FUNCTOR_date9 MKFUNCTOR(ATOM_date,9) +#define FUNCTOR_dcall1 MKFUNCTOR(ATOM_dcall,1) +#define FUNCTOR_dcut1 MKFUNCTOR(ATOM_dcut,1) +#define FUNCTOR_dde_error2 MKFUNCTOR(ATOM_dde_error,2) +#define FUNCTOR_debugging1 MKFUNCTOR(ATOM_debugging,1) +#define FUNCTOR_detached1 MKFUNCTOR(ATOM_detached,1) +#define FUNCTOR_dexit2 MKFUNCTOR(ATOM_dexit,2) +#define FUNCTOR_dforeign_registered2 MKFUNCTOR(ATOM_dforeign_registered,2) +#define FUNCTOR_dgarbage_collect1 MKFUNCTOR(ATOM_dgarbage_collect,1) +#define FUNCTOR_div2 MKFUNCTOR(ATOM_div,2) +#define FUNCTOR_divide2 MKFUNCTOR(ATOM_divide,2) +#define FUNCTOR_dmessage_queue1 MKFUNCTOR(ATOM_dmessage_queue,1) +#define FUNCTOR_dmutex1 MKFUNCTOR(ATOM_dmutex,1) +#define FUNCTOR_domain_error2 MKFUNCTOR(ATOM_domain_error,2) +#define FUNCTOR_dot2 MKFUNCTOR(ATOM_dot,2) +#define FUNCTOR_doublestar2 MKFUNCTOR(ATOM_doublestar,2) +#define FUNCTOR_dprof_node1 MKFUNCTOR(ATOM_dprof_node,1) +#define FUNCTOR_dstream1 MKFUNCTOR(ATOM_dstream,1) +#define FUNCTOR_dthread_init0 MKFUNCTOR(ATOM_dthread_init,0) +#define FUNCTOR_dthrow1 MKFUNCTOR(ATOM_dthrow,1) +#define FUNCTOR_dtime2 MKFUNCTOR(ATOM_dtime,2) +#define FUNCTOR_dwakeup1 MKFUNCTOR(ATOM_dwakeup,1) +#define FUNCTOR_e0 MKFUNCTOR(ATOM_e,0) +#define FUNCTOR_encoding1 MKFUNCTOR(ATOM_encoding,1) +#define FUNCTOR_end_of_stream1 MKFUNCTOR(ATOM_end_of_stream,1) +#define FUNCTOR_eof_action1 MKFUNCTOR(ATOM_eof_action,1) +#define FUNCTOR_equals2 MKFUNCTOR(ATOM_equals,2) +#define FUNCTOR_erased1 MKFUNCTOR(ATOM_erased,1) +#define FUNCTOR_error2 MKFUNCTOR(ATOM_error,2) +#define FUNCTOR_eval1 MKFUNCTOR(ATOM_eval,1) +#define FUNCTOR_evaluation_error1 MKFUNCTOR(ATOM_evaluation_error,1) +#define FUNCTOR_exception1 MKFUNCTOR(ATOM_exception,1) +#define FUNCTOR_exception3 MKFUNCTOR(ATOM_exception,3) +#define FUNCTOR_existence_error2 MKFUNCTOR(ATOM_existence_error,2) +#define FUNCTOR_exited1 MKFUNCTOR(ATOM_exited,1) +#define FUNCTOR_exp1 MKFUNCTOR(ATOM_exp,1) +#define FUNCTOR_fail0 MKFUNCTOR(ATOM_fail,0) +#define FUNCTOR_failure_error1 MKFUNCTOR(ATOM_failure_error,1) +#define FUNCTOR_file1 MKFUNCTOR(ATOM_file,1) +#define FUNCTOR_file4 MKFUNCTOR(ATOM_file,4) +#define FUNCTOR_file_name1 MKFUNCTOR(ATOM_file_name,1) +#define FUNCTOR_file_no1 MKFUNCTOR(ATOM_file_no,1) +#define FUNCTOR_float1 MKFUNCTOR(ATOM_float,1) +#define FUNCTOR_float_fractional_part1 MKFUNCTOR(ATOM_float_fractional_part,1) +#define FUNCTOR_float_integer_part1 MKFUNCTOR(ATOM_float_integer_part,1) +#define FUNCTOR_floor1 MKFUNCTOR(ATOM_floor,1) +#define FUNCTOR_foreign_function1 MKFUNCTOR(ATOM_foreign_function,1) +#define FUNCTOR_frame3 MKFUNCTOR(ATOM_frame,3) +#define FUNCTOR_frame_finished1 MKFUNCTOR(ATOM_frame_finished,1) +#define FUNCTOR_goal_expansion2 MKFUNCTOR(ATOM_goal_expansion,2) +#define FUNCTOR_hat2 MKFUNCTOR(ATOM_hat,2) +#define FUNCTOR_ifthen2 MKFUNCTOR(ATOM_ifthen,2) +#define FUNCTOR_input0 MKFUNCTOR(ATOM_input,0) +#define FUNCTOR_integer1 MKFUNCTOR(ATOM_integer,1) +#define FUNCTOR_interrupt1 MKFUNCTOR(ATOM_interrupt,1) +#define FUNCTOR_io_error2 MKFUNCTOR(ATOM_io_error,2) +#define FUNCTOR_is2 MKFUNCTOR(ATOM_is,2) +#define FUNCTOR_isovar1 MKFUNCTOR(ATOM_isovar,1) +#define FUNCTOR_larger2 MKFUNCTOR(ATOM_larger,2) +#define FUNCTOR_larger_equal2 MKFUNCTOR(ATOM_larger_equal,2) +#define FUNCTOR_line_count1 MKFUNCTOR(ATOM_line_count,1) +#define FUNCTOR_list_position4 MKFUNCTOR(ATOM_list_position,4) +#define FUNCTOR_listing1 MKFUNCTOR(ATOM_listing,1) +#define FUNCTOR_locked2 MKFUNCTOR(ATOM_locked,2) +#define FUNCTOR_log1 MKFUNCTOR(ATOM_log,1) +#define FUNCTOR_log101 MKFUNCTOR(ATOM_log10,1) +#define FUNCTOR_lsb1 MKFUNCTOR(ATOM_lsb,1) +#define FUNCTOR_lshift2 MKFUNCTOR(ATOM_lshift,2) +#define FUNCTOR_max2 MKFUNCTOR(ATOM_max,2) +#define FUNCTOR_max_size1 MKFUNCTOR(ATOM_max_size,1) +#define FUNCTOR_message_lines1 MKFUNCTOR(ATOM_message_lines,1) +#define FUNCTOR_min2 MKFUNCTOR(ATOM_min,2) +#define FUNCTOR_minus1 MKFUNCTOR(ATOM_minus,1) +#define FUNCTOR_minus2 MKFUNCTOR(ATOM_minus,2) +#define FUNCTOR_mod2 MKFUNCTOR(ATOM_mod,2) +#define FUNCTOR_mode1 MKFUNCTOR(ATOM_mode,1) +#define FUNCTOR_msb1 MKFUNCTOR(ATOM_msb,1) +#define FUNCTOR_newline1 MKFUNCTOR(ATOM_newline,1) +#define FUNCTOR_not_implemented2 MKFUNCTOR(ATOM_not_implemented,2) +#define FUNCTOR_not_provable1 MKFUNCTOR(ATOM_not_provable,1) +#define FUNCTOR_occurs_check2 MKFUNCTOR(ATOM_occurs_check,2) +#define FUNCTOR_or2 MKFUNCTOR(ATOM_or,2) +#define FUNCTOR_output0 MKFUNCTOR(ATOM_output,0) +#define FUNCTOR_permission_error3 MKFUNCTOR(ATOM_permission_error,3) +#define FUNCTOR_pi0 MKFUNCTOR(ATOM_pi,0) +#define FUNCTOR_pipe1 MKFUNCTOR(ATOM_pipe,1) +#define FUNCTOR_plus1 MKFUNCTOR(ATOM_plus,1) +#define FUNCTOR_plus2 MKFUNCTOR(ATOM_plus,2) +#define FUNCTOR_popcount1 MKFUNCTOR(ATOM_popcount,1) +#define FUNCTOR_portray1 MKFUNCTOR(ATOM_portray,1) +#define FUNCTOR_position1 MKFUNCTOR(ATOM_position,1) +#define FUNCTOR_powm3 MKFUNCTOR(ATOM_powm,3) +#define FUNCTOR_print1 MKFUNCTOR(ATOM_print,1) +#define FUNCTOR_print_message2 MKFUNCTOR(ATOM_print_message,2) +#define FUNCTOR_procedure2 MKFUNCTOR(ATOM_procedure,2) +#define FUNCTOR_prove1 MKFUNCTOR(ATOM_prove,1) +#define FUNCTOR_prove2 MKFUNCTOR(ATOM_prove,2) +#define FUNCTOR_punct2 MKFUNCTOR(ATOM_punct,2) +#define FUNCTOR_random1 MKFUNCTOR(ATOM_random,1) +#define FUNCTOR_rational1 MKFUNCTOR(ATOM_rational,1) +#define FUNCTOR_rationalize1 MKFUNCTOR(ATOM_rationalize,1) +#define FUNCTOR_rdiv2 MKFUNCTOR(ATOM_rdiv,2) +#define FUNCTOR_rem2 MKFUNCTOR(ATOM_rem,2) +#define FUNCTOR_reposition1 MKFUNCTOR(ATOM_reposition,1) +#define FUNCTOR_representation_error1 MKFUNCTOR(ATOM_representation_error,1) +#define FUNCTOR_representation_errors1 MKFUNCTOR(ATOM_representation_errors,1) +#define FUNCTOR_resource_error1 MKFUNCTOR(ATOM_resource_error,1) +#define FUNCTOR_retry1 MKFUNCTOR(ATOM_retry,1) +#define FUNCTOR_round1 MKFUNCTOR(ATOM_round,1) +#define FUNCTOR_rshift2 MKFUNCTOR(ATOM_rshift,2) +#define FUNCTOR_semicolon2 MKFUNCTOR(ATOM_semicolon,2) +#define FUNCTOR_setup_and_call_cleanup4 MKFUNCTOR(ATOM_setup_and_call_cleanup,4) +#define FUNCTOR_shared_object2 MKFUNCTOR(ATOM_shared_object,2) +#define FUNCTOR_shell2 MKFUNCTOR(ATOM_shell,2) +#define FUNCTOR_sign1 MKFUNCTOR(ATOM_sign,1) +#define FUNCTOR_signal1 MKFUNCTOR(ATOM_signal,1) +#define FUNCTOR_signal2 MKFUNCTOR(ATOM_signal,2) +#define FUNCTOR_sin1 MKFUNCTOR(ATOM_sin,1) +#define FUNCTOR_singletons1 MKFUNCTOR(ATOM_singletons,1) +#define FUNCTOR_size1 MKFUNCTOR(ATOM_size,1) +#define FUNCTOR_smaller2 MKFUNCTOR(ATOM_smaller,2) +#define FUNCTOR_smaller_equal2 MKFUNCTOR(ATOM_smaller_equal,2) +#define FUNCTOR_softcut2 MKFUNCTOR(ATOM_softcut,2) +#define FUNCTOR_spy1 MKFUNCTOR(ATOM_spy,1) +#define FUNCTOR_sqrt1 MKFUNCTOR(ATOM_sqrt,1) +#define FUNCTOR_star2 MKFUNCTOR(ATOM_star,2) +#define FUNCTOR_status1 MKFUNCTOR(ATOM_status,1) +#define FUNCTOR_stream4 MKFUNCTOR(ATOM_stream,4) +#define FUNCTOR_stream_position4 MKFUNCTOR(ATOM_stream_position,4) +#define FUNCTOR_string1 MKFUNCTOR(ATOM_string,1) +#define FUNCTOR_string2 MKFUNCTOR(ATOM_string,2) +#define FUNCTOR_string_position2 MKFUNCTOR(ATOM_string_position,2) +#define FUNCTOR_syntax_error1 MKFUNCTOR(ATOM_syntax_error,1) +#define FUNCTOR_syntax_error3 MKFUNCTOR(ATOM_syntax_error,3) +#define FUNCTOR_tan1 MKFUNCTOR(ATOM_tan,1) +#define FUNCTOR_term_expansion2 MKFUNCTOR(ATOM_term_expansion,2) +#define FUNCTOR_term_position5 MKFUNCTOR(ATOM_term_position,5) +#define FUNCTOR_timeout1 MKFUNCTOR(ATOM_timeout,1) +#define FUNCTOR_timeout_error2 MKFUNCTOR(ATOM_timeout_error,2) +#define FUNCTOR_trace1 MKFUNCTOR(ATOM_trace,1) +#define FUNCTOR_traceinterc3 MKFUNCTOR(ATOM_traceinterc,3) +#define FUNCTOR_tracing1 MKFUNCTOR(ATOM_tracing,1) +#define FUNCTOR_true0 MKFUNCTOR(ATOM_true,0) +#define FUNCTOR_truncate1 MKFUNCTOR(ATOM_truncate,1) +#define FUNCTOR_tty1 MKFUNCTOR(ATOM_tty,1) +#define FUNCTOR_type1 MKFUNCTOR(ATOM_type,1) +#define FUNCTOR_type_error2 MKFUNCTOR(ATOM_type_error,2) +#define FUNCTOR_undefinterc4 MKFUNCTOR(ATOM_undefinterc,4) +#define FUNCTOR_var1 MKFUNCTOR(ATOM_var,1) +#define FUNCTOR_wakeup3 MKFUNCTOR(ATOM_wakeup,3) +#define FUNCTOR_warning3 MKFUNCTOR(ATOM_warning,3) +#define FUNCTOR_xor2 MKFUNCTOR(ATOM_xor,2) +#define FUNCTOR_xpceref1 MKFUNCTOR(ATOM_xpceref,1) +#define FUNCTOR_dc_call_prolog0 MKFUNCTOR(ATOM_dc_call_prolog,0) +#define FUNCTOR_strict_equal2 MKFUNCTOR(ATOM_strict_equal,2) diff --git a/LGPL/PLStream/buildatoms b/LGPL/PLStream/buildatoms new file mode 100644 index 000000000..ec3de1e96 --- /dev/null +++ b/LGPL/PLStream/buildatoms @@ -0,0 +1,35 @@ + +:- use_module(library(lineutils), + [file_filter/3, + split/3]). + +:- use_module(library(lists), + [append/2]). + +:- initialization(main). + +:- yap_flag(write_strings,on). + +main :- + file_filter('ATOMS','atoms.h',gen_decl). + +gen_decl(Inp,Out) :- + split(Inp," ",["A",Atom,String]), !, + append(["#define ATOM_",Atom," MK_ATOM(",String,")"],Out). +gen_decl(Inp,Out) :- + split(Inp," ",["F",Name,Arity]), !, + counter(I), + number_codes(I,IS), + append(["#define FUNCTOR_",Name,Arity," MKFUNCTOR(ATOM_",Name,",",Arity,")"],Out). + + +:- nb_setval(count,0). + +counter(I) :- + nb_getval(count,I), + I1 is I+1, + nb_setval(count,I1). + + + + diff --git a/LGPL/PLStream/pl-buffer.c b/LGPL/PLStream/pl-buffer.c new file mode 100644 index 000000000..4048ffafb --- /dev/null +++ b/LGPL/PLStream/pl-buffer.c @@ -0,0 +1,114 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: jan@swi.psy.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2002, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +#include "pl-incl.h" + +// vsc: changed from SWI +#define discardable_buffer (LD->discardable_buffer) +#define buffer_ring (LD->buffer_ring) +#define current_buffer_id (LD->current_buffer_id) + +Buffer +findBuffer(int flags) +{ GET_LD + Buffer b; + + if ( flags & BUF_RING ) + { if ( ++current_buffer_id == BUFFER_RING_SIZE ) + current_buffer_id = 0; + b = &buffer_ring[current_buffer_id]; + } else + b = &discardable_buffer; + + if ( !b->base ) + initBuffer(b); + + emptyBuffer(b); + return b; +} + +int +unfindBuffer(int flags) +{ GET_LD + if ( flags & BUF_RING ) + { if ( --current_buffer_id <= 0 ) + current_buffer_id = BUFFER_RING_SIZE-1; + } + + fail; +} + + + +void +growBuffer(Buffer b, size_t minfree) +{ size_t osz = b->max - b->base, sz = osz; + size_t top = b->top - b->base; + + if ( b->max - b->top >= (int)minfree ) + return; + + if ( sz < 512 ) + sz = 512; /* minimum reasonable size */ + while( top + minfree > sz ) + sz *= 2; + + if ( b->base != b->static_buffer ) + { +#ifdef BUFFER_USES_MALLOC + b->base = realloc(b->base, sz); + if ( !b->base ) + outOfCore(); +#else + char *old = b->base; + b->base = allocHeap(sz); + memcpy(b->base, old, osz); +#endif + } else /* from static buffer */ + { char *new; +#ifdef BUFFER_USES_MALLOC + if ( !(new = malloc(sz)) ) + outOfCore(); +#else + new = allocHeap(sz); +#endif + memcpy(new, b->static_buffer, osz); + b->base = new; + } + + b->top = b->base + top; + b->max = b->base + sz; +} + +char * +buffer_string(const char *s, int flags) +{ Buffer b = findBuffer(flags); + size_t l = strlen(s) + 1; + + addMultipleBuffer(b, s, l, char); + + return baseBuffer(b, char); +} + + diff --git a/LGPL/PLStream/pl-buffer.h b/LGPL/PLStream/pl-buffer.h new file mode 100644 index 000000000..3c7e73895 --- /dev/null +++ b/LGPL/PLStream/pl-buffer.h @@ -0,0 +1,112 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: jan@swi.psy.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2002, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +#ifndef BUFFER_H_INCLUDED +#define BUFFER_H_INCLUDED + +#define STATIC_BUFFER_SIZE (512) +#define BUFFER_USES_MALLOC 1 + +#define BUFFER_RING_SIZE 16 /* foreign buffer ring (pl-fli.c) */ + +typedef struct +{ char * base; /* allocated base */ + char * top; /* pointer to top */ + char * max; /* current location */ + char static_buffer[STATIC_BUFFER_SIZE]; +} tmp_buffer, *TmpBuffer; + +typedef struct +{ char * base; /* allocated base */ + char * top; /* pointer to top */ + char * max; /* current location */ + char static_buffer[sizeof(char *)]; +} buffer, *Buffer; + +void growBuffer(Buffer b, size_t minfree); + +Buffer findBuffer(int flags); + +char *buffer_string(const char *s, int flags); + +int unfindBuffer(int flags); + +Buffer codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide); + +#define addBuffer(b, obj, type) \ + do \ + { if ( (b)->top + sizeof(type) > (b)->max ) \ + growBuffer((Buffer)b, sizeof(type)); \ + *((type *)(b)->top) = obj; \ + (b)->top += sizeof(type); \ + } while(0) + +#define addMultipleBuffer(b, ptr, times, type) \ + do \ + { size_t _tms = (times); \ + size_t _len = _tms * sizeof(type); \ + type *_d, *_s = (type *)ptr; \ + if ( (b)->top + _len > (b)->max ) \ + growBuffer((Buffer)b, _len); \ + _d = (type *)(b)->top; \ + while ( _tms-- ) \ + *_d++ = *_s++; \ + (b)->top = (char *)_d; \ + } while(0) + +#define baseBuffer(b, type) ((type *) (b)->base) +#define topBuffer(b, type) ((type *) (b)->top) +#define inBuffer(b, addr) ((char *) (addr) >= (b)->base && \ + (char *) (addr) < (b)->top) +#define fetchBuffer(b, i, type) (baseBuffer(b, type)[i]) + +#define seekBuffer(b, cnt, type) ((b)->top = sizeof(type) * (cnt) + (b)->base) +#define sizeOfBuffer(b) ((b)->top - (b)->base) +#define freeSpaceBuffer(b) ((b)->max - (b)->top) +#define entriesBuffer(b, type) (sizeOfBuffer(b) / sizeof(type)) +#define initBuffer(b) ((b)->base = (b)->top = (b)->static_buffer, \ + (b)->max = (b)->base + \ + sizeof((b)->static_buffer)) +#define emptyBuffer(b) ((b)->top = (b)->base) +#define isEmptyBuffer(b) ((b)->top == (b)->base) + +#ifdef BUFFER_USES_MALLOC +#define discardBuffer(b) \ + do \ + { if ( (b)->base && (b)->base != (b)->static_buffer ) \ + { free((b)->base); \ + (b)->base = (b)->static_buffer; \ + } \ + } while(0) +#else +#define discardBuffer(b) \ + do \ + { if ( (b)->base && (b)->base != (b)->static_buffer ) \ + { freeHeap((b)->base, (b)->max - (b)->base); \ + (b)->base = (b)->static_buffer; \ + } \ + } while(0) +#endif + +#endif /*BUFFER_H_INCLUDED*/ diff --git a/LGPL/PLStream/pl-ctype.c b/LGPL/PLStream/pl-ctype.c new file mode 100644 index 000000000..136db6ce3 --- /dev/null +++ b/LGPL/PLStream/pl-ctype.c @@ -0,0 +1,911 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: wielemak@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2007, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +#include "pl-incl.h" +#include +#include "pl-ctype.h" + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +This module defines: + + char_type(?Char, ?Type) + code_type(?Char, ?Type) + +See manual for details. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#define CHAR_MODE 0 +#define CODE_MODE 1 + +#define CTX_CHAR 0 /* Class(Char) */ +#define CTX_CODE 1 /* Class(Int) */ + +typedef struct +{ atom_t name; /* name of the class */ + int (*test)(wint_t chr); /* boolean */ + int (*reverse)(wint_t chr); /* reverse mapping */ + short arity; /* arity of class (i.e. lower('A')) */ + short ctx_type; /* CTX_* */ +} char_type; + +#define ENUM_NONE 0x00 +#define ENUM_CHAR 0x01 +#define ENUM_CLASS 0x02 +#define ENUM_BOTH 0x03 + +typedef struct +{ int current; /* current character */ + const char_type *class; /* current class */ + int do_enum; /* what to enumerate */ +} generator; + + +static int unicode_separator(pl_wchar_t c); + +static int +iswhite(wint_t chr) +{ return chr == ' ' || chr == '\t'; +} + + +#ifdef __YAP_PROLOG__ +inline int +unicode_separator(pl_wchar_t c) +{ //return PlBlankW(c); // vsc: we need to look into this + return iswhite(c); +} +#endif + +static int +fiscsym(wint_t chr) +{ return iswalnum(chr) || chr == '_'; +} + + +static int +fiscsymf(wint_t chr) +{ return iswalpha(chr) || chr == '_'; +} + +static int +iseof(wint_t chr) +{ return chr == (wint_t)-1; +} + +static int +iseol(wint_t chr) +{ return chr >= 10 && chr <= 13; +} + +static int +isnl(wint_t chr) +{ return chr == '\n'; +} + +static int +isperiod(wint_t chr) +{ return chr && strchr(".?!", chr) != NULL; +} + +static int +isquote(wint_t chr) +{ return chr && strchr("'`\"", chr) != NULL; +} + +static int +fupper(wint_t chr) +{ return iswlower(chr) ? (int)towupper(chr) : -1; +} + +static int +flower(wint_t chr) +{ return iswupper(chr) ? (int)towlower(chr) : -1; +} + +static int +ftoupper(wint_t chr) +{ return towupper(chr); +} + +static int +ftolower(wint_t chr) +{ return towlower(chr); +} + +static int +fparen(wint_t chr) +{ switch(chr) + { case '(': + return ')'; + case '{': + return '}'; + case '[': + return ']'; + default: + return -1; + } +} + + +static int +rparen(wint_t chr) +{ switch(chr) + { case ')': + return '('; + case '}': + return '{'; + case ']': + return '['; + default: + return -1; + } +} + + +static int +fdigit(wint_t chr) +{ if ( chr <= 0xff && isdigit(chr) ) + return chr - '0'; + return -1; +} + + +static int +rdigit(wint_t d) +{ if ( (int)d >= 0 && d <= 9 ) + return d+'0'; + return -1; +} + + +static int +fxdigit(wint_t chr) +{ if ( chr > 0xff ) + return -1; + if ( isdigit(chr) ) + return chr - '0'; + if ( chr >= 'a' && chr <= 'f' ) + return chr - 'a' + 10; + if ( chr >= 'A' && chr <= 'F' ) + return chr - 'A' + 10; + return -1; +} + + +static int +rxdigit(wint_t d) +{ if ( (int)d >= 0 && d <= 9 ) + return d+'0'; + if ( d >= 10 && d <= 15 ) + return d-10+'a'; + return -1; +} + + + +#define mkfunction(name) \ + static int f ## name(wint_t chr) { return name(chr); } + +mkfunction(iswalnum) +mkfunction(iswalpha) +mkfunction(isascii) +mkfunction(iswcntrl) +mkfunction(iswdigit) +mkfunction(iswgraph) +mkfunction(iswlower) +mkfunction(iswupper) +mkfunction(iswpunct) +mkfunction(iswspace) + +#ifdef __SWI_PROLOG__ + +#define INIT_DEF(Type, Name, Size) \ + static void init_ ## Name (void) {} \ + static const Type Name[] { + +#define ADD_DEF2(Atom, Type) \ + { Atom, Type }, +#define ADD_DEF5(Atom, Type, Reverse, Arity, Ctx) \ + { Atom, Type, Reverse, Arity, Ctx }, + \ +#define END_DEFS(Atom, F) \ + { Atom, F } +} + +#endif + +INIT_DEF(char_type, char_types, 26) +ADD_DEF2(ATOM_alnum, fiswalnum) +ADD_DEF2(ATOM_csym, fiscsym ) +ADD_DEF2(ATOM_csymf, fiscsymf ) +ADD_DEF2(ATOM_ascii, fisascii ) +ADD_DEF2(ATOM_white, iswhite ) +ADD_DEF2(ATOM_cntrl, fiswcntrl ) +ADD_DEF2(ATOM_digit, fiswdigit ) +ADD_DEF2(ATOM_graph, fiswgraph ) +ADD_DEF2(ATOM_lower, fiswlower ) +ADD_DEF2(ATOM_upper, fiswupper ) +ADD_DEF2(ATOM_punct, fiswpunct ) +ADD_DEF2(ATOM_space, fiswspace ) +ADD_DEF2(ATOM_end_of_file,iseof ) +ADD_DEF2(ATOM_end_of_line,iseol ) +ADD_DEF2(ATOM_newline,isnl ) +ADD_DEF2(ATOM_period,isperiod ) +ADD_DEF2(ATOM_quote, isquote ) +ADD_DEF5(ATOM_lower, fupper, flower, 1, CTX_CHAR ) +ADD_DEF5(ATOM_upper, flower, fupper, 1, CTX_CHAR ) +ADD_DEF5(ATOM_to_lower,ftoupper, ftolower, 1, CTX_CHAR ) +ADD_DEF5(ATOM_to_upper,ftolower, ftoupper, 1, CTX_CHAR ) +ADD_DEF5(ATOM_paren, fparen, rparen, 1, CTX_CHAR ) +ADD_DEF5(ATOM_digit, fdigit, rdigit, 1, CTX_CODE ) +ADD_DEF5(ATOM_xdigit,fxdigit, rxdigit, 1, CTX_CODE ) +END_DEFS(NULL_ATOM, NULL) + + +static const char_type * +char_type_by_name(atom_t name, int arity) +{ const char_type *cc; + + for(cc = char_types; cc->name; cc++) + { if ( cc->name == name && cc->arity == arity ) + return cc; + } + + return NULL; +} + + +static int +advanceGen(generator *gen) +{ if ( gen->do_enum & ENUM_CHAR ) + { if ( ++gen->current == 256 ) + fail; + } else + { gen->class++; + if ( !gen->class->name ) + fail; + } + + succeed; +} + + +static int +unify_char_type(term_t type, const char_type *ct, int context, int how) +{ if ( ct->arity == 0 ) + return PL_unify_atom(type, ct->name); + else /*if ( ct->arity == 1 )*/ + { if ( PL_unify_functor(type, PL_new_functor(ct->name, 1)) ) + { term_t a = PL_new_term_ref(); + + _PL_get_arg(1, type, a); + + if ( ct->ctx_type == CTX_CHAR ) + return PL_unify_char(a, context, how); + else + return PL_unify_integer(a, context); + } + } + + fail; +} + + +static foreign_t +do_char_type(term_t chr, term_t class, control_t h, int how) +{ generator *gen; + fid_t fid; + + switch( ForeignControl(h) ) + { case FRG_FIRST_CALL: + { const char_type *cc = NULL; + int c; + int do_enum = ENUM_NONE; + atom_t cn; + int arity; + + if ( PL_is_variable(chr) ) + do_enum |= ENUM_CHAR; + if ( PL_is_variable(class) ) + do_enum |= ENUM_CLASS; + + if ( do_enum == ENUM_BOTH ) + return PL_error("char_type", 2, NULL, ERR_INSTANTIATION); + + if ( !(do_enum & ENUM_CHAR) ) + { if ( !PL_get_char(chr, &c, TRUE) ) + fail; + if ( c == -1 ) + return PL_unify_atom(class, ATOM_end_of_file); + } + + if ( !(do_enum & ENUM_CLASS) ) + { if ( !PL_get_name_arity(class, &cn, &arity) || + !(cc = char_type_by_name(cn, arity)) ) + return PL_error("char_type", 2, NULL, + ERR_TYPE, ATOM_char_type, class); + } + + if ( do_enum == ENUM_NONE ) + { if ( arity == 0 ) + return (*cc->test)((wint_t)c) ? TRUE : FALSE; + else + { int rval = (*cc->test)((wint_t)c); + + if ( rval >= 0 ) + { term_t a = PL_new_term_ref(); + int ok; + + _PL_get_arg(1, class, a); + + if ( cc->ctx_type == CTX_CHAR ) + ok = PL_unify_char(a, rval, how); + else + ok = PL_unify_integer(a, rval); + + if ( ok ) + return TRUE; + else + do_enum = ENUM_CHAR; /* try the other way around */ + } else + fail; + } + } + + if ( do_enum == ENUM_CHAR && arity == 1 ) + { term_t a = PL_new_term_ref(); /* char_type(X, lower('A')) */ + int ca; + + _PL_get_arg(1, class, a); + if ( !PL_is_variable(a) ) + { if ( PL_get_char(a, &ca, FALSE) ) + { int c = (*cc->reverse)((wint_t)ca); + + if ( c < 0 ) + fail; + + return PL_unify_char(chr, c, how); + } + fail; /* error */ + } + } + + gen = allocHeap(sizeof(*gen)); + gen->do_enum = do_enum; + + if ( do_enum & ENUM_CHAR ) + { gen->class = cc; + gen->current = -1; + } else if ( do_enum & ENUM_CLASS ) + { gen->class = char_types; + gen->current = c; + } + + break; + } + case FRG_REDO: + gen = ForeignContextPtr(h); + break; + case FRG_CUTTED: + gen = ForeignContextPtr(h); + if ( gen ) + freeHeap(gen, sizeof(*gen)); + default: + succeed; + } + + fid = PL_open_foreign_frame(); + for(;;) + { int rval; + + if ( (rval = (*gen->class->test)((wint_t)gen->current)) ) + { if ( gen->do_enum & ENUM_CHAR ) + { if ( !PL_unify_char(chr, gen->current, how) ) + goto next; + } + if ( gen->class->arity > 0 ) + { if ( rval < 0 || + !unify_char_type(class, gen->class, rval, how) ) + goto next; + + } else if ( gen->do_enum & ENUM_CLASS ) + { if ( !unify_char_type(class, gen->class, rval, how) ) + goto next; + } + + if ( advanceGen(gen) ) /* ok, found one */ + ForeignRedoPtr(gen); + else + { freeHeap(gen, sizeof(*gen)); /* the only one */ + succeed; + } + } + next: + PL_rewind_foreign_frame(fid); + + if ( !advanceGen(gen) ) + break; + } + + freeHeap(gen, sizeof(*gen)); + fail; +} + + + +static +PRED_IMPL("char_type", 2, char_type, PL_FA_NONDETERMINISTIC) +{ return do_char_type(A1, A2, PL__ctx, CHAR_MODE); +} + + +static +PRED_IMPL("code_type", 2, code_type, PL_FA_NONDETERMINISTIC) +{ return do_char_type(A1, A2, PL__ctx, CODE_MODE); +} + + +#if 0 +static +PRED_IMPL("iswctype", 2, iswctype, 0) +{ char *s; + int chr; + wctype_t t; + + if ( !PL_get_char_ex(A1, &chr, FALSE) || + !PL_get_chars_ex(A2, &s, CVT_ATOM) ) + return FALSE; + + if ( !(t=wctype(s)) ) + return PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_type, A2); + + return iswctype(chr, t) ? TRUE : FALSE; +} +#endif + + +static int +init_tout(PL_chars_t *t, size_t len) +{ switch(t->encoding) + { case ENC_ISO_LATIN_1: + if ( len < sizeof(t->buf) ) + { t->text.t = t->buf; + t->storage = PL_CHARS_LOCAL; + } else + { t->text.t = PL_malloc(len); + t->storage = PL_CHARS_MALLOC; + } + succeed; + case ENC_WCHAR: + if ( len*sizeof(pl_wchar_t) < sizeof(t->buf) ) + { t->text.w = (pl_wchar_t*)t->buf; + t->storage = PL_CHARS_LOCAL; + } else + { t->text.w = PL_malloc(len*sizeof(pl_wchar_t)); + t->storage = PL_CHARS_MALLOC; + } + succeed; + default: + assert(0); + fail; + } +} + + +static inline wint_t +get_chr_from_text(const PL_chars_t *t, size_t index) +{ switch(t->encoding) + { case ENC_ISO_LATIN_1: + return t->text.t[index]&0xff; + case ENC_WCHAR: + return t->text.w[index]; + default: + assert(0); + return 0; + } +} + + +static foreign_t +modify_case_atom(term_t in, term_t out, int down) +{ PL_chars_t tin, tout; + + if ( !PL_get_text(in, &tin, CVT_ATOMIC|CVT_EXCEPTION) ) + return FALSE; + + if ( PL_get_text(out, &tout, CVT_ATOMIC) ) + { unsigned int i; + + if ( tin.length != tout.length ) + fail; + + for(i=0; i 255 ) + { PL_promote_text(&tout); + for( ; i 255 ) + { PL_promote_text(&tout); + for( ; i + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Note: on some installations, locale doesn't work correctly. Printing a +message isn't really cute. It would be better to use printMessage(), but +the system isn't yet initialised far enough. Maybe we should store the +failure and print a message at the end of the initialisation? + +We only return FALSE if LC_CTYPE fails. This is a serious indication +that locale support is broken. We don't depend too much on the others, +so we ignore possible problems. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static int +initLocale() +{ int rc = TRUE; + + if ( !setlocale(LC_CTYPE, "") ) + { rc = FALSE; + DEBUG(0, Sdprintf("Failed to set LC_CTYPE locale\n")); + } + if ( !setlocale(LC_TIME, "") ) + { DEBUG(0, Sdprintf("Failed to set LC_TIME locale\n")); + } + if ( !setlocale(LC_COLLATE, "") ) + { DEBUG(0, Sdprintf("Failed to set LC_COLLATE locale\n")); + } + + return rc; +} + +typedef struct +{ int category; + const char *name; +} lccat; + +static lccat lccats[] = +{ { LC_ALL, "all" }, + { LC_COLLATE, "collate" }, + { LC_CTYPE, "ctype" }, +#ifdef LC_MESSAGES + { LC_MESSAGES, "messages" }, +#endif + { LC_MONETARY, "monetary" }, + { LC_NUMERIC, "numeric" }, + { LC_TIME, "time" }, + { 0, NULL } +}; + + +static +PRED_IMPL("setlocale", 3, setlocale, 0) +{ char *what; + char *locale; + const lccat *lcp; + + + if ( !PL_get_chars_ex(A1, &what, CVT_ATOM) ) + fail; + if ( PL_is_variable(A3) ) + locale = NULL; + else if ( !PL_get_chars_ex(A3, &locale, CVT_ATOM) ) + fail; + + for ( lcp = lccats; lcp->name; lcp++ ) + { if ( streq(lcp->name, what) ) + { char *old = setlocale(lcp->category, NULL); + + if ( !PL_unify_chars(A2, PL_ATOM, -1, old) ) + fail; + + if ( PL_compare(A2, A3) != 0 ) + { if ( !setlocale(lcp->category, locale) ) + return PL_error(NULL, 0, MSG_ERRNO, ERR_SYSCALL, "setlocale"); + } + + succeed; + } + } + + return PL_error(NULL, 0, NULL, ERR_DOMAIN, + PL_new_atom("category"), A1); +} + +#else + +#define initLocale() 1 + +static +PRED_IMPL("setlocale", 3, setlocale, 0) +{ return notImplemented("setlocale", 3); +} + +#endif + + + /******************************* + * PUBLISH PREDICATES * + *******************************/ + +BeginPredDefs(ctype) + PRED_DEF("char_type", 2, char_type, PL_FA_NONDETERMINISTIC) + PRED_DEF("code_type", 2, code_type, PL_FA_NONDETERMINISTIC) + PRED_DEF("setlocale", 3, setlocale, 0) + PRED_DEF("downcase_atom", 2, downcase_atom, 0) + PRED_DEF("upcase_atom", 2, upcase_atom, 0) + PRED_DEF("normalize_space", 2, normalize_space, 0) +EndPredDefs + + + /******************************* + * PROLOG CHARACTERS * + *******************************/ + +const char _PL_char_types[] = { +/* ^@ ^A ^B ^C ^D ^E ^F ^G ^H ^I ^J ^K ^L ^M ^N ^O 0-15 */ + CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, +/* ^P ^Q ^R ^S ^T ^U ^V ^W ^X ^Y ^Z ^[ ^\ ^] ^^ ^_ 16-31 */ + CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, +/* sp ! " # $ % & ' ( ) * + , - . / 32-47 */ + SP, SO, DQ, SY, SY, SO, SY, SQ, PU, PU, SY, SY, PU, SY, SY, SY, +/* 0 1 2 3 4 5 6 7 8 9 : ; < = > ? 48-63 */ + DI, DI, DI, DI, DI, DI, DI, DI, DI, DI, SY, SO, SY, SY, SY, SY, +/* @ A B C D E F G H I J K L M N O 64-79 */ + SY, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, +/* P Q R S T U V W X Y Z [ \ ] ^ _ 80-95 */ + UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, PU, SY, PU, SY, UC, +/* ` a b c d e f g h i j k l m n o 96-111 */ + SY, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, +/* p q r s t u v w x y z { | } ~ ^? 112-127 */ + LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, PU, PU, PU, SY, CT, + /* 128-159 (C1 controls) */ + CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, + CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, CT, + /* 160-255 (G1 graphics) */ + /* ISO Latin 1 is assumed */ + SP, SO, SO, SO, SO, SO, SO, SO, SO, SO, LC, SO, SO, SO, SO, SO, + SO, SO, SO, SO, SO, SO, SO, SO, SO, SO, LC, SO, SO, SO, SO, SO, + UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, + UC, UC, UC, UC, UC, UC, UC, SO, UC, UC, UC, UC, UC, UC, UC, LC, + LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, + LC, LC, LC, LC, LC, LC, LC, SO, LC, LC, LC, LC, LC, LC, LC, LC +}; + + +typedef struct +{ const char *name; + IOENC encoding; +} enc_map; + +static const enc_map map[] = +{ { "UTF-8", ENC_UTF8 }, + { "utf8", ENC_UTF8 }, + { "ISO8859-1", ENC_ISO_LATIN_1 }, + { "ISO8859_1", ENC_ISO_LATIN_1 }, + { "iso88591", ENC_ISO_LATIN_1 }, + { "iso_8859_1", ENC_ISO_LATIN_1 }, + { NULL, ENC_UNKNOWN } +}; + +static IOENC +initEncoding(void) +{ if ( LD ) + { if ( !LD->encoding ) + { char *enc; + + if ( !initLocale() ) + { LD->encoding = ENC_ISO_LATIN_1; + } else if ( (enc = setlocale(LC_CTYPE, NULL)) ) + { LD->encoding = ENC_ANSI; /* text encoding */ + + if ( (enc = strchr(enc, '.')) ) + { const enc_map *m; + enc++; /* skip '.' */ + + for ( m=map; m->name; m++ ) + { if ( strcmp(enc, m->name) == 0 ) + { LD->encoding = m->encoding; + break; + } + } + } + } else + { LD->encoding = ENC_ISO_LATIN_1; + } + } + + return LD->encoding; + } + + return ENC_ANSI; +} + + +void +initCharTypes(void) +{ + init_char_types(); + initEncoding(); +} + +#if __SWI_PROLOG__ +bool +systemMode(bool accept) +{ bool old = SYSTEM_MODE ? TRUE : FALSE; + + if ( accept ) + debugstatus.styleCheck |= DOLLAR_STYLE; + else + debugstatus.styleCheck &= ~DOLLAR_STYLE; + + return old; +} + +#endif diff --git a/LGPL/PLStream/pl-ctype.h b/LGPL/PLStream/pl-ctype.h new file mode 100644 index 000000000..a259b6c48 --- /dev/null +++ b/LGPL/PLStream/pl-ctype.h @@ -0,0 +1,82 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: jan@swi.psy.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2002, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +extern const char _PL_char_types[]; /* array of character types */ + +#define CT 0 /* control-character */ +#define SP 1 /* space */ +#define SO 2 /* solo character */ +#define SY 3 /* symbol character */ +#define PU 4 /* Punctuation character */ +#define DQ 5 /* Double quote */ +#define SQ 6 /* Single quote */ +#define BQ 7 /* Back quote */ +#define UC 8 /* Uppercase character */ +#define LC 9 /* Lowercase character */ +#define DI 10 /* Digit */ + +#define isControl(c) (_PL_char_types[(unsigned)(c) & 0xff] == CT) +#define isBlank(c) (_PL_char_types[(unsigned)(c) & 0xff] <= SP) +#define isDigit(c) (_PL_char_types[(unsigned)(c) & 0xff] == DI) +#define isLower(c) (_PL_char_types[(unsigned)(c) & 0xff] == LC) +#define isUpper(c) (_PL_char_types[(unsigned)(c) & 0xff] == UC) +#define isSymbol(c) (_PL_char_types[(unsigned)(c) & 0xff] == SY) +#define isPunct(c) (_PL_char_types[(unsigned)(c) & 0xff] == PU) +#define isSolo(c) (_PL_char_types[(unsigned)(c) & 0xff] == SO) +#define isAlpha(c) (_PL_char_types[(unsigned)(c) & 0xff] >= UC) +#define isLetter(c) (isLower(c) || isUpper(c)) + +#define toLower(c) ((c) + 'a' - 'A') +#define makeLower(c) ((c) >= 'A' && (c) <= 'Z' ? toLower(c) : (c)) + +#define matchingBracket(c) ((c) == '[' ? ']' :\ + '{' ? '}' :\ + '(' ? ')' : EOS) +#define Control(c) ((c) == '?' ? 127 : (c) - '@') + + + /******************************* + * WIDE CHARACTER SUPPORT * + *******************************/ + +#include +#include + +#define PlCharType(c, t, w) \ + ((unsigned)(c) <= 0xff ? (_PL_char_types[(unsigned char)(c)] t) : w) + +#define isControlW(c) PlCharType(c, == CT, iswcntrl((wint_t)c)) +#define isBlankW(c) PlCharType(c, <= SP, iswspace((wint_t)c)) +#define isDigitW(c) PlCharType(c, == DI, FALSE) +#define isLowerW(c) PlCharType(c, == LC, iswlower((wint_t)c)) +#define isUpperW(c) PlCharType(c, == UC, iswupper((wint_t)c)) +#define isSymbolW(c) PlCharType(c, == SY, FALSE) +#define isPunctW(c) PlCharType(c, == PU, FALSE) +#define isSoloW(c) PlCharType(c, == SO, FALSE) +#define isAlphaW(c) PlCharType(c, >= UC, iswalnum((wint_t)c)) +#define isLetterW(c) (PlCharType(c, == LC, iswalpha((wint_t)c)) || \ + PlCharType(c, == UC, FALSE)) + +#define toLowerW(c) ((unsigned)(c) <= 'Z' ? (c) + 'a' - 'A' : towlower(c)) +#define makeLowerW(c) ((c) >= 'A' && (c) <= 'Z' ? toLower(c) : towlower(c)) diff --git a/LGPL/PLStream/pl-error.c b/LGPL/PLStream/pl-error.c new file mode 100644 index 000000000..d49aa8163 --- /dev/null +++ b/LGPL/PLStream/pl-error.c @@ -0,0 +1,180 @@ +#include "pl-incl.h" + +void outOfCore(void) {} +void fatalError(const char *fm, ...) {exit(1);} +void printMessage(int type, ...) {} + + /******************************* + * ERROR-CHECKING *_get() * + *******************************/ + +int +PL_get_nchars_ex(term_t t, size_t *len, char **s, unsigned int flags) +{ return PL_get_nchars(t, len, s, flags|CVT_EXCEPTION); +} + + +int +PL_get_chars_ex(term_t t, char **s, unsigned int flags) +{ return PL_get_nchars(t, NULL, s, flags|CVT_EXCEPTION); +} + + +int +PL_get_atom_ex(term_t t, atom_t *a) +{ if ( PL_get_atom(t, a) ) + succeed; + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, t); +} + + +int +PL_get_integer_ex(term_t t, int *i) +{ if ( PL_get_integer(t, i) ) + succeed; + + if ( PL_is_integer(t) ) + return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_int); + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t); +} + + +int +PL_get_long_ex(term_t t, long *i) +{ if ( PL_get_long(t, i) ) + succeed; + + if ( PL_is_integer(t) ) + return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_long); + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t); +} + + +int +PL_get_int64_ex(term_t t, int64_t *i) +{ if ( PL_get_int64(t, i) ) + succeed; + + if ( PL_is_integer(t) ) + return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_int64_t); + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t); +} + + +int +PL_get_intptr_ex(term_t t, intptr_t *i) +{ +#if SIZEOF_LONG != SIZEOF_VOIDP && SIZEOF_VOIDP == 8 + return PL_get_int64_ex(t, i); +#else + return PL_get_long_ex(t, (long*)i); +#endif +} + + +int +PL_get_bool_ex(term_t t, int *i) +{ if ( PL_get_bool(t, i) ) + succeed; + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_bool, t); +} + + +int +PL_get_float_ex(term_t t, double *f) +{ if ( PL_get_float(t, f) ) + succeed; + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_float, t); +} + + +int +PL_get_char_ex(term_t t, int *p, int eof) +{ if ( PL_get_char(t, p, eof) ) + succeed; + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_character, t); +} + + +int +PL_unify_list_ex(term_t l, term_t h, term_t t) +{ if ( PL_unify_list(l, h, t) ) + succeed; + + if ( PL_get_nil(l) ) + fail; + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l); +} + + +int +PL_unify_nil_ex(term_t l) +{ if ( PL_unify_nil(l) ) + succeed; + + if ( PL_is_list(l) ) + fail; + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l); +} + + +int +PL_get_list_ex(term_t l, term_t h, term_t t) +{ if ( PL_get_list(l, h, t) ) + succeed; + + if ( PL_get_nil(l) ) + fail; + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l); +} + +int +PL_get_nil_ex(term_t l) +{ if ( PL_get_nil(l) ) + succeed; + + if ( PL_is_list(l) ) + fail; + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l); +} + + +int +PL_get_module_ex(term_t name, module_t *m) +{ if ( !PL_get_module(name, m) ) + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, name); + + succeed; +} + +int +PL_unify_bool_ex(term_t t, bool val) +{ bool v; + + if ( PL_is_variable(t) ) + return PL_unify_atom(t, val ? ATOM_true : ATOM_false); + if ( PL_get_bool(t, &v) ) + { if ( (!val && !v) || (val && v) ) + succeed; + fail; + } + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_bool, t); +} + +word +notImplemented(char *name, int arity) +{ return (word)PL_error(NULL, 0, NULL, ERR_NOT_IMPLEMENTED_PROC, name, arity); +} + diff --git a/LGPL/PLStream/pl-error.h b/LGPL/PLStream/pl-error.h new file mode 100644 index 000000000..8b3f675a4 --- /dev/null +++ b/LGPL/PLStream/pl-error.h @@ -0,0 +1,66 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: jan@swi.psy.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2002, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +#define ERR_NO_ERROR 0 +#define ERR_INSTANTIATION 1 /* void */ +#define ERR_TYPE 2 /* atom_t expected, term_t value */ +#define ERR_DOMAIN 3 /* atom_t domain, term_t value */ +#define ERR_REPRESENTATION 4 /* atom_t what */ +#define ERR_MODIFY_STATIC_PROC 5 /* predicate_t proc */ +#define ERR_EVALUATION 6 /* atom_t what */ +#define ERR_AR_TYPE 7 /* atom_t expected, Number value */ +#define ERR_NOT_EVALUABLE 8 /* functor_t func */ +#define ERR_DIV_BY_ZERO 9 /* void */ +#define ERR_FAILED 10 /* predicate_t proc */ +#define ERR_FILE_OPERATION 11 /* atom_t action, atom_t type, term_t */ +#define ERR_PERMISSION 12 /* atom_t type, atom_t op, term_t obj*/ +#define ERR_NOT_IMPLEMENTED_FEATURE 13 /* const char *what */ +#define ERR_EXISTENCE 14 /* atom_t type, term_t obj */ +#define ERR_STREAM_OP 15 /* atom_t action, term_t obj */ +#define ERR_RESOURCE 16 /* atom_t resource */ +#define ERR_NOMEM 17 /* void */ +#define ERR_SYSCALL 18 /* void */ +#define ERR_SHELL_FAILED 19 /* term_t command */ +#define ERR_SHELL_SIGNALLED 20 /* term_t command, int signal */ +#define ERR_AR_UNDEF 21 /* void */ +#define ERR_AR_OVERFLOW 22 /* void */ +#define ERR_AR_UNDERFLOW 23 /* void */ +#define ERR_UNDEFINED_PROC 24 /* Definition def */ +#define ERR_SIGNALLED 25 /* int sig, char *name */ +#define ERR_CLOSED_STREAM 26 /* IOSTREAM * */ +#define ERR_BUSY 27 /* mutexes */ +#define ERR_PERMISSION_PROC 28 /* op, type, Definition */ +#define ERR_DDE_OP 29 /* op, error */ +#define ERR_SYNTAX 30 /* what */ +#define ERR_SHARED_OBJECT_OP 31 /* op, error */ +#define ERR_TIMEOUT 32 /* op, object */ +#define ERR_NOT_IMPLEMENTED_PROC 33 /* name, arity */ +#define ERR_FORMAT 34 /* message */ +#define ERR_FORMAT_ARG 35 /* seq, term */ +#define ERR_OCCURS_CHECK 36 /* Word, Word */ +#define ERR_CHARS_TYPE 37 /* char *, term */ +#define ERR_MUST_BE_VAR 38 /* int argn, term_t term */ + +#define MSG_ERRNO ((char *)(-1)) + diff --git a/LGPL/PLStream/pl-feature.c b/LGPL/PLStream/pl-feature.c new file mode 100644 index 000000000..c0ebc08fe --- /dev/null +++ b/LGPL/PLStream/pl-feature.c @@ -0,0 +1,10 @@ +int defFeature(const char *c, int f, ...) { +/**** add extra flags to engine: nowadays PL_set_prolog_flag */ + return 0; +} + +int trueFeature(int f) { +/**** define whether the feature is set or not */ + return 0; +} + diff --git a/LGPL/PLStream/pl-file.c b/LGPL/PLStream/pl-file.c new file mode 100644 index 000000000..b27d26b79 --- /dev/null +++ b/LGPL/PLStream/pl-file.c @@ -0,0 +1,4768 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: wielemak@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2008, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +This module is far too big. It defines a layer around open(), etc. to +get opening and closing of files to the symbolic level required for +Prolog. It also defines basic I/O predicates, stream based I/O and +finally a bundle of operations on files, such as name expansion, +renaming, deleting, etc. Most of this module is rather straightforward. + +If time is there I will have a look at all this to clean it. Notably +handling times must be cleaned, but that not only holds for this module. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/*#define O_DEBUG 1*/ +/*#define O_DEBUG_MT 1*/ + +#define EXPERIMENT 1 + +#include "pl-incl.h" +#include "pl-ctype.h" +#include "pl-utf8.h" +#include + +#ifdef HAVE_SYS_SELECT_H +#include +#endif +#ifdef HAVE_SYS_TIME_H +#include +#endif +#ifdef HAVE_SYS_PARAM_H +#include +#endif +#ifdef HAVE_SYS_FILE_H +#include +#endif +#ifdef HAVE_SYS_STAT_H +#include +#endif +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#ifdef HAVE_SYS_FILE_H +#include +#endif +#ifdef HAVE_UNISTD_H +#include +#endif +#ifdef HAVE_BSTRING_H +#include +#endif + +#define LOCK() PL_LOCK(L_FILE) /* MT locking */ +#define UNLOCK() PL_UNLOCK(L_FILE) + +static int bad_encoding(atom_t name); + +static bool streamStatus(IOSTREAM *s); + +INIT_DEF(atom_t, standardStreams, 6) + ADD_STDSTREAM(ATOM_user_input) /* 0 */ + ADD_STDSTREAM(ATOM_user_output) /* 1 */ + ADD_STDSTREAM(ATOM_user_error) /* 2 */ + ADD_STDSTREAM(ATOM_current_input) /* 3 */ + ADD_STDSTREAM(ATOM_current_output) /* 4 */ + ADD_STDSTREAM(ATOM_protocol) /* 5 */ +END_STDSTREAMS(NULL_ATOM) + + + +static int +standardStreamIndexFromName(atom_t name) +{ const atom_t *ap; + + for(ap=standardStreams; *ap; ap++) + { if ( *ap == name ) + return (int)(ap - standardStreams); + } + + return -1; +} + + +static int +standardStreamIndexFromStream(IOSTREAM *s) +{ GET_LD + IOSTREAM **sp = LD->IO.streams; + int i = 0; + + for( ; i<6; i++, sp++ ) + { if ( *sp == s ) + return i; + } + + return -1; +} + + + /******************************* + * BOOKKEEPING * + *******************************/ + +static void aliasStream(IOSTREAM *s, atom_t alias); +static void unaliasStream(IOSTREAM *s, atom_t name); + +static Table streamAliases; /* alias --> stream */ +static Table streamContext; /* stream --> extra data */ + +typedef struct _alias +{ struct _alias *next; + atom_t name; +} alias; + + +#define IO_TELL 0x001 /* opened by tell/1 */ +#define IO_SEE 0x002 /* opened by see/1 */ + +typedef struct +{ alias *alias_head; + alias *alias_tail; + atom_t filename; /* associated filename */ + unsigned flags; +} stream_context; + + +static stream_context * +getStreamContext(IOSTREAM *s) +{ Symbol symb; + + if ( !(symb = lookupHTable(streamContext, s)) ) + { GET_LD + stream_context *ctx = allocHeap(sizeof(*ctx)); + + DEBUG(1, Sdprintf("Created ctx=%p for stream %p\n", ctx, s)); + + ctx->alias_head = ctx->alias_tail = NULL; + ctx->filename = NULL_ATOM; + ctx->flags = 0; + addHTable(streamContext, s, ctx); + + return ctx; + } + + return symb->value; +} + + +void +aliasStream(IOSTREAM *s, atom_t name) +{ GET_LD + stream_context *ctx; + Symbol symb; + alias *a; + + /* ensure name is free (error?) */ + if ( (symb = lookupHTable(streamAliases, (void *)name)) ) + unaliasStream(symb->value, name); + + ctx = getStreamContext(s); + addHTable(streamAliases, (void *)name, s); + PL_register_atom(name); + + a = allocHeap(sizeof(*a)); + a->next = NULL; + a->name = name; + + if ( ctx->alias_tail ) + { ctx->alias_tail->next = a; + ctx->alias_tail = a; + } else + { ctx->alias_head = ctx->alias_tail = a; + } +} + +/* MT: Locked by freeStream() +*/ + +static void +unaliasStream(IOSTREAM *s, atom_t name) +{ GET_LD + Symbol symb; + + if ( name ) + { if ( (symb = lookupHTable(streamAliases, (void *)name)) ) + { deleteSymbolHTable(streamAliases, symb); + + if ( (symb=lookupHTable(streamContext, s)) ) + { stream_context *ctx = symb->value; + alias **a; + + for(a = &ctx->alias_head; *a; a = &(*a)->next) + { if ( (*a)->name == name ) + { alias *tmp = *a; + + *a = tmp->next; + freeHeap(tmp, sizeof(*tmp)); + if ( tmp == ctx->alias_tail ) + ctx->alias_tail = NULL; + + break; + } + } + } + + PL_unregister_atom(name); + } + } else /* delete them all */ + { if ( (symb=lookupHTable(streamContext, s)) ) + { stream_context *ctx = symb->value; + alias *a, *n; + + for(a = ctx->alias_head; a; a=n) + { Symbol s2; + + n = a->next; + + if ( (s2 = lookupHTable(streamAliases, (void *)a->name)) ) + { deleteSymbolHTable(streamAliases, s2); + PL_unregister_atom(a->name); + } + + freeHeap(a, sizeof(*a)); + } + + ctx->alias_head = ctx->alias_tail = NULL; + } + } +} + + +static void +freeStream(IOSTREAM *s) +{ GET_LD + Symbol symb; + int i; + IOSTREAM **sp; + + DEBUG(1, Sdprintf("freeStream(%p)\n", s)); + + LOCK(); + unaliasStream(s, NULL_ATOM); + if ( (symb=lookupHTable(streamContext, s)) ) + { stream_context *ctx = symb->value; + + if ( ctx->filename == source_file_name ) + { source_file_name = NULL_ATOM; /* TBD: pop? */ + source_line_no = -1; + } + + freeHeap(ctx, sizeof(*ctx)); + deleteSymbolHTable(streamContext, symb); + } + /* if we are a standard stream */ + /* reassociate with standard I/O */ + /* NOTE: there may be more! */ + for(i=0, sp = LD->IO.streams; i<6; i++, sp++) + { if ( *sp == s ) + { if ( s->flags & SIO_INPUT ) + *sp = Sinput; + else if ( sp == &Suser_error ) + *sp = Serror; + else if ( sp == &Sprotocol ) + *sp = NULL; + else + *sp = Soutput; + } + } + UNLOCK(); +} + + +/* MT: locked by caller (openStream()) */ + +static void +setFileNameStream(IOSTREAM *s, atom_t name) +{ getStreamContext(s)->filename = name; +} + + +static atom_t +fileNameStream(IOSTREAM *s) +{ atom_t name; + + LOCK(); + name = getStreamContext(s)->filename; + UNLOCK(); + + return name; +} + + + /******************************* + * GET HANDLES * + *******************************/ + +#ifdef O_PLMT + +static inline IOSTREAM * +getStream(IOSTREAM *s) +{ if ( s && s->magic == SIO_MAGIC ) /* TBD: ensure visibility? */ + { Slock(s); + return s; + } + + return NULL; +} + +static inline IOSTREAM * +tryGetStream(IOSTREAM *s) +{ if ( s && s->magic == SIO_MAGIC && StryLock(s) == 0 ) + return s; + + return NULL; +} + +static inline void +releaseStream(IOSTREAM *s) +{ if ( s->magic == SIO_MAGIC ) + Sunlock(s); +} + +#else /*O_PLMT*/ + +#define getStream(s) (s) +#define tryGetStream(s) (s) +#define releaseStream(s) + +#endif /*O_PLMT*/ + +int +PL_release_stream(IOSTREAM *s) +{ if ( Sferror(s) ) + return streamStatus(s); + + releaseStream(s); + return TRUE; +} + + +#define SH_ERRORS 0x01 /* generate errors */ +#define SH_ALIAS 0x02 /* allow alias */ +#define SH_UNLOCKED 0x04 /* don't lock the stream */ +#define SH_SAFE 0x08 /* Lookup in table */ + +static int +get_stream_handle__LD(term_t t, IOSTREAM **s, int flags ARG_LD) +{ atom_t alias; + + if ( PL_is_functor(t, FUNCTOR_dstream1) ) + { void *p; + term_t a = PL_new_term_ref(); + + _PL_get_arg(1, t, a); + if ( PL_get_pointer(a, &p) ) + { if ( flags & SH_SAFE ) + { Symbol symb; + + LOCK(); + symb = lookupHTable(streamContext, p); + UNLOCK(); + + if ( !symb ) + goto noent; + } + + if ( flags & SH_UNLOCKED ) + { if ( ((IOSTREAM *)p)->magic == SIO_MAGIC ) + { *s = p; + return TRUE; + } + goto noent; + } + + if ( (*s = getStream(p)) ) + return TRUE; + + goto noent; + } + } else if ( PL_get_atom(t, &alias) ) + { Symbol symb; + + if ( !(flags & SH_UNLOCKED) ) + LOCK(); + if ( (symb=lookupHTable(streamAliases, (void *)alias)) ) + { IOSTREAM *stream; + uintptr_t n = (uintptr_t)symb->value; + + if ( n < 6 ) /* standard stream! */ + { stream = LD->IO.streams[n]; + } else + stream = symb->value; + + if ( !(flags & SH_UNLOCKED) ) + UNLOCK(); + + if ( stream ) + { if ( (flags & SH_UNLOCKED) ) + { if ( stream->magic == SIO_MAGIC ) + { *s = stream; + return TRUE; + } + } else if ( (*s = getStream(stream)) ) + return TRUE; + goto noent; + } + } + if ( !(flags & SH_UNLOCKED) ) + UNLOCK(); + + goto noent; + } + + if ( flags & SH_ERRORS ) + return PL_error(NULL, 0, NULL, ERR_DOMAIN, + (flags&SH_ALIAS) ? ATOM_stream_or_alias : ATOM_stream, t); + + fail; + +noent: + if ( flags & SH_ERRORS ) + PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_stream, t); + fail; +} + +#define get_stream_handle(t, sp, flags) \ + get_stream_handle__LD(t, sp, flags PASS_LD) + +int +PL_get_stream_handle(term_t t, IOSTREAM **s) +{ GET_LD + return get_stream_handle(t, s, SH_ERRORS|SH_ALIAS); +} + + +int +PL_unify_stream_or_alias(term_t t, IOSTREAM *s) +{ GET_LD + int rval; + stream_context *ctx; + int i; + + if ( (i=standardStreamIndexFromStream(s)) >= 0 && i < 3 ) + return PL_unify_atom(t, standardStreams[i]); + + LOCK(); + ctx = getStreamContext(s); + if ( ctx->alias_head ) + { rval = PL_unify_atom(t, ctx->alias_head->name); + } else + { term_t a = PL_new_term_ref(); + + PL_put_pointer(a, s); + PL_cons_functor(a, FUNCTOR_dstream1, a); + + rval = PL_unify(t, a); + } + UNLOCK(); + + return rval; +} + + +int +PL_unify_stream(term_t t, IOSTREAM *s) +{ GET_LD + stream_context *ctx; + term_t a = PL_new_term_ref(); + + LOCK(); + ctx = getStreamContext(s); + UNLOCK(); + + PL_put_pointer(a, s); + PL_cons_functor(a, FUNCTOR_dstream1, a); + + if ( PL_unify(t, a) ) + succeed; + if ( PL_is_functor(t, FUNCTOR_dstream1) ) + fail; + + return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_stream, t); +} + + +bool /* old FLI name (compatibility) */ +PL_open_stream(term_t handle, IOSTREAM *s) +{ return PL_unify_stream(handle, s); +} + + +IOSTREAM ** /* provide access to Suser_input, */ +_PL_streams(void) /* Suser_output and Suser_error */ +{ GET_LD + return &Suser_input; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +getInputStream(term_t t, IOSTREAM **s) +getOutputStream(term_t t, IOSTREAM **s) + These functions are the basis used by all Prolog predicates to get + a input or output stream handle. If t = 0, current input/output is + returned. This allows us to define the standard-stream based version + simply by calling the explicit stream-based version with 0 for the + stream argument. + + MT: The returned stream is always locked and should be returned + using releaseStream() or streamStatus(). +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +static bool +getOutputStream(term_t t, IOSTREAM **stream) +{ GET_LD + atom_t a; + IOSTREAM *s; + + if ( t == 0 ) + { *stream = getStream(Scurout); + return TRUE; + } else if ( PL_get_atom(t, &a) && a == ATOM_user ) + { *stream = getStream(Suser_output); + return TRUE; + } else + { *stream = NULL; /* make compiler happy */ + } + + if ( !PL_get_stream_handle(t, &s) ) + fail; + + if ( !(s->flags &SIO_OUTPUT) ) + { releaseStream(s); + return PL_error(NULL, 0, NULL, ERR_PERMISSION, + ATOM_output, ATOM_stream, t); + } + + *stream = s; + succeed; +} + + +static bool +getInputStream__LD(term_t t, IOSTREAM **stream ARG_LD) +{ atom_t a; + IOSTREAM *s; + + if ( t == 0 ) + { *stream = getStream(Scurin); + return TRUE; + } else if ( PL_get_atom(t, &a) && a == ATOM_user ) + { *stream = getStream(Suser_input); + return TRUE; + } else + { *stream = NULL; /* make compiler happy */ + } + + if ( !get_stream_handle(t, &s, SH_ERRORS|SH_ALIAS) ) + fail; + + if ( !(s->flags &SIO_INPUT) ) + { releaseStream(s); + return PL_error(NULL, 0, NULL, ERR_PERMISSION, + ATOM_input, ATOM_stream, t); + } + + *stream = s; + succeed; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +In windows GUI applications, the IO-streams are not bound. We do not +wish to generate an error on the stream errors that may be caused by +this. It is a bit of a hack, but the alternative is to define a stream +that ignores the error. This might get hairy if the user is playing with +these streams too. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#ifdef __WINDOWS__ +static int +isConsoleStream(IOSTREAM *s) +{ int i = standardStreamIndexFromStream(s); + + return i >= 0 && i < 3; +} +#else +#define isConsoleStream(s) FALSE +#endif + + +static bool +reportStreamError(IOSTREAM *s) +{ if ( GD->cleaning == CLN_NORMAL && + !isConsoleStream(s) && + (s->flags & (SIO_FERR|SIO_WARN)) ) + { GET_LD + atom_t op; + term_t stream = PL_new_term_ref(); + char *msg; + + PL_unify_stream_or_alias(stream, s); + + if ( (s->flags & SIO_FERR) ) + { if ( s->exception ) + { fid_t fid = PL_open_foreign_frame(); + term_t ex = PL_new_term_ref(); + PL_recorded(s->exception, ex); + PL_erase(s->exception); + s->exception = NULL; + PL_raise_exception(ex); + PL_close_foreign_frame(fid); + fail; + } + + if ( s->flags & SIO_INPUT ) + { if ( Sfpasteof(s) ) + { return PL_error(NULL, 0, NULL, ERR_PERMISSION, + ATOM_input, ATOM_past_end_of_stream, stream); + } else if ( (s->flags & SIO_TIMEOUT) ) + { PL_error(NULL, 0, NULL, ERR_TIMEOUT, + ATOM_read, stream); + Sclearerr(s); + fail; + } else + op = ATOM_read; + } else + op = ATOM_write; + + msg = s->message ? s->message : MSG_ERRNO; + + PL_error(NULL, 0, msg, ERR_STREAM_OP, op, stream); + + if ( (s->flags & SIO_CLEARERR) ) + Sseterr(s, SIO_FERR, NULL); + + fail; + } else + { printMessage(ATOM_warning, + PL_FUNCTOR_CHARS, "io_warning", 2, + PL_TERM, stream, + PL_CHARS, s->message); + + Sseterr(s, SIO_WARN, NULL); + } + } + + succeed; +} + + +bool +streamStatus(IOSTREAM *s) +{ if ( (s->flags & (SIO_FERR|SIO_WARN)) ) + { releaseStream(s); + return reportStreamError(s); + } + + releaseStream(s); + succeed; +} + + + /******************************* + * TTY MODES * + *******************************/ + +ttybuf ttytab; /* saved terminal status on entry */ +int ttymode; /* Current tty mode */ + +typedef struct input_context * InputContext; +typedef struct output_context * OutputContext; + +struct input_context +{ IOSTREAM * stream; /* pushed input */ + atom_t term_file; /* old term_position file */ + int term_line; /* old term_position line */ + InputContext previous; /* previous context */ +}; + + +struct output_context +{ IOSTREAM * stream; /* pushed output */ + OutputContext previous; /* previous context */ +}; + +#define input_context_stack (LD->IO.input_stack) +#define output_context_stack (LD->IO.output_stack) + +static IOSTREAM *openStream(term_t file, term_t mode, term_t options); + +void +dieIO(void) +{ if ( GD->io_initialised ) + { pl_noprotocol(); + closeFiles(TRUE); + PopTty(Sinput, &ttytab); + } +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +closeStream() performs Prolog-level closing. Most important right now is +to to avoid closing the user-streams. If a stream cannot be flushed (due +to a write-error), an exception is generated. + +MT: We assume the stream is locked and will unlock it here. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static bool +closeStream(IOSTREAM *s) +{ if ( s == Sinput ) + { Sclearerr(s); + releaseStream(s); + } else if ( s == Soutput || s == Serror ) + { if ( Sflush(s) < 0 ) + return streamStatus(s); + releaseStream(s); + } else + { if ( !Sferror(s) && Sflush(s) < 0 ) + { streamStatus(s); + Sclose(s); + return FALSE; + } + if ( Sclose(s) < 0 ) /* will unlock as well */ + fail; + } + + succeed; +} + + +void +closeFiles(int all) +{ GET_LD + TableEnum e; + Symbol symb; + + e = newTableEnum(streamContext); + while( (symb=advanceTableEnum(e)) ) + { IOSTREAM *s = symb->name; + + if ( all || !(s->flags & SIO_NOCLOSE) ) + { IOSTREAM *s2 = tryGetStream(s); + + if ( s2 ) + { if ( !all ) + { term_t t = PL_new_term_ref(); + + PL_unify_stream_or_alias(t, s2); + printMessage(ATOM_informational, + PL_FUNCTOR, FUNCTOR_close_on_abort1, + PL_TERM, t); + PL_reset_term_refs(t); + } + + closeStream(s2); + } + } + } + freeTableEnum(e); +} + + +void +PL_cleanup_fork(void) +{ TableEnum e; + Symbol symb; + + e = newTableEnum(streamContext); + while( (symb=advanceTableEnum(e)) ) + { IOSTREAM *s = symb->name; + int fd; + + if ( (fd=Sfileno(s)) >= 3 ) + close(fd); + } + freeTableEnum(e); + + stopItimer(); +} + + +void +protocol(const char *str, size_t n) +{ GET_LD + IOSTREAM *s; + + if ( LD && (s = getStream(Sprotocol)) ) + { while( n-- > 0 ) + Sputcode(*str++&0xff, s); + Sflush(s); + releaseStream(s); /* we don not check errors */ + } +} + + + /******************************* + * TEMPORARY I/O * + *******************************/ + + +static word +pl_push_input_context(void) +{ GET_LD + InputContext c = allocHeap(sizeof(struct input_context)); + + c->stream = Scurin; + c->term_file = source_file_name; + c->term_line = source_line_no; + c->previous = input_context_stack; + input_context_stack = c; + + succeed; +} + + +static word +pl_pop_input_context(void) +{ GET_LD + InputContext c = input_context_stack; + + if ( c ) + { Scurin = c->stream; + source_file_name = c->term_file; + source_line_no = c->term_line; + input_context_stack = c->previous; + freeHeap(c, sizeof(struct input_context)); + + succeed; + } else + { Scurin = Sinput; + fail; + } +} + + +static void +pushOutputContext(void) +{ GET_LD + OutputContext c = allocHeap(sizeof(struct output_context)); + + c->stream = Scurout; + c->previous = output_context_stack; + output_context_stack = c; +} + + +static void +popOutputContext(void) +{ GET_LD + OutputContext c = output_context_stack; + + if ( c ) + { if ( c->stream->magic == SIO_MAGIC ) + Scurout = c->stream; + else + { Sdprintf("Oops, current stream closed?"); + Scurout = Soutput; + } + output_context_stack = c->previous; + freeHeap(c, sizeof(struct output_context)); + } else + Scurout = Soutput; +} + + +int +setupOutputRedirect(term_t to, redir_context *ctx, int redir) +{ GET_LD + atom_t a; + + ctx->term = to; + ctx->redirected = redir; + + if ( to == 0 ) + { ctx->stream = getStream(Scurout); + ctx->is_stream = TRUE; + } else if ( PL_get_atom(to, &a) && a == ATOM_user ) + { ctx->stream = getStream(Suser_output); + ctx->is_stream = TRUE; + } else if ( get_stream_handle(to, &ctx->stream, SH_SAFE) ) + { if ( !(ctx->stream->flags &SIO_OUTPUT) ) + { releaseStream(ctx->stream); + return PL_error(NULL, 0, NULL, ERR_PERMISSION, + ATOM_output, ATOM_stream, to); + } + + ctx->is_stream = TRUE; + } else + { if ( PL_is_functor(to, FUNCTOR_codes2) ) + { ctx->out_format = PL_CODE_LIST; + ctx->out_arity = 2; + } else if ( PL_is_functor(to, FUNCTOR_codes1) ) + { ctx->out_format = PL_CODE_LIST; + ctx->out_arity = 1; + } else if ( PL_is_functor(to, FUNCTOR_chars2) ) + { ctx->out_format = PL_CHAR_LIST; + ctx->out_arity = 2; + } else if ( PL_is_functor(to, FUNCTOR_chars1) ) + { ctx->out_format = PL_CHAR_LIST; + ctx->out_arity = 1; + } else if ( PL_is_functor(to, FUNCTOR_string1) ) + { ctx->out_format = PL_STRING; + ctx->out_arity = 1; + } else if ( PL_is_functor(to, FUNCTOR_atom1) ) + { ctx->out_format = PL_ATOM; + ctx->out_arity = 1; + } else + { return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_output, to); + } + + ctx->is_stream = FALSE; + ctx->data = ctx->buffer; + ctx->size = sizeof(ctx->buffer); + ctx->stream = Sopenmem(&ctx->data, &ctx->size, "w"); + ctx->stream->encoding = ENC_WCHAR; + } + + ctx->magic = REDIR_MAGIC; + + if ( redir ) + { pushOutputContext(); + Scurout = ctx->stream; + } + + succeed; +} + + +int +closeOutputRedirect(redir_context *ctx) +{ int rval = TRUE; + + if ( ctx->magic != REDIR_MAGIC ) + return rval; /* already done */ + ctx->magic = 0; + + if ( ctx->redirected ) + popOutputContext(); + + if ( ctx->is_stream ) + { rval = streamStatus(ctx->stream); + } else + { GET_LD + term_t out = PL_new_term_ref(); + term_t diff, tail; + + closeStream(ctx->stream); + _PL_get_arg(1, ctx->term, out); + if ( ctx->out_arity == 2 ) + { diff = PL_new_term_ref(); + _PL_get_arg(2, ctx->term, diff); + tail = PL_new_term_ref(); + } else + { diff = tail = 0; + } + + rval = PL_unify_wchars_diff(out, tail, ctx->out_format, + ctx->size/sizeof(wchar_t), + (wchar_t*)ctx->data); + if ( tail ) + rval = PL_unify(tail, diff); + + if ( ctx->data != ctx->buffer ) + free(ctx->data); + } + + return rval; +} + + +void +discardOutputRedirect(redir_context *ctx) +{ if ( ctx->magic != REDIR_MAGIC ) + return; /* already done */ + + ctx->magic = 0; + + if ( ctx->redirected ) + popOutputContext(); + + if ( ctx->is_stream ) + { releaseStream(ctx->stream); + } else + { closeStream(ctx->stream); + if ( ctx->data != ctx->buffer ) + free(ctx->data); + } +} + + +static +PRED_IMPL("with_output_to", 2, with_output_to, PL_FA_TRANSPARENT) +{ redir_context outctx; + + if ( setupOutputRedirect(A1, &outctx, TRUE) ) + { term_t ex = 0; + int rval; + + if ( (rval = callProlog(NULL, A2, PL_Q_CATCH_EXCEPTION, &ex)) ) + return closeOutputRedirect(&outctx); + discardOutputRedirect(&outctx); + if ( ex ) + return PL_raise_exception(ex); + } + + fail; +} + + + +void +PL_write_prompt(int dowrite) +{ GET_LD + IOSTREAM *s = getStream(Suser_output); + + if ( s ) + { if ( dowrite ) + { atom_t a = PrologPrompt(); + + if ( a ) + writeAtomToStream(s, a); + } + + Sflush(s); + releaseStream(s); + } + + LD->prompt.next = FALSE; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Get a single character from Sinput without waiting for a return. The +character should not be echoed. If TTY_CONTROL_FEATURE is false this +function will read the first character and then skip all character upto +and including the newline. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static int +Sgetcode_intr(IOSTREAM *s, int signals) +{ int c; + +#ifdef __WINDOWS__ + int newline = s->newline; + s->newline = SIO_NL_POSIX; /* avoid blocking \r */ +#endif + do + { Sclearerr(s); + c = Sgetcode(s); + } while ( c == -1 && + errno == EINTR && + (!signals || PL_handle_signals() >= 0) + ); +#ifdef __WINDOWS__ + s->newline = newline; +#endif + + return c; +} + + +static int +getSingleChar(IOSTREAM *stream, int signals) +{ GET_LD + int c; + ttybuf buf; + + // debugstatus.suspendTrace++; WARNING: suspendTrace + Slock(stream); + Sflush(stream); + PushTty(stream, &buf, TTY_RAW); /* just donot prompt */ + + if ( !trueFeature(TTY_CONTROL_FEATURE) ) + { int c2; + + c2 = Sgetcode_intr(stream, signals); + while( c2 == ' ' || c2 == '\t' ) /* skip blanks */ + c2 = Sgetcode_intr(stream, signals); + c = c2; + while( c2 != EOF && c2 != '\n' ) /* read upto newline */ + c2 = Sgetcode_intr(stream, signals); + } else + { if ( stream->position ) + { IOPOS oldpos = *stream->position; + c = Sgetcode_intr(stream, signals); + *stream->position = oldpos; + } else + c = Sgetcode_intr(stream, signals); + } + + if ( c == 4 || c == 26 ) /* should ask the terminal! */ + c = -1; + + PopTty(stream, &buf); + // debugstatus.suspendTrace--; WARNING: suspendTrace + Sunlock(stream); + + return c; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +readLine() reads a line from the terminal. It is used only by the tracer. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#ifndef DEL +#define DEL 127 +#endif + +bool +readLine(IOSTREAM *in, IOSTREAM *out, char *buffer) +{ GET_LD + int c; + char *buf = &buffer[strlen(buffer)]; + ttybuf tbuf; + + Slock(in); + Slock(out); + + PushTty(in, &tbuf, TTY_RAW); /* just donot prompt */ + + for(;;) + { Sflush(out); + + switch( (c=Sgetc(in)) ) + { case '\n': + case '\r': + case EOF: + *buf++ = EOS; + PopTty(in, &tbuf); + Sunlock(in); + Sunlock(out); + + return c == EOF ? FALSE : TRUE; + case '\b': + case DEL: + if ( trueFeature(TTY_CONTROL_FEATURE) && buf > buffer ) + { Sfputs("\b \b", out); + buf--; + } + default: + if ( trueFeature(TTY_CONTROL_FEATURE) ) + Sputc(c, out); + *buf++ = c; + } + } +} + + +IOSTREAM * +PL_current_input() +{ GET_LD + return getStream(Scurin); +} + + +IOSTREAM * +PL_current_output() +{ GET_LD + return getStream(Scurout); +} + + +static word +openProtocol(term_t f, bool appnd) +{ GET_LD + IOSTREAM *s; + term_t mode = PL_new_term_ref(); + + pl_noprotocol(); + + PL_put_atom(mode, appnd ? ATOM_append : ATOM_write); + if ( (s = openStream(f, mode, 0)) ) + { s->flags |= SIO_NOCLOSE; /* do not close on abort */ + + Sprotocol = s; + Suser_input->tee = s; + Suser_output->tee = s; + Suser_error->tee = s; + + return TRUE; + } + + return FALSE; +} + + +word +pl_noprotocol(void) +{ GET_LD + IOSTREAM *s; + + if ( (s = getStream(Sprotocol)) ) + { TableEnum e; + Symbol symb; + + e = newTableEnum(streamContext); + while( (symb=advanceTableEnum(e)) ) + { IOSTREAM *p = symb->name; + + if ( p->tee == s ) + p->tee = NULL; + } + freeTableEnum(e); + + closeStream(s); + Sprotocol = NULL; + } + + succeed; +} + + + /******************************* + * STREAM ATTRIBUTES * + *******************************/ + + +static foreign_t +pl_set_stream(term_t stream, term_t attr) +{ GET_LD + IOSTREAM *s; + atom_t aname; + int arity; + + if ( !PL_get_stream_handle(stream, &s) ) + fail; + + if ( PL_get_name_arity(attr, &aname, &arity) ) + { if ( arity == 1 ) + { term_t a = PL_new_term_ref(); + + _PL_get_arg(1, attr, a); + + if ( aname == ATOM_alias ) /* alias(name) */ + { atom_t alias; + int i; + + if ( !PL_get_atom_ex(a, &alias) ) + goto error; + + if ( (i=standardStreamIndexFromName(alias)) >= 0 ) + { LD->IO.streams[i] = s; + if ( i == 0 ) + LD->prompt.next = TRUE; /* changed standard input: prompt! */ + goto ok; + } + + LOCK(); + aliasStream(s, alias); + UNLOCK(); + goto ok; + } else if ( aname == ATOM_buffer ) /* buffer(Buffering) */ + { atom_t b; + +#define SIO_ABUF (SIO_FBUF|SIO_LBUF|SIO_NBUF) + if ( !PL_get_atom_ex(a, &b) ) + goto error; + if ( b == ATOM_full ) + { s->flags &= ~SIO_ABUF; + s->flags |= SIO_FBUF; + } else if ( b == ATOM_line ) + { s->flags &= ~SIO_ABUF; + s->flags |= SIO_LBUF; + } else if ( b == ATOM_false ) + { Sflush(s); + s->flags &= ~SIO_ABUF; + s->flags |= SIO_NBUF; + } else + { PL_error("set_stream", 2, NULL, ERR_DOMAIN, + ATOM_buffer, a); + goto error; + } + goto ok; + } else if ( aname == ATOM_buffer_size ) + { int size; + + if ( !PL_get_integer_ex(a, &size) ) + goto error; + if ( size < 1 ) + { PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_one, a); + goto error; + } + Ssetbuffer(s, NULL, size); + goto ok; + } else if ( aname == ATOM_eof_action ) /* eof_action(Action) */ + { atom_t action; + + if ( !PL_get_atom_ex(a, &action) ) + fail; + if ( action == ATOM_eof_code ) + { s->flags &= ~(SIO_NOFEOF|SIO_FEOF2ERR); + } else if ( action == ATOM_reset ) + { s->flags &= ~SIO_FEOF2ERR; + s->flags |= SIO_NOFEOF; + } else if ( action == ATOM_error ) + { s->flags &= ~SIO_NOFEOF; + s->flags |= SIO_FEOF2ERR; + } else + { PL_error("set_stream", 2, NULL, ERR_DOMAIN, + ATOM_eof_action, a); + goto error; + } + + goto ok; + } else if ( aname == ATOM_close_on_abort ) /* close_on_abort(Bool) */ + { int close; + + if ( !PL_get_bool_ex(a, &close) ) + goto error; + + if ( close ) + s->flags &= ~SIO_NOCLOSE; + else + s->flags |= SIO_NOCLOSE; + + goto ok; + } else if ( aname == ATOM_record_position ) + { int rec; + + if ( !PL_get_bool_ex(a, &rec) ) + goto error; + + if ( rec ) + s->position = &s->posbuf; + else + s->position = NULL; + + goto ok; + } else if ( aname == ATOM_file_name ) /* file_name(Atom) */ + { atom_t fn; + + if ( !PL_get_atom_ex(a, &fn) ) + goto error; + + LOCK(); + setFileNameStream(s, fn); + UNLOCK(); + + goto ok; + } else if ( aname == ATOM_timeout ) + { double f; + atom_t v; + + if ( PL_get_atom(a, &v) && v == ATOM_infinite ) + { s->timeout = -1; + goto ok; + } + if ( !PL_get_float_ex(a, &f) ) + goto error; + + s->timeout = (int)(f*1000.0); + if ( s->timeout < 0 ) + s->timeout = 0; + goto ok; + } else if ( aname == ATOM_tty ) /* tty(bool) */ + { int val; + + if ( !PL_get_bool_ex(a, &val) ) + goto error; + + if ( val ) + set(s, SIO_ISATTY); + else + clear(s, SIO_ISATTY); + + goto ok; + } else if ( aname == ATOM_encoding ) /* encoding(atom) */ + { atom_t val; + IOENC enc; + + if ( !PL_get_atom_ex(a, &val) ) + goto error; + if ( (enc = atom_to_encoding(val)) == ENC_UNKNOWN ) + { bad_encoding(val); + goto error; + } + + if ( Ssetenc(s, enc, NULL) == 0 ) + goto ok; + + PL_error(NULL, 0, NULL, ERR_PERMISSION, + ATOM_encoding, ATOM_stream, stream); + goto error; + } else if ( aname == ATOM_representation_errors ) + { atom_t val; + + if ( !PL_get_atom_ex(a, &val) ) + goto error; + clear(s, SIO_REPXML|SIO_REPPL); + if ( val == ATOM_error ) + ; + else if ( val == ATOM_xml ) + set(s, SIO_REPXML); + else if ( val == ATOM_prolog ) + set(s, SIO_REPPL); + else + { PL_error(NULL, 0, NULL, ERR_DOMAIN, + ATOM_representation_errors, a); + goto error; + } + goto ok; + } else if ( aname == ATOM_newline ) + { atom_t val; + + if ( !PL_get_atom_ex(a, &val) ) + goto error; + if ( val == ATOM_posix ) + s->newline = SIO_NL_POSIX; + else if ( val == ATOM_dos ) + s->newline = SIO_NL_DOS; + else if ( val == ATOM_detect ) + { if ( false(s, SIO_INPUT) ) + { PL_error(NULL, 0, "detect only allowed for input streams", + ERR_DOMAIN, ATOM_newline, a); + goto error; + } + s->newline = SIO_NL_DETECT; + } else + { PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_newline, a); + goto error; + } + goto ok; + } + } + } + + PL_error("set_stream", 2, NULL, ERR_TYPE, + PL_new_atom("stream_attribute"), attr); + goto error; + +ok: + releaseStream(s); + succeed; +error: + releaseStream(s); + fail; +} + + + /******************************** + * STRING I/O * + *********************************/ + +extern IOFUNCTIONS Smemfunctions; + +bool +tellString(char **s, size_t *size, IOENC enc) +{ GET_LD + IOSTREAM *stream; + + stream = Sopenmem(s, size, "w"); + stream->encoding = enc; + pushOutputContext(); + Scurout = stream; + + return TRUE; +} + + +bool +toldString(void) +{ GET_LD + IOSTREAM *s = getStream(Scurout); + + if ( !s ) + succeed; + + if ( s->functions == &Smemfunctions ) + { closeStream(s); + popOutputContext(); + } else + releaseStream(s); + + succeed; +} + + + /******************************** + * WAITING FOR INPUT * + ********************************/ + +#ifndef HAVE_SELECT + +word +pl_wait_for_input(term_t streams, term_t available, + term_t timeout) +{ GET_LD + return notImplemented("wait_for_input", 3); +} + +#else + +typedef struct fdentry +{ int fd; + term_t stream; + struct fdentry *next; +} fdentry; + + +static inline term_t +findmap(fdentry *map, int fd) +{ for( ; map; map = map->next ) + { if ( map->fd == fd ) + return map->stream; + } + assert(0); + return 0; +} + + +static word +pl_wait_for_input(term_t Streams, term_t Available, + term_t timeout) +{ GET_LD + fd_set fds; + struct timeval t, *to; + double time; + int n, max = 0, ret, min = 1 << (INTBITSIZE-2); + fdentry *map = NULL; + term_t head = PL_new_term_ref(); + term_t streams = PL_copy_term_ref(Streams); + term_t available = PL_copy_term_ref(Available); + term_t ahead = PL_new_term_ref(); + int from_buffer = 0; + atom_t a; + + FD_ZERO(&fds); + while( PL_get_list(streams, head, streams) ) + { IOSTREAM *s; + int fd; + fdentry *e; + + if ( !PL_get_stream_handle(head, &s) ) + fail; + if ( (fd=Sfileno(s)) < 0 ) + { releaseStream(s); + return PL_error("wait_for_input", 3, NULL, ERR_DOMAIN, + PL_new_atom("file_stream"), head); + } + releaseStream(s); + /* check for input in buffer */ + if ( s->bufp < s->limitp ) + { if ( !PL_unify_list(available, ahead, available) || + !PL_unify(ahead, head) ) + fail; + from_buffer++; + } + + e = alloca(sizeof(*e)); + e->fd = fd; + e->stream = PL_copy_term_ref(head); + e->next = map; + map = e; + +#ifdef __WINDOWS__ + FD_SET((SOCKET)fd, &fds); +#else + FD_SET(fd, &fds); +#endif + + if ( fd > max ) + max = fd; + if( fd < min ) + min = fd; + } + if ( !PL_get_nil(streams) ) + return PL_error("wait_for_input", 3, NULL, ERR_TYPE, ATOM_list, Streams); + + if ( from_buffer > 0 ) + return PL_unify_nil(available); + + if ( PL_get_atom(timeout, &a) && a == ATOM_infinite ) + { to = NULL; + } else if ( PL_is_integer(timeout) ) + { long v; + + PL_get_long(timeout, &v); + if ( v > 0L ) + { t.tv_sec = v; + t.tv_usec = 0; + to = &t; + } else if ( v == 0 ) + { to = NULL; + } else + { t.tv_sec = 0; + t.tv_usec = 0; + to = &t; + } + } else + { if ( !PL_get_float(timeout, &time) ) + return PL_error("wait_for_input", 3, NULL, + ERR_TYPE, ATOM_float, timeout); + + if ( time >= 0.0 ) + { t.tv_sec = (int)time; + t.tv_usec = ((int)(time * 1000000) % 1000000); + } else + { t.tv_sec = 0; + t.tv_usec = 0; + } + to = &t; + } + + while( (ret=select(max+1, &fds, NULL, NULL, to)) == -1 && + errno == EINTR ) + { fdentry *e; + + if ( PL_handle_signals() < 0 ) + fail; /* exception */ + + FD_ZERO(&fds); /* EINTR may leave fds undefined */ + for(e=map; e; e=e->next) /* so we rebuild it to be safe */ + { +#ifdef __WINDOWS__ + FD_SET((SOCKET)e->fd, &fds); +#else + FD_SET(e->fd, &fds); +#endif + } + } + + switch(ret) + { case -1: + return PL_error("wait_for_input", 3, MSG_ERRNO, ERR_FILE_OPERATION, + ATOM_select, ATOM_stream, Streams); + + case 0: /* Timeout */ + break; + + default: /* Something happend -> check fds */ + for(n=min; n <= max; n++) + { if ( FD_ISSET(n, &fds) ) + { if ( !PL_unify_list(available, ahead, available) || + !PL_unify(ahead, findmap(map, n)) ) + fail; + } + } + break; + } + + return PL_unify_nil(available); +} + +#endif /* HAVE_SELECT */ + + + /******************************** + * PROLOG CONNECTION * + *********************************/ + +#define MAX_PENDING SIO_BUFSIZE /* 4096 */ + +static void +re_buffer(IOSTREAM *s, const char *from, size_t len) +{ if ( s->bufp < s->limitp ) + { size_t size = s->limitp - s->bufp; + + memmove(s->buffer, s->bufp, size); + s->bufp = s->buffer; + s->limitp = &s->bufp[size]; + } else + { s->bufp = s->limitp = s->buffer; + } + + memcpy(s->bufp, from, len); + s->bufp += len; +} + + +#ifndef HAVE_MBSNRTOWCS +static size_t +mbsnrtowcs(wchar_t *dest, const char **src, + size_t nms, size_t len, mbstate_t *ps) +{ wchar_t c; + const char *us = *src; + const char *es = us+nms; + size_t count = 0; + + assert(dest == NULL); /* incomplete implementation */ + + while(usflags&SIO_TEXT ) + { switch(s->newline) + { case SIO_NL_DETECT: + s->newline = SIO_NL_DOS; + /*FALLTHROUGH*/ + case SIO_NL_DOS: + return TRUE; + } + } + return FALSE; +} + + +static +PRED_IMPL("read_pending_input", 3, read_pending_input, 0) +{ PRED_LD + IOSTREAM *s; + + if ( getInputStream(A1, &s) ) + { char buf[MAX_PENDING]; + ssize_t n; + word gstore, lp; + int64_t off0 = Stell64(s); + IOPOS pos0; + + if ( Sferror(s) ) + return streamStatus(s); + + n = Sread_pending(s, buf, sizeof(buf), 0); + if ( n < 0 ) /* should not happen */ + return streamStatus(s); + if ( n == 0 ) /* end-of-file */ + { S__fcheckpasteeof(s, -1); + return PL_unify(A2, A3); + } + if ( s->position ) + { pos0 = *s->position; + } else + { memset(&pos0, 0, sizeof(pos0)); /* make compiler happy */ + } + + switch(s->encoding) + { case ENC_OCTET: + case ENC_ISO_LATIN_1: + case ENC_ASCII: + { ssize_t i; + lp = gstore = INIT_SEQ_CODES(n); + // lp = gstore = allocGlobal(1+n*3); /* TBD: shift */ + + for(i=0; iposition ) + S__fupdatefilepos_getc(s, c); + + gstore = EXTEND_SEQ_CODES(gstore, c); + } + if ( s->position ) + s->position->byteno = pos0.byteno+n; + + break; + } + case ENC_ANSI: + { size_t count, i; + mbstate_t s0; + const char *us = buf; + const char *es = buf+n; + + if ( !s->mbstate ) + { if ( !(s->mbstate = malloc(sizeof(*s->mbstate))) ) + { PL_error(NULL, 0, NULL, ERR_NOMEM); + goto failure; + } + memset(s->mbstate, 0, sizeof(*s->mbstate)); + } + s0 = *s->mbstate; + count = mbsnrtowcs(NULL, &us, n, 0, &s0); + if ( count == (size_t)-1 ) + { Sseterr(s, SIO_WARN, "Illegal multibyte Sequence"); + goto failure; + } + + DEBUG(2, Sdprintf("Got %ld codes from %d bytes; incomplete: %ld\n", + count, n, es-us)); + + lp = gstore = INIT_SEQ_CODES(count); + + for(us=buf,i=0; imbstate); + if ( c == '\r' && skip_cr(s) ) + continue; + if ( s->position ) + S__fupdatefilepos_getc(s, c); + + gstore = EXTEND_SEQ_CODES(gstore, c); + } + if ( s->position ) + s->position->byteno = pos0.byteno+us-buf; + + re_buffer(s, us, es-us); + break; + } + case ENC_UTF8: + { const char *us = buf; + const char *es = buf+n; + size_t count = 0, i; + + while(usposition ) + S__fupdatefilepos_getc(s, c); + + gstore = EXTEND_SEQ_CODES(gstore, c); + } + if ( s->position ) + s->position->byteno = pos0.byteno+us-buf; + + re_buffer(s, us, es-us); + break; + } + case ENC_UNICODE_BE: + case ENC_UNICODE_LE: + { size_t count = (size_t)n/2; + const char *us = buf; + size_t done, i; + + lp = gstore = INIT_SEQ_CODES(count); + + for(i=0; iencoding == ENC_UNICODE_BE ) + c = ((us[0]&0xff)<<8)+(us[1]&0xff); + else + c = ((us[1]&0xff)<<8)+(us[0]&0xff); + if ( c == '\r' && skip_cr(s) ) + continue; + + if ( s->position ) + S__fupdatefilepos_getc(s, c); + + gstore = EXTEND_SEQ_CODES(gstore, c); + } + + done = count*2; + if ( s->position ) + s->position->byteno = pos0.byteno+done; + re_buffer(s, buf+done, n-done); + break; + } + case ENC_WCHAR: + { const pl_wchar_t *ws = (const pl_wchar_t*)buf; + size_t count = (size_t)n/sizeof(pl_wchar_t); + size_t done, i; + + lp = gstore = INIT_SEQ_CODES(count); + + for(i=0; iposition ) + S__fupdatefilepos_getc(s, c); + + gstore = EXTEND_SEQ_CODES(gstore, c); + } + + done = count*sizeof(pl_wchar_t); + if ( s->position ) + s->position->byteno = pos0.byteno+done; + re_buffer(s, buf+done, n-done); + break; + } + case ENC_UNKNOWN: + default: + assert(0); + fail; + } + + + if (!CLOSE_SEQ_OF_CODES(gstore, lp, A2, A3)) + goto failure; + + releaseStream(s); + succeed; + + failure: + Sseek64(s, off0, SIO_SEEK_SET); /* TBD: error? */ + if ( s->position ) + *s->position = pos0; + releaseStream(s); + fail; + } + + fail; +} + +int +PL_get_char(term_t c, int *p, int eof) +{ GET_LD + int chr; + atom_t name; + PL_chars_t text; + + if ( PL_get_integer(c, &chr) ) + { if ( chr >= 0 ) + { *p = chr; + return TRUE; + } + if ( eof && chr == -1 ) + { *p = chr; + return TRUE; + } + } else if ( PL_get_text(c, &text, CVT_ATOM|CVT_STRING|CVT_LIST) && + text.length == 1 ) + { *p = text.encoding == ENC_ISO_LATIN_1 ? text.text.t[0]&0xff + : text.text.w[0]; + return TRUE; + } else if ( eof && PL_get_atom(c, &name) && name == ATOM_end_of_file ) + { *p = -1; + return TRUE; + } + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_character, c); +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +PL_unify_char(term_t chr, int c, int how) + Unify a character. Try to be as flexible as possible, only binding a + variable `chr' to a code or one-char-atom. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +int +PL_unify_char(term_t chr, int c, int how) +{ GET_LD + int c2 = -1; + + if ( PL_is_variable(chr) ) + { switch(how) + { case CHAR_MODE: + { atom_t a = (c == -1 ? ATOM_end_of_file : codeToAtom(c)); + + return PL_unify_atom(chr, a); + } + case CODE_MODE: + case BYTE_MODE: + default: + return PL_unify_integer(chr, c); + } + } else if ( PL_get_char(chr, &c2, TRUE) ) + return c == c2; + + fail; +} + +static foreign_t +put_byte(term_t stream, term_t byte ARG_LD) +{ IOSTREAM *s; + int c; + + if ( !PL_get_integer(byte, &c) || c < 0 || c > 255 ) + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_byte, byte); + if ( !getOutputStream(stream, &s) ) + fail; + + Sputc(c, s); + + return streamStatus(s); +} + + +static +PRED_IMPL("put_byte", 2, put_byte2, 0) +{ PRED_LD + + return put_byte(A1, A2 PASS_LD); +} + + +static +PRED_IMPL("put_byte", 1, put_byte1, 0) +{ PRED_LD + + return put_byte(0, A1 PASS_LD); +} + + +static foreign_t +put_code(term_t stream, term_t chr ARG_LD) +{ IOSTREAM *s; + int c = 0; + + if ( !PL_get_char(chr, &c, FALSE) ) + fail; + if ( !getOutputStream(stream, &s) ) + fail; + + Sputcode(c, s); + + return streamStatus(s); +} + + +static +PRED_IMPL("put_code", 2, put_code2, 0) +{ PRED_LD + + return put_code(A1, A2 PASS_LD); +} + + +static +PRED_IMPL("put_code", 1, put_code1, 0) +{ PRED_LD + + return put_code(0, A1 PASS_LD); +} + + +static +PRED_IMPL("put", 2, put2, 0) +{ PRED_LD + + return put_code(A1, A2 PASS_LD); +} + + +static +PRED_IMPL("put", 1, put1, 0) +{ PRED_LD + + return put_code(0, A1 PASS_LD); +} + + +static foreign_t +get_nonblank(term_t in, term_t chr ARG_LD) +{ IOSTREAM *s; + + if ( getInputStream(in, &s) ) + { int c; + + for(;;) + { c = Sgetcode(s); + + if ( c == EOF ) + { TRY(PL_unify_integer(chr, -1)); + return streamStatus(s); + } + + if ( !isBlankW(c) ) + { releaseStream(s); + return PL_unify_integer(chr, c); + } + } + } + + fail; +} + + +static +PRED_IMPL("get", 1, get1, 0) +{ PRED_LD + + return get_nonblank(0, A1 PASS_LD); +} + + +static +PRED_IMPL("get", 2, get2, 0) +{ PRED_LD + + return get_nonblank(A1, A2 PASS_LD); +} + + +static foreign_t +skip(term_t in, term_t chr ARG_LD) +{ int c = -1; + int r; + IOSTREAM *s; + + if ( !PL_get_char(chr, &c, FALSE) ) + fail; + if ( !getInputStream(in, &s) ) + fail; + + while((r=Sgetcode(s)) != c && r != EOF ) + ; + + return streamStatus(s); +} + + +static +PRED_IMPL("skip", 1, skip1, 0) +{ PRED_LD + + return skip(0, A1 PASS_LD); +} + + +static +PRED_IMPL("skip", 2, skip2, 0) +{ PRED_LD + + return skip(A1, A2 PASS_LD); +} + + +static word +pl_get_single_char(term_t chr) +{ GET_LD + IOSTREAM *s = getStream(Suser_input); + int c = getSingleChar(s, TRUE); + + if ( c == EOF ) + { PL_unify_integer(chr, -1); + return streamStatus(s); + } + + releaseStream(s); + + return PL_unify_integer(chr, c); +} + + +static foreign_t +pl_get_byte2(term_t in, term_t chr ARG_LD) +{ IOSTREAM *s; + + if ( getInputStream(in, &s) ) + { int c = Sgetc(s); + + if ( PL_unify_integer(chr, c) ) + return streamStatus(s); + + if ( Sferror(s) ) + return streamStatus(s); + + PL_get_char(chr, &c, TRUE); /* set type-error */ + } + + fail; +} + + +static +PRED_IMPL("get_byte", 2, get_byte2, 0) +{ PRED_LD + + return pl_get_byte2(A1, A2 PASS_LD); +} + + +static +PRED_IMPL("get_byte", 1, get_byte1, 0) +{ PRED_LD + + return pl_get_byte2(0, A1 PASS_LD); +} + + +static foreign_t +pl_get_code2(term_t in, term_t chr) +{ GET_LD + IOSTREAM *s; + + if ( getInputStream(in, &s) ) + { int c = Sgetcode(s); + + if ( PL_unify_integer(chr, c) ) + return streamStatus(s); + + if ( Sferror(s) ) + return streamStatus(s); + + PL_get_char(chr, &c, TRUE); /* set type-error */ + releaseStream(s); + } + + fail; +} + + +static +PRED_IMPL("get_code", 2, get_code2, 0) +{ return pl_get_code2(A1, A2); +} + + +static +PRED_IMPL("get_code", 1, get_code1, 0) +{ return pl_get_code2(0, A1); +} + + +static foreign_t +pl_get_char2(term_t in, term_t chr) +{ GET_LD + IOSTREAM *s; + + if ( getInputStream(in, &s) ) + { int c = Sgetcode(s); + + if ( PL_unify_atom(chr, c == -1 ? ATOM_end_of_file : codeToAtom(c)) ) + return streamStatus(s); + + if ( Sferror(s) ) + return streamStatus(s); + + PL_get_char(chr, &c, TRUE); /* set type-error */ + releaseStream(s); + } + + fail; +} + + +static +PRED_IMPL("get_char", 2, get_char2, 0) +{ return pl_get_char2(A1, A2); +} + + +static +PRED_IMPL("get_char", 1, get_char1, 0) +{ return pl_get_char2(0, A1); +} + + +static word +pl_ttyflush(void) +{ GET_LD + IOSTREAM *s = getStream(Suser_output); + + Sflush(s); + + return streamStatus(s); +} + + +static word +pl_protocol(term_t file) +{ return openProtocol(file, FALSE); +} + + +static word +pl_protocola(term_t file) +{ return openProtocol(file, TRUE); +} + + +static word +pl_protocolling(term_t file) +{ GET_LD + IOSTREAM *s; + + if ( (s = Sprotocol) ) + { atom_t a; + + if ( (a = fileNameStream(s)) ) + return PL_unify_atom(file, a); + else + return PL_unify_stream_or_alias(file, s); + } + + fail; +} + + +static word +pl_prompt(term_t old, term_t new) +{ GET_LD + atom_t a; + + if ( PL_unify_atom(old, LD->prompt.current) && + PL_get_atom(new, &a) ) + { if ( LD->prompt.current ) + PL_unregister_atom(LD->prompt.current); + LD->prompt.current = a; + PL_register_atom(a); + succeed; + } + + fail; +} + + +static void +prompt1(atom_t prompt) +{ GET_LD + + if ( LD->prompt.first != prompt ) + { if ( LD->prompt.first ) + PL_unregister_atom(LD->prompt.first); + LD->prompt.first = prompt; + PL_register_atom(LD->prompt.first); + } + + LD->prompt.first_used = FALSE; +} + + +static word +pl_prompt1(term_t prompt) +{ GET_LD + atom_t a; + PL_chars_t txt; + + if ( PL_get_atom(prompt, &a) ) + { prompt1(a); + } else if ( PL_get_text(prompt, &txt, CVT_ALL|CVT_EXCEPTION) ) + { prompt1(textToAtom(&txt)); + } else + fail; + + succeed; +} + + +atom_t +PrologPrompt() +{ GET_LD + + if ( !LD->prompt.first_used && LD->prompt.first ) + { LD->prompt.first_used = TRUE; + + return LD->prompt.first; + } + + if ( Sinput->position && Sinput->position->linepos == 0 ) + return LD->prompt.current; + else + return 0; /* "" */ +} + + +static word +pl_tab2(term_t out, term_t spaces) +{ GET_LD + number n; + int rval = FALSE; + IOSTREAM *s; + + if ( !getOutputStream(out, &s) ) + fail; + + if ( valueExpression(spaces, &n PASS_LD) ) + { if ( toIntegerNumber(&n, 0) ) + { int64_t m; + + switch(n.type) + { case V_INTEGER: + m = n.value.i; + break; +#ifdef O_GMP + case V_MPZ: + { if ( !mpz_to_int64(n.value.mpz, &m) ) + { PL_error(NULL, 0, NULL, ERR_EVALUATION, ATOM_int_overflow); + goto error; + } + } +#endif + default: + assert(0); + } + + while(m-- > 0) + { if ( Sputcode(' ', s) < 0 ) + break; + } + + rval = TRUE; + } + + clearNumber(&n); + } else + { rval = PL_error("tab", 1, NULL, ERR_TYPE, ATOM_integer, spaces); + } + + if ( rval ) + return streamStatus(s); + +#ifdef O_GMP +error: +#endif + (void)streamStatus(s); + fail; +} + +static word +pl_tab(term_t n) +{ return pl_tab2(0, n); +} + + + /******************************* + * ENCODING * + *******************************/ + +typedef struct encname +{ IOENC code; + atom_t name; +} encoding_name; + +INIT_DEF(struct encname, encoding_names, 10) + ADD_ENCODING( ENC_UNKNOWN, ATOM_unknown ) + ADD_ENCODING( ENC_OCTET, ATOM_octet ) + ADD_ENCODING( ENC_ASCII, ATOM_ascii ) + ADD_ENCODING( ENC_ISO_LATIN_1, ATOM_iso_latin_1 ) + ADD_ENCODING( ENC_ANSI, ATOM_text ) + ADD_ENCODING( ENC_UTF8, ATOM_utf8 ) + ADD_ENCODING( ENC_UNICODE_BE, ATOM_unicode_be ) + ADD_ENCODING( ENC_UNICODE_LE, ATOM_unicode_le ) + ADD_ENCODING( ENC_WCHAR, ATOM_wchar_t ) +END_ENCODINGS( ENC_UNKNOWN, 0 ) + + +IOENC +atom_to_encoding(atom_t a) +{ struct encname *en; + + for(en=encoding_names; en->name; en++) + { if ( en->name == a ) + return en->code; + } + + return ENC_UNKNOWN; +} + + +static atom_t +encoding_to_atom(IOENC enc) +{ return encoding_names[enc].name; +} + + +static int +bad_encoding(atom_t name) +{ GET_LD + term_t t = PL_new_term_ref(); + + PL_put_atom(t, name); + return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_encoding, t); +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +fn_to_atom() translates a 8-bit filename into a unicode atom. The +encoding is generic `multibyte' on Unix systems and fixed to UTF-8 on +Windows, where the uxnt layer translates the UTF-8 sequences to the +Windows *W() functions. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static atom_t +fn_to_atom(const char *fn) +{ PL_chars_t text; + atom_t a; + + text.text.t = (char *)fn; + text.encoding = ((REP_FN&REP_UTF8) ? ENC_UTF8 : + (REP_FN&REP_MB) ? ENC_ANSI : ENC_ISO_LATIN_1); + text.storage = PL_CHARS_HEAP; + text.length = strlen(fn); + text.canonical = FALSE; + + a = textToAtom(&text); + PL_free_text(&text); + + return a; +} + + + /******************************** + * STREAM BASED I/O * + *********************************/ + + +INIT_DEF(opt_spec, open4_options, 10) + ADD_OPEN4_OPT( ATOM_type, OPT_ATOM ) + ADD_OPEN4_OPT( ATOM_reposition, OPT_BOOL ) + ADD_OPEN4_OPT( ATOM_alias, OPT_ATOM ) + ADD_OPEN4_OPT( ATOM_eof_action, OPT_ATOM ) + ADD_OPEN4_OPT( ATOM_close_on_abort, OPT_BOOL ) + ADD_OPEN4_OPT( ATOM_buffer, OPT_ATOM ) + ADD_OPEN4_OPT( ATOM_lock, OPT_ATOM ) + ADD_OPEN4_OPT( ATOM_encoding, OPT_ATOM ) + ADD_OPEN4_OPT( ATOM_bom, OPT_BOOL ) +END_OPEN4_DEFS(NULL_ATOM, 0) + + +IOSTREAM * +openStream(term_t file, term_t mode, term_t options) +{ GET_LD + atom_t mname; + atom_t type = ATOM_text; + bool reposition = TRUE; + atom_t alias = NULL_ATOM; + atom_t eof_action = ATOM_eof_code; + atom_t buffer = ATOM_full; + atom_t lock = ATOM_none; + atom_t encoding = NULL_ATOM; + bool close_on_abort = TRUE; + bool bom = -1; + char how[10]; + char *h = how; + char *path; + IOSTREAM *s; + IOENC enc; + + if ( options ) + { if ( ! +scan_options(options, 0, ATOM_stream_option, open4_options, + &type, &reposition, &alias, &eof_action, + &close_on_abort, &buffer, &lock, &encoding, &bom) ) + fail; + } + + /* MODE */ + if ( PL_get_atom(mode, &mname) ) + { if ( mname == ATOM_write ) + { *h++ = 'w'; + } else if ( mname == ATOM_append ) + { bom = FALSE; + *h++ = 'a'; + } else if ( mname == ATOM_update ) + { bom = FALSE; + *h++ = 'u'; + } else if ( mname == ATOM_read ) + { *h++ = 'r'; + } else + { PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_io_mode, mode); + return NULL; + } + } else + { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, mode); + return NULL; + } + + /* ENCODING */ + if ( encoding != NULL_ATOM ) + { enc = atom_to_encoding(encoding); + if ( enc == ENC_UNKNOWN ) + { bad_encoding(encoding); + + return NULL; + } + } else if ( type == ATOM_binary ) + { enc = ENC_OCTET; + bom = FALSE; + } else + { enc = LD->encoding; + } + + if ( bom == -1 ) + bom = (mname == ATOM_read ? TRUE : FALSE); + if ( type == ATOM_binary ) + *h++ = 'b'; + + /* LOCK */ + if ( lock != ATOM_none ) + { *h++ = 'l'; + if ( lock == ATOM_read || lock == ATOM_shared ) + *h++ = 'r'; + else if ( lock == ATOM_write || lock == ATOM_exclusive ) + *h++ = 'w'; + else + { term_t l = PL_new_term_ref(); + PL_put_atom(l, lock); + PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_lock, l); + return NULL; + } + } + + *h = EOS; + + /* FILE */ + if ( PL_get_chars(file, &path, + CVT_ATOM|CVT_STRING|CVT_EXCEPTION|REP_FN) ) + { if ( !(s = Sopen_file(path, how)) ) + { PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION, + ATOM_open, ATOM_source_sink, file); + return NULL; + } + setFileNameStream(s, fn_to_atom(path)); + } +#ifdef HAVE_POPEN + else if ( PL_is_functor(file, FUNCTOR_pipe1) ) + { term_t a = PL_new_term_ref(); + char *cmd; + + PL_get_arg(1, file, a); + if ( !PL_get_chars(a, &cmd, CVT_ATOM|CVT_STRING|REP_FN) ) + { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, a); + return NULL; + } + + if ( !(s = Sopen_pipe(cmd, how)) ) + { PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION, + ATOM_open, ATOM_source_sink, file); + return NULL; + } + } +#endif /*HAVE_POPEN*/ + else + { return NULL; + } + + s->encoding = enc; + if ( !close_on_abort ) + s->flags |= SIO_NOCLOSE; + + if ( how[0] == 'r' ) + { if ( eof_action != ATOM_eof_code ) + { if ( eof_action == ATOM_reset ) + s->flags |= SIO_NOFEOF; + else if ( eof_action == ATOM_error ) + s->flags |= SIO_FEOF2ERR; + } + } else + { if ( buffer != ATOM_full ) + { s->flags &= ~SIO_FBUF; + if ( buffer == ATOM_line ) + s->flags |= SIO_LBUF; + if ( buffer == ATOM_false ) + s->flags |= SIO_NBUF; + } + } + + if ( alias != NULL_ATOM ) + aliasStream(s, alias); + if ( !reposition ) + s->position = NULL; + + if ( bom ) + { if ( mname == ATOM_read ) + { if ( ScheckBOM(s) < 0 ) + { bom_error: + + streamStatus(getStream(s)); + return NULL; + } + } else + { if ( SwriteBOM(s) < 0 ) + goto bom_error; + } + } + + return s; +} + + +static word +pl_open4(term_t file, term_t mode, term_t stream, term_t options) +{ IOSTREAM *s = openStream(file, mode, options); + + if ( s ) + return PL_unify_stream_or_alias(stream, s); + + fail; +} + + +static word +pl_open(term_t file, term_t mode, term_t stream) +{ return pl_open4(file, mode, stream, 0); +} + + /******************************* + * EDINBURGH I/O * + *******************************/ + +static IOSTREAM * +findStreamFromFile(atom_t name, unsigned int flags) +{ TableEnum e; + Symbol symb; + IOSTREAM *s = NULL; + + e = newTableEnum(streamContext); + while( (symb=advanceTableEnum(e)) ) + { stream_context *ctx = symb->value; + + if ( ctx->filename == name && + true(ctx, flags) ) + { s = symb->name; + break; + } + } + freeTableEnum(e); + + return s; +} + + +static word +pl_see(term_t f) +{ GET_LD + IOSTREAM *s; + atom_t a; + term_t mode; + + LOCK(); + if ( get_stream_handle(f, &s, SH_ALIAS|SH_UNLOCKED) ) + { Scurin = s; + goto ok; + } + + if ( PL_get_atom(f, &a) && a == ATOM_user ) + { Scurin = Suser_input; + goto ok; + } + if ( (s = findStreamFromFile(a, IO_SEE)) ) + { Scurin = s; + goto ok; + } + + mode = PL_new_term_ref(); + PL_put_atom(mode, ATOM_read); + if ( !(s = openStream(f, mode, 0)) ) + { UNLOCK(); + fail; + } + + set(getStreamContext(s), IO_SEE); + pl_push_input_context(); + Scurin = s; + +ok: + UNLOCK(); + + succeed; +} + +static word +pl_seeing(term_t f) +{ GET_LD + if ( Scurin == Suser_input ) + return PL_unify_atom(f, ATOM_user); + + return pl_current_input(f); +} + +static word +pl_seen(void) +{ GET_LD + IOSTREAM *s = getStream(Scurin); + + pl_pop_input_context(); + + if ( s->flags & SIO_NOFEOF ) + succeed; + + return closeStream(s); +} + +/* MT: Does not create a lock on the stream +*/ + +static word +do_tell(term_t f, atom_t m) +{ GET_LD + IOSTREAM *s; + atom_t a; + term_t mode; + + LOCK(); + if ( get_stream_handle(f, &s, SH_UNLOCKED) ) + { Scurout = s; + goto ok; + } + + if ( PL_get_atom(f, &a) && a == ATOM_user ) + { Scurout = Suser_output; + goto ok; + } + + if ( (s = findStreamFromFile(a, IO_TELL)) ) + { Scurout = s; + goto ok; + } + + mode = PL_new_term_ref(); + PL_put_atom(mode, m); + if ( !(s = openStream(f, mode, 0)) ) + { UNLOCK(); + fail; + } + + set(getStreamContext(s), IO_TELL); + pushOutputContext(); + Scurout = s; + +ok: + UNLOCK(); + succeed; +} + +static word +pl_tell(term_t f) +{ return do_tell(f, ATOM_write); +} + +static word +pl_append(term_t f) +{ return do_tell(f, ATOM_append); +} + +static word +pl_telling(term_t f) +{ GET_LD + if ( Scurout == Suser_output ) + return PL_unify_atom(f, ATOM_user); + + return pl_current_output(f); +} + +static word +pl_told(void) +{ GET_LD + IOSTREAM *s = getStream(Scurout); + + popOutputContext(); + + if ( s->flags & SIO_NOFEOF ) + succeed; + + return closeStream(s); +} + + /******************************* + * NULL-STREAM * + *******************************/ + +static ssize_t +Swrite_null(void *handle, char *buf, size_t size) +{ return size; +} + + +static ssize_t +Sread_null(void *handle, char *buf, size_t size) +{ return 0; +} + + +static long +Sseek_null(void *handle, long offset, int whence) +{ switch(whence) + { case SIO_SEEK_SET: + return offset; + case SIO_SEEK_CUR: + case SIO_SEEK_END: + default: + return -1; + } +} + + +static int +Sclose_null(void *handle) +{ return 0; +} + + +static const IOFUNCTIONS nullFunctions = +{ Sread_null, + Swrite_null, + Sseek_null, + Sclose_null +}; + + +static word +pl_open_null_stream(term_t stream) +{ int sflags = SIO_NBUF|SIO_RECORDPOS|SIO_OUTPUT; + IOSTREAM *s = Snew((void *)NULL, sflags, (IOFUNCTIONS *)&nullFunctions); + + if ( s ) + { s->encoding = ENC_UTF8; + return PL_unify_stream_or_alias(stream, s); + } + + fail; +} + + +static word +pl_close(term_t stream) +{ IOSTREAM *s; + + if ( PL_get_stream_handle(stream, &s) ) + return closeStream(s); + + fail; +} + + +INIT_DEF(opt_spec, close2_options, 2) + ADD_CLOSE2_OPT( ATOM_force, OPT_BOOL ) +END_CLOSE2_DEFS( NULL_ATOM, 0 ) + + +static word +pl_close2(term_t stream, term_t options) +{ IOSTREAM *s; + bool force = FALSE; + + if ( !scan_options(options, 0, ATOM_close_option, close2_options, &force) ) + fail; + + if ( !force ) + return pl_close(stream); + + if ( !PL_get_stream_handle(stream, &s) ) + fail; + + if ( s == Sinput ) + Sclearerr(s); + else if ( s == Soutput || s == Serror ) + { Sflush(s); + Sclearerr(s); + } else + { Sflush(s); + Sclose(s); + } + + succeed; +} + + + /******************************* + * STREAM-PROPERTY * + *******************************/ + +static int +stream_file_name_propery(IOSTREAM *s, term_t prop ARG_LD) +{ atom_t name; + + if ( (name = getStreamContext(s)->filename) ) + { return PL_unify_atom(prop, name); + } + + fail; +} + + +static int +stream_mode_property(IOSTREAM *s, term_t prop ARG_LD) +{ atom_t mode; + + if ( s->flags & SIO_INPUT ) + mode = ATOM_read; + else + { assert(s->flags & SIO_OUTPUT); + + if ( s->flags & SIO_APPEND ) + mode = ATOM_append; + else if ( s->flags & SIO_UPDATE ) + mode = ATOM_update; + else + mode = ATOM_write; + } + + return PL_unify_atom(prop, mode); +} + + +static int +stream_input_prop(IOSTREAM *s ARG_LD) +{ return (s->flags & SIO_INPUT) ? TRUE : FALSE; +} + + +static int +stream_output_prop(IOSTREAM *s ARG_LD) +{ return (s->flags & SIO_OUTPUT) ? TRUE : FALSE; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Incomplete: should be non-deterministic if the stream has multiple aliases! +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static int +stream_alias_prop(IOSTREAM *s, term_t prop ARG_LD) +{ atom_t name; + stream_context *ctx = getStreamContext(s); + int i; + + if ( PL_get_atom(prop, &name) ) + { alias *a; + + for( a = ctx->alias_head; a; a = a->next ) + { if ( a->name == name ) + return TRUE; + } + + if ( (i=standardStreamIndexFromName(name)) >= 0 && + i < 6 && + s == LD->IO.streams[i] ) + return TRUE; + + return FALSE; + } + + if ( (i=standardStreamIndexFromStream(s)) >= 0 && i < 3 ) + return PL_unify_atom(prop, standardStreams[i]); + if ( ctx->alias_head ) + return PL_unify_atom(prop, ctx->alias_head->name); + + return FALSE; +} + + +static int +stream_position_prop(IOSTREAM *s, term_t prop ARG_LD) +{ if ( s->position ) + { return PL_unify_term(prop, + PL_FUNCTOR, FUNCTOR_stream_position4, + PL_INT64, s->position->charno, + PL_INT, s->position->lineno, + PL_INT, s->position->linepos, + PL_INT64, s->position->byteno); + } + + fail; +} + + +static int +stream_end_of_stream_prop(IOSTREAM *s, term_t prop ARG_LD) +{ if ( s->flags & SIO_INPUT ) + { GET_LD + atom_t val; + + if ( s->flags & SIO_FEOF2 ) + val = ATOM_past; + else if ( s->flags & SIO_FEOF ) + val = ATOM_at; + else + val = ATOM_not; + + return PL_unify_atom(prop, val); + } + + return FALSE; +} + + +static int +stream_eof_action_prop(IOSTREAM *s, term_t prop ARG_LD) +{ atom_t val; + + if ( s->flags & SIO_NOFEOF ) + val = ATOM_reset; + else if ( s->flags & SIO_FEOF2ERR ) + val = ATOM_error; + else + val = ATOM_eof_code; + + return PL_unify_atom(prop, val); +} + + +#ifdef HAVE_FSTAT +#include +#endif + +#if !defined(S_ISREG) && defined(S_IFREG) +#define S_ISREG(m) ((m&S_IFMT) == S_IFREG) +#endif + +static int +stream_reposition_prop(IOSTREAM *s, term_t prop ARG_LD) +{ atom_t val; + + if ( s->functions->seek ) + { +#ifdef HAVE_FSTAT + int fd = Sfileno(s); + struct stat buf; + + if ( fstat(fd, &buf) == 0 && S_ISREG(buf.st_mode) ) + val = ATOM_true; + else + val = ATOM_false; +#else + val = ATOM_true; +#endif + } else + val = ATOM_false; + + return PL_unify_atom(prop, val); +} + + +static int +stream_close_on_abort_prop(IOSTREAM *s, term_t prop ARG_LD) +{ return PL_unify_bool_ex(prop, !(s->flags & SIO_NOCLOSE)); +} + + +static int +stream_type_prop(IOSTREAM *s, term_t prop ARG_LD) +{ return PL_unify_atom(prop, s->flags & SIO_TEXT ? ATOM_text : ATOM_binary); +} + + +static int +stream_file_no_prop(IOSTREAM *s, term_t prop ARG_LD) +{ int fd; + + if ( (fd = Sfileno(s)) >= 0 ) + return PL_unify_integer(prop, fd); + + fail; +} + + +static int +stream_tty_prop(IOSTREAM *s, term_t prop ARG_LD) +{ if ( (s->flags & SIO_ISATTY) ) + return PL_unify_bool_ex(prop, TRUE); + + fail; +} + + +static int +stream_bom_prop(IOSTREAM *s, term_t prop ARG_LD) +{ if ( (s->flags & SIO_BOM) ) + return PL_unify_bool_ex(prop, TRUE); + + fail; +} + + +static int +stream_newline_prop(IOSTREAM *s, term_t prop ARG_LD) +{ switch ( s->newline ) + { case SIO_NL_POSIX: + case SIO_NL_DETECT: + return PL_unify_atom(prop, ATOM_posix); + case SIO_NL_DOS: + return PL_unify_atom(prop, ATOM_dos); + } + + fail; +} + + +static int +stream_encoding_prop(IOSTREAM *s, term_t prop ARG_LD) +{ return PL_unify_atom(prop, encoding_to_atom(s->encoding)); +} + + +static int +stream_reperror_prop(IOSTREAM *s, term_t prop ARG_LD) +{ atom_t a; + + if ( (s->flags & SIO_REPXML) ) + a = ATOM_xml; + else if ( (s->flags & SIO_REPPL) ) + a = ATOM_prolog; + else + a = ATOM_error; + + return PL_unify_atom(prop, a); +} + + +static int +stream_buffer_prop(IOSTREAM *s, term_t prop ARG_LD) +{ atom_t b; + + if ( s->flags & SIO_FBUF ) + b = ATOM_full; + else if ( s->flags & SIO_LBUF ) + b = ATOM_line; + else /*if ( s->flags & SIO_NBUF )*/ + b = ATOM_false; + + return PL_unify_atom(prop, b); +} + + +static int +stream_buffer_size_prop(IOSTREAM *s, term_t prop ARG_LD) +{ if ( (s->flags & SIO_NBUF) ) + fail; + + return PL_unify_integer(prop, s->bufsize); +} + + +static int +stream_timeout_prop(IOSTREAM *s, term_t prop ARG_LD) +{ if ( s->timeout == -1 ) + return PL_unify_atom(prop, ATOM_infinite); + + return PL_unify_float(prop, (double)s->timeout/1000.0); +} + + +typedef struct +{ functor_t functor; /* functor of property */ + int (*function)(); /* function to generate */ +} sprop; + + +INIT_DEF(sprop, sprop_list, 24) + ADD_SPROP( FUNCTOR_file_name1, stream_file_name_propery ) + ADD_SPROP( FUNCTOR_mode1, stream_mode_property ) + ADD_SPROP( FUNCTOR_input0, stream_input_prop ) + ADD_SPROP( FUNCTOR_output0, stream_output_prop ) + ADD_SPROP( FUNCTOR_alias1, stream_alias_prop ) + ADD_SPROP( FUNCTOR_position1, stream_position_prop ) + ADD_SPROP( FUNCTOR_end_of_stream1, stream_end_of_stream_prop ) + ADD_SPROP( FUNCTOR_eof_action1, stream_eof_action_prop ) + ADD_SPROP( FUNCTOR_reposition1, stream_reposition_prop ) + ADD_SPROP( FUNCTOR_type1, stream_type_prop ) + ADD_SPROP( FUNCTOR_file_no1, stream_file_no_prop ) + ADD_SPROP( FUNCTOR_buffer1, stream_buffer_prop ) + ADD_SPROP( FUNCTOR_buffer_size1, stream_buffer_size_prop ) + ADD_SPROP( FUNCTOR_close_on_abort1,stream_close_on_abort_prop ) + ADD_SPROP( FUNCTOR_tty1, stream_tty_prop ) + ADD_SPROP( FUNCTOR_encoding1, stream_encoding_prop ) + ADD_SPROP( FUNCTOR_bom1, stream_bom_prop ) + ADD_SPROP( FUNCTOR_newline1, stream_newline_prop ) + ADD_SPROP( FUNCTOR_representation_errors1, stream_reperror_prop ) + ADD_SPROP( FUNCTOR_timeout1, stream_timeout_prop ) +END_SPROP_DEFS( 0, NULL) + + +typedef struct +{ TableEnum e; /* Enumerator on stream-table */ + IOSTREAM *s; /* Stream we are enumerating */ + const sprop *p; /* Pointer in properties */ + int fixed_p; /* Propety is given */ +} prop_enum; + + +static foreign_t +pl_stream_property(term_t stream, term_t property, control_t h) +{ GET_LD + IOSTREAM *s; + prop_enum *pe; + fid_t fid; + term_t a1; + + switch( ForeignControl(h) ) + { case FRG_FIRST_CALL: + a1 = PL_new_term_ref(); + + if ( PL_is_variable(stream) ) /* generate */ + { const sprop *p = sprop_list; + int fixed = FALSE; + functor_t f; + + if ( PL_get_functor(property, &f) ) /* test for defined property */ + { for( ; p->functor; p++ ) + { if ( f == p->functor ) + { fixed = TRUE; + break; + } + } + if ( !p->functor ) + return PL_error(NULL, 0, NULL, ERR_DOMAIN, + ATOM_stream_property, property); + } + + pe = allocHeap(sizeof(*pe)); + + pe->e = newTableEnum(streamContext); + pe->s = NULL; + pe->p = p; + pe->fixed_p = fixed; + + break; + } + + LOCK(); /* given stream */ + if ( get_stream_handle(stream, &s, SH_ERRORS|SH_UNLOCKED) ) + { functor_t f; + + if ( PL_is_variable(property) ) /* generate properties */ + { pe = allocHeap(sizeof(*pe)); + + pe->e = NULL; + pe->s = s; + pe->p = sprop_list; + pe->fixed_p = FALSE; + UNLOCK(); + + break; + } + + if ( PL_get_functor(property, &f) ) + { const sprop *p = sprop_list; + + for( ; p->functor; p++ ) + { if ( f == p->functor ) + { int rval; + + switch(arityFunctor(f)) + { case 0: + rval = (*p->function)(s PASS_LD); + break; + case 1: + { term_t a1 = PL_new_term_ref(); + + _PL_get_arg(1, property, a1); + rval = (*p->function)(s, a1 PASS_LD); + break; + } + default: + assert(0); + rval = FALSE; + } + UNLOCK(); + return rval; + } + } + } else + { UNLOCK(); + return PL_error(NULL, 0, NULL, ERR_DOMAIN, + ATOM_stream_property, property); + } + } + UNLOCK(); + fail; /* bad stream handle */ + case FRG_REDO: + { pe = ForeignContextPtr(h); + a1 = PL_new_term_ref(); + + break; + } + case FRG_CUTTED: + { pe = ForeignContextPtr(h); + + if ( pe ) /* 0 if exception on FRG_FIRST_CALL */ + { if ( pe->e ) + freeTableEnum(pe->e); + + freeHeap(pe, sizeof(*pe)); + } + succeed; + } + default: + assert(0); + fail; + } + + + fid = PL_open_foreign_frame(); + + for(;;) + { if ( pe->s ) /* given stream */ + { fid_t fid2; + + if ( PL_is_variable(stream) ) + { if ( !PL_unify_stream(stream, pe->s) ) + goto enum_e; + } + + fid2 = PL_open_foreign_frame(); + for( ; pe->p->functor ; pe->p++ ) + { if ( PL_unify_functor(property, pe->p->functor) ) + { int rval; + + switch(arityFunctor(pe->p->functor)) + { case 0: + rval = (*pe->p->function)(pe->s PASS_LD); + break; + case 1: + { _PL_get_arg(1, property, a1); + + rval = (*pe->p->function)(pe->s, a1 PASS_LD); + break; + } + default: + assert(0); + rval = FALSE; + } + if ( rval ) + { if ( pe->fixed_p ) + pe->s = NULL; + else + pe->p++; + ForeignRedoPtr(pe); + } + } + + if ( pe->fixed_p ) + break; + PL_rewind_foreign_frame(fid2); + } + PL_close_foreign_frame(fid2); + pe->s = NULL; + } + + enum_e: + if ( pe->e ) + { Symbol symb; + + while ( (symb=advanceTableEnum(pe->e)) ) + { PL_rewind_foreign_frame(fid); + if ( PL_unify_stream(stream, symb->name) ) + { pe->s = symb->name; + if ( !pe->fixed_p ) + pe->p = sprop_list; + break; + } + } + } + + if ( !pe->s ) + { if ( pe->e ) + freeTableEnum(pe->e); + + freeHeap(pe, sizeof(*pe)); + fail; + } + } +} + + +static +PRED_IMPL("is_stream", 1, is_stream, 0) +{ GET_LD + IOSTREAM *s; + + if ( get_stream_handle(A1, &s, SH_SAFE) ) + { releaseStream(s); + succeed; + } + + fail; +} + + + + /******************************* + * FLUSH * + *******************************/ + + +static word +pl_flush_output1(term_t out) +{ IOSTREAM *s; + + if ( getOutputStream(out, &s) ) + { Sflush(s); + return streamStatus(s); + } + + fail; +} + + +static word +pl_flush_output(void) +{ return pl_flush_output1(0); +} + + +static int +getStreamWithPosition(term_t stream, IOSTREAM **sp) +{ IOSTREAM *s; + + if ( PL_get_stream_handle(stream, &s) ) + { if ( !s->position ) + { PL_error(NULL, 0, NULL, ERR_PERMISSION, /* non-ISO */ + ATOM_property, ATOM_position, stream); + releaseStream(s); + return FALSE; + } + + *sp = s; + return TRUE; + } + + return FALSE; +} + + +static int +getRepositionableStream(term_t stream, IOSTREAM **sp) +{ GET_LD + IOSTREAM *s; + + if ( get_stream_handle(stream, &s, SH_ERRORS) ) + { if ( !s->position || !s->functions || !s->functions->seek ) + { PL_error(NULL, 0, NULL, ERR_PERMISSION, + ATOM_reposition, ATOM_stream, stream); + releaseStream(s); + return FALSE; + } + + *sp = s; + return TRUE; + } + + return FALSE; +} + + +static word +pl_set_stream_position(term_t stream, term_t pos) +{ GET_LD + IOSTREAM *s; + int64_t charno, byteno; + long linepos, lineno; + term_t a = PL_new_term_ref(); + + if ( !(getRepositionableStream(stream, &s)) ) + fail; + + if ( !PL_is_functor(pos, FUNCTOR_stream_position4) || + !PL_get_arg(1, pos, a) || + !PL_get_int64(a, &charno) || + !PL_get_arg(2, pos, a) || + !PL_get_long(a, &lineno) || + !PL_get_arg(3, pos, a) || + !PL_get_long(a, &linepos) || + !PL_get_arg(4, pos, a) || + !PL_get_int64(a, &byteno) ) + { releaseStream(s); + return PL_error("stream_position", 3, NULL, + ERR_DOMAIN, ATOM_stream_position, pos); + } + + if ( Sseek64(s, byteno, SIO_SEEK_SET) != 0 ) + return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION, + ATOM_reposition, ATOM_stream, stream); + + s->position->byteno = byteno; + s->position->charno = charno; + s->position->lineno = (int)lineno; + s->position->linepos = (int)linepos; + + releaseStream(s); + + succeed; +} + + +static word +pl_seek(term_t stream, term_t offset, term_t method, term_t newloc) +{ GET_LD + atom_t m; + int whence = -1; + int64_t off, new; + IOSTREAM *s; + + if ( !(PL_get_atom_ex(method, &m)) ) + return FALSE; + + if ( m == ATOM_bof ) + whence = SIO_SEEK_SET; + else if ( m == ATOM_current ) + whence = SIO_SEEK_CUR; + else if ( m == ATOM_eof ) + whence = SIO_SEEK_END; + else + return PL_error("seek", 4, NULL, ERR_DOMAIN, ATOM_seek_method, method); + + if ( !PL_get_int64(offset, &off) ) + return PL_error("seek", 4, NULL, ERR_DOMAIN, ATOM_integer, offset); + + if ( PL_get_stream_handle(stream, &s) ) + { int unit = Sunit_size(s); + + off *= unit; + if ( Sseek64(s, off, whence) < 0 ) + { if ( errno == EINVAL ) + PL_error("seek", 4, "offset out of range", ERR_DOMAIN, + ATOM_position, offset); + else + PL_error("seek", 4, OsError(), ERR_PERMISSION, + ATOM_reposition, ATOM_stream, stream); + releaseStream(s); + fail; + } + + new = Stell64(s); + releaseStream(s); + new /= unit; + + return PL_unify_int64(newloc, new); + } + + fail; +} + + +static word +pl_set_input(term_t stream) +{ GET_LD + IOSTREAM *s; + + if ( getInputStream(stream, &s) ) + { Scurin = s; + releaseStream(s); + return TRUE; + } + + return FALSE; +} + + +static word +pl_set_output(term_t stream) +{ GET_LD + IOSTREAM *s; + + if ( getOutputStream(stream, &s) ) + { Scurout = s; + releaseStream(s); + return TRUE; + } + + return FALSE; +} + + +word +pl_current_input(term_t stream) +{ GET_LD + return PL_unify_stream(stream, Scurin); +} + + +word +pl_current_output(term_t stream) +{ GET_LD + return PL_unify_stream(stream, Scurout); +} + + +static +PRED_IMPL("byte_count", 2, byte_count, 0) +{ IOSTREAM *s; + + if ( getStreamWithPosition(A1, &s) ) + { int64_t n = s->position->byteno; + + releaseStream(s); + return PL_unify_int64(A2, n); + } + + fail; +} + + +static +PRED_IMPL("character_count", 2, character_count, 0) +{ IOSTREAM *s; + + if ( getStreamWithPosition(A1, &s) ) + { int64_t n = s->position->charno; + + releaseStream(s); + return PL_unify_int64(A2, n); + } + + fail; +} + + +static +PRED_IMPL("line_count", 2, line_count, 0) +{ GET_LD + IOSTREAM *s; + + if ( getStreamWithPosition(A1, &s) ) + { intptr_t n = s->position->lineno; + + releaseStream(s); + return PL_unify_integer(A2, n); + } + + fail; +} + + +static +PRED_IMPL("line_position", 2, line_position, 0) +{ GET_LD + IOSTREAM *s; + + if ( getStreamWithPosition(A1, &s) ) + { intptr_t n = s->position->linepos; + + releaseStream(s); + return PL_unify_integer(A2, n); + } + + fail; +} + + +static word +pl_source_location(term_t file, term_t line) +{ GET_LD + if ( ReadingSource && + PL_unify_atom(file, source_file_name) && + PL_unify_integer(line, source_line_no) ) + succeed; + + fail; +} + + +static word +pl_at_end_of_stream1(term_t stream) +{ GET_LD + IOSTREAM *s; + + if ( getInputStream(stream, &s) ) + { int rval = Sfeof(s); + + if ( rval < 0 ) + { PL_error(NULL, 0, "not-buffered stream", ERR_PERMISSION, + ATOM_end_of_stream, ATOM_stream, stream); + rval = FALSE; + } + + if ( rval && Sferror(s) ) /* due to error */ + return streamStatus(s); + else + releaseStream(s); + + return rval; + } + + return FALSE; /* exception */ +} + + +static word +pl_at_end_of_stream0(void) +{ return pl_at_end_of_stream1(0); +} + +static foreign_t +peek(term_t stream, term_t chr, int how) +{ GET_LD + IOSTREAM *s; + IOPOS pos; + int c; + + if ( !getInputStream(stream, &s) ) + fail; + + pos = s->posbuf; + if ( how == BYTE_MODE ) + { c = Sgetc(s); + if ( c != EOF ) + Sungetc(c, s); + } else + { c = Sgetcode(s); + if ( c != EOF ) + Sungetcode(c, s); + } + s->posbuf = pos; + if ( Sferror(s) ) + return streamStatus(s); + releaseStream(s); + + return PL_unify_char(chr, c, how); +} + + +static +PRED_IMPL("peek_byte", 2, peek_byte2, 0) +{ return peek(A1, A2, BYTE_MODE); +} + + +static +PRED_IMPL("peek_byte", 1, peek_byte1, 0) +{ return peek(0, A1, BYTE_MODE); +} + + +static +PRED_IMPL("peek_code", 2, peek_code2, 0) +{ return peek(A1, A2, CODE_MODE); +} + + +static +PRED_IMPL("peek_code", 1, peek_code1, 0) +{ return peek(0, A1, CODE_MODE); +} + + +static +PRED_IMPL("peek_char", 2, peek_char2, 0) +{ return peek(A1, A2, CHAR_MODE); +} + + +static +PRED_IMPL("peek_char", 1, peek_char1, 0) +{ return peek(0, A1, CHAR_MODE); +} + + + /******************************* + * INTERACTION * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +set_prolog_OI(+In, +Out, +Error) + +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +typedef struct wrappedIO +{ void *wrapped_handle; /* original handle */ + IOFUNCTIONS *wrapped_functions; /* original functions */ + IOSTREAM *wrapped_stream; /* stream we wrapped */ + IOFUNCTIONS functions; /* new function block */ +} wrappedIO; + + +static ssize_t +Sread_user(void *handle, char *buf, size_t size) +{ GET_LD + wrappedIO *wio = handle; + + if ( LD->prompt.next && ttymode != TTY_RAW ) + PL_write_prompt(TRUE); + else + Sflush(Suser_output); + + size = (*wio->wrapped_functions->read)(wio->wrapped_handle, buf, size); + if ( size == 0 ) /* end-of-file */ + { Sclearerr(Suser_input); + LD->prompt.next = TRUE; + } else if ( size > 0 && buf[size-1] == '\n' ) + LD->prompt.next = TRUE; + + return size; +} + + +static int +closeWrappedIO(void *handle) +{ wrappedIO *wio = handle; + int rval; + + if ( wio->wrapped_functions->close ) + rval = (*wio->wrapped_functions->close)(wio->wrapped_handle); + else + rval = 0; + + wio->wrapped_stream->functions = wio->wrapped_functions; + wio->wrapped_stream->handle = wio->wrapped_handle; + PL_free(wio); + + return rval; +} + + +static void +wrapIO(IOSTREAM *s, + ssize_t (*read)(void *, char *, size_t), + ssize_t (*write)(void *, char *, size_t)) +{ wrappedIO *wio = PL_malloc(sizeof(*wio)); + + wio->wrapped_functions = s->functions; + wio->wrapped_handle = s->handle; + wio->wrapped_stream = s; + + wio->functions = *s->functions; + if ( read ) wio->functions.read = read; + if ( write ) wio->functions.write = write; + wio->functions.close = closeWrappedIO; + + s->functions = &wio->functions; + s->handle = wio; +} + + +static +PRED_IMPL("set_prolog_IO", 3, set_prolog_IO, 0) +{ PRED_LD + IOSTREAM *in = NULL, *out = NULL, *error = NULL; + int rval = FALSE; + + if ( !PL_get_stream_handle(A1, &in) || + !PL_get_stream_handle(A2, &out) ) + goto out; + + if ( PL_compare(A2, A3) == 0 ) /* == */ + { error = getStream(Snew(out->handle, out->flags, out->functions)); + error->flags &= ~SIO_ABUF; /* disable buffering */ + error->flags |= SIO_NBUF; + } else + { if ( !PL_get_stream_handle(A3, &error) ) + goto out; + } + + LOCK(); + out->flags &= ~SIO_ABUF; /* output: line buffered */ + out->flags |= SIO_LBUF; + + LD->IO.streams[0] = in; /* user_input */ + LD->IO.streams[1] = out; /* user_output */ + LD->IO.streams[2] = error; /* user_error */ + LD->IO.streams[3] = in; /* current_input */ + LD->IO.streams[4] = out; /* current_output */ + + wrapIO(in, Sread_user, NULL); + LD->prompt.next = TRUE; + + UNLOCK(); + rval = TRUE; + +out: + if ( in ) + releaseStream(in); + if ( out ) + releaseStream(out); + if ( error && error != out ) + releaseStream(error); + + return rval; +} + + + /******************************** + * FILES * + *********************************/ + +static bool +unifyTime(term_t t, intptr_t time) +{ return PL_unify_float(t, (double)time); +} + + +static void +add_option(term_t options, functor_t f, atom_t val) +{ GET_LD + term_t head = PL_new_term_ref(); + + PL_unify_list(options, head, options); + PL_unify_term(head, PL_FUNCTOR, f, PL_ATOM, val); + + PL_reset_term_refs(head); +} + +#define CVT_FILENAME (CVT_ATOM|CVT_STRING|CVT_LIST) + +static int +PL_get_file_name(term_t n, char **namep, int flags) +{ GET_LD + char *name; + char tmp[MAXPATHLEN]; + char ospath[MAXPATHLEN]; + + if ( flags & PL_FILE_SEARCH ) + { predicate_t pred = PL_predicate("absolute_file_name", 3, "system"); + term_t av = PL_new_term_refs(3); + term_t options = PL_copy_term_ref(av+2); + int cflags = ((flags&PL_FILE_NOERRORS) ? PL_Q_CATCH_EXCEPTION + : PL_Q_PASS_EXCEPTION); + + PL_put_term(av+0, n); + + if ( flags & PL_FILE_EXIST ) + add_option(options, FUNCTOR_access1, ATOM_exist); + if ( flags & PL_FILE_READ ) + add_option(options, FUNCTOR_access1, ATOM_read); + if ( flags & PL_FILE_WRITE ) + add_option(options, FUNCTOR_access1, ATOM_write); + if ( flags & PL_FILE_EXECUTE ) + add_option(options, FUNCTOR_access1, ATOM_execute); + + PL_unify_nil(options); + + if ( !PL_call_predicate(NULL, cflags, pred, av) ) + fail; + + return PL_get_chars_ex(av+1, namep, CVT_ATOMIC|BUF_RING|REP_FN); + } + + if ( flags & PL_FILE_NOERRORS ) + { if ( !PL_get_chars(n, &name, CVT_FILENAME|REP_FN) ) + fail; + } else + { if ( !PL_get_chars_ex(n, &name, CVT_FILENAME|REP_FN) ) + fail; + } + + if ( trueFeature(FILEVARS_FEATURE) ) + { if ( !(name = ExpandOneFile(name, tmp)) ) + fail; + } + + if ( !(flags & PL_FILE_NOERRORS) ) + { atom_t op = 0; + + if ( (flags&PL_FILE_READ) && !AccessFile(name, ACCESS_READ) ) + op = ATOM_read; + if ( !op && (flags&PL_FILE_WRITE) && !AccessFile(name, ACCESS_WRITE) ) + op = ATOM_write; + if ( !op && (flags&PL_FILE_EXECUTE) && !AccessFile(name, ACCESS_EXECUTE) ) + op = ATOM_execute; + + if ( op ) + return PL_error(NULL, 0, NULL, ERR_PERMISSION, ATOM_file, op, n); + + if ( (flags & PL_FILE_EXIST) && !AccessFile(name, ACCESS_EXIST) ) + return PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_file, n); + } + + if ( flags & PL_FILE_ABSOLUTE ) + { if ( !(name = AbsoluteFile(name, tmp)) ) + fail; + } + + if ( flags & PL_FILE_OSPATH ) + { if ( !(name = OsPath(name, ospath)) ) + fail; + } + + *namep = buffer_string(name, BUF_RING); + succeed; +} + + +static word +pl_time_file(term_t name, term_t t) +{ char *fn; + + if ( PL_get_file_name(name, &fn, 0) ) + { intptr_t time; + + if ( (time = LastModifiedFile(fn)) == -1 ) + return PL_error(NULL, 0, NULL, ERR_FILE_OPERATION, ATOM_time, ATOM_file, name); + + return unifyTime(t, time); + } + + fail; +} + + +static word +pl_size_file(term_t name, term_t len) +{ char *n; + + if ( PL_get_file_name(name, &n, 0) ) + { int64_t size; + + if ( (size = SizeFile(n)) < 0 ) + return PL_error("size_file", 2, OsError(), ERR_FILE_OPERATION, + ATOM_size, ATOM_file, name); + + return PL_unify_int64(len, size); + } + + fail; +} + + +static word +pl_size_stream(term_t stream, term_t len) +{ GET_LD + IOSTREAM *s; + int rval; + + if ( !PL_get_stream_handle(stream, &s) ) + fail; + + rval = PL_unify_integer(len, Ssize(s)); + PL_release_stream(s); + + return rval; +} + + +static word +pl_access_file(term_t name, term_t mode) +{ GET_LD + char *n; + int md; + atom_t m; + + if ( !PL_get_atom(mode, &m) ) + return PL_error("access_file", 2, NULL, ERR_TYPE, ATOM_atom, mode); + if ( !PL_get_file_name(name, &n, 0) ) + fail; + + if ( m == ATOM_none ) + succeed; + + if ( m == ATOM_write || m == ATOM_append ) + md = ACCESS_WRITE; + else if ( m == ATOM_read ) + md = ACCESS_READ; + else if ( m == ATOM_execute ) + md = ACCESS_EXECUTE; + else if ( m == ATOM_exist ) + md = ACCESS_EXIST; + else + return PL_error("access_file", 2, NULL, ERR_DOMAIN, ATOM_io_mode, mode); + + if ( AccessFile(n, md) ) + succeed; + + if ( md == ACCESS_WRITE && !AccessFile(n, ACCESS_EXIST) ) + { char tmp[MAXPATHLEN]; + char *dir = DirName(n, tmp); + + if ( dir[0] ) + { if ( !ExistsDirectory(dir) ) + fail; + } + if ( AccessFile(dir[0] ? dir : ".", md) ) + succeed; + } + + fail; +} + + +static word +pl_read_link(term_t file, term_t link, term_t to) +{ char *n, *l, *t; + char buf[MAXPATHLEN]; + + if ( !PL_get_file_name(file, &n, 0) ) + fail; + + if ( (l = ReadLink(n, buf)) && + PL_unify_atom_chars(link, l) && + (t = DeRefLink(n, buf)) && + PL_unify_atom_chars(to, t) ) + succeed; + + fail; +} + + +word +pl_exists_file(term_t name) +{ char *n; + + if ( !PL_get_file_name(name, &n, 0) ) + fail; + + return ExistsFile(n); +} + + +static word +pl_exists_directory(term_t name) +{ char *n; + + if ( !PL_get_file_name(name, &n, 0) ) + fail; + + return ExistsDirectory(n); +} + + +static word +pl_tmp_file(term_t base, term_t name) +{ GET_LD + char *n; + + if ( !PL_get_chars(base, &n, CVT_ALL) ) + return PL_error("tmp_file", 2, NULL, ERR_TYPE, ATOM_atom, base); + + return PL_unify_atom(name, TemporaryFile(n)); +} + + +static word +pl_delete_file(term_t name) +{ char *n; + + if ( !PL_get_file_name(name, &n, 0) ) + fail; + + if ( RemoveFile(n) ) + succeed; + + return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION, + ATOM_delete, ATOM_file, name); +} + + +static word +pl_delete_directory(term_t name) +{ char *n; + + if ( !PL_get_file_name(name, &n, 0) ) + fail; + + if ( rmdir(n) == 0 ) + succeed; + else + return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION, + ATOM_delete, ATOM_directory, name); +} + + +static word +pl_make_directory(term_t name) +{ char *n; + + if ( !PL_get_file_name(name, &n, 0) ) + fail; + + if ( mkdir(n, 0777) == 0 ) + succeed; + else + return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION, + ATOM_create, ATOM_directory, name); +} + + +static word +pl_same_file(term_t file1, term_t file2) +{ char *n1, *n2; + + if ( PL_get_file_name(file1, &n1, 0) && + PL_get_file_name(file2, &n2, 0) ) + return SameFile(n1, n2); + + fail; +} + + +static word +pl_rename_file(term_t old, term_t new) +{ GET_LD + char *o, *n; + + if ( PL_get_file_name(old, &o, 0) && + PL_get_file_name(new, &n, 0) ) + { if ( SameFile(o, n) ) + { if ( fileerrors ) + return PL_error("rename_file", 2, "same file", ERR_PERMISSION, + ATOM_rename, ATOM_file, old); + fail; + } + + if ( RenameFile(o, n) ) + succeed; + + if ( fileerrors ) + return PL_error("rename_file", 2, OsError(), ERR_FILE_OPERATION, + ATOM_rename, ATOM_file, old); + fail; + } + + fail; +} + + +static word +pl_fileerrors(term_t old, term_t new) +{ GET_LD + return setBoolean(&fileerrors, old, new); +} + + +static word +pl_absolute_file_name(term_t name, term_t expanded) +{ char *n; + char tmp[MAXPATHLEN]; + + if ( PL_get_file_name(name, &n, 0) && + (n = AbsoluteFile(n, tmp)) ) + return PL_unify_chars(expanded, PL_ATOM|REP_FN, -1, n); + + fail; +} + + +static word +pl_is_absolute_file_name(term_t name) +{ char *n; + + if ( PL_get_file_name(name, &n, 0) && + IsAbsolutePath(n) ) + succeed; + + fail; +} + + +static word +pl_working_directory(term_t old, term_t new) +{ GET_LD + const char *wd; + + if ( !(wd = PL_cwd()) ) + fail; + + if ( PL_unify_chars(old, PL_ATOM|REP_FN, -1, wd) ) + { if ( PL_compare(old, new) != 0 ) + { char *n; + + if ( PL_get_file_name(new, &n, 0) ) + { if ( ChDir(n) ) + succeed; + + if ( fileerrors ) + return PL_error(NULL, 0, NULL, ERR_FILE_OPERATION, + ATOM_chdir, ATOM_directory, new); + fail; + } + } + + succeed; + } + + fail; +} + + +static word +pl_file_base_name(term_t f, term_t b) +{ char *n; + + if ( !PL_get_chars_ex(f, &n, CVT_ALL|REP_FN) ) + fail; + + return PL_unify_chars(b, PL_ATOM|REP_FN, -1, BaseName(n)); +} + + +static word +pl_file_dir_name(term_t f, term_t b) +{ char *n; + char tmp[MAXPATHLEN]; + + if ( !PL_get_chars_ex(f, &n, CVT_ALL|REP_FN) ) + fail; + + return PL_unify_chars(b, PL_ATOM|REP_FN, -1, DirName(n, tmp)); +} + + +static int +has_extension(const char *name, const char *ext) +{ GET_LD + const char *s = name + strlen(name); + + if ( ext[0] == EOS ) + succeed; + + while(*s != '.' && *s != '/' && s > name) + s--; + if ( *s == '.' && s > name && s[-1] != '/' ) + { if ( ext[0] == '.' ) + ext++; + if ( trueFeature(FILE_CASE_FEATURE) ) + return strcmp(&s[1], ext) == 0; + else + return strcasecmp(&s[1], ext) == 0; + } + + fail; +} + + +static int +name_too_long(void) +{ return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_path_length); +} + + +static word +pl_file_name_extension(term_t base, term_t ext, term_t full) +{ GET_LD + char *b = NULL, *e = NULL, *f; + char buf[MAXPATHLEN]; + + if ( !PL_is_variable(full) ) + { if ( PL_get_chars(full, &f, CVT_ALL|CVT_EXCEPTION|REP_FN) ) + { char *s = f + strlen(f); /* ?base, ?ext, +full */ + + while(*s != '.' && *s != '/' && s > f) + s--; + if ( *s == '.' ) + { if ( PL_get_chars(ext, &e, CVT_ALL|REP_FN) ) + { if ( e[0] == '.' ) + e++; + if ( trueFeature(FILE_CASE_FEATURE) ) + { TRY(strcmp(&s[1], e) == 0); + } else + { TRY(strcasecmp(&s[1], e) == 0); + } + } else + { TRY(PL_unify_chars(ext, PL_ATOM|REP_FN, -1, &s[1])); + } + if ( s-f > MAXPATHLEN ) + return name_too_long(); + strncpy(buf, f, s-f); + buf[s-f] = EOS; + + return PL_unify_chars(base, PL_ATOM|REP_FN, -1, buf); + } + if ( PL_unify_atom_chars(ext, "") && + PL_unify(full, base) ) + PL_succeed; + } + PL_fail; + } + + if ( PL_get_chars_ex(base, &b, CVT_ALL|BUF_RING|REP_FN) && + PL_get_chars_ex(ext, &e, CVT_ALL|REP_FN) ) + { char *s; + + if ( e[0] == '.' ) /* +Base, +Extension, -full */ + e++; + if ( has_extension(b, e) ) + return PL_unify(base, full); + if ( strlen(b) + 1 + strlen(e) + 1 > MAXPATHLEN ) + return name_too_long(); + strcpy(buf, b); + s = buf + strlen(buf); + *s++ = '.'; + strcpy(s, e); + + return PL_unify_chars(full, PL_ATOM|REP_FN, -1, buf); + } else + fail; +} + + +static word +pl_prolog_to_os_filename(term_t pl, term_t os) +{ GET_LD +#ifdef O_XOS + wchar_t *wn; + + if ( !PL_is_variable(pl) ) + { char *n; + wchar_t buf[MAXPATHLEN]; + + if ( PL_get_chars_ex(pl, &n, CVT_ALL|REP_UTF8) ) + { if ( !_xos_os_filenameW(n, buf, MAXPATHLEN) ) + return name_too_long(); + + return PL_unify_wchars(os, PL_ATOM, -1, buf); + } + fail; + } + + if ( PL_get_wchars(os, NULL, &wn, CVT_ALL) ) + { wchar_t lbuf[MAXPATHLEN]; + char buf[MAXPATHLEN]; + + _xos_long_file_nameW(wn, lbuf, MAXPATHLEN); + _xos_canonical_filenameW(lbuf, buf, MAXPATHLEN, 0); + + return PL_unify_chars(pl, PL_ATOM|REP_UTF8, -1, buf); + } + + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, pl); +#else /*O_XOS*/ + return PL_unify(pl, os); +#endif /*O_XOS*/ +} + + +static foreign_t +pl_mark_executable(term_t path) +{ char *name; + + if ( !PL_get_file_name(path, &name, 0) ) + return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_source_sink, path); + + return MarkExecutable(name); +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +copy_stream_data(+StreamIn, +StreamOut, [Len]) + Copy all data from StreamIn to StreamOut. Should be somewhere else, + and maybe we need something else to copy resources. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + +static foreign_t +pl_copy_stream_data3(term_t in, term_t out, term_t len) +{ GET_LD + IOSTREAM *i, *o; + int c; + int count = 0; + + if ( !getInputStream(in, &i) ) + return FALSE; + if ( !getOutputStream(out, &o) ) + { releaseStream(i); + return FALSE; + } + + if ( !len ) + { while ( (c = Sgetcode(i)) != EOF ) + { if ( (++count % 4096) == 0 && PL_handle_signals() < 0 ) + { releaseStream(i); + releaseStream(o); + fail; + } + if ( Sputcode(c, o) < 0 ) + { releaseStream(i); + return streamStatus(o); + } + } + } else + { int64_t n; + + if ( !PL_get_int64_ex(len, &n) ) + fail; + + while ( n-- > 0 && (c = Sgetcode(i)) != EOF ) + { if ( (++count % 4096) == 0 && PL_handle_signals() < 0 ) + { releaseStream(i); + releaseStream(o); + fail; + } + if ( Sputcode(c, o) < 0 ) + { releaseStream(i); + return streamStatus(o); + } + } + } + + releaseStream(o); + return streamStatus(i); +} + +static foreign_t +pl_copy_stream_data2(term_t in, term_t out) +{ return pl_copy_stream_data3(in, out, 0); +} + + + /******************************* + * PUBLISH PREDICATES * + *******************************/ + +BeginPredDefs(file) + PRED_DEF("set_prolog_IO", 3, set_prolog_IO, 0) + PRED_DEF("read_pending_input", 3, read_pending_input, 0) + PRED_DEF("get_code", 2, get_code2, PL_FA_ISO) + PRED_DEF("get_code", 1, get_code1, PL_FA_ISO) + PRED_DEF("get_char", 2, get_char2, PL_FA_ISO) + PRED_DEF("get_char", 1, get_char1, PL_FA_ISO) + PRED_DEF("get_byte", 2, get_byte2, PL_FA_ISO) + PRED_DEF("get_byte", 1, get_byte1, PL_FA_ISO) + PRED_DEF("peek_code", 2, peek_code2, PL_FA_ISO) + PRED_DEF("peek_code", 1, peek_code1, PL_FA_ISO) + PRED_DEF("peek_char", 2, peek_char2, PL_FA_ISO) + PRED_DEF("peek_char", 1, peek_char1, PL_FA_ISO) + PRED_DEF("peek_byte", 2, peek_byte2, PL_FA_ISO) + PRED_DEF("peek_byte", 1, peek_byte1, PL_FA_ISO) + PRED_DEF("put_byte", 2, put_byte2, PL_FA_ISO) + PRED_DEF("put_byte", 1, put_byte1, PL_FA_ISO) + PRED_DEF("put_code", 2, put_code2, PL_FA_ISO) + PRED_DEF("put_code", 1, put_code1, PL_FA_ISO) + PRED_DEF("put_char", 2, put_code2, PL_FA_ISO) + PRED_DEF("put_char", 1, put_code1, PL_FA_ISO) + PRED_DEF("put", 2, put2, 0) + PRED_DEF("put", 1, put1, 0) + PRED_DEF("skip", 1, skip1, 0) + PRED_DEF("skip", 2, skip2, 0) + PRED_DEF("get", 1, get1, 0) + PRED_DEF("get", 2, get2, 0) + PRED_DEF("get0", 2, get_code2, 0) + PRED_DEF("get0", 1, get_code1, 0) + PRED_DEF("is_stream", 1, is_stream, 0) + PRED_DEF("byte_count", 2, byte_count, 0) + PRED_DEF("character_count", 2, character_count, 0) + PRED_DEF("line_count", 2, line_count, 0) + PRED_DEF("line_position", 2, line_position, 0) + PRED_DEF("with_output_to", 2, with_output_to, PL_FA_TRANSPARENT) +EndPredDefs + +static const PL_extension file_foreigns[] = { + FRG("get_single_char", 1, pl_get_single_char, 0), + FRG("$push_input_context", 0, pl_push_input_context, 0), + FRG("$pop_input_context", 0, pl_pop_input_context, 0), + FRG("seeing", 1, pl_seeing, 0), + FRG("telling", 1, pl_telling, 0), + FRG("seen", 0, pl_seen, 0), + FRG("tmp_file", 2, pl_tmp_file, 0), + FRG("delete_file", 1, pl_delete_file, 0), + FRG("delete_directory", 1, pl_delete_directory, 0), + FRG("make_directory", 1, pl_make_directory, 0), + FRG("access_file", 2, pl_access_file, 0), + FRG("read_link", 3, pl_read_link, 0), + FRG("exists_file", 1, pl_exists_file, 0), + FRG("exists_directory", 1, pl_exists_directory, 0), + FRG("rename_file", 2, pl_rename_file, 0), + FRG("same_file", 2, pl_same_file, 0), + FRG("time_file", 2, pl_time_file, 0), + FRG("told", 0, pl_told, 0), + FRG("see", 1, pl_see, 0), + FRG("tell", 1, pl_tell, 0), + FRG("append", 1, pl_append, 0), + FRG("ttyflush", 0, pl_ttyflush, 0), + FRG("flush_output", 0, pl_flush_output, 0), + FRG("prompt", 2, pl_prompt, 0), + FRG("prompt1", 1, pl_prompt1, 0), + FRG("$absolute_file_name", 2, pl_absolute_file_name, 0), + FRG("is_absolute_file_name", 1, pl_is_absolute_file_name, 0), + FRG("file_base_name", 2, pl_file_base_name, 0), + FRG("file_directory_name", 2, pl_file_dir_name, 0), + FRG("file_name_extension", 3, pl_file_name_extension, 0), + FRG("prolog_to_os_filename", 2, pl_prolog_to_os_filename, 0), + FRG("set_stream_position", 2, pl_set_stream_position, ISO), + FRG("wait_for_input", 3, pl_wait_for_input, 0), + FRG("protocol", 1, pl_protocol, 0), + FRG("protocola", 1, pl_protocola, 0), + FRG("noprotocol", 0, pl_noprotocol, 0), + FRG("protocolling", 1, pl_protocolling, 0), + FRG("tab", 1, pl_tab, 0), + FRG("open", 3, pl_open, ISO), + FRG("open", 4, pl_open4, ISO), + FRG("open_null_stream", 1, pl_open_null_stream, 0), + FRG("close", 1, pl_close, ISO), + FRG("close", 2, pl_close2, ISO), + FRG("stream_property", 2, pl_stream_property, NDET|ISO), + FRG("flush_output", 1, pl_flush_output1, ISO), + FRG("set_stream_position", 2, pl_set_stream_position, ISO), + FRG("seek", 4, pl_seek, 0), + FRG("set_input", 1, pl_set_input, ISO), + FRG("set_output", 1, pl_set_output, ISO), + FRG("set_stream", 2, pl_set_stream, 0), + FRG("current_input", 1, pl_current_input, ISO), + FRG("current_output", 1, pl_current_output, ISO), + FRG("source_location", 2, pl_source_location, 0), + FRG("at_end_of_stream", 1, pl_at_end_of_stream1, ISO), + FRG("at_end_of_stream", 0, pl_at_end_of_stream0, ISO), + FRG("size_file", 2, pl_size_file, 0), + FRG("$size_stream", 2, pl_size_stream, 0), + FRG("fileerrors", 2, pl_fileerrors, 0), + FRG("working_directory", 2, pl_working_directory, 0), + FRG("$mark_executable", 1, pl_mark_executable, 0), + FRG("copy_stream_data", 2, pl_copy_stream_data2, 0), + FRG("copy_stream_data", 3, pl_copy_stream_data3, 0) + +}; + +void +initIO(void) +{ GET_LD + const atom_t *np; + int i; + + init_standardStreams(); + init_encoding_names(); + init_open4_options(); + init_close2_options(); + init_sprop_list(); + streamAliases = newHTable(16); + streamContext = newHTable(16); + + fileerrors = TRUE; +#ifdef __unix__ +{ int fd; + + if ( (fd=Sfileno(Sinput)) < 0 || !isatty(fd) || + (fd=Sfileno(Soutput)) < 0 || !isatty(fd) ) + defFeature("tty_control", FT_BOOL, FALSE); +} +#endif + ResetTty(); + + Sclosehook(freeStream); + + Sinput->position = &Sinput->posbuf; /* position logging */ + Soutput->position = &Sinput->posbuf; + Serror->position = &Sinput->posbuf; + + ttymode = TTY_COOKED; + PushTty(Sinput, &ttytab, TTY_SAVE); + LD->prompt.current = ATOM_prompt; + PL_register_atom(ATOM_prompt); + + Suser_input = Sinput; + Suser_output = Soutput; + Suser_error = Serror; + Scurin = Sinput; /* see/tell */ + Scurout = Soutput; + Sprotocol = NULL; /* protocolling */ + + getStreamContext(Sinput); /* add for enumeration */ + getStreamContext(Soutput); + getStreamContext(Serror); + for( i=0, np = standardStreams; *np; np++, i++ ) + addHTable(streamAliases, (void *)*np, (void *)(intptr_t)i); + + GD->io_initialised = TRUE; +} + diff --git a/LGPL/PLStream/pl-incl.h b/LGPL/PLStream/pl-incl.h new file mode 100644 index 000000000..007e8d411 --- /dev/null +++ b/LGPL/PLStream/pl-incl.h @@ -0,0 +1,549 @@ + +#include "config.h" +#include +#if HAVE_STRING_H +#include +#endif +#define COMMON(X) X + +#ifdef HAVE_LOCALE_H +#include +#endif +#include +#include +#if HAVE_SYS_PARAM_H +#include //MAXPATHLEN +#endif +#if __YAP_PROLOG__ +#include "pl-yap.h" +#endif + + + /******************************** + * UTILITIES * + *********************************/ +#define ROUND(p, n) ((((p) + (n) - 1) & ~((n) - 1))) + + /******************************** + * HASH TABLES * + *********************************/ + +#include "pl-table.h" +#include "pl-stream.h" +#include "pl-os.h" +#include "pl-error.h" + + /******************************** + * BUFFERS * + *********************************/ + +#include "pl-buffer.h" + + /******************************* + * OPTION LISTS * + *******************************/ + +#include "pl-opts.h" + +// numbers + +typedef enum +{ V_INTEGER, /* integer (64-bit) value */ +#ifdef O_GMP + V_MPZ, /* mpz_t */ + V_MPQ, /* mpq_t */ +#endif + V_REAL /* Floating point number (double) */ +} numtype; + +typedef struct +{ numtype type; /* type of number */ + union { double f; /* value as real */ + int64_t i; /* value as integer */ + word w[WORDS_PER_DOUBLE]; /* for packing/unpacking the double */ +#ifdef O_GMP + mpz_t mpz; /* GMP integer */ + mpq_t mpq; /* GMP rational */ +#endif + } value; +} number, *Number; + +typedef enum +{ CLN_NORMAL = 0, /* Normal mode */ + CLN_ACTIVE, /* Started cleanup */ + CLN_FOREIGN, /* Foreign hooks */ + CLN_PROLOG, /* Prolog hooks */ + CLN_SHARED, /* Unload shared objects */ + CLN_DATA /* Remaining data */ +} cleanup_status; + +typedef struct tempfile * TempFile; /* pl-os.c */ +typedef struct canonical_dir * CanonicalDir; /* pl-os.c */ +typedef struct on_halt * OnHalt; /* pl-os.c */ + +/* The GD global variable */ +struct { + int io_initialised; + cleanup_status cleaning; /* Inside PL_cleanup() */ + + struct + { TempFile _tmpfile_head; + TempFile _tmpfile_tail; + CanonicalDir _canonical_dirlist; + char * myhome; /* expansion of ~ */ + char * fred; /* last expanded ~user */ + char * fredshome; /* home of fred */ + OnHalt on_halt_list; /* list of onhalt hooks */ + int halting; /* process is shutting down */ + int gui_app; /* Win32: Application is a gui app */ + IOFUNCTIONS iofunctions; /* initial IO functions */ + IOFUNCTIONS org_terminal; /* IO+Prolog terminal functions */ + IOFUNCTIONS rl_functions; /* IO+Terminal+Readline functions */ + } os; + + struct + { atom_t * array; /* index --> atom */ + size_t count; /* elements in array */ + atom_t *for_code[256]; /* code --> one-char-atom */ + } atoms; + +} gds; + + +#define GD (&gds) +#define GLOBAL_LD (&gds) + +// LOCAL variables (heap will get this form LOCAL + +#define FT_ATOM 0 /* atom feature */ +#define FT_BOOL 1 /* boolean feature (true, false) */ +#define FT_INTEGER 2 /* integer feature */ +#define FT_TERM 3 /* term feature */ +#define FT_INT64 4 /* passed as int64_t */ +#define FT_MASK 0x0f /* mask to get type */ + +#define FF_READONLY 0x10 /* feature is read-only */ +#define FF_KEEP 0x20 /* keep value it already set */ + +typedef struct +{ unsigned long flags; /* the feature flags */ +} pl_features_t; + +typedef enum +{ OCCURS_CHECK_FALSE = 0, + OCCURS_CHECK_TRUE, + OCCURS_CHECK_ERROR +} occurs_check_t; + +typedef struct +{ atom_t file; /* current source file */ + int line; /* current line */ + int linepos; /* position in the line */ + int64_t character; /* current character location */ +} source_location; + + +typedef struct exception_frame /* PL_throw exception environments */ +{ struct exception_frame *parent; /* parent frame */ + jmp_buf exception_jmp_env; /* longjmp environment */ +} exception_frame; + +#define EXCEPTION_GUARDED(code, cleanup) \ + { exception_frame __throw_env; \ + __throw_env.parent = LD->exception.throw_environment; \ + if ( setjmp(__throw_env.exception_jmp_env) != 0 ) \ + { LD->exception.throw_environment = __throw_env.parent; \ + cleanup; \ + } else \ + { LD->exception.throw_environment = &__throw_env; \ + code; \ + LD->exception.throw_environment = __throw_env.parent; \ + } \ + } + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +At times an abort is not allowed because the heap is inconsistent the +programmer should call startCritical to start such a code region and +endCritical to end it. + +MT/TBD: how to handle this gracefully in the multi-threading case. Does +it mean anything? +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* vsc: needs defining */ +#define startCritical +#define endCritical + +/* The LD macro layer */ +typedef struct PL_local_data { + + struct /* Local IO stuff */ + { IOSTREAM *streams[6]; /* handles for standard streams */ + struct input_context *input_stack; /* maintain input stream info */ + struct output_context *output_stack; /* maintain output stream info */ + } IO; + + struct + { Table table; /* Feature table */ + pl_features_t mask; /* Masked access to booleans */ + int write_attributes; /* how to write attvars? */ + occurs_check_t occurs_check; /* Unify and occurs check */ + } feature; + + source_location read_source; /* file, line, char of last term */ + + struct + { int active; /* doing pipe I/O */ + jmp_buf context; /* context of longjmp() */ + } pipe; + + struct + { atom_t current; /* current global prompt */ + atom_t first; /* how to prompt first line */ + int first_used; /* did we do the first line? */ + int next; /* prompt on next read operation */ + } prompt; + + IOENC encoding; /* default I/O encoding */ + + struct + { char * _CWDdir; + size_t _CWDlen; +#ifdef __BEOS__ + status_t dl_error; /* dlopen() emulation in pl-beos.c */ +#endif + int rand_initialised; /* have we initialised random? */ + } os; + + struct + { term_t term; /* exception term */ + term_t bin; /* temporary handle for exception */ + term_t printed; /* already printed exception */ + term_t tmp; /* tmp for errors */ + term_t pending; /* used by the debugger */ + int in_hook; /* inside exception_hook() */ + exception_frame *throw_environment; /* PL_throw() environments */ + } exception; + const char *float_format; /* floating point format */ + + buffer discardable_buffer; /* PL_*() character buffers */ + buffer buffer_ring[BUFFER_RING_SIZE]; + int current_buffer_id; + +} PL_local_data_t; + +#define features (LD->feature.mask) + +PL_local_data_t lds; + +#define exception_term (LD->exception.term) + +// THIS HAS TO BE ABSTRACTED + +#define LD (&lds) +#define LOCAL_LD (&lds) + +#define ARG_LD +#define GET_LD +#define PRED_LD +#define PASS_LD + +/* Support PL_LOCK in the interface */ +#define PL_LOCK(X) +#define PL_UNLOCK(X) + + +#ifndef TRUE +#define TRUE 1 +#define FALSE 0 +#endif +#define succeed return TRUE +#define fail return FALSE +#define TRY(goal) if ((goal) == FALSE) fail + + +/* atom_t macro layer */ +#define NULL_ATOM ((atom_t)0) + +#include "atoms.h" + +atom_t source_file_name; /** source name of the current file that we are + consulting */ +int source_line_no; /** guess.... */ + +IOSTREAM * Suser_input; +IOSTREAM * Suser_output; +IOSTREAM * Suser_error; +IOSTREAM * Scurin; /* see/tell */ +IOSTREAM * Scurout; +IOSTREAM * Sprotocol; /* protocolling */ + +int fileerrors; + +int ttymode; + +#define CHARESCAPE_FEATURE 0x00001 /* handle \ in atoms */ +#define GC_FEATURE 0x00002 /* do GC */ +#define TRACE_GC_FEATURE 0x00004 /* verbose gc */ +#define TTY_CONTROL_FEATURE 0x00008 /* allow for tty control */ +#define READLINE_FEATURE 0x00010 /* readline is loaded */ +#define DEBUG_ON_ERROR_FEATURE 0x00020 /* start tracer on error */ +#define REPORT_ERROR_FEATURE 0x00040 /* print error message */ +#define FILE_CASE_FEATURE 0x00080 /* file names are case sensitive */ +#define FILE_CASE_PRESERVING_FEATURE 0x0100 /* case preserving file names */ +#define DOS_FILE_NAMES_FEATURE 0x00200 /* dos (8+3) file names */ +#define ALLOW_VARNAME_FUNCTOR 0x00400 /* Read Foo(x) as 'Foo'(x) */ +#define ISO_FEATURE 0x00800 /* Strict ISO compliance */ +#define OPTIMISE_FEATURE 0x01000 /* -O: optimised compilation */ +#define FILEVARS_FEATURE 0x02000 /* Expand $var and ~ in filename */ +#define AUTOLOAD_FEATURE 0x04000 /* do autoloading */ +#define CHARCONVERSION_FEATURE 0x08000 /* do character-conversion */ +#define LASTCALL_FEATURE 0x10000 /* Last call optimization enabled? */ +#define EX_ABORT_FEATURE 0x20000 /* abort with exception */ +#define BACKQUOTED_STRING_FEATURE 0x40000 /* `a string` */ +#define SIGNALS_FEATURE 0x80000 /* Handle signals */ +#define DEBUGINFO_FEATURE 0x100000 /* generate debug info */ + +int defFeature(const char *c, int f, ...); + +int trueFeature(int f); + + /******************************* + * STREAM I/O * + *******************************/ + +#define REDIR_MAGIC 0x23a9bef3 + +typedef struct redir_context +{ int magic; /* REDIR_MAGIC */ + IOSTREAM *stream; /* temporary output */ + int is_stream; /* redirect to stream */ + int redirected; /* output is redirected */ + term_t term; /* redirect target */ + int out_format; /* output type */ + int out_arity; /* 2 for difference-list versions */ + size_t size; /* size of I/O buffer */ + char *data; /* data written */ + char buffer[1024]; /* fast temporary buffer */ +} redir_context; + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Defining built-in predicates using the new interface +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#define EOS '\0' +#define ESC ((char) 27) +#define streq(s, q) ((strcmp((s), (q)) == 0)) + +#define CHAR_MODE 0 /* See PL_unify_char() */ +#define CODE_MODE 1 +#define BYTE_MODE 2 + + +/* string stuff */ + /******************************* + * STRING SUPPORT * + *******************************/ +char * store_string(const char *s); +void remove_string(char *s); + + +/* from foreign interface */ + /******************************* + * FILENAME SUPPORT * + *******************************/ + +#define PL_FILE_ABSOLUTE 0x01 /* return absolute path */ +#define PL_FILE_OSPATH 0x02 /* return path in OS notation */ +#define PL_FILE_SEARCH 0x04 /* use file_search_path */ +#define PL_FILE_EXIST 0x08 /* demand file to exist */ +#define PL_FILE_READ 0x10 /* demand read-access */ +#define PL_FILE_WRITE 0x20 /* demand write-access */ +#define PL_FILE_EXECUTE 0x40 /* demand execute-access */ +#define PL_FILE_NOERRORS 0x80 /* do not raise exceptions */ + + +#define PL_FA_ISO (0x20) /* Internal: ISO core predicate */ + + /******************************** + * READ WARNINGS * + *********************************/ + +#define ReadingSource (source_line_no > 0 && \ + source_file_name != NULL_ATOM) + + +#include + +typedef double real; + +#define true(s, a) ((s)->flags & (a)) +#define false(s, a) (!true((s), (a))) +#define set(s, a) ((s)->flags |= (a)) +#define clear(s, a) ((s)->flags &= ~(a)) +#define DEBUG(LEVEL, COMMAND) + +#define forwards static /* forwards function declarations */ + +#define PL_dispatch(FD, COM) +extern int PL_unify_char(term_t chr, int c, int how); +extern int PL_get_char(term_t chr, int *c, int eof); +extern int PL_get_text(term_t l, PL_chars_t *text, int flags); +extern void PL_cleanup_fork(void); +extern int PL_rethrow(void); +extern void PL_get_number(term_t l, number *n); +extern int PL_write_term(IOSTREAM *s, term_t term, int precedence, int flags); +extern int PL_unify_atomic(term_t t, PL_atomic_t a); + +#define _PL_get_arg(X,Y,Z) PL_get_arg(X,Y,Z) +#define _PL_unify_atomic PL_unify_atomic +extern IOSTREAM ** /* provide access to Suser_input, */ + _PL_streams(void); /* Suser_output and Suser_error */ + +#define PL_get_text__LD PL_get_text +#define getInputStream__LD getInputStream +extern int get_atom_text(atom_t atom, PL_chars_t *text); +extern int get_string_text(word w, PL_chars_t *text); +extern char *format_float(double f, char *buf, const char *format); + +/**** stuff from pl-error.c ****/ +extern int PL_get_bool_ex(term_t t, int *i); +extern int PL_get_nchars_ex(term_t t, size_t *len, char **s, unsigned int flags); +extern int PL_get_chars_ex(term_t t, char **s, unsigned int flags); +extern int PL_get_atom_ex(term_t t, atom_t *a); +extern int PL_get_integer_ex(term_t t, int *i); +extern int PL_get_long_ex(term_t t, long *i); +extern int PL_get_int64_ex(term_t t, int64_t *i); +extern int PL_get_intptr_ex(term_t t, intptr_t *i); +extern int PL_get_bool_ex(term_t t, int *i); +extern int PL_get_float_ex(term_t t, double *f); +extern int PL_get_char_ex(term_t t, int *p, int eof); +extern int PL_unify_list_ex(term_t l, term_t h, term_t t); +extern int PL_unify_nil_ex(term_t l); +extern int PL_get_list_ex(term_t l, term_t h, term_t t); +extern int PL_get_nil_ex(term_t l); +extern int PL_get_module_ex(term_t name, module_t *m); +extern int PL_unify_bool_ex(term_t t, bool val); +extern int PL_unify_bool_ex(term_t t, bool val); +extern int PL_get_bool_ex(term_t t, int *i); +extern int PL_get_integer_ex(term_t t, int *i); + +/**** stuff from pl-file.c ****/ +extern void initIO(void); + +extern void dieIO(void); +extern void protocol(const char *str, size_t n); +extern bool readLine(IOSTREAM *in, IOSTREAM *out, char *buffer); +extern bool tellString(char **s, size_t *size, IOENC enc); +extern bool tellString(char **s, size_t *size, IOENC enc); +extern bool toldString(void); + +extern int setupOutputRedirect(term_t to, redir_context *ctx, int redir); +extern void discardOutputRedirect(redir_context *ctx); +extern int closeOutputRedirect(redir_context *ctx); + +extern IOENC atom_to_encoding(atom_t); + +void closeFiles(int); +atom_t PrologPrompt(void); +word pl_current_input(term_t); +word pl_current_output(term_t); +word pl_exists_file(term_t name); +char *DirName(const char *f, char *dir); +void outOfCore(void); + +word pl_noprotocol(void); + +IOSTREAM *PL_current_input(void); +IOSTREAM *PL_current_output(void); +extern int PL_release_stream(IOSTREAM *s); +extern int PL_get_stream_handle(term_t t, IOSTREAM **s); +extern int PL_unify_stream_or_alias(term_t t, IOSTREAM *s); +extern int PL_unify_stream(term_t t, IOSTREAM *s); +extern bool PL_open_stream(term_t handle, IOSTREAM *s); +extern void PL_write_prompt(int dowrite); + +/**** stuff from pl-error.c ****/ +extern void outOfCore(void); +extern void fatalError(const char *fm, ...); +extern void printMessage(int type, ...); +extern int callProlog(void * module, term_t goal, int flags, term_t *ex); +extern word notImplemented(char *name, int arity); + +/**** stuff from pl-ctype.c ****/ +extern void initCharTypes(void); + +/**** stuff from pl-os.c ****/ +extern void cleanupOs(void); +extern void PL_clock_wait_ticks(intptr_t waited); +extern void setOSFeatures(void); +extern uintptr_t FreeMemory(void); +extern uint64_t _PL_Random(void); +extern void RemoveTemporaryFiles(void); +extern int Pause(real t); +char *findExecutable(const char *av0, char *buffer); + +/**** SWI stuff (emulated in pl-yap.c) ****/ +extern int writeAtomToStream(IOSTREAM *so, atom_t at); +extern int valueExpression(term_t t, Number r ARG_LD); +extern word lookupAtom(const char *s, size_t len); +extern atom_t lookupUCSAtom(const pl_wchar_t *s, size_t len); +extern atom_t codeToAtom(int chrcode); +extern int toIntegerNumber(Number n, int flags); +extern int get_atom_ptr_text(Atom a, PL_chars_t *text); + +static inline word +setBoolean(int *flag, term_t old, term_t new) +{ if ( !PL_unify_bool_ex(old, *flag) || + !PL_get_bool_ex(new, flag) ) + fail; + + succeed; +} + +static inline word +setInteger(int *flag, term_t old, term_t new) +{ if ( !PL_unify_integer(old, *flag) || + !PL_get_integer_ex(new, flag) ) + fail; + + succeed; +} + +#if defined(__SWI_PROLOG__) + +static inline word +INIT_SEQ_CODES(size_t n) +{ + return allocGlobal(1+(n)*3); /* TBD: shift */ +} + +static inline word +EXTEND_SEQ_CODES(word gstore, int c) { + *gstore = consPtr(&gstore[1], TAG_COMPOUND|STG_GLOBAL); + gstore++; + *gstore++ = FUNCTOR_dot2; + *gstore++ = consInt(c); + return gstore; +} + +static inline int +CLOSE_SEQ_OF_CODES(word gstore, word lp, word A2, word A3)) { + setVar(*gstore); + gTop = gstore+1; + + a = valTermRef(A2); + deRef(a); + if ( !unify_ptrs(a, lp PASS_LD) ) + return FALSE; + a = valTermRef(A3); + deRef(a); + if ( !unify_ptrs(a, gstore PASS_LD) ) + return FALSE; + return TRUE; +} + +#else + +#endif diff --git a/LGPL/PLStream/pl-opts.h b/LGPL/PLStream/pl-opts.h new file mode 100644 index 000000000..f4aeffd2c --- /dev/null +++ b/LGPL/PLStream/pl-opts.h @@ -0,0 +1,24 @@ + /******************************* + * OPTION LISTS * + *******************************/ + +#define OPT_BOOL (0) /* types */ +#define OPT_INT (1) +#define OPT_STRING (2) +#define OPT_ATOM (3) +#define OPT_TERM (4) /* arbitrary term */ +#define OPT_LONG (5) +#define OPT_NATLONG (6) /* > 0 */ +#define OPT_TYPE_MASK 0xff +#define OPT_INF 0x100 /* allow 'inf' */ + +#define OPT_ALL 0x1 /* flags */ + +typedef struct +{ atom_t name; /* Name of option */ + int type; /* Type of option */ +} opt_spec, *OptSpec; + +extern bool scan_options(term_t options, int flags, atom_t optype, + const opt_spec *specs, ...); + diff --git a/LGPL/PLStream/pl-os.c b/LGPL/PLStream/pl-os.c new file mode 100644 index 000000000..dd937a6de --- /dev/null +++ b/LGPL/PLStream/pl-os.c @@ -0,0 +1,3157 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: wielemak@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2007, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +/* Modified (M) 1993 Dave Sherratt */ + +/*#define O_DEBUG 1*/ + +#if __TOS__ +#include /* before pl-os.h due to Fopen, ... */ +#endif +#if OS2 && EMX +#include /* this has to appear before pl-incl.h */ +#endif + +#include "pl-incl.h" +#include "pl-ctype.h" +#include "pl-utf8.h" +#undef abs +#include /* avoid abs() problem with msvc++ */ +#include /* rename() and remove() prototypes */ + +#if HAVE_SYS_STAT_H +#include +#endif +#if !O_XOS +#define statfunc stat +#endif +#if HAVE_PWD_H +#include +#endif +#if HAVE_VFORK_H +#include +#endif +#ifdef HAVE_UNISTD_H +#include +#endif +#ifdef HAVE_SYS_FILE_H +#include +#endif +#if defined(HAVE_SYS_RESOURCE_H) +#include +#endif +#ifdef HAVE_FTIME +#include +#endif +#include +#include +#ifndef __WATCOMC__ /* appears a conflict */ +#include +#endif + +#if defined(__WATCOMC__) +#include +#include +#endif + +#ifdef __WINDOWS__ +#define STAT_TYPE struct _stat +#else +#define STAT_TYPE struct stat +#endif + +#if OS2 && EMX +static real initial_time; +#endif /* OS2 */ + +#define LOCK() PL_LOCK(L_OS) +#define UNLOCK() PL_UNLOCK(L_OS) + +static void initExpand(void); +static void cleanupExpand(void); +static void initEnviron(void); +static char * Which(const char *program, char *fullname); + +#ifndef DEFAULT_PATH +#define DEFAULT_PATH "/bin:/usr/bin" +#endif + + /******************************* + * GLOBALS * + *******************************/ +#ifdef HAVE_CLOCK +intptr_t clock_wait_ticks; +#endif + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +This module is a contraction of functions that used to be all over the +place. together with pl-os.h (included by pl-incl.h) this file +should define a basic layer around the OS, on which the rest of +SWI-Prolog is based. SWI-Prolog has been developed on SUN, running +SunOs 3.4 and later 4.0. + +Unfortunately some OS's simply do not offer an equivalent to SUN os +features. In most cases part of the functionality of the system will +have to be dropped. See the header of pl-incl.h for details. +- - - - - - - - - - - - - - - - */ + + /******************************** + * INITIALISATION * + *********************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + bool initOs() + + Initialise the OS dependant functions. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +bool +initOs(void) +{ DEBUG(1, Sdprintf("OS:initExpand() ...\n")); + initExpand(); + DEBUG(1, Sdprintf("OS:initEnviron() ...\n")); + initEnviron(); + +#ifdef __WINDOWS__ + set(&features, FILE_CASE_PRESERVING_FEATURE); +#else + set(&features, FILE_CASE_FEATURE); + set(&features, FILE_CASE_PRESERVING_FEATURE); +#endif + +#ifdef HAVE_CLOCK + clock_wait_ticks = 0L; +#endif + +#if OS2 + { DATETIME i; + DosGetDateTime((PDATETIME)&i); + initial_time = (i.hours * 3600.0) + + (i.minutes * 60.0) + + i.seconds + + (i.hundredths / 100.0); + } +#endif /* OS2 */ + + DEBUG(1, Sdprintf("OS:done\n")); + + succeed; +} + + +void +cleanupOs(void) +{ cleanupExpand(); +} + + + /******************************** + * OS ERRORS * + *********************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + char *OsError() + Return a char *, holding a description of the last OS call error. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +char * +OsError(void) +{ +#ifdef HAVE_STRERROR +#ifdef __WINDOWS__ + return strerror(_xos_errno()); +#else + return strerror(errno); +#endif +#else /*HAVE_STRERROR*/ +static char errmsg[64]; + +#ifdef __unix__ + extern int sys_nerr; +#if !EMX && SWI_PROLOG /* VSC */ + extern char *sys_errlist[]; +#endif + extern int errno; + + if ( errno < sys_nerr ) + return sys_errlist[errno]; +#endif + + Ssprintf(errmsg, "Unknown Error (%d)", errno); + return errmsg; +#endif /*HAVE_STRERROR*/ +} + + /******************************** + * PROCESS CHARACTERISTICS * + *********************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + double CpuTime(cputime_kind) + + Returns a floating point number, representing the amount of (user) + CPU-seconds used by the process Prolog is in. For systems that do + not allow you to obtain this information you may wish to return + elapsed time since Prolog was started, as this function is used to + by consult/1 and time/1 to determine the amount of CPU time used to + consult a file or to execute a query. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#ifndef __WINDOWS__ /* defined in pl-nt.c */ + +#ifdef HAVE_TIMES +#include + +#if defined(_SC_CLK_TCK) +#define Hz ((int)sysconf(_SC_CLK_TCK)) +#else +#ifdef HZ +# define Hz HZ +#else +# define Hz 60 /* if nothing better: guess */ +#endif +#endif /*_SC_CLK_TCK*/ +#endif /*HAVE_TIMES*/ + + +double +CpuTime(cputime_kind which) +{ +#ifdef HAVE_TIMES + struct tms t; + double used; + static int MTOK_got_hz = FALSE; + static double MTOK_hz; + + if ( !MTOK_got_hz ) + { MTOK_hz = (double) Hz; + MTOK_got_hz++; + } + times(&t); + + switch( which ) + { case CPU_USER: + used = (double) t.tms_utime / MTOK_hz; + break; + case CPU_SYSTEM: + default: /* make compiler happy */ + used = (double) t.tms_stime / MTOK_hz; + } + + if ( isnan(used) ) /* very dubious, but this */ + used = 0.0; /* happens when running under GDB */ + + return used; +#else + +#if OS2 && EMX + DATETIME i; + + DosGetDateTime((PDATETIME)&i); + return (((i.hours * 3600) + + (i.minutes * 60) + + i.seconds + + (i.hundredths / 100.0)) - initial_time); +#else + +#ifdef HAVE_CLOCK + return (real) (clock() - clock_wait_ticks) / (real) CLOCKS_PER_SEC; +#else + + return 0.0; + +#endif +#endif +#endif +} + +#endif /*__WINDOWS__*/ + +void +PL_clock_wait_ticks(intptr_t waited) +{ +#ifdef HAVE_CLOCK + clock_wait_ticks += waited; +#endif +} + + +double +WallTime(void) +{ double stime; + +#if HAVE_CLOCK_GETTIME + struct timespec tp; + + clock_gettime(CLOCK_REALTIME, &tp); + stime = (double)tp.tv_sec + (double)tp.tv_nsec/1000000000.0; +#else +#ifdef HAVE_GETTIMEOFDAY + struct timeval tp; + + gettimeofday(&tp, NULL); + stime = (double)tp.tv_sec + (double)tp.tv_usec/1000000.0; +#else +#ifdef HAVE_FTIME + struct timeb tb; + + ftime(&tb); + stime = (double)tb.time + (double)tb.millitm/1000.0; +#else + stime = (double)time((time_t *)NULL); +#endif +#endif +#endif + + return stime; +} + + /******************************* + * FEATURES * + *******************************/ + +#ifndef __WINDOWS__ /* Windows version in pl-nt.c */ + +#ifdef HAVE_SC_NPROCESSORS_CONF +static int +CpuCount() +{ + return sysconf(_SC_NPROCESSORS_CONF); +} +#else + +#ifdef PROCFS_CPUINFO +static int +CpuCount() +{ FILE *fd = fopen("/proc/cpuinfo", "r"); + + if ( fd ) + { char buf[256]; + int count = 0; + + while(fgets(buf, sizeof(buf)-1, fd)) + { char *vp; + + if ( (vp = strchr(buf, ':')) ) + { char *en; + + for(en=vp; en > buf && en[-1] <= ' '; en--) + ; + *en = EOS; + DEBUG(2, Sdprintf("Got %s = %s\n", buf, vp+2)); + if ( streq("processor", buf) && isDigit(vp[2]) ) + { int cpu = atoi(vp+2); + + if ( cpu+1 > count ) + count = cpu+1; + } + } + } + + fclose(fd); + return count; + } + + return 0; +} + +#else /*PROCFS_CPUINFO*/ + +#ifdef HAVE_SYSCTLBYNAME /* MacOS X */ + +#include +#include + +int +CpuCount() +{ int count ; + size_t size=sizeof(count) ; + + if ( sysctlbyname("hw.ncpu", &count, &size, NULL, 0) ) + return 0; + + return count; +} + +#else + +#define CpuCount() 0 + +#endif /*sysctlbyname*/ + +#endif /*PROCFS_CPUINFO*/ + +#endif /*HAVE_SC_NPROCESSORS_CONF*/ + + +void +setOSFeatures(void) +{ int cpu_count = CpuCount(); + + if ( cpu_count > 0 ) + defFeature("cpu_count", FT_INTEGER, cpu_count); +} +#endif + + /******************************* + * MEMORY * + *******************************/ +#if SWI_PROLOG +uintptr_t +UsedMemory(void) +{ +#if defined(HAVE_GETRUSAGE) && defined(HAVE_RU_IDRSS) + struct rusage usage; + + if ( getrusage(RUSAGE_SELF, &usage) == 0 && + usage.ru_idrss ) + { return usage.ru_idrss; /* total unshared data */ + } +#endif + + return (GD->statistics.heap + + usedStack(global) + + usedStack(local) + + usedStack(trail)); +} +#else +uintptr_t +UsedMemory(void) +{ + return 0; +} +#endif + + +uintptr_t +FreeMemory(void) +{ +#if defined(HAVE_GETRLIMIT) && defined(RLIMIT_DATA) + uintptr_t used = UsedMemory(); + struct rlimit limit; + + if ( getrlimit(RLIMIT_DATA, &limit) == 0 ) + return limit.rlim_cur - used; +#endif + + return 0L; +} + + + /******************************** + * ARITHMETIC * + *********************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + uint64_t _PL_Random() + + Return a random number. Used for arithmetic only. More trouble. On + some systems (__WINDOWS__) the seed of rand() is thread-local, while on + others it is global. We appear to have the choice between + + # srand()/rand() + Differ in MT handling, often bad distribution + + # srandom()/random() + Not portable, not MT-Safe but much better distribution + + # drand48() and friends + Depreciated according to Linux manpage, suggested by Solaris + manpage. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static void +initRandom(void) +{ unsigned int seed; + +#ifdef __WINDOWS__ + seed = (unsigned int)GetTickCount(); +#else +#ifdef HAVE_GETTIMEOFDAY + struct timeval tp; + + gettimeofday(&tp, NULL); + seed = (unsigned int)(tp.tv_sec + tp.tv_usec); +#else + seed = (unsigned int)time((time_t *) NULL); +#endif +#endif + +#ifdef HAVE_SRANDOM + srandom(seed); +#else +#ifdef HAVE_SRAND + srand(seed); +#endif +#endif +} + +uint64_t +_PL_Random(void) +{ if ( !LD->os.rand_initialised ) + { initRandom(); + LD->os.rand_initialised = TRUE; + } + +#ifdef HAVE_RANDOM +#if SIZEOF_VOIDP == 4 + { uint64_t l = random(); + + l ^= (uint64_t)random()<<32; + + return l; + } +#else + return random(); +#endif +#else + { uint64_t l = rand(); /* 0os._tmpfile_head) +#define tmpfile_tail (GD->os._tmpfile_tail) + +#ifndef DEFTMPDIR +#ifdef __WINDOWS__ +#define DEFTMPDIR "c:/tmp" +#else +#define DEFTMPDIR "/tmp" +#endif +#endif + +atom_t +TemporaryFile(const char *id) +{ char temp[MAXPATHLEN]; + TempFile tf = allocHeap(sizeof(struct tempfile)); + char envbuf[MAXPATHLEN]; + char *tmpdir; + + if ( !((tmpdir = Getenv("TEMP", envbuf, sizeof(envbuf))) || + (tmpdir = Getenv("TMP", envbuf, sizeof(envbuf)))) ) + tmpdir = DEFTMPDIR; + +#ifdef __unix__ +{ static int MTOK_temp_counter = 0; + + Ssprintf(temp, "%s/pl_%s_%d_%d", + tmpdir, id, (int) getpid(), MTOK_temp_counter++); +} +#endif + +#ifdef __WINDOWS__ +{ char *tmp; + static int temp_counter = 0; + +#ifdef __LCC__ + if ( (tmp = tmpnam(NULL)) ) +#else + if ( (tmp = _tempnam(tmpdir, id)) ) +#endif + { PrologPath(tmp, temp, sizeof(temp)); + } else + Ssprintf(temp, "%s/pl_%s_%d", tmpdir, id, temp_counter++); +} +#endif + +#if EMX + static int temp_counter = 0; + char *foo; + + if ( (foo = tempnam(".", (const char *)id)) ) + { strcpy(temp, foo); + free(foo); + } else + Ssprintf(temp, "pl_%s_%d_%d", id, getpid(), temp_counter++); +#endif + +#if tos + tmpnam(temp); +#endif + + tf->name = PL_new_atom(temp); /* locked: ok! */ + tf->next = NULL; + + startCritical; + if ( !tmpfile_tail ) + { tmpfile_head = tmpfile_tail = tf; + } else + { tmpfile_tail->next = tf; + tmpfile_tail = tf; + } + endCritical; + + return tf->name; +} + +void +RemoveTemporaryFiles(void) +{ TempFile tf, tf2; + + startCritical; + for(tf = tmpfile_head; tf; tf = tf2) + { RemoveFile(stringAtom(tf->name)); + tf2 = tf->next; + freeHeap(tf, sizeof(struct tempfile)); + } + + tmpfile_head = tmpfile_tail = NULL; + endCritical; +} + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Fortunately most C-compilers are sold with a library that defines +Unix-style access to the file system. The standard functions go via +macros to deal with 16-bit machines, but are not defined as functions +here. Some more specific things SWI-Prolog wants to know about files +are defined here: + + intptr_t LastModifiedFile(path) + char *path; + + Returns the last time `path' has been modified. Used by the source + file administration to implement make/0. + + bool ExistsFile(path) + char *path; + + Succeeds if `path' refers to the pathname of a regular file (not a + directory). + + bool AccessFile(path, mode) + char *path; + int mode; + + Succeeds if `path' is the pathname of an existing file and it can + be accessed in any of the inclusive or constructed argument `mode'. + + bool ExistsDirectory(path) + char *path; + + Succeeds if `path' refers to the pathname of a directory. + + bool RemoveFile(path) + char *path; + + Removes a (regular) file from the file system. Returns TRUE if + succesful FALSE otherwise. + + bool RenameFile(old, new) + char *old, *new; + + Rename file from name `old' to name `new'. If new already exists, it is + deleted. Returns TRUE if succesful, FALSE otherwise. + + bool OpenStream(stream) + int stream; + + Succeeds if `stream' refers to an open i/o stream. + + bool MarkExecutable(path) + char *path; + + Mark `path' as an executable program. Used by the intermediate code + compiler and the creation of stand-alone executables. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Size of a VM page of memory. Most BSD machines have this function. If not, +here are several alternatives ... +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#ifndef HAVE_GETPAGESIZE +#ifdef _SC_PAGESIZE +int +getpagesize() +{ return sysconf(_SC_PAGESIZE); +} +#else /*_SC_PAGESIZE*/ + +#if hpux +#include +int +getpagesize() +{ +#ifdef EXEC_PAGESIZE + return EXEC_PAGESIZE; +#else + return 4096; /* not that important */ +#endif +} +#endif /*hpux*/ +#endif /*_SC_PAGESIZE*/ +#endif /*HAVE_GETPAGESIZE*/ + +#if O_HPFS + +/* Conversion rules Prolog <-> OS/2 (using HPFS) + / <-> \ + /x:/ <-> x:\ (embedded drive letter) + No length restrictions up to MAXPATHLEN, no case conversions. +*/ + +char * +PrologPath(char *ospath, char *path, size_t len) +{ char *s = ospath, *p = path; + int limit = len-1; + + if (isLetter(s[0]) && s[1] == ':') + { *p++ = '/'; + *p++ = *s++; + *p++ = *s++; + limit -= 3; + } + for(; *s && limit; s++, p++, limit--) + *p = (*s == '\\' ? '/' : makeLower(*s)); + *p = EOS; + + return path; +} + + +char * +OsPath(const char *plpath, char *path) +{ const char *s = plpath, *p = path; + int limit = MAXPATHLEN-1; + + if ( s[0] == '/' && isLetter(s[1]) && s[2] == ':') /* embedded drive letter*/ + { s++; + *p++ = *s++; + *p++ = *s++; + if ( *s != '/' ) + *p++ = '\\'; + limit -= 2; + } + + for(; *s && limit; s++, p++, limit--) + *p = (*s == '/' ? '\\' : *s); + if ( p[-1] == '\\' && p > path ) + p--; + *p = EOS; + + return path; +} +#endif /* O_HPFS */ + +#ifdef __unix__ +char * +PrologPath(const char *p, char *buf, size_t len) +{ strncpy(buf, p, len); + + return buf; +} + +char * +OsPath(const char *p, char *buf) +{ strcpy(buf, p); + + return buf; +} +#endif /*__unix__*/ + +#if O_XOS +char * +PrologPath(const char *p, char *buf, size_t len) +{ int flags = (trueFeature(FILE_CASE_FEATURE) ? 0 : XOS_DOWNCASE); + + return _xos_canonical_filename(p, buf, len, flags); +} + +char * +OsPath(const char *p, char *buf) +{ strcpy(buf, p); + + return buf; +} +#endif /* O_XOS */ + +intptr_t +LastModifiedFile(char *f) +{ char tmp[MAXPATHLEN]; + +#if defined(HAVE_STAT) || defined(__unix__) + STAT_TYPE buf; + + if ( statfunc(OsPath(f, tmp), &buf) < 0 ) + return -1; + + return (intptr_t)buf.st_mtime; +#endif + +#if tos +#define DAY (24*60*60L) + static int msize[] = {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}; + intptr_t t; + int n; + struct ffblk buf; + struct dz + { unsigned int hour : 5; /* hour (0-23) */ + unsigned int min : 6; /* minute (0-59) */ + unsigned int sec : 5; /* seconds in steps of 2 */ + unsigned int year : 7; /* year (0=1980) */ + unsigned int mon : 4; /* month (1-12) */ + unsigned int day : 5; /* day (1-31) */ + } *dz; + + if ( findfirst(OsPath(f, tmp), &buf, FA_HIDDEN) != 0 ) + return -1; + dz = (struct dz *) &buf.ff_ftime; + DEBUG(2, Sdprintf("%d/%d/%d %d:%d:%d\n", + dz->day, dz->mon, dz->year+1980, dz->hour, dz->min, dz->sec)); + + t = (10*365+2) * DAY; /* Start of 1980 */ + for(n=0; n < dz->year; n++) + t += ((n % 4) == 0 ? 366 : 365) * DAY; + for(n=1; n < dz->mon; n++) + t += msize[n+1] * DAY; + t += (dz->sec * 2) + (dz->min * 60) + (dz->hour *60*60L); + + return t; +#endif +} + + +#ifndef F_OK +#define F_OK 0 +#endif + +bool +ExistsFile(const char *path) +{ +#ifdef O_XOS + return _xos_exists(path, _XOS_FILE); +#else + char tmp[MAXPATHLEN]; + +#if defined(HAVE_STAT) || defined(__unix__) + struct stat buf; + + if ( statfunc(OsPath(path, tmp), &buf) == -1 || !S_ISREG(buf.st_mode) ) + { DEBUG(2, perror(tmp)); + fail; + } + succeed; +#endif + +#if tos + struct ffblk buf; + + if ( findfirst(OsPath(path, tmp), &buf, FA_HIDDEN) == 0 ) + { DEBUG(2, Sdprintf("%s (%s) exists\n", path, OsPath(path))); + succeed; + } + DEBUG(2, Sdprintf("%s (%s) does not exist\n", path, OsPath(path))); + fail; +#endif +#endif +} + + +bool +AccessFile(const char *path, int mode) +{ char tmp[MAXPATHLEN]; +#ifdef HAVE_ACCESS + int m = 0; + + if ( mode == ACCESS_EXIST ) + m = F_OK; + else + { if ( mode & ACCESS_READ ) m |= R_OK; + if ( mode & ACCESS_WRITE ) m |= W_OK; +#ifdef X_OK + if ( mode & ACCESS_EXECUTE ) m |= X_OK; +#endif + } + + return access(OsPath(path, tmp), m) == 0 ? TRUE : FALSE; +#endif + +#ifdef tos + struct ffblk buf; + + if ( findfirst(OsPath(path, tmp), &buf, FA_DIREC|FA_HIDDEN) != 0 ) + fail; /* does not exists */ + if ( (mode & ACCESS_WRITE) && (buf.ff_attrib & FA_RDONLY) ) + fail; /* readonly file */ + + succeed; +#endif +} + + +bool +ExistsDirectory(const char *path) +{ +#ifdef O_XOS + return _xos_exists(path, _XOS_DIR); +#else + char tmp[MAXPATHLEN]; + char *ospath = OsPath(path, tmp); + +#if defined(HAVE_STAT) || defined(__unix__) + struct stat buf; + + if ( statfunc(ospath, &buf) < 0 ) + fail; + + if ( S_ISDIR(buf.st_mode) ) + succeed; + + fail; +#endif + +#ifdef tos + struct ffblk buf; + + if ( findfirst(ospath, &buf, FA_DIREC|FA_HIDDEN) == 0 && + buf.ff_attrib & FA_DIREC ) + succeed; + if ( streq(ospath, ".") || streq(ospath, "..") ) /* hack */ + succeed; + fail; +#endif +#endif /*O_XOS*/ +} + + +int64_t +SizeFile(const char *path) +{ char tmp[MAXPATHLEN]; + STAT_TYPE buf; + +#if defined(HAVE_STAT) || defined(__unix__) + if ( statfunc(OsPath(path, tmp), &buf) < 0 ) + return -1; +#endif + + return buf.st_size; +} + + +int +RemoveFile(const char *path) +{ char tmp[MAXPATHLEN]; + +#ifdef HAVE_REMOVE + return remove(OsPath(path, tmp)) == 0 ? TRUE : FALSE; +#else + return unlink(OsPath(path, tmp)) == 0 ? TRUE : FALSE; +#endif +} + + +bool +RenameFile(const char *old, const char *new) +{ char oldbuf[MAXPATHLEN]; + char newbuf[MAXPATHLEN]; + char *osold, *osnew; + + osold = OsPath(old, oldbuf); + osnew = OsPath(new, newbuf); + +#ifdef HAVE_RENAME + remove(osnew); /* assume we have this too */ + return rename(osold, osnew) == 0 ? TRUE : FALSE; +#else +{ int rval; + + unlink(osnew); + if ( (rval = link(osold, osnew)) == 0 + && (rval = unlink(osold)) != 0) + unlink(osnew); + + if ( rval == 0 ) + succeed; + + fail; +} +#endif /*HAVE_RENAME*/ +} + +bool +SameFile(const char *f1, const char *f2) +{ if ( trueFeature(FILE_CASE_FEATURE) ) + { if ( streq(f1, f2) ) + succeed; + } else + { if ( strcasecmp(f1, f2) == 0 ) + succeed; + } + +#ifdef __unix__ /* doesn't work on most not Unix's */ + { struct stat buf1; + struct stat buf2; + char tmp[MAXPATHLEN]; + + if ( statfunc(OsPath(f1, tmp), &buf1) != 0 || + statfunc(OsPath(f2, tmp), &buf2) != 0 ) + fail; + if ( buf1.st_ino == buf2.st_ino && buf1.st_dev == buf2.st_dev ) + succeed; + } +#endif +#ifdef O_XOS + return _xos_same_file(f1, f2); +#endif /*O_XOS*/ + /* Amazing! There is no simple way to check two files for identity. */ + /* stat() and fstat() both return dummy values for inode and device. */ + /* this is fine as OS'es not supporting symbolic links don't need this */ + + fail; +} + + +bool +MarkExecutable(const char *name) +{ +#if (defined(HAVE_STAT) && defined(HAVE_CHMOD)) || defined(__unix__) + STAT_TYPE buf; + mode_t um; + + um = umask(0777); + umask(um); + if ( statfunc(name, &buf) == -1 ) + { term_t file = PL_new_term_ref(); + + PL_put_atom_chars(file, name); + return PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION, + ATOM_stat, ATOM_file, file); + } + + if ( (buf.st_mode & 0111) == (~um & 0111) ) + succeed; + + buf.st_mode |= 0111 & ~um; + if ( chmod(name, buf.st_mode) == -1 ) + { term_t file = PL_new_term_ref(); + + PL_put_atom_chars(file, name); + return PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION, + ATOM_chmod, ATOM_file, file); + } +#endif /* defined(HAVE_STAT) && defined(HAVE_CHMOD) */ + + succeed; +} + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + char *AbsoluteFile(const char *file, char *path) + + Expand a file specification to a system-wide unique description of + the file that can be passed to the file functions that take a path + as argument. Path should refer to the same file, regardless of the + current working directory. On Unix absolute file names are used + for this purpose. + + This function is based on a similar (primitive) function in + Edinburgh C-Prolog. + + char *BaseName(path) + char *path; + + Return the basic file name for a file having path `path'. + + char *DirName(const char *path, char *dir) + + Return the directory name for a file having path `path'. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#if defined(HAVE_SYMLINKS) && (defined(HAVE_STAT) || defined(__unix__)) +#define O_CANONISE_DIRS + +struct canonical_dir +{ char * name; /* name of directory */ + char * canonical; /* canonical name of directory */ + dev_t device; /* device number */ + ino_t inode; /* inode number */ + CanonicalDir next; /* next in chain */ +}; + +#define canonical_dirlist (GD->os._canonical_dirlist) + +forwards char *canoniseDir(char *); +#endif /*O_CANONISE_DIRS*/ + +#define CWDdir (LD->os._CWDdir) /* current directory */ +#define CWDlen (LD->os._CWDlen) /* strlen(CWDdir) */ + +static void +initExpand(void) +{ +#ifdef O_CANONISE_DIRS + char *dir; + char *cpaths; +#endif + + CWDdir = NULL; + CWDlen = 0; + +#ifdef O_CANONISE_DIRS +{ char envbuf[MAXPATHLEN]; + + if ( (cpaths = Getenv("CANONICAL_PATHS", envbuf, sizeof(envbuf))) ) + { char buf[MAXPATHLEN]; + + while(*cpaths) + { char *e; + + if ( (e = strchr(cpaths, ':')) ) + { int l = e-cpaths; + + strncpy(buf, cpaths, l); + buf[l] = EOS; + cpaths += l+1; + canoniseDir(buf); + } else + { canoniseDir(cpaths); + break; + } + } + } + + if ( (dir = Getenv("HOME", envbuf, sizeof(envbuf))) ) canoniseDir(dir); + if ( (dir = Getenv("PWD", envbuf, sizeof(envbuf))) ) canoniseDir(dir); + if ( (dir = Getenv("CWD", envbuf, sizeof(envbuf))) ) canoniseDir(dir); +} +#endif +} + +#ifdef O_CANONISE_DIRS + +static void +cleanupExpand(void) +{ CanonicalDir dn = canonical_dirlist, next; + + canonical_dirlist = NULL; + for( ; dn; dn = next ) + { next = dn->next; + free(dn); + } +} + + +static void +registerParentDirs(const char *path) +{ const char *e = path + strlen(path); + + while(e>path) + { char dirname[MAXPATHLEN]; + char tmp[MAXPATHLEN]; + CanonicalDir d; + struct stat buf; + + for(e--; *e != '/' && e > path + 1; e-- ) + ; + + strncpy(dirname, path, e-path); + dirname[e-path] = EOS; + + for(d = canonical_dirlist; d; d = d->next) + { if ( streq(d->name, dirname) ) + return; + } + + if ( statfunc(OsPath(dirname, tmp), &buf) == 0 ) + { CanonicalDir dn = malloc(sizeof(*dn)); + + dn->name = store_string(dirname); + dn->inode = buf.st_ino; + dn->device = buf.st_dev; + dn->canonical = dn->name; + dn->next = canonical_dirlist; + canonical_dirlist = dn; + + DEBUG(1, Sdprintf("Registered canonical dir %s\n", dirname)); + } else + return; + } +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +verify_entry() verifies the path cache for this path is still safe. If +not it updates the cache and returns FALSE. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static int +verify_entry(CanonicalDir d) +{ char tmp[MAXPATHLEN]; + struct stat buf; + + if ( statfunc(OsPath(d->canonical, tmp), &buf) == 0 ) + { if ( d->inode == buf.st_ino && + d->device == buf.st_dev ) + return TRUE; + + DEBUG(1, Sdprintf("%s: inode/device changed\n", d->canonical)); + + d->inode = buf.st_ino; + d->device = buf.st_dev; + } else + { DEBUG(1, Sdprintf("%s: no longer exists\n", d->canonical)); + + if ( d == canonical_dirlist ) + { canonical_dirlist = d->next; + } else + { CanonicalDir cd; + + for(cd=canonical_dirlist; cd; cd=cd->next) + { if ( cd->next == d ) + { cd->next = d->next; + break; + } + } + } + + free(d); + } + + return FALSE; +} + + +static char * +canoniseDir(char *path) +{ CanonicalDir d, next; + struct stat buf; + char tmp[MAXPATHLEN]; + + DEBUG(1, Sdprintf("canoniseDir(%s) --> ", path)); + + for(d = canonical_dirlist; d; d = next) + { next = d->next; + + if ( streq(d->name, path) && verify_entry(d) ) + { if ( d->name != d->canonical ) + strcpy(path, d->canonical); + + DEBUG(1, Sdprintf("(lookup) %s\n", path)); + return path; + } + } + + /* we need to use malloc() here */ + /* because allocHeap() only ensures */ + /* alignment for `word', and inode_t */ + /* is sometimes bigger! */ + + if ( statfunc(OsPath(path, tmp), &buf) == 0 ) + { CanonicalDir dn = malloc(sizeof(*dn)); + char dirname[MAXPATHLEN]; + char *e = path + strlen(path); + + dn->name = store_string(path); + dn->inode = buf.st_ino; + dn->device = buf.st_dev; + + do + { strncpy(dirname, path, e-path); + dirname[e-path] = EOS; + if ( statfunc(OsPath(dirname, tmp), &buf) < 0 ) + break; + + DEBUG(2, Sdprintf("Checking %s (dev=%d,ino=%d)\n", + dirname, buf.st_dev, buf.st_ino)); + + for(d = canonical_dirlist; d; d = next) + { next = d->next; + + if ( d->inode == buf.st_ino && d->device == buf.st_dev && + verify_entry(d) ) + { DEBUG(2, Sdprintf("Hit with %s (dev=%d,ino=%d)\n", + d->canonical, d->device, d->inode)); + + strcpy(dirname, d->canonical); + strcat(dirname, e); + strcpy(path, dirname); + dn->canonical = store_string(path); + dn->next = canonical_dirlist; + canonical_dirlist = dn; + DEBUG(1, Sdprintf("(replace) %s\n", path)); + registerParentDirs(path); + return path; + } + } + + for(e--; *e != '/' && e > path + 1; e-- ) + ; + } while( e > path ); + + dn->canonical = dn->name; + dn->next = canonical_dirlist; + canonical_dirlist = dn; + + DEBUG(1, Sdprintf("(new, existing) %s\n", path)); + registerParentDirs(path); + return path; + } + + DEBUG(1, Sdprintf("(nonexisting) %s\n", path)); + return path; +} + +#else + +#define canoniseDir(d) + +static void +cleanupExpand(void) +{ +} + +#endif /*O_CANONISE_DIRS*/ + + +static char * +canoniseFileName(char *path) +{ char *out = path, *in = path, *start = path; + char *osave[100]; + int osavep = 0; + +#ifdef O_HASDRIVES /* C: */ + if ( in[1] == ':' && isLetter(in[0]) ) + { in += 2; + + out = start = in; + } +#endif +#ifdef O_HASSHARES /* //host/ */ + if ( in[0] == '/' && in[1] == '/' && isAlpha(in[2]) ) + { char *s; + + for(s = in+3; *s && (isAlpha(*s) || *s == '.'); s++) + ; + if ( *s == '/' ) + { in = out = s+1; + start = in-1; + } + } +#endif + + while( in[0] == '/' && in[1] == '.' && in[2] == '.' && in[3] == '/' ) + in += 3; + while( in[0] == '.' && in[1] == '/' ) + in += 2; + if ( in[0] == '/' ) + *out++ = '/'; + osave[osavep++] = out; + + while(*in) + { if (*in == '/') + { + again: + if ( *in ) + { while( in[1] == '/' ) /* delete multiple / */ + in++; + if ( in[1] == '.' ) + { if ( in[2] == '/' ) /* delete /./ */ + { in += 2; + goto again; + } + if ( in[2] == EOS ) /* delete trailing /. */ + { *out = EOS; + return path; + } + if ( in[2] == '.' && (in[3] == '/' || in[3] == EOS) ) + { if ( osavep > 0 ) /* delete /foo/../ */ + { out = osave[--osavep]; + in += 3; + if ( in[0] == EOS && out > start+1 ) + { out[-1] = EOS; /* delete trailing / */ + return path; + } + goto again; + } else if ( start[0] == '/' && out == start+1 ) + { in += 3; + goto again; + } + } + } + } + if ( *in ) + in++; + if ( out > path && out[-1] != '/' ) + *out++ = '/'; + osave[osavep++] = out; + } else + *out++ = *in++; + } + *out++ = *in++; + + return path; +} + + +static char * +utf8_strlwr(char *s) +{ char tmp[MAXPATHLEN]; + char *o, *i; + + strcpy(tmp, s); + for(i=tmp, o=s; *i; ) + { int c; + + i = utf8_get_char(i, &c); + c = towlower((wint_t)c); + o = utf8_put_char(o, c); + } + *o = EOS; + + return s; +} + + +char * +canonisePath(char *path) +{ if ( !trueFeature(FILE_CASE_FEATURE) ) + utf8_strlwr(path); + + canoniseFileName(path); + +#ifdef O_CANONISE_DIRS +{ char *e; + char dirname[MAXPATHLEN]; + + e = path + strlen(path) - 1; + for( ; *e != '/' && e > path; e-- ) + ; + strncpy(dirname, path, e-path); + dirname[e-path] = EOS; + canoniseDir(dirname); + strcat(dirname, e); + strcpy(path, dirname); +} +#endif + + return path; +} + + +static char * +takeWord(const char **string, char *wrd, int maxlen) +{ const char *s = *string; + char *q = wrd; + int left = maxlen-1; + + while( isAlpha(*s) || *s == '_' ) + { if ( --left < 0 ) + { PL_error(NULL, 0, NULL, ERR_REPRESENTATION, + ATOM_max_variable_length); + return NULL; + } + *q++ = *s++; + } + *q = EOS; + + *string = s; + return wrd; +} + + +bool +expandVars(const char *pattern, char *expanded, int maxlen) +{ int size = 0; + char wordbuf[MAXPATHLEN]; + + if ( *pattern == '~' ) + { char *user; + char *value; + int l; + + pattern++; + user = takeWord(&pattern, wordbuf, sizeof(wordbuf)); + LOCK(); + + if ( user[0] == EOS ) /* ~/bla */ + { +#ifdef O_XOS + value = _xos_home(); +#else /*O_XOS*/ + if ( !(value = GD->os.myhome) ) + { char envbuf[MAXPATHLEN]; + + if ( (value = Getenv("HOME", envbuf, sizeof(envbuf))) && + (value = PrologPath(value, wordbuf, sizeof(wordbuf))) ) + { GD->os.myhome = store_string(value); + } else + { value = GD->os.myhome = store_string("/"); + } + } +#endif /*O_XOS*/ + } else /* ~fred */ +#ifdef HAVE_GETPWNAM + { struct passwd *pwent; + + if ( GD->os.fred && streq(GD->os.fred, user) ) + { value = GD->os.fredshome; + } else + { if ( !(pwent = getpwnam(user)) ) + { if ( fileerrors ) + { term_t name = PL_new_term_ref(); + + PL_put_atom_chars(name, user); + PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_user, name); + } + UNLOCK(); + fail; + } + if ( GD->os.fred ) + remove_string(GD->os.fred); + if ( GD->os.fredshome ) + remove_string(GD->os.fredshome); + + GD->os.fred = store_string(user); + value = GD->os.fredshome = store_string(pwent->pw_dir); + } + } +#else + { if ( fileerrors ) + PL_error(NULL, 0, NULL, ERR_NOT_IMPLEMENTED_FEATURE, "user_info"); + + UNLOCK(); + fail; + } +#endif + size += (l = (int) strlen(value)); + if ( size+1 >= maxlen ) + return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_path_length); + strcpy(expanded, value); + expanded += l; + UNLOCK(); + + /* ~/ should not become // */ + if ( expanded[-1] == '/' && pattern[0] == '/' ) + pattern++; + } + + for( ;; ) + { int c = *pattern++; + + switch( c ) + { case EOS: + break; + case '$': + { char envbuf[MAXPATHLEN]; + char *var = takeWord(&pattern, wordbuf, sizeof(wordbuf)); + char *value; + int l; + + if ( var[0] == EOS ) + goto def; + LOCK(); + value = Getenv(var, envbuf, sizeof(envbuf)); + if ( value == (char *) NULL ) + { if ( fileerrors ) + { term_t name = PL_new_term_ref(); + + PL_put_atom_chars(name, var); + PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_variable, name); + } + + UNLOCK(); + fail; + } + size += (l = (int)strlen(value)); + if ( size+1 >= maxlen ) + { UNLOCK(); + return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, + ATOM_max_path_length); + } + strcpy(expanded, value); + UNLOCK(); + + expanded += l; + + continue; + } + default: + def: + size++; + if ( size+1 >= maxlen ) + return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, + ATOM_max_path_length); + *expanded++ = c; + + continue; + } + break; + } + + if ( ++size >= maxlen ) + return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, + ATOM_max_path_length); + *expanded = EOS; + + succeed; +} + + +static int +ExpandFile(const char *pattern, char **vector) +{ char expanded[MAXPATHLEN]; + int matches = 0; + + if ( !expandVars(pattern, expanded, sizeof(expanded)) ) + return -1; + + vector[matches++] = store_string(expanded); + + return matches; +} + + +char * +ExpandOneFile(const char *spec, char *file) +{ char *vector[256]; + int size; + + switch( (size=ExpandFile(spec, vector)) ) + { case -1: + return NULL; + case 0: + { term_t tmp = PL_new_term_ref(); + + PL_put_atom_chars(tmp, spec); + PL_error(NULL, 0, "no match", ERR_EXISTENCE, ATOM_file, tmp); + + return NULL; + } + case 1: + strcpy(file, vector[0]); + remove_string(vector[0]); + return file; + default: + { term_t tmp = PL_new_term_ref(); + int n; + + for(n=0; n +#define mkdir _xos_mkdir +#endif + +static int +GetCurrentDriveLetter() +{ +#ifdef OS2 + return _getdrive(); +#endif +#ifdef __WINDOWS__ + return _getdrive() + 'a' - 1; +#endif +#ifdef __WATCOMC__ + { unsigned drive; + _dos_getdrive(&drive); + return = 'a' + drive - 1; + } +#endif +} + +#else /*O_HASDRIVES*/ + +int +IsAbsolutePath(const char *p) +{ return p[0] == '/'; +} + +#endif /*O_HASDRIVES*/ + +#define isRelativePath(p) ( p[0] == '.' ) + + +char * +AbsoluteFile(const char *spec, char *path) +{ char tmp[MAXPATHLEN]; + char buf[MAXPATHLEN]; + char *file = PrologPath(spec, buf, sizeof(buf)); + + if ( trueFeature(FILEVARS_FEATURE) ) + { if ( !(file = ExpandOneFile(buf, tmp)) ) + return (char *) NULL; + } + + if ( IsAbsolutePath(file) ) + { strcpy(path, file); + + return canonisePath(path); + } + +#ifdef O_HASDRIVES + if ( isDriveRelativePath(file) ) /* /something --> d:/something */ + { if ((strlen(file) + 3) > MAXPATHLEN) + { PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_path_length); + return (char *) NULL; + } + path[0] = GetCurrentDriveLetter(); + path[1] = ':'; + strcpy(&path[2], file); + return canonisePath(path); + } +#endif /*O_HASDRIVES*/ + + if ( !PL_cwd() ) + return NULL; + + if ( (CWDlen + strlen(file) + 1) >= MAXPATHLEN ) + { PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_path_length); + return (char *) NULL; + } + + strcpy(path, CWDdir); + if ( file[0] != EOS ) + strcpy(&path[CWDlen], file); + if ( strchr(file, '.') || strchr(file, '/') ) + return canonisePath(path); + else + return path; +} + + +void +PL_changed_cwd(void) +{ if ( CWDdir ) + remove_string(CWDdir); + CWDdir = NULL; + CWDlen = 0; +} + + +const char * +PL_cwd(void) +{ if ( CWDlen == 0 ) + { char buf[MAXPATHLEN]; + char *rval; + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +On SunOs, getcwd() is using popen() to read the output of /bin/pwd. This +is slow and appears not to cooperate with profile/3. getwd() is supposed +to be implemented directly. What about other Unixes? +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#if defined(HAVE_GETWD) && (defined(__sun__) || defined(__sun)) +#undef HAVE_GETCWD +#endif + +#if defined(HAVE_GETWD) && !defined(HAVE_GETCWD) + rval = getwd(buf); +#else + rval = getcwd(buf, sizeof(buf)); +#endif + if ( !rval ) + { term_t tmp = PL_new_term_ref(); + + PL_put_atom(tmp, ATOM_dot); + PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION, + ATOM_getcwd, ATOM_directory, tmp); + + return NULL; + } + + canonisePath(buf); + CWDlen = strlen(buf); + buf[CWDlen++] = '/'; + buf[CWDlen] = EOS; + + if ( CWDdir ) + remove_string(CWDdir); + CWDdir = store_string(buf); + } + + return (const char *)CWDdir; +} + + +char * +BaseName(const char *f) +{ const char *base; + + for(base = f; *f; f++) + { if (*f == '/') + base = f+1; + } + + return (char *)base; +} + + +char * +DirName(const char *f, char *dir) +{ const char *base, *p; + + for(base = p = f; *p; p++) + { if (*p == '/' && p[1] != EOS ) + base = p; + } + if ( base == f ) + { if ( *f == '/' ) + strcpy(dir, "/"); + else + strcpy(dir, "."); + } else + { if ( dir != f ) /* otherwise it is in-place */ + strncpy(dir, f, base-f); + dir[base-f] = EOS; + } + + return dir; +} + + +char * +ReadLink(const char *f, char *buf) +{ +#ifdef HAVE_READLINK + int n; + + if ( (n=readlink(f, buf, MAXPATHLEN-1)) > 0 ) + { buf[n] = EOS; + return buf; + } +#endif + + return NULL; +} + + +static char * +DeRefLink1(const char *f, char *lbuf) +{ char buf[MAXPATHLEN]; + char *l; + + if ( (l=ReadLink(f, buf)) ) + { if ( l[0] == '/' ) /* absolute path */ + { strcpy(lbuf, buf); + return lbuf; + } else + { char *q; + + strcpy(lbuf, f); + q = &lbuf[strlen(lbuf)]; + while(q>lbuf && q[-1] != '/') + q--; + strcpy(q, l); + + canoniseFileName(lbuf); + + return lbuf; + } + } + + return NULL; +} + + +char * +DeRefLink(const char *link, char *buf) +{ char tmp[MAXPATHLEN]; + char *f; + int n = 20; /* avoid loop! */ + + while((f=DeRefLink1(link, tmp)) && n-- > 0) + link = f; + + if ( n > 0 ) + { strcpy(buf, link); + return buf; + } else + return NULL; +} + + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + bool ChDir(path) + char *path; + + Change the current working directory to `path'. File names may depend + on `path'. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +bool +ChDir(const char *path) +{ char ospath[MAXPATHLEN]; + char tmp[MAXPATHLEN]; + + OsPath(path, ospath); + + if ( path[0] == EOS || streq(path, ".") || + (CWDdir && streq(path, CWDdir)) ) + succeed; + + AbsoluteFile(path, tmp); + + if ( chdir(ospath) == 0 ) + { size_t len; + + len = strlen(tmp); + if ( len == 0 || tmp[len-1] != '/' ) + { tmp[len++] = '/'; + tmp[len] = EOS; + } + CWDlen = len; + if ( CWDdir ) + remove_string(CWDdir); + CWDdir = store_string(tmp); + + succeed; + } + + fail; +} + + + /******************************** + * TIME CONVERSION * + *********************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + struct tm *LocalTime(time, struct tm *r) + intptr_t *time; + + Convert time in Unix internal form (seconds since Jan 1 1970) into a + structure providing easier access to the time. + + For non-Unix systems: struct time is supposed to look like this. + Move This definition to pl-os.h and write the conversion functions + here. + + struct tm { + int tm_sec; / * second in the minute (0-59)* / + int tm_min; / * minute in the hour (0-59) * / + int tm_hour; / * hour of the day (0-23) * / + int tm_mday; / * day of the month (1-31) * / + int tm_mon; / * month of the year (1-12) * / + int tm_year; / * year (0 = 1900) * / + int tm_wday; / * day in the week (1-7, 1 = sunday) * / + int tm_yday; / * day in the year (0-365) * / + int tm_isdst; / * daylight saving time info * / + }; + + intptr_t Time() + + Return time in seconds after Jan 1 1970 (Unix' time notion). +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +struct tm * +LocalTime(long *t, struct tm *r) +{ +#if defined(_REENTRANT) && defined(HAVE_LOCALTIME_R) + return localtime_r(t, r); +#else + *r = *localtime((const time_t *) t); + return r; +#endif +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + TERMINAL IO MANIPULATION + +ResetStdin() + Clear the Sinput buffer after a saved state. Only necessary + if O_SAVE is defined. + +PushTty(IOSTREAM *s, ttybuf *buf, int state) + Push the tty to the specified state and save the old state in + buf. + +PopTty(IOSTREAM *s, ttybuf *buf) + Restore the tty state. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static void +ResetStdin() +{ Sinput->limitp = Sinput->bufp = Sinput->buffer; + if ( !GD->os.org_terminal.read ) + GD->os.org_terminal = *Sinput->functions; +} + +static ssize_t +Sread_terminal(void *handle, char *buf, size_t size) +{ intptr_t h = (intptr_t)handle; + int fd = (int)h; + source_location oldsrc = LD->read_source; + + if ( LD->prompt.next && ttymode != TTY_RAW ) + PL_write_prompt(TRUE); + else + Sflush(Suser_output); + + PL_dispatch(fd, PL_DISPATCH_WAIT); + size = (*GD->os.org_terminal.read)(handle, buf, size); + + if ( size == 0 ) /* end-of-file */ + { if ( fd == 0 ) + { Sclearerr(Suser_input); + LD->prompt.next = TRUE; + } + } else if ( size > 0 && buf[size-1] == '\n' ) + LD->prompt.next = TRUE; + + LD->read_source = oldsrc; + + return size; +} + +void +ResetTty() +{ startCritical; + ResetStdin(); + + if ( !GD->os.iofunctions.read ) + { GD->os.iofunctions = *Sinput->functions; + GD->os.iofunctions.read = Sread_terminal; + + Sinput->functions = + Soutput->functions = + Serror->functions = &GD->os.iofunctions; + } + LD->prompt.next = TRUE; + endCritical; +} + +#ifdef O_HAVE_TERMIO /* sys/termios.h or sys/termio.h */ + +#ifndef HAVE_TCSETATTR +#ifndef NO_SYS_IOCTL_H_WITH_SYS_TERMIOS_H +#include +#endif +#ifndef TIOCGETA +#define TIOCGETA TCGETA +#endif +#endif + +bool +PushTty(IOSTREAM *s, ttybuf *buf, int mode) +{ struct termios tio; + int fd; + + buf->mode = ttymode; + ttymode = mode; + + if ( (fd = Sfileno(s)) < 0 || !isatty(fd) ) + succeed; /* not a terminal */ + if ( !trueFeature(TTY_CONTROL_FEATURE) ) + succeed; + +#ifdef HAVE_TCSETATTR + if ( tcgetattr(fd, &buf->tab) ) /* save the old one */ + fail; +#else + if ( ioctl(fd, TIOCGETA, &buf->tab) ) /* save the old one */ + fail; +#endif + + tio = buf->tab; + + switch( mode ) + { case TTY_RAW: +#if defined(HAVE_TCSETATTR) && defined(HAVE_CFMAKERAW) + cfmakeraw(&tio); + tio.c_oflag = buf->tab.c_oflag; /* donot change output modes */ + tio.c_lflag |= ISIG; +#else + tio.c_lflag &= ~(ECHO|ICANON); +#endif + /* OpenBSD requires this anyhow!? */ + /* Bug in OpenBSD or must we? */ + /* Could this do any harm? */ + tio.c_cc[VTIME] = 0, tio.c_cc[VMIN] = 1; + break; + case TTY_OUTPUT: + tio.c_oflag |= (OPOST|ONLCR); + break; + case TTY_SAVE: + succeed; + default: + sysError("Unknown PushTty() mode: %d", mode); + /*NOTREACHED*/ + } + +#ifdef HAVE_TCSETATTR + if ( tcsetattr(fd, TCSANOW, &tio) != 0 ) + { static int MTOK_warned; /* MT-OK */ + + if ( !MTOK_warned++ ) + warning("Failed to set terminal: %s", OsError()); + } +#else +#ifdef TIOCSETAW + ioctl(fd, TIOCSETAW, &tio); +#else + ioctl(fd, TCSETAW, &tio); + ioctl(fd, TCXONC, (void *)1); +#endif +#endif + + succeed; +} + + +bool +PopTty(IOSTREAM *s, ttybuf *buf) +{ int fd; + ttymode = buf->mode; + + if ( (fd = Sfileno(s)) < 0 || !isatty(fd) ) + succeed; /* not a terminal */ + if ( !trueFeature(TTY_CONTROL_FEATURE) ) + succeed; + +#ifdef HAVE_TCSETATTR + tcsetattr(fd, TCSANOW, &buf->tab); +#else +#ifdef TIOCSETA + ioctl(fd, TIOCSETA, &buf->tab); +#else + ioctl(fd, TCSETA, &buf->tab); + ioctl(fd, TCXONC, (void *)1); +#endif +#endif + + succeed; +} + +#else /* O_HAVE_TERMIO */ + +#ifdef HAVE_SGTTYB + +bool +PushTty(IOSTREAM *s, ttybuf *buf, int mode) +{ struct sgttyb tio; + int fd; + + buf->mode = ttymode; + ttymode = mode; + + if ( (fd = Sfileno(s)) < 0 || !isatty(fd) ) + succeed; /* not a terminal */ + if ( !trueFeature(TTY_CONTROL_FEATURE) ) + succeed; + + if ( ioctl(fd, TIOCGETP, &buf->tab) ) /* save the old one */ + fail; + tio = buf->tab; + + switch( mode ) + { case TTY_RAW: + tio.sg_flags |= CBREAK; + tio.sg_flags &= ~ECHO; + break; + case TTY_OUTPUT: + tio.sg_flags |= (CRMOD); + break; + case TTY_SAVE: + succeed; + default: + sysError("Unknown PushTty() mode: %d", mode); + /*NOTREACHED*/ + } + + + ioctl(fd, TIOCSETP, &tio); + ioctl(fd, TIOCSTART, NULL); + + succeed; +} + + +bool +PopTty(IOSTREAM *s, ttybuf *buf) +{ ttymode = buf->mode; + int fd; + + if ( (fd = Sfileno(s)) < 0 || !isatty(fd) ) + succeed; /* not a terminal */ + if ( !trueFeature(TTY_CONTROL_FEATURE) ) + succeed; + + ioctl(fd, TIOCSETP, &buf->tab); + ioctl(fd, TIOCSTART, NULL); + + succeed; +} + +#else /*HAVE_SGTTYB*/ + +bool +PushTty(IOSTREAM *s, ttybuf *buf, int mode) +{ buf->mode = ttymode; + ttymode = mode; + + succeed; +} + + +bool +PopTty(IOSTREAM *s, ttybuf *buf) +{ ttymode = buf->mode; + if ( ttymode != TTY_RAW ) + LD->prompt.next = TRUE; + + succeed; +} + +#endif /*HAVE_SGTTYB*/ +#endif /*O_HAVE_TERMIO*/ + + + /******************************** + * ENVIRONMENT CONTROL * + *********************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Simple library to manipulate the OS environment. The modified +environment will be passed to child processes and the can also be +requested via getenv/2 from Prolog. Functions + + int Setenv(name, value) + char *name, *value; + + Set the OS environment variable with name `name'. If it exists + its value is changed, otherwise a new entry in the environment is + created. The return value is a pointer to the old value, or NULL if + the variable is new. + + int Unsetenv(name) + char *name; + + Delete a variable from the environment. Return value is the old + value, or NULL if the variable did not exist. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +size_t +getenv3(const char *name, char *buf, size_t len) +{ +#if O_XOS + return _xos_getenv(name, buf, len); +#else + char *s = getenv(name); + size_t l; + + if ( s ) + { if ( (l=strlen(s)) < len ) + memcpy(buf, s, l+1); + else if ( len > 0 ) + buf[0] = EOS; /* empty string if not fit */ + + return l; + } + + return (size_t)-1; +#endif +} + + +char * +Getenv(const char *name, char *buf, size_t len) +{ size_t l = getenv3(name, buf, len); + + if ( l != (size_t)-1 && l < len ) + return buf; + + return NULL; +} + + +#if defined(HAVE_PUTENV) || defined(HAVE_SETENV) + +int +Setenv(char *name, char *value) +{ +#ifdef HAVE_SETENV + if ( setenv(name, value, TRUE) != 0 ) + return PL_error(NULL, 0, MSG_ERRNO, ERR_SYSCALL, "setenv"); +#else + char *buf; + + if ( *name == '\0' || strchr(name, '=') != NULL ) + { errno = EINVAL; + return PL_error(NULL, 0, MSG_ERRNO, ERR_SYSCALL, "setenv"); + } + + buf = alloca(strlen(name) + strlen(value) + 2); + + if ( buf ) + { Ssprintf(buf, "%s=%s", name, value); + + if ( putenv(store_string(buf)) < 0 ) + return PL_error(NULL, 0, MSG_ERRNO, ERR_SYSCALL, "setenv"); + } else + return PL_error(NULL, 0, NULL, ERR_NOMEM); +#endif + succeed; +} + +int +Unsetenv(char *name) +{ +#ifdef HAVE_UNSETENV +#ifdef VOID_UNSETENV + unsetenv(name); +#else + if ( unsetenv(name) < 0 ) + return PL_error(NULL, 0, MSG_ERRNO, ERR_SYSCALL, "unsetenv"); +#endif + + succeed; +#else + if ( !getenv(name) ) + succeed; + + return Setenv(name, ""); +#endif +} + +static void +initEnviron() +{ +} + +#else /*HAVE_PUTENV*/ + +#ifdef tos +char **environ; +#else +extern char **environ; /* Unix predefined environment */ +#endif + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Grow the environment array by one and return the (possibly moved) base +pointer to the new environment. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +forwards char **growEnviron(char**, int); +forwards char *matchName(const char *, const char *); +forwards void setEntry(char **, char *, char *); + +static char ** +growEnviron(char **e, int amount) +{ static int filled; + static int size = -1; + + if ( amount == 0 ) /* reset after a dump */ + { size = -1; + return e; + } + + if ( size < 0 ) + { char **env, **e1, **e2; + + for(e1=e, filled=0; *e1; e1++, filled++) + ; + size = ROUND(filled+10+amount, 32); + env = (char **)malloc(size * sizeof(char *)); + for ( e1=e, e2=env; *e1; *e2++ = *e1++ ) + ; + *e2 = (char *) NULL; + filled += amount; + + return env; + } + + filled += amount; + if ( filled + 1 > size ) + { char **env, **e1, **e2; + + size += 32; + env = (char **)realloc(e, size * sizeof(char *)); + for ( e1=e, e2=env; *e1; *e2++ = *e1++ ) + ; + *e2 = (char *) NULL; + + return env; + } + + return e; +} + + +static void +initEnviron(void) +{ growEnviron(environ, 0); +} + + +static char * +matchName(const char *e, const char *name) +{ while( *name && *e == *name ) + e++, name++; + + if ( (*e == '=' || *e == EOS) && *name == EOS ) + return (*e == '=' ? e+1 : e); + + return (char *) NULL; +} + + +static void +setEntry(char **e, char *name, char *value) +{ int l = (int)strlen(name); + + *e = (char *) malloc(l + strlen(value) + 2); + strcpy(*e, name); + e[0][l++] = '='; + strcpy(&e[0][l], value); +} + + +char * +Setenv(char *name, char *value) +{ char **e; + char *v; + int n; + + for(n=0, e=environ; *e; e++, n++) + { if ( (v=matchName(*e, name)) != NULL ) + { if ( !streq(v, value) ) + setEntry(e, name, value); + return v; + } + } + environ = growEnviron(environ, 1); + setEntry(&environ[n], name, value); + environ[n+1] = (char *) NULL; + + return (char *) NULL; +} + + +char * +Unsetenv(char *name) +{ char **e; + char *v; + int n; + + for(n=0, e=environ; *e; e++, n++) + { if ( (v=matchName(*e, name)) != NULL ) + { environ = growEnviron(environ, -1); + e = &environ[n]; + do + { e[0] = e[1]; + e++; + } while(*e); + + return v; + } + } + + return (char *) NULL; +} + +#endif /*HAVE_PUTENV*/ + + /******************************** + * SYSTEM PROCESSES * + *********************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + int System(command) + char *command; + + Invoke a command on the operating system. The return value is the + exit status of the command. Return value 0 implies succesful + completion. If you are not running Unix your C-library might provide + an alternative. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#ifdef __unix__ +#define SPECIFIC_SYSTEM 1 + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +According to the autoconf docs HAVE_SYS_WAIT_H is set if sys/wait.h is +defined *and* is POSIX.1 compliant, which implies it uses int status +argument to wait() +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#ifdef HAVE_SYS_WAIT_H +#undef UNION_WAIT +#include +#define wait_t int + +#ifndef WEXITSTATUS +# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8) +#endif +#ifndef WIFEXITED +# define WIFEXITED(stat_val) (((stat_val) & 255) == 0) +#endif + +#else /*HAVE_SYS_WAIT_H*/ + +#ifdef UNION_WAIT /* Old BSD style wait */ +#include +#define wait_t union wait + +#ifndef WEXITSTATUS +#define WEXITSTATUS(s) ((s).w_status) +#endif +#ifndef WTERMSIG +#define WTERMSIG(s) ((s).w_status) +#endif +#endif /*UNION_WAIT*/ + +#endif /*HAVE_SYS_WAIT_H*/ + + +int +System(char *cmd) +{ int pid; + char *shell = "/bin/sh"; + int rval; + void (*old_int)(); + void (*old_stop)(); + + if ( (pid = fork()) == -1 ) + { return PL_error("shell", 2, OsError(), ERR_SYSCALL, "fork"); + } else if ( pid == 0 ) /* The child */ + { Setenv("PROLOGCHILD", "yes"); + PL_cleanup_fork(); + execl(shell, BaseName(shell), "-c", cmd, (char *)0); + fatalError("Failed to execute %s: %s", shell, OsError()); + fail; + /*NOTREACHED*/ + } else + { wait_t status; /* the parent */ + int n; + + old_int = signal(SIGINT, SIG_IGN); +#ifdef SIGTSTP + old_stop = signal(SIGTSTP, SIG_DFL); +#endif /* SIGTSTP */ + + for(;;) + { +#ifdef HAVE_WAITPID + n = waitpid(pid, &status, 0); +#else + n = wait(&status); +#endif + if ( n == -1 && errno == EINTR ) + continue; + if ( n != pid ) + continue; + break; + } + + if ( n == -1 ) + { term_t tmp = PL_new_term_ref(); + + PL_put_atom_chars(tmp, cmd); + PL_error("shell", 2, MSG_ERRNO, ERR_SHELL_FAILED, tmp); + + rval = 1; + } else if (WIFEXITED(status)) + { rval = WEXITSTATUS(status); +#ifdef WIFSIGNALED + } else if (WIFSIGNALED(status)) + { term_t tmp = PL_new_term_ref(); + int sig = WTERMSIG(status); + + PL_put_atom_chars(tmp, cmd); + PL_error("shell", 2, NULL, ERR_SHELL_SIGNALLED, tmp, sig); + rval = 1; +#endif + } else + { rval = 1; /* make gcc happy */ + fatalError("Unknown return code from wait(3)"); + /*NOTREACHED*/ + } + } + + signal(SIGINT, old_int); /* restore signal handlers */ +#ifdef SIGTSTP + signal(SIGTSTP, old_stop); +#endif /* SIGTSTP */ + + return rval; +} +#endif /* __unix__ */ + +#ifdef tos +#define SPECIFIC_SYSTEM 1 +#include + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +The routine system_via_shell() has been written by Tom Demeijer. Thanks! +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#define _SHELL_P ((intptr_t *)0x4f6L) +#define SHELL_OK (do_sys != 0) + +int cdecl (*do_sys)(const char *cmd); /* Parameter on stack ! */ + +static int +system_via_shell(const char *cmd) +{ intptr_t oldssp; + + oldssp = Super((void *)0L); + do_sys = (void (*))*_SHELL_P; + Super((void *)oldssp); + + if(cmd==NULL && SHELL_OK) + return 0; + + if (SHELL_OK) + return do_sys(cmd); + + return -1; +} + +int +System(command) +char *command; +{ char tmp[MANIPULATION]; + char path[MAXPATHLEN]; + char *cmd_path; + COMMAND commandline; + char *s, *q; + int status, l; + char *cmd = command; + + if ( (status = system_via_shell(command)) != -1 ) + { Sprintf("\033e"); /* get cursor back */ + + return status; + } + + /* get the name of the executable and store in path */ + for(s=path; *cmd != EOS && !isBlank(*cmd); *s++ = *cmd++) + ; + *s = EOS; + if ( !(cmd_path = Which(path, tmp)) ) + { warning("%s: command not found", path); + return 1; + } + + /* copy the command in commandline */ + while( isBlank(*cmd) ) + cmd++; + + for(l = 0, s = cmd, q = commandline.command_tail; *s && l <= 126; s++ ) + { if ( *s != '\'' ) + { *q++ = (*s == '/' ? '\\' : *s); + l++; + } + } + commandline.length = l; + *q = EOS; + + /* execute the command */ + if ( (status = (int) Pexec(0, OsPath(cmd_path), &commandline, NULL)) < 0 ) + { warning("Failed to execute %s: %s", command, OsError()); + return 1; + } + + /* clean up after a graphics application */ + if ( strpostfix(cmd_path, ".prg") || strpostfix(cmd_path, ".tos") ) + { graf_mouse(M_OFF, NULL); /* get rid of the mouse */ + Sprintf("\033e\033E"); /* clear screen and get cursor */ + } + + return status; +} +#endif + +#ifdef HAVE_WINEXEC /* Windows 3.1 */ +#define SPECIFIC_SYSTEM 1 + +int +System(char *command) +{ char *msg; + int rval = WinExec(command, SW_SHOWNORMAL); + + if ( rval < 32 ) + { switch( rval ) + { case 0: msg = "Not enough memory"; break; + case 2: msg = "File not found"; break; + case 3: msg = "No path"; break; + case 5: msg = "Unknown error"; break; + case 6: msg = "Lib requires separate data segment"; break; + case 8: msg = "Not enough memory"; break; + case 10: msg = "Incompatible Windows version"; break; + case 11: msg = "Bad executable file"; break; + case 12: msg = "Incompatible operating system"; break; + case 13: msg = "MS-DOS 4.0 executable"; break; + case 14: msg = "Unknown executable file type"; break; + case 15: msg = "Real-mode application"; break; + case 16: msg = "Cannot start multiple copies"; break; + case 19: msg = "Executable is compressed"; break; + case 20: msg = "Invalid DLL"; break; + case 21: msg = "Application is 32-bits"; break; + default: msg = "Unknown error"; + } + + warning("Could not start %s: error %d (%s)", + command, rval, msg); + return 1; + } + + return 0; +} +#endif + + +#ifdef __WINDOWS__ +#define SPECIFIC_SYSTEM 1 + + /* definition in pl-nt.c */ +#endif + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Nothing special is needed. Just hope the C-library defines system(). +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#ifndef SPECIFIC_SYSTEM + +int +System(command) +char *command; +{ return system(command); +} + +#endif + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +[candidate] + +exec(+Cmd, [+In, +Out, +Error], -Pid) + +The streams may be one of standard stream, std, null stream, null, or +pipe(S), where S is a pipe stream + +Detach if none is std! + +TBD: Sort out status. The above is SICStus 3. YAP uses `Status' for last +argument (strange). SICStus 4 appears to drop this altogether. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + + + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + char *Symbols(char *buf) + + Return the path name of the executable of SWI-Prolog. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#ifndef __WINDOWS__ /* Win32 version in pl-nt.c */ + +char * +findExecutable(const char *av0, char *buffer) +{ char *file; + char buf[MAXPATHLEN]; + char tmp[MAXPATHLEN]; + + if ( !av0 || !PrologPath(av0, buf, sizeof(buf)) ) + return NULL; + file = Which(buf, tmp); + +#if __unix__ /* argv[0] can be an #! script! */ + if ( file ) + { int n, fd; + char buf[MAXPATHLEN]; + + /* Fails if mode is x-only, but */ + /* then it can't be a script! */ + if ( (fd = open(file, O_RDONLY)) < 0 ) + return strcpy(buffer, file); + + if ( (n=read(fd, buf, sizeof(buf)-1)) > 0 ) + { close(fd); + + buf[n] = EOS; + if ( strncmp(buf, "#!", 2) == 0 ) + { char *s = &buf[2], *q; + while(*s && isBlank(*s)) + s++; + for(q=s; *q && !isBlank(*q); q++) + ; + *q = EOS; + + return strcpy(buffer, s); + } + } + + close(fd); + } +#endif /*__unix__*/ + + return strcpy(buffer, file ? file : buf); +} +#endif /*__WINDOWS__*/ + + +#ifdef __unix__ +static char * +okToExec(const char *s) +{ struct stat stbuff; + + if (statfunc(s, &stbuff) == 0 && /* stat it */ + S_ISREG(stbuff.st_mode) && /* check for file */ + access(s, X_OK) == 0) /* can be executed? */ + return (char *)s; + else + return (char *) NULL; +} +#define PATHSEP ':' +#endif /* __unix__ */ + +#ifdef tos +#define EXEC_EXTENSIONS { ".ttp", ".prg", NULL } +#define PATHSEP ',' +#endif + +#if defined(OS2) || defined(__DOS__) || defined(__WINDOWS__) +#define EXEC_EXTENSIONS { ".exe", ".com", ".bat", ".cmd", NULL } +#define PATHSEP ';' +#endif + +#ifdef EXEC_EXTENSIONS + +static char * +okToExec(const char *s) +{ static char *extensions[] = EXEC_EXTENSIONS; + static char **ext; + + DEBUG(2, Sdprintf("Checking %s\n", s)); + for(ext = extensions; *ext; ext++) + if ( stripostfix(s, *ext) ) + return ExistsFile(s) ? (char *)s : (char *) NULL; + + for(ext = extensions; *ext; ext++) + { static char path[MAXPATHLEN]; + + strcpy(path, s); + strcat(path, *ext); + if ( ExistsFile(path) ) + return path; + } + + return (char *) NULL; +} +#endif /*EXEC_EXTENSIONS*/ + +static char * +Which(const char *program, char *fullname) +{ char *path, *dir; + char *e; + + if ( IsAbsolutePath(program) || +#if OS2 && EMX + isDriveRelativePath(program) || +#endif /* OS2 */ + isRelativePath(program) || + strchr(program, '/') ) + { if ( (e = okToExec(program)) != NULL ) + { strcpy(fullname, e); + + return fullname; + } + + return NULL; + } + +#if OS2 && EMX + if ((e = okToExec(program)) != NULL) + { + getcwd(fullname, MAXPATHLEN); + strcat(fullname, "/"); + strcat(fullname, e); + return fullname; + } +#endif /* OS2 */ + if ((path = getenv("PATH") ) == 0) + path = DEFAULT_PATH; + + while(*path) + { if ( *path == PATHSEP ) + { if ( (e = okToExec(program)) ) + return strcpy(fullname, e); + else + path++; /* fix by Ron Hess (hess@sco.com) */ + } else + { char tmp[MAXPATHLEN]; + + for(dir = fullname; *path && *path != PATHSEP; *dir++ = *path++) + ; + if (*path) + path++; /* skip : */ + if ((dir-fullname) + strlen(program)+2 > MAXPATHLEN) + continue; + *dir++ = '/'; + strcpy(dir, program); + if ( (e = okToExec(OsPath(fullname, tmp))) ) + return strcpy(fullname, e); + } + } + + return NULL; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + int Pause(time) + real time; + + Suspend execution `time' seconds. Time is given as a floating + point, expressing the time to sleep in seconds. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#ifdef __WINDOWS__ +#define PAUSE_DONE 1 /* see pl-nt.c */ +#endif + +#if !defined(PAUSE_DONE) && defined(HAVE_NANOSLEEP) +#define PAUSE_DONE 1 + +int +Pause(real t) +{ struct timespec req; + int rc; + + if ( t < 0.0 ) + succeed; + + req.tv_sec = (time_t) t; + req.tv_nsec = (intptr_t)((t - floor(t)) * 1000000000); + + for(;;) + { rc = nanosleep(&req, &req); + if ( rc == -1 && errno == EINTR ) + { if ( PL_handle_signals() < 0 ) + return FALSE; + } else + return TRUE; + } +} + +#endif /*HAVE_NANOSLEEP*/ + + +#if !defined(PAUSE_DONE) && defined(HAVE_USLEEP) +#define PAUSE_DONE 1 + +int +Pause(real t) +{ + if ( t <= 0.0 ) + return; + + usleep((uintptr_t)(t * 1000000.0)); + + return TRUE; +} + +#endif /*HAVE_USLEEP*/ + + +#if !defined(PAUSE_DONE) && defined(HAVE_SELECT) +#define PAUSE_DONE 1 + +int +Pause(real time) +{ struct timeval timeout; + + if ( time <= 0.0 ) + return; + + if ( time < 60.0 ) /* select() is expensive. Does it make sense */ + { timeout.tv_sec = (intptr_t) time; + timeout.tv_usec = (intptr_t)(time * 1000000) % 1000000; + select(32, NULL, NULL, NULL, &timeout); + + return TRUE; + } else + { int rc; + int left = (int)(time+0.5); + + do + { rc = sleep(left); + if ( rc == -1 && errno == EINTR ) + { if ( PL_handle_signals() < 0 ) + return FALSE; + + return TRUE; + } + left -= rc; + } while ( rc != 0 ); + } +} + +#endif /*HAVE_SELECT*/ + +#if !defined(PAUSE_DONE) && defined(HAVE_DOSSLEEP) +#define PAUSE_DONE 1 + +int /* a millisecond granualrity. */ +Pause(time) /* the EMX function sleep uses a seconds */ +real time; /* granularity only. */ +{ /* the select() trick does not work at all. */ + if ( time <= 0.0 ) + return; + + DosSleep((ULONG)(time * 1000)); + + return TRUE; +} + +#endif /*HAVE_DOSSLEEP*/ + +#if !defined(PAUSE_DONE) && defined(HAVE_SLEEP) +#define PAUSE_DONE 1 + +int +Pause(real t) +{ if ( t <= 0.5 ) + succeed; + + sleep((int)(t + 0.5)); + + succeed; +} + +#endif /*HAVE_SLEEP*/ + +#if !defined(PAUSE_DONE) && defined(HAVE_DELAY) +#define PAUSE_DONE 1 + +int +Pause(real t) +{ delay((int)(t * 1000)); + + return TRUE; +} + +#endif /*HAVE_DELAY*/ + +#if !defined(PAUSE_DONE) && defined(tos) +#define PAUSE_DONE 1 + +int +Pause(real t) +{ intptr_t wait = (intptr_t)(t * 200.0); + intptr_t start_tick = clock(); + intptr_t end_tick = wait + start_tick; + + while( clock() < end_tick ) + { if ( kbhit() ) + { wait_ticks += clock() - start_tick; + start_tick = clock(); + TtyAddChar(getch()); + } + } + + wait_ticks += end_tick - start_tick; + + return TRUE; +} + +#endif /*tos*/ + +#ifndef PAUSE_DONE +int +Pause(real t) +{ return notImplemented("sleep", 1); +} +#endif + diff --git a/LGPL/PLStream/pl-os.h b/LGPL/PLStream/pl-os.h new file mode 100644 index 000000000..f99787ad2 --- /dev/null +++ b/LGPL/PLStream/pl-os.h @@ -0,0 +1,254 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: jan@swi.psy.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2002, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#ifdef HAVE_SYS_PARAM_H /* get MAXPATHLEN */ +#include +#endif + + + /******************************** + * MEMORY MANAGEMENT * + *********************************/ + +extern void *Allocate(intptr_t); + + /******************************** + * MISCELLANEOUS * + *********************************/ + +extern char *OsError(void); +extern bool initOs(void); + + + /******************************** + * FILES * + *********************************/ + +#ifndef STREAM_OPEN_BIN_READ +#define STREAM_OPEN_BIN_READ "rb" +#endif + +#ifndef STREAM_OPEN_BIN_WRITE +#define STREAM_OPEN_BIN_WRITE "wb" +#endif + +#ifdef HAVE_POPEN +#define PIPE 1 +#define Popen(path, m) Sopen_pipe(OsPath(path), m) +#define Pclose(fd) pclose(fd) +#endif + +#ifndef MAXPATHLEN +#ifdef PATH_MAX +#define MAXPATHLEN PATH_MAX +#else +#ifdef PATHSIZE +#define MAXPATHLEN PATHSIZE +#endif +#endif +#endif + + +#define Fflush(fd) Sflush(fd) +#define Fclose(fd) Sclose(fd) +#define Open(path, how, mode) open(OsPath(path), how, mode) +#define Read(fd, buf, size) read(fd, buf, size) +#define Write(fd, buf, size) write(fd, buf, size) +#define Getc(fd) Sgetc(fd) +#define Putw(w, fd) Sputw((intptr_t)(w), fd) +#define Getw(fd) Sgetw(fd) + + /******************************* + * PAGE AND TABLE-SIZE * + *******************************/ + +#ifdef HAVE_SYSCONF +#if defined(_SC_OPEN_MAX) && !defined(HAVE_GETPAGESIZE) +#undef getdtablesize +#define getdtablesize() sysconf(_SC_OPEN_MAX) +#ifndef HAVE_GETDTABLESIZE +#define HAVE_GETDTABLESIZE 1 +#endif +#endif +#if defined(_SC_PAGESIZE) && !defined(HAVE_GETPAGESIZE) +#undef getpagesize +#define getpagesize() sysconf(_SC_PAGESIZE) +#ifndef HAVE_GETPAGESIZE +#define HAVE_GETPAGESIZE 1 +#endif +#endif +#endif /*HAVE_SYSCONF*/ + +#ifndef HAVE_GETDTABLESIZE +extern int getdtablesize(void); +#endif +#ifndef HAVE_GETPAGESIZE +extern int getpagesize(void); +#endif + + /******************************* + * FILE ACCESS * + *******************************/ + +#define ACCESS_EXIST 0 +#define ACCESS_EXECUTE 1 +#define ACCESS_READ 2 +#define ACCESS_WRITE 4 + + + /******************************** + * TIME CONVERSION * + *********************************/ + +typedef enum +{ CPU_USER, + CPU_SYSTEM +} cputime_kind; + +extern double CpuTime(cputime_kind); +extern double WallTime(void); + + + /******************************* + * MEMORY * + *******************************/ + +extern uintptr_t UsedMemory(void); +extern uintptr_t FreeMemory(void); + + + /******************************** + * IOSTREAM DESCR. SETS * + ********************************/ + +#if !defined(FD_ZERO) && !defined(__WINDOWS__) +#ifdef HAVE_SYS_SELECT_H +#include +#else +#define FD_ZERO(s) { *((uintptr_t *)(s)) = (0L); } +#define FD_SET(fd, s) { *((uintptr_t *)(s)) |= ((uintptr_t)L << (fd)); } +#define FD_ISSET(fd, s) ( (*((uintptr_t *)(s)) & ((uintptr_t)L << (fd))) != 0 ) +#endif +#endif + + /******************************** + * TERMINAL CONTROL * + *********************************/ + +#define TTY_COOKED 1 /* Initial mode: echo */ +#define TTY_RAW 2 /* Non-blocking, non-echo */ +#define TTY_OUTPUT 3 /* enable post-processing */ +#define TTY_SAVE 4 /* just save status */ + +#ifdef HAVE_TCSETATTR +#include +#include +#define O_HAVE_TERMIO 1 +#else /*HAVE_TCSETATTR*/ +#ifdef HAVE_SYS_TERMIO_H +#include +#define termios termio +#define O_HAVE_TERMIO 1 +#else +#ifdef HAVE_SYS_TERMIOS_H +#include +#define O_HAVE_TERMIO 1 +#endif +#endif +#endif /*HAVE_TCSETATTR*/ + +#ifdef O_HAVE_TERMIO + +typedef struct +{ struct termios tab; /* saved tty status */ + int mode; /* Prolog;'s view on mode */ +} ttybuf; + +#else /* !O_HAVE_TERMIO */ + +#ifdef HAVE_SGTTYB +#include +typedef struct +{ struct sgttyb tab; /* saved tty status */ + int mode; /* Prolog;'s view on mode */ +} ttybuf; + +#else + +typedef struct +{ int mode; /* Prolog;'s view on mode */ +} ttybuf; + +#endif /*HAVE_SGTTYB*/ +#endif /*O_HAVE_TERMIO*/ + +extern ttybuf ttytab; /* saved tty status */ +extern int ttymode; /* Current tty mode */ + +#define IsaTty(fd) isatty(fd) + +extern bool PushTty(IOSTREAM *s, ttybuf *, int mode); +extern bool PopTty(IOSTREAM *s, ttybuf *); +extern void ResetTty(void); + + + /******************************** + * PROCESS CONTROL * + *********************************/ + +extern int System(char *command); + +extern char *ExpandOneFile(const char *spec, char *file); +extern char *AbsoluteFile(const char *spec, char *path); +extern int IsAbsolutePath(const char *spec); +extern char *ReadLink(const char *f, char *buf); +extern char *DeRefLink(const char *link, char *buf); +extern bool ExistsDirectory(const char *path); +extern bool AccessFile(const char *path, int mode); +extern bool AccessFile(const char *path, int mode); +extern char *OsPath(const char *plpath, char *path); +extern char *Getenv(const char *, char *buf, size_t buflen); +extern char *BaseName(const char *f); +extern intptr_t LastModifiedFile(char *f); +extern int64_t SizeFile(const char *path); +extern bool ExistsFile(const char *path); +extern atom_t TemporaryFile(const char *id); +extern int RemoveFile(const char *path); +extern bool SameFile(const char *f1, const char *f2); +extern bool RenameFile(const char *old, const char *new); +extern bool ChDir(const char *path); +extern bool MarkExecutable(const char *name); + + + diff --git a/LGPL/PLStream/pl-stream.c b/LGPL/PLStream/pl-stream.c new file mode 100644 index 000000000..663aa5fca --- /dev/null +++ b/LGPL/PLStream/pl-stream.c @@ -0,0 +1,3413 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: wielemak@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2007, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +#ifdef __WINDOWS__ +#include +#ifdef WIN64 +#define MD "config/win64.h" +#else +#define MD "config/win32.h" +#endif +#include +#include "pl-mswchar.h" +#define CRLF_MAPPING 1 +#endif + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +This modules defines the SWI-Prolog I/O streams. These streams are +provided to gain common access to any type of character data: files, +stdio streams, but also resources, strings, XPCE objects, etc. + +MT: + +Multithreading is supported through Slock() and Sunlock(). These are +recursive locks. If a stream handle might be known to another thread +locking is required. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#ifdef MD +#include MD +#else +#include +#endif + +#if _FILE_OFFSET_BITS == 64 || defined(_LARGE_FILES) +#define O_LARGEFILES 1 /* use for conditional code in Prolog */ +#else +#undef O_LARGEFILES +#endif + +#define PL_KERNEL 1 +#include +typedef wchar_t pl_wchar_t; +#include "pl-stream.h" +#include "pl-utf8.h" +#include +#ifdef HAVE_SYS_TIME_H +#include +#else +#include +#endif +#include +#ifdef HAVE_MALLOC_H +#include +#else +#ifdef HAVE_SYS_MALLOC_H +#include +#endif +#endif +#include +#include +#include +#include +#include +#include +#include +#include +#ifdef HAVE_SYS_SELECT_H +#include +#endif +#ifdef HAVE_UNISTD_H +#include +#endif +#include /* sprintf() for numeric values */ +#include +#ifdef SYSLIB_H +#include SYSLIB_H +#endif + +#ifndef MB_LEN_MAX +#define MB_LEN_MAX 6 +#endif + +#define ROUND(p, n) ((((p) + (n) - 1) & ~((n) - 1))) +#define UNDO_SIZE ROUND(MB_LEN_MAX, sizeof(wchar_t)) + +#ifndef FALSE +#define FALSE 0 +#endif +#ifndef TRUE +#define TRUE 1 +#endif + +#define char_to_int(c) (0xff & (int)(c)) + +#define TMPBUFSIZE 256 /* Serror bufsize for Svfprintf() */ + +int Slinesize = SIO_LINESIZE; /* Sgets() buffer size */ + +static ssize_t S__flushbuf(IOSTREAM *s); +static void run_close_hooks(IOSTREAM *s); +static int S__removebuf(IOSTREAM *s); +static int S__seterror(IOSTREAM *s); + +#ifdef O_PLMT +#define SLOCK(s) if ( s->mutex ) recursiveMutexLock(s->mutex) +#define SUNLOCK(s) if ( s->mutex ) recursiveMutexUnlock(s->mutex) +inline int +STRYLOCK(IOSTREAM *s) +{ if ( s->mutex && + recursiveMutexTryLock(s->mutex) == EBUSY ) + return FALSE; + + return TRUE; +} +#else +#define SLOCK(s) +#define SUNLOCK(s) +#define STRYLOCK(s) (TRUE) +#endif + +#include "pl-error.h" +typedef void *record_t; +typedef intptr_t term_t; + +extern int fatalError(const char *fm, ...); +extern int PL_error(const char *pred, int arity, + const char *msg, int id, ...); +extern int PL_handle_signals(void); +extern IOENC initEncoding(void); +extern int reportStreamError(IOSTREAM *s); +extern record_t PL_record(term_t t); +extern int PL_thread_self(void); + + + /******************************* + * BUFFER * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Note that the buffer is allocated from s->unbuffer, which starts +UNDO_SIZE before s->buffer, so we can always push-back a wide +character into a multibyte stream. We do not do this for SIO_USERBUF +case, but this is only used by the output stream Svfprintf() where it is +not needed. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static size_t +S__setbuf(IOSTREAM *s, char *buffer, size_t size) +{ char *newbuf, *newunbuf; + int newflags = s->flags; + + if ( size == 0 ) + size = SIO_BUFSIZE; + + if ( (s->flags & SIO_OUTPUT) ) + { if ( S__removebuf(s) < 0 ) + return -1; + } + + if ( buffer ) + { newunbuf = newbuf = buffer; + newflags |= SIO_USERBUF; + } else + { if ( !(newunbuf = malloc(size+UNDO_SIZE)) ) + { errno = ENOMEM; + return -1; + } + newflags &= ~SIO_USERBUF; + newbuf = newunbuf + UNDO_SIZE; + } + + if ( (s->flags & SIO_INPUT) ) + { size_t buffered = s->limitp - s->bufp; + size_t copy = (buffered < size ? buffered : size); + + if ( size < buffered ) + { size_t offset = size - buffered; + int64_t newpos; + + if ( s->functions->seek64 ) + { newpos = (*s->functions->seek64)(s->handle, offset, SIO_SEEK_CUR); + } else if ( s->functions->seek ) + { newpos = (*s->functions->seek)(s->handle, (long)offset, SIO_SEEK_CUR); + } else + { newpos = -1; + errno = ESPIPE; + } + + if ( newpos == -1 ) + { if ( !(newflags & SIO_USERBUF) ) + { int oldeno = errno; + + free(newunbuf); + errno = oldeno; + return -1; + } + } + } + + memcpy(newbuf, s->bufp, copy); + S__removebuf(s); + s->unbuffer = newunbuf; + s->bufp = s->buffer = newbuf; + s->limitp = s->buffer+copy; + } else + { s->unbuffer = newunbuf; + s->bufp = s->buffer = newbuf; + s->limitp = &s->buffer[size]; + } + s->bufsize = (int)size; + s->flags = newflags; + + return size; +} + + +void +Ssetbuffer(IOSTREAM *s, char *buffer, size_t size) +{ S__setbuf(s, buffer, size); + s->flags &= ~SIO_USERBUF; +} + + +static int +S__removebuf(IOSTREAM *s) +{ if ( s->buffer && s->unbuffer ) + { int rval = 0; + + if ( (s->flags & SIO_OUTPUT) && S__flushbuf(s) < 0 ) + rval = -1; + + if ( !(s->flags & SIO_USERBUF) ) + free(s->unbuffer); + s->bufp = s->limitp = s->buffer = s->unbuffer = NULL; + s->bufsize = 0; + + return rval; + } + + return 0; +} + + +#ifdef DEBUG_IO_LOCKS +static char * +Sname(IOSTREAM *s) +{ if ( s == Serror ) return "error"; + if ( s == Sinput ) return "input"; + if ( s == Soutput ) return "output"; + return "?"; +} + + +#include +#include + +static void +print_trace(void) +{ void *array[7]; + size_t size; + char **strings; + size_t i; + + size = backtrace(array, sizeof(array)/sizeof(void *)); + strings = backtrace_symbols(array, size); + + printf(" Stack:"); + for(i = 1; i < size; i++) + { printf("\n\t[%ld] %s", (long)i, strings[i]); + } + printf("\n"); + + free(strings); +} +#endif /*DEBUG_IO_LOCKS*/ + + +int +Slock(IOSTREAM *s) +{ SLOCK(s); + +#ifdef DEBUG_IO_LOCKS + if ( s->locks > 2 ) + { printf(" Lock [%d]: %s: %d locks", PL_thread_self(), Sname(s), s->locks+1); + print_trace(); + } +#endif + + if ( !s->locks++ ) + { if ( (s->flags & (SIO_NBUF|SIO_OUTPUT)) == (SIO_NBUF|SIO_OUTPUT) ) + return S__setbuf(s, NULL, TMPBUFSIZE) == (size_t)-1 ? -1 : 0; + } + + return 0; +} + + +int +StryLock(IOSTREAM *s) +{ if ( !STRYLOCK(s) ) + return -1; + + if ( !s->locks++ ) + { if ( (s->flags & (SIO_NBUF|SIO_OUTPUT)) == (SIO_NBUF|SIO_OUTPUT) ) + return S__setbuf(s, NULL, TMPBUFSIZE) == (size_t)-1 ? -1 : 0; + } + + return 0; +} + + +static int +S__unlock(IOSTREAM *s) +{ int rval = 0; + +#ifdef DEBUG_IO_LOCKS + if ( s->locks > 3 ) + { printf("Unlock [%d]: %s: %d locks", PL_thread_self(), Sname(s), s->locks-1); + print_trace(); + } +#endif + + if ( s->locks ) + { if ( --s->locks == 0 ) + { if ( (s->flags & (SIO_NBUF|SIO_OUTPUT)) == (SIO_NBUF|SIO_OUTPUT) ) + rval = S__removebuf(s); + } + } else + { assert(0); + } + + return rval; +} + + +int +Sunlock(IOSTREAM *s) +{ int rval = S__unlock(s); + SUNLOCK(s); + + return rval; +} + + + /******************************* + * FLUSH/FILL * + *******************************/ + +/* return values: -1: error, else #bytes written */ + +static ssize_t +S__flushbuf(IOSTREAM *s) +{ char *from, *to; + ssize_t rc; + + SLOCK(s); + from = s->buffer; + to = s->bufp; + + while ( from < to ) + { size_t size = (size_t)(to - from); + ssize_t n = (*s->functions->write)(s->handle, from, size); + + if ( n > 0 ) /* wrote some */ + { from += n; + } else if ( n < 0 ) /* error */ + { S__seterror(s); + rc = -1; + goto out; + } else /* wrote nothing? */ + { break; + } + } + + if ( to == from ) /* full flush */ + { rc = s->bufp - s->buffer; + s->bufp = s->buffer; + } else /* partial flush */ + { size_t left = to - from; + + rc = from - s->buffer; + memmove(s->buffer, from, left); + s->bufp = s->buffer + left; + } + +out: + SUNLOCK(s); + return rc; +} + + +static int +S__flushbufc(int c, IOSTREAM *s) +{ if ( s->buffer ) + { if ( S__flushbuf(s) <= 0 ) /* == 0: no progress!? */ + c = -1; + else + *s->bufp++ = (c & 0xff); + } else + { if ( s->flags & SIO_NBUF ) + { char chr = (char)c; + + if ( (*s->functions->write)(s->handle, &chr, 1) != 1 ) + { s->flags |= SIO_FERR; + c = -1; + } + } else + { if ( S__setbuf(s, NULL, 0) == (size_t)-1 ) + { s->flags |= SIO_FERR; + c = -1; + } else + *s->bufp++ = (char)c; + } + } + + return c; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +S__fillbuf() fills the read-buffer, returning the first character of it. +It also realises the SWI-Prolog timeout facility. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +int +S__fillbuf(IOSTREAM *s) +{ int c; + + if ( s->flags & (SIO_FEOF|SIO_FERR) ) + { s->flags |= SIO_FEOF2; /* reading past eof */ + return -1; + } + +#ifdef HAVE_SELECT + s->flags &= ~SIO_TIMEOUT; + + if ( s->timeout >= 0 ) + { int fd = Sfileno(s); + + if ( fd >= 0 ) + { fd_set wait; + struct timeval time; + int rc; + + time.tv_sec = s->timeout / 1000; + time.tv_usec = (s->timeout % 1000) * 1000; + FD_ZERO(&wait); +#ifdef __WINDOWS__ + FD_SET((SOCKET)fd, &wait); +#else + FD_SET(fd, &wait); +#endif + + for(;;) + { rc = select(fd+1, &wait, NULL, NULL, &time); + + if ( rc < 0 && errno == EINTR ) + { if ( PL_handle_signals() < 0 ) + { errno = EPLEXCEPTION; + return -1; + } + + continue; + } + + break; + } + + if ( rc == 0 ) + { s->flags |= (SIO_TIMEOUT|SIO_FERR); + return -1; + } + } else + { errno = EPERM; /* no permission to select */ + s->flags |= SIO_FERR; + return -1; + } + } +#endif + + + if ( s->flags & SIO_NBUF ) + { char chr; + ssize_t n; + + if ( (n=(*s->functions->read)(s->handle, &chr, 1)) == 1 ) + { c = char_to_int(chr); + return c; + } else if ( n == 0 ) + { if ( !(s->flags & SIO_NOFEOF) ) + s->flags |= SIO_FEOF; + return -1; + } else + { S__seterror(s); + return -1; + } + } else + { ssize_t n; + size_t len; + + if ( !s->buffer ) + { if ( S__setbuf(s, NULL, 0) == (size_t)-1 ) + return -1; + s->bufp = s->limitp = s->buffer; + len = s->bufsize; + } else if ( s->bufp < s->limitp ) + { len = s->limitp - s->bufp; + memmove(s->buffer, s->bufp, s->limitp - s->bufp); + s->bufp = s->buffer; + s->limitp = &s->bufp[len]; + len = s->bufsize - len; + } else + { s->bufp = s->limitp = s->buffer; + len = s->bufsize; + } + + if ( (n=(*s->functions->read)(s->handle, s->limitp, len)) > 0 ) + { s->limitp += n; + c = char_to_int(*s->bufp++); + return c; + } else + { if ( n == 0 ) + { if ( !(s->flags & SIO_NOFEOF) ) + s->flags |= SIO_FEOF; + return -1; +#ifdef EWOULDBLOCK + } else if ( errno == EWOULDBLOCK ) + { s->bufp = s->buffer; + s->limitp = s->buffer; + return -1; +#endif + } else + { S__seterror(s); + return -1; + } + } + } +} + + /******************************* + * CHARACTER I/O * + *******************************/ + + +static inline void +update_linepos(IOSTREAM *s, int c) +{ IOPOS *p = s->position; + + if ( c > '\r' ) /* speedup the 99% case a bit */ + { p->linepos++; + return; + } + + switch(c) + { case '\n': + p->lineno++; + p->linepos = 0; + s->flags &= ~SIO_NOLINEPOS; + break; + case '\r': + p->linepos = 0; + s->flags &= ~SIO_NOLINEPOS; + break; + case '\b': + if ( p->linepos > 0 ) + p->linepos--; + break; + case EOF: + break; + case '\t': + p->linepos |= 7; + default: + p->linepos++; + } +} + + + +int +S__fcheckpasteeof(IOSTREAM *s, int c) +{ S__checkpasteeof(s, c); + + return c; +} + + +int +S__fupdatefilepos_getc(IOSTREAM *s, int c) +{ IOPOS *p = s->position; + + update_linepos(s, c); + p->byteno++; + p->charno++; + + return c; +} + + +static inline int +S__updatefilepos(IOSTREAM *s, int c) +{ IOPOS *p = s->position; + + if ( p ) + { update_linepos(s, c); + p->charno++; + } + S__checkpasteeof(s,c); + + return c; +} + + +static inline int +get_byte(IOSTREAM *s) +{ int c = Snpgetc(s); + + if ( s->position ) + s->position->byteno++; + + return c; +} + + +static int +put_byte(int c, IOSTREAM *s) +{ c &= 0xff; + + if ( s->bufp < s->limitp ) + { *s->bufp++ = c; + } else + { if ( S__flushbufc(c, s) < 0 ) + { s->lastc = EOF; + return -1; + } + } + + if ( s->position ) + s->position->byteno++; + + return c; +} + + +int +Sputc(int c, IOSTREAM *s) +{ c &= 0xff; + + if ( put_byte(c, s) < 0 ) + return -1; + + s->lastc = c; + + if ( c == '\n' && (s->flags & SIO_LBUF) ) + { if ( S__flushbuf(s) < 0 ) + return -1; + } + + return S__updatefilepos(s, c); +} + + +int +Sfgetc(IOSTREAM *s) +{ return Sgetc(s); +} + + +static inline void +unget_byte(int c, IOSTREAM *s) +{ IOPOS *p = s->position; + + *--s->bufp = c; + if ( p ) + { p->charno--; /* FIXME: not correct */ + p->byteno--; + if ( c == '\n' ) + p->lineno--; + s->flags |= SIO_NOLINEPOS; + } +} + + +int +Sungetc(int c, IOSTREAM *s) +{ if ( s->bufp > s->unbuffer ) + { unget_byte(c, s); + + return c; + } + + return -1; +} + + +static int +reperror(int c, IOSTREAM *s) +{ if ( c >= 0 && (s->flags & (SIO_REPXML|SIO_REPPL)) ) + { char buf[16]; + const char *q; + + if ( (s->flags & SIO_REPPL) ) + { if ( c <= 0xffff ) + sprintf(buf, "\\u%04X", c); + else + sprintf(buf, "\\U%08X", c); + } else + sprintf(buf, "&#%d;", c); + + for(q = buf; *q; q++) + { if ( put_byte(*q, s) < 0 ) + return -1; + } + + return c; + } + + Sseterr(s, SIO_FERR|SIO_CLEARERR, "Encoding cannot represent character"); + return -1; +} + + + +static int +put_code(int c, IOSTREAM *s) +{ switch(s->encoding) + { case ENC_OCTET: + case ENC_ISO_LATIN_1: + if ( c >= 256 ) + { if ( reperror(c, s) < 0 ) + return -1; + break; + } + simple: + if ( put_byte(c, s) < 0 ) + return -1; + break; + case ENC_ASCII: + if ( c >= 128 ) + { if ( reperror(c, s) < 0 ) + return -1; + break; + } + goto simple; + case ENC_ANSI: + { char b[MB_LEN_MAX]; + size_t n; + + if ( !s->mbstate ) + { if ( !(s->mbstate = malloc(sizeof(*s->mbstate))) ) + return EOF; /* out of memory */ + memset(s->mbstate, 0, sizeof(*s->mbstate)); + } + + if ( (n = wcrtomb(b, (wchar_t)c, s->mbstate)) == (size_t)-1 ) + { if ( reperror(c, s) < 0 ) + return -1; + } else + { size_t i; + + for(i=0; i>8, s) < 0 ) + return -1; + if ( put_byte(c&0xff, s) < 0 ) + return -1; + break; + case ENC_UNICODE_LE: + if ( put_byte(c&0xff, s) < 0 ) + return -1; + if ( put_byte(c>>8, s) < 0 ) + return -1; + break; + case ENC_WCHAR: + { pl_wchar_t chr = c; + unsigned char *q = (unsigned char *)&chr; + unsigned char *e = &q[sizeof(pl_wchar_t)]; + + while(qlastc = c; + + if ( c == '\n' && (s->flags & SIO_LBUF) ) + { if ( S__flushbuf(s) < 0 ) + return -1; + } + + return S__updatefilepos(s, c); +} + + +int +Sputcode(int c, IOSTREAM *s) +{ if ( c < 0 ) + return reperror(c, s); + + if ( s->tee && s->tee->magic == SIO_MAGIC ) + Sputcode(c, s->tee); + + if ( c == '\n' && (s->flags&SIO_TEXT) && s->newline == SIO_NL_DOS ) + { if ( put_code('\r', s) < 0 ) + return -1; + } + + return put_code(c, s); +} + + +int +Scanrepresent(int c, IOSTREAM *s) +{ switch(s->encoding) + { case ENC_OCTET: + case ENC_ISO_LATIN_1: + if ( c <= 0xff ) + return 0; + return -1; + case ENC_ASCII: + if ( c < 0x7f ) + return 0; + return -1; + case ENC_ANSI: + { mbstate_t state; + char b[MB_LEN_MAX]; + + memset(&state, 0, sizeof(state)); + if ( wcrtomb(b, (wchar_t)c, &state) != (size_t)-1 ) + return 0; + return -1; + } + case ENC_WCHAR: + if ( sizeof(wchar_t) > 2 ) + return 0; + /*FALLTHROUGH*/ + case ENC_UNICODE_BE: + case ENC_UNICODE_LE: + if ( c <= 0xffff ) + return 0; + return -1; + case ENC_UTF8: + return 0; + default: + assert(0); + return -1; + } +} + + +int +Sgetcode(IOSTREAM *s) +{ int c; + +retry: + switch(s->encoding) + { case ENC_OCTET: + case ENC_ISO_LATIN_1: + c = get_byte(s); + break; + case ENC_ASCII: + { c = get_byte(s); + if ( c > 128 ) + Sseterr(s, SIO_WARN, "non-ASCII character"); + break; + } + case ENC_ANSI: + { char b[1]; + size_t rc, n = 0; + wchar_t wc; + + if ( !s->mbstate ) + { if ( !(s->mbstate = malloc(sizeof(*s->mbstate))) ) + return EOF; /* out of memory */ + memset(s->mbstate, 0, sizeof(*s->mbstate)); + } + + for(;;) + { if ( (c = get_byte(s)) == EOF ) + { if ( n == 0 ) + { goto out; + } else + { Sseterr(s, SIO_WARN, "EOF in multibyte Sequence"); + goto mberr; + } + } + b[0] = c; + + if ( (rc=mbrtowc(&wc, b, 1, s->mbstate)) == 1 ) + { c = wc; + goto out; + } else if ( rc == (size_t)-1 ) + { Sseterr(s, SIO_WARN, "Illegal multibyte Sequence"); + goto mberr; + } /* else -2: incomplete */ + } + + mberr: + c = UTF8_MALFORMED_REPLACEMENT; + goto out; + } + case ENC_UTF8: + { c = get_byte(s); + if ( c == EOF ) + break; + + if ( c & 0x80 ) + { int extra = UTF8_FBN(c); + int code; + + if ( extra < 0 ) + { Sseterr(s, SIO_WARN, "Illegal UTF-8 start"); + c = UTF8_MALFORMED_REPLACEMENT; + goto out; + } + + code = UTF8_FBV(c,extra); + for( ; extra > 0; extra-- ) + { int c2 = get_byte(s); + + if ( !ISUTF8_CB(c2) ) + { Sseterr(s, SIO_WARN, "Illegal UTF-8 continuation"); + c = UTF8_MALFORMED_REPLACEMENT; + Sungetc(c2, s); + goto out; + } + code = (code<<6)+(c2&0x3f); + } + c = code; + } + break; + } + case ENC_UNICODE_BE: + case ENC_UNICODE_LE: + { int c1, c2; + + c1 = get_byte(s); + if ( c1 == EOF ) + { c = -1; + goto out; + } + c2 = get_byte(s); + + if ( c2 == EOF ) + { Sseterr(s, SIO_WARN, "EOF in unicode character"); + c = UTF8_MALFORMED_REPLACEMENT; + } else + { if ( s->encoding == ENC_UNICODE_BE ) + c = (c1<<8)+c2; + else + c = (c2<<8)+c1; + } + + break; + } + case ENC_WCHAR: + { pl_wchar_t chr; + char *p = (char*)&chr; + size_t n; + + for(n=0; nflags&SIO_TEXT) ) + { switch(s->newline) + { case SIO_NL_DETECT: + s->newline = SIO_NL_DOS; + /*FALLTHROUGH*/ + case SIO_NL_DOS: + goto retry; + } + } + + if ( s->tee && s->tee->magic == SIO_MAGIC && c != -1 ) + Sputcode(c, s->tee); + + return S__updatefilepos(s, c); +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +(*) For ENC_ANSI there is a problem as this deals with multi-modal +streams, streams that may hold escape sequences to move from one +character set to another: ascii ... japanese ascii ... +Suppose now we have two characters [ascii, japanese]. When reading the +japanese character the first time, the system will translate the + and the mode will be japanese. When pushing back, only +the japanese character will be put back, not the escape sequence. What +to do? +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +int +Sungetcode(int c, IOSTREAM *s) +{ switch(s->encoding) + { case ENC_OCTET: + case ENC_ISO_LATIN_1: + if ( c >= 256 ) + return -1; /* illegal */ + simple: + if ( s->bufp > s->unbuffer ) + { unget_byte(c, s); + return c; + } + return -1; /* no room */ + case ENC_ASCII: + if ( c >= 128 ) + return -1; /* illegal */ + goto simple; + case ENC_ANSI: /* (*) See above */ + { char b[MB_LEN_MAX]; + size_t n; + + if ( !s->mbstate ) /* do we need a seperate state? */ + { if ( !(s->mbstate = malloc(sizeof(*s->mbstate))) ) + return EOF; /* out of memory */ + memset(s->mbstate, 0, sizeof(*s->mbstate)); + } + + if ( (n = wcrtomb(b, (wchar_t)c, s->mbstate)) != (size_t)-1 && + s->bufp >= n + s->unbuffer ) + { size_t i; + + for(i=n; i-- > 0; ) + { unget_byte(b[i], s); + } + + return c; + } + + return -1; + } + case ENC_UTF8: + { if ( (unsigned)c >= 0x8000000 ) + return -1; + + if ( c < 0x80 ) + { goto simple; + } else + { char buf[6]; + char *p, *end; + + end = utf8_put_char(buf, c); + if ( s->bufp - s->unbuffer >= end-buf ) + { for(p=end-1; p>=buf; p--) + { unget_byte(*p, s); + } + + return c; + } + + return -1; + } + } + case ENC_UNICODE_BE: + { if ( c >= 0x10000 ) + return -1; + + if ( s->bufp-1 > s->unbuffer ) + { unget_byte(c&0xff, s); + unget_byte((c>>8)&0xff, s); + + return c; + } + return -1; + } + case ENC_UNICODE_LE: + { if ( c >= 0x10000 ) + return -1; + + if ( s->bufp-1 > s->unbuffer ) + { unget_byte((c>>8)&0xff, s); + unget_byte(c&0xff, s); + + return c; + } + return -1; + } + case ENC_WCHAR: + { pl_wchar_t chr = c; + + if ( s->bufp-sizeof(chr) >= s->unbuffer ) + { char *p = (char*)&chr; + int n; + + for(n=sizeof(chr); --n>=0; ) + unget_byte(p[n], s); + + return c; + } + return -1; + } + case ENC_UNKNOWN: + return -1; + } + + assert(0); + return -1; +} + + /******************************* + * PUTW/GETW * + *******************************/ + +int +Sputw(int w, IOSTREAM *s) +{ unsigned char *q = (unsigned char *)&w; + unsigned int n; + + for(n=0; nposition ) + { for( ; chars > 0; chars-- ) + { int c; + + if ( (c = Sgetc(s)) == EOF ) + break; + + *buf++ = c & 0xff; + } + } else + { while(chars > 0) + { int c; + + if ( s->bufp < s->limitp ) + { size_t avail = s->limitp - s->bufp; + + if ( chars <= avail ) + { memcpy(buf, s->bufp, chars); + s->bufp += chars; + return elms; + } else + { memcpy(buf, s->bufp, avail); + chars -= avail; + buf += avail; + s->bufp += avail; + } + } + + if ( (c = S__fillbuf(s)) == EOF ) + break; + + *buf++ = c & 0xff; + chars--; + } + } + + return (size*elms - chars)/size; +} + + +size_t +Sfwrite(const void *data, size_t size, size_t elms, IOSTREAM *s) +{ size_t chars = size * elms; + const char *buf = data; + + for( ; chars > 0; chars-- ) + { if ( Sputc(*buf++, s) < 0 ) + break; + } + + return (size*elms - chars)/size; +} + + + /******************************* + * PENDING * + *******************************/ + +ssize_t +Sread_pending(IOSTREAM *s, char *buf, size_t limit, int flags) +{ int done = 0; + size_t n; + + if ( s->bufp >= s->limitp && (flags & SIO_RP_BLOCK) ) + { int c = S__fillbuf(s); + + if ( c < 0 ) + { if ( (s->flags & SIO_FEOF) ) + return 0; + return c; + } + + buf[0] = c; + limit--; + done = 1; + } + + n = s->limitp - s->bufp; + if ( n > limit ) + n = limit; + memcpy(&buf[done], s->bufp, n); + s->bufp += n; + + return done+n; +} + + + /******************************* + * BOM * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Check the stream for a BOM (Byte Order Marker). If present (and known), +update the stream encoding. Return value is one of + + -1: error (check errno) + 0: ok. If BOM, SIO_BOM is added to flags +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +typedef struct +{ IOENC encoding; + unsigned int bomlen; + const char *bom; +} bomdef; + +static const bomdef bomdefs[] = +{ { ENC_UTF8, 3, "\357\273\277" }, /* 0xef, 0xbb, 0xbb */ + { ENC_UNICODE_BE, 2, "\376\377" }, /* 0xfe, oxff */ + { ENC_UNICODE_LE, 2, "\377\376" }, /* 0xff, oxfe */ + { ENC_UNKNOWN, 0, NULL } +}; + +int +ScheckBOM(IOSTREAM *s) +{ if ( (s->flags & SIO_NBUF) ) + { errno = EINVAL; + return -1; + } + + for(;;) + { size_t avail = s->limitp - s->bufp; + const bomdef *bd; + + for(bd=bomdefs; bd->bomlen; bd++) + { if ( avail >= bd->bomlen && memcmp(s->bufp, bd->bom, bd->bomlen) == 0 ) + { s->encoding = bd->encoding; + s->bufp += bd->bomlen; + s->flags |= SIO_BOM; + return 0; + } + } + + if ( avail >= 4 ) /* longest BOM */ + return 0; + + if ( S__fillbuf(s) == -1 ) + return 0; /* empty stream */ + s->bufp--; + } +} + + +int +SwriteBOM(IOSTREAM *s) +{ switch(s->encoding) + { case ENC_UTF8: + case ENC_UNICODE_LE: + case ENC_UNICODE_BE: + { if ( Sputcode(0xfeff, s) != -1 ) + { s->flags |= SIO_BOM; + + return 0; + } + return -1; + } + default: + return 0; + } +} + + + /******************************* + * FLAGS * + *******************************/ + +int +Sfeof(IOSTREAM *s) +{ if ( s->flags & SIO_FEOF ) + return TRUE; + + if ( s->bufp < s->limitp ) + return FALSE; + + if ( s->flags & SIO_NBUF ) + { errno = EINVAL; + return -1; + } + + if ( S__fillbuf(s) == -1 ) + return TRUE; + + s->bufp--; + return FALSE; +} + + +static int +S__seterror(IOSTREAM *s) +{ if ( s->functions->control ) + { char *msg; + + if ( (*s->functions->control)(s->handle, + SIO_LASTERROR, + (void *)&msg) == 0 ) + { Sseterr(s, SIO_FERR, msg); + return 0; + } + } + + s->flags |= SIO_FERR; + return 0; +} + + +int +Sferror(IOSTREAM *s) +{ return (s->flags & SIO_FERR) != 0; +} + + +int +Sfpasteof(IOSTREAM *s) +{ return (s->flags & (SIO_FEOF2ERR|SIO_FEOF2)) == (SIO_FEOF2ERR|SIO_FEOF2); +} + + +void +Sclearerr(IOSTREAM *s) +{ s->flags &= ~(SIO_FEOF|SIO_WARN|SIO_FERR|SIO_FEOF2|SIO_TIMEOUT|SIO_CLEARERR); + Sseterr(s, 0, NULL); +} + + +void +Sseterr(IOSTREAM *s, int flag, const char *message) +{ if ( s->message ) + { free(s->message); + s->message = NULL; + s->flags &= ~SIO_CLEARERR; + } + if ( message ) + { s->flags |= flag; + s->message = strdup(message); + } else + { s->flags &= ~flag; + } +} + + +void +Sset_exception(IOSTREAM *s, term_t ex) +{ s->exception = PL_record(ex); + s->flags |= SIO_FERR; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Set the encoding of a stream. The enc argument is the new encoding. If +old is not NULL, the old encoding is written to the given location. + +Please note that not all code changing the encoding call Ssetenc at the +moment. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +int +Ssetenc(IOSTREAM *s, IOENC enc, IOENC *old) +{ if ( old ) + *old = s->encoding; + if ( enc == s->encoding ) + return 0; + + if ( s->functions->control ) + { if ( (*s->functions->control)(s->handle, + SIO_SETENCODING, + (void *)&enc) != 0 ) + return -1; + } + + s->encoding = enc; + return 0; +} + + /******************************* + * FLUSH * + *******************************/ + +int +Sflush(IOSTREAM *s) +{ if ( s->buffer && (s->flags & SIO_OUTPUT) ) + { if ( S__flushbuf(s) < 0 ) + return -1; + if ( s->functions->control && + (*s->functions->control)(s->handle, SIO_FLUSHOUTPUT, NULL) < 0 ) + return -1; + } + + return 0; +} + + /******************************* + * SEEK * + *******************************/ + +int +Sunit_size(IOSTREAM *s) +{ switch(s->encoding) + { case ENC_UNKNOWN: + case ENC_OCTET: + case ENC_ASCII: + case ENC_ISO_LATIN_1: + case ENC_ANSI: + case ENC_UTF8: + return 1; + case ENC_UNICODE_BE: + case ENC_UNICODE_LE: + return 2; + case ENC_WCHAR: + return sizeof(wchar_t); + default: + assert(0); + return 1; /* not reached */ + } +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Return the size of the underlying data object. Should be optimized; +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +long +Ssize(IOSTREAM *s) +{ if ( s->functions->control ) + { long size; + + if ( (*s->functions->control)(s->handle, SIO_GETSIZE, (void *)&size) == 0 ) + return size; + } + if ( s->functions->seek ) + { long here = Stell(s); + long end; + + if ( Sseek(s, 0, SIO_SEEK_END) == 0 ) + end = Stell(s); + else + end = -1; + Sseek(s, here, SIO_SEEK_SET); + + return end; + } + + errno = ESPIPE; + return -1; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Sseek64(IOSTREAM *s, int64_t pos, int whence) + +Re-position the stream to byte-no 'pos'. + +Maybe we should optimise this to become block-aligned? Or can we leave +this to read/write? + +The first part checks whether repositioning the read pointer in the +buffer suffices to achieve the seek. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +int +Sseek64(IOSTREAM *s, int64_t pos, int whence) +{ if ( (s->flags & SIO_INPUT) && s->limitp > s->buffer ) /* something there */ + { int64_t now = Stell64(s); + + if ( now != -1 ) + { int64_t newpos; + char *nbufp = (char *)-1; + + if ( whence == SIO_SEEK_CUR ) + { nbufp = s->bufp + pos; + newpos = now + pos; + } else if ( whence == SIO_SEEK_SET ) + { nbufp = s->bufp + (pos - now); + newpos = pos; + } else + newpos = -1; /* should not happen */ + + if ( nbufp >= s->buffer && nbufp < s->limitp ) + { s->bufp = nbufp; + + pos = newpos; + goto update; + } + } + } + + if ( !s->functions->seek && !s->functions->seek64 ) + { errno = ESPIPE; + return -1; + } + + Sflush(s); + + s->bufp = s->buffer; + if ( (s->flags & SIO_INPUT) ) + s->limitp = s->buffer; + + if ( whence == SIO_SEEK_CUR ) + { pos += Stell64(s); + whence = SIO_SEEK_SET; + } + + if ( s->functions->seek64 ) + pos = (*s->functions->seek64)(s->handle, pos, whence); + else if ( pos <= LONG_MAX ) + pos = (*s->functions->seek)(s->handle, (long)pos, whence); + else + { errno = EINVAL; + return -1; + } + + if ( pos < 0 ) + { errno = EINVAL; + return -1; + } + +update: + s->flags &= ~(SIO_FEOF|SIO_FEOF2); /* not on eof of file anymore */ + + if ( s->position ) + { s->flags |= (SIO_NOLINENO|SIO_NOLINEPOS); /* no update this */ + s->position->byteno = pos; + s->position->charno = pos/Sunit_size(s); /* compatibility */ + } + + return 0; +} + + +int +Sseek(IOSTREAM *s, long pos, int whence) +{ return Sseek64(s, (int64_t)pos, whence); +} + + + +/* Stell64(IOSTREAM *s) returns the current position in the file in + bytes +*/ + +int64_t +Stell64(IOSTREAM *s) +{ if ( s->position ) + { return s->position->byteno; + } else if ( s->functions->seek || s->functions->seek64 ) + { int64_t pos; + + if ( s->functions->seek64 ) + pos = (*s->functions->seek64)(s->handle, 0L, SIO_SEEK_CUR); + else + pos = (*s->functions->seek)(s->handle, 0L, SIO_SEEK_CUR); + + if ( s->buffer ) /* open */ + { int64_t off = s->bufp - s->buffer; + + if ( s->flags & SIO_INPUT ) + off -= s->limitp - s->buffer; + + pos += off; + } + + return pos; + } else + { errno = EINVAL; + return -1; + } +} + + +long +Stell(IOSTREAM *s) +{ int64_t pos = Stell64(s); + + if ( pos <= LONG_MAX ) + return (long) pos; + + errno = EINVAL; + return -1; +} + + + /******************************* + * CLOSE * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +(*) Sclose() can be called recursively. For example if an XPCE object is +only referenced from an open stream, the close-function will delete the +object, which in turn calls the ->unlink which may wish to close the +associated stream. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +int +Sclose(IOSTREAM *s) +{ int rval = 0; + + if ( s->magic != SIO_MAGIC ) /* already closed!? */ + { errno = EINVAL; + return -1; + } + + if ( (s->flags&SIO_CLOSING) ) /* recursive (*) */ + return rval; + + if ( s->upstream ) + { Sseterr(s, SIO_FERR, "Locked by upstream filter"); + reportStreamError(s); + return -1; + } + + SLOCK(s); + s->flags |= SIO_CLOSING; + rval = S__removebuf(s); + if ( s->mbstate ) + free(s->mbstate); + +#ifdef __WINDOWS__ + if ( (s->flags & SIO_ADVLOCK) ) + { OVERLAPPED ov; + HANDLE h = (HANDLE)_get_osfhandle((int)s->handle); + + memset(&ov, 0, sizeof(ov)); + UnlockFileEx(h, 0, 0, 0xffffffff, &ov); + s->flags &= ~SIO_ADVLOCK; + } +#endif + if ( s->functions->close && (*s->functions->close)(s->handle) < 0 ) + { s->flags |= SIO_FERR; + rval = -1; + } + while(s->locks > 0) /* remove buffer-locks */ + { int rc = S__unlock(s); + + if ( rval == 0 ) + rval = rc; + } + if ( rval < 0 ) + reportStreamError(s); + run_close_hooks(s); /* deletes Prolog registration */ + + SUNLOCK(s); + +#ifdef O_PLMT + if ( s->mutex ) + { recursiveMutexDelete(s->mutex); + free(s->mutex); + s->mutex = NULL; + } +#endif + + s->magic = SIO_CMAGIC; + if ( !(s->flags & SIO_STATIC) ) + free(s); + + return rval; +} + + + /******************************* + * STRING I/O * + *******************************/ + +char * +Sfgets(char *buf, int n, IOSTREAM *s) +{ char *q = buf; + + while( n-- > 0 ) + { int c = Sgetc(s); + + if ( c == EOF ) + { *q = '\0'; + if ( q == buf ) + buf = NULL; + goto out; + } else + { *q++ = c; + if ( c == '\n' ) + { if ( n > 0 ) + *q = '\0'; + goto out; + } + } + } + +out: + return buf; +} + + +char * +Sgets(char *buf) +{ char *s = Sfgets(buf, Slinesize, Sinput); + char *q; + + if ( s ) /* delete trailing \n */ + { q = &s[strlen(s)]; + if ( q > s && q[-1] == '\n' ) + *--q = '\0'; + } + + return s; +} + + +int +Sfputs(const char *q, IOSTREAM *s) +{ + for( ; *q; q++) + { if ( Sputcode(*q&0xff, s) < 0 ) + return EOF; + } + + return 0; +} + + +int +Sputs(const char *q) +{ return Sfputs(q, Soutput); +} + + + /******************************* + * PRINTF * + *******************************/ + +int +Sfprintf(IOSTREAM *s, const char *fm, ...) +{ va_list args; + int rval; + + va_start(args, fm); + rval = Svfprintf(s, fm, args); + va_end(args); + + return rval; +} + + +int +Sprintf(const char *fm, ...) +{ va_list args; + int rval; + + va_start(args, fm); + rval = Svfprintf(Soutput, fm, args); + va_end(args); + + return rval; +} + + +int +Svprintf(const char *fm, va_list args) +{ return Svfprintf(Soutput, fm, args); +} + + +#define NEXTCHR(s, c) if ( utf8 ) \ + { (s) = utf8_get_char((s), &(c)); \ + } else \ + { c = *(s)++; c &= 0xff; \ + } + +#define OUTCHR(s, c) do { printed++; \ + if ( Sputcode((c), (s)) < 0 ) goto error; \ + } while(0) +#define valdigit(c) ((c) - '0') +#define A_LEFT 0 /* left-aligned field */ +#define A_RIGHT 1 /* right-aligned field */ + +int +Svfprintf(IOSTREAM *s, const char *fm, va_list args) +{ intptr_t printed = 0; + char buf[TMPBUFSIZE]; + int tmpbuf; + + SLOCK(s); + + if ( !s->buffer && (s->flags & SIO_NBUF) ) + { S__setbuf(s, buf, sizeof(buf)); + tmpbuf = TRUE; + } else + tmpbuf = FALSE; + + while(*fm) + { if ( *fm == '%' ) + { fm++; + + if ( *fm == '%' ) + { OUTCHR(s, *fm); + fm++; + continue; + } else + { int align = A_RIGHT; + int modified = FALSE; + int has_arg1 = FALSE, has_arg2 = FALSE; + int arg1=0, arg2=0; + char fbuf[100], *fs = fbuf, *fe = fbuf; + int islong = 0; + int pad = ' '; + int utf8 = FALSE; + + for(;;) + { switch(*fm) + { case '+': align = A_RIGHT; fm++; continue; + case '-': align = A_LEFT; fm++; continue; + case '0': pad = '0'; fm++; continue; + case ' ': pad = ' '; fm++; continue; + case '#': modified = TRUE; fm++; continue; + } + break; + } + + if ( *fm == '*' ) + { has_arg1++; + fm++; + arg1 = va_arg(args, int); + } else if ( isdigit(char_to_int(*fm)) ) + { if ( *fm == '0' ) + pad = '0'; + arg1 = valdigit(*fm); + has_arg1++; + for( fm++; isdigit(char_to_int(*fm)); fm++) + arg1 = arg1*10 + valdigit(*fm); + } + if ( *fm == '.' ) + { has_arg2++; + fm++; + if ( *fm == '*' ) + { arg2 = va_arg(args, int); + } else + { arg2 = 0; + for( ; isdigit(char_to_int(*fm)); fm++) + arg2 = arg2*10 + valdigit(*fm); + } + } + + if ( *fm == 'l' ) + { islong++; /* 1: %ld */ + fm++; + } + if ( *fm == 'l' ) + { islong++; /* 2: %lld */ + fm++; + } + if ( *fm == 'U' ) /* %Us: UTF-8 string */ + { utf8 = TRUE; + fm++; + } + + switch(*fm) + { case 'c': + *fe++ = va_arg(args, int); + break; + case 'p': + { void *ptr = va_arg(args, void*); + char fmbuf[8], *fp=fmbuf; + *fp++ = '%'; + if ( modified ) + *fp++ = '#'; + *fp++ = 'p'; + *fp = '\0'; + sprintf(fs, fmbuf, ptr); + fe = &fs[strlen(fs)]; + + break; + } + case 'd': + case 'i': + case 'o': + case 'u': + case 'x': + case 'X': + { intptr_t v = 0; /* make compiler silent */ + int64_t vl = 0; + char fmbuf[8], *fp=fmbuf; + + switch( islong ) + { case 0: + v = va_arg(args, int); + break; + case 1: + v = va_arg(args, intptr_t); + break; + case 2: + vl = va_arg(args, int64_t); + break; + } + + *fp++ = '%'; + if ( modified ) + *fp++ = '#'; + *fp++ = 'l'; + if ( islong < 2 ) + { *fp++ = *fm; + *fp = '\0'; + sprintf(fs, fmbuf, v); + } else + { +#ifdef __WINDOWS__ + strcat(fp-1, "I64"); /* Synchronise with INT64_FORMAT! */ + fp += strlen(fp); +#else + *fp++ = 'l'; +#endif + *fp++ = *fm; + *fp = '\0'; + sprintf(fs, fmbuf, vl); + } + fe = &fs[strlen(fs)]; + + break; + } + case 'f': + case 'e': + case 'E': + case 'g': + case 'G': + { double v = va_arg(args, double); + char fmbuf[8], *fp=fmbuf; + + *fp++ = '%'; + if ( modified ) + *fp++ = '#'; + if ( has_arg2 ) /* specified percission */ + { *fp++ = '.'; + *fp++ = '*'; + *fp++ = *fm; + *fp = '\0'; + sprintf(fs, fmbuf, arg2, v); + } else + { *fp++ = *fm; + *fp = '\0'; + sprintf(fs, fmbuf, v); + } + fe = &fs[strlen(fs)]; + + break; + } + case 's': + fs = va_arg(args, char *); + if ( !fs ) + fs = "(null)"; + break; + } + + if ( has_arg1 ) /* aligned field */ + { if ( fs == fbuf ) + *fe = '\0'; + + if ( align == A_LEFT ) + { int w = 0; + while(*fs) + { int c; + NEXTCHR(fs, c); + OUTCHR(s, c); + w++; + } + while(w < arg1) + { OUTCHR(s, pad); + w++; + } + } else /*if ( align == A_RIGHT ) */ + { size_t w; + + if ( fs == fbuf ) + w = fe - fs; + else + w = strlen(fs); + + if ( utf8 ) + w = utf8_strlen(fs, w); + + if ( (ssize_t)w < arg1 ) + { w = arg1 - w; + while(w > 0 ) + { OUTCHR(s, pad); + w--; + } + } + while(*fs) + { int c; + NEXTCHR(fs, c); + OUTCHR(s, c); + } + } + } else + { if ( fs == fbuf ) /* unaligned field, just output */ + { while(fs < fe) + OUTCHR(s, *fs++); + } else + { while(*fs) + { int c; + NEXTCHR(fs, c); + OUTCHR(s, c); + } + } + } + fm++; + } + } else if ( *fm == '\\' && fm[1] ) + { OUTCHR(s, fm[1]); + fm += 2; + } else + { OUTCHR(s, *fm); + fm++; + } + } + + if ( tmpbuf ) + { if ( S__removebuf(s) < 0 ) + goto error; + } + + SUNLOCK(s); + return (int)printed; + +error: + SUNLOCK(s); + return -1; +} + + +int +Ssprintf(char *buf, const char *fm, ...) +{ va_list args; + int rval; + + va_start(args, fm); + rval = Svsprintf(buf, fm, args); + va_end(args); + + return rval; +} + + +int +Svsprintf(char *buf, const char *fm, va_list args) +{ IOSTREAM s; + int rval; + + memset(&s, 0, sizeof(s)); + s.bufp = buf; + s.limitp = (char *)(~0L); + s.buffer = buf; + s.flags = SIO_FBUF|SIO_OUTPUT; + s.encoding = ENC_ISO_LATIN_1; + + if ( (rval = Svfprintf(&s, fm, args)) >= 0 ) + *s.bufp = '\0'; + + return rval; +} + + +int +Svdprintf(const char *fm, va_list args) +{ int rval; + IOSTREAM *s = Soutput; + + Slock(s); + rval = Svfprintf(s, fm, args); +#if defined(_DEBUG) && defined(__WINDOWS__) + Sputc('\0', s); + s->bufp--; /* `Unput' */ + OutputDebugString(s->buffer); +#endif + if ( Sflush(s) != 0 ) + rval = -1; + Sunlock(s); + + return rval; +} + + +int +Sdprintf(const char *fm, ...) +{ va_list args; + int rval; + + va_start(args, fm); + rval = Svdprintf(fm, args); + va_end(args); + + return rval; +} + +#if 0 + /******************************* + * SCANF * + *******************************/ + +int +Svfscanf(IOSTREAM *s, const char *fm, va_list args) +{ int done = 0; /* # items converted */ + int chread = 0; /* # characters read */ + int c = GET(s); /* current character */ + int supress; /* if TRUE, don't assign (*) */ + int field_width; /* max width of field */ + int tsize; /* SZ_SHORT, SZ_NORMAL, SZ_LONG */ + + while(*fm) + { if ( *fm == ' ' ) + { while ( isblank(c) ) + c = GET(s); + fm++; + continue; + } else if ( *fm == '%' && fm[1] != '%' ) + { supress = FALSE; + field_width = -1; + int size = SZ_STANDARD; + + for(;;) /* parse modifiers */ + { fm++; + if ( isdigit(*fm) ) + { field_width = valdigit(*fm); + for(++fm; isdigit(*fm); fm++) + field_width = 10*field_width + valdigit(*fm); + fm--; + continue; + } + if ( *fm == '*' ) + { supress++; + continue; + } + if ( *fm == 'l' ) + { size = SZ_LONG; + continue; + } + if ( *fm == 'h' ) + { size = SZ_SHORT; + continue; + } + } + + if ( *fm != '[' && *fm != c ) + while(isblank(c)) + c = GET(s); + + switch(*fm) + { { intptr_t v; /* collect value here */ + int negative; /* true if < 0 */ + int base; /* base for conversion */ + int ok; /* successful */ + case 'd': + base = 10; + + do_int: + negative = FALSE; + if ( c == '+' ) + c = GET(s); + else if ( c == '-' ) + { negative++; + c = GET(s); + } + do_unsigned: + ok = FALSE; + if ( base == 16 ) /* hexadecimal */ + { if ( isxdigit(c) ) + { v = valxdigit(c); + for(c = GET(s); isxdigit(c); c = GET(s)) + v = base*v + valxdigit(c); + ok++; + } + } else + { int cv; + + if ( isdigit(c) && (cv=valdigit(c)) < base ) + { v = cv; + for(c = GET(s); isdigit(c) && (cv=valdigit(c)) < base; c = GET(s)) + v = base*v + cv; + ok++; + } + } + + if ( ok ) + { if ( !supress ) + { if ( negative ) + v = -v; + if ( tsize == SZ_SHORT ) + { short *vp = va_arg(args, short *); + *vp = v; + } else if ( tsize == SZ_LONG ) + { intptr_t *vp = va_arg(args, intptr_t *); + *vp = v; + } else + { int *vp = va_arg(args, int *); + *vp = v; + } + done++; + } + continue; /* with next */ + } else + return done; + case 'u': + base = 10; + negative = FALSE; + goto do_unsigned; + case 'o': + base = 8; + goto do_int; + case 'x': + base = 16; + goto do_int; + case 'i': + if ( c == '0' ) + { int c2 = GET(s); + + if ( c2 == 'x' ) + { base = 16; + c = GET(s); + } else + { UNGET(c2, s); + base = 8; + } + negative = FALSE; + goto do_unsigned; + } + base = 10; + goto do_int; + } + case 'n': + if ( !supress ) + { if ( tsize == SZ_SHORT ) + { short *vp = va_arg(args, short *); + *vp = chread; + } else if ( tsize == SZ_LONG ) + { intptr_t *vp = va_arg(args, intptr_t *); + *vp = chread; + } else + { int *vp = va_arg(args, int *); + *vp = chread; + } + done++; + } + fm++; + continue; + case 'E': + case 'e': + case 'f': + case 'G': + case 'g': + { char work[200]; + char *w = work; + int ds = 0; + double v; + + if ( c == '-' || c == '+' ) /* [+|-] */ + { *w++ = c; + c = GET(s); + } + while(isdigit(c)) /* {digit} */ + { *w++ = c; + c = GET(s); + ds++; + } + if ( c == '.' ) /* [.] */ + *w++ = c; + while(isdigit(c)) /* {digit} */ + { *w++ = c; + c = GET(s); + ds++; + } + if ( !ds ) + SCAN_ERROR(s) + if ( c == 'e' || c == 'E' ) /* [e{}] */ + { *w++ = c; + c = GET(s); + if ( !isdigit(c) ) + SCAN_ERROR(s) + while(isdigit(c)) + { *w++ = c; + c = GET(s); + } + } + + if ( !supress ) + { *w = '\0'; + v = strtod(work, &w) + if ( w == work ) + SCAN_ERROR(s); + + switch(tsize) + { case SZ_NORMAL: + { float *fp = va_arg(args, float *); + *fp = v; + break; + } + case SZ_LONG: + { double *fp = va_arg(args, double *); + *fp = v; + break; + } + } + done++; + } + + fm++; + continue; + } + case 's': + if ( !supress ) + { char *sp = va_arg(args, char *); + + while(!isblank(c) && field_width-- != 0) + { *sp++ = c; + c = GET(s); + } + } else + while(!isblank(c) && field_width-- != 0) + c = GET(s); + fm++; + continue; + case 'c': + if ( !supress ) + { char *cp = va_arg(args, char *); + *cp = c; + } + c = GET(s); + fm++; + continue; + case '[': + { char set[256]; + + memset(set, 0, sizeof(set)); + fm++; + if ( *fm == ']' ) + set[*fm++]++; + else if ( *fm == '^' ) + { fm++; + negate++; + } + while(*fm != ']') + { if ( *fm == '-' ) + + } + } + } + } else /* normal character */ + { if ( c == *fm ) + { c = GET(s); + fm++; + continue; + } + + break; + } + } + +out: + UNGET(c, s); + + return done; +} + +#endif /*0*/ + + + /******************************* + * FILTER STREAMS * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Link two streams in a pipeline, where filter filters data for stream +`parent'. If parent is an output steam we have + + application --> filter --> parent --> + +If parent is an input stream we have + + --> parent --> filter --> application +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +int +Sset_filter(IOSTREAM *parent, IOSTREAM *filter) +{ if ( !parent || parent->magic != SIO_MAGIC ) + { errno = EINVAL; + return -1; + } + + if ( filter ) + { if ( filter->magic != SIO_MAGIC ) + { errno = EINVAL; + return -1; + } + } + + parent->upstream = filter; + if ( filter ) + filter->downstream = parent; + + return 0; +} + + + /******************************* + * FILE STREAMS * + *******************************/ + +static ssize_t +Sread_file(void *handle, char *buf, size_t size) +{ intptr_t h = (intptr_t) handle; + ssize_t bytes; + + for(;;) + { +#ifdef __WINDOWS__ + bytes = read((int)h, buf, (int)size); +#else + bytes = read((int)h, buf, size); +#endif + + if ( bytes == -1 && errno == EINTR ) + { if ( PL_handle_signals() < 0 ) + { errno = EPLEXCEPTION; + return -1; + } + + continue; + } + + return bytes; + } +} + + +static ssize_t +Swrite_file(void *handle, char *buf, size_t size) +{ intptr_t h = (intptr_t) handle; + ssize_t bytes; + + for(;;) + { +#ifdef __WINDOWS__ + bytes = write((int)h, buf, (int)size); +#else + bytes = write((int)h, buf, size); +#endif + + if ( bytes == -1 && errno == EINTR ) + { if ( PL_handle_signals() < 0 ) + { errno = EPLEXCEPTION; + return -1; + } + + continue; + } + + return bytes; + } +} + + +static long +Sseek_file(void *handle, long pos, int whence) +{ intptr_t h = (intptr_t) handle; + + /* cannot do EINTR according to man */ + return lseek((int)h, pos, whence); +} + + +#ifdef O_LARGEFILES +static int64_t +Sseek_file64(void *handle, int64_t pos, int whence) +{ intptr_t h = (intptr_t) handle; + + /* cannot do EINTR according to man */ + return lseek((int)h, pos, whence); +} +#endif + + +static int +Sclose_file(void *handle) +{ intptr_t h = (intptr_t) handle; + int rc; + + do + { rc = close((int) h); + } while ( rc == -1 && errno == EINTR ); + + return rc; +} + + +static int +Scontrol_file(void *handle, int action, void *arg) +{ intptr_t h = (intptr_t) handle; + int fd = (int)h; + + switch(action) + { case SIO_GETSIZE: + { intptr_t *rval = arg; + struct stat buf; + + if ( fstat(fd, &buf) == 0 ) + { *rval = buf.st_size; + return 0; + } + return -1; + } + case SIO_SETENCODING: + case SIO_FLUSHOUTPUT: + return 0; + default: + return -1; + } +} + + +IOFUNCTIONS Sfilefunctions = +{ Sread_file, + Swrite_file, + Sseek_file, + Sclose_file, + Scontrol_file, +#ifdef O_LARGEFILES + Sseek_file64 +#else + NULL +#endif +}; + + +IOFUNCTIONS Sttyfunctions = +{ Sread_file, + Swrite_file, + NULL, + Sclose_file, + Scontrol_file, +#ifdef O_LARGEFILES + Sseek_file64 +#else + NULL +#endif +}; + + +IOSTREAM * +Snew(void *handle, int flags, IOFUNCTIONS *functions) +{ IOSTREAM *s; + int fd; + + if ( !(s = malloc(sizeof(IOSTREAM))) ) + { errno = ENOMEM; + return NULL; + } + memset((char *)s, 0, sizeof(IOSTREAM)); + s->magic = SIO_MAGIC; + s->lastc = EOF; + s->flags = flags; + s->handle = handle; + s->functions = functions; + s->timeout = -1; /* infinite */ + s->posbuf.lineno = 1; + s->encoding = ENC_ISO_LATIN_1; +#if CRLF_MAPPING + s->newline = SIO_NL_DOS; +#endif + if ( flags & SIO_RECORDPOS ) + s->position = &s->posbuf; +#ifdef O_PLMT + if ( !(flags & SIO_NOMUTEX) ) + { if ( !(s->mutex = malloc(sizeof(recursiveMutex))) ) + { free(s); + return NULL; + } + recursiveMutexInit(s->mutex); + } +#endif + if ( (fd = Sfileno(s)) >= 0 && isatty(fd) ) + s->flags |= SIO_ISATTY; + + return s; +} + + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Open a file. In addition to the normal arguments, "lr" means get a read +(shared-) lock on the file and "lw" means get an write (exclusive-) +lock. How much do we need to test here? + +Note that the low-level open is always binary as O_TEXT open files +result in lost and corrupted data in some encodings (UTF-16 is one of +them). Sgetcode() and Sputcode() do the LF <-> CRLF mapping of +CRLF_MAPPING is defined. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +IOSTREAM * +Sopen_file(const char *path, const char *how) +{ int fd; + int oflags = O_BINARY; + int flags = SIO_FILE|SIO_TEXT|SIO_RECORDPOS; + int op = *how++; + intptr_t lfd; + enum {lnone=0,lread,lwrite} lock = lnone; + IOSTREAM *s; + IOENC enc = ENC_UNKNOWN; + + for( ; *how; how++) + { switch(*how) + { case 'b': /* binary */ + flags &= ~SIO_TEXT; + enc = ENC_OCTET; + break; + case 'r': /* no record */ + flags &= ~SIO_RECORDPOS; + break; + case 'l': /* lock r: read, w: write */ + if ( *++how == 'r' ) + lock = lread; + else if ( *how == 'w' ) + lock = lwrite; + else + { errno = EINVAL; + return NULL; + } + break; + default: + errno = EINVAL; + return NULL; + } + } + +#if O_LARGEFILES && defined(O_LARGEFILE) + oflags |= O_LARGEFILE; +#endif + + switch(op) + { case 'w': + fd = open(path, O_WRONLY|O_CREAT|O_TRUNC|oflags, 0666); + flags |= SIO_OUTPUT; + break; + case 'a': + fd = open(path, O_WRONLY|O_CREAT|O_APPEND|oflags, 0666); + flags |= SIO_OUTPUT|SIO_APPEND; + break; + case 'u': + fd = open(path, O_WRONLY|O_CREAT|oflags, 0666); + flags |= SIO_OUTPUT|SIO_UPDATE; + break; + case 'r': + fd = open(path, O_RDONLY|oflags); + flags |= SIO_INPUT; + break; + default: + errno = EINVAL; + return NULL; + } + + + + if ( fd < 0 ) + return NULL; + + if ( lock ) + { +#ifdef FCNTL_LOCKS + struct flock buf; + + memset(&buf, 0, sizeof(buf)); + buf.l_type = (lock == lread ? F_RDLCK : F_WRLCK); + + if ( fcntl(fd, F_SETLKW, &buf) < 0 ) + { int save = errno; + close(fd); + errno = save; + return NULL; + } +#else /* we don't have locking */ +#if __WINDOWS__ + HANDLE h = (HANDLE)_get_osfhandle(fd); + OVERLAPPED ov; + + memset(&ov, 0, sizeof(ov)); + if ( !LockFileEx(h, (lock == lread ? 0 : LOCKFILE_EXCLUSIVE_LOCK), + 0, + 0, 0xfffffff, + &ov) ) + { close(fd); + errno = EACCES; /* TBD: proper error */ + return NULL; + } +#else + close(fd); + errno = EINVAL; + return NULL; +#endif +#endif + } + + lfd = (intptr_t)fd; + s = Snew((void *)lfd, flags, &Sfilefunctions); + if ( enc != ENC_UNKNOWN ) + s->encoding = enc; + if ( lock ) + s->flags |= SIO_ADVLOCK; + + return s; +} + + +IOSTREAM * +Sfdopen(int fd, const char *type) +{ int flags; + intptr_t lfd; + + if ( fd < 0 ) + { errno = EINVAL; + return NULL; + } +#if defined(HAVE_FCNTL) && defined(F_GETFL) + if ( fcntl(fd, F_GETFL) == -1 ) + return NULL; +#endif + + if ( *type == 'r' ) + flags = SIO_FILE|SIO_INPUT|SIO_RECORDPOS; + else + flags = SIO_FILE|SIO_OUTPUT|SIO_RECORDPOS; + + lfd = (intptr_t)fd; + + return Snew((void *)lfd, flags, &Sfilefunctions); +} + +/* MT: as long as s is valid, this should be ok +*/ + +int +Sfileno(IOSTREAM *s) +{ int n; + + if ( s->flags & SIO_FILE ) + { intptr_t h = (intptr_t)s->handle; + n = (int)h; + } else if ( s->flags & SIO_PIPE ) + { n = fileno((FILE *)s->handle); + } else if ( s->functions->control && + (*s->functions->control)(s->handle, + SIO_GETFILENO, + (void *)&n) == 0 ) + { ; + } else + { errno = EINVAL; + n = -1; /* no file stream */ + } + + return n; +} + + + /******************************* + * PIPES * + *******************************/ + +#ifdef HAVE_POPEN +#ifdef __WINDOWS__ +#include "popen.c" + +#define popen(cmd, how) pt_popen(cmd, how) +#define pclose(fd) pt_pclose(fd) +#endif + +static ssize_t +Sread_pipe(void *handle, char *buf, size_t size) +{ FILE *fp = handle; + +#ifdef __WINDOWS__ + return read(fileno(fp), buf, (unsigned int)size); +#else + return read(fileno(fp), buf, size); +#endif +} + + +static ssize_t +Swrite_pipe(void *handle, char *buf, size_t size) +{ FILE *fp = handle; + +#ifdef __WINDOWS__ + return write(fileno(fp), buf, (unsigned int)size); +#else + return write(fileno(fp), buf, size); +#endif +} + + +static int +Sclose_pipe(void *handle) +{ FILE *fp = handle; + + pclose(fp); + return 0; +} + + +IOFUNCTIONS Spipefunctions = +{ Sread_pipe, + Swrite_pipe, + (Sseek_function)0, + Sclose_pipe +}; + + +IOSTREAM * +Sopen_pipe(const char *command, const char *type) +{ char mode[2]; + FILE *fd; + +#if 0 + Sdprintf("Opening \"%s\", mode \"%s\" --> %p (%d)\n", + command, type, fd, errno); +#endif + + mode[0] = type[0]; + mode[1] = '\0'; + + if ( (fd = popen(command, mode)) ) + { int flags; + + if ( *type == 'r' ) + flags = SIO_PIPE|SIO_INPUT; + else + flags = SIO_PIPE|SIO_OUTPUT; + + return Snew((void *)fd, flags, &Spipefunctions); + } + + return NULL; +} + +#endif /*HAVE_POPEN*/ + + /******************************* + * MEMORY STREAMS * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Memory streams form a replacement for sprintf(), sscanf() and friends. +They allow regarding a piece of (for output) malloc() maintained memory +to serve as a temporary buffer. + +MT: we assume these handles are not passed between threads +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +typedef struct +{ size_t here; /* `here' location */ + size_t size; /* size of buffer */ + size_t *sizep; /* pointer to size */ + size_t allocated; /* allocated size */ + char **buffer; /* allocated buffer */ + int malloced; /* malloc() maintained */ +} memfile; + + +void +Sfree(void *ptr) /* Windows: must free from same */ +{ free(ptr); /* DLL */ +} + + +static size_t +S__memfile_nextsize(size_t needed) +{ size_t size = 512; + + while ( size < needed ) + size *= 2; + + return size; +} + + +static ssize_t +Swrite_memfile(void *handle, char *buf, size_t size) +{ memfile *mf = handle; + + if ( mf->here + size + 1 >= mf->allocated ) + { intptr_t ns = S__memfile_nextsize(mf->here + size + 1); + char *nb; + + if ( mf->allocated == 0 || !mf->malloced ) + { if ( !(nb = malloc(ns)) ) + { errno = ENOMEM; + return -1; + } + if ( !mf->malloced ) + { if ( *mf->buffer ) + memcpy(nb, *mf->buffer, mf->allocated); + mf->malloced = TRUE; + } + } else + { if ( !(nb = realloc(*mf->buffer, ns)) ) + { errno = ENOMEM; + return -1; + } + } + + mf->allocated = ns; + *mf->buffer = nb; + } + + memcpy(&(*mf->buffer)[mf->here], buf, size); + mf->here += size; + + if ( mf->here > mf->size ) + { mf->size = mf->here; + if ( mf->sizep ) /* make externally known */ + *mf->sizep = mf->size; + (*mf->buffer)[mf->size] = '\0'; + } + + return size; +} + + +static ssize_t +Sread_memfile(void *handle, char *buf, size_t size) +{ memfile *mf = handle; + + if ( size + mf->here > mf->size ) + { if ( mf->here > mf->size ) + size = 0; + else + size = mf->size - mf->here; + } + + memcpy(buf, &(*mf->buffer)[mf->here], size); + mf->here += size; + + return size; +} + + +static long +Sseek_memfile(void *handle, long offset, int whence) +{ memfile *mf = handle; + + switch(whence) + { case SIO_SEEK_SET: + break; + case SIO_SEEK_CUR: + offset += (long)mf->here; /* Win64: truncates */ + break; + case SIO_SEEK_END: + offset = (long)mf->size - offset; /* Win64 */ + break; + default: + errno = EINVAL; + return -1; + } + if ( offset < 0 || offset > (long)mf->size ) + { errno = EINVAL; + return -1; + } + mf->here = offset; + + return offset; +} + + +static int +Sclose_memfile(void *handle) +{ memfile *mf = handle; + + if ( mf ) + { free(mf); + return 0; + } + + errno = EINVAL; /* not opened */ + return -1; +} + + +IOFUNCTIONS Smemfunctions = +{ Sread_memfile, + Swrite_memfile, + Sseek_memfile, + Sclose_memfile +}; + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Sopenmem(char **buffer, size_t *sizep, const char* mode) + Open a memory area as a stream. Output streams will automatically + resized using realloc() if *size = 0 or the stream is opened with mode + "wa". + + If the buffer is allocated or enlarged, this is achieved using malloc() + or realloc(). In this case the returned buffer should be freed by the + caller when done. Example: + + { char buf[1024]; (don't allocate for small stuff) + char *s = buf; + IOSTREAM *fd; + size_t size = sizeof(buf); + + fd = Sopenmem(&s, &size, "w"); + ... + Sclose(fd); + ... + if ( s != buf ) (appearently moved) + Sfree(s); + } + +Note: Its is NOT allows to access streams created with this call from +multiple threads. This is ok for all usage inside Prolog itself (often +through tellString()/toldString(). This call is intented to use write +and other output predicates to create strings. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +IOSTREAM * +Sopenmem(char **buffer, size_t *sizep, const char *mode) +{ memfile *mf = malloc(sizeof(memfile)); + int flags = SIO_FBUF|SIO_RECORDPOS|SIO_NOMUTEX; + size_t size; + + if ( !mf ) + { errno = ENOMEM; + return NULL; + } + + mf->malloced = FALSE; + + switch(*mode) + { case 'r': + flags |= SIO_INPUT; + if ( sizep == NULL || *sizep == (size_t)-1 ) + size = (*buffer ? strlen(*buffer) : 0); + else + size = *sizep; + mf->size = size; + mf->allocated = size+1; + break; + case 'w': + flags |= SIO_OUTPUT; + mf->size = 0; + mf->allocated = (sizep ? *sizep : 0); + if ( *buffer == NULL || mode[1] == 'a' ) + mf->malloced = TRUE; + if ( *buffer ) + *buffer[0] = '\0'; + if ( sizep ) + *sizep = mf->size; + break; + default: + free(mf); + errno = EINVAL; + return NULL; + } + + mf->sizep = sizep; + mf->here = 0; + mf->buffer = buffer; + + return Snew(mf, flags, &Smemfunctions); +} + + /******************************* + * STRINGS * + *******************************/ + +/* MT: we assume these handles are not passed between threads +*/ + +static ssize_t +Sread_string(void *handle, char *buf, size_t size) +{ return 0; /* signal EOF */ +} + +static ssize_t +Swrite_string(void *handle, char *buf, size_t size) +{ errno = ENOSPC; /* signal error */ + return -1; +} + +static int +Sclose_string(void *handle) +{ IOSTREAM *s = handle; + + if ( s->flags & SIO_OUTPUT ) + { if ( s->bufp < s->limitp ) + { *s->bufp++ = '\0'; + return 0; + } else + { errno = ENOSPC; /* signal error */ + return -1; + } + } else + return 0; /* input string */ +} + +IOFUNCTIONS Sstringfunctions = +{ Sread_string, + Swrite_string, + (Sseek_function)0, + Sclose_string +}; + + +IOSTREAM * +Sopen_string(IOSTREAM *s, char *buf, size_t size, const char *mode) +{ int flags = SIO_FBUF|SIO_USERBUF; + + if ( !s ) + { if ( !(s = malloc(sizeof(IOSTREAM))) ) + { errno = ENOMEM; + return NULL; + } + } else + flags |= SIO_STATIC; + + memset((char *)s, 0, sizeof(IOSTREAM)); + s->timeout = -1; + s->buffer = buf; + s->bufp = buf; + s->unbuffer = buf; + s->handle = s; /* for Sclose_string() */ + s->functions = &Sstringfunctions; + s->encoding = ENC_ISO_LATIN_1; + + switch(*mode) + { case 'r': + if ( size == (size_t)-1 ) + size = strlen(buf); + flags |= SIO_INPUT; + break; + case 'w': + flags |= SIO_OUTPUT; + break; + default: + errno = EINVAL; + return NULL; + } + + s->flags = flags; + s->limitp = &buf[size]; + s->magic = SIO_MAGIC; + + return s; +} + + /******************************* + * STANDARD HANDLES * + *******************************/ + +#define STDIO(n, f) { NULL, NULL, NULL, NULL, \ + EOF, SIO_MAGIC, 0, f, {0, 0, 0}, NULL, \ + ((void *)(n)), &Sttyfunctions, \ + 0, NULL, \ + (void (*)(void *))0, NULL, \ + -1, \ + 0, \ + ENC_ISO_LATIN_1 \ + } + +#define SIO_STDIO (SIO_FILE|SIO_STATIC|SIO_NOCLOSE|SIO_ISATTY|SIO_TEXT) +#define STDIO_STREAMS \ + STDIO(0, SIO_STDIO|SIO_LBUF|SIO_INPUT|SIO_NOFEOF), /* Sinput */ \ + STDIO(1, SIO_STDIO|SIO_LBUF|SIO_OUTPUT|SIO_REPPL), /* Soutput */ \ + STDIO(2, SIO_STDIO|SIO_NBUF|SIO_OUTPUT|SIO_REPPL) /* Serror */ + + +IOSTREAM S__iob[] = +{ STDIO_STREAMS +}; + + +static const IOSTREAM S__iob0[] = +{ STDIO_STREAMS +}; + + +void +SinitStreams() +{ static int done; + + if ( !done++ ) + { int i; + IOENC enc = initEncoding(); + + for(i=0; i<=2; i++) + { if ( !isatty(i) ) + { S__iob[i].flags &= ~SIO_ISATTY; + S__iob[i].functions = &Sfilefunctions; /* Check for pipe? */ + } + if ( S__iob[i].encoding == ENC_ISO_LATIN_1 ) + S__iob[i].encoding = enc; +#ifdef O_PLMT + S__iob[i].mutex = malloc(sizeof(recursiveMutex)); + recursiveMutexInit(S__iob[i].mutex); +#endif +#if CRLF_MAPPING + _setmode(i, O_BINARY); + S__iob[i].newline = SIO_NL_DOS; +#endif + } + +#ifdef __WINDOWS__ + pt_init(); /* init popen() issues */ +#endif + } +} + + +IOSTREAM * +S__getiob() +{ return S__iob; +} + + + /******************************* + * HOOKS * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +This allows external packages (Prolog itself) to monitor the destruction +of streams. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +typedef struct _close_hook +{ struct _close_hook *next; + void (*hook)(IOSTREAM *s); +} close_hook; + +static close_hook *close_hooks; + +static void +run_close_hooks(IOSTREAM *s) +{ close_hook *p; + + for(p=close_hooks; p; p = p->next) + (*p->hook)(s); + + if ( s->close_hook ) + (*s->close_hook)(s->closure); +} + +int +Sclosehook(void (*hook)(IOSTREAM *s)) +{ close_hook *h = malloc(sizeof(*h)); + + if ( !h ) + return -1; + h->next = close_hooks; + h->hook = hook; + close_hooks = h; + + return 0; +} + + + /******************************* + * CLEANUP * + *******************************/ + +void +Sreset(void) +{ IOSTREAM *s; + + if ( (s=Sinput) && s->magic == SIO_MAGIC ) + { s->bufp = s->limitp = s->buffer; + } + if ( (s=Soutput) && s->magic == SIO_MAGIC ) + { s->bufp = s->buffer; + } + if ( (s=Serror) && s->magic == SIO_MAGIC ) + { s->bufp = s->buffer; + } +} + + +void +Scleanup(void) +{ close_hook *p, *next; + int i; + + for(p=close_hooks; p; p=next) + { next = p->next; + free(p); + } + + close_hooks = NULL; + + for(i=0; i<=2; i++) + { IOSTREAM *s = &S__iob[i]; + + s->bufp = s->buffer; /* avoid actual flush */ + S__removebuf(s); + *s = S__iob0[i]; /* re-initialise */ + } +} + diff --git a/LGPL/PLStream/pl-stream.h b/LGPL/PLStream/pl-stream.h new file mode 100644 index 000000000..409ea2f8c --- /dev/null +++ b/LGPL/PLStream/pl-stream.h @@ -0,0 +1,413 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: jan@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2005, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +#ifndef _PL_STREAM_H +#define _PL_STREAM_H + +/* This appears to make the wide-character support compile and work + on HPUX 11.23. There really should be a cleaner way ... +*/ +#if defined(__hpux) +#include +#endif + +#if defined(_MSC_VER) && !defined(__WINDOWS__) +#define __WINDOWS__ 1 +#endif + +#include +#include +#include +#ifdef __WINDOWS__ +typedef __int64 int64_t; +#if (_MSC_VER < 1300) +typedef long intptr_t; +typedef unsigned long uintptr_t; +#endif +typedef intptr_t ssize_t; /* signed version of size_t */ +#else +#include +#include /* more portable than stdint.h */ +#endif + +#ifdef __cplusplus +extern "C" { +#endif + + /******************************* + * EXPORT * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +See SWI-Prolog.h, containing the same code for an explanation on this +stuff. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#ifndef _PL_EXPORT_DONE +#define _PL_EXPORT_DONE + +#if (defined(__WINDOWS__) || defined(__CYGWIN__)) && !defined(__LCC__) +#define HAVE_DECLSPEC +#endif + +#ifdef HAVE_DECLSPEC +# ifdef PL_KERNEL +#define PL_EXPORT(type) __declspec(dllexport) type +#define PL_EXPORT_DATA(type) __declspec(dllexport) type +#define install_t void +# else +# ifdef __BORLANDC__ +#define PL_EXPORT(type) type _stdcall +#define PL_EXPORT_DATA(type) extern type +# else +#define PL_EXPORT(type) extern type +#define PL_EXPORT_DATA(type) __declspec(dllimport) type +# endif +#define install_t __declspec(dllexport) void +# endif +#else /*HAVE_DECLSPEC*/ +#define PL_EXPORT(type) extern type +#define PL_EXPORT_DATA(type) extern type +#define install_t void +#endif /*HAVE_DECLSPEC*/ +#endif /*_PL_EXPORT_DONE*/ + + /******************************* + * CONSTANTS * + *******************************/ + +#ifndef EOF +#define EOF (-1) +#endif + +#ifndef NULL +#define NULL ((void *)0) +#endif + +#if defined(__WINDOWS__) && !defined(EWOULDBLOCK) +#define EWOULDBLOCK 1000 /* Needed for socket handling */ +#endif +#define EPLEXCEPTION 1001 /* errno: pending Prolog exception */ + +#define SIO_BUFSIZE (4096) /* buffering buffer-size */ +#define SIO_LINESIZE (1024) /* Sgets() default buffer size */ +#define SIO_MAGIC (7212676) /* magic number */ +#define SIO_CMAGIC (42) /* we are close (and thus illegal!) */ + +typedef ssize_t (*Sread_function)(void *handle, char *buf, size_t bufsize); +typedef ssize_t (*Swrite_function)(void *handle, char*buf, size_t bufsize); +typedef long (*Sseek_function)(void *handle, long pos, int whence); +typedef int64_t (*Sseek64_function)(void *handle, int64_t pos, int whence); +typedef int (*Sclose_function)(void *handle); +typedef int (*Scontrol_function)(void *handle, int action, void *arg); + +#if defined(O_PLMT) && defined(PL_KERNEL) +#include "pl-mutex.h" +#define IOLOCK recursiveMutex +#else +typedef void * IOLOCK; /* Definition for external use */ +#endif + +typedef struct io_functions +{ Sread_function read; /* fill the buffer */ + Swrite_function write; /* empty the buffer */ + Sseek_function seek; /* seek to position */ + Sclose_function close; /* close stream */ + Scontrol_function control; /* Info/control */ + Sseek64_function seek64; /* seek to position (intptr_t files) */ +} IOFUNCTIONS; + +typedef struct io_position +{ int64_t byteno; /* byte-position in file */ + int64_t charno; /* character position in file */ + int lineno; /* lineno in file */ + int linepos; /* position in line */ + intptr_t reserved[2]; /* future extensions */ +} IOPOS; + + /* NOTE: check with encoding_names */ + /* in pl-file.c */ +typedef enum +{ ENC_UNKNOWN = 0, /* invalid/unknown */ + ENC_OCTET, /* raw 8 bit input */ + ENC_ASCII, /* US-ASCII (0..127) */ + ENC_ISO_LATIN_1, /* ISO Latin-1 (0..256) */ + ENC_ANSI, /* default (multibyte) codepage */ + ENC_UTF8, + ENC_UNICODE_BE, /* big endian unicode file */ + ENC_UNICODE_LE, /* little endian unicode file */ + ENC_WCHAR /* pl_wchar_t */ +} IOENC; + +#define SIO_NL_POSIX 0 /* newline as \n */ +#define SIO_NL_DOS 1 /* newline as \r\n */ +#define SIO_NL_DETECT 3 /* detect processing mode */ + +typedef struct io_stream +{ char *bufp; /* `here' */ + char *limitp; /* read/write limit */ + char *buffer; /* the buffer */ + char *unbuffer; /* Sungetc buffer */ + int lastc; /* last character written */ + int magic; /* magic number SIO_MAGIC */ + int bufsize; /* size of the buffer */ + int flags; /* Status flags */ + IOPOS posbuf; /* location in file */ + IOPOS * position; /* pointer to above */ + void *handle; /* function's handle */ + IOFUNCTIONS *functions; /* open/close/read/write/seek */ + int locks; /* lock/unlock count */ + IOLOCK * mutex; /* stream mutex */ + /* SWI-Prolog 4.0.7 */ + void (*close_hook)(void* closure); + void * closure; + /* SWI-Prolog 5.1.3 */ + int timeout; /* timeout (milliseconds) */ + /* SWI-Prolog 5.4.4 */ + char * message; /* error/warning message */ + IOENC encoding; /* character encoding used */ + struct io_stream * tee; /* copy data to this stream */ + mbstate_t * mbstate; /* ENC_ANSI decoding */ + struct io_stream * upstream; /* stream providing our input */ + struct io_stream * downstream; /* stream providing our output */ + unsigned newline : 2; /* Newline mode */ + void * exception; /* pending exception (record_t) */ + intptr_t reserved[2]; /* reserved for extension */ +} IOSTREAM; + + +#define SmakeFlag(n) (1<<(n-1)) + +#define SIO_FBUF SmakeFlag(1) /* full buffering */ +#define SIO_LBUF SmakeFlag(2) /* line buffering */ +#define SIO_NBUF SmakeFlag(3) /* no buffering */ +#define SIO_FEOF SmakeFlag(4) /* end-of-file */ +#define SIO_FERR SmakeFlag(5) /* error ocurred */ +#define SIO_USERBUF SmakeFlag(6) /* buffer is from user */ +#define SIO_INPUT SmakeFlag(7) /* input stream */ +#define SIO_OUTPUT SmakeFlag(8) /* output stream */ +#define SIO_NOLINENO SmakeFlag(9) /* line no. info is void */ +#define SIO_NOLINEPOS SmakeFlag(10) /* line pos is void */ +#define SIO_STATIC SmakeFlag(11) /* Stream in static memory */ +#define SIO_RECORDPOS SmakeFlag(12) /* Maintain position */ +#define SIO_FILE SmakeFlag(13) /* Stream refers to an OS file */ +#define SIO_PIPE SmakeFlag(14) /* Stream refers to an OS pipe */ +#define SIO_NOFEOF SmakeFlag(15) /* don't set SIO_FEOF flag */ +#define SIO_TEXT SmakeFlag(16) /* text-mode operation */ +#define SIO_FEOF2 SmakeFlag(17) /* attempt to read past eof */ +#define SIO_FEOF2ERR SmakeFlag(18) /* Sfpasteof() */ +#define SIO_NOCLOSE SmakeFlag(19) /* Do not close on abort */ +#define SIO_APPEND SmakeFlag(20) /* opened in append-mode */ +#define SIO_UPDATE SmakeFlag(21) /* opened in update-mode */ +#define SIO_ISATTY SmakeFlag(22) /* Stream is a tty */ +#define SIO_CLOSING SmakeFlag(23) /* We are closing the stream */ +#define SIO_TIMEOUT SmakeFlag(24) /* We had a timeout */ +#define SIO_NOMUTEX SmakeFlag(25) /* Do not allow multi-thread access */ +#define SIO_ADVLOCK SmakeFlag(26) /* File locked with advisory lock */ +#define SIO_WARN SmakeFlag(27) /* Pending warning */ +#define SIO_CLEARERR SmakeFlag(28) /* Clear error after reporting */ +#define SIO_REPXML SmakeFlag(29) /* Bad char --> XML entity */ +#define SIO_REPPL SmakeFlag(30) /* Bad char --> Prolog \hex\ */ +#define SIO_BOM SmakeFlag(31) /* BOM was detected/written */ + +#define SIO_SEEK_SET 0 /* From beginning of file. */ +#define SIO_SEEK_CUR 1 /* From current position. */ +#define SIO_SEEK_END 2 /* From end of file. */ + +PL_EXPORT(IOSTREAM *) S__getiob(void); /* get DLL's __iob[] address */ + +PL_EXPORT_DATA(IOFUNCTIONS) Sfilefunctions; /* OS file functions */ +PL_EXPORT_DATA(int) Slinesize; /* Sgets() linesize */ +#if defined(__CYGWIN__) && !defined(PL_KERNEL) +#define S__iob S__getiob() +#else +PL_EXPORT_DATA(IOSTREAM) S__iob[3]; /* Libs standard streams */ +#endif + +#define Sinput (&S__iob[0]) /* Stream Sinput */ +#define Soutput (&S__iob[1]) /* Stream Soutput */ +#define Serror (&S__iob[2]) /* Stream Serror */ + +#define Sgetchar() Sgetc(Sinput) +#define Sputchar(c) Sputc((c), Soutput) + +#define S__checkpasteeof(s,c) \ + if ( (c)==-1 && (s)->flags & (SIO_FEOF|SIO_FERR) ) \ + ((s)->flags |= SIO_FEOF2) +#define S__updatefilepos_getc(s, c) \ + ((s)->position ? S__fupdatefilepos_getc((s), (c)) \ + : S__fcheckpasteeof((s), (c))) + +#define Snpgetc(s) ((s)->bufp < (s)->limitp ? (int)(*(s)->bufp++)&0xff \ + : S__fillbuf(s)) +#define Sgetc(s) S__updatefilepos_getc((s), Snpgetc(s)) + +/* Control-operations */ +#define SIO_GETSIZE (1) /* get size of underlying object */ +#define SIO_GETFILENO (2) /* get underlying file (if any) */ +#define SIO_SETENCODING (3) /* modify encoding of stream */ +#define SIO_FLUSHOUTPUT (4) /* flush output */ +#define SIO_LASTERROR (5) /* string holding last error */ + +/* Sread_pending() */ +#define SIO_RP_BLOCK 0x1 /* wait for new input */ + +#if IOSTREAM_REPLACES_STDIO + +#undef FILE +#undef stdin +#undef stdout +#undef stderr +#undef putc +#undef getc +#undef putchar +#undef getchar +#undef feof +#undef ferror +#undef fileno +#undef clearerr + +#define FILE IOSTREAM +#define stdin Sinput +#define stdout Soutput +#define stderr Serror + +#define putc Sputc +#define getc Sgetc +#define fputc Sputc +#define fgetc Sgetc +#define getw Sgetw +#define putw Sputw +#define fread Sfread +#define fwrite Sfwrite +#define ungetc Sungetc +#define putchar Sputchar +#define getchar Sgetchar +#define feof Sfeof +#define ferror Sferror +#define clearerr Sclearerr +#define fflush Sflush +#define fseek Sseek +#define ftell Stell +#define fclose Sclose +#define fgets Sfgets +#define gets Sgets +#define fputs Sfputs +#define puts Sputs +#define fprintf Sfprintf +#define printf Sprintf +#define vprintf Svprintf +#define vfprintf Svfprintf +#define sprintf Ssprintf +#define vsprintf Svsprintf +#define fopen Sopen_file +#define fdopen Sfdopen +#define fileno Sfileno +#define popen Sopen_pipe + +#endif /*IOSTREAM_REPLACES_STDIO*/ + + /******************************* + * PROTOTYPES * + *******************************/ + +PL_EXPORT(void) SinitStreams(void); +PL_EXPORT(void) Scleanup(void); +PL_EXPORT(void) Sreset(void); +PL_EXPORT(int) S__fupdatefilepos_getc(IOSTREAM *s, int c); +PL_EXPORT(int) S__fcheckpasteeof(IOSTREAM *s, int c); +PL_EXPORT(int) S__fillbuf(IOSTREAM *s); +PL_EXPORT(int) Sunit_size(IOSTREAM *s); + /* byte I/O */ +PL_EXPORT(int) Sputc(int c, IOSTREAM *s); +PL_EXPORT(int) Sfgetc(IOSTREAM *s); +PL_EXPORT(int) Sungetc(int c, IOSTREAM *s); + /* multibyte I/O */ +PL_EXPORT(int) Scanrepresent(int c, IOSTREAM *s); +PL_EXPORT(int) Sputcode(int c, IOSTREAM *s); +PL_EXPORT(int) Sgetcode(IOSTREAM *s); +PL_EXPORT(int) Sungetcode(int c, IOSTREAM *s); + /* word I/O */ +PL_EXPORT(int) Sputw(int w, IOSTREAM *s); +PL_EXPORT(int) Sgetw(IOSTREAM *s); +PL_EXPORT(size_t) Sfread(void *data, size_t size, size_t elems, + IOSTREAM *s); +PL_EXPORT(size_t) Sfwrite(const void *data, size_t size, size_t elems, + IOSTREAM *s); +PL_EXPORT(int) Sfeof(IOSTREAM *s); +PL_EXPORT(int) Sfpasteof(IOSTREAM *s); +PL_EXPORT(int) Sferror(IOSTREAM *s); +PL_EXPORT(void) Sclearerr(IOSTREAM *s); +PL_EXPORT(void) Sseterr(IOSTREAM *s, int which, const char *message); +#ifdef _FLI_H_INCLUDED +PL_EXPORT(void) Sset_exception(IOSTREAM *s, term_t ex); +#else +PL_EXPORT(void) Sset_exception(IOSTREAM *s, intptr_t ex); +#endif +PL_EXPORT(int) Ssetenc(IOSTREAM *s, IOENC new_enc, IOENC *old_enc); +PL_EXPORT(int) Sflush(IOSTREAM *s); +PL_EXPORT(long) Ssize(IOSTREAM *s); +PL_EXPORT(int) Sseek(IOSTREAM *s, long pos, int whence); +PL_EXPORT(long) Stell(IOSTREAM *s); +PL_EXPORT(int) Sclose(IOSTREAM *s); +PL_EXPORT(char *) Sfgets(char *buf, int n, IOSTREAM *s); +PL_EXPORT(char *) Sgets(char *buf); +PL_EXPORT(ssize_t) Sread_pending(IOSTREAM *s, + char *buf, size_t limit, int flags); +PL_EXPORT(int) Sfputs(const char *q, IOSTREAM *s); +PL_EXPORT(int) Sputs(const char *q); +PL_EXPORT(int) Sfprintf(IOSTREAM *s, const char *fm, ...); +PL_EXPORT(int) Sprintf(const char *fm, ...); +PL_EXPORT(int) Svprintf(const char *fm, va_list args); +PL_EXPORT(int) Svfprintf(IOSTREAM *s, const char *fm, va_list args); +PL_EXPORT(int) Ssprintf(char *buf, const char *fm, ...); +PL_EXPORT(int) Svsprintf(char *buf, const char *fm, va_list args); +PL_EXPORT(int) Svdprintf(const char *fm, va_list args); +PL_EXPORT(int) Sdprintf(const char *fm, ...); +PL_EXPORT(int) Slock(IOSTREAM *s); +PL_EXPORT(int) StryLock(IOSTREAM *s); +PL_EXPORT(int) Sunlock(IOSTREAM *s); +PL_EXPORT(IOSTREAM *) Snew(void *handle, int flags, IOFUNCTIONS *functions); +PL_EXPORT(IOSTREAM *) Sopen_file(const char *path, const char *how); +PL_EXPORT(IOSTREAM *) Sfdopen(int fd, const char *type); +PL_EXPORT(int) Sfileno(IOSTREAM *s); +PL_EXPORT(IOSTREAM *) Sopen_pipe(const char *command, const char *type); +PL_EXPORT(IOSTREAM *) Sopenmem(char **buffer, size_t *sizep, const char *mode); +PL_EXPORT(IOSTREAM *) Sopen_string(IOSTREAM *s, char *buf, size_t sz, const char *m); +PL_EXPORT(int) Sclosehook(void (*hook)(IOSTREAM *s)); +PL_EXPORT(void) Sfree(void *ptr); +PL_EXPORT(int) Sset_filter(IOSTREAM *parent, IOSTREAM *filter); +PL_EXPORT(void) Ssetbuffer(IOSTREAM *s, char *buf, size_t size); + +PL_EXPORT(int64_t) Stell64(IOSTREAM *s); +PL_EXPORT(int) Sseek64(IOSTREAM *s, int64_t pos, int whence); + +PL_EXPORT(int) ScheckBOM(IOSTREAM *s); +PL_EXPORT(int) SwriteBOM(IOSTREAM *s); + +#ifdef __cplusplus +} +#endif + +#endif /*_PL_STREAM_H*/ diff --git a/LGPL/PLStream/pl-string.c b/LGPL/PLStream/pl-string.c new file mode 100644 index 000000000..8ac40d0d2 --- /dev/null +++ b/LGPL/PLStream/pl-string.c @@ -0,0 +1,67 @@ + +#include "pl-incl.h" + + + /******************************** + * STRINGS * + *********************************/ + + +#ifdef O_DEBUG +#define CHAR_INUSE 0x42 +#define CHAR_FREED 0x41 + +char * +store_string(const char *s) +{ if ( s ) + { GET_LD + char *copy = (char *)allocHeap(strlen(s)+2); + + *copy++ = CHAR_INUSE; + strcpy(copy, s); + + return copy; + } else + { return NULL; + } +} + + +void +remove_string(char *s) +{ if ( s ) + { GET_LD + assert(s[-1] == CHAR_INUSE); + + s[-1] = CHAR_FREED; + freeHeap(s-1, strlen(s)+2); + } +} + +#else /*O_DEBUG*/ + +char * +store_string(const char *s) +{ if ( s ) + { GET_LD + + char *copy = (char *)allocHeap(strlen(s)+1); + + strcpy(copy, s); + return copy; + } else + { return NULL; + } +} + + +void +remove_string(char *s) +{ if ( s ) + { GET_LD + freeHeap(s, strlen(s)+1); + } +} + +#endif /*O_DEBUG*/ + diff --git a/LGPL/PLStream/pl-table.c b/LGPL/PLStream/pl-table.c new file mode 100644 index 000000000..5d6ba8bba --- /dev/null +++ b/LGPL/PLStream/pl-table.c @@ -0,0 +1,427 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: jan@swi.psy.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2002, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +/*#define O_DEBUG 1*/ +#include "pl-incl.h" +#ifdef O_PLMT +#define LOCK_TABLE(t) if ( t->mutex ) simpleMutexLock(t->mutex) +#define UNLOCK_TABLE(t) if ( t->mutex ) simpleMutexUnlock(t->mutex) +#else +#define LOCK_TABLE(t) (void)0 +#define UNLOCK_TABLE(t) (void)0 +#endif + +static inline Symbol rawAdvanceTableEnum(TableEnum e); + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +This file provides generic hash-tables. Most of the implementation is +rather straightforward. Special are the *TableEnum() functions to +create, advance over and destroy enumerator objects. These objects are +used to enumerate the symbols of these tables, used primarily for the +pl_current_* predicates. + +The enumerators cause two things: (1) as intptr_t enumerators are +associated, the table will not be rehashed and (2) if symbols are +deleted that are referenced by an enumerator, the enumerator is +automatically advanced to the next free symbol. This, in general, makes +the enumeration of hash-tables safe. + +TODO: abort should delete any pending enumerators. This should be +thread-local, as thread_exit/1 should do the same. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static void +allocHTableEntries(Table ht) +{ int n; + Symbol *p; + + ht->entries = allocHeap(ht->buckets * sizeof(Symbol)); + + for(n=0, p = &ht->entries[0]; n < ht->buckets; n++, p++) + *p = NULL; +} + + +Table +newHTable(int buckets) +{ Table ht; + + ht = allocHeap(sizeof(struct table)); + ht->buckets = (buckets & ~TABLE_MASK); + ht->size = 0; + ht->enumerators = NULL; + ht->free_symbol = NULL; + ht->copy_symbol = NULL; +#ifdef O_PLMT + if ( (buckets & TABLE_UNLOCKED) ) + ht->mutex = NULL; + else + { ht->mutex = allocHeap(sizeof(simpleMutex)); + simpleMutexInit(ht->mutex); + } +#endif + + allocHTableEntries(ht); + return ht; +} + + +void +destroyHTable(Table ht) +{ +#ifdef O_PLMT + if ( ht->mutex ) + { simpleMutexDelete(ht->mutex); + freeHeap(ht->mutex, sizeof(*ht->mutex)); + ht->mutex = NULL; + } +#endif + + clearHTable(ht); + freeHeap(ht->entries, ht->buckets * sizeof(Symbol)); + freeHeap(ht, sizeof(struct table)); +} + + +#if O_DEBUG || O_HASHSTAT +#define HASHSTAT(c) c +static int lookups; +static int cmps; + +void +exitTables(int status, void *arg) +{ Sdprintf("hashstat: Anonymous tables: %d lookups using %d compares\n", + lookups, cmps); +} +#else +#define HASHSTAT(c) +#endif /*O_DEBUG*/ + + +void +initTables() +{ static int done = FALSE; + + if ( !done ) + { done = TRUE; + + HASHSTAT(PL_on_halt(exitTables, NULL)); + } +} + + +Symbol +lookupHTable(Table ht, void *name) +{ Symbol s = ht->entries[pointerHashValue(name, ht->buckets)]; + + HASHSTAT(lookups++); + for( ; s; s = s->next) + { HASHSTAT(cmps++); + if ( s->name == name ) + return s; + } + + return NULL; +} + +#ifdef O_DEBUG +void +checkHTable(Table ht) +{ int i; + int n = 0; + + for(i=0; ibuckets; i++) + { Symbol s; + + for(s=ht->entries[i]; s; s=s->next) + { assert(lookupHTable(ht, s->name) == s); + n++; + } + } + + assert(n == ht->size); +} +#endif + +/* MT: Locked by calling addHTable() +*/ + +static void +rehashHTable(Table ht) +{ Symbol *oldtab; + int oldbucks; + int i; + + oldtab = ht->entries; + oldbucks = ht->buckets; + ht->buckets *= 2; + allocHTableEntries(ht); + + DEBUG(1, Sdprintf("Rehashing table %p to %d entries\n", ht, ht->buckets)); + + for(i=0; iname, ht->buckets); + + n = s->next; + s->next = ht->entries[v]; + ht->entries[v] = s; + } + } + + freeHeap(oldtab, oldbucks * sizeof(Symbol)); + DEBUG(0, checkHTable(ht)); +} + + +Symbol +addHTable(Table ht, void *name, void *value) +{ Symbol s; + int v; + + LOCK_TABLE(ht); + v = (int)pointerHashValue(name, ht->buckets); + if ( lookupHTable(ht, name) ) + { UNLOCK_TABLE(ht); + return NULL; + } + s = allocHeap(sizeof(struct symbol)); + s->name = name; + s->value = value; + s->next = ht->entries[v]; + ht->entries[v] = s; + ht->size++; + DEBUG(9, Sdprintf("addHTable(0x%x, 0x%x, 0x%x) --> size = %d\n", + ht, name, value, ht->size)); + + if ( ht->buckets * 2 < ht->size && !ht->enumerators ) + rehashHTable(ht); + UNLOCK_TABLE(ht); + + DEBUG(1, checkHTable(ht)); + return s; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Note: s must be in the table! +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +void +deleteSymbolHTable(Table ht, Symbol s) +{ int v; + Symbol *h; + TableEnum e; + + LOCK_TABLE(ht); + v = (int)pointerHashValue(s->name, ht->buckets); + h = &ht->entries[v]; + + for( e=ht->enumerators; e; e = e->next ) + { if ( e->current == s ) + rawAdvanceTableEnum(e); + } + + for( ; *h; h = &(*h)->next ) + { if ( *h == s ) + { *h = (*h)->next; + + freeHeap(s, sizeof(struct symbol)); + ht->size--; + + break; + } + } + + UNLOCK_TABLE(ht); +} + + +void +clearHTable(Table ht) +{ int n; + TableEnum e; + + LOCK_TABLE(ht); + for( e=ht->enumerators; e; e = e->next ) + { e->current = NULL; + e->key = ht->buckets; + } + + for(n=0; n < ht->buckets; n++) + { Symbol s, q; + + for(s = ht->entries[n]; s; s = q) + { q = s->next; + + if ( ht->free_symbol ) + (*ht->free_symbol)(s); + + freeHeap(s, sizeof(struct symbol)); + } + + ht->entries[n] = NULL; + } + + ht->size = 0; + UNLOCK_TABLE(ht); +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Table copyHTable(Table org) + Make a copy of a hash-table. This is used to realise the copy-on-write + as defined by SharedTable. The table is copied to have exactly the + same dimensions as the original. If the copy_symbol function is + provided, it is called to allow duplicating the symbols name or value + fields. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +Table +copyHTable(Table org) +{ Table ht; + int n; + + ht = allocHeap(sizeof(struct table)); + LOCK_TABLE(org); + *ht = *org; /* copy all attributes */ +#ifdef O_PLMT + ht->mutex = NULL; +#endif + allocHTableEntries(ht); + + for(n=0; n < ht->buckets; n++) + { Symbol s, *q; + + q = &ht->entries[n]; + for(s = org->entries[n]; s; s = s->next) + { Symbol s2 = allocHeap(sizeof(*s2)); + + *q = s2; + q = &s2->next; + s2->name = s->name; + s2->value = s->value; + + if ( ht->copy_symbol ) + (*ht->copy_symbol)(s2); + } + *q = NULL; + } +#ifdef O_PLMT + if ( org->mutex ) + { ht->mutex = allocHeap(sizeof(simpleMutex)); + simpleMutexInit(ht->mutex); + } +#endif + UNLOCK_TABLE(org); + + return ht; +} + + + /******************************* + * ENUMERATING * + *******************************/ + +TableEnum +newTableEnum(Table ht) +{ TableEnum e = allocHeap(sizeof(struct table_enum)); + Symbol n; + + LOCK_TABLE(ht); + e->table = ht; + e->key = 0; + e->next = ht->enumerators; + ht->enumerators = e; + + n = ht->entries[0]; + while(!n && ++e->key < ht->buckets) + n=ht->entries[e->key]; + e->current = n; + UNLOCK_TABLE(ht); + + return e; +} + + +void +freeTableEnum(TableEnum e) +{ TableEnum *ep; + Table ht; + + if ( !e ) + return; + + ht = e->table; + LOCK_TABLE(ht); + for( ep=&ht->enumerators; *ep ; ep = &(*ep)->next ) + { if ( *ep == e ) + { *ep = (*ep)->next; + + freeHeap(e, sizeof(*e)); + break; + } + } + UNLOCK_TABLE(ht); +} + + +static inline Symbol +rawAdvanceTableEnum(TableEnum e) +{ Symbol s, n; + Table ht = e->table; + + if ( !(s = e->current) ) + return s; + n = s->next; + + while(!n) + { if ( ++e->key >= ht->buckets ) + { e->current = NULL; + return s; + } + + n=ht->entries[e->key]; + } + e->current = n; + + return s; +} + + +Symbol +advanceTableEnum(TableEnum e) +{ Symbol s; +#ifdef O_PLMT + Table ht = e->table; +#endif + + LOCK_TABLE(ht); + s = rawAdvanceTableEnum(e); + UNLOCK_TABLE(ht); + + return s; +} diff --git a/LGPL/PLStream/pl-table.h b/LGPL/PLStream/pl-table.h new file mode 100644 index 000000000..9f60ddecf --- /dev/null +++ b/LGPL/PLStream/pl-table.h @@ -0,0 +1,58 @@ +/***** + Hash Tables pl-table.h +****/ + +#define LMASK_BITS 7 /* total # mask bits */ + +#define TABLE_MASK 0xf0000000UL + +#define pointerHashValue(p, size) ((((intptr_t)(p) >> LMASK_BITS) ^ \ + ((intptr_t)(p) >> (LMASK_BITS+5)) ^ \ + ((intptr_t)(p))) & \ + ((size)-1)) + +typedef struct symbol * Symbol; /* symbol of hash table */ + +/* hash Table + lock + scaling + enumerator */ +typedef struct table *Table; + +typedef struct table_enum* TableEnum; + +/* symbol table hash package */ + +struct table +{ int buckets; /* size of hash table */ + int size; /* # symbols in the table */ + TableEnum enumerators; /* Handles for enumeration */ +#ifdef O_PLMT + simpleMutex *mutex; /* Mutex to guard table */ +#endif + void (*copy_symbol)(Symbol s); + void (*free_symbol)(Symbol s); + Symbol *entries; /* array of hash symbols */ +}; + +struct symbol +{ Symbol next; /* next in chain */ + void * name; /* name entry of symbol */ + void * value; /* associated value with name */ +}; + +struct table_enum +{ Table table; /* Table we are working on */ + int key; /* Index of current symbol-chain */ + Symbol current; /* The current symbol */ + TableEnum next; /* More choice points */ +}; + +extern void initTables(void); +extern Table newHTable(int size); +extern void destroyHTable(Table ht); +extern Symbol lookupHTable(Table ht, void *name); +extern Symbol addHTable(Table ht, void *name, void *value); +extern void deleteSymbolHTable(Table ht, Symbol s); +extern void clearHTable(Table ht); +extern Table copyHTable(Table org); +extern TableEnum newTableEnum(Table ht); +extern void freeTableEnum(TableEnum e); +extern Symbol advanceTableEnum(TableEnum e); diff --git a/LGPL/PLStream/pl-text.c b/LGPL/PLStream/pl-text.c new file mode 100644 index 000000000..e030c39fc --- /dev/null +++ b/LGPL/PLStream/pl-text.c @@ -0,0 +1,1158 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker and Anjo Anjewierden + E-mail: jan@swi.psy.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2002, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +#include "pl-incl.h" +#include "pl-ctype.h" +#include "pl-utf8.h" +#include +#include +#ifdef __WINDOWS__ +#include "pl-mswchar.h" /* Terrible hack */ +#endif + +#undef LD +#define LD LOCAL_LD + +#ifdef SWI_PROLOG +static inline word +valHandle__LD(term_t r ARG_LD) +{ Word p = valTermRef(r); + + deRef(p); + return *p; +} + +#define valHandle(r) valHandle__LD(r PASS_LD) +#define setHandle(h, w) (*valTermRef(h) = (w)) +#endif + + + /******************************* + * UNIFIED TEXT STUFF * + *******************************/ + +static inline size_t +bufsize_text(PL_chars_t *text, size_t len) +{ size_t unit; + + switch(text->encoding) + { case ENC_ISO_LATIN_1: + case ENC_ASCII: + case ENC_UTF8: + case ENC_ANSI: + unit = sizeof(char); + break; + case ENC_WCHAR: + unit = sizeof(pl_wchar_t); + break; + default: + assert(0); + unit = sizeof(char); /*NOTREACHED*/ + } + + return len*unit; +} + + +void +PL_save_text(PL_chars_t *text, int flags) +{ if ( (flags & BUF_MALLOC) && text->storage != PL_CHARS_MALLOC ) + { size_t bl = bufsize_text(text, text->length+1); + void *new = PL_malloc(bl); + + memcpy(new, text->text.t, bl); + text->text.t = new; + text->storage = PL_CHARS_MALLOC; + } else if ( text->storage == PL_CHARS_LOCAL ) + { Buffer b = findBuffer(BUF_RING); + size_t bl = bufsize_text(text, text->length+1); + + addMultipleBuffer(b, text->text.t, bl, char); + text->text.t = baseBuffer(b, char); + + text->storage = PL_CHARS_RING; + } +} + + +int +PL_get_text__LD(term_t l, PL_chars_t *text, int flags ARG_LD) +{ + Word w = valHandle(l); + + if ( (flags & CVT_ATOM) && isAtom(w) ) + { if ( !get_atom_text(w, text) ) + goto maybe_write; + } else if ( (flags & CVT_STRING) && isString(w) ) + { if ( !get_string_text(w, text PASS_LD) ) + goto maybe_write; + } else if ( (flags & CVT_INTEGER) && isInteger(w) ) + { number n; + + PL_get_number(l, &n); + switch(n.type) + { case V_INTEGER: + sprintf(text->buf, INT64_FORMAT, n.value.i); + text->text.t = text->buf; + text->length = strlen(text->text.t); + text->storage = PL_CHARS_LOCAL; + break; +#ifdef O_GMP + case V_MPZ: + { size_t sz = mpz_sizeinbase(n.value.mpz, 10) + 2; + Buffer b = findBuffer(BUF_RING); + + growBuffer(b, sz); + mpz_get_str(b->base, 10, n.value.mpz); + b->top = b->base + strlen(b->base); + text->text.t = baseBuffer(b, char); + text->length = entriesBuffer(b, char); + text->storage = PL_CHARS_RING; + + break; + } +#endif + default: + assert(0); + } + text->encoding = ENC_ISO_LATIN_1; + text->canonical = TRUE; + } else if ( (flags & CVT_FLOAT) && isReal(w) ) + { format_float(valReal(w), text->buf, LD->float_format); + text->text.t = text->buf; + text->length = strlen(text->text.t); + text->encoding = ENC_ISO_LATIN_1; + text->storage = PL_CHARS_LOCAL; + text->canonical = TRUE; + } else if ( (flags & CVT_LIST) && + (isList(w) || isNil(w)) ) + { Buffer b; + + if ( (b = codes_or_chars_to_buffer(l, BUF_RING, FALSE)) ) + { text->length = entriesBuffer(b, char); + addBuffer(b, EOS, char); + text->text.t = baseBuffer(b, char); + text->encoding = ENC_ISO_LATIN_1; + } else if ( (b = codes_or_chars_to_buffer(l, BUF_RING, TRUE)) ) + { text->length = entriesBuffer(b, pl_wchar_t); + addBuffer(b, EOS, pl_wchar_t); + text->text.w = baseBuffer(b, pl_wchar_t); + text->encoding = ENC_WCHAR; + } else + goto maybe_write; + + text->storage = PL_CHARS_RING; + text->canonical = TRUE; + } else if ( (flags & CVT_VARIABLE) && isVar(w) ) + { text->text.t = varName(l, text->buf); + text->length = strlen(text->text.t); + text->encoding = ENC_ISO_LATIN_1; + text->storage = PL_CHARS_LOCAL; + text->canonical = TRUE; + } else if ( (flags & CVT_WRITE) ) + { IOENC encodings[3]; + IOENC *enc; + char *r; + + case_write: + encodings[0] = ENC_ISO_LATIN_1; + encodings[1] = ENC_WCHAR; + encodings[2] = ENC_UNKNOWN; + + for(enc = encodings; *enc != ENC_UNKNOWN; enc++) + { size_t size; + IOSTREAM *fd; + + r = text->buf; + size = sizeof(text->buf); + fd = Sopenmem(&r, &size, "w"); + fd->encoding = *enc; + if ( PL_write_term(fd, l, 1200, 0) && + Sputcode(EOS, fd) >= 0 && + Sflush(fd) >= 0 ) + { text->encoding = *enc; + text->storage = (r == text->buf ? PL_CHARS_LOCAL : PL_CHARS_MALLOC); + text->canonical = TRUE; + + if ( *enc == ENC_ISO_LATIN_1 ) + { text->length = size-1; + text->text.t = r; + } else + { text->length = (size/sizeof(pl_wchar_t))-1; + text->text.w = (pl_wchar_t *)r; + } + + Sclose(fd); + + return TRUE; + } else + { Sclose(fd); + if ( r != text->buf ) + Sfree(r); + } + } + + goto error; + } else + { goto error; + } + + succeed; + +maybe_write: + if ( (flags & CVT_WRITE) ) + goto case_write; + +error: + if ( (flags & CVT_EXCEPTION) ) + { atom_t expected; + + if ( flags & CVT_LIST ) + expected = ATOM_text; + else if ( flags & CVT_NUMBER ) + expected = ATOM_atomic; + else + expected = ATOM_atom; + + return PL_error(NULL, 0, NULL, ERR_TYPE, expected, l); + } + + fail; +} + + +atom_t +textToAtom(PL_chars_t *text) +{ PL_canonise_text(text); + + if ( text->encoding == ENC_ISO_LATIN_1 ) + { return lookupAtom(text->text.t, text->length); + } else + { return lookupUCSAtom(text->text.w, text->length); + } +} + + +#if SWI_PROLOG +word +textToString(PL_chars_t *text) +{ PL_canonise_text(text); + + if ( text->encoding == ENC_ISO_LATIN_1 ) + { return globalString(text->length, text->text.t); + } else + { return globalWString(text->length, text->text.w); + } +} +#endif + + +int +PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type) +{ switch(type) + { case PL_ATOM: + { atom_t a = textToAtom(text); + int rval = _PL_unify_atomic(term, a); + + PL_unregister_atom(a); + return rval; + } + case PL_STRING: +#if SWI_PROLOG + { word w = textToString(text); + + return _PL_unify_atomic(term, w); + } +#endif + case PL_CODE_LIST: + case PL_CHAR_LIST: + { if ( text->length == 0 ) + { if ( tail ) + { GET_LD + PL_put_term(tail, term); + return TRUE; + } else + { return PL_unify_nil(term); + } + } else + { GET_LD + term_t l = PL_new_term_ref(); + word p0, p; + + switch(text->encoding) + { case ENC_ISO_LATIN_1: + { const unsigned char *s = (const unsigned char *)text->text.t; + const unsigned char *e = &s[text->length]; + +#if SWI_PROLOG + p0 = p = allocGlobal(text->length*3); + for( ; s < e; s++) + { *p++ = FUNCTOR_dot2; + if ( type == PL_CODE_LIST ) + *p++ = consInt(*s); + else + *p++ = codeToAtom(*s); + *p = consPtr(p+1, TAG_COMPOUND|STG_GLOBAL); + p++; + } +#endif + break; + } + case ENC_WCHAR: + { const pl_wchar_t *s = (const pl_wchar_t *)text->text.t; + const pl_wchar_t *e = &s[text->length]; + +#if SWI_PROLOG + p0 = p = allocGlobal(text->length*3); + for( ; s < e; s++) + { *p++ = FUNCTOR_dot2; + if ( type == PL_CODE_LIST ) + *p++ = consInt(*s); + else + *p++ = codeToAtom(*s); + *p = consPtr(p+1, TAG_COMPOUND|STG_GLOBAL); + p++; + } +#endif + break; + } + case ENC_UTF8: + { const char *s = text->text.t; + const char *e = &s[text->length]; + size_t len = utf8_strlen(s, text->length); + +#if SWI_PROLOG + p0 = p = allocGlobal(len*3); + while(stext.t; + size_t rc, n = text->length; + size_t len = 0; + mbstate_t mbs; + wchar_t wc; + + memset(&mbs, 0, sizeof(mbs)); + while( n > 0 && (rc=mbrtowc(&wc, s, n, &mbs)) != (size_t)-1 ) + { len++; + n -= rc; + s += rc; + } + +#if SWI_PROLOG + p0 = p = allocGlobal(len*3); + memset(&mbs, 0, sizeof(mbs)); + n = text->length; + + while(n > 0) + { rc = mbrtowc(&wc, s, n, &mbs); + + *p++ = FUNCTOR_dot2; + if ( type == PL_CODE_LIST ) + *p++ = consInt(wc); + else + *p++ = codeToAtom(wc); + *p = consPtr(p+1, TAG_COMPOUND|STG_GLOBAL); + p++; + + s += rc; + n -= rc; + } +#endif + break; + } + default: + { assert(0); + + return FALSE; + } + } + +#if SWI_PROLOG + setHandle(l, consPtr(p0, TAG_COMPOUND|STG_GLOBAL)); + p--; + if ( tail ) + { setVar(*p); + if ( PL_unify(l, term) ) + { setHandle(tail, makeRefG(p)); + return TRUE; + } + + return FALSE; + } else + { *p = ATOM_nil; + return PL_unify(l, term); + } +#endif + } + } + default: + { assert(0); + + return FALSE; + } + } +} + + +int +PL_unify_text_range(term_t term, PL_chars_t *text, + size_t offset, size_t len, int type) +{ if ( offset == 0 && len == text->length ) + { return PL_unify_text(term, 0, text, type); + } else + { PL_chars_t sub; + int rc; + + if ( offset > text->length || offset + len > text->length ) + return FALSE; + + sub.length = len; + sub.storage = PL_CHARS_HEAP; + if ( text->encoding == ENC_ISO_LATIN_1 ) + { sub.text.t = text->text.t+offset; + sub.encoding = ENC_ISO_LATIN_1; + sub.canonical = TRUE; + } else + { sub.text.w = text->text.w+offset; + sub.encoding = ENC_WCHAR; + sub.canonical = FALSE; + } + + rc = PL_unify_text(term, 0, &sub, type); + + PL_free_text(&sub); + + return rc; + } +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +int PL_promote_text(PL_chars_t *text) + +Promote a text to USC if it is currently 8-bit text. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +int +PL_promote_text(PL_chars_t *text) +{ if ( text->encoding != ENC_WCHAR ) + { if ( text->storage == PL_CHARS_MALLOC ) + { pl_wchar_t *new = PL_malloc(sizeof(pl_wchar_t)*(text->length+1)); + pl_wchar_t *t = new; + const unsigned char *s = (const unsigned char *)text->text.t; + const unsigned char *e = &s[text->length]; + + while(stext.t); + text->text.w = new; + + text->encoding = ENC_WCHAR; + } else if ( text->storage == PL_CHARS_LOCAL && + (text->length+1)*sizeof(pl_wchar_t) < sizeof(text->buf) ) + { unsigned char buf[sizeof(text->buf)]; + unsigned char *f = buf; + unsigned char *e = &buf[text->length]; + pl_wchar_t *t = (pl_wchar_t*)text->buf; + + memcpy(buf, text->buf, text->length*sizeof(char)); + while(fencoding = ENC_WCHAR; + } else + { Buffer b = findBuffer(BUF_RING); + const unsigned char *s = (const unsigned char *)text->text.t; + const unsigned char *e = &s[text->length]; + + for( ; stext.w = baseBuffer(b, pl_wchar_t); + text->encoding = ENC_WCHAR; + text->storage = PL_CHARS_RING; + } + } + + succeed; +} + + +int +PL_demote_text(PL_chars_t *text) +{ if ( text->encoding != ENC_ISO_LATIN_1 ) + { if ( text->storage == PL_CHARS_MALLOC ) + { char *new = PL_malloc(sizeof(char)*(text->length+1)); + char *t = new; + const pl_wchar_t *s = (const pl_wchar_t *)text->text.t; + const pl_wchar_t *e = &s[text->length]; + + while(s 0xff ) + { PL_free(new); + return FALSE; + } + *t++ = *s++ & 0xff; + } + *t = EOS; + + PL_free(text->text.t); + text->text.t = new; + + text->encoding = ENC_ISO_LATIN_1; + } else if ( text->storage == PL_CHARS_LOCAL ) + { pl_wchar_t buf[sizeof(text->buf)/sizeof(pl_wchar_t)]; + pl_wchar_t *f = buf; + pl_wchar_t *e = &buf[text->length]; + char *t = text->buf; + + memcpy(buf, text->buf, text->length*sizeof(pl_wchar_t)); + while(f 0xff ) + return FALSE; + *t++ = *f++ & 0xff; + } + *t = EOS; + text->encoding = ENC_ISO_LATIN_1; + } else + { Buffer b = findBuffer(BUF_RING); + const pl_wchar_t *s = (const pl_wchar_t*)text->text.w; + const pl_wchar_t *e = &s[text->length]; + + for( ; s 0xff ) + { unfindBuffer(BUF_RING); + return FALSE; + } + addBuffer(b, *s&0xff, char); + } + addBuffer(b, EOS, char); + + text->text.t = baseBuffer(b, char); + text->storage = PL_CHARS_RING; + text->encoding = ENC_ISO_LATIN_1; + } + } + + succeed; +} + + +static int +can_demote(PL_chars_t *text) +{ if ( text->encoding != ENC_ISO_LATIN_1 ) + { const pl_wchar_t *w = (const pl_wchar_t*)text->text.w; + const pl_wchar_t *e = &w[text->length]; + + for(; w 0xff ) + return FALSE; + } + } + + return TRUE; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Convert text to 8-bit according to flags. May hold REP_UTF8 to convert +to UTF-8, REP_MB to convert to locale 8-bit representation or nothing to +convert to ISO Latin-1. This predicate can fail of the text cannot be +represented. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static int +wctobuffer(wchar_t c, mbstate_t *mbs, Buffer buf) +{ char b[MB_LEN_MAX]; + size_t n; + + if ( (n=wcrtomb(b, c, mbs)) != (size_t)-1 ) + { size_t i; + + for(i=0; iencoding != target ) + { Buffer b = findBuffer(BUF_RING); + + switch(text->encoding) + { case ENC_ISO_LATIN_1: + { const unsigned char *s = (const unsigned char*)text->text.t; + const unsigned char *e = &s[text->length]; + + if ( target == ENC_UTF8 ) + { for( ; stext.w; + const pl_wchar_t *e = &w[text->length]; + + if ( target == ENC_UTF8 ) + { for( ; wlength = sizeOfBuffer(b)-1; + text->text.t = baseBuffer(b, char); + text->encoding = target; + text->storage = PL_CHARS_RING; + } + + succeed; + +rep_error: + if ( (flags & CVT_EXCEPTION) ) + { char msg[128]; + + sprintf(msg, + "Cannot represent char U%04x using %s encoding", + norep, + target == ENC_ISO_LATIN_1 ? "ISO Latin-1" : "current locale"); + + return PL_error(NULL, 0, msg, ERR_REPRESENTATION, ATOM_encoding); + } + + fail; +} + + +int +PL_canonise_text(PL_chars_t *text) +{ if ( !text->canonical ) + { switch(text->encoding ) + { case ENC_ISO_LATIN_1: + break; /* nothing to do */ + case ENC_WCHAR: + { const pl_wchar_t *w = (const pl_wchar_t*)text->text.w; + const pl_wchar_t *e = &w[text->length]; + + for(; w 0xff ) + return FALSE; + } + + return PL_demote_text(text); + } + case ENC_UTF8: + { const char *s = text->text.t; + const char *e = &s[text->length]; + + while(sencoding = ENC_ISO_LATIN_1; + text->canonical = TRUE; + } else + { int chr; + int wide = FALSE; + size_t len = s - text->text.t; + + while(s 0xff ) /* requires wide characters */ + wide = TRUE; + len++; + } + + s = (const char *)text->text.t; + text->length = len; + + if ( wide ) + { pl_wchar_t *to = PL_malloc(sizeof(pl_wchar_t)*(len+1)); + + text->text.w = to; + while(sencoding = ENC_WCHAR; + text->storage = PL_CHARS_MALLOC; + } else + { char *to = PL_malloc(len+1); + + text->text.t = to; + while(sencoding = ENC_ISO_LATIN_1; + text->storage = PL_CHARS_MALLOC; + } + + text->canonical = TRUE; + } + + succeed; + } + case ENC_ANSI: + { mbstate_t mbs; + size_t len = 0; + int iso = TRUE; + char *s = text->text.t; + size_t rc, n = text->length; + wchar_t wc; + + memset(&mbs, 0, sizeof(mbs)); + while( n > 0 && (rc=mbrtowc(&wc, s, n, &mbs)) != (size_t)-1 ) + { if ( wc > 0xff ) + iso = FALSE; + len++; + n -= rc; + s += rc; + } + + if ( n == 0 ) + { const char *from = text->text.t; + void *do_free; + + n = text->length; + memset(&mbs, 0, sizeof(mbs)); + + if ( text->storage == PL_CHARS_MALLOC ) + do_free = text->text.t; + else + do_free = NULL; + + if ( iso ) + { char *to; + + text->encoding = ENC_ISO_LATIN_1; + if ( len+1 < sizeof(text->buf) ) + { text->text.t = text->buf; + text->storage = PL_CHARS_LOCAL; + } else + { text->text.t = PL_malloc(len+1); + text->storage = PL_CHARS_MALLOC; + } + + to = text->text.t; + while( n > 0 && (rc=mbrtowc(&wc, from, n, &mbs)) != (size_t)-1 ) + { *to++ = (char)wc; + n -= rc; + from += rc; + } + *to = EOS; + } else + { wchar_t *to; + char b2[sizeof(text->buf)]; + + text->encoding = ENC_WCHAR; + if ( len+1 < sizeof(text->buf)/sizeof(wchar_t) ) + { if ( text->text.t == text->buf ) + { memcpy(b2, text->buf, sizeof(text->buf)); + from = b2; + } + text->text.w = (wchar_t*)text->buf; + } else + { text->text.w = PL_malloc((len+1)*sizeof(wchar_t)); + text->storage = PL_CHARS_MALLOC; + } + + to = text->text.w; + while( n > 0 && (rc=mbrtowc(&wc, from, n, &mbs)) != (size_t)-1 ) + { *to++ = wc; + n -= rc; + from += rc; + } + *to = EOS; + } + + text->length = len; + text->canonical = TRUE; + if ( do_free ) + PL_free(do_free); + + succeed; + } + + fail; + } + default: + assert(0); + } + } + + succeed; +} + + +void +PL_free_text(PL_chars_t *text) +{ if ( text->storage == PL_CHARS_MALLOC ) + PL_free(text->text.t); +} + + +void +PL_text_recode(PL_chars_t *text, IOENC encoding) +{ if ( text->encoding != encoding ) + { switch(encoding) + { case ENC_UTF8: + { switch(text->encoding) + { case ENC_ASCII: + text->encoding = ENC_UTF8; + break; + case ENC_ISO_LATIN_1: + { Buffer b = findBuffer(BUF_RING); + const unsigned char *s = (const unsigned char *)text->text.t; + const unsigned char *e = &s[text->length]; + char tmp[8]; + + for( ; slength = entriesBuffer(b, char); + addBuffer(b, EOS, char); + text->text.t = baseBuffer(b, char); + text->encoding = ENC_UTF8; + text->storage = PL_CHARS_RING; + + break; + } + case ENC_WCHAR: + { Buffer b = findBuffer(BUF_RING); + const pl_wchar_t *s = text->text.w; + const pl_wchar_t *e = &s[text->length]; + char tmp[8]; + + for( ; s 0x7f ) + { const char *end = utf8_put_char(tmp, (int)*s); + const char *q = tmp; + + for(q=tmp; qlength = entriesBuffer(b, char); + addBuffer(b, EOS, char); + text->text.t = baseBuffer(b, char); + text->encoding = ENC_UTF8; + text->storage = PL_CHARS_RING; + + break; + } + default: + assert(0); + } + break; + default: + assert(0); + } + } + } +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +PL_cmp_text(PL_chars_t *t1, size_t o1, + PL_chars_t *t2, size_t o2, + size_t len) + +Compares two substrings of two text representations. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +int +PL_cmp_text(PL_chars_t *t1, size_t o1, PL_chars_t *t2, size_t o2, + size_t len) +{ ssize_t l = len; + int ifeq = 0; + + if ( l > (ssize_t)(t1->length - o1) ) + { l = t1->length - o1; + ifeq = -1; /* first is short */ + } + if ( l > (ssize_t)(t2->length - o2) ) + { l = t2->length - o2; + if ( ifeq == 0 ) + ifeq = 1; + } + + if ( l == 0 ) /* too long offsets */ + return ifeq; + + if ( t1->encoding == ENC_ISO_LATIN_1 && t2->encoding == ENC_ISO_LATIN_1 ) + { const unsigned char *s = (const unsigned char *)t1->text.t+o1; + const unsigned char *q = (const unsigned char *)t2->text.t+o2; + + for(; l-- > 0 && *s == *q; s++, q++ ) + ; + if ( l < 0 ) + return ifeq; + else + return *s > *q ? 1 : -1; + } else if ( t1->encoding == ENC_WCHAR && t2->encoding == ENC_WCHAR ) + { const pl_wchar_t *s = t1->text.w+o1; + const pl_wchar_t *q = t2->text.w+o2; + + for(; l-- > 0 && *s == *q; s++, q++ ) + ; + if ( l < 0 ) + return ifeq; + else + return *s > *q ? 1 : -1; + } else if ( t1->encoding == ENC_ISO_LATIN_1 && t2->encoding == ENC_WCHAR ) + { const unsigned char *s = (const unsigned char *)t1->text.t+o1; + const pl_wchar_t *q = t2->text.w+o2; + + for(; l-- > 0 && *s == *q; s++, q++ ) + ; + if ( l < 0 ) + return ifeq; + else + return *s > *q ? 1 : -1; + } else + { const pl_wchar_t *s = t1->text.w+o1; + const unsigned char *q = (const unsigned char *)t2->text.t+o2; + + for(; l-- > 0 && *s == *q; s++, q++ ) + ; + if ( l < 0 ) + return ifeq; + else + return *s > *q ? 1 : -1; + } +} + + +int +PL_concat_text(int n, PL_chars_t **text, PL_chars_t *result) +{ size_t total_length = 0; + int latin = TRUE; + int i; + + for(i=0; ilength; + } + + result->canonical = TRUE; + result->length = total_length; + + if ( latin ) + { char *to; + + result->encoding = ENC_ISO_LATIN_1; + if ( total_length+1 < sizeof(result->buf) ) + { result->text.t = result->buf; + result->storage = PL_CHARS_LOCAL; + } else + { result->text.t = PL_malloc(total_length+1); + result->storage = PL_CHARS_MALLOC; + } + + for(to=result->text.t, i=0; itext.t, text[i]->length); + to += text[i]->length; + } + *to = EOS; + } else + { pl_wchar_t *to; + + result->encoding = ENC_WCHAR; + if ( total_length+1 < sizeof(result->buf)/sizeof(pl_wchar_t) ) + { result->text.w = (pl_wchar_t*)result->buf; + result->storage = PL_CHARS_LOCAL; + } else + { result->text.w = PL_malloc((total_length+1)*sizeof(pl_wchar_t)); + result->storage = PL_CHARS_MALLOC; + } + + for(to=result->text.w, i=0; iencoding == ENC_WCHAR ) + { memcpy(to, text[i]->text.w, text[i]->length*sizeof(pl_wchar_t)); + to += text[i]->length; + } else + { const unsigned char *f = (const unsigned char *)text[i]->text.t; + const unsigned char *e = &f[text[i]->length]; + + while(ftext.w) == total_length); + *to = EOS; + } + + return TRUE; +} + + +IOSTREAM * +Sopen_text(PL_chars_t *txt, const char *mode) +{ IOSTREAM *stream; + + if ( !streq(mode, "r") ) + { errno = EINVAL; + return NULL; + } + + stream = Sopen_string(NULL, + txt->text.t, + bufsize_text(txt, txt->length), + mode); + stream->encoding = txt->encoding; + + return stream; +} + +int +PL_unify_chars(term_t t, int flags, size_t len, const char *s) +{ PL_chars_t text; + term_t tail; + int rc; + + if ( len == (size_t)-1 ) + len = strlen(s); + + text.text.t = (char *)s; + text.encoding = ((flags&REP_UTF8) ? ENC_UTF8 : \ + (flags&REP_MB) ? ENC_ANSI : ENC_ISO_LATIN_1); + text.storage = PL_CHARS_HEAP; + text.length = len; + text.canonical = FALSE; + + flags &= ~(REP_UTF8|REP_MB|REP_ISO_LATIN_1); + + if ( (flags & PL_DIFF_LIST) ) + { tail = t+1; + flags &= (~PL_DIFF_LIST); + } else + { tail = 0; + } + + rc = PL_unify_text(t, tail, &text, flags); + PL_free_text(&text); + + return rc; +} + diff --git a/LGPL/PLStream/pl-text.h b/LGPL/PLStream/pl-text.h new file mode 100644 index 000000000..c2c39d935 --- /dev/null +++ b/LGPL/PLStream/pl-text.h @@ -0,0 +1,80 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker and Anjo Anjewierden + E-mail: jan@swi.psy.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2002, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +#ifndef PL_TEXT_H_INCLUDED +#define PL_TEXT_H_INCLUDED + +typedef enum +{ PL_CHARS_MALLOC, /* malloced data */ + PL_CHARS_RING, /* stored in the buffer ring */ + PL_CHARS_HEAP, /* stored in program area (atoms) */ + PL_CHARS_STACK, /* stored on the global stack */ + PL_CHARS_LOCAL /* stored in in-line buffer */ +} PL_chars_alloc_t; + + +typedef struct +{ union + { char *t; /* tranditional 8-bit char* */ + pl_wchar_t *w; /* wide character string */ + } text; + size_t length; + /* private stuff */ + IOENC encoding; /* how it is encoded */ + PL_chars_alloc_t storage; /* how it is stored */ + int canonical; /* TRUE: ENC_ISO_LATIN_1 or ENC_WCHAR */ + char buf[100]; /* buffer for simple stuff */ +} PL_chars_t; + +#define PL_init_text(txt) \ + { (txt)->text.t = NULL; \ + (txt)->encoding = ENC_UNKNOWN; \ + (txt)->storage = PL_CHARS_LOCAL; \ + (txt)->canonical = FALSE; \ + } + +extern int PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type); +extern int PL_unify_text_range(term_t term, PL_chars_t *text, + size_t from, size_t len, int type); + +extern int PL_promote_text(PL_chars_t *text); +extern int PL_demote_text(PL_chars_t *text); +extern int PL_mb_text(PL_chars_t *text, int flags); +extern int PL_canonise_text(PL_chars_t *text); + +extern int PL_cmp_text(PL_chars_t *t1, size_t o1, PL_chars_t *t2, size_t o2, + size_t len); +extern int PL_concat_text(int n, PL_chars_t **text, PL_chars_t *result); + +extern void PL_free_text(PL_chars_t *text); +extern void PL_save_text(PL_chars_t *text, int flags); + +extern int PL_get_text__LD(term_t l, PL_chars_t *text, int flags ARG_LD); +extern atom_t textToAtom(PL_chars_t *text); + +extern IOSTREAM * Sopen_text(PL_chars_t *text, const char *mode); +extern void PL_text_recode(PL_chars_t *text, IOENC encoding); + + +#endif /*PL_TEXT_H_INCLUDED*/ diff --git a/LGPL/PLStream/pl-utf8.c b/LGPL/PLStream/pl-utf8.c new file mode 100644 index 000000000..294236356 --- /dev/null +++ b/LGPL/PLStream/pl-utf8.c @@ -0,0 +1,117 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker and Anjo Anjewierden + E-mail: jan@swi.psy.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2002, University of Amsterdam + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +#include /* get size_t */ +#include "pl-utf8.h" + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +UTF-8 Decoding, based on http://www.cl.cam.ac.uk/~mgk25/unicode.html +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#define CONT(i) ISUTF8_CB(in[i]) +#define VAL(i, s) ((in[i]&0x3f) << s) + +char * +_PL__utf8_get_char(const char *in, int *chr) +{ /* 2-byte, 0x80-0x7ff */ + if ( (in[0]&0xe0) == 0xc0 && CONT(1) ) + { *chr = ((in[0]&0x1f) << 6)|VAL(1,0); + return (char *)in+2; + } + /* 3-byte, 0x800-0xffff */ + if ( (in[0]&0xf0) == 0xe0 && CONT(1) && CONT(2) ) + { *chr = ((in[0]&0xf) << 12)|VAL(1,6)|VAL(2,0); + return (char *)in+3; + } + /* 4-byte, 0x10000-0x1FFFFF */ + if ( (in[0]&0xf8) == 0xf0 && CONT(1) && CONT(2) && CONT(3) ) + { *chr = ((in[0]&0x7) << 18)|VAL(1,12)|VAL(2,6)|VAL(3,0); + return (char *)in+4; + } + /* 5-byte, 0x200000-0x3FFFFFF */ + if ( (in[0]&0xfc) == 0xf8 && CONT(1) && CONT(2) && CONT(3) && CONT(4) ) + { *chr = ((in[0]&0x3) << 24)|VAL(1,18)|VAL(2,12)|VAL(3,6)|VAL(4,0); + return (char *)in+5; + } + /* 6-byte, 0x400000-0x7FFFFFF */ + if ( (in[0]&0xfe) == 0xfc && CONT(1) && CONT(2) && CONT(3) && CONT(4) && CONT(5) ) + { *chr = ((in[0]&0x1) << 30)|VAL(1,24)|VAL(2,18)|VAL(3,12)|VAL(4,6)|VAL(5,0); + return (char *)in+4; + } + + *chr = *in; + + return (char *)in+1; +} + + +char * +_PL__utf8_put_char(char *out, int chr) +{ if ( chr < 0x80 ) + { *out++ = chr; + } else if ( chr < 0x800 ) + { *out++ = 0xc0|((chr>>6)&0x1f); + *out++ = 0x80|(chr&0x3f); + } else if ( chr < 0x10000 ) + { *out++ = 0xe0|((chr>>12)&0x0f); + *out++ = 0x80|((chr>>6)&0x3f); + *out++ = 0x80|(chr&0x3f); + } else if ( chr < 0x200000 ) + { *out++ = 0xf0|((chr>>18)&0x07); + *out++ = 0x80|((chr>>12)&0x3f); + *out++ = 0x80|((chr>>6)&0x3f); + *out++ = 0x80|(chr&0x3f); + } else if ( chr < 0x4000000 ) + { *out++ = 0xf8|((chr>>24)&0x03); + *out++ = 0x80|((chr>>18)&0x3f); + *out++ = 0x80|((chr>>12)&0x3f); + *out++ = 0x80|((chr>>6)&0x3f); + *out++ = 0x80|(chr&0x3f); + } else if ( (unsigned)chr < 0x80000000 ) + { *out++ = 0xfc|((chr>>30)&0x01); + *out++ = 0x80|((chr>>24)&0x3f); + *out++ = 0x80|((chr>>18)&0x3f); + *out++ = 0x80|((chr>>12)&0x3f); + *out++ = 0x80|((chr>>6)&0x3f); + *out++ = 0x80|(chr&0x3f); + } + + return out; +} + + +size_t +utf8_strlen(const char *s, size_t len) +{ const char *e = &s[len]; + unsigned int l = 0; + + while(s= 0xc0 && (unsigned)(c) <= 0xfd) + +#define ISUTF8_CB(c) (((c)&0xc0) == 0x80) /* Is continuation byte */ +#define ISUTF8_FB2(c) (((c)&0xe0) == 0xc0) +#define ISUTF8_FB3(c) (((c)&0xf0) == 0xe0) +#define ISUTF8_FB4(c) (((c)&0xf8) == 0xf0) +#define ISUTF8_FB5(c) (((c)&0xfc) == 0xf8) +#define ISUTF8_FB6(c) (((c)&0xfe) == 0xfc) + +#define UTF8_FBN(c) (!(c&0x80) ? 0 : \ + ISUTF8_FB2(c) ? 1 : \ + ISUTF8_FB3(c) ? 2 : \ + ISUTF8_FB4(c) ? 3 : \ + ISUTF8_FB5(c) ? 4 : \ + ISUTF8_FB6(c) ? 5 : -1) +#define UTF8_FBV(c,n) ( n == 0 ? c : (c & ((0x01<<(6-n))-1)) ) + +#define utf8_get_char(in, chr) \ + (*(in) & 0x80 ? _PL__utf8_get_char(in, chr) \ + : (*(chr) = *(in), (char *)(in)+1)) +#define utf8_put_char(out, chr) \ + ((chr) < 0x80 ? out[0]=(char)(chr), out+1 \ + : _PL__utf8_put_char(out, (chr))) + +extern char *_PL__utf8_get_char(const char *in, int *chr); +extern char *_PL__utf8_put_char(char *out, int chr); + +extern size_t utf8_strlen(const char *s, size_t len); + + +#endif /*UTF8_H_INCLUDED*/ diff --git a/LGPL/PLStream/pl-yap.c b/LGPL/PLStream/pl-yap.c new file mode 100644 index 000000000..74ea61a38 --- /dev/null +++ b/LGPL/PLStream/pl-yap.c @@ -0,0 +1,539 @@ + +/* YAP support for some low-level SWI stuff */ + +#include +#include "pl-incl.h" + +static atom_t +uncachedCodeToAtom(int chrcode) +{ if ( chrcode < 256 ) + { char tmp[1]; + + tmp[0] = chrcode; + return lookupAtom(tmp, 1); + } else + { pl_wchar_t tmp[2]; + int new; + + tmp[0] = chrcode; + tmp[1] = '\0'; + + return (atom_t)YAP_LookupWideAtom(tmp); + } +} + + +atom_t +codeToAtom(int chrcode) +{ atom_t a; + + if ( chrcode == EOF ) + return ATOM_end_of_file; + + assert(chrcode >= 0); + + if ( chrcode < (1<<15) ) + { int page = chrcode / 256; + int entry = chrcode % 256; + atom_t *pv; + + if ( !(pv=GD->atoms.for_code[page]) ) + { pv = PL_malloc(256*sizeof(atom_t)); + + memset(pv, 0, 256*sizeof(atom_t)); + GD->atoms.for_code[page] = pv; + } + + if ( !(a=pv[entry]) ) + { a = pv[entry] = uncachedCodeToAtom(chrcode); + } + } else + { a = uncachedCodeToAtom(chrcode); + } + + return a; +} + +int +PL_rethrow(void) +{ GET_LD + + if ( LD->exception.throw_environment ) + longjmp(LD->exception.throw_environment->exception_jmp_env, 1); + + fail; +} + + +int +callProlog(module_t module, term_t goal, int flags, term_t *ex) +{ term_t g = PL_new_term_ref(); + functor_t fd; + predicate_t proc; + + if ( ex ) + *ex = 0; + + PL_strip_module(goal, &module, g); + if ( !PL_get_functor(g, &fd) ) + { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_callable, goal); + if ( ex ) + *ex = exception_term; + + fail; + } + + proc = PL_pred(fd, module); + + { int arity = arityFunctor(fd); + term_t args = PL_new_term_refs(arity); + qid_t qid; + int n, rval; + + for(n=0; ntype) + { case V_INTEGER: + succeed; +#ifdef O_GMP + case V_MPZ: + succeed; + case V_MPQ: /* never from stacks iff integer */ + if ( mpz_cmp_ui(mpq_denref(n->value.mpq), 1L) == 0 ) + { mpz_clear(mpq_denref(n->value.mpq)); + n->value.mpz[0] = mpq_numref(n->value.mpq)[0]; + n->type = V_MPZ; + succeed; + } + fail; +#endif + case V_REAL: + if ( (flags & TOINT_CONVERT_FLOAT) ) + { if ( double_in_int64_range(n->value.f) ) + { int64_t l = (int64_t)n->value.f; + + if ( (flags & TOINT_TRUNCATE) || + (double)l == n->value.f ) + { n->value.i = l; + n->type = V_INTEGER; + + return TRUE; + } + return FALSE; +#ifdef O_GMP + } else + { mpz_init_set_d(n->value.mpz, n->value.f); + n->type = V_MPZ; + + return TRUE; +#endif + } + } + return FALSE; + } +#endif + assert(0); + fail; +} + + +int +_PL_unify_atomic(term_t t, PL_atomic_t a) +{ + return YAP_Unify(Yap_GetFromSlot(t), (YAP_Term)a); +} + +word lookupAtom(const char *s, size_t len) +{ + return (word)YAP_LookupAtom(s); +} + +atom_t lookupUCSAtom(const pl_wchar_t *s, size_t len) +{ + return (atom_t)YAP_LookupWideAtom(s); +} + + + + /******************************* + * OPTIONS * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Variable argument list: + + atom_t name + int type OPT_ATOM, OPT_STRING, OPT_BOOL, OPT_INT, OPT_LONG + pointer value +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#define MAXOPTIONS 32 + +typedef union +{ bool *b; /* boolean value */ + long *l; /* long value */ + int *i; /* integer value */ + char **s; /* string value */ + word *a; /* atom value */ + term_t *t; /* term-reference */ + void *ptr; /* anonymous pointer */ +} optvalue; + + +bool +scan_options(term_t options, int flags, atom_t optype, + const opt_spec *specs, ...) +{ va_list args; + const opt_spec *s; + optvalue values[MAXOPTIONS]; + term_t list = PL_copy_term_ref(options); + term_t head = PL_new_term_ref(); + term_t tmp = PL_new_term_ref(); + term_t val = PL_new_term_ref(); + int n; + + if ( trueFeature(ISO_FEATURE) ) + flags |= OPT_ALL; + + va_start(args, specs); + for( n=0, s = specs; s->name; s++, n++ ) + values[n].ptr = va_arg(args, void *); + va_end(args); + + while ( PL_get_list(list, head, list) ) + { atom_t name; + int arity; + + if ( PL_get_name_arity(head, &name, &arity) ) + { if ( name == ATOM_equals && arity == 2 ) + { PL_get_arg(1, head, tmp); + + if ( !PL_get_atom(tmp, &name) ) + goto itemerror; + PL_get_arg(2, head, val); + } else if ( arity == 1 ) + { PL_get_arg(1, head, val); + } else if ( arity == 0 ) + PL_put_atom(val, ATOM_true); + } else if ( PL_is_variable(head) ) + { return PL_error(NULL, 0, NULL, ERR_INSTANTIATION); + } else + { itemerror: + return PL_error(NULL, 0, NULL, ERR_DOMAIN, optype, head); + } + + for( n=0, s = specs; s->name; n++, s++ ) + { if ( s->name == name ) + { switch((s->type & OPT_TYPE_MASK)) + { case OPT_BOOL: + { atom_t aval; + + if ( !PL_get_atom(val, &aval) ) + fail; + if ( aval == ATOM_true || aval == ATOM_on ) + *values[n].b = TRUE; + else if ( aval == ATOM_false || aval == ATOM_off ) + *values[n].b = FALSE; + else + goto itemerror; + break; + } + case OPT_INT: + { if ( !PL_get_integer(val, values[n].i) ) + goto itemerror; + + break; + } + case OPT_LONG: + { if ( !PL_get_long(val, values[n].l) ) + { if ( (s->type & OPT_INF) && PL_is_inf(val) ) + *values[n].l = LONG_MAX; + else + goto itemerror; + } + + break; + } + case OPT_NATLONG: + { if ( !PL_get_long(val, values[n].l) ) + goto itemerror; + if ( *(values[n].l) <= 0 ) + return PL_error(NULL, 0, NULL, ERR_DOMAIN, + ATOM_not_less_than_one, val); + + break; + } + case OPT_STRING: + { char *str; + + if ( !PL_get_chars(val, &str, CVT_ALL) ) /* copy? */ + goto itemerror; + *values[n].s = str; + break; + } + case OPT_ATOM: + { atom_t a; + + if ( !PL_get_atom(val, &a) ) + goto itemerror; + *values[n].a = a; + break; + } + case OPT_TERM: + { *values[n].t = val; + val = PL_new_term_ref(); /* can't reuse anymore */ + break; + } + default: + assert(0); + fail; + } + break; + } + } + + if ( !s->name && (flags & OPT_ALL) ) + goto itemerror; + } + + if ( !PL_get_nil(list) ) + return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, list); + + succeed; +} + + +int +get_atom_ptr_text(Atom a, PL_chars_t *text) +{ if (YAP_IsWideAtom(a)) + { pl_wchar_t *name = (pl_wchar_t *)YAP_WideAtomName(a); + text->text.w = name; + text->length = wcslen(name); + text->encoding = ENC_WCHAR; + } else + { char *name = (char *)YAP_AtomName(a); + text->text.t = name; + text->length = strlen(name); + text->encoding = ENC_ISO_LATIN_1; + } + text->storage = PL_CHARS_HEAP; + text->canonical = TRUE; + + succeed; +} + + +int +get_atom_text(atom_t atom, PL_chars_t *text) +{ Atom a = atomValue(atom); + + return get_atom_ptr_text(a, text); +} + +int +get_string_text(word w, PL_chars_t *text ARG_LD) +{ fail; +} + +void +PL_get_number(term_t l, number *n) { + YAP_Term t = valHandle(l); + if (YAP_IsIntTerm(t)) { + n->type = V_INTEGER; + n->value.i = YAP_IntOfTerm(t); +#ifdef O_GMP + } else { + n->type = V_MPZ; + n->value.mpz = YAP_BigNumOfTerm(t); +#endif + } +} + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Formatting a float. This is very complicated as we must write floats +such that it can be read as a float. This means using the conventions of +the C locale and if the float happens to be integer as .0. + +Switching the locale is no option as locale handling is not thread-safe +and may have unwanted consequences for embedding. There is a intptr_t +discussion on the very same topic on the Python mailinglist. Many hacks +are proposed, none is very satisfactory. Richard O'Keefe suggested to +use ecvt(), fcvt() and gcvt(). These are not thread-safe. The GNU C +library provides *_r() variations that can do the trick. An earlier +patch used localeconv() to find the decimal point, but this is both +complicated and not thread-safe. + +Finally, with help of Richard we decided to replace the first character +that is not a digit nor [eE], as this must be the decimal point. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#define isDigit(c) ((c) >= '0' && (c) <= '9') + +char * +format_float(double f, char *buf, const char *format) +{ char *q; + + sprintf(buf, format, f); + + q = buf; + if ( *q == '-' ) /* skip -?[0-9]* */ + q++; + while(*q && (isDigit(*q) || *q <= ' ')) + q++; + + switch( *q ) + { case '\0': + *q++ = '.'; + *q++ = '0'; + *q = EOS; + break; + case 'e': + case 'E': + break; + default: + *q = '.'; + } + + return buf; +} + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +codes_or_chars_to_buffer(term_t l, unsigned flags, int wide) + +If l represents a list of codes or characters, return a buffer holding +the characters. If wide == TRUE the buffer contains objects of type +pl_wchar_t. Otherwise it contains traditional characters. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static int +charCode(YAP_Term w) +{ if ( YAP_IsAtomTerm(w) ) + { + Atom a = atomValue(w); + + if ( YAP_AtomNameLength(a) == 1) { + if (YAP_IsWideAtom(a)) { + return YAP_WideAtomName(a)[0]; + } + return YAP_AtomName(a)[0]; + } + } + return -1; +} + + + +Buffer +codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide) +{ GET_LD + Buffer b; + YAP_Term list = YAP_GetFromSlot(l); + YAP_Term arg; + enum { CHARS, CODES } type; + + if ( YAP_IsPairTerm(list) ) + { arg = YAP_HeadOfTerm(list); + if ( YAP_IsIntTerm(arg) ) + { long int i = YAP_IntOfTerm(arg); + if ( i >= 0 && (wide || i < 256) ) + { type = CODES; + goto ok; + } + } else if ( charCode(arg) >= 0 ) + { type = CHARS; + goto ok; + } + } else if ( list != YAP_TermNil() ) + { return findBuffer(flags); + } + + fail; + +ok: + b = findBuffer(flags); + + while( YAP_IsPairTerm(list) ) + { intptr_t c = -1; + + arg = YAP_HeadOfTerm(list); + + switch(type) + { case CODES: + if ( YAP_IsIntTerm(arg) ) + { c = YAP_IntOfTerm(arg); + } + break; + case CHARS: + c = charCode(arg); + break; + } + + if ( c < 0 || (!wide && c > 0xff) ) + { unfindBuffer(flags); /* TBD: check unicode range */ + return NULL; + } + + if ( wide ) + addBuffer(b, (pl_wchar_t)c, pl_wchar_t); + else + addBuffer(b, (unsigned char)c, unsigned char); + + list = YAP_TailOfTerm(list); + } + if ( list != YAP_TermNil() ) + { unfindBuffer(flags); + return NULL; + } + + return b; +} diff --git a/LGPL/PLStream/pl-yap.h b/LGPL/PLStream/pl-yap.h new file mode 100644 index 000000000..ba6ab4ff2 --- /dev/null +++ b/LGPL/PLStream/pl-yap.h @@ -0,0 +1,154 @@ +#ifndef PL_YAP_H +#define PL_YAP_H + +#ifdef __YAP_PROLOG__ + +#if HAVE_CTYPE_H +#include +#endif + +#define SIZE_VOIDP SIZEOF_INT_P + +#if SIZE_DOUBLE==SIZEOF_INT_P +#define WORDS_PER_DOUBLE 1 +#else +#define WORDS_PER_DOUBLE 2 +#endif + +#if SIZEOF_LONG_INT==4 +#define INT64_FORMAT "%lld" +#define INTBITSIZE 32 +#else +#define INT64_FORMAT "%ld" +#define INTBITSIZE 64 +#endif + +typedef uintptr_t word; /* Anonymous 4 byte object */ +typedef YAP_Term Word; /* Anonymous 4 byte object */ +typedef YAP_Atom Atom; +//move this to SWI + +typedef uintptr_t PL_atomic_t; /* same a word */ + + +#define INIT_DEF(Type, Name, Size) \ + static Type Name[Size]; \ + static void init_ ## Name (void) { \ + int i = 0; + +#define ADD_DEF2(Atom, Type) \ + char_types[i].name = Atom; \ + char_types[i].test = Type; \ + i++; +#define ADD_DEF5(Atom, Type, Reverse, Arity, Ctx) \ + char_types[i].name = Atom; \ + char_types[i].test = Type; \ + char_types[i].reverse = Reverse; \ + char_types[i].arity = Arity; \ + char_types[i].ctx_type = Ctx; \ + i++; +#define END_DEFS(Atom, F) \ + char_types[i].name = Atom; \ + char_types[i].test = F; \ +} + +#define ADD_ENCODING(Atom, Type) \ + encoding_names[i].code = Atom; \ + encoding_names[i].name = Type; \ + i++; +#define END_ENCODINGS(Atom, F) \ + encoding_names[i].code = Atom; \ + encoding_names[i].name = F; \ +} + +#define ADD_OPEN4_OPT(Atom, Type) \ + open4_options[i].name = Atom; \ + open4_options[i].type = Type; \ + i++; +#define END_OPEN4_DEFS(Atom, F) \ + open4_options[i].name = Atom; \ + open4_options[i].type = F; \ +} + +#define ADD_CLOSE2_OPT(Atom, Type) \ + close2_options[i].name = Atom; \ + close2_options[i].type = Type; \ + i++; +#define END_CLOSE2_DEFS(Atom, F) \ + close2_options[i].name = Atom; \ + close2_options[i].type = F; \ +} + +#define ADD_SPROP(F1, F2) \ + sprop_list[i].functor = F1; \ + sprop_list[i].function = F2; \ + i++; +#define END_SPROP_DEFS(F1, F2) \ + sprop_list[i].functor = F1; \ + sprop_list[i].function = F2; \ +} + +#define ADD_STDSTREAM(Atom) \ + standardStreams[i] = Atom; \ + i++; +#define END_STDSTREAMS(Atom) \ + standardStreams[i] = Atom; \ +} + + +#define MK_ATOM(X) ((atom_t)YAP_LookupAtom(X)) +#define MKFUNCTOR(X,Y) ((functor_t)YAP_MkFunctor((YAP_Atom)(X),Y)) + +/*** memory allocation stuff: SWI wraps around malloc */ + +#define allocHeap(X) YAP_AllocSpaceFromYap(X) + +#define freeHeap(X,Size) YAP_FreeSpaceFromYap(X) + + +#define stopItimer() + +/* TBD */ +static inline word +INIT_SEQ_CODES(size_t n) +{ + return 0L; /* TBD: shift */ +} + +static inline word +EXTEND_SEQ_CODES(word gstore, int c) { + return gstore; +} + +static inline int +CLOSE_SEQ_OF_CODES(word gstore, word lp, word t1, word t2) { + return TRUE; +} + +static inline Word +valHandle(term_t tt) +{ + return (word)YAP_GetFromSlot(tt); +} +#define arityFunctor(f) YAP_ArityOfFunctor((YAP_Functor)f) + +#define stringAtom(w) YAP_AtomName((YAP_Atom)(w)) +#define isInteger(A) (YAP_IsIntTerm((A)) && YAP_IsBigNumTerm((A))) +#define isString(A) FALSE +#define isAtom(A) YAP_IsAtomTerm((A)) +#define isList(A) YAP_IsPairTerm((A)) +#define isNil(A) ((A) == YAP_TermNil()) +#define isReal(A)YAP_IsFloatTerm((A)) +#define isVar(A) YAP_IsVarTerm((A)) +#define varName(l, buf) buf +#define valReal(w) YAP_FloatOfTerm((w)) +#define AtomLength(w) YAP_AtomNameLength(w) +#define atomValue(atom) ((YAP_Atom)atom) +#define argTermP(w,i) ((Word)((YAP_ArgsOfTerm(w)+(i)))) +#define deRef(t) (t = YAP_Deref(t)) + +#define clearNumber(n) + +#endif /* __YAP_PROLOG__ */ + +#endif /* PL_YAP_H */