[m-dev.] Opium-M [1/5]
Erwan Jahier
Erwan.Jahier at irisa.fr
Tue Oct 26 23:40:05 AEST 1999
Estimated hours taken: 1000
Add Opium-M in the extras repository.
extras/opium_m/VERSION:
extras/opium_m/README:
extras/opium_m/opium-mode.el:
An emacs mode designed to write opium scenario.
extras/opium_m/INSTALL-OPIUM-M:
Opium-M installation script.
extras/opium_m/source/autoload.op:
extras/opium_m/source/interactive_queries.op:
extras/opium_m/source/browse.op:
extras/opium_m/source/interface.op:
extras/opium_m/source/control_flow.op:
extras/opium_m/source/make.op:
extras/opium_m/source/coprocess_M.op:
extras/opium_m/source/opium_kernel_M.op:
extras/opium_m/source/current_arg_M.op:
extras/opium_m/source/parameter.op:
extras/opium_m/source/current_slots_M.op:
extras/opium_m/source/scenario.op:
extras/opium_m/source/display_M.op:
extras/opium_m/source/scenario_handler.op:
extras/opium_m/source/error.op:
extras/opium_m/source/source_M.op:
extras/opium_m/source/event_attributes_M.op:
extras/opium_m/source/step_by_step_M.op:
extras/opium_m/source/exec_control_M.op:
extras/opium_m/source/translate.op:
extras/opium_m/source/forward_move_M.op:
extras/opium_m/source/types.op:
extras/opium_m/source/load_Opium-M.pl:
extras/opium_m/source/make_scenario-M.pl:
extras/opium_m/source/load_Opium-M_without_banner.pl:
extras/opium_m/source/util.pl:
extras/opium_m/source/load_scenario-M.pl:
The Opium-M source files.
extras/opium_m/non-regression-tests/*:
Non regression tests for Opium-M.
extras/opium_m/non-regression-tests/queens.m:
extras/opium_m/non-regression-tests/test_vars.m:
extras/opium_m/non-regression-tests/test_listing.m:
Mercury files that are tested.
extras/opium_m/non-regression-tests/browse.in:
extras/opium_m/non-regression-tests/queens.in:
extras/opium_m/non-regression-tests/test_vars.in:
Input of the non regression tests.
extras/opium_m/non-regression-tests/queens.exp:
extras/opium_m/non-regression-tests/test_vars.exp:
extras/opium_m/non-regression-tests/listing_output.exp:
Expected output of the non regression tests.
extras/opium_m/non-regression-tests/runtests:
extras/opium_m/non-regression-tests/Mmakefile:
To perform the non regression tests.
extras/opium_m/non-regression-tests/Mmake.common:
extras/opium_m/non-regression-tests/shutdown:
extras/opium_m/non-regression-tests/startup:
extras/opium_m/non-regression-tests/handle_options:
Those files are copied from the Mercury tests repository.
extras/opium_m/scripts/exec_mercury_program:
Script that is used to run Mercury programs under the control of
Opium-M.
extras/opium_m/scripts/fixmanual:
Script that patch the output of `manual' command (which automaticly
generates the Opium-M Reference Manual).
Index: extras/opium_m/INSTALL-OPIUM-M
===================================================================
RCS file: INSTALL-OPIUM-M
diff -N INSTALL-OPIUM-M
--- /dev/null Wed May 28 10:49:58 1997
+++ INSTALL-OPIUM-M Tue Oct 26 23:26:06 1999
@@ -0,0 +1,88 @@
+#!/bin/sh
+# Copyright (C) 1999 IRISA/INRIA.
+#
+# Author : Erwan Jahier <jahier at irisa.fr>
+#
+# This script creates the Opium-M script.
+
+
+
+MERCURY_OPIUM_DIR=`pwd`
+export MERCURY_OPIUM_DIR
+cd scripts
+rm -f Opium-M
+touch Opium-M
+
+# Get the Mercury library path (needed in source-M scenario)
+MmcDefault=/soft/mercury/library
+
+echo "What is the complete path of the Mercury library files? [default=$MmcDefault]"
+read RESPONSE
+
+case $RESPONSE in
+ '') LIB_MERCURY=$MmcDefault;;
+ *) LIB_MERCURY=$RESPONSE;;
+esac
+
+cat << EOF >> Opium-M
+#!/bin/sh
+# Copyright (C) 1999 IRISA/INRIA.
+#
+# Author : Erwan Jahier <jahier at irisa.fr>
+#
+# Script generated by INSTALL-OPIUM-M.
+
+Help="
+Name: Opium-M
+Usage: Opium-M [--no-banner]
+Description:
+ Runs Opium-M, the Mercury trace analyser.
+"
+
+#This variable should contain the path where Opium-M has been installed
+MERCURY_OPIUM_DIR=$MERCURY_OPIUM_DIR
+export MERCURY_OPIUM_DIR
+
+#This variable should contain the path of the mercury library source files
+#(which is needed in the source-M scenario)
+LIB_MERCURY=$LIB_MERCURY
+export LIB_MERCURY
+
+case \$1 in
+ --no-banner) COMMAND="eclipse -b ${MERCURY_OPIUM_DIR}/source/load_Opium-M_without_banner.pl " ;;
+
+ *) COMMAND="eclipse -b ${MERCURY_OPIUM_DIR}/source/load_Opium-M.pl " ;;
+esac
+
+exec \$COMMAND
+echo \$COMMAND
+
+EOF
+cd ..
+
+chmod a+x ${MERCURY_OPIUM_DIR}/scripts/Opium-M
+
+echo "Compiling Opium-M files..."
+eclipse -b ${MERCURY_OPIUM_DIR}/source/make_scenario-M.pl
+
+echo "Compiling the Mercury program listing.m..."
+[ -d bin ] || mkdir bin
+cd ${MERCURY_OPIUM_DIR}/source
+mmake listing.depend
+mmake listing
+mv ${MERCURY_OPIUM_DIR}/source/listing ${MERCURY_OPIUM_DIR}/bin/
+chmod a+x ${MERCURY_OPIUM_DIR}/bin/listing
+mmake listing.realclean
+
+echo ""
+echo " Don't forget to add ${MERCURY_OPIUM_DIR}/scripts and"
+echo " ${MERCURY_OPIUM_DIR}/bin to your PATH."
+echo " Make sure that the executables mmc and eclipse are accessible "
+echo " from your PATH too."
+
+
+
+
+
+
+
Index: extras/opium_m/README
===================================================================
RCS file: README
diff -N README
--- /dev/null Wed May 28 10:49:58 1997
+++ README Tue Oct 26 23:26:06 1999
@@ -0,0 +1,27 @@
+# Install Opium-M.
+------------------
+
+To install Opium-M, unzip and de-tar the file Opium-M-*.tar.gz, and run the
+script INSTALL-OPIUM-M. This will create in the scripts/ directory the
+script Opium-M that let you run Opium-M.
+
+Add directories scripts/ and bin/ in your PATH environment variable. Make sure
+that the executables mmc and eclipse are also accessible from your PATH.
+
+
+The current release of Opium-M has been tested with the following
+configurations:
+- Architecture: sparc/Solaris2.[5,6,7] and i686/Linux2.0
+- ECLiPSe: 3.4.5 (*), 3.5.2 (*), 4.0 (*), and 4.1.
+- Mercury: later than 1999-03-12 release of the day.
+
+
+(*) If you use one of those versions of ECLiPSe, you will need to add the
+following line in your .opium-m-rc file (that should be in your home
+directory):
+":- set_parameter(socket_domain, [inet])."
+
+This is to work around a bug in ECLiPSe socket interface that has been fixed in
+version 4.1.
+
+ -o-
Index: extras/opium_m/VERSION
===================================================================
RCS file: VERSION
diff -N VERSION
--- /dev/null Wed May 28 10:49:58 1997
+++ VERSION Tue Oct 26 23:26:06 1999
@@ -0,0 +1 @@
+VERSION=10-26-99
Index: extras/opium_m/opium-mode.el
===================================================================
RCS file: opium-mode.el
diff -N opium-mode.el
--- /dev/null Wed May 28 10:49:58 1997
+++ opium-mode.el Tue Oct 26 23:26:07 1999
@@ -0,0 +1,215 @@
+;/*
+; * $Header: opium-mode.el,v 1.8 90/12/20 18:43:59 anna Exp $
+; * 1990 Copyright ECRC GmbH
+; */
+
+;
+; opium mode to help to declare opium's objects
+;
+
+(defun opium-mode ()
+ (interactive)
+ (setq mode-name "opium-mode")
+)
+
+
+(defun scenario ()
+ (interactive)
+ (end-of-line)
+ (insert-string "\nopium_scenario(\n")
+ (insert-string
+ (concat "\tname\t\t: "
+ (read-string "Name ? ")
+ ",\n"))
+ (insert-string
+ (concat "\tfiles\t\t: ["
+ (read-string "Source Files, included the current file ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\tscenarios\t: ["
+ (read-string "Further scenarios needed to run the actual one ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\tmessage\t\t:\n\""
+ (read-string " Help Message ? ")
+ "\"\n"))
+ (insert-string "\t).\n")
+ (message "opium_scenario defined"))
+
+
+(defun command ()
+ (interactive)
+ (insert-string "\nopium_command(\n")
+ (insert-string
+ (concat "\tname\t\t: "
+ (read-string "Name ? ")
+ ",\n"))
+ (insert-string
+ (concat "\targ_list\t: ["
+ (read-string "Arguments ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\targ_type_list\t: ["
+ (read-string "Argument Types ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\tabbrev\t\t: "
+ (read-string "Abbrev ? (no arguments, '_' if no abbrev) ")
+ ",\n"))
+ (insert-string
+ (concat "\tinterface\t: "
+ (read-string "Interface ? (button/menu/hidden) ")
+ ",\n"))
+ (insert-string
+ (concat "\tcommand_type\t: "
+ (read-string "Command type ? (trace/opium/tool) ")
+ ",\n"))
+ (insert-string
+ (concat "\timplementation\t: "
+ (read-string "Name of the implementation ? ")
+ ",\n"))
+ (insert-string
+ (concat "\tparameters\t: ["
+ (read-string "Related Parameters ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\tmessage\t\t:\n\""
+ (read-string "Help Message ? ")
+ "\"\n"))
+ (insert-string "\t).\n")
+ (message "opium_command defined"))
+
+
+(defun primitive ()
+ (interactive)
+ (insert-string "\nopium_primitive(\n")
+ (insert-string
+ (concat "\tname\t\t: "
+ (read-string "Name ? ")
+ ",\n"))
+ (insert-string
+ (concat "\targ_list\t: ["
+ (read-string "Arguments ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\targ_type_list\t: ["
+ (read-string "Argument Types ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\tabbrev\t\t: "
+ (read-string "Abbrev ? (no arguments) ")
+ ",\n"))
+ (insert-string
+ (concat "\timplementation\t: "
+ (read-string "Name of the implementation ? ")
+ ",\n"))
+ (insert-string
+ (concat "\tmessage\t\t:\n\""
+ (read-string "Help Message ? ")
+ "\"\n"))
+ (insert-string "\t).\n")
+ (message "opium_primitive defined"))
+
+
+(defun procedure ()
+ (interactive)
+ (insert-string "\nopium_procedure(\n")
+ (insert-string
+ (concat "\tname\t\t: "
+ (read-string "Name ? ")
+ ",\n"))
+ (insert-string
+ (concat "\targ_list\t: ["
+ (read-string "Arguments ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\timplementation\t: "
+ (read-string " Name of the implementation ? ")
+ ",\n"))
+ (insert-string
+ (concat "\tparameters\t: ["
+ (read-string "Related Parameters ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\tmessage\t\t:\n\""
+ (read-string "Help Message ? ")
+ "\"\n"))
+ (insert-string "\t).\n")
+ (message "opium_procedure defined"))
+
+
+(defun parameter ()
+ (interactive)
+ (insert-string "\nopium_parameter(\n")
+ (insert-string
+ (concat "\tname\t\t: "
+ (read-string "Name ? ")
+ ",\n"))
+ (insert-string
+ (concat "\targ_list\t: ["
+ (read-string "Arguments ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\targ_type_list\t: ["
+ (read-string "Argument Types ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\tparameter_type\t: "
+ (read-string "Parameter type ? (single/multiple) ")
+ ",\n"))
+ (insert-string
+ (concat "\tdefault\t\t: ["
+ (read-string "Default Value of the Arguments ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\tcommands\t: ["
+ (read-string "Related Commands ? (separate with ',') ")
+ "],\n"))
+ (insert-string
+ (concat "\tmessage\t\t: \n\""
+ (read-string "Help Message ? ")
+ "\"\n"))
+ (insert-string "\t).\n")
+ (message "opium_parameter defined"))
+
+
+(defun type ()
+ (interactive)
+ (insert-string "\nopium_type(\n")
+ (insert-string
+ (concat "\tname\t\t: "
+ (read-string "Name ? ")
+ ",\n"))
+ (insert-string
+ (concat "\timplementation\t: "
+ (read-string " Name of the implementation ? ")
+ ",\n"))
+ (insert-string
+ (concat "\tmessage\t\t: \n\""
+ (read-string "Help Message ? ")
+ "\"\n"))
+ (insert-string "\t).\n")
+ (message "opium_type defined"))
+
+
+(defun demo ()
+ (interactive)
+ (insert-string "\nopium_demo(\n")
+ (insert-string
+ (concat "\tname\t\t: "
+ (read-string "Name ? ")
+ ",\n"))
+ (insert-string
+ (concat "\tdemo_goal\t: ("
+ (read-string " Goals to be used for the demo? (separate with ',') ")
+ "),\n"))
+ (insert-string
+ (concat "\tcondition\t: ("
+ (read-string " Conditions/initialisation for the demo goal? (separate with ',') ")
+ "),\n"))
+ (insert-string
+ (concat "\tmessage\t\t: \n\""
+ (read-string "Help Message ? ")
+ "\"\n"))
+ (insert-string "\t).\n")
+ (message "opium_demo defined"))
Index: extras/opium_m/non-regression-tests/Mmake.common
===================================================================
RCS file: Mmake.common
diff -N Mmake.common
--- /dev/null Wed May 28 10:49:58 1997
+++ Mmake.common Tue Oct 26 23:26:08 1999
@@ -0,0 +1,83 @@
+#-----------------------------------------------------------------------------#
+
+#
+# Note: Mmake lets you override MCFLAGS for a particular file by setting
+# MCFLAGS-foo. Similarly, you can override GRADEFLAGS for a particular
+# file by setting both GRADEFLAGS-foo and (for compiling the foo_init.c
+# file) GRADEFLAGS-foo_init.
+#
+
+# override this with `mmake HAVE_NUPROLOG=yes'
+# if you want to rebuild the `.exp' files.
+HAVE_NUPROLOG=no
+
+DIFF_OPTS=-c
+
+#-----------------------------------------------------------------------------#
+
+# .PRECIOUS: %.mod %.c %.o %_init.c %.no %.nu %_init.nl %_init.no
+
+%_init.c: Entry
+
+#
+# If there is a `.inp' file, then we pipe that in as the command's input.
+# Then we run the command, with stdout and stderr both redirected to the
+# `.out' file. Finally if the command fails (returns non-zero exit status),
+# we print out the contents of the `.out' file. We use `grep . $@ /dev/null'
+# to print out the contents, because that precedes each line of output with
+# the filename, which is helpful when running a parallel make.
+#
+%.out: %
+ { [ -f $*.inp ] && cat $*.inp; } | ./$< > $@ 2>&1 || \
+ { grep . $@ /dev/null; exit 1; }
+
+#
+# For some test cases, there is more than one valid output.
+# We try matching the output with the `.exp' file, and if that
+# doesn't succeed, and there is a `.exp2' file, then we try matching
+# against that too.
+#
+%.res: %.exp %.out
+ -rm -f $@
+ diff $(DIFF_OPTS) $*.exp $*.out > $@ || \
+ { [ -f $*.exp2 ] && diff $(DIFF_OPTS) $*.exp2 $*.out > $@; }
+
+#-----------------------------------------------------------------------------#
+
+clean_local: clean_out clean_res
+
+clean_mc: clean_c clean_o clean_out clean_res
+
+clean_out:
+ rm -f *.out
+
+clean_exp:
+ rm -f *.exp
+
+clean_res:
+ rm -f *.res
+
+#
+# The `foo' targets make `foo_local' in the current directory before
+# recursively making `foo' in all subdirectories. The recursive part
+# is handled in individual Mmakefiles.
+#
+
+.PHONY: check_local dep_local depend_local all_local
+
+.PHONY: check_subdirs dep_subdirs depend_subdirs realclean_subdirs \
+ clean_subdirs all_subdirs
+
+check: check_local check_subdirs
+dep: dep_local dep_subdirs
+depend: depend_local depend_subdirs
+realclean: realclean_subdirs
+clean: clean_subdirs
+all: all_local all_subdirs
+
+SUBDIR_MMAKE = mmake \
+ GRADE='$(GRADE)' \
+ EXTRA_CFLAGS='$(EXTRA_CFLAGS)' \
+ EXTRA_MCFLAGS='$(EXTRA_MCFLAGS)'
+
+#-----------------------------------------------------------------------------#
Index: extras/opium_m/non-regression-tests/Mmakefile
===================================================================
RCS file: Mmakefile
diff -N Mmakefile
--- /dev/null Wed May 28 10:49:58 1997
+++ Mmakefile Tue Oct 26 23:26:08 1999
@@ -0,0 +1,87 @@
+#-----------------------------------------------------------------------------#
+
+main_target: check
+
+# include ../../Mmake.common
+# This file is copied from the Mercury tests repository
+include ./Mmake.common
+
+RM_C=:
+#-----------------------------------------------------------------------------#
+
+OPIUM = ../scripts/Opium-M --no-banner
+
+#-----------------------------------------------------------------------------#
+
+DEBUGGER_PROGS= \
+ queens \
+ test_vars \
+
+MCFLAGS = --trace deep
+MLFLAGS = --trace
+C2INITFLAGS = --trace
+
+# We need to use shared libraries for interactive queries to work.
+# The following is necessary for shared libraries to work on Linux.
+MGNUCFLAGS-interactive = --pic-reg
+MLFLAGS-interactive = --shared
+
+# Base grades `jump' and `fast' cannot be used with
+# stack layouts (which are required for tracing).
+
+ifneq "$(findstring asm_,$(GRADE))" ""
+ PROGS=$(DEBUGGER_PROGS)
+else
+ ifneq "$(findstring jump,$(GRADE))" ""
+ PROGS=
+ else
+ ifneq "$(findstring fast,$(GRADE))" ""
+ PROGS=
+ else
+ PROGS=$(DEBUGGER_PROGS)
+ endif
+ endif
+endif
+
+#-----------------------------------------------------------------------------#
+
+queens.out.orig: queens queens.in
+ $(OPIUM) < queens.in > queens.out.orig 2>&1
+
+# Filter out things that might chande depending if we use Eclipse3.5.2
+# or Eclipse4.*, unix or inet socket, etc.
+queens.out: queens.out.orig
+ cat queens.out.orig | \
+ grep -v 'host = ' | \
+ grep -v 'compiled traceable' | \
+ grep -v 'loading' | \
+ grep -v 'is loaded' | \
+ grep -v 'making scenario' \
+ > queens.out 2>&1
+
+test_vars.out.orig: test_vars test_vars.in
+ $(OPIUM) < test_vars.in > test_vars.out.orig 2>&1
+
+test_vars.out: test_vars.out.orig
+ cat test_vars.out.orig | \
+ grep -v 'host = ' | \
+ grep -v 'compiled traceable' | \
+ grep -v 'loading' | \
+ grep -v 'is loaded' | \
+ grep -v 'making scenario' \
+ > test_vars.out 2>&1
+
+#-----------------------------------------------------------------------------#
+
+DEPS= $(PROGS:%=$(deps_subdir)%.dep)
+DEPENDS= $(PROGS:%=%.depend)
+OUTS= $(PROGS:%=%.out)
+RESS= $(PROGS:%=%.res)
+
+dep_local: $(DEPS)
+depend_local: $(DEPENDS)
+check_local: $(OUTS) $(RESS)
+all_local: $(PROGS)
+
+#-----------------------------------------------------------------------------#
+
Index: extras/opium_m/non-regression-tests/browse.in
===================================================================
RCS file: browse.in
diff -N browse.in
--- /dev/null Wed May 28 10:49:58 1997
+++ browse.in Tue Oct 26 23:26:08 1999
@@ -0,0 +1,12 @@
+ls
+cd
+help
+h
+?
+set
+set format pretty
+< 2
+set
+print
+p
+quit
Index: extras/opium_m/non-regression-tests/handle_options
===================================================================
RCS file: handle_options
diff -N handle_options
--- /dev/null Wed May 28 10:49:58 1997
+++ handle_options Tue Oct 26 23:26:08 1999
@@ -0,0 +1,84 @@
+usage="\
+Usage: $0 [options]
+Options:
+ -f <mcflags>, --flags <mcflags>
+ Pass EXTRA_MCFLAGS=<mcflags> as an option to \`mmake check'.
+ -m <mgnucflags>, --mgnucflags <mgnucflags>
+ Pass EXTRA_MGNUCFLAGS=<mgnucflags> as an option to \`mmake check'.
+ -c <cflags>, --cflags <cflags>
+ Pass EXTRA_CFLAGS=<cflags> as an option to \`mmake check'.
+ -l <mlflags>, --mlflags <mlflags>
+ Pass EXTRA_MLFLAGS=<mlflags> as an option to \`mmake check'.
+ -g <grade>, --grade <grade>
+ Pass GRADE=<grade> as an option to \`mmake check'.
+ -j <num-jobs>, --jobs <num-jobs>
+ Run using <num-jobs> different parallel processes.
+"
+
+jfactor=""
+flagsopt=""
+mgnucflagsopt=""
+cflagsopt=""
+mlflagsopt=""
+gradeopt=""
+fflag=""
+mflag=""
+cflag=""
+lflag=""
+gflag=""
+
+while [ $# -gt 0 ]; do
+ case "$1" in
+
+ -f|--flags)
+ fflag="-f '$2'"
+ flagsopt="EXTRA_MCFLAGS='$2'"
+ shift ;;
+
+ -m|--mgnucflags)
+ mflag="-m '$2'"
+ mgnucflagsopt="EXTRA_MGNUCFLAGS='$2'"
+ shift ;;
+
+ -c|--cflags)
+ cflag="-c '$2'"
+ cflagsopt="EXTRA_CFLAGS='$2'"
+ shift ;;
+
+ -l|--mlflags)
+ lflag="-l '$2'"
+ mlflagsopt="EXTRA_MLFLAGS='$2'"
+ shift ;;
+
+ -g|--grade)
+ gflag="-g $2"
+ gradeopt="GRADE=$2"
+ shift ;;
+
+ -j|--jobs)
+ jfactor="-j$2"; shift ;;
+ -j*)
+ jfactor="-j` expr $1 : '-j\(.*\)' `" ;;
+ --jobs*)
+ jfactor="--jobs` expr $1 : '--jobs\(.*\)' `" ;;
+
+ --)
+ shift; break ;;
+ -*)
+ echo "$0: unknown option \`$1'" 1>&2
+ echo "$usage" 1>&2
+ exit 1 ;;
+ *)
+ break ;;
+ esac
+ shift
+done
+
+if [ $# -ne 0 ]; then
+ echo "$0: unexpected argument(s) \`$*'" 1>&2
+ echo "$usage" 1>&2
+ exit 1
+fi
+
+mmakeopts="$jfactor $flagsopt $mgnucflagsopt $cflagsopt $mlflagsopt $gradeopt"
+runtestopts="$jfactor $mflag $cflag $lflag $fflag $gflag"
Index: extras/opium_m/non-regression-tests/listing_output.exp
===================================================================
RCS file: listing_output.exp
diff -N listing_output.exp
--- /dev/null Wed May 28 10:49:58 1997
+++ listing_output.exp Tue Oct 26 23:26:09 1999
@@ -0,0 +1,33 @@
+:- pred test(term, string). %pred
+:- mode test(in, out) is det. %pred_mode
+:- func test(string) = int. %func
+:- mode test(out) = in is det. %func_mode
+:- pred test(term::in, string::out) is det. %pred_and_mode
+:- func test(string::in) = int::out is det. %func_and_mode
+test(X, V) :-
+ p(X,V).
+test(X, V) -->
+ p(X,V).
+test(1,2,3).
+test(4) = 4.
+test = 4.
+:- pragma c_code(test(S1::in, S2::in, S3::in, Foo::in),
+ [will_not_call_mercury, thread_safe], "{
+ size_t len_1 = strlen(S1);
+ SUCCESS_INDICATOR = (
+ strncmp(S1, S3, len_1) == 0 &&
+ strcmp(S2, S3 + len_1) == 0
+ );
+}").
+:- type test
+ ---> pair_of_lines(int, int).
+:- type test(T)
+ ---> no
+ ; yes(T).
+test(Bar) = Output :-
+ test(Bar, Output).
+test(Bar, Bar1, Bar2,
+ Bar3, Bar4) = Output -->
+ test(Bar, Output).
+test(Bar, Bar2) = Output.
+
Index: extras/opium_m/non-regression-tests/queens.exp
===================================================================
RCS file: queens.exp
diff -N queens.exp
--- /dev/null Wed May 28 10:49:58 1997
+++ queens.exp Tue Oct 26 23:26:15 1999
@@ -0,0 +1,404 @@
+[Opium-M 1]:
+**************************************************
+******** Non regression test for Opium-M *********
+**************************************************
+
+**************************************************
+**** Display the first 20 events:
+Start debugging queens program.
+
+---------------------------------
+[./queens ...]
+
+ 1: 1 [1] call main(state('<<c_pointer>>'), -) []
+ 2: 2 [2] call data(-) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+ 4: 3 [2] call queen([1, 2, 3, 4, 5], -) []
+ 5: 4 [3] call qperm([1, 2, 3, 4, 5], -) []
+ 6: 4 [3] switch qperm([1, 2, 3, 4, 5], -) [s1]
+ 7: 5 [4] call qdelete(-, [1, 2, 3, 4, 5], -) []
+ 8: 5 [4] disj qdelete(-, [1, 2, 3, 4, 5], -) [c2, d1]
+ 9: 5 [4] exit qdelete(1, [1, 2, 3, 4, 5], [2, 3, 4, 5]) []
+ 10: 6 [4] call qperm([2, 3, 4, 5], -) []
+ 11: 6 [4] switch qperm([2, 3, 4, 5], -) [s1]
+ 12: 7 [5] call nondet (predicate) {queens} queens: qdelete(-, [2, 3, 4, 5] {list__list(int)}, -)/3-0 []
+ 13: 7 [5] disj nondet (predicate) {queens} queens: qdelete(-, [2, 3, 4, 5] {list__list(int)}, -)/3-0 [c2, d1]
+ 14: 7 [5] exit nondet (predicate) {queens} queens: qdelete(2 {int}, [2, 3, 4, 5] {list__list(int)}, [3, 4, 5] {list__list(int)})/3-0 []
+ 15: 8 [5] call nondet (predicate) {queens} queens: qperm([3, 4, 5] {list__list(int)}, -)/2-0 []
+ 16: 8 [5] switch nondet (predicate) {queens} queens: qperm([3, 4, 5] {list__list(int)}, -)/2-0 [s1]
+ 17: 9 [6] call nondet (predicate) {queens} queens: qdelete(-, [3, 4, 5] {list__list(int)}, -)/3-0 []
+ 18: 9 [6] disj nondet (predicate) {queens} queens: qdelete(-, [3, 4, 5] {list__list(int)}, -)/3-0 [c2, d1]
+ 19: 9 [6] exit nondet (predicate) {queens} queens: qdelete(3 {int}, [3, 4, 5] {list__list(int)}, [4, 5] {list__list(int)})/3-0 []
+ 20: 10 [6] call nondet (predicate) {queens} queens: qperm([4, 5] {list__list(int)}, -)/2-0 []
+[1, 3, 5, 2, 4]
+
+---------------------------------
+End of connection with the traced program
+ok.
+
+C = 11
+C2 = 20
+[Opium-M 2]:
+**************************************************
+**** Testing toggle/1...
+run(./, queens, )
+Start debugging queens program.
+
+---------------------------------
+[./queens ...]
+
+ 1: 1 [1] call main(state('<<c_pointer>>'), -) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle chrono attribute:
+ 2 [2] exit data([1, 2, 3, 4, 5]) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle call attribute:
+ 3: [2] exit data([1, 2, 3, 4, 5]) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle port attribute:
+ 3: 2 [2] data([1, 2, 3, 4, 5]) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle depth attribute:
+ 3: 2 exit data([1, 2, 3, 4, 5]) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle deter attribute:
+ 3: 2 [2] exit det data([1, 2, 3, 4, 5]) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle proc_type attribute:
+ 3: 2 [2] exit (predicate) data([1, 2, 3, 4, 5]) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle decl_module attribute:
+ 3: 2 [2] exit queens: data([1, 2, 3, 4, 5]) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle def_module attribute:
+ 3: 2 [2] exit {queens} data([1, 2, 3, 4, 5]) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle name attribute:
+ 3: 2 [2] exit ([1, 2, 3, 4, 5]) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle arity attribute:
+ 3: 2 [2] exit data([1, 2, 3, 4, 5])/1 []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle mode_number attribute:
+ 3: 2 [2] exit data([1, 2, 3, 4, 5])-0 []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle arg attribute:
+ 3: 2 [2] exit data() []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle local_vars attribute:
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle type attribute:
+ 3: 2 [2] exit data([1, 2, 3, 4, 5] {list__list(int)}) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+toggle goal_path attribute:
+ 3: 2 [2] exit data([1, 2, 3, 4, 5])
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+no (more) solution.
+[Opium-M 3]: [1, 3, 5, 2, 4]
+
+---------------------------------
+End of connection with the traced program
+toggle: ok.
+[Opium-M 4]:
+**************************************************
+**** Testing one by one variable retrieval...
+run(./, queens, )
+Start debugging queens program.
+
+---------------------------------
+[./queens ...]
+
+ 1: 1 [1] call main(state('<<c_pointer>>'), -) []
+673: 3 [2] exit queen([1, 2, 3, 4, 5], [1, 3, 5, 2, 4]) []
+[live_var_names_and_types(HeadVar__1, list:list(int)), live_var_names_and_types(HeadVar__2, list:list(int))]
+[1, 2, 3, 4, 5][1, 3, 5, 2, 4]
+
+---------------------------------
+End of connection with the traced program
+one by one variable retrieval: ok.
+
+List = [live_var_names_and_types("HeadVar__1", "list:list(int)"), live_var_names_and_types("HeadVar__2", "list:list(int)")]
+VarName = "HeadVar__1"
+Var = [1, 2, 3, 4, 5]
+[Opium-M 5]:
+**************************************************
+**** Testing current...
+run(./, queens, )
+Start debugging queens program.
+
+---------------------------------
+[./queens ...]
+
+ 1: 1 [1] call main(state('<<c_pointer>>'), -) []
+673: 3 [2] exit queen([1, 2, 3, 4, 5], [1, 3, 5, 2, 4]) []
+current_live_var: [(HeadVar__1, [1, 2, 3, 4, 5], list : list(int)), (HeadVar__2, [1, 3, 5, 2, 4], list : list(int))]
+chrono = 673
+call = 3
+depth = 2
+port = exit
+pred_or_func = predicate
+def_module = queens
+decl_module = queens
+name = queen
+arity = 2
+proc = predicate -> queens : queen / 2 - 0
+det = nondet
+goal_path = []
+args = [[1, 2, 3, 4, 5], [1, 3, 5, 2, 4]]
+arg_names = [HeadVar__1, HeadVar__2]
+arg_types = [list:list(int), list:list(int)]
+vars = [live_var(HeadVar__1, [1, 2, 3, 4, 5], list : list(int)), live_var(HeadVar__2, [1, 3, 5, 2, 4], list : list(int))]
+var_names_and_types = [live_var_names_and_types(HeadVar__1, list:list(int)), live_var_names_and_types(HeadVar__2, list:list(int))]
+non_arg_vars = []
+
+predicate -> queens : queen / 2 - 0
+queens : queen / 2 - 0
+predicate -> queen / 2 - 0
+predicate -> queens : queen - 0
+predicate -> queens : queen / 2
+queen / 2 - 0
+queens : queen - 0
+queens : queen / 2
+predicate -> queen - 0
+predicate -> queen / 2
+predicate -> queens : queen
+predicate -> queen
+queens : queen
+queen / 2
+queen - 0
+predicate -> queens : queen / 2 - 0[1, 3, 5, 2, 4]
+
+---------------------------------
+End of connection with the traced program
+current: ok.
+
+Name = Name
+Value = Value
+Type = Type
+List = [("HeadVar__1", [1, 2, 3, 4, 5], list : list(int)), ("HeadVar__2", [1, 3, 5, 2, 4], list : list(int))]
+Xchrono = 673
+Xcall = 3
+Xdepth = 2
+Xport = exit
+Xpred_or_func = predicate
+Xdef_module = queens
+Xdecl_module = queens
+Xname = queen
+Xarity = 2
+Xproc = predicate -> queens : queen / 2 - 0
+Xdet = nondet
+Xgoal_path = []
+Xargs = [[1, 2, 3, 4, 5], [1, 3, 5, 2, 4]]
+Xarg_names = ["HeadVar__1", "HeadVar__2"]
+Xarg_types = ["list:list(int)", "list:list(int)"]
+Xvars = [live_var("HeadVar__1", [1, 2, 3, 4, 5], list : list(int)), live_var("HeadVar__2", [1, 3, 5, 2, 4], list : list(int))]
+Xvar_names_and_types = [live_var_names_and_types("HeadVar__1", "list:list(int)"), live_var_names_and_types("HeadVar__2", "list:list(int)")]
+Xnon_arg_vars = []
+PT1 = predicate
+M1 = queens
+P1 = queen
+A1 = 2
+MN1 = 0
+M2 = queens
+P2 = queen
+A2 = 2
+MN2 = 0
+PT3 = predicate
+P3 = queen
+A3 = 2
+MN3 = 0
+PT4 = predicate
+M4 = queens
+P4 = queen
+MN4 = 0
+PT5 = predicate
+M5 = queens
+P5 = queen
+A5 = 2
+P6 = queen
+A6 = 2
+MN6 = 0
+M7 = queens
+P7 = queen
+MN7 = 0
+M8 = queens
+P8 = queen
+A8 = 2
+PT9 = predicate
+P9 = queen
+MN9 = 0
+PT10 = predicate
+P10 = queen
+A10 = 2
+PT11 = predicate
+M11 = queens
+P11 = queen
+PT12 = predicate
+P12 = queen
+M13 = queens
+P13 = queen
+P14 = queen
+A14 = 2
+P15 = queen
+MN15 = 0
+P16 = predicate -> queens : queen / 2 - 0
+[Opium-M 6]:
+**************************************************
+**** Testing retry/1...
+run(./, queens, )
+Start debugging queens program.
+
+---------------------------------
+[./queens ...]
+
+ 1: 1 [1] call main(state('<<c_pointer>>'), -) []
+673: 3 [2] exit queen([1, 2, 3, 4, 5], [1, 3, 5, 2, 4]) []
+ 4: 3 [2] call queen([1, 2, 3, 4, 5], -) []
+[1, 3, 5, 2, 4]
+
+---------------------------------
+End of connection with the traced program
+retry: ok.
+[Opium-M 7]:
+**************************************************
+**** Testing stack dumps...
+run(./, queens, )
+Start debugging queens program.
+
+---------------------------------
+[./queens ...]
+
+ 1: 1 [1] call main(state('<<c_pointer>>'), -) []
+ 3: 2 [2] exit data([1, 2, 3, 4, 5]) []
+
+Level 0: (chrono=2, call=2, depth=2) pred queens:data/1-0 (det)
+Level 1: (chrono=1, call=1, depth=1) pred queens:main/2-0 (cc_multi)
+[1, 3, 5, 2, 4]
+
+---------------------------------
+End of connection with the traced program
+stack: ok.
+
+Stack = [[level(0), detail(2, 2, 2), pred, proc("queens", "data", 1, 0), det("det")], [level(1), detail(1, 1, 1), pred, proc("queens", "main", 2, 0), det("cc_multi")]]
+[Opium-M 8]:
+**************************************************
+**** Testing the term browser...
+run(./, queens, )
+Start debugging queens program.
+
+---------------------------------
+[./queens ...]
+
+ 1: 1 [1] call main(state('<<c_pointer>>'), -) []
+397: 83 [8] exit nodiag(1, 5, []) []
+browser> 1
+
+browser> browser> Commands are:
+ ls [path] -- list subterm (expanded)
+ cd [path] -- cd current subterm (default is root)
+ help -- show this help message
+ set var value -- set a setting
+ set -- show settings
+ print -- show single line representation of current term
+ quit -- quit browser
+SICStus Prolog style commands are:
+ p -- print
+ < [n] -- set depth (default is 10)
+ ^ [path] -- cd [path]
+ ? -- help
+ h -- help
+
+-- settings:
+-- size; depth; path; format (flat pretty verbose); clipx; clipy
+-- Paths can be Unix-style or SICStus-style: /2/3/1 or ^2^3^1
+
+browser> Commands are:
+ ls [path] -- list subterm (expanded)
+ cd [path] -- cd current subterm (default is root)
+ help -- show this help message
+ set var value -- set a setting
+ set -- show settings
+ print -- show single line representation of current term
+ quit -- quit browser
+SICStus Prolog style commands are:
+ p -- print
+ < [n] -- set depth (default is 10)
+ ^ [path] -- cd [path]
+ ? -- help
+ h -- help
+
+-- settings:
+-- size; depth; path; format (flat pretty verbose); clipx; clipy
+-- Paths can be Unix-style or SICStus-style: /2/3/1 or ^2^3^1
+
+browser> Commands are:
+ ls [path] -- list subterm (expanded)
+ cd [path] -- cd current subterm (default is root)
+ help -- show this help message
+ set var value -- set a setting
+ set -- show settings
+ print -- show single line representation of current term
+ quit -- quit browser
+SICStus Prolog style commands are:
+ p -- print
+ < [n] -- set depth (default is 10)
+ ^ [path] -- cd [path]
+ ? -- help
+ h -- help
+
+-- settings:
+-- size; depth; path; format (flat pretty verbose); clipx; clipy
+-- Paths can be Unix-style or SICStus-style: /2/3/1 or ^2^3^1
+
+browser> Max depth is: 3
+Max size is: 10
+X clip is: 79
+Y clip is: 25
+Current path is: /
+Print format is verbose
+browser> browser> browser> Max depth is: 2
+Max size is: 10
+X clip is: 79
+Y clip is: 25
+Current path is: /
+Print format is pretty
+browser> 1
+browser> 1
+browser> [1, 3, 5, 2, 4]
+
+---------------------------------
+End of connection with the traced program
+browser: ok.
+[Opium-M 9]:
+**************************************************
+**** Testing other Opium commands...
+apropos(window)
+ man
+ manual
+ latex_manual
+ window_command
+ opium_command_in_module
+ print_man
+
+man(apropos)
+
+apropos(Name) {a}
+Command which displays all the commands, primitives, procedures, parameters, or types for which Name is a substring of.
+Example:
+[Opium-M]: apropos man.
+ man
+ manual
+ latex_manual
+ window_command
+ opium_command_in_module
+ print_man
+
+Name : atom
+type of command : opium
+scenario : help (GloLoc in Opium-M)
+
+ok.
+**************************************************
+[Opium-M 10]:
+bye
Index: extras/opium_m/non-regression-tests/queens.in
===================================================================
RCS file: queens.in
diff -N queens.in
--- /dev/null Wed May 28 10:49:58 1997
+++ queens.in Tue Oct 26 23:26:23 1999
@@ -0,0 +1,186 @@
+write("\n**************************************************\n"),
+write("******** Non regression test for Opium-M *********\n"),
+write("**************************************************\n\n"),
+
+
+write("**************************************************\n"),
+ write("**** Display the first 20 events:\n"),
+ run(queens),
+ next,
+ current(chrono=C),
+ C > 10,
+ next_np,
+ print_full_event,
+ current(chrono=C2),
+ C2 >= 20, !,
+ no_trace,
+ write("ok.\n").
+
+write("\n**************************************************"),
+ write("\n**** Testing toggle/1...\n"),
+ rerun,
+ fget(name = data and port = exit), !,
+ member(X, [chrono, call, port, depth, deter, proc_type, decl_module,
+ def_module, name, arity, mode_number, arg, local_vars, type,
+ goal_path]),
+ write("toggle "),
+ write(X),
+ write(" attribute:\n"),
+ toggle(X),
+ print_event,
+ toggle(X),
+ print_event,
+ fail.
+ no_trace,
+ write("toggle: ok.\n").
+
+write("\n**************************************************"),
+ write("\n**** Testing one by one variable retrieval...\n"),
+ rerun,
+ fget(name = queen and port = exit),
+ current(var_names_and_types = List),
+ List = [live_var_names_and_types(VarName, _)| _],
+ write(List), nl,
+ current_live_var(VarName, Var, _),
+ write_trace(Var), !,
+ no_trace,
+ write("one by one variable retrieval: ok.\n").
+
+write("\n**************************************************"),
+ write("\n**** Testing current...\n"),
+ rerun,
+ fget(name = queen and port = exit),
+
+ % testing current_live_var
+ setof((Name, Value, Type), current_live_var(Name, Value, Type), List),
+ write("current_live_var: "),
+ write(List), nl,
+
+ % testing attributes retrieval
+ write("chrono = "),
+ current(chrono = Xchrono),
+ write(Xchrono),
+ write("\ncall = "),
+ current(call = Xcall),
+ write(Xcall),
+ write("\ndepth = "),
+ current(depth = Xdepth),
+ write(Xdepth),
+ write("\nport = "),
+ current(port = Xport),
+ write(Xport),
+ write("\npred_or_func = "),
+ current(pred_or_func = Xpred_or_func),
+ write(Xpred_or_func),
+ write("\ndef_module = "),
+ current(def_module = Xdef_module),
+ write(Xdef_module),
+ write("\ndecl_module = "),
+ current(decl_module = Xdecl_module),
+ write(Xdecl_module),
+ write("\nname = "),
+ current(name = Xname),
+ write(Xname),
+ write("\narity = "),
+ current(arity = Xarity),
+ write(Xarity),
+ write("\nproc = "),
+ current(proc = Xproc),
+ write(Xproc),
+ write("\ndet = "),
+ current(det = Xdet),
+ write(Xdet),
+ write("\ngoal_path = "),
+ current(goal_path = Xgoal_path),
+ write(Xgoal_path),
+ write("\nargs = "),
+ current(args = Xargs),
+ write(Xargs),
+ write("\narg_names = "),
+ current(arg_names = Xarg_names),
+ write(Xarg_names),
+ write("\narg_types = "),
+ current(arg_types = Xarg_types),
+ write(Xarg_types),
+ write("\nvars = "),
+ current(vars = Xvars),
+ write(Xvars),
+ write("\nvar_names_and_types = "),
+ current(var_names_and_types = Xvar_names_and_types),
+ write(Xvar_names_and_types),
+ write("\nnon_arg_vars = "),
+ current(non_arg_vars = Xnon_arg_vars),
+ write(Xnon_arg_vars), nl,
+
+ % test current(proc = ...)
+ current(proc = (PT1->M1:(P1/A1-MN1))), nl,
+ write(PT1->M1:(P1/A1-MN1)),
+ current(proc = M2:(P2/A2-MN2) ), nl,
+ write(M2:(P2/A2-MN2)),
+ current(proc = (PT3->(P3/A3-MN3)) ), nl,
+ write( PT3->(P3/A3-MN3)),
+ current(proc = (PT4->(M4:(P4-MN4))) ), nl,
+ write(PT4->M4:(P4-MN4)),
+ current(proc = (PT5->(M5:(P5/A5))) ), nl,
+ write(PT5->(M5:(P5/A5))),
+ current(proc = (P6/A6-MN6) ), nl,
+ write((P6/A6-MN6)),
+ current(proc = M7:(P7-MN7) ), nl,
+ write(M7:(P7-MN7)),
+ current(proc = M8:(P8/A8) ), nl,
+ write(M8:(P8/A8)),
+ current(proc = (PT9->(P9-MN9)) ), nl,
+ write(PT9->(P9-MN9)),
+ current(proc = ( PT10->(P10/A10)) ), nl,
+ write(PT10->(P10/A10)),
+ current(proc = (PT11->(M11:(P11)) )), nl,
+ write(PT11->M11:(P11) ),
+ current(proc = (PT12->P12) ), nl,
+ write(PT12->P12),
+ current(proc = M13:P13 ), nl,
+ write(M13:P13),
+ current(proc = P14/A14 ), nl,
+ write(P14/A14),
+ current(proc = P15-MN15 ), nl,
+ write( P15-MN15),
+ current(proc = P16), nl,
+ write(P16), !,
+ no_trace,
+ write("current: ok.\n").
+
+write("\n**************************************************"),
+ write("\n**** Testing retry/1...\n"),
+ rerun,
+ fget(name = queen and port = exit),
+ retry, !,
+ no_trace,
+ write("retry: ok.\n").
+
+write("\n**************************************************"),
+ write("\n**** Testing stack dumps...\n"),
+ rerun,
+ fget(name = data and port = exit), !,
+ current(stack = Stack),
+ stack, !,
+ no_trace,
+ write("stack: ok.\n").
+
+write("\n**************************************************"),
+ write("\n**** Testing the term browser...\n"),
+ rerun,
+ fget(name = nodiag and port = exit),
+ open("browse.in", read, browse_stream),
+ set_stream(input, browse_stream),
+ browse("HeadVar__1"),
+ no_trace,
+ write("browser: ok.\n").
+
+write("\n**************************************************"),
+ write("\n**** Testing other Opium commands...\n"),
+ write("apropos(window)"), nl,
+ apropos(man),
+ write("man(apropos)"), nl,
+ man(apropos),
+ write("ok.\n"),
+
+write("**************************************************\n").
Index: extras/opium_m/non-regression-tests/queens.m
===================================================================
RCS file: queens.m
diff -N queens.m
--- /dev/null Wed May 28 10:49:58 1997
+++ queens.m Tue Oct 26 23:26:24 1999
@@ -0,0 +1,101 @@
+:- module queens.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is cc_multi.
+
+:- implementation.
+
+:- import_module list, int.
+
+main -->
+ ( { data(Data), queen(Data, Out) } ->
+ print_list(Out)
+ ;
+ io__write_string("No solution\n")
+ ).
+
+:- pred data(list(int)).
+:- mode data(out) is det.
+
+:- pred queen(list(int), list(int)).
+:- mode queen(in, out) is nondet.
+
+:- pred qperm(list(T), list(T)).
+:- mode qperm(in, out) is nondet.
+
+:- pred qdelete(T, list(T), list(T)).
+:- mode qdelete(out, in, out) is nondet.
+
+:- pred safe(list(int)).
+:- mode safe(in) is semidet.
+
+:- pred nodiag(int, int, list(int)).
+:- mode nodiag(in, in, in) is semidet.
+
+data([1,2,3,4,5]).
+
+queen(Data, Out) :-
+ qperm(Data, Out),
+ safe(Out).
+
+qperm([], []).
+qperm([X|Y], K) :-
+ qdelete(U, [X|Y], Z),
+ K = [U|V],
+ qperm(Z, V).
+
+qdelete(A, [A|L], L).
+qdelete(X, [A|Z], [A|R]) :-
+ qdelete(X, Z, R).
+
+safe([]).
+safe([N|L]) :-
+ nodiag(N, 1, L),
+ safe(L).
+
+nodiag(_, _, []).
+nodiag(B, D, [N|L]) :-
+ NmB is N - B,
+ BmN is B - N,
+ ( D = NmB ->
+ fail
+ ; D = BmN ->
+ fail
+ ;
+ true
+ ),
+ D1 is D + 1,
+ nodiag(B, D1, L).
+
+:- pred print_list(list(int), io__state, io__state).
+:- mode print_list(in, di, uo) is det.
+
+print_list(Xs) -->
+ (
+ { Xs = [] }
+ ->
+ io__write_string("[]\n")
+ ;
+ io__write_string("["),
+ print_list_2(Xs),
+ io__write_string("]\n")
+ ).
+
+:- pred print_list_2(list(int), io__state, io__state).
+:- mode print_list_2(in, di, uo) is det.
+
+print_list_2([]) --> [].
+print_list_2([X|Xs]) -->
+ io__write_int(X),
+ (
+ { Xs = [] }
+ ->
+ []
+ ;
+ io__write_string(", "),
+ print_list_2(Xs)
+ ).
Index: extras/opium_m/non-regression-tests/runtests
===================================================================
RCS file: runtests
diff -N runtests
--- /dev/null Wed May 28 10:49:58 1997
+++ runtests Tue Oct 26 23:26:24 1999
@@ -0,0 +1,31 @@
+#!/bin/sh
+# Test whether the code generated by the Mercury compiler
+# is producing the expected output.
+# Return a status of 0 (true) if everything is all right, and 1 otherwise.
+
+# . ../../handle_options
+# . ../../startup
+# Those two files are copied from the Mercury tests repository
+. ./handle_options
+. ./startup
+
+eval mmake $mmakeopts depend || exit 1
+eval mmake -k $mmakeopts check
+checkstatus=$?
+
+cat *.res > .allres
+if test ! -s .allres -a "$checkstatus" = 0
+then
+ echo "the tests in the debugger/external directory succeeded"
+ echo "mmakeopts=$mmakeopts"
+ rm -f .allres
+ . ./shutdown
+# . ../../shutdown
+ exit 0
+else
+ echo "the tests in the debugger/external directory failed"
+ echo "mmakeopts=$mmakeopts"
+ echo "the differences are:"
+ cat .allres
+ exit 1
+fi
Index: extras/opium_m/non-regression-tests/shutdown
===================================================================
RCS file: shutdown
diff -N shutdown
--- /dev/null Wed May 28 10:49:58 1997
+++ shutdown Tue Oct 26 23:26:24 1999
@@ -0,0 +1,4 @@
+echo cleaning up the directory after the tests
+mmake $gradeopt $jfactor realclean_local > /dev/null 2>&1
+rm core > /dev/null 2>&1
+touch CLEAN
Index: extras/opium_m/non-regression-tests/startup
===================================================================
RCS file: startup
diff -N startup
--- /dev/null Wed May 28 10:49:58 1997
+++ startup Tue Oct 26 23:26:24 1999
@@ -0,0 +1,8 @@
+echo cleaning up the directory before the tests
+if ls -lt | head -2 | egrep CLEAN > /dev/null 2>&1
+then
+ rm -f CLEAN > /dev/null 2>&1
+else
+ rm -f CLEAN > /dev/null 2>&1
+ mmake $gradeopt $jfactor realclean_local > /dev/null 2>&1
+fi
Index: extras/opium_m/non-regression-tests/test_listing.m
===================================================================
RCS file: test_listing.m
diff -N test_listing.m
--- /dev/null Wed May 28 10:49:58 1997
+++ test_listing.m Tue Oct 26 23:26:24 1999
@@ -0,0 +1,41 @@
+%------------------------------------------------------------------------------%
+% Copyright (C) 1999 IRISA/INRIA.
+%
+% Auteur : Erwan Jahier <jahier at irisa.fr>
+%
+% This file is just intended to test the listing Mercury program.
+% (listing test_listing test)
+
+:- pred test(term, string). %pred
+:- mode test(in, out) is det. %pred_mode
+:- func test(string) = int. %func
+:- mode test(out) = in is det. %func_mode
+:- pred test(term::in, string::out) is det. %pred_and_mode
+:- func test(string::in) = int::out is det. %func_and_mode
+test(X, V) :-
+ p(X,V).
+test(X, V) -->
+ p(X,V).
+test(1,2,3).
+test(4) = 4.
+test = 4.
+:- pragma c_code(test(S1::in, S2::in, S3::in, Foo::in),
+ [will_not_call_mercury, thread_safe], "{
+ size_t len_1 = strlen(S1);
+ SUCCESS_INDICATOR = (
+ strncmp(S1, S3, len_1) == 0 &&
+ strcmp(S2, S3 + len_1) == 0
+ );
+}").
+:- type test
+ ---> pair_of_lines(int, int).
+:- type test(T)
+ ---> no
+ ; yes(T).
+test(Bar) = Output :-
+ test(Bar, Output).
+test(Bar, Bar1, Bar2,
+ Bar3, Bar4) = Output -->
+ test(Bar, Output).
+test(Bar, Bar2) = Output.
+
Index: extras/opium_m/non-regression-tests/test_vars.exp
===================================================================
RCS file: test_vars.exp
diff -N test_vars.exp
--- /dev/null Wed May 28 10:49:58 1997
+++ test_vars.exp Tue Oct 26 23:26:25 1999
@@ -0,0 +1,18 @@
+[Opium-M 1]:
+**************************************************
+**** Testing test_vars.m...
+Start debugging test_vars program.
+
+---------------------------------
+[./test_vars ...]
+
+ 1: 1 [1] call main(state('<<c_pointer>>'), -) []
+ 3: 2 [2] exit p(3 - 8) []
+[3 - 8]
+---------------------------------
+End of connection with the traced program
+test_vars: ok.
+
+Arg = [3 - 8]
+[Opium-M 2]:
+bye
Index: extras/opium_m/non-regression-tests/test_vars.in
===================================================================
RCS file: test_vars.in
diff -N test_vars.in
--- /dev/null Wed May 28 10:49:58 1997
+++ test_vars.in Tue Oct 26 23:26:25 1999
@@ -0,0 +1,8 @@
+write("\n**************************************************"),
+ write("\n**** Testing test_vars.m...\n"),
+ run(test_vars),
+ goto(3),
+ current(arg = Arg),
+ write(Arg), !,
+ no_trace,
+ write("test_vars: ok.\n").
Index: extras/opium_m/non-regression-tests/test_vars.m
===================================================================
RCS file: test_vars.m
diff -N test_vars.m
--- /dev/null Wed May 28 10:49:58 1997
+++ test_vars.m Tue Oct 26 23:26:25 1999
@@ -0,0 +1,15 @@
+:- module test_vars.
+
+:- interface.
+:- import_module io.
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+:- import_module int, std_util.
+
+:- pred p(pair(int)::out) is det.
+
+main(IO, IO) :-
+ p(_).
+
+p(3-8).
Index: extras/opium_m/scripts/exec_mercury_program
===================================================================
RCS file: exec_mercury_program
diff -N exec_mercury_program
--- /dev/null Wed May 28 10:49:58 1997
+++ exec_mercury_program Tue Oct 26 23:26:25 1999
@@ -0,0 +1,60 @@
+#!/bin/sh
+# Copyright (C) 1999 IRISA/INRIA.
+#
+# Author : Erwan Jahier <jahier at irisa.fr>
+#
+# 1st argument is the socket address (unix) or the port name (inet),
+# 2nd argument is the socket domain (unix or inet),
+# 3rd argument is name of the machine to run the mercury program on,
+# 4th argument is the name of the program being called,
+# the following arguments are the arguments of the program being called.
+
+
+echo " "
+echo "---------------------------------"
+echo "[$4 ...] "
+echo " "
+
+SOCKETDOMAIN=$2
+REMOTEMACHINE=$3
+LOCALMACHINE=`uname -n`
+
+case $SOCKETDOMAIN in
+unix) MERCURY_DEBUGGER_UNIX_SOCKET=$1
+ MERCURY_OPTIONS="$MERCURY_OPTIONS -De"
+ export MERCURY_DEBUGGER_UNIX_SOCKET
+ export MERCURY_OPTIONS
+ shift 3
+ $@
+ ;;
+
+inet) HOSTADDR=`ypcat hosts|grep $LOCALMACHINE|awk '{printf "%s\n", $1}'|sort -u`
+ # XXX How can I retrieve the host address without this horrible
+ # hack?
+ # That don't even work on machines that have not got ypcat...
+ # Note it is not a big deal since it is only needed if people
+ # want to use internet sockets and there is no reason why people
+ # would want those. (except if they don't have eclipse 4.1).
+ MERCURY_DEBUGGER_INET_SOCKET="$HOSTADDR $1"
+ MERCURY_OPTIONS="$MERCURY_OPTIONS -De"
+ export MERCURY_DEBUGGER_INET_SOCKET
+ export MERCURY_OPTIONS
+ shift 3
+ case $REMOTEMACHINE in
+ local) $@ ;;
+ # XXX Remote debugging does not work yet.
+ *) rsh $REMOTEMACHINE $@;;
+ esac
+ ;;
+
+*) echo "error in exec_mercury_program"
+ echo "SOCKETDOMAIN should be set to unix or inet"
+ ;;
+esac
+
+echo ""
+echo "---------------------------------"
+
+
+
+
Index: extras/opium_m/scripts/fixmanual
===================================================================
RCS file: fixmanual
diff -N fixmanual
--- /dev/null Wed May 28 10:49:58 1997
+++ fixmanual Tue Oct 26 23:26:25 1999
@@ -0,0 +1,48 @@
+#!/bin/sh -
+
+# /*
+# * $Header: fixmanual,v 1.5 90/12/20 18:43:41 anna Exp $
+# * 1990 Copyright ECRC GmbH
+# */
+
+# Fix the manual file
+
+ex $1 <<\EOF
+%s/_/\\_/g
+w
+q
+EOF
+ex $1 <<\EOF
+%s/</$<$/g
+w
+q
+EOF
+ex $1 <<\EOF
+%s/>/$>$/g
+w
+q
+EOF
+ex $1 <<\EOF
+%s/\\==/$\\backslash$==/g
+w
+q
+EOF
+ex $1 <<\EOF
+%s/\\=/$\\backslash$=/g
+w
+q
+EOF
+ex $1 <<\EOF
+%s/=/$=$/g
+w
+q
+EOF
+ex $1 <<\EOF
+%s/\~/\\verb+\~+/g
+w
+q
+EOF
+
+
+
+
Index: extras/opium_m/source/autoload.op
===================================================================
RCS file: autoload.op
diff -N autoload.op
--- /dev/null Wed May 28 10:49:58 1997
+++ autoload.op Tue Oct 26 23:26:26 1999
@@ -0,0 +1,74 @@
+/*
+ * $Header: autoload.op,v 1.13 90/12/20 18:43:10 anna Exp $
+ * 1990 Copyright ECRC GmbH
+ */
+
+/*
+ * to_be_autoloaded(+Cmd, +Module)
+ * checks whether a call of Cmd in Module requires to load a scenario.
+ *
+ * It is assumed that the translation of *.op files will generate
+ * *.autoload files which for each command contain
+ * autoload_command(Command(Args), Scenario)
+ * autoload_command(Command, Scenario)
+ * For each scenario which is loaded inactive, a clause of procedure
+ * autoload_scenario/4 is added, which gives information how this
+ * scenario has to be loaded in order to be active. If a command of an
+ * inactive scenario is used, the scenario is activated automatically.
+ *
+ * Commands which are supposed to have arguments and are used without,
+ * are trapped here as well, procedure check_arg_type is used to prompt
+ * the user for proper values.
+ */
+
+to_be_autoloaded(Cmd, sepia_kernel, NewCmd) :-
+ /* sepia_kernel cannot be an opium module */
+ !,
+ fail.
+to_be_autoloaded(Cmd, Module, NewCmd) :-
+ /* there exists a command with same name but with arguments,
+ * possibly in another module but visible in the calling module */
+ opium_command_in_module((
+ name : Cmd,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ abbrev : Abbrev,
+ interface : Interface,
+ command_type : CommandType,
+ scenario : Scenario,
+ implementation : P,
+ parameters : ParList,
+ message : Message ), M),
+ length(ArgList, Arity),
+ call(is_predicate(Cmd/Arity), Module),
+ !,
+ check_arg_type([], ArgList, ArgType, NewArg),
+ Cmd =.. [CmdName | _],
+ NewCmd =.. [CmdName | NewArg].
+to_be_autoloaded(Cmd, Module, Cmd) :-
+ /* the calling module contains autoload information for Cmd,
+ * so it is time to activate the respective inactive scenario */
+ (is_opium_module(Module) ->
+ true
+ ;
+ provide_opium_module(Module)
+ /* otherwise loop as autoload_command/2 is undefined */
+ ),
+ call(autoload_command(Cmd, Scenario), Module),
+ !,
+ call(autoload_scenario(Scenario, [_, Traceable, GloLoc], SrcDir, ObjDir), Module),
+ make(Scenario, Module, [active, Traceable, GloLoc], SrcDir, ObjDir).
+to_be_autoloaded(Cmd, Module, Cmd) :-
+ /* there is autoload information for Cmd in another module,
+ * and the command is intended to be visible in the calling module,
+ * so it is time to activate this scenario */
+ opium_module(M),
+ call(autoload_command(Cmd, Scenario), M),
+ call(autoload_scenario(Scenario, [_, Traceable, global], SrcDir, ObjDir), M),
+ !,
+ make(Scenario, M, [active, Traceable, global], SrcDir, ObjDir).
+
+
+
+
+
Index: extras/opium_m/source/browse.op
===================================================================
RCS file: browse.op
diff -N browse.op
--- /dev/null Wed May 28 10:49:58 1997
+++ browse.op Tue Oct 26 23:26:27 1999
@@ -0,0 +1,82 @@
+%------------------------------------------------------------------------------%
+% Copyright (C) 1999 IRISA/INRIA.
+%
+% Author : Erwan Jahier
+% File : browse.op
+%
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : browse,
+ arg_list : [VarName],
+ arg_type_list : [string],
+ abbrev : _,
+ interface : button,
+ command_type : opium,
+ implementation : browse_Op,
+ parameters : [],
+ message :
+"Call the Mercury term browser. Type `help' at the browser prompt to get \
+on-line help"
+).
+
+browse_Op(VarName) :-
+ quote_string(VarName, VarNameQuoted),
+ send_message_to_socket(browse(VarNameQuoted)),
+ browser_loop.
+
+browser_loop :-
+ print("browser> "), flush(user),
+ ( read_and_check(Command) ->
+ atom_string(Command, CommandStr),
+ quote_string(CommandStr, CommandStrQuoted),
+ send_message_to_socket(external_request(CommandStrQuoted)),
+ read_loop(Msg)
+ ;
+ send_message_to_socket(external_request('"help"')),
+ read_loop(Msg)
+ ),
+ (
+ Msg = browser_quit,
+ read_message_from_socket(browser_end),
+ !
+ ;
+ Msg = browser_end_command,
+ !,
+ browser_loop
+ ;
+ Msg = error(ErrorMsg),
+ print(ErrorMsg), nl,
+ !,
+ browser_loop
+ ;
+ print("Msg = "), print(Msg),
+ print("\n************** Error in browse.op\n")
+ ).
+
+read_loop(MsgOut) :-
+ read_message_from_socket(Msg),
+ (
+ Msg = browser_str(Str),
+ print(Str),
+ !,
+ read_loop(MsgOut)
+ ;
+ Msg = browser_int(N),
+ print(N),
+ !,
+ read_loop(MsgOut)
+ ;
+ Msg = browser_nl,
+ nl,
+ !,
+ read_loop(MsgOut)
+ ;
+ % Msg = browser_quit, browser_end_command, error().
+ MsgOut = Msg
+ ).
+
+read_and_check(Command) :-
+ read_string("\n", _, String),
+ atom_string(Command, String).
Index: extras/opium_m/source/control_flow.op
===================================================================
RCS file: control_flow.op
diff -N control_flow.op
--- /dev/null Wed May 28 10:49:58 1997
+++ control_flow.op Tue Oct 26 23:26:27 1999
@@ -0,0 +1,228 @@
+%------------------------------------------------------------------------------%
+% Copyright (C) 1999 IRISA/INRIA.
+%
+% Author : Erwan Jahier
+% File : control_flow.op
+%
+
+%------------------------------------------------------------------------------%
+opium_scenario(
+ name : control_flow,
+ files : [control_flow],
+ scenarios : [],
+ message :
+"Scenario that provides commands which generates various control flow graphs. \
+This scenario make use of the graph generator `dot' program (so you will need to \
+have dot available from your PATH environment variable to be able to use this \
+scenario."
+ ).
+
+%------------------------------------------------------------------------------%
+opium_parameter(
+ name : ps_viewer,
+ arg_list : [String],
+ arg_type_list : [string],
+ parameter_type : single,
+ default : ["gv "],
+ commands : [control_flow_graph, dynamic_call_graph],
+ message :
+"Parameter which sets the name of the command used to visualize the generated \
+post-script file."
+ ).
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : control_flow_graph,
+ arg_list : [ProgramCall],
+ arg_type_list : [is_mercury_program_call],
+ abbrev : cfg,
+ interface : button,
+ command_type : opium,
+ implementation : control_flow_graph_Op,
+ parameters : [ps_viewer],
+ message :
+"This command generates a control flow graph of the Mercury program \
+execution."
+ ).
+
+control_flow_graph_Op(Program) :-
+ run(Program),
+ generate_filename(Program, ".cfg.dot", ".cfg.ps", DotFile, PsFile),
+ generate_control_flow_graph([], main/2, Graph),
+ display_graph(Graph, DotFile, PsFile).
+
+
+% :- type graph ---> list(call(procedure, procedure)).
+%
+%:- pred generate_control_flow_graph(graph, procedure, graph).
+%:- mode generate_control_flow_graph(in, in, out) is det.
+%
+generate_control_flow_graph(G0, Proc, G) :-
+ % XXX I should do that with collect when it is available!!
+ ( fget_np(port = [call, exit,redo,fail]) ->
+ current(proc_name = Name and arity = N),
+ CurrentProc = Name/N,
+ G1 = [call(Proc, CurrentProc)|G0],
+ generate_control_flow_graph(G1, CurrentProc, G),
+ !
+ ;
+ % end of the execution
+ remove_dupl(G0, G)
+ ).
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : dynamic_call_graph,
+ arg_list : [ProgramCall],
+ arg_type_list : [is_mercury_program_call],
+ abbrev : dcg,
+ interface : button,
+ command_type : opium,
+ implementation : dynamic_call_graph_Op,
+ parameters : [ps_viewer],
+ message :
+"This command generates a dynamic call graph of the Mercury program \
+execution. We call a dynamic call graph the dynamic slice of the (static) \
+call graph, i.e. the calls that have effectively been done during the execution."
+ ).
+
+dynamic_call_graph_Op(Program) :-
+ run(Program),
+ generate_filename(Program, ".dcg.dot", ".dcg.ps", DotFile, PsFile),
+ generate_dynamic_call_graph([], Graph),
+ display_graph(Graph, DotFile, PsFile).
+
+%
+%:- pred generate_dynamic_call_graph(graph, graph).
+%:- mode generate_dynamic_call_graph(in, out) is det.
+%
+generate_dynamic_call_graph(G0, G) :-
+ % XXX I should do that with collect when it is available!!
+ ( fget_np(port = call) ->
+ current(proc_name = Name and arity = N),
+ ancestor(Anc),
+ CurrentProc = Name/N,
+ G1 = [call(Anc, CurrentProc)|G0],
+ generate_dynamic_call_graph(G1, G),
+ !
+ ;
+ % end of the execution
+ remove_dupl(G0, G)
+ ).
+
+ancestor(Anc) :-
+ current(stack = [_, List|_]),
+ member(proc(_,Name,Arity,_), List),
+ Anc = Name/Arity,
+ !.
+ancestor(none).
+
+%------------------------------------------------------------------------------%
+%
+%:- pred generate_filename(string, string, string, string, string).
+%:- mode generate_filename(in ,in, in, out, out) is det.
+%
+generate_filename(Program, DotExt, PsExt, DotFile, PsFile) :-
+ ( string(Program) ->
+ ProgramStr = Program,
+ !
+ ;
+ term_string(Program, ProgramStr)
+ ),
+ decompose_path_call_and_args1(ProgramStr, _, ProgramCallStr, _),
+ append_strings(ProgramCallStr, DotExt, DotFile),
+ append_strings(ProgramCallStr, PsExt, PsFile).
+
+%:- pred display_graph(graph, string, string).
+%:- mode display_graph(in, in, in) is det.
+%
+display_graph(Graph, DotFile, PsFile) :-
+ extract_proc_list_from_graph(Graph, ProcList),
+ open(DotFile, write, dotfile),
+ print(dotfile, "digraph G {\n\n"),
+ dump_proc(ProcList),
+ dump_graph(Graph),
+ print(dotfile, "}\n"),
+ close(dotfile),
+ compile_dot(DotFile, PsFile),
+ display_ps(PsFile).
+dump_proc([]).
+dump_proc([X|Xs]) :-
+ printf(dotfile, "\t \t \"%w\"\n", [X]),
+ dump_proc2(Xs).
+
+
+dump_proc2([]) :- nl(dotfile).
+dump_proc2([X|Xs]) :-
+ printf(dotfile, "\t ; \t \"%w\"\n", [X]),
+ dump_proc2(Xs).
+
+dump_graph([]) :- nl(dotfile).
+dump_graph([call(X,Y)|CG]) :-
+ printf(dotfile, "\t\"%w\" -> \"%w\";\n", [X,Y]),
+ dump_graph(CG).
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : compile_dot,
+ arg_list : [DotFile, PsFile],
+ arg_type_list : [string, string],
+ abbrev : _,
+ implementation : compile_dot_Op,
+ message :
+"Primitive which applies `dot' to DotFile and outputs the resulting \
+post-script in PsFile."
+ ).
+
+compile_dot_Op(DotFile, PsFile) :-
+ concat_string(["dot -Tps ", DotFile, " -o ", PsFile], Cmd),
+ print(Cmd), nl,
+ sh(Cmd).
+
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : display_ps,
+ arg_list : [PsFile],
+ arg_type_list : [string],
+ abbrev : _,
+ implementation : display_ps_Op,
+ message :
+"primitive which displays post-script files."
+ ).
+
+display_ps_Op(PsFile) :-
+ ps_viewer(PsViewer),
+ concat_string([PsViewer, " ", PsFile, " &"], Cmd),
+ print(Cmd), nl,
+ sh(Cmd).
+
+
+%------------------------------------------------------------------------------%
+%
+% :- pred extract_proc_list_from_graph(graph, list(procedure)).
+% :- mode extract_proc_list_from_graph(in, out) is det.
+%
+extract_proc_list_from_graph(Graph, ProcList) :-
+ extract_proc_list_from_graph2(Graph, ProcList0),
+ remove_dupl(ProcList0, ProcList1),
+ reverse(ProcList1, ProcList).
+
+extract_proc_list_from_graph2([], []).
+extract_proc_list_from_graph2([call(Proc,_)|Graph], [Proc|ProcList]) :-
+ extract_proc_list_from_graph2(Graph, ProcList).
+
+
+%------------------------------------------------------------------------------%
+% XXX I should write a tail recursive version of this predicate
+remove_dupl([], []).
+remove_dupl(L0, L) :-
+ L0 = [X|L1],
+ remove_dupl(L1, L2),
+ ( member(X, L2) ->
+ L = L2
+ ;
+ L = [X|L2]
+ ).
Index: extras/opium_m/source/coprocess_M.op
===================================================================
RCS file: coprocess_M.op
diff -N coprocess_M.op
--- /dev/null Wed May 28 10:49:58 1997
+++ coprocess_M.op Tue Oct 26 23:26:28 1999
@@ -0,0 +1,218 @@
+%------------------------------------------------------------------------------%
+% Copyright (C) 1999 IRISA/INRIA.
+%
+% Author : Erwan Jahier <jahier at irisa.fr>
+%
+% Opium-M built-ins, primitives and commands related to coprocessing
+% in the Opium-M process (part of scenario opium_kernel-M.op).
+
+
+
+%------------------------------------------------------------------------------%
+%:- pred start_connection(atom, atom, atom).
+%:- mode start_connection(in, out) is det.
+% To start the connection with the Mercury process
+start_connection(ProgramName, SockId2) :-
+ write("Start debugging "),
+ write(ProgramName),
+ write(" program.\n"),
+ get_parameter(socket_domain, [SocketDomain]),
+ ( (SocketDomain = unix) ->
+ % construct the socket address (ex: /tmp/soc1233)
+ construct_socket_address(SockAddPidStr),
+ atom_string(SockId, SockAddPidStr),
+ socket(unix, stream, sock)
+ ;
+ % socket_type = inet
+ socket(internet, stream, sock)
+ ),
+
+ % clean up unused socket addresses
+ kill_all_socket_address,
+
+ % Bind the socket name to the socket
+ bind(sock, SockId),
+ ( (SocketDomain = unix) ->
+ SockId2 = SockId
+ ;
+ SockId = _ / SockId2
+ ),
+ listen(sock, 1).
+
+construct_socket_address(Addr) :-
+ mercury_opium_socket_address(Addr0),
+ append_strings(Addr0, "soc", Addr1),
+
+ % We add the pid to the socket path name to make sure that 2 users on
+ % the same machine can use Opium-M simultaneously.
+ get_flag(pid, Pid),
+ number_string(Pid, PidStr),
+ append_strings(Addr1, PidStr, Addr),
+
+ % Record the socket address to be able to delete it later
+ setval(socket_address_str, SockAddPidStr).
+
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : end_connection,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : ec,
+ implementation : end_connection_Op,
+ message :
+'Ends the connection with the traced program.'
+ ).
+
+% :- pred end_connection is det.
+end_connection_Op :-
+ kill_all_socket_address,
+ setval(state_of_opium, not_running),
+ close(sock),
+ close(newsock),
+ write("End of connection with the traced program\n").
+
+kill_all_socket_address :-
+ get_flag(pid, Pid),
+ number_string(Pid, PidStr),
+ append_strings("*", PidStr, StarPidStr),
+ mercury_opium_socket_address(AddressStr),
+ append_strings("rm -f ", AddressStr, C),
+ append_strings(C, StarPidStr, Command),
+ opium_write_debug(user, Command),
+ sh(Command).
+ % I should rather use exec(Command, []) here but for
+ % unknown reason, it does not remove the socket file.
+
+%------------------------------------------------------------------------------%
+%:- pred send_message_to_socket(atom).
+%:- mode send_message_to_socket(in) is det.
+ % low level primitive to send message to the Mercury process via a
+ % socket.
+
+send_message_to_socket(Query) :-
+ getval(state_of_opium, State),
+ (
+ State == running
+ ->
+ printf(newsock, "%w. \n%b", [Query]),
+ opium_printf_debug("SEND : +%w. +\n", [Query])
+ ;
+ State == not_running
+ ->
+ printf(stderr,"No program is running\n", [])
+ ;
+ % State == eot
+ write(stderr,"You are at the end of the trace.\n")
+ ).
+
+
+%------------------------------------------------------------------------------%
+%:- pred read_message_from_socket(atom).
+%:- mode read_message_from_socket(out) is det.
+ % low level primitive to read message from the Mercury process via a
+ % socket.
+read_message_from_socket(Message) :-
+ read(newsock, Message),
+ opium_printf_debug("RECEIVE : +%w+\n\n", Message).
+
+
+%------------------------------------------------------------------------------%
+opium_parameter(
+ name : mercury_opium_socket_address,
+ arg_list : [SocketAdress],
+ arg_type_list : [string],
+ parameter_type : single,
+ default : ["/tmp/"],
+ commands : [],
+ message :
+"Parameter which gives the directory that will be used to create the temporary \
+socket file in (file that is used for socket communication between the two \
+process)."
+ ).
+
+
+%------------------------------------------------------------------------------%
+opium_parameter(
+ name : debug_opium,
+ arg_list : [OnOff],
+ arg_type_list : [is_member([on, off])],
+ parameter_type : single,
+ default : [off],
+ commands : [opium_write_debug, opium_printf_debug],
+ message :
+'Prints additional information in the trace to debug Opium.'
+ ).
+
+
+%------------------------------------------------------------------------------%
+opium_procedure(
+ name : opium_write_debug,
+ arg_list : [X],
+ implementation : opium_write_debug_Op,
+ parameters : [debug_opium],
+ message :
+'This procedure is used to print information to debug Opium.'
+ ).
+
+opium_write_debug_Op(X) :-
+ (debug_opium(on) ->
+ write(X)
+ ;
+ true
+ ).
+
+
+opium_procedure(
+ name : opium_write_debug,
+ arg_list : [Stream, X],
+ implementation : opium_write_debug_Op,
+ parameters : [debug_opium],
+ message :
+'This procedure is used to print information to debug Opium.'
+ ).
+
+opium_write_debug_Op(Stream, X) :-
+ (debug_opium(on) ->
+ write(Stream, X)
+ ;
+ true
+ ),
+ flush(Stream).
+
+
+opium_procedure(
+ name : opium_printf_debug,
+ arg_list : [Format, X],
+ implementation : opium_printf_debug_Op,
+ parameters : [debug_opium],
+ message :
+'This procedure is used to print information to debug Opium.'
+ ).
+
+opium_printf_debug_Op(Format, X) :-
+ (debug_opium(on) ->
+ printf(Format, X)
+ ;
+ true
+ ).
+
+
+opium_procedure(
+ name : opium_printf_debug,
+ arg_list : [Stream, Format, X],
+ implementation : opium_printf_debug_Op,
+ parameters : [debug_opium],
+ message :
+'This procedure is used to print information to debug Opium.'
+ ).
+
+opium_printf_debug_Op(Stream, Format, X) :-
+ (debug_opium(on) ->
+ printf(Stream, Format, X)
+ ;
+ true
+ ).
+
+
+
Index: extras/opium_m/source/current_arg_M.op
===================================================================
RCS file: current_arg_M.op
diff -N current_arg_M.op
--- /dev/null Wed May 28 10:49:58 1997
+++ current_arg_M.op Tue Oct 26 23:26:29 1999
@@ -0,0 +1,453 @@
+%------------------------------------------------------------------------------%
+% Copyright (C) 1999 IRISA/INRIA.
+%
+% Author : Erwan Jahier <jahier at irisa.fr>
+%
+% This file implements all the predicates that deal with variables retrieval.
+
+
+
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : current_arg,
+ arg_list : [ArgumentList],
+ arg_type_list : [is_list_or_var],
+ abbrev : _,
+ implementation : current_arg_Op,
+ message :
+"Gets or checks the values of the currently live arguments of the current \
+event. It will unify non-live arguments with the atom '-'.\n\
+Example: if the first argument of the current procedure is 2, the second is \
+[4, 6] and the third is not live, current_arg(Arg) will unify Arg with the \
+list [2, [4, 6], -].\n\
+\n\
+If you do not want to retrieve an argument (because it is very big for \
+example), you can use the atom '-': for example, current_arg([X, -, -]) will \
+only retrieve the first argument."
+ ).
+
+current_arg_Op(Arg) :-
+ current(arity = Arity),
+ (
+ free(Arg),
+ current_vars(ListLiveArg, _),
+ generate_list_arg(0, Arity, ListLiveArg, Arg),
+ !
+ ;
+ is_list(Arg),
+ % for example if Arg = [-,-,X,-,Y,-], we retrieve the argument
+ % one by one (which is stupid if we have [X1, X2, X3] ...).
+ length(Arg, Length),
+ (
+ Arity == Length
+ ->
+ current_live_var_names_and_types_ll(ListVarNames, _),
+ retrieve_one_by_one(ListVarNames, 1, Arg)
+ ;
+ % for example if Arg = [X | _]
+ current_vars(ListLiveArg, _),
+ generate_list_arg(0, Arity, ListLiveArg, Arg),
+ !
+ )
+ ).
+
+
+retrieve_one_by_one(ListVarNames, N, [Arg | TailArg]) :-
+ (
+ Arg == '-',
+ !
+ ;
+ integer_to_headvar(N, HeadVar__N),
+ current_live_var(ListVarNames, HeadVar__N, RetrievedArg, _Type),
+ Arg = RetrievedArg
+ ),
+ N1 is N + 1,
+ retrieve_one_by_one(ListVarNames, N1, TailArg).
+
+retrieve_one_by_one(_, _, []).
+
+
+% :- type live_var --->
+% live_var(
+% string, % variable name
+% T, % Variable value
+% string % variable type
+% ).
+
+%:- pred generate_list_arg(int, int, list(live_var), list(T)).
+%:- mode generate_list_arg(in, in, out, out) is det.
+ % This predicate take a list of live_var and outputs the list of the
+ % current predicate arguments where non live arguments are replaced
+ % by '-'.
+ % Ex: generate_list_arg(0, 3, [live_var("HeadVar2", 4, int)], [-, 4, -]).
+generate_list_arg(Max, Max, _, []) :-
+ !.
+
+generate_list_arg(N, Max, ListVar, [NewVar | NewTail]) :-
+ NN is N + 1,
+ (
+ integer_to_headvar(NN, VarName),
+ member(live_var(VarName, Value, _Type), ListVar)
+ ->
+ NewVar = Value,
+ generate_list_arg(NN, Max, ListVar, NewTail)
+ ;
+ NewVar = '-',
+ generate_list_arg(NN, Max, ListVar, NewTail)
+ ).
+
+%:- pred headvar_to_integer(string, integer).
+%:- mode headvar_to_integer(in, out) is semidet.
+ % Internal name of arguments of the current predicate are of the form
+ % "HeadVar__i". This predicate converts it into an integer.
+ % Example: headvar_to_integer(HeadVar__3, 3).
+headvar_to_integer(HeadVar, Int) :-
+ append_strings("HeadVar__", IntStr, HeadVar),
+ number_string(Int, IntStr).
+
+integer_to_headvar(Int, HeadVar) :-
+ number_string(Int, IntStr),
+ append_strings("HeadVar__", IntStr, HeadVar).
+
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : current_arg_names,
+ arg_list : [ListArgNames],
+ arg_type_list : [is_list_or_var],
+ abbrev : _,
+ implementation : current_arg_names_Op,
+ message :
+"Gets or checks the list of the names of the current procedure arguments. \
+Unify non-live arguments with the atom '-'."
+ ).
+
+current_arg_names_Op(ListArgNames) :-
+ current_live_var_names_and_types(LVN),
+ current(arity = Arity),
+ generate_list_arg_names(0, Arity, LVN, ListArgNames).
+
+generate_list_arg_names(Max, Max, _, []) :-
+ !.
+
+generate_list_arg_names(N, Max, ListVar, [NewVarName | NewTail]) :-
+ NN is N + 1,
+ (
+ integer_to_headvar(NN, VarName),
+ member(live_var_names_and_types(VarName, _), ListVar)
+ ->
+ NewVarName = VarName,
+ generate_list_arg_names(NN, Max, ListVar, NewTail)
+ ;
+ NewVarName = '-',
+ generate_list_arg_names(NN, Max, ListVar, NewTail)
+ ).
+
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : current_arg_types,
+ arg_list : [ListArgTypes],
+ arg_type_list : [is_list_or_var],
+ abbrev : _,
+ implementation : current_arg_types_Op,
+ message :
+"Gets or checks the list of the arguments types of the current procedure. \
+Unify non-live arguments with the atom '-'"
+ ).
+
+current_arg_types_Op(ListArgTypes) :-
+ current_live_var_names_and_types(LVN),
+ current(arity = Arity),
+ generate_list_arg_types(0, Arity, LVN, ListArgTypes).
+
+generate_list_arg_types(Max, Max, _, []) :-
+ !.
+
+generate_list_arg_types(N, Max, ListVar, [NewVarType | NewTail]) :-
+ NN is N + 1,
+ (
+ integer_to_headvar(NN, VarName),
+ member(live_var_names_and_types(VarName, VarType), ListVar)
+ ->
+ NewVarType = VarType,
+ generate_list_arg_types(NN, Max, ListVar, NewTail)
+ ;
+ NewVarType = '-',
+ generate_list_arg_types(NN, Max, ListVar, NewTail)
+ ).
+
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : current_vars,
+ arg_list : [LiveArgList, OtherLiveVarList],
+ arg_type_list : [is_list_or_var, is_list_or_var],
+ abbrev : _,
+ implementation : current_vars_Op,
+ message :
+"Gets or checks the values of the currently live (*) variables of the \
+current event. These variables are separated in two lists: one containing the \
+live arguments of the current predicate, one containing other currently live \
+variables.\n\
+\n\
+(*) We say that a variable is live at a given point of the execution if it has \
+been instantiated and if the result of that instantiation is still available \
+(which is not the case for for destructively updated variables).\
+"
+ ).
+
+% :- pred current_vars(list(live_var), list(live_var)).
+% :- mode current_vars(out, out) is det.
+% :- mode current_vars(in, out) is semidet.
+% :- mode current_vars(out, in) is semidet.
+% :- mode current_vars(in ,in) is semidet.
+current_vars_Op(ListLiveArg, ListOtherLiveVar) :-
+ (
+ (
+ not(free(ListOtherLiveVar)),
+ ListOtherLiveVar = '-'
+ ;
+ not(free(ListOtherLiveVar)),
+ ListOtherLiveVar = '-'
+ )
+ % We retrieve the information about arguments only if it
+ % is needed.
+ ->
+ true
+ ;
+ current_vars2(ListLiveArgRetrieved, ListOtherLiveVarRetrieved),
+ ListLiveArg = ListLiveArgRetrieved,
+ ListOtherLiveVar = ListOtherLiveVarRetrieved
+ ).
+
+
+%:- pred current_vars2(list(live_var), list(live_var)).
+%:- mode current_vars2(out, out) is det.
+current_vars2(ListLiveArgRetrieved, ListOtherLiveVarRetrieved) :-
+ current_vars_ll(ListLiveVar, ListName),
+ % The Mercury side send us all the live variables so we separate
+ % here the live variables that are arguments of the current
+ % predicate (which internal name is of the form "HeadVar__i") from
+ % the other live variables.
+ separate_live_args_from_live_var(ListLiveVar, ListName,
+ ListArg, ListArgName, ListOtherVar , ListOtherVarName),
+ synthetise_list_univ_and_list_string(ListOtherVar, ListOtherVarName,
+ ListOtherLiveVarRetrieved),
+ synthetise_list_univ_and_list_string(ListArg, ListArgName,
+ ListLiveArgRetrieved).
+
+
+%:- pred separate_live_args_from_live_var(list(univ), list(string),
+% list(univ), list(string), list(univ), list(string) ).
+%:- mode separate_live_args_from_live_var(in, in, out, out, out, out) is det.
+ % Separates live arguments of the current predicate from other live
+ % variables.
+ % The list in input contains a list of 'univ(value - type)' that
+ % describes
+ % live variables and a list of string of their corresponding internal
+ % variable name. When the variable name begins with "HeadVar__", we put
+ % its corresponding variable in the first output; and we put them
+ % on the second output list otherwise.
+separate_live_args_from_live_var([], [], [], [], [], []).
+separate_live_args_from_live_var([Var | TailVar], [VarName | TailVarName],
+ ListArg, ListArgName, ListOtherVar , ListOtherVarName) :-
+ separate_live_args_from_live_var(TailVar, TailVarName,
+ TailListArg, TailListArgName,
+ TailListOtherVar, TailListOtherVarName),
+ ( append_strings("HeadVar__", _, VarName) ->
+ append([Var], TailListArg, ListArg),
+ append([VarName], TailListArgName, ListArgName),
+ ListOtherVar = TailListOtherVar,
+ ListOtherVarName = TailListOtherVarName
+ ;
+ ListArg = TailListArg,
+ ListArgName = TailListArgName,
+ append([Var], TailListOtherVar, ListOtherVar),
+ append([VarName], TailListOtherVarName, ListOtherVarName)
+ ).
+
+%:- pred synthetise_list_univ_and_list_string(list(univ), list(string),
+% list(live_var) ).
+%:- mode synthetise_list_univ_and_list_string(in, in, out) is det.
+ % Take a list of univ and a list of string of the same size and
+ % synthetize it into a list of live_var.
+
+synthetise_list_univ_and_list_string(L1, L2, Lout) :-
+ (
+ synthetise_list_univ_and_list_string2(L1, L2, Lout),
+ !
+ ;
+ write("\nSoftware error in opium-M: "),
+ write("synthetise_list_univ_and_list_string failed.\n"),
+ abort
+ ).
+
+synthetise_list_univ_and_list_string2(X, [Name | TailName], ListArgLive) :-
+ (
+ X = [univ(Arg:Type) | TailArg],
+ !
+ ;
+ X = [_| TailArg],
+ Arg = 'error',
+ Type = 'error',
+ write("***** Can't retrieve that type of argument. "),
+ write("This is a bug in Opium-M...\n")
+ ),
+ synthetise_list_univ_and_list_string2(TailArg, TailName, ListArgLeft),
+ ListArgLive = [live_var(Name, Arg, Type) | ListArgLeft].
+
+synthetise_list_univ_and_list_string2([], [], []).
+
+% :- pred current_vars_ll(list(univ), list(string)).
+% :- mode current_vars_ll(out, out) is det.
+ % Retrieve the list of currently live variables and the list of their
+ % internal name.
+current_vars_ll(ListLiveVar, ListName) :-
+ send_message_to_socket(current_vars),
+ read_message_from_socket(Response),
+ Response = current_vars(ListLiveVar, ListName).
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : current_live_var,
+ arg_list : [VarId, VarValue, VarType],
+ arg_type_list : [is_string_or_integer_or_var, is_term,
+ is_atom_or_var],
+ abbrev : clv,
+ interface : menu,
+ command_type : opium,
+ implementation : current_live_var_Op,
+ parameters : [],
+ message :
+'Gets or checks the name, the value and the type of the currently live \
+variables. VarId can be a string representing the variable name or, if it is \
+an argument of the current procedure, an integer representing the rank the \
+argument.\n\
+Example: \
+current_live_var("HeadVar__3", VarValue, _Type) (or equivalently \
+current_live_var(3, VarValue, _Type)) binds VarValue with the \
+current value of the third argument of the current predicate if it exists \
+and if it is live, fails otherwise. \
+You can get all the live variables by querying \
+current_live_var(VarId, VarValue, VarType) and typing \";\" at the prompt to \
+search for other solutions. \
+You can also get the list of all the currently live variables of type int \
+with the Opium-M query \
+setof((Name, Value), current_live_var(Name, Value, int), List).\
+'
+ ).
+
+
+% :- pred current_live_var(string_or_integer, atom).
+% :- mode current_live_var(in, out) is semidet.
+current_live_var_Op(VarId, VarValue, VarType) :-
+ ( integer(VarId) ->
+ integer_to_headvar(VarId, VarName)
+ ;
+ VarName = VarId
+ ),
+ current_live_var_names_and_types_ll(ListVarNames, _),
+ current_live_var(ListVarNames, VarName, VarValue, VarType).
+
+
+current_live_var(ListVarNames, VarNames, Value, Type) :-
+ member(VarNames, ListVarNames),
+ get_internal_number(VarNames, ListVarNames, InternalNumber),
+ current_nth_var_ll(InternalNumber, X),
+ X = univ(Value : Type).
+
+get_internal_number(VarNames, ListVarNames, InternalNumber) :-
+ % This predicate unifies InternalNumber with the rank of VarNames in
+ % ListVarNames - 1.
+ get_internal_number(1, VarNames, ListVarNames, InternalNumber).
+
+
+get_internal_number(N, VarNames, [VarNames | _], N) :- !.
+get_internal_number(N, VarNames, [_ | ListVarNames], InternalNumber) :-
+ NN is N + 1,
+ get_internal_number(NN, VarNames, ListVarNames, InternalNumber).
+
+% :- pred current_nth_var_ll(int, univ).
+% :- mode current_nth_var_ll(in, out) is det.
+current_nth_var_ll(VarInternalNumber, Var) :-
+ send_message_to_socket(current_nth_var(VarInternalNumber)),
+ read_message_from_socket(Response),
+ Response = current_nth_var(Var).
+
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : current_live_var_names_and_types,
+ arg_list : [ListVarNames],
+ arg_type_list : [is_list_or_var],
+ abbrev : _,
+ implementation : current_live_var_names_and_types_Op,
+ message :
+"Gets or checks the list of names and types of the currently live variables. \
+Each live variable is represented by the term \
+live_var_names_and_types(VariableName, TypeOfTheVariable).\
+"
+ ).
+
+
+% :- pred current_live_var_names_and_types(list(string)).
+% :- mode current_live_var_names_and_types(out) is det.
+current_live_var_names_and_types_Op(SynthetisedList) :-
+ current_live_var_names_and_types_ll(ListVarNames, ListType),
+ synthetise_var_names_list_and_type_list(ListVarNames, ListType,
+ SynthetisedList).
+
+
+% :- type live_var_names_and_types --->
+% live_var_names_and_types(
+% int, % internal variable representation
+% string, % Variable name
+% string % variable type
+% ).
+
+%:- pred synthetise_var_names_list_and_type_list(
+% list(string), list(string), list(live_var_names_and_types)).
+%:- mode synthetise_var_names_list_and_type_list(in, in, out) is det.
+ % Merge the list of variables names and their type.
+synthetise_var_names_list_and_type_list([], [], []).
+synthetise_var_names_list_and_type_list([Var | TailVar], [Type | TailType],
+ [Hout | Tout]) :-
+ Hout = live_var_names_and_types(Var, Type),
+ synthetise_var_names_list_and_type_list(TailVar, TailType, Tout).
+
+% :- pred current_live_var_names_and_types_ll(list(string), list(string)).
+% :- mode current_live_var_names_and_types_ll(out, out) is det.
+ % Outputs the list of the internal names of the currently live variables
+ % and a list of their corresponding types.
+current_live_var_names_and_types_ll(ListVarNames, ListType) :-
+ send_message_to_socket(current_live_var_names),
+ read_message_from_socket(Response),
+ Response = current_live_var_names(ListVarNames, ListType).
+
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : current_live_var_names_and_types,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : _,
+ implementation : current_live_var_names_and_types_Op,
+ message :
+"current_live_var_names_and_types/0 gets and displays the live variable names \
+and types. You can change this display by customizing the procedure \
+display_list_var_names.\
+"
+ ).
+
+current_live_var_names_and_types_Op :-
+ current_live_var_names_and_types(List),
+ write(user, "Current live variable names are: \n"),
+ display_list_var_names(List),
+ flush(user).
+
+
+%------------------------------------------------------------------------------%
+
--
R1.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list